summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--AlsaSeq.hs26
-rw-r--r--axis.hs2
-rw-r--r--midi-dump.hs22
3 files changed, 39 insertions, 11 deletions
diff --git a/AlsaSeq.hs b/AlsaSeq.hs
index 1c53b18..e8321af 100644
--- a/AlsaSeq.hs
+++ b/AlsaSeq.hs
@@ -1,7 +1,7 @@
1{-# LANGUAGE NondecreasingIndentation #-} 1{-# LANGUAGE NondecreasingIndentation #-}
2module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent, 2module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', forwardNoteEvent,
3cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch, 3cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch,
4unPitch, unChannel, MidiHook) where 4unPitch, unChannel, MidiHook, MidiPitchSet) where
5import qualified Sound.ALSA.Exception as AlsaExc 5import qualified Sound.ALSA.Exception as AlsaExc
6import qualified Sound.ALSA.Sequencer.Address as Addr 6import qualified Sound.ALSA.Sequencer.Address as Addr
7import qualified Sound.ALSA.Sequencer as SndSeq 7import qualified Sound.ALSA.Sequencer as SndSeq
@@ -143,6 +143,9 @@ inputPendingLoop h b = do
143 (AlsaExc.Cons location _ code) -> AlsaExc.throw location code 143 (AlsaExc.Cons location _ code) -> AlsaExc.throw location code
144 (Right result) -> return result 144 (Right result) -> return result
145 145
146type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch)
147parseAlsaEvents :: SndSeq.AllowInput mode =>
148 SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet
146parseAlsaEvents h keysDown immediate = loop keysDown 149parseAlsaEvents h keysDown immediate = loop keysDown
147 where 150 where
148 loop keysDown = do 151 loop keysDown = do
@@ -162,6 +165,25 @@ parseAlsaEvents h keysDown immediate = loop keysDown
162 loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) 165 loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
163 _ -> loop keysDown 166 _ -> loop keysDown
164 167
168parseAlsaEvents' h keysDown immediate = loop [] keysDown
169 where
170 loop events keysDown = do
171 pending <- inputPendingLoop h True
172 if (pending == 0) then
173 return (events, keysDown)
174 else do
175 ev <- Event.input h
176 immediate ev
177 case Event.body ev of
178 Event.NoteEv Event.NoteOn n ->
179 if (Event.unVelocity (Event.noteVelocity n) == 0) then
180 loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
181 else
182 loop (ev:events) (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown)
183 Event.NoteEv Event.NoteOff n ->
184 loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
185 _ -> loop (ev:events) keysDown
186
165type MidiHook = Event.T -> IO () 187type MidiHook = Event.T -> IO ()
166 188
167forwardNoteEvent :: SndSeq.AllowOutput mode => SndSeq.T mode -> Queue.T -> Addr.T -> MidiHook 189forwardNoteEvent :: SndSeq.AllowOutput mode => SndSeq.T mode -> Queue.T -> Addr.T -> MidiHook
diff --git a/axis.hs b/axis.hs
index ba4ccdc..c784865 100644
--- a/axis.hs
+++ b/axis.hs
@@ -396,7 +396,7 @@ textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do
396 return () 396 return ()
397 return () 397 return ()
398 398
399--parseSDLEvents :: Set.Set SDL.SDLKey -> Set.Set SDL.Event -> IO (Set.Set SDL.Keysym.SDLKey, Set.Set SDL.Event) 399parseSDLEvents :: Set.Set SDLKey -> (Int, Int) -> IO (Set.Set SDLKey, (Int, Int))
400parseSDLEvents keysDown others = do 400parseSDLEvents keysDown others = do
401 event <- SDL.pollEvent 401 event <- SDL.pollEvent
402 case event of 402 case event of
diff --git a/midi-dump.hs b/midi-dump.hs
index 0f714ed..a5a3d9c 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -2,26 +2,32 @@ import AlsaSeq
2import Control.Concurrent (threadDelay) 2import Control.Concurrent (threadDelay)
3import qualified Sound.ALSA.Exception as AlsaExc 3import qualified Sound.ALSA.Exception as AlsaExc
4import qualified Data.Set as Set 4import qualified Data.Set as Set
5import qualified Haskore.Basic.Pitch as Pitch
6import qualified Sound.ALSA.Sequencer.Event as Event
5 7
6main = main' `AlsaExc.catch` handler 8main = main' `AlsaExc.catch` handler
7 where 9 where
8 handler e = putStrLn $ "alsa_exception: " ++ AlsaExc.show e 10 handler e = putStrLn $ "alsa_exception: " ++ AlsaExc.show e
9 11
12data State = State {
13 keysDown :: MidiPitchSet,
14 inputHistory :: [Maybe Event.T]
15}
16
10main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do 17main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
11 cmdlineAlsaConnect h public 18 cmdlineAlsaConnect h public
12 19
13 let 20 let
14 forwardNOW = forwardNoteEvent h q publicAddr 21 forwardNOW = forwardNoteEvent h q publicAddr
15 go keysDown = do 22 go state = do
16 keysDown' <- parseAlsaEvents h keysDown (\ev -> do forwardNOW ev; hook ev) 23 (events, keysDown') <- parseAlsaEvents' h (keysDown state) forwardNOW
17 if (keysDown == keysDown') then 24 if ((keysDown state) == keysDown') then
18 threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%. 25 threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
19 else do 26 else do
27 let newHistory = if (Set.null $ keysDown state) then Nothing:newEvents else newEvents
28 newEvents = map Just events
20 printChordLn keysDown' 29 printChordLn keysDown'
21 go keysDown' 30 go (state { keysDown = keysDown', inputHistory = newHistory ++ inputHistory state })
22 31
23 putStrLn "Rock on!" 32 putStrLn "Rock on!"
24 go Set.empty 33 go (State Set.empty [])
25
26hook :: MidiHook
27hook ev = return ()