midimory-0.0.2: src/Reactive.hs

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