Tic tac toe from chapter 11 of Programming in Haskell – Hutton 2nd edition

tictactoe.hs

import Data.Char
import Data.List
import System.IO
import System.Random (randomRIO)


-- Basic declarations

size :: Int
size = 4

type Grid = [[Player]]

data Player = O | B | X
              deriving (Eq, Ord, Show)


-- Example winning grid
-- [[B,O,O],[O,X,O],[X,X,X]] :: Grid

next :: Player -> Player
next O = X
next X = O
next B = B

-- Grid utils

empty :: Grid
empty = replicate size (replicate size B)

full :: Grid -> Bool
full = all (/= B) . concat

-- we assume player O goes first
turn :: Grid -> Player
turn g = if os <= xs then O else X
  where
    os = length (filter (== O) ps)
    xs = length (filter (== X) ps)
    ps = concat g

winninglength :: Int
winninglength = 3

groups :: Int -> [Player] -> [[Player]] 
groups _ [] = [[]]
groups n xs = [take n xs'] ++  groups n (drop n xs)
              where xs' = if ((length xs) >= n) then xs else []


consecutive :: Int -> Player -> [Player] -> Bool
consecutive n p xs = or (map (all (== p)) (filter (\x -> not (null x)) (groups n xs)))

wins :: Player -> Grid -> Bool
wins p g = any line (rows ++ cols ++ dias)
  where
    line = consecutive winninglength p
    rows = g
    cols = transpose g
    dias = [diag g, diag (map reverse g)]

diag :: Grid -> [Player]
diag g = [g !! n !! n | n <- [0..size-1]]

won :: Grid -> Bool
won g = wins O g || wins X g

-- Display grid

cls :: IO ()
cls = putStr "\ESC[2J"

goto :: (Int,Int) -> IO ()
goto (x,y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")

putGrid :: Grid -> IO ()
putGrid = putStrLn . unlines . concat . interleave bar . map showRow
  where bar = [replicate ((size*4)-1) '-']

showRow :: [Player] -> [String]
showRow = beside . interleave bar . map showPlayer
  where
    beside = foldr1 (zipWith (++))
    bar    = replicate 3 "|"

showPlayer :: Player -> [String]
showPlayer O = ["   ", " O ", "   "]
showPlayer B = ["   ", "   ", "   "]
showPlayer X = ["   ", " X ", "   "]

interleave :: a -> [a] -> [a]
interleave x []     = []
interleave x [y]    = [y]
interleave x (y:ys) = y : x : interleave x ys

-- Making a move

valid :: Grid -> Int -> Bool
valid g i = 0 <= i && i < size ^ 2 && concat g !! i == B

move :: Grid -> Int -> Player -> [Grid]
move g i p =
    if valid g i then [chop size (xs ++ [p] ++ ys)] else []
    where (xs,B:ys) = splitAt i (concat g)

chop :: Int -> [a] -> [[a]]
chop n [] = []
chop n xs = take n xs : chop n (drop n xs)


-- Reading a number 

getNat :: String -> IO Int
getNat prompt = do 
    putStr prompt
    xs <- getLine
    if xs /= [] && all isDigit xs then
        return (read xs)
    else
        do putStrLn "ERROR: Invalid number"
           getNat prompt

-- Human vs human
tictactoe :: IO ()
tictactoe = run empty O

run :: Grid -> Player -> IO ()
run g p = do
    cls
    goto (1,1)
    putGrid g
    run' g p

run' :: Grid -> Player -> IO ()
run' g p | wins O g = putStrLn "Player O wins!\n"
         | wins X g = putStrLn "Player X wins!\n"
         | full g   = putStrLn "It's a draw!\n"
         | otherwise = 
            do i <- getNat (prompt p)
               case move g i p of
                  [] -> do putStrLn "Error: Invalid move"
                           run' g p
                  [g'] -> run g' (next p)

prompt :: Player -> String
prompt p = "Player " ++ show p ++ ", enter your move:"

-- Game Trees

data Tree a = Node a [Tree a]
              deriving Show

gametree :: Grid -> Player -> Tree Grid
gametree g p = Node g [gametree g' (next p) | g' <- moves g p]

moves :: Grid -> Player -> [Grid]
moves g p | won g = []
          | full g = []
          | otherwise = concat [move g i p | i <- [0..((size^2)-1)]]

-- Tree pruning

prune :: Int -> Tree a -> Tree a
prune 0 (Node x _) = Node x []
prune n (Node x ts) = Node x [prune (n-1) t | t <- ts]

depth :: Int
depth = 4

-- minimax algorithm
minimax :: Tree Grid -> Tree (Grid, Player)
minimax (Node g []) | wins O g  = Node (g,O) []
                    | wins X g  = Node (g,X) []
                    | otherwise = Node (g,B) []
minimax (Node g ts) | turn g == O = Node (g, minimum ps) ts'
                    | turn g == X = Node (g, maximum ps) ts'
                      where
                        ts' = map minimax ts
                        ps = [p | Node (_, p) _ <- ts']

bestmoves :: Grid -> Player -> [Grid]
bestmoves g p = [g | (g,d) <- bestGrids, d == minTreeDepth]
               where
                 tree             = prune depth (gametree g p)
                 Node (_,best) ts = minimax tree
                 bestGrids        = [(g', minimum (if (null ts') then [0] else map treedepth ts')) | (Node (g', p') ts') <- ts, p' == best]
                 minTreeDepth     = minimum [d | (_,d) <- bestGrids]


                 
main :: IO ()
main = do hSetBuffering stdout NoBuffering
          putStr "Do you wish to play first? (y/n)"
          x <- getChar
          getChar
          putChar '\n'
          if x == 'y' then
            play empty O O
          else 
            play empty O X

play :: Grid -> Player -> Player -> IO ()
play g p h = do cls
                goto (1,1)
                putGrid g
                play' g p h

play' :: Grid -> Player -> Player -> IO ()
play' g p h
  | wins O g  = putStrLn "Player O wins!\n"
  | wins X g  = putStrLn "Player X wins!\n"
  | full g    = putStrLn "It's a draw!\n"
  | p == h    = do i <- getNat (prompt p)
                   case move g i p of 
                     [] -> do putStrLn "Error: Invalid move"
                              play' g p h
                     [g'] -> play g' (next p) h
  | otherwise = do putStr ("Player " ++ show (next h) ++ " is thinking...")
                   let gs = bestmoves g p
                   n <- randomRIO (0, (length gs) - 1)
                   play (gs !! n) (next p) h
                    
treesize :: Tree a -> Int
treesize (Node _ nodes) = 1 + sum (map treesize nodes) 

treedepth :: Tree a -> Int
treedepth (Node _ []) = 0
treedepth (Node _ nodes) = 1 + maximum (map treedepth nodes)