axis.hs: start to move mainloop into RWST

2 files changed, 107 insertions, 88 deletions

diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal
index da7a2a8..852d040 100644
--- a/axis-of-eval.cabal
+++ b/axis-of-eval.cabal
@@ -18,9 +18,10 @@ executable axis
   default-language: Haskell2010
   hs-source-dirs: .
   build-depends:
-    base, time, SDL, SDL-ttf, SDL-gfx, containers, haskore, alsa-seq, alsa-core, base-prelude
+    base, time, SDL, SDL-ttf, SDL-gfx, containers, haskore, alsa-seq, alsa-core, base-prelude, mtl
   main-is: axis.hs
-  other-modules: AlsaSeq
+  ghc-options: -threaded -W -Wall -O2
+  other-modules: AlsaSeq, AlsaShutUp
 
 executable rtq
   default-language: Haskell2010
@@ -39,5 +40,5 @@ executable midi-dump
     sqlite-simple, bytestring, base-prelude, midi-alsa, midi, psqueues,
     transformers, semigroups, HCodecs, threads
   main-is: midi-dump.hs
-  other-modules: AlsaSeq, Midi, RealTimeQueue
+  other-modules: AlsaSeq, Midi, RealTimeQueue, AlsaShutUp
   ghc-options: -threaded -W -Wall -O2 -rtsopts
diff --git a/axis.hs b/axis.hs
index b093414..cdbcc7c 100644
--- a/axis.hs
+++ b/axis.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
 import Prelude ()
 import BasePrelude
 import Data.Time.Clock
@@ -18,6 +19,11 @@ import Data.Bits
 import qualified Sound.ALSA.Sequencer.Event as Event
 import qualified Graphics.UI.SDL.Utilities as SDL.Util
 import qualified Data.Map as Map
+import Control.Monad.RWS.Strict
+
+import qualified Sound.ALSA.Sequencer
+import qualified Sound.ALSA.Sequencer.Queue
+import qualified Sound.ALSA.Sequencer.Address
 
 smartShowPitch = showPitch -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars
 
@@ -188,6 +194,12 @@ firstDigitDown :: Set.Set SDL.Keysym.SDLKey -> Maybe Integer
 firstDigitDown k = if Set.null digitsDown then Nothing else Just $ (-48 +) $ fromIntegral $ SDL.Util.fromEnum $ Set.findMin digitsDown
   where digitsDown = Set.intersection _SDL_DIGITS k
 
+data Env = Env
+                (Sound.ALSA.Sequencer.T Sound.ALSA.Sequencer.DuplexMode)
+                Sound.ALSA.Sequencer.Queue.T
+                Sound.ALSA.Sequencer.Address.T
+                (Int -> Int -> IO SDL.Surface)
+
 main =
   withAlsaInit $ \h public private q publicAddr privateAddr -> do
     cmdlineAlsaConnect h public -- fail early if bad command lines
@@ -211,91 +223,97 @@ main =
       -- SDL.createRGBSurfaceEndian [] 1 1 24
       putStrLn "Initialized."
 
-      let parseAlsa keysDown = parseAlsaEvents h keysDown (forwardNoteEvent h q publicAddr)
-      let loop state midiKeysDown keysDown resolution font = do
-            let LoopState firstLoop colsRepeat = state
-
-            (keysDown', resolution') <- parseSDLEvents keysDown resolution
-            midiKeysDown' <- parseAlsa midiKeysDown
-            let colsRepeat' =
-                  case firstDigitDown keysDown' of
-                    Nothing  -> colsRepeat
-                    (Just 0) -> colsRepeat
-                    (Just n) -> n
-
-            let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat
-
-            when restartVideo $ do
-              let (w, h) = resolution'
-              _ <- setVideoMode w h
-              return ()
-
-            let (w, h) = resolution'
-                fontSize = chooseFontSize w h
-            font' <- if restartVideo
-                       then SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize
-                       else return font
-
-            videoSurface <- SDL.getVideoSurface
-            videoClipRect <- SDL.getClipRect videoSurface
-            let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat' videoClipRect
-
-            let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p)) [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH]
-                keysOFF really = allKeysOff colsRepeat' really videoSurface font' axis_key_locations axis_key_size
-                allKeysOFF = keysOFF False
-                allKeysReallyOFF = keysOFF True
-
-            when firstLoop allKeysOFF
-
-            --      when (x /= x' && x' /= "") $ do
-            --        textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
-            --        return ()
-            let chanfilter = Set.filter (\(c, _) -> c /= Event.Channel 9)
-                beforeKeys = chanfilter midiKeysDown
-                nowKeys = chanfilter midiKeysDown'
-
-                changedPitches = Set.map snd $ Set.union (Set.difference nowKeys beforeKeys) (Set.difference beforeKeys nowKeys)
-                playingNowChans n = Set.map fst $ Set.filter (\(_, p) -> p == n) nowKeys
-                actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches
-                chanPitches = Map.fromListWith (++) $ map (\(c, p) -> (c, [p])) $ Set.toList nowKeys
-
-            when (midiKeysDown' /= midiKeysDown) $ do
-              --        let chord = showChord midiKeysDown'
-              --        let chord = show $ pitchList midiKeysDown'
-              --        let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown'
-              --        textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
-              smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size
-
-            when restartVideo $ do
-              allKeysOFF
-              smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size
-
-            when (keysDown' /= keysDown) $ do
-              when (keyDown SDL.SDLK_BACKSPACE keysDown') allKeysOFF
-              when (keyDown SDL.SDLK_c keysDown') allKeysReallyOFF
-
-              --    Control.Monad.when (keysDown' /= keysDown) $ do
-              --      let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown'
-              --      textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
-              --      textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
-              --        if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""
-              --      return ()
-              --    Control.Monad.when(False) $ do
-              --
-              --      mouse <- SDL.getRelativeMouseState
-              --      let (x, y, button) = mouse
-              --      let text = ((show x) ++ " " ++ (show y) ++ " " ++ (show button))
-              --      textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text
-              --      Control.Monad.when (x /= 0 || y /= 0) warpMouse
-
-            _ <- SDL.flip videoSurface
-            let framerate = 30
-            let delay = 1000 `div` framerate -- TODO: subtract delta
-            SDL.delay delay
-            unless (keyDown SDL.SDLK_ESCAPE keysDown) $
-              loop (LoopState False colsRepeat') midiKeysDown' keysDown' resolution' font'
-
-      loop (LoopState True _AXIS_COLS_REPEAT) Set.empty Set.empty (sWidth, sHeight) font
+      (_, ()) <- execRWST
+                    (mainLoop Set.empty Set.empty (sWidth, sHeight) font)
+                    (Env h q publicAddr setVideoMode) (LoopState True _AXIS_COLS_REPEAT)
+      return ()
+
+mainLoop :: (MonadIO f, MonadState LoopState f, MonadReader Env f)
+         => Set.Set (Event.Channel, Event.Pitch) -> Set.Set SDLKey -> (Int, Int) -> SDL.TTF.Font -> f ()
+mainLoop midiKeysDown keysDown resolution font = do
+    Env h q publicAddr setVideoMode <- ask
+    LoopState firstLoop colsRepeat <- get
+
+    (keysDown', resolution') <- liftIO $ parseSDLEvents keysDown resolution
+    midiKeysDown' <- liftIO $ parseAlsaEvents h midiKeysDown (forwardNoteEvent h q publicAddr)
+    let colsRepeat' =
+            case firstDigitDown keysDown' of
+            Nothing  -> colsRepeat
+            (Just 0) -> colsRepeat
+            (Just n) -> n
+
+    let restartVideo = resolution' /= resolution || colsRepeat' /= colsRepeat
+
+    when restartVideo $ do
+        let (w, h) = resolution'
+        void $ liftIO $ setVideoMode w h
+
+    let (w, h) = resolution'
+        fontSize = chooseFontSize w h
+    font' <- if restartVideo
+                then liftIO $ SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize
+                else return font
+
+    videoSurface <- liftIO SDL.getVideoSurface
+    videoClipRect <- liftIO $ SDL.getClipRect videoSurface
+    let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat' videoClipRect
+
+    let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p))
+                                        [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH]
+        keysOFF really = allKeysOff colsRepeat' really videoSurface font' axis_key_locations axis_key_size
+        allKeysOFF = keysOFF False
+        allKeysReallyOFF = keysOFF True
+
+    when firstLoop $ liftIO allKeysOFF
+
+    --      when (x /= x' && x' /= "") $ do
+    --        textBand videoSurface videoClipRect (SDL.Rect 0 0 0 70) font x'
+    --        return ()
+    let chanfilter = Set.filter (\(c, _) -> c /= Event.Channel 9)
+        beforeKeys = chanfilter midiKeysDown
+        nowKeys = chanfilter midiKeysDown'
+
+        changedPitches = Set.map snd $ Set.union (Set.difference nowKeys beforeKeys)
+                                        (Set.difference beforeKeys nowKeys)
+        playingNowChans n = Set.map fst $ Set.filter (\(_, p) -> p == n) nowKeys
+        actions = Set.toList $ Set.map (\p -> (p, Set.toList $ playingNowChans p)) changedPitches
+        chanPitches = Map.fromListWith (++) $ map (\(c, p) -> (c, [p])) $ Set.toList nowKeys
+
+    when (midiKeysDown' /= midiKeysDown) $ do
+        --        let chord = showChord midiKeysDown'
+        --        let chord = show $ pitchList midiKeysDown'
+        --        let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown'
+        --        textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
+        liftIO $ smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size
+
+    when restartVideo $ do
+        liftIO allKeysOFF
+        liftIO $ smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size
+
+    when (keysDown' /= keysDown) $ do
+        when (keyDown SDL.SDLK_BACKSPACE keysDown') $ liftIO allKeysOFF
+        when (keyDown SDL.SDLK_c keysDown') $ liftIO allKeysReallyOFF
+
+    --    Control.Monad.when (keysDown' /= keysDown) $ do
+    --      let chord = unwords $ map (\k -> drop 5 (show k)) $ Set.toList keysDown'
+    --      textBand videoSurface videoClipRect (SDL.Rect 0 210 0 70) font chord
+    --      textBand videoSurface videoClipRect (SDL.Rect 0 280 0 70) font $
+    --        if keyDown SDL.SDLK_a keysDown' then "arpeggiate" else ""
+    --      return ()
+    --    Control.Monad.when(False) $ do
+    --
+    --      mouse <- SDL.getRelativeMouseState
+    --      let (x, y, button) = mouse
+    --      let text = ((show x) ++ " " ++ (show y) ++ " " ++ (show button))
+    --      textBand videoSurface videoClipRect (SDL.Rect 0 140 0 70) font text
+    --      Control.Monad.when (x /= 0 || y /= 0) warpMouse
+    void $ liftIO $ SDL.flip videoSurface
+    let framerate = 30
+    let delay = 1000 `div` framerate -- TODO: subtract delta
+    liftIO $ SDL.delay delay
+    unless (keyDown SDL.SDLK_ESCAPE keysDown) $ do
+        put (LoopState False colsRepeat')
+        mainLoop  midiKeysDown' keysDown' resolution' font'
 
 zipzip ls = if null (head ls) then [] else map head ls : zipzip (map tail ls)