{-----------------------------------------------------------------------------
reactive-banana-wx
Example: A version of TicTacToe with silly interface elements
Author: Gideon Sireling
------------------------------------------------------------------------------}
import Control.Monad
import Data.Array
import Data.List hiding (union)
import Data.Maybe
import Graphics.UI.WX hiding (Event)
import Graphics.UI.WXCore hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX
{-----------------------------------------------------------------------------
User Interface
------------------------------------------------------------------------------}
main = start $ do
-- create the main window
window <- frame [text := "OX"]
label <- staticText window [text := "Move: X"]
-- overwritten by FRP, here to ensure correct positioning
btns <- replicateM 3 $ button window [size := sz 40 40]
radios <- replicateM 3 $ radioBox window Vertical ["", "?"] []
checks <- replicateM 3 $ checkBox window [text := " "]
-- reserve space for X/O in label
set window [layout := column 5 [grid 1 1
[map widget btns, map widget radios, map widget checks]
, floatCenter $ widget label]]
network <- compile $ do
-- convert WxHaskell events to FRP events
let event0s widgets event = forM widgets $ \x -> event0 x event
events <- liftM concat $ sequence
[event0s btns command, event0s radios select, event0s checks command]
let
moves :: Event (State -> State)
moves = foldl1 union $ zipWith (\e s -> play s <$ e) events
[(x,y) | y <- [1..3], x <- [1..3]]
where play square (game, _) = move game square
state :: Discrete State
state = accumD (newGame, Nothing) moves
player :: Discrete String
player = (\(Game player _, _) -> show player) <$> state
tokens :: [Discrete String]
tokens = map (\e -> stepperD "" (player <@ e)) events
-- wire up the widget event handlers
zipWithM_ (\b e -> sink b [text :== e, enabled :== null <$> e])
(map objectCast btns
++ map objectCast radios
++ map objectCast checks :: [Control ()])
tokens
sink label [text :== ("Move: " ++) <$> player]
-- end game event handler
reactimate $ (end window . fromJust) <$>
filterE isJust (changes $ snd <$> state)
actuate network
end :: Frame () -> Token -> IO ()
end window result = do
infoDialog window "" $ case result of
X -> "X won!"
O -> "O won!"
None -> "Draw!"
close window
{-----------------------------------------------------------------------------
Game Logic
------------------------------------------------------------------------------}
type State = (Game, Maybe Token)
data Token = None | X | O
deriving Eq
-- |The coordinates of a square.
type Square = (Int,Int)
-- |A noughts and crosses board.
type Board = Array Square Token
-- |Returns an empty 'Board'.
newBoard :: Board
newBoard = listArray ((1,1),(3,3)) (repeat None)
-- |Puts a 'Token' in a 'Square'.
setSquare :: Board -> Square -> Token -> Board
setSquare board square token =
if (board ! square) /= None
then error $ "square " ++ show square ++ " is not empty"
else board // [(square, token)]
-- |Determine if the 'Board' is in an end state.
-- Returns 'Just' 'Token' if the game has been won,
-- 'Just' 'None' for a draw, otherwise 'Nothing'.
endGame :: Board -> Maybe Token
endGame board
| Just X `elem` maybeWins = Just X
| Just O `elem` maybeWins = Just O
| None `notElem` elems board = Just None
| otherwise = Nothing
where rows :: [[Square]]
rows = let i = [1..3]
in [[(x,y) | y <- i] | x <- i] ++ -- rows
[[(y,x) | y <- i] | x <- i] ++ -- coloumns
[[(x,x) | x <- i], [(x,4-x) | x <- i]] -- diagonals
rows2tokens :: [[Token]]
rows2tokens = map (map (board !)) rows
isWin :: [Token] -> Maybe Token
isWin tokens
| all (==X) tokens = Just X
| all (==O) tokens = Just O
| otherwise = Nothing
maybeWins :: [Maybe Token]
maybeWins = map isWin rows2tokens
-- |The state of a game, i.e. the player who's turn it is, and the current board.
data Game = Game Token Board
newGame :: Game
newGame = Game X newBoard
-- |Puts the player's token on the specified square.
-- Returns 'Just' 'Token' if the game has been won,
-- 'Just' 'None' for a draw, otherwise 'Nothing'.
move :: Game -> Square -> (Game, Maybe Token)
move (Game player board) square =
let board' = setSquare board square player
player' = case player of {X -> O; O -> X}
in (Game player' board', endGame board')
{-----------------------------------------------------------------------------
Show instances
------------------------------------------------------------------------------}
outersperse :: a -> [a] -> [a]
outersperse x ys = x : intersperse x ys ++ [x]
instance Show Token where
show X = "X"
show O = "O"
show None = " "
showList tokens = showString $ outersperse '|' $ concatMap show tokens
-- Board cannot be declared an instance of Show,
-- as this would overlap with the existing instance for Array.
showBoard :: Board -> String
showBoard board =
let border = " +-+-+-+"
i = [1..3]
showRow x = show x ++ show [board ! (y,x) | y <- i]
in intercalate "\n" $ " 1 2 3" : outersperse border (map showRow i)
instance Show Game where
show (Game player board) = showBoard board ++ "\n\nTurn: " ++ show player