midimory-0.0.1: src/Main.hs

module Main where

import qualified Configuration as Config
import qualified Option
import qualified MIDI

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 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 ((!))
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))

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 := makeMessage PlayerA 0 ]
   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
       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
            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 := makeMessage pl 1 ]
                     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
                        gameOver <- isGameOver
                        set message [ text :=
                           case gameOver of
                              [] -> makeMessage newpl 0
                              [winner] ->
                                 "Game Over! The winner is " ++
                                 formatPlayer winner
                              _ -> "Game Over! Stalemate!" ]
             ]
            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 := makeMessage PlayerA 0 ]
            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