midimory 0.0.1 → 0.0.2
raw patch · 4 files changed
+253/−70 lines, 4 filesdep +reactive-bananadep +reactive-banana-wxnew-component:exe:midimory-reactive
Dependencies added: reactive-banana, reactive-banana-wx
Files
- midimory.cabal +34/−2
- src/Game.hs +76/−0
- src/Main.hs +16/−68
- src/Reactive.hs +127/−0
midimory.cabal view
@@ -1,5 +1,5 @@ Name: midimory-Version: 0.0.1+Version: 0.0.2 Maintainer: Henning Thielemann <alsa@henning-thielemann.de> Author: Henning Thielemann <alsa@henning-thielemann.de> Category: Sound, Music, Game, GUI@@ -42,12 +42,17 @@ Source-Repository this type: darcs- tag: 0.0.1+ tag: 0.0.2 location: http://code.haskell.org/~thielema/midimory/ +Flag reactive+ Description: Additional alternative implementation using reactive-banana-wx+ Default: False+ Executable midimory Main-Is: Main.hs Other-Modules:+ Game Configuration MIDI Option@@ -65,3 +70,30 @@ array >=0.4 && <0.6, utility-ht >=0.0.12 && <0.1, base >=3 && <5++Executable midimory-reactive+ Main-Is: Reactive.hs+ Other-Modules:+ Game+ Configuration+ MIDI+ Option+ Hs-Source-Dirs: src+ GHC-Options: -Wall+ If flag(reactive)+ Build-Depends:+ reactive-banana-wx >=1.1 && <1.2,+ reactive-banana >=1.1 && <1.2,+ wx >=0.12.1.6 && <0.93,+ wxcore >=0.12.1.6 && <0.93,+ alsa-seq >=0.6 && <0.7,+ alsa-core >=0.5 && <0.6,+ optparse-applicative >=0.14 && <0.15,+ random >=1.0 && <1.2,+ transformers >=0.2 && <0.6,+ containers >=0.2 && <0.6,+ array >=0.4 && <0.6,+ utility-ht >=0.0.12 && <0.1,+ base >=3 && <5+ Else+ Buildable: False
+ src/Game.hs view
@@ -0,0 +1,76 @@+module Game where++import qualified Configuration as Config++import qualified Sound.ALSA.Sequencer.Event as Event++import qualified System.Random as Rnd++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT+import Control.Monad (forM)+import Control.Applicative ((<$>))++import qualified Data.Sequence as Seq+import qualified Data.Array as Array+import Data.Sequence (Seq, ViewL((:<)), (><), )+import Data.Array (Array)++++data Player = PlayerA | PlayerB++switchPlayer :: Player -> Player+switchPlayer PlayerA = PlayerB+switchPlayer PlayerB = PlayerA++formatPlayer :: Player -> String+formatPlayer PlayerA = "Player A"+formatPlayer PlayerB = "Player B"+++data Choice = First | Second++makeMessage :: Player -> Choice -> String+makeMessage player choice =+ formatPlayer player ++ ": Hit " +++ (case choice of First -> "first"; Second -> "second") +++ " button!"++completeMessage :: (Ord a, Num a) => a -> Player -> (a, a) -> String+completeMessage maxScore pl (a,b) =+ let winners =+ if a+b < maxScore+ then []+ else+ case compare a b of+ GT -> [PlayerA]+ LT -> [PlayerB]+ EQ -> [PlayerA, PlayerB]+ in case winners of+ [] -> makeMessage pl First+ [winner] -> "Game Over! The winner is " ++ formatPlayer winner+ _ -> "Game Over! Stalemate!"++++pick :: Int -> Seq a -> (a, Seq a)+pick n as =+ let (prefix, suffix) = Seq.splitAt n as+ in case Seq.viewl suffix of+ Seq.EmptyL -> error "pick: index too large"+ a :< rest -> (a, prefix >< rest)++shuffle :: (Rnd.RandomGen g) => [a] -> MS.State g [a]+shuffle xs =+ flip MS.evalStateT (Seq.fromList xs) $+ forM (takeWhile (>=0) $ tail $ iterate (subtract 1) (length xs)) $ \maxN -> do+ n <- MT.lift $ MS.state $ Rnd.randomR (0, maxN)+ MS.state $ pick n++shufflePitches ::+ (Rnd.RandomGen g) => Config.T -> MS.State g (Array (Int, Int) Event.Pitch)+shufflePitches cfg =+ Array.listArray ((0, 0), (Config.rows cfg - 1, Config.columns cfg - 1))+ <$>+ shuffle ((\ps -> ps++ps) $ Config.pitches cfg)
src/Main.hs view
@@ -1,8 +1,10 @@ module Main where +import qualified Game import qualified Configuration as Config import qualified Option import qualified MIDI+import Game (Choice(First,Second), Player(PlayerA,PlayerB), switchPlayer) import qualified Sound.ALSA.Sequencer.Event as Event @@ -15,57 +17,16 @@ import qualified System.Random as Rnd import qualified Control.Monad.Trans.State as MS-import qualified Control.Monad.Trans.Class as MT import Control.Monad (forM, )-import Control.Applicative ((<$>))+import Control.Applicative (liftA2, (<$>)) -import qualified Data.Sequence as Seq-import qualified Data.Array as Array-import Data.Sequence (Seq, ViewL((:<)), (><), )-import Data.Array ((!))+import Data.Array (Array, (!)) import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef, ) -pick :: Int -> Seq a -> (a, Seq a)-pick n as =- let (prefix, suffix) = Seq.splitAt n as- in case Seq.viewl suffix of- Seq.EmptyL -> error "pick: index too large"- a :< rest -> (a, prefix >< rest)--shuffle :: (Rnd.RandomGen g) => g -> [a] -> [a]-shuffle g xs =- flip MS.evalState g $- flip MS.evalStateT (Seq.fromList xs) $- forM (takeWhile (>=0) $ tail $ iterate (subtract 1) (length xs)) $ \maxN -> do- n <- MT.lift $ MS.state $ Rnd.randomR (0, maxN)- MS.state $ pick n---data Player = PlayerA | PlayerB--switchPlayer :: Player -> Player-switchPlayer PlayerA = PlayerB-switchPlayer PlayerB = PlayerA--formatPlayer :: Player -> String-formatPlayer PlayerA = "Player A"-formatPlayer PlayerB = "Player B"--makeMessage :: Player -> Int -> String-makeMessage player count =- formatPlayer player ++ ": Hit " ++- (if count == 0 then "first" else "second") ++- " button!"---shufflePitches :: Config.T -> IO (Array.Array (Int, Int) Event.Pitch)-shufflePitches cfg = do- seed <- Rnd.randomIO- return $- Array.listArray- ((0, 0), (Config.rows cfg - 1, Config.columns cfg - 1))- (shuffle (Rnd.mkStdGen seed) ((\ps -> ps++ps) $ Config.pitches cfg))+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@@ -74,7 +35,7 @@ pitches <- newIORef =<< shufflePitches cfg selected <- newIORef Nothing player <- newIORef PlayerA- message <- WX.staticText p [ text := makeMessage PlayerA 0 ]+ 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 []@@ -82,17 +43,6 @@ case pl of PlayerA -> scoreA PlayerB -> scoreB- isGameOver = do- a <- get scoreA selection- b <- get scoreB selection- return $- if a+b < maxScore- then []- else- case compare a b of- LT -> [PlayerB]- GT -> [PlayerA]- EQ -> [PlayerA, PlayerB] matrix <- forM (zip [0..] (Config.texts cfg)) $ \(r,ln) -> forM (zip [0..] ln) $ \(c,label) -> do@@ -107,7 +57,7 @@ writeIORef selected $ Just (b, pitch) set b [ WX.enabled := False ] pl <- readIORef player- set message [ text := makeMessage pl 1 ]+ set message [ text := Game.makeMessage pl Second ] Just (firstButton, firstPitch) -> do writeIORef selected Nothing pl <- readIORef player@@ -121,14 +71,12 @@ set firstButton [ WX.enabled := True ] modifyIORef player switchPlayer newpl <- readIORef player- gameOver <- isGameOver- set message [ text :=- case gameOver of- [] -> makeMessage newpl 0- [winner] ->- "Game Over! The winner is " ++- formatPlayer winner- _ -> "Game Over! Stalemate!" ]+ score <-+ liftA2 (,)+ (get scoreA selection)+ (get scoreB selection)+ set message+ [ text := Game.completeMessage maxScore newpl score ] ] return b restart <-@@ -138,7 +86,7 @@ mapM_ (mapM_ (\b -> set b [ WX.enabled := True ])) matrix set scoreA [ selection := 0 ] set scoreB [ selection := 0 ]- set message [ text := makeMessage PlayerA 0 ]+ set message [ text := Game.makeMessage PlayerA First ] writeIORef selected Nothing writeIORef player PlayerA writeIORef pitches =<< shufflePitches cfg
+ src/Reactive.hs view
@@ -0,0 +1,127 @@+module Main where++import qualified Game+import qualified Configuration as Config+import qualified Option+import qualified MIDI+import Game (Choice(First,Second), Player(PlayerA,PlayerB), switchPlayer)++import qualified Reactive.Banana.WX as RBWX+import qualified Reactive.Banana as RB+import Reactive.Banana.WX (Prop'((:==)))+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 qualified System.Random as Rnd++import qualified Control.Monad.Trans.State as MS+import Control.Monad (forM, (<=<))+import Control.Applicative ((<$>), (<$), (<*>))++import qualified Data.Foldable as Fold+import Data.Array ((!))+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) :+ []+ ]++ seed <- Rnd.randomIO+ RBWX.actuate <=< RB.compile $ do+ restartEv <- RBWX.event0 restart command+ let accumMS m s ev =+ fmap fst <$> RB.accumB (MS.runState m s) (MS.runState m . snd <$ ev)+ pitchesBe <-+ accumMS (Game.shufflePitches cfg) (Rnd.mkStdGen seed) restartEv+ let clashMsg = "clicks cannot occur at the same time"+ buttonPitchEv <-+ fmap (foldl (RB.unionWith (error clashMsg)) RB.never) $+ mapM+ (\(pos,button) -> do+ ev <- RBWX.event0 button command+ return ((,) button . (!pos) <$> pitchesBe <@ ev)) $+ concat matrix+ RBWX.reactimate $ MIDI.sendNote sequ . snd <$> buttonPitchEv+ let accumRestart s0 ev =+ RB.accumB s0 $ RB.unionWith (.) (const s0 <$ restartEv) ev+ selectedBe <-+ accumRestart Nothing+ ((\buttonPitch -> maybe (Just buttonPitch) (const Nothing))+ <$> buttonPitchEv)+ let matchingPitchEv =+ (\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+ RBWX.reactimate (restartAct <$ restartEv)+ RBWX.reactimate $+ (\(button,match) ->+ case match of+ Just (firstButton, False) -> enable firstButton True+ _ -> enable button False)+ <$>+ matchingPitchEv+ choiceBe <-+ RB.stepper First $+ RB.unionWith const (First <$ restartEv)+ (maybe Second (const First) . snd <$> matchingPitchEv)+ playerBe <-+ accumRestart PlayerA+ ((\match -> if Fold.all snd match then id else switchPlayer)+ <$> fmap snd matchingPitchEv)+ scoreBe <-+ accumRestart (0,0)+ ((\pl match ->+ if Fold.any snd match+ then case pl of PlayerA -> mapFst succ; PlayerB -> mapSnd succ+ else id)+ <$> playerBe+ <@> fmap snd matchingPitchEv)+ 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+ [ text :== chooseMessage <$> choiceBe <*> playerBe <*> scoreBe ]+++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