diff options
Diffstat (limited to 'midi-dump.hs')
-rw-r--r-- | midi-dump.hs | 67 |
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 | ||
188 | mainLoop :: MidiController () | 188 | mainLoop :: MidiController () |
189 | mainLoop = do | 189 | mainLoop = 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 | ||
198 | waitThreads :: MidiController () | 213 | waitThreads :: MidiController () |
199 | waitThreads = gets _waitThreads >>= mapM_ liftIO | 214 | waitThreads = gets _waitThreads >>= mapM_ liftIO |
@@ -375,43 +390,35 @@ getMidiSender = do | |||
375 | 390 | ||
376 | processMidi :: MidiController () | 391 | processMidi :: MidiController () |
377 | processMidi = do | 392 | processMidi = 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 | ||
416 | filterTriads :: MidiPitchMap -> MidiController () | 423 | filterTriads :: MidiPitchMap -> MidiController () |
417 | filterTriads newKeys = do | 424 | filterTriads newKeys = do |