midimory-0.0.2.3: src/Reactive.hs

module Main where

import qualified GUI
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((:=)), command, selection, text)

import qualified System.Random as Rnd

import qualified Control.Monad.Trans.State as MS
import Control.Monad ((<=<))
import Control.Applicative ((<$>), (<$), (<*>))

import qualified Data.Foldable as Fold
import Data.Array ((!))
import Data.Tuple.HT (mapFst, mapSnd)


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 (GUI.restart gui) 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 $ GUI.matrix gui
      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 = 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) ->
            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 (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 ]


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 $ runGUI config sequ