output the set of midi pitches being played

1 files changed, 40 insertions, 23 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 2534fd4..d0bde4e 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -1,6 +1,3 @@
-import Control.Monad (forever, )
-import Control.Monad (mplus, )
-import Data.Maybe.HT (toMaybe, )
 import qualified Sound.ALSA.Exception as AlsaExc
 import qualified Sound.ALSA.Sequencer.Address as Addr
 import qualified Sound.ALSA.Sequencer as SndSeq
@@ -16,14 +13,27 @@ import qualified Sound.ALSA.Sequencer.Time as Time
 import qualified System.Exit as Exit
 import qualified System.IO as IO
 import System.Environment (getArgs, )
+import Text.Printf
 
-main :: IO ()
-main = (do
+import qualified Data.Set as Set
+
+printWords [] = return ()
+printWords ls = putStrLn $ foldr1 (\a b -> a ++ " " ++ b) ls
+
+pitchWords set = map (show . Event.unPitch) $ Set.toList set
+
+prettyNote :: Event.Note -> String
+prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) =
+    let pitch = Event.unPitch noteNote
+        vlcty = Event.unVelocity noteVelocity
+    in
+      printf "%d (%d)" pitch vlcty
+
+alsaInit k = do
   SndSeq.withDefault SndSeq.Block $ \h -> do
   Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell-Beat"
   Port.withSimple h "inout"
-     (Port.caps [Port.capRead, Port.capSubsRead,
-                 Port.capWrite, Port.capSubsWrite])
+     (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite])
      (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do
   Port.withSimple h "private"
      (Port.caps [Port.capRead, Port.capWrite])
@@ -39,25 +49,31 @@ main = (do
   let publicAddr  = Addr.Cons c public
       privateAddr = Addr.Cons c private
 
+  k h public private q publicAddr privateAddr
+
+main :: IO ()
+main = (do
+
+  alsaInit $ \h public private q publicAddr privateAddr -> do
+
   args <- getArgs
   case args of
-     [input, output] ->
+
+     [input, output] -> do
         (Connect.createFrom h public =<< Addr.parse h input)
-        >>
         (Connect.createTo   h public =<< Addr.parse h output)
-        >>
         return ()
-     _ ->
+
+     _ -> do
        IO.hPutStrLn IO.stderr "need arguments: input-client output-client"
-       >>
        Exit.exitFailure
 
-  let wait = do
+  let wait keysDown = do
       ev <- Event.input h
       case Event.body ev of
-         Event.NoteEv Event.NoteOn n  -> return (Event.NoteOn, n)
-         Event.NoteEv Event.NoteOff n -> return (Event.NoteOff, n)
-         _ -> wait
+         Event.NoteEv Event.NoteOn n  -> return (Event.NoteOn,  n, Set.insert (Event.noteNote n) keysDown)
+         Event.NoteEv Event.NoteOff n -> return (Event.NoteOff, n, Set.delete (Event.noteNote n) keysDown)
+         _ -> wait keysDown
 
   Queue.control h q Event.QueueStart Nothing
 
@@ -67,13 +83,14 @@ main = (do
              Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0
          }
 
-  let go = do
-      (onoff, note) <- wait
-      print note
+  let go keysDown = do
+      (onoff, note, down) <- wait keysDown
+      --putStrLn $ prettyNote note
+      printWords $ pitchWords down
       Event.output h $ mkEv $ Event.NoteEv onoff note
       _ <- Event.drainOutput h
-      go
+      go down
 
-  go)
-   `AlsaExc.catch` \e ->
-     putStrLn $ "alsa_exception: " ++ AlsaExc.show e
+  go Set.empty)
+     `AlsaExc.catch` \e ->
+       putStrLn $ "alsa_exception: " ++ AlsaExc.show e