From 9a065c35ecdf3cc78d08d4b785762d7c5cc51466 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Thu, 17 Dec 2015 18:06:40 -0500 Subject: axis.hs: start to move mainloop into RWST --- axis-of-eval.cabal | 7 +- axis.hs | 188 +++++++++++++++++++++++++++++------------------------ 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) -- cgit v1.2.3