1 files changed, 41 insertions, 13 deletions

diff --git a/axis.hs b/axis.hs
index 7513163..64217ea 100644
--- a/axis.hs
+++ b/axis.hs
@@ -1,5 +1,6 @@
+{-# LANGUAGE StandaloneDeriving #-}
 import FRP.Netwire hiding (when)
-import Prelude hiding ((.), id)
+import Prelude hiding ((.), id, null, filter)
 import Data.Time.Clock
 import Control.Wire hiding (when)
 import Control.Wire.Session
@@ -21,17 +22,44 @@ netwireIsCool =
         holdFor 0.5 . periodic 1 . pure "Hoo..." <|>
         pure "...ray!"
 
-main = SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $
+main =
   withAlsaInit $ \h public private q publicAddr privateAddr -> do
+  cmdlineAlsaConnect h public -- fail early if bad command lines
+
+  SDL.withInit [SDL.InitVideo, SDL.InitTimer, SDL.InitJoystick] $ do
+  info <- SDL.getVideoInfo
+  let width = SDL.videoInfoWidth info
+      height = SDL.videoInfoHeight info
+--screen <- SDL.setVideoMode width height 32 [SDL.SWSurface, SDL.Fullscreen]
+  screen <- SDL.setVideoMode width height 32 [SDL.SWSurface]
   putStrLn "Initialized."
-  loop clockSession_ netwireIsCool ""
-  where
-  loop s w x = do
-    (ds, s') <- stepSession s
-    (ex, w') <- stepWire w ds (Right x)
-    let x' = either (const "") id ex
-    Control.Monad.when (x /= x' && x' /= "") $ putStrLn x'
-    let framerate = 30
-    let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds)
-    SDL.delay (delay)
-    loop s' w' x'
+
+  let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr)
+  let loop midiKeysDown keysDown s w x = do
+        keysDown' <- parseSDLEvents keysDown
+        midiKeysDown' <- parseAlsa midiKeysDown
+        (ds, s') <- stepSession s
+        (ex, w') <- stepWire w ds (Right x)
+        let x' = either (const "") id ex
+        Control.Monad.when (x /= x' && x' /= "") $ putStrLn x'
+        let framerate = 30
+        let delay = 1000 `div` framerate - 1000 * (floor $ dtime ds)
+        SDL.delay (delay)
+        Control.Monad.when (not $ keyDown SDL.SDLK_ESCAPE keysDown) $
+          loop midiKeysDown' keysDown' s' w' x'
+
+  loop Set.empty Set.empty clockSession_ netwireIsCool ""
+
+parseSDLEvents :: Set.Set SDL.Keysym -> IO (Set.Set SDL.Keysym)
+parseSDLEvents keysDown = do
+  event <- SDL.pollEvent
+  case event of
+    SDL.NoEvent -> return keysDown
+    SDL.KeyDown k -> parseSDLEvents (Set.insert k keysDown)
+    SDL.KeyUp k -> parseSDLEvents (Set.delete k keysDown)
+    _ -> parseSDLEvents keysDown
+
+keyDown :: SDL.SDLKey -> Set.Set SDL.Keysym -> Bool
+keyDown k = not . Set.null . Set.filter ((== k) . SDL.symKey)
+
+deriving instance Ord SDL.Keysym