data Status = Draw | Won | Play deriving (Eq, Show) data Game = Game [Int] Status Int deriving Show initGame = Game (replicate 9 0) Play (-1) goals = [ [0,1,2] , [3,4,5] , [6,7,8] , [0,3,6] , [1,4,7] , [2,5,8] , [0,4,8] , [2,4,6] ] classify board player | or $ all ((== player) . (board!!)) <$> goals = Game board Won player | 0 `notElem` board = Game board Draw player | otherwise = Game board Play $ -player
Tic-Tac-Toe
Minimax
Random
First Available
Tic-tac-toe, or Noughts and Crosses, is the "Hello, World!" of two-player deterministic perfect information turn-based games. (This sentence remains true after removing an arbitrary number of adjectives.) Thus this game is ideal for experimenting with computer opponents that search game trees.
Get on board
We represent a board with a list of 9 integers, where 0 means an empty square, while 1 and -1 mean X and O. We also record the next player to move and whether someone as won. Although this could be deduced from the board alone, since X always moves first in our version, it seems better to compute this information once and store the result.
When the game is won, we reuse the next-player field to store the winning player.
From a given board, the next possible moves are determined by the empty spots, which is slightly awkward to compute with lists:
nextMoves game@(Game board status p) = case status of Play -> (`classify` p) <$> go id board _ -> [] where go pre post = case post of [] -> [] x:xs -> (if x == 0 then (pre (p:xs) :) else id) $ go (pre . (x:)) xs
The Game Tree
Even non-gamers likely understand game trees, as in everyday interactions, we think "if I do A, then they’ll do X, but if I do B, then they’ll do Y or Z".
We swipe some code from Data.Tree
, and define maximum
and minimum
which
our Base
library lacks:
data Tree a = Node { rootLabel :: a, -- ^ label value subForest :: [Tree a] -- ^ zero or more child trees } deriving Show unfoldTree :: (b -> (a, [b])) -> b -> Tree a unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs) unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree a] unfoldForest f = map (unfoldTree f) maximum = foldr1 max minimum = foldr1 min
Computing the game tree from a given board is one-liner:
gameTree = unfoldTree \g -> (g, nextMoves g)
For example:
gameTree (Game [-1,1,0 ,-1,1,1 ,0,-1,0] Play 1)
Best worst-case
The idea behind minimax comes naturally to gamers. If both players are playing optimally, and know that their opponent is playing optimally, then we should assume our opponent is going to find the move that hurts the most; the worst-case scenario. On our end, we always want the move with the most benefit. Thus we end up alternating between two points of view, hence the name minimax.
Implementing minimax is comes less naturally because mutual recursion can be confusing. Luckily, we’re writing in Haskell, and luckier still, we’re only one click away from the classic paper: John Hughes, Why Functional Programming Matters.
Hughes shows how easy it is to implement minimax search in Haskell:
score (Game _ Won n) = n score _ = 0 maximize (Node leaf []) = score leaf maximize (Node _ kids) = maximum $ minimize <$> kids minimize (Node leaf []) = score leaf minimize (Node _ kids) = minimum $ maximize <$> kids
Given a list of potential moves xs
, the following returns the first best move
found:
best xs = snd $ foldr1 go $ zip (minimize . gameTree <$> xs) xs where go a b = if fst a > fst b then a else b
But wait, there’s more! Hughes then demonstrates the power of lazy evaluation by implementing alpha-beta pruning, an optimization which also comes naturally to gamers. If I’m playing chess, and I see a move that leads to the opponent checkmating me, then I’ll immediately drop that move from further consideration; it makes no sense to play it anyway and hope my opponent fails to spot a win. This is a special case of alpha-beta pruning.
As Hughes explains, thanks to lazy evaluation, a few edits are enough to gain alpha-beta pruning. In other languages, we must dive deep into the search algorithm to change its control flow.
omitWith op (ms:mss) = m : omit m mss where oppest = foldr1 \a b -> if op a b then a else b m = oppest ms omit _ [] = [] omit pot (ns:nss) | any (`op` pot) ns = omit pot nss | otherwise = n : omit n nss where n = oppest ns maximize' :: Tree Game -> [Int] maximize' (Node leaf []) = [score leaf] maximize' (Node _ kids) = omitWith (<=) $ minimize' <$> kids minimize' :: Tree Game -> [Int] minimize' (Node leaf []) = [score leaf] minimize' (Node _ kids) = omitWith (>=) $ maximize' <$> kids bestAB ms = snd $ foldr1 go $ zip (minimum . minimize' . gameTree <$> ms) ms where go a b = if fst a > fst b then a else b
Plumbing
Now to put the above theory into practice.
We shuffle the list of potential moves so that the best one chosen by the search varies from game to game.
shuffle xs = case length xs of 0 -> pure [] n -> do i <- fromInteger . readInteger <$> jsEval ("Math.floor(Math.random() * " ++ show n ++ ");") let (as, x:bs) = splitAt i xs (x:) <$> shuffle (as ++ bs)
We make various algorithms available for the user to try out.
aiMove game = do shuffled <- shuffle future go [ ("alphabeta", bestAB shuffled) , ("brute", best shuffled) , ("rando", head shuffled) , ("first", head future) ] where future = nextMoves game go ((s, m):rest) = do jsEval (s ++ ".checked;") >>= \case "true" -> pure m _ -> go rest
Code to draw the board:
sz = 64 bd = 4 clip x y xoff = jsEval_ $ concat [ "ctx.drawImage(xo, ", show xoff, ", 0, ", show sz, ", ", show sz , ", ", show x, ", ", show y, ", ", show sz, ", ", show sz , ");" ] sq i p = when (p /= 0) $ clip (x*sz) (y*sz) (bool 0 sz $ p > 0) where (y, x) = divMod i 3 draw = (*> pure ()) . sequence . zipWith sq [0..]
Event handlers and user interface. The delayHack
mess allows the webpage to
be redrawn so that the player can see their move while the computer is
thinking.
update game@(Game board status player) = do setGlobal game draw board jsEval_ $ concat ["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) do jsEval_ $ "console.log(`" ++ show (nextMoves game) ++ "`);" delayHack $ update =<< aiMove game valid x y = and [0 <= x, x <= 3, 0 <= y, y <= 3] click xraw yraw = do Game board status player <- global let x = div xraw sz y = div yraw sz when (status == Play && player == -1 && valid x y) do -- I originally called it `x` but discovered my compiler has -- a bug involving shadowed variables. let (as, totallyNotX:bs) = splitAt (3*y + x) board when (totallyNotX == 0) $ update $ classify (as ++ player:bs) player delayRef = unsafePerformIO $ newIORef (undefined "delayHack" :: IO ()) delayHack f = do writeIORef delayRef f jsEval_ $ "setTimeout(() => repl.run('chat', ['Main'], 'delayHackCont'), 1);" delayHackCont = readIORef delayRef >>= id
The newGame
function draws the borders of the board, and calls update
with
an empty board.
oblong x y w h = jsEval_ $ concat ["ctx.fillRect(", show x, ", ", show y, ", ", show w, ", ", show h, ");"] newGame = do jsEval_ "ctx.clearRect(0, 0, canvas.width, canvas.height);" oblong ( sz - bd) 0 (2*bd) (3*sz) oblong (2*sz - bd) 0 (2*bd) (3*sz) oblong 0 ( sz - bd) (3*sz) (2*bd) oblong 0 (2*sz - bd) (3*sz) (2*bd) update initGame
We hook up the event handlers and start a new game:
jsEval_ [r| newButton.addEventListener("click", (ev) => repl.run("chat", ["Main"], "newGame")); canvas.addEventListener("click", (ev) => repl.run("chat", ["Main"], "click " + ev.offsetX + " " + ev.offsetY)); document.body.addEventListener("keydown", (ev) => { if (ev.keyCode == 113) repl.run("chat", ["Main"], "newGame"); }); |] newGame