summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--midi-dump.hs19
1 files changed, 12 insertions, 7 deletions
diff --git a/midi-dump.hs b/midi-dump.hs
index 1a331e8..7d6d238 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -5,6 +5,8 @@ import qualified Data.Set as Set
5import qualified Haskore.Basic.Pitch as Pitch 5import qualified Haskore.Basic.Pitch as Pitch
6import qualified Sound.ALSA.Sequencer.Event as Event 6import qualified Sound.ALSA.Sequencer.Event as Event
7import Control.Monad.RWS.Strict 7import Control.Monad.RWS.Strict
8import Data.Maybe
9import Data.List
8 10
9main = main' `AlsaExc.catch` handler 11main = main' `AlsaExc.catch` handler
10 where 12 where
@@ -22,23 +24,26 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
22 24
23 putStrLn "Rock on!" 25 putStrLn "Rock on!"
24 26
25 (s, ()) <- execRWST loop (h, public, private, q, publicAddr, privateAddr) emptyLoopState 27 (_, ()) <- execRWST loop (h, public, private, q, publicAddr, privateAddr) emptyLoopState
26 return () 28 return ()
27 29
28loop = do 30loop = do
29 (h, public, private, q, publicAddr, privateAddr) <- ask 31 (h, _, _, q, publicAddr, _) <- ask
30 loopState <- get
31 oldKeys <- gets keysDown 32 oldKeys <- gets keysDown
32 let forwardNOW = forwardNoteEvent h q publicAddr 33 let forwardNOW = forwardNoteEvent h q publicAddr
33
34 (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW 34 (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW
35 35
36 if (oldKeys == newKeys) then 36 if (oldKeys == newKeys) then
37 liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%. 37 liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
38 else do 38 else do
39 let newHistory = if Set.null oldKeys then Nothing:newEvents else newEvents 39 let newEvents = map Just events
40 newEvents = map Just events 40
41 liftIO $ printChordLn newKeys 41 liftIO $ printChordLn newKeys
42 put loopState { keysDown = newKeys, inputHistory = newHistory ++ inputHistory loopState } 42 modify $ \s -> s { keysDown = newKeys, inputHistory = newEvents ++ inputHistory s }
43
44 when (Set.null newKeys) $ do
45 hist <- gets (takeWhile isJust . inputHistory)
46 liftIO $ print hist
47 modify $ \s -> s { inputHistory = Nothing:inputHistory s }
43 48
44 loop 49 loop