module Data.TicTacToe.Board
(
EmptyBoard
, Board
, FinishedBoard
, empty
, getResult
, Move(..)
, (-?->)
, MoveResult
, foldMoveResult
, keepPlayingOr
, keepPlaying
, TakeBack(..)
, TakenBack
, foldTakenBack
, takenBackBoard
, BoardLike(..)
, printEachPosition
) where
import Prelude hiding (any, all, concat, foldr)
import Data.TicTacToe.Position
import Data.TicTacToe.Player
import Data.TicTacToe.GameResult
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Foldable
import Data.List(intercalate)
import Data.Maybe
data EmptyBoard =
EmptyBoard
class Move from to | from -> to where
(-->) ::
Position
-> from
-> to
infixr 5 -->
instance Move EmptyBoard Board where
p --> _ =
[(p, player1)] `Board` M.singleton p player1
instance Move Board MoveResult where
p --> b@(Board q m) =
let w = whoseTurn b
(j, m') = M.insertLookupWithKey (\_ x _ -> x) p w m
wins =
[
(NW, W , SW)
, (N , C , S )
, (NE, E , SE)
, (NW, N , NE)
, (W , C , E )
, (SW, S , SE)
, (NW, C , SE)
, (SW, C , NE)
]
allEq (d:e:t) = d == e && allEq (e:t)
allEq _ = True
isWin = any (\(a, b, c) -> any allEq $ mapM (`M.lookup` m') [a, b, c]) wins
isDraw = all (`M.member` m') [minBound ..]
b' = Board ((p, w):q) m'
in maybe (if isWin
then
GameFinished (b' `FinishedBoard` win w)
else
if isDraw
then
GameFinished (b' `FinishedBoard` draw)
else
KeepPlaying b') (const PositionAlreadyOccupied) j
(-?->) ::
Position
-> MoveResult
-> MoveResult
p -?-> r =
keepPlayingOr r (\b -> p --> b) r
infixr 5 -?->
data MoveResult =
PositionAlreadyOccupied
| KeepPlaying Board
| GameFinished FinishedBoard
deriving Eq
foldMoveResult ::
a
-> (Board -> a)
-> (FinishedBoard -> a)
-> MoveResult
-> a
foldMoveResult occ _ _ PositionAlreadyOccupied =
occ
foldMoveResult _ kp _ (KeepPlaying b) =
kp b
foldMoveResult _ _ gf (GameFinished b) =
gf b
keepPlayingOr ::
a
-> (Board -> a)
-> MoveResult
-> a
keepPlayingOr def kp =
foldMoveResult def kp (const def)
keepPlaying ::
MoveResult
-> Maybe Board
keepPlaying (KeepPlaying b) =
Just b
keepPlaying _ =
Nothing
instance Show MoveResult where
show PositionAlreadyOccupied = "*Position already occupied*"
show (KeepPlaying b) = concat ["{", show b, "}"]
show (GameFinished b) = concat ["{{", show b, "}}"]
class TakeBack to from | to -> from where
takeBack ::
to
-> from
instance TakeBack FinishedBoard Board where
takeBack (FinishedBoard (Board ((p, _):t) m) _) =
Board t (p `M.delete` m)
takeBack (FinishedBoard (Board [] _) _) =
error "Broken invariant: board-in-play with empty move list. This is a program bug."
data TakenBack =
TakeBackIsEmpty
| TakeBackIsBoard Board
deriving Eq
foldTakenBack ::
a
-> (Board -> a)
-> TakenBack
-> a
foldTakenBack e _ TakeBackIsEmpty =
e
foldTakenBack _ k (TakeBackIsBoard b) =
k b
takenBackBoard ::
TakenBack
-> Maybe Board
takenBackBoard =
foldTakenBack Nothing Just
instance TakeBack Board TakenBack where
takeBack (Board (_:[]) _) =
TakeBackIsEmpty
takeBack (Board ((p, _):t) m) =
TakeBackIsBoard (Board t (p `M.delete` m))
takeBack (Board [] _) =
error "Broken invariant: board-in-play with empty move list. This is a program bug."
data Board =
Board [(Position, Player)] !(M.Map Position Player)
deriving Eq
instance Show Board where
show b@(Board _ m) =
intercalate " " [showPositionMap m, "[", show (whoseTurn b), "to move ]"]
data FinishedBoard =
FinishedBoard Board GameResult
deriving Eq
getResult ::
FinishedBoard
-> GameResult
getResult (FinishedBoard _ r) =
r
instance Show FinishedBoard where
show (FinishedBoard (Board _ m) r) =
let summary = gameResult (\p -> show p ++ " wins") "draw" r
in intercalate " " [showPositionMap m, "[[", summary, "]]"]
empty ::
EmptyBoard
empty =
EmptyBoard
printEachPosition ::
(Position -> String)
-> IO ()
printEachPosition k =
let z = ".===.===.===."
lines = [
z
, concat ["| ", k NW, " | ", k N , " | ", k NE, " |"]
, z
, concat ["| ", k W , " | ", k C , " | ", k E , " |"]
, z
, concat ["| ", k SW, " | ", k S , " | ", k SE, " |"]
, z
]
in forM_ lines putStrLn
class BoardLike b where
whoseTurn ::
b
-> Player
whoseTurn =
alternate . whoseNotTurn
whoseNotTurn ::
b
-> Player
whoseNotTurn =
alternate . whoseTurn
isEmpty ::
b
-> Bool
occupiedPositions ::
b
-> S.Set Position
moves ::
b
-> Int
isSubboardOf ::
b
-> b
-> Bool
isProperSubboardOf ::
b
-> b
-> Bool
playerAt ::
b
-> Position
-> Maybe Player
playerAtOr ::
b
-> Position
-> Player
-> Player
playerAtOr b p q =
q `fromMaybe` playerAt b p
isOccupied ::
b
-> Position
-> Bool
isOccupied b p =
isJust $ playerAt b p
isNotOccupied ::
b
-> Position
-> Bool
isNotOccupied b p =
not (isOccupied b p)
printBoard ::
b
-> IO ()
instance BoardLike EmptyBoard where
whoseTurn _ =
player1
isEmpty _ =
True
occupiedPositions _ =
S.empty
moves _ =
0
isSubboardOf _ _ =
True
isProperSubboardOf _ _ =
False
playerAt _ _ =
Nothing
printBoard _ =
printEachPosition (pos M.empty " ")
instance BoardLike Board where
whoseTurn (Board [] _) =
player1
whoseTurn (Board ((_, q):_) _) =
alternate q
isEmpty _ =
False
occupiedPositions (Board _ m) =
M.keysSet m
moves (Board _ m) =
M.size m
isSubboardOf (Board _ m) (Board _ m') =
m `M.isSubmapOf` m'
isProperSubboardOf (Board _ m) (Board _ m') =
m `M.isProperSubmapOf` m'
playerAt (Board _ m) p =
p `M.lookup` m
printBoard (Board _ m) =
printEachPosition (pos m " ")
instance BoardLike FinishedBoard where
isEmpty (FinishedBoard b _) =
isEmpty b
occupiedPositions (FinishedBoard b _) =
occupiedPositions b
moves (FinishedBoard b _) =
moves b
isSubboardOf (FinishedBoard b _) (FinishedBoard b' _) =
b `isSubboardOf` b'
isProperSubboardOf (FinishedBoard b _) (FinishedBoard b' _) =
b `isProperSubboardOf` b'
playerAt (FinishedBoard b _) p =
b `playerAt` p
printBoard (FinishedBoard b _) =
printBoard b
pos ::
Ord k =>
M.Map k Player
-> String
-> k
-> String
pos m empty p =
maybe empty (return . toSymbol) (p `M.lookup` m)
showPositionMap ::
M.Map Position Player
-> String
showPositionMap m =
let pos' = pos m "?"
in concat [ ".=", pos' NW, "=.=", pos' N , "=.=", pos' NE
, "=.=", pos' W , "=.=", pos' C , "=.=", pos' E
, "=.=", pos' SW, "=.=", pos' S , "=.=", pos' SE, "=."
]