import Data.List (intersperse, transpose)
import Text.PrettyPrint.Boxes
-----------------------------------------------------------------------
-- Tic Tac Toe
-- X: computer, O: player
data Player = X | O
deriving (Eq, Show)
-- Board: 1 2 3
-- 4 5 6
-- 7 8 9
--
-- Left n: square number n has not been played yet
-- Right X|O: square has been played already
type Square = Either Int Player
type Board = [[Square]]
-- A position consists of
-- * current board
-- * player next up to place a stone
data Position = Position Board Player
showSquare :: Square -> String
showSquare = either show show
showBoard :: Board -> [String]
showBoard = frame "┌─┬─┬─┐" "├─┼─┼─┤" "└─┴─┴─┘" .
map (concat . frame "│" "│" "│" . map showSquare)
where
-- frame l m r [x₁, x₂, x₃] → [l, x₁, m, x₂, m, x₃, r]
frame :: a -> a -> a -> [a] -> [a]
frame l m r xs = [l] ++ intersperse m xs ++ [r]
instance Show Position where
show (Position b _) = unlines (showBoard b)
-----------------------------------------------------------------------
initial :: Position
initial = Position (map (map Left) [[1,2,3],[4,5,6],[7,8,9]]) O
-- |
-- next (i.e. first) move to be made by O (player)
-- List of game positions reachable from current position pos
moves :: Position -> [Position]
moves pos@(Position b _) = map (move pos) (openSquares b)
where
-- List of squares on board b that a player could still occupy
openSquares :: Board -> [Square]
openSquares b = [ Left sq | Left sq <- concat b ]
-- New game position if player p occupies square sq on board b
move :: Position -> Square -> Position
move (Position b p) sq = Position (map (map (place sq p)) b) (next p)
-- Player p wants to occupy open square sq: how would square sq' change?
place :: Square -> Player -> Square -> Square
place sq p sq' | sq == sq' = Right p
place _ _ sq' = sq'
next :: Player -> Player
next X = O
next O = X
-- Static evaluation of position p: has computer (X) won the game?
-- 1: X won the game
-- -1: O won the game
-- 0: game still undecided
static :: Position -> Int
static (Position b p) = if won b then case p of
X -> -1
O -> 1
else 0
where
-- Does board b represent a winning constellation?
won :: Board -> Bool
won b = any full (diagonals b ++ rows b ++ cols b)
-- Are these squares occupied by the same player?
full :: [Square] -> Bool
full [Right p1, Right p2, Right p3] = p1 == p2 && p2 == p3
full _ = False
-- The two diagonals, three rows, three columns of board p
diagonals, rows, cols :: Board -> [[Square]]
diagonals [[a1, _,a3],
[ _,b2, _],
[c1, _,c3]] = [[a1,b2,c3], [a3,b2,c1]]
rows = id
cols = transpose
-----------------------------------------------------------------------
-- A game tree is just a rose tree
-- ▢ ← current position p
-- ├----▢ ⎫
-- │ ⎬ ← positions after all possible moves from p
-- └----▢ ⎭
data Tree a = Node a [Tree a]
deriving Show
-----------------------------------------------------------------------
-- Box-based pretty printing (see Text.PrettyPrint.Boxes)
-- A class of types a that can be rendered as a box
class Boxable a where
box :: a -> Box
instance Boxable Int where
box x = text (show x)
instance Boxable Position where
box (Position b _) = vcat top (map text (showBoard b))
instance (Boxable a, Boxable b) => Boxable (a,b) where
box (x,y) = box x <+> box y
instance Boxable a => Boxable (Tree a) where
-- ▢
-- ├----▢
-- │
-- └----▢
box (Node x []) = box x
box (Node x ts) =
vcat top ([box x] -- ▢ ← alignment
++ --
map (\b -> stem (rows b) <> b) -- ├----▢
(init branches) -- ├----▢
++ --
[char '└' <> last branches]) -- └----▢
where
-- Add branches to list of boxes [▢,▢,...]:
-- [ ----▢, ----▢, ...]
branches :: [Box]
branches = map (\t -> text "---- " <> box t) ts
-- ├ ← alignment
-- │ ⎫
-- │ ⎬ height n
-- │ ⎭
stem :: Int -> Box
stem n = vcat top (char '├' : replicate n (char '│'))
-----------------------------------------------------------------------
-- John Hughes: see "Why Functional Programming Matters", Section 5
-- Generator: can generate the complete game tree
repTree :: (a -> [a]) -> a -> Tree a
repTree f x = Node x (map (repTree f) (f x))
-- The complete game tree (if explored fully)
gameTree :: Position -> Tree Position
gameTree p = repTree moves p
-- Cut off game subtrees whenever a winning/losing position
-- has been reached
cutOff :: Tree Int -> Tree Int
cutOff (Node 0 ts) = Node 0 (map cutOff ts)
cutOff (Node x _) = Node x []
-- mapTree f t: map f over the nodes of tree t (⚠︎ Tree is a Functor)
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
-- prune n t: cut off tree t at depth n
prune :: Int -> Tree a -> Tree a
prune 0 (Node x _) = Node x []
prune n (Node x ts) = Node x (map (prune (n - 1)) ts)
-----------------------------------------------------------------------
-- Sample subtree in which X can force a win
-- (maximize aGameTree == 1)
--
-- whose turn?
-- X O X
-- ↓ ↓ ↓
-- 0
-- ├---- 0
-- │ └---- -1
-- │
-- ├---- 0
-- │ ├---- 0
-- │ │ └---- 1
-- │ │
-- │ └---- 0
-- │ └---- 1
-- │
-- └---- 0
-- ├---- -1
-- │
-- └---- 0
-- └---- 1
aGameTree :: Tree Int
aGameTree = Node 0 [Node 0 [Node (-1) []],
Node 0 [Node 0 [Node 1 []],
Node 0 [Node 1 []]],
Node 0 [Node (-1) [],
Node 0 [Node 1 []]]]
maximize, minimize :: Ord a => Tree a -> a
maximize (Node x []) = x
maximize (Node _ ts) = maximum (map minimize ts)
-- | |
-- we will take the assume opponent (O) will take his best move
-- best move possible (= the worst move from our perspective)
minimize (Node x []) = x
minimize (Node _ ts) = minimum (map maximize ts)
-- evaluate a position from the viewpoint of the computer (X)
--
-- modular specification thanks to lazy evaluation
evaluate :: Position -> Int
evaluate = maximize . cutOff . mapTree static . gameTree
-----------------------------------------------------------------------
-- Optional optimization
-- (alpha-beta algorithm)
--
-- ℓ
-- ↓
-- max
-- ├---- min
-- │ └---- 1⌑
-- │ │
-- │ └---- 1⌑
-- │
-- └---- min
-- ├---- 0⌖
-- │
-- ├---- ? ← We're looking for the maximal minimum which will
-- │ at least be 1 (see ⌑). Due to 0 (see ⌖), this minimum
-- └---- ? ← will be 0 or less ⇒ need not know value of the '?'
--
-- - Need a formulation that can see all lists in layer ℓ at once
-- (list of lists, see `[[a]] in `mapmin`/`mapmax` below)
maximize', minimize' :: Ord a => Tree a -> [a]
maximize' (Node x []) = [x]
maximize' (Node _ ts) = mapmin (map minimize' ts)
where
mapmin :: Ord a => [[a]] -> [a]
mapmin (xs:xss) = minimum xs : omit (minimum xs) xss
-- |
-- largest minimum found so far (pot)
-- we're only interested in the maximal minimum, so
-- omit the minimum computation for those lists xs in which we find
-- any element that does not exceed pot (the largest minimum found so far);
-- finding such an element (with `any') does not need to inspect all
-- elements in xs => savings thanks to lazy evaluation
omit :: Ord a => a -> [[a]] -> [a]
omit pot [] = []
omit pot (xs:xss) | any (<= pot) xs = omit pot xss
| otherwise = minimum xs : omit (minimum xs) xss
minimize' (Node x []) = [x]
minimize' (Node _ ts) = mapmax (map maximize' ts)
where
mapmax :: Ord a => [[a]] -> [a]
mapmax (xs:xss) = maximum xs : omit (maximum xs) xss
omit pot [] = []
omit pot (xs:xss) | any (>= pot) xs = omit pot xss
| otherwise = maximum xs : omit (maximum xs) xss
-- evaluate a position from the viewpoint of the computer (X),
-- NB: no pruning necessary, can evaluate full game tree
evaluate' :: Position -> Int
evaluate' = maximum . maximize' . cutOff . mapTree static . gameTree
-----------------------------------------------------------------------
main :: IO ()
main = do
print initial
-- printBox $ box $ prune 3 $ gameTree initial
-- increase pruning depth to 6 (= 6 stones played) to see the first
-- boards in which the computer (X) can win
-- main = printBox $ box $ prune 6 $ mapTree static $ gameTree initial
-- looks only five moves ahead, will yield 0 (nobody's won yet)
--main = print $ evaluate initial
-- can look ahead until game's end (efficient evaluate'), will yield 1
-- (computer X can win)
--main = print $ evaluate' initial