1 files changed, 26 insertions, 4 deletions

diff --git a/AlsaSeq.hs b/AlsaSeq.hs
index 5b65967..0512c80 100644
--- a/AlsaSeq.hs
+++ b/AlsaSeq.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE NondecreasingIndentation #-}
-module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', forwardNoteEvent,
-cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch,
-unPitch, unChannel, MidiHook, MidiPitchSet) where
+module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', parseAlsaEvents'', forwardNoteEvent,
+cmdlineAlsaConnect, printChordLn, printChordLn', showChord, pitchList, showPitch,
+unPitch, unChannel, MidiHook, MidiPitchSet, MidiPitchMap) where
 import qualified Sound.ALSA.Exception as AlsaExc
 import qualified Sound.ALSA.Sequencer.Address as Addr
 import qualified Sound.ALSA.Sequencer as SndSeq
@@ -23,6 +23,7 @@ import Text.Printf
 import Control.Monad (when, forM_, forM)
 
 import qualified Data.Set as Set
+import qualified Data.Map.Strict as Map
 import Data.List (group, sort)
 import Haskore.Basic.Pitch
 import Foreign.C.Error (Errno(Errno))
@@ -32,6 +33,7 @@ unPitch = Event.unPitch
 unChannel = Event.unChannel
 
 printChordLn set = printWords $ pitchWords set
+printChordLn' = printWords . map (showPitch . Event.unPitch . snd) . Map.keys
 
 joinWords [] = ""
 joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls
@@ -41,7 +43,7 @@ printWords ls = putStrLn $ joinWords ls
 
 showChord ls = joinWords $ pitchWords ls
 
-showPitch x = 
+showPitch x =
   let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
   in Haskore.Basic.Pitch.classFormat pitch (show octave)
 
@@ -145,6 +147,7 @@ inputPendingLoop h b = do
     (Right result) -> return result
 
 type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch)
+type MidiPitchMap = Map.Map (Event.Channel, Event.Pitch) Event.Velocity
 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
@@ -185,6 +188,25 @@ parseAlsaEvents' h keysDown immediate = loop [] keysDown
              loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
            _ -> loop (ev:events) 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) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown)
+             else
+               loop (ev:events) (Map.insert (Event.noteChannel n, Event.noteNote n) (Event.noteVelocity n) keysDown)
+           Event.NoteEv Event.NoteOff n ->
+             loop (ev:events) (Map.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