summaryrefslogtreecommitdiff
path: root/midi-dump.hs
diff options
context:
space:
mode:
Diffstat (limited to 'midi-dump.hs')
-rw-r--r--midi-dump.hs67
1 files changed, 37 insertions, 30 deletions
diff --git a/midi-dump.hs b/midi-dump.hs
index 5e0859b..0adef56 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -187,13 +187,28 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
187 187
188mainLoop :: MidiController () 188mainLoop :: MidiController ()
189mainLoop = do 189mainLoop = do
190 tick <- getAbsTime
191 modify $ \s -> s { _lastTick = tick }
192
190 maybeReadLine >>= maybe processMidi processCommand 193 maybeReadLine >>= maybe processMidi processCommand
191 wantExit <- gets _wantExit 194 wantExit <- gets _wantExit
192 metronome 195 metronome
193 playScheduled 196 playScheduled
197
194 if wantExit 198 if wantExit
195 then waitThreads 199 then waitThreads
196 else mainLoop 200 else delay >> mainLoop
201
202 where
203 tickDuration = 5000 -- 5ms
204 delay = do
205 before <- gets _lastTick
206 after <- getAbsTime
207 if after - before < fromIntegral (10^(6::Int) * tickDuration) then
208 liftIO $ threadDelay $ tickDuration - fromIntegral (nsec after - nsec before) `div` 1000
209 else
210 liftIO $ putStrLn "Uh oh! Dropped frame!"
211 mainLoop
197 212
198waitThreads :: MidiController () 213waitThreads :: MidiController ()
199waitThreads = gets _waitThreads >>= mapM_ liftIO 214waitThreads = gets _waitThreads >>= mapM_ liftIO
@@ -375,43 +390,35 @@ getMidiSender = do
375 390
376processMidi :: MidiController () 391processMidi :: MidiController ()
377processMidi = do 392processMidi = do
378 h <- asks _h 393 h <- asks _h
379 oldKeys <- gets _keysDown 394 oldKeys <- gets _keysDown
380 forwardNOW <- getMidiSender 395 forwardNOW <- getMidiSender
381 (events, newKeys) <- liftIO $ parseAlsaEvents'' h oldKeys forwardNOW 396 (events, newKeys) <- liftIO $ parseAlsaEvents'' h oldKeys forwardNOW
382 397
398 when (oldKeys /= newKeys) $ do
399 now <- gets _lastTick
400 let newEvents = map ((,) now . Event.body) events
383 401
384 if oldKeys == newKeys 402 modify $ \s -> s { _keysDown = newKeys, _recording = recordEvents (_recording s) newEvents }
385 then liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
386 else do
387 now <- getAbsTime
388 let newEvents = map ((,) now . Event.body) events
389
390 modify $ \s ->
391 s
392 { _keysDown = newKeys
393 , _recording = recordEvents (_recording s) newEvents
394 , _lastTick = now
395 }
396 403
397 whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys 404 whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys
398 405
399 filterTriads newKeys 406 filterTriads newKeys
400 407
401 -- Whenever no keys are pressed, flush any buffered events to the database 408 -- Whenever no keys are pressed, flush any buffered events to the database
402 when (Map.null newKeys) $ do 409 when (Map.null newKeys) $ do
403 doSave <- asks _doSave 410 doSave <- asks _doSave
404 when doSave $ gets _recording >>= saveMidi >> return () 411 when doSave $ gets _recording >>= saveMidi >> return ()
405 modify $ \s -> s { _recording = StartRecording now } 412 modify $ \s -> s { _recording = StartRecording now }
406 413
407 -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys 414 -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys
408 when (Map.null oldKeys) $ do 415 when (Map.null oldKeys) $ do
409 replay <- gets _replay 416 replay <- gets _replay
410 when (latestEvent replay < (now - TimeSpec 3 0)) $ do 417 when (latestEvent replay < (now - TimeSpec 3 0)) $ do
411 modify $ \s -> s { _replay = StartRecording now } 418 modify $ \s -> s { _replay = StartRecording now }
412 return () 419 return ()
413 420
414 modify $ \s -> s { _replay = recordEvents (_replay s) newEvents } 421 modify $ \s -> s { _replay = recordEvents (_replay s) newEvents }
415 422
416filterTriads :: MidiPitchMap -> MidiController () 423filterTriads :: MidiPitchMap -> MidiController ()
417filterTriads newKeys = do 424filterTriads newKeys = do