midimory-0.0.2: src/Main.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 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 qualified System.Random as Rnd

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

import Data.Array (Array, (!))
import Data.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) :
            []
    ]


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