midimory-0.0: src/Main.hs

module Main where

import MIDI

import qualified Sound.ALSA.Sequencer.Event as Event

import Graphics.UI.WX
   (Prop((:=)), set, get, text, selection, command, on,
    close, container, widget,
    layout, margin, row, column, )

import qualified Graphics.UI.WX as WX

import qualified System.Random as Rnd

import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef, )

import qualified Control.Monad.Trans.State as MS
import Control.Monad.IO.Class (liftIO, )
import Control.Monad (forM, )

import qualified Data.Sequence as Seq
import Data.Sequence (Seq, ViewL((:<)), (><), )


data Config =
   Config {
      rows, columns :: Int,
      texts :: [[String]],
      pitches :: [Event.Pitch]
   }

makeConfig :: [[String]] -> [Event.Pitch] -> Config
makeConfig ts ps =
   Config {
      rows = length ts,
      columns = maximum (map length ts),
      texts = ts,
      pitches = ps
   }

config4x4, config4x4sg, config4x6sg, config6x6sg :: Config
config4x4 =
   makeConfig
      (map (\r -> map (\c -> [r,c]) ['0'..'3']) ['A'..'D'])
      (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12])

config4x4sg =
   makeConfig
      (map (map (:[])) ["SPR*", "*ACH", "GIT*", "*TER"])
      (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12])

config4x6sg =
   makeConfig
      (map (map (:[])) $ concat $ replicate 2 ["SPRACH", "GITTER"])
      (map (Event.Pitch . (60+)) [0..11])

config6x6sg =
   makeConfig
      (map (map (:[])) $ concat $ replicate 3 ["SPRACH", "GITTER"])
      (map (Event.Pitch . (60+)) [0..17])


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)

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!"


makeGUI :: Config -> Sequencer -> IO ()
makeGUI cfg sequ = do
   f <- WX.frame [text := "Midimory"]
   p <- WX.panel f []
   selected <- newIORef Nothing
   player <- newIORef PlayerA
   message <- WX.staticText p [ text := makeMessage PlayerA 0 ]
   let maxScore = div (rows cfg * 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 <-
      flip MS.evalStateT ((\ps -> ps >< ps) $ Seq.fromList $ pitches cfg) $
      forM (texts cfg) $ \ln -> forM ln $ \c -> do
         pitch <- do
            maxN <- MS.gets Seq.length
            n <- liftIO $ Rnd.randomRIO (0, maxN - 1)
            MS.StateT (return . pick n)
         liftIO $ do
            b <- WX.button p [ text := c ]
            set b [
               on command := do
                  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
   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 (columns cfg) (rows cfg)
                   (map (map (WX.fill . widget)) matrix) :
                WX.hfill (widget quit) :
                []) :
            WX.vfill (widget scoreB) :
            []
    ]


main :: IO ()
main =
   withSequencer "Midimory" $ WX.start . makeGUI config4x4