store midi event history in a simple list

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 @@
 {-# LANGUAGE NondecreasingIndentation #-}
-module AlsaSeq (withAlsaInit, parseAlsaEvents, forwardNoteEvent,
+module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', forwardNoteEvent,
 cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch,
-unPitch, unChannel, MidiHook) where
+unPitch, unChannel, MidiHook, MidiPitchSet) where
 import qualified Sound.ALSA.Exception as AlsaExc
 import qualified Sound.ALSA.Sequencer.Address as Addr
 import qualified Sound.ALSA.Sequencer as SndSeq
@@ -143,6 +143,9 @@ inputPendingLoop h b = do
         (AlsaExc.Cons location _ code) -> AlsaExc.throw location code
     (Right result) -> return result
 
+type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch)
+parseAlsaEvents :: SndSeq.AllowInput mode =>
+  SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet
 parseAlsaEvents h keysDown immediate = loop keysDown
   where
     loop keysDown = do
@@ -162,6 +165,25 @@ parseAlsaEvents h keysDown immediate = loop keysDown
              loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
            _ -> loop keysDown
 
+parseAlsaEvents' h keysDown immediate = loop [] keysDown
+  where
+    loop events keysDown = do
+      pending <- inputPendingLoop h True
+      if (pending == 0) then
+        return (events, keysDown)
+      else do
+        ev <- Event.input h
+        immediate ev
+        case Event.body ev of
+           Event.NoteEv Event.NoteOn n ->
+             if (Event.unVelocity (Event.noteVelocity n) == 0) then
+               loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
+             else
+               loop (ev:events) (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown)
+           Event.NoteEv Event.NoteOff n ->
+             loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
+           _ -> loop (ev:events) keysDown
+
 type MidiHook = Event.T -> IO ()
 
 forwardNoteEvent :: 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
     return ()
   return ()
 
---parseSDLEvents :: Set.Set SDL.SDLKey -> Set.Set SDL.Event -> IO (Set.Set SDL.Keysym.SDLKey, Set.Set SDL.Event)
+parseSDLEvents :: Set.Set SDLKey -> (Int, Int) -> IO (Set.Set SDLKey, (Int, Int))
 parseSDLEvents keysDown others = do
   event <- SDL.pollEvent
   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
 import Control.Concurrent (threadDelay)
 import qualified Sound.ALSA.Exception as AlsaExc
 import qualified Data.Set as Set
+import qualified Haskore.Basic.Pitch as Pitch
+import qualified Sound.ALSA.Sequencer.Event as Event
 
 main = main' `AlsaExc.catch` handler
   where
   handler e = putStrLn $ "alsa_exception: " ++ AlsaExc.show e
 
+data State = State {
+  keysDown :: MidiPitchSet,
+  inputHistory :: [Maybe Event.T]
+}
+
 main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
   cmdlineAlsaConnect h public
 
   let
     forwardNOW = forwardNoteEvent h q publicAddr
-    go keysDown = do
-      keysDown' <- parseAlsaEvents h keysDown (\ev -> do forwardNOW ev; hook ev)
-      if (keysDown == keysDown') then
+    go state = do
+      (events, keysDown') <- parseAlsaEvents' h (keysDown state) forwardNOW
+      if ((keysDown state) == keysDown') then
         threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
       else do
+        let newHistory = if (Set.null $ keysDown state) then Nothing:newEvents else newEvents
+            newEvents = map Just events
         printChordLn keysDown'
-      go keysDown'
+        go (state { keysDown = keysDown', inputHistory = newHistory ++ inputHistory state })
 
   putStrLn "Rock on!"
-  go Set.empty
-
-hook :: MidiHook
-hook ev = return ()
+  go (State Set.empty [])