From 53ee5dfebc44c84c4a67581655686426eef51986 Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Wed, 15 Jan 2014 11:27:14 -0500
Subject: factor out new function: parseAlsaEvents

---
 midi-dump.hs | 46 +++++++++++++++++++++++++++-------------------
 1 file changed, 27 insertions(+), 19 deletions(-)

(limited to 'midi-dump.hs')

diff --git a/midi-dump.hs b/midi-dump.hs
index 50f0020..b94b178 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -21,6 +21,7 @@ import Control.Monad (when, forM_, forM)
 import qualified Data.Set as Set
 import Data.List (group, sort)
 import Haskore.Basic.Pitch
+import Control.Concurrent (threadDelay)
 
 joinWords [] = ""
 joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls
@@ -106,37 +107,44 @@ cmdlineAlsaConnect h public = do
 	IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
 	Exit.exitFailure
 
+parseAlsaEvents h keysDown immediate = loop keysDown
+  where
+    loop keysDown = do
+      pending <- Event.inputPending h True
+      if (pending == 0) then
+	return keysDown
+      else do
+	ev <- Event.input h
+	case Event.body ev of
+	   Event.NoteEv Event.NoteOn n  -> do
+	     immediate Event.NoteEv Event.NoteOn n
+	     loop (Set.insert (Event.noteNote n) keysDown)
+	   Event.NoteEv Event.NoteOff n -> do
+	     immediate Event.NoteEv Event.NoteOff n
+	     loop (Set.delete (Event.noteNote n) keysDown)
+	   _ -> loop keysDown
+
 main :: IO ()
 main = (do
 
   alsaInit $ \h public private q publicAddr privateAddr -> do
   cmdlineAlsaConnect h public
 
-  let wait keysDown = do
-      pending <- Event.inputPending h True
-      if (pending > 0)
-      then do
-	ev <- Event.input h
-	case Event.body ev of
-	   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
-      else
-	wait keysDown
-
   let mkEv e =
          (Event.simple publicAddr e) {
              Event.queue = q,
              Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0
          }
 
-  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 down
+  let
+    go keysDown = do
+      let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
+      keysDown' <- parseAlsaEvents h keysDown immediate
+      if (keysDown == keysDown') then
+	threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
+      else do
+	printWords $ pitchWords keysDown'
+      go keysDown'
 
   putStrLn "Rock on!"
   go Set.empty)
-- 
cgit v1.2.3