diff --git a/midimory.cabal b/midimory.cabal --- a/midimory.cabal +++ b/midimory.cabal @@ -1,5 +1,5 @@ Name: midimory -Version: 0.0.1 +Version: 0.0.2 Maintainer: Henning Thielemann Author: Henning Thielemann 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 diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 --- /dev/null +++ b/src/Game.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Reactive.hs b/src/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/Reactive.hs @@ -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