midimory 0.0.2 → 0.0.2.1
raw patch · 4 files changed
+155/−129 lines, 4 files
Files
- midimory.cabal +4/−2
- src/GUI.hs +66/−0
- src/Main.hs +70/−85
- src/Reactive.hs +15/−42
midimory.cabal view
@@ -1,5 +1,5 @@ Name: midimory-Version: 0.0.2+Version: 0.0.2.1 Maintainer: Henning Thielemann <alsa@henning-thielemann.de> Author: Henning Thielemann <alsa@henning-thielemann.de> Category: Sound, Music, Game, GUI@@ -42,7 +42,7 @@ Source-Repository this type: darcs- tag: 0.0.2+ tag: 0.0.2.1 location: http://code.haskell.org/~thielema/midimory/ Flag reactive@@ -52,6 +52,7 @@ Executable midimory Main-Is: Main.hs Other-Modules:+ GUI Game Configuration MIDI@@ -74,6 +75,7 @@ Executable midimory-reactive Main-Is: Reactive.hs Other-Modules:+ GUI Game Configuration MIDI
+ src/GUI.hs view
@@ -0,0 +1,66 @@+module GUI where++import qualified Game+import qualified Configuration as Config++import qualified Graphics.UI.WX as WX+import Graphics.UI.WX+ (Prop((:=)), text, command, on,+ close, container, widget,+ layout, margin, row, column, )++import Control.Monad (forM)+++data T =+ Cons {+ frame :: WX.Frame (),+ panel :: WX.Panel (),+ message :: WX.StaticText (),+ scoreA, scoreB :: WX.Gauge (),+ matrix :: [[((Int,Int), WX.Button ())]],+ restart :: WX.Button (),+ maxScore :: Int+ }+++create :: Config.T -> IO T+create cfg = do+ f <- WX.frame [text := "Midimory"]+ p <- WX.panel f []+ message_ <-+ WX.staticText p [ text := Game.makeMessage Game.PlayerA Game.First ]+ let maxScore_ = div (Config.rows cfg * Config.columns cfg) 2+ scoreA_ <- WX.vgauge p maxScore_ []+ scoreB_ <- WX.vgauge p maxScore_ []+ matrix_ <-+ forM (zip [0..] (Config.texts cfg)) $ \(r,ln) ->+ forM (zip [0..] ln) $ \(c,label) -> do+ b <- WX.button p [ text := label ]+ return ((r,c),b)+ restart_ <- WX.button p [ text := "Restart" ]+ quit_ <- WX.button p [ text := "Quit", on command := close f ]+ WX.set f [layout :=+ container p $ margin 10 $+ row 5 $+ WX.vfill (widget scoreA_) :+ (column 5 $+ WX.hfill (widget message_) :+ WX.grid (Config.columns cfg) (Config.rows cfg)+ (map (map (WX.fill . widget . snd)) matrix_) :+ row 5 [WX.hfill (widget restart_), WX.hfill (widget quit_)] :+ []) :+ WX.vfill (widget scoreB_) :+ []+ ]++ return $+ Cons {+ frame = f,+ panel = p,+ message = message_,+ scoreA = scoreA_, scoreB = scoreB_,+ matrix = matrix_,+ restart = restart_,+ maxScore = maxScore_+ }
src/Main.hs view
@@ -1,5 +1,6 @@ module Main where +import qualified GUI import qualified Game import qualified Configuration as Config import qualified Option@@ -9,107 +10,91 @@ import qualified Sound.ALSA.Sequencer.Event as Event import qualified Graphics.UI.WX as WX-import Graphics.UI.WX- (Prop((:=)), set, get, text, selection, command, on,- close, container, widget,- layout, margin, row, column, )+import Graphics.UI.WX (Prop((:=)), text, selection, command, on) import qualified System.Random as Rnd import qualified Control.Monad.Trans.State as MS-import Control.Monad (forM, )-import Control.Applicative (liftA2, (<$>))+import Control.Monad (forM_)+import Control.Applicative (liftA2, liftA3, (<$>)) import Data.Array (Array, (!))-import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef, )+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef, ) shufflePitches :: Config.T -> IO (Array (Int, Int) Event.Pitch) shufflePitches cfg = MS.evalState (Game.shufflePitches cfg) . Rnd.mkStdGen <$> Rnd.randomIO -makeGUI :: Config.T -> MIDI.Sequencer -> IO ()-makeGUI cfg sequ = do- f <- WX.frame [text := "Midimory"]- p <- WX.panel f []- pitches <- newIORef =<< shufflePitches cfg- selected <- newIORef Nothing- player <- newIORef PlayerA- message <- WX.staticText p [ text := Game.makeMessage PlayerA First ]- let maxScore = div (Config.rows cfg * Config.columns cfg) 2- scoreA <- WX.vgauge p maxScore []- scoreB <- WX.vgauge p maxScore []- let playerScore pl =- case pl of- PlayerA -> scoreA- PlayerB -> scoreB- matrix <-- forM (zip [0..] (Config.texts cfg)) $ \(r,ln) ->- forM (zip [0..] ln) $ \(c,label) -> do- b <- WX.button p [ text := label ]- set b [- on command := do- pitch <- (! (r,c)) <$> readIORef pitches- MIDI.sendNote sequ pitch- mfirst <- readIORef selected- case mfirst of- Nothing -> do- writeIORef selected $ Just (b, pitch)- set b [ WX.enabled := False ]- pl <- readIORef player- set message [ text := Game.makeMessage pl Second ]- Just (firstButton, firstPitch) -> do- writeIORef selected Nothing- pl <- readIORef player- if firstPitch == pitch- then do- set b [ WX.enabled := False ]- let score = playerScore pl- n <- get score selection- set score [ selection := succ n ]- else do- set firstButton [ WX.enabled := True ]- modifyIORef player switchPlayer- newpl <- readIORef player- score <-- liftA2 (,)- (get scoreA selection)- (get scoreB selection)- set message- [ text := Game.completeMessage maxScore newpl score ]- ]- return b- restart <-- WX.button p [- text := "Restart",- on command := do- mapM_ (mapM_ (\b -> set b [ WX.enabled := True ])) matrix- set scoreA [ selection := 0 ]- set scoreB [ selection := 0 ]- set message [ text := Game.makeMessage PlayerA First ]- writeIORef selected Nothing- writeIORef player PlayerA- writeIORef pitches =<< shufflePitches cfg- ]- quit <- WX.button p [text := "Quit", on command := close f]- set f [layout :=- container p $ margin 10 $- row 5 $- WX.vfill (widget scoreA) :- (column 5 $- WX.hfill (widget message) :- WX.grid (Config.columns cfg) (Config.rows cfg)- (map (map (WX.fill . widget)) matrix) :- row 5 [WX.hfill (widget restart), WX.hfill (widget quit)] :- []) :- WX.vfill (widget scoreB) :- []- ]+type+ State =+ (IORef (Array (Int, Int) Event.Pitch),+ IORef (Maybe (WX.Button (), Event.Pitch)),+ IORef Player) +move :: MIDI.Sequencer -> GUI.T -> State -> ((Int,Int), WX.Button ()) -> IO ()+move sequ gui (pitches, selected, player) (pos,b) = do+ pitch <- (!pos) <$> readIORef pitches+ MIDI.sendNote sequ pitch+ mfirst <- readIORef selected+ case mfirst of+ Nothing -> do+ writeIORef selected $ Just (b, pitch)+ WX.set b [ WX.enabled := False ]+ pl <- readIORef player+ WX.set (GUI.message gui) [ text := Game.makeMessage pl Second ]+ Just (firstButton, firstPitch) -> do+ writeIORef selected Nothing+ pl <- readIORef player+ if firstPitch == pitch+ then do+ WX.set b [ WX.enabled := False ]+ let score =+ case pl of+ PlayerA -> GUI.scoreA gui+ PlayerB -> GUI.scoreB gui+ n <- WX.get score selection+ WX.set score [ selection := succ n ]+ else do+ WX.set firstButton [ WX.enabled := True ]+ modifyIORef player switchPlayer+ newpl <- readIORef player+ score <-+ liftA2 (,)+ (WX.get (GUI.scoreA gui) selection)+ (WX.get (GUI.scoreB gui) selection)+ WX.set (GUI.message gui)+ [ text := Game.completeMessage (GUI.maxScore gui) newpl score ] +restart :: Config.T -> GUI.T -> State -> IO ()+restart cfg gui (pitches, selected, player) = do+ mapM_ (\(_pos,b) -> WX.set b [ WX.enabled := True ]) $+ concat $ GUI.matrix gui+ WX.set (GUI.scoreA gui) [ selection := 0 ]+ WX.set (GUI.scoreB gui) [ selection := 0 ]+ WX.set (GUI.message gui) [ text := Game.makeMessage PlayerA First ]+ writeIORef pitches =<< shufflePitches cfg+ writeIORef selected Nothing+ writeIORef player PlayerA++runGUI :: Config.T -> MIDI.Sequencer -> IO ()+runGUI cfg sequ = do+ gui <- GUI.create cfg+ state <-+ liftA3 (,,)+ (newIORef =<< shufflePitches cfg)+ (newIORef Nothing)+ (newIORef PlayerA)++ forM_ (concat $ GUI.matrix gui) $ \(pos,b) ->+ WX.set b [ on command := move sequ gui state (pos,b) ]++ WX.set (GUI.restart gui) [ on command := restart cfg gui state ]++ main :: IO () main = do (config, (dests,chan)) <- Option.multiArgs "Concentration game for tones" MIDI.withSequencer "Midimory" chan $ \sequ -> do mapM_ (MIDI.parseAndConnect sequ) dests- WX.start $ makeGUI config sequ+ WX.start $ runGUI config sequ
src/Reactive.hs view
@@ -1,5 +1,6 @@ module Main where +import qualified GUI import qualified Game import qualified Configuration as Config import qualified Option@@ -12,15 +13,12 @@ import Reactive.Banana ((<@>), (<@)) import qualified Graphics.UI.WX as WX-import Graphics.UI.WX- (Prop((:=)), set, text, selection, command, on,- close, container, widget,- layout, margin, row, column, )+import Graphics.UI.WX (Prop((:=)), command, selection, text) import qualified System.Random as Rnd import qualified Control.Monad.Trans.State as MS-import Control.Monad (forM, (<=<))+import Control.Monad ((<=<)) import Control.Applicative ((<$>), (<$), (<*>)) import qualified Data.Foldable as Fold@@ -28,38 +26,13 @@ import Data.Tuple.HT (mapFst, mapSnd) -makeGUI :: Config.T -> MIDI.Sequencer -> IO ()-makeGUI cfg sequ = do- f <- WX.frame [text := "Midimory"]- p <- WX.panel f []- message <- WX.staticText p [ text := Game.makeMessage PlayerA First ]- let maxScore = div (Config.rows cfg * Config.columns cfg) 2- scoreA <- WX.vgauge p maxScore []- scoreB <- WX.vgauge p maxScore []- matrix <-- forM (zip [0..] (Config.texts cfg)) $ \(r,ln) ->- forM (zip [0..] ln) $ \(c,label) -> do- b <- WX.button p [ text := label ]- return ((r,c),b)- restart <- WX.button p [ text := "Restart" ]- quit <- WX.button p [text := "Quit", on command := close f]- set f [layout :=- container p $ margin 10 $- row 5 $- WX.vfill (widget scoreA) :- (column 5 $- WX.hfill (widget message) :- WX.grid (Config.columns cfg) (Config.rows cfg)- (map (map (WX.fill . widget . snd)) matrix) :- row 5 [WX.hfill (widget restart), WX.hfill (widget quit)] :- []) :- WX.vfill (widget scoreB) :- []- ]+runGUI :: Config.T -> MIDI.Sequencer -> IO ()+runGUI cfg sequ = do+ gui <- GUI.create cfg seed <- Rnd.randomIO RBWX.actuate <=< RB.compile $ do- restartEv <- RBWX.event0 restart command+ restartEv <- RBWX.event0 (GUI.restart gui) command let accumMS m s ev = fmap fst <$> RB.accumB (MS.runState m s) (MS.runState m . snd <$ ev) pitchesBe <-@@ -71,7 +44,7 @@ (\(pos,button) -> do ev <- RBWX.event0 button command return ((,) button . (!pos) <$> pitchesBe <@ ev)) $- concat matrix+ concat $ GUI.matrix gui RBWX.reactimate $ MIDI.sendNote sequ . snd <$> buttonPitchEv let accumRestart s0 ev = RB.accumB s0 $ RB.unionWith (.) (const s0 <$ restartEv) ev@@ -83,8 +56,8 @@ (\mfirst -> mapSnd (\pitch -> mapSnd (pitch==) <$> mfirst)) <$> selectedBe <@> buttonPitchEv- let enable but state = set but [ WX.enabled := state ]- let restartAct = mapM_ (flip enable True . snd) $ concat matrix+ let enable but state = WX.set but [ WX.enabled := state ]+ let restartAct = mapM_ (flip enable True . snd) $ concat $ GUI.matrix gui RBWX.reactimate (restartAct <$ restartEv) RBWX.reactimate $ (\(button,match) ->@@ -112,10 +85,10 @@ let chooseMessage choice pl score = case choice of Second -> Game.makeMessage pl Second- First -> Game.completeMessage maxScore pl score- RBWX.sink scoreA [ selection :== fst <$> scoreBe ]- RBWX.sink scoreB [ selection :== snd <$> scoreBe ]- RBWX.sink message+ First -> Game.completeMessage (GUI.maxScore gui) pl score+ RBWX.sink (GUI.scoreA gui) [ selection :== fst <$> scoreBe ]+ RBWX.sink (GUI.scoreB gui) [ selection :== snd <$> scoreBe ]+ RBWX.sink (GUI.message gui) [ text :== chooseMessage <$> choiceBe <*> playerBe <*> scoreBe ] @@ -124,4 +97,4 @@ (config, (dests,chan)) <- Option.multiArgs "Concentration game for tones" MIDI.withSequencer "Midimory" chan $ \sequ -> do mapM_ (MIDI.parseAndConnect sequ) dests- WX.start $ makeGUI config sequ+ WX.start $ runGUI config sequ