# Breakthrough

Breakthrough was invented by Dan Troyka [Rules].

import Control.Monad
import Data.Array
import Data.Maybe
import Data.Tree
import System.Random
import Haste
import Haste.Concurrent
import Haste.DOM
import Haste.Events
import Haste.Graphics.Canvas

bnds = ((0,0), (7,7)); sz = 40

data Event = Mo (Int, Int) | Ke Int
data State = Won | Play deriving Eq
data Game = Game { board :: Array (Int, Int) Int
, state :: State
, player :: Int
, selection :: Maybe (Int, Int)
, anim :: Maybe (Int, ((Int, Int), (Int, Int)))
, lastMove :: ((Int, Int), (Int, Int))
}

initRow y | y <= 1 = -1
| y >= 6 = 1
| True   = 0

initBoard = array bnds [(i, initRow y) | i@(x,y) <- range bnds]

initGame = Game initBoard Play 1 Nothing Nothing undefined

score game = if state game == Won then player game * (-1024) else
(-1) * sum [(board game)!i | i <- range bnds]

omitWith op ((g, ns):nss) = let
omit pot [] = []
omit pot ((g, ns):nss) | or $map (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, map snd $minimize' k) | k <- kids] maximize = last . maximize' minimize' :: Tree Game -> [(Game, Int)] minimize' (Node leaf []) = [(undefined, score leaf)] minimize' (Node _ kids) = omitWith (>=)$
[(rootLabel k, map snd $maximize' k) | k <- kids] best game ms = lastMove$ fst $maximize$ prune 4 $Node game (map (gameTree . move game) ms) gameTree = unfoldTree (\x -> (x, nextNodes x)) nextMoves game = if state game == Play then [(i, dst) | i <- range bnds, (board game)!i == player game, dst <- movesFrom i game] else [] nextNodes game = map (move game)$ nextMoves game

prune 0 (Node a _) = Node a []
prune n (Node a kids) = Node a $map (prune (n - 1)) kids box :: Int -> Int -> Int -> Int -> Picture () -- Why is this needed? box x y dx dy = fill$ rect (fromIntegral x, fromIntegral y) (fromIntegral (x+dx), fromIntegral (y+dy))

sqColor False = RGB 191 191 191
sqColor True  = RGB 255 255 255

drawB pic x y = draw pic (fromIntegral x, fromIntegral y)

playerName   1  = "White"
playerName (-1) = "Black"

movesFrom (x, y) game = let
b = board game
p = player game
in [i1 | dx <- [-1, 0, 1], let i1 = (x + dx, y - p), inRange bnds i1, b!i1 /= p, dx /= 0 || b!i1 == 0]

move game (i0, i1@(_, y1)) = let
p = player game
nextBoard = board game // [(i0, 0), (i1, p)]
nextState = if (p == 1 && y1 == 0) || (p == -1 && y1 == 7) then Won else Play
in Game nextBoard nextState (if nextState == Won then p else -p) Nothing Nothing (i0, i1)

shuffleIO [] = return []
shuffleIO xs = getStdRandom (randomR (0, length xs - 1)) >>= \n ->
let (a, b:bs) = splitAt n xs in (b:) <$> shuffleIO (a ++ bs) main = withElems ["canvas", "message"]$ \[canvasE, msg] -> do
Just canvas <- fromElem canvasE
whitePiece <- createCanvas sz sz
renderOnTop whitePiece $color (RGB 255 255 255)$ fill $circle (20, 20) 10 renderOnTop whitePiece$ color (RGB 0 0 0) $stroke$ circle (20, 20) 11
blackPiece <- createCanvas sz sz
renderOnTop blackPiece $color (RGB 0 0 0)$ fill $circle (20, 20) 11 fromCan <- createCanvas sz sz render fromCan$ color (RGB 127 15 15) $sequence_ [ box 0 0 5 40, box 0 0 40 5, box 35 0 40 40, box 0 35 40 40 ] toCan <- createCanvas sz sz render toCan$ color (RGBA 0 191 0 0.3) $box 0 0 sz sz boardCan <- createCanvas 320 320 sequence_$ [renderOnTop boardCan $color (sqColor (mod (x + y) 2 == 0))$ box (x*sz) (y*sz) sz sz | (x, y) <- range bnds]
buf <- createCanvas 320 320

ev <- newEmptyMVar
void $canvasE onEvent MouseDown$ \m ->
concurrent $putMVar ev$ Mo $mouseCoords m void$ documentBody onEvent KeyDown $\k -> concurrent$ putMVar ev $Ke$ keyCode k

let
renderPiece c p (x,y) = renderOnTop c $draw (if p == 1 then whitePiece else blackPiece) (fromIntegral x, fromIntegral y) drawGame game = do sequence_$ (render buf $draw boardCan (0, 0)) : [renderPiece buf p (x*sz, y*sz) | i@(x, y) <- range bnds, let p = (board game)!i, p /= 0] render canvas$ draw buf (0, 0)
setProp msg "innerHTML" $playerName (player game) ++ case state game of Play -> " to move" Won -> " wins" loop game = if isNothing$ anim game then let sel0 = selection game in do
e <- takeMVar ev
case e of
Mo (bx, by) -> when (state game == Play) $let i@(x, y) = (div bx sz, div by sz) sel = if (board game)!i == player game then Just i else Nothing in when (inRange bnds i)$ do
render canvas $draw buf (0, 0) if sel0 == Nothing then do unless (sel == Nothing)$ do
renderOnTop canvas $drawB fromCan (x*sz) (y*sz) sequence_ [renderOnTop canvas$
drawB toCan (x1*sz) (y1*sz) | (x1, y1) <- movesFrom i game]
loop game { selection = sel }
else if i elem movesFrom (fromJust sel0) game then
loop game { anim = Just (0, (fromJust sel0, i)) }
else
loop game { selection = Nothing }
Ke 113 -> drawGame initGame >> loop initGame
_ -> loop game

else let Just (frame, m@((x0, y0), (x1, y1))) = anim game in
if frame == 8 then let game1 = move game m in do
drawGame game1
if state game1 == Play && player game1 == -1 then do
wait 1  -- Delay for redraw.
ms <- liftIO $shuffleIO$ nextMoves game1
loop game1 { anim = Just (0, best game1 ms) }
else
loop game1
else let f x0 x1 frame = x0 * sz + (x1 - x0) * sz * frame div 8 in do
drawGame game { board = board game // [((x0, y0), 0)] }
renderPiece canvas (player game) (f x0 x1 frame, f y0 y1 frame)
void $setTimer (Once 20)$ loop game { anim = Just (frame + 1, m) }

concurrent $forkIO$ drawGame initGame >> loop initGame


Ben Lynn blynn@cs.stanford.edu 💡