import Data.Array
import Data.Bool
import Data.IORef
import Data.List
import Data.Ord
import Data.Tree
import Control.Monad
import System.Random
import Haste
import Haste.DOM
import Haste.Events
import Haste.Graphics.Canvas
import Haste.JSString (pack)
sz = 64; bd = 4; bnds = ((0,0), (2,2))
moveRandomly = False
data Status = Draw | Won | Play deriving Eq
data Game = Game (Array (Int, Int) Int) Status Int
initGame = Game (listArray bnds $ repeat 0) Play (-1)
goals = [join (,) <$> [0..2], (,) <*> (2-) <$> [0..2]] -- Diagonals.
++ ((<$> [0..2]) . (,) <$> [0..2]) -- Rows and columns.
++ ((<$> [0..2]) . flip (,) <$> [0..2])
move board0 player i
| or $ all ((== player) . (board!)) <$> goals = Game board Won player
| 0 `notElem` elems board = Game board Draw player
| otherwise = Game board Play $ -player
where board = board0 // [(i, player)]
nextMoves game@(Game board status p) = (game, case status of
Play -> [move board p i | i <- indices board, board!i == 0]
_ -> [])
gameTree = unfoldTree nextMoves
score (Game _ Won n) = n
score _ = 0
maximize (Node leaf []) = leaf
maximize (Node _ kids) = maximum $ minimize <$> kids
minimize (Node leaf []) = leaf
minimize (Node _ kids) = minimum $ maximize <$> kids
best = maximumBy $ comparing $ minimize . fmap score . gameTree
omitWith op ((g, ns):nss) = let
omit _ [] = []
omit pot ((g, ns):nss) | any (`op` pot) ns = omit pot nss
| otherwise = (g, last ns) : omit (last ns) nss
in (g, last ns) : omit (last ns) nss
maximize' :: Tree Game -> [(Game, Int)]
maximize' (Node leaf []) = [(undefined, score leaf)]
maximize' (Node _ kids) = omitWith (<=)
[(rootLabel k, snd <$> minimize' k) | k <- kids]
minimize' :: Tree Game -> [(Game, Int)]
minimize' (Node leaf []) = [(undefined, score leaf)]
minimize' (Node _ kids) = omitWith (>=)
[(rootLabel k, snd <$> maximize' k) | k <- kids]
bestAB ms = fst $ last . maximize' $ Node undefined $ map gameTree ms
f = fromIntegral
oblong x y w h = fill $ rect (f x, f y) (f $ x + w, f $ y + h)
main = withElems ["canvas", "message", "noab"] $ \[cElem, message, noab] -> do
xo <- loadBitmap $ pack "xo.png"
Just canvas <- fromElem cElem
gameVar <- newIORef initGame
let
shuffleIO [] = return []
shuffleIO xs = getStdRandom (randomR (0, length xs - 1)) >>= \n ->
let (a, b:bs) = splitAt n xs in (b:) <$> shuffleIO (a ++ bs)
sq ((x, y), p) = do
-- Draw borders.
when (x /= 0) $ oblong (x * sz) (y * sz) bd sz
when (x /= 2) $ oblong (x * sz + sz - bd) (y * sz) bd sz
when (y /= 0) $ oblong (x * sz) (y * sz) sz bd
when (y /= 2) $ oblong (x * sz) (y * sz + sz - bd) sz bd
-- Draw nought or cross when present.
when (p /= 0) $ drawClipped xo (f $ x * sz, f $ y * sz) $
Rect (f $ bool 0 sz $ p > 0) 0 (f sz) (f sz)
aiMove game = do
shuffledMoves <- shuffleIO $ snd $ nextMoves game
disableAB <- ("true" ==) <$> getProp noab "checked"
return $ if moveRandomly then head shuffledMoves else
bool bestAB best disableAB shuffledMoves
go game = writeIORef gameVar game >> update
update = do
game@(Game board status player) <- readIORef gameVar
render canvas $ mapM_ sq $ assocs board
setProp message "innerHTML" $ case status of
Won -> ("X.O"!!(player + 1)) : " wins"
Draw -> "Draw"
Play -> if player == -1 then "X to move" else "Thinking..."
when (player == 1 && status == Play) $ void $
setTimer (Once 1) $ aiMove game >>= go -- Delay for redraw.
_ <- cElem `onEvent` MouseDown $ \(MouseData (x, y) _ _) -> do
Game board status player <- readIORef gameVar
let i = (x `div` sz, y `div` sz) in when (status == Play && player == -1
&& inRange bnds i && board!i == 0) $ go $ move board player i
_ <- documentBody `onEvent` KeyDown $ \k -> when (keyCode k == 113) $ go initGame
update
Tic-tac-toe
Disable
alpha-beta
pruning.