Tic-Tac-Toe MinMax in Haskell

minmax.hs

module MinMax where

import Data.List (minimumBy)

 -- a game of tic-tac-toe
--- load this file in ghci, and enter
--- 'ticTacToe' in the prompt

type Token = Char

data Row = Row Token Token Token
data Board = Board Row Row Row

instance Show Row where
    show (Row x y z) = [x] ++ "|" ++ [y] ++ "|" ++ [z]

instance Show Board where
    show (Board r1 r2 r3) = "\n"        ++
                            show r1     ++
                            "\n-----\n" ++
                            show r2     ++
                            "\n-----\n" ++
                            show r3     ++
                            "\n"

ticTacToe :: IO ()
ticTacToe = (humanPlay . cpuPlay) newBoard

rowMoves :: Row -> Token -> [Row]
rowMoves row tok = (playM row) ++ (playL row) ++ (playR row)
    where playL (Row ' ' y z) = [Row tok y z]
          playL _             = []
          playM (Row x ' ' z) = [Row x tok z]
          playM _             = []
          playR (Row x y ' ') = [Row x y tok]
          playR _             = []

moves :: Board -> Token -> [Board]
moves (Board r1 r2 r3) tok = b2 ++ b1 ++ b3
    where b1 = fmap (\r -> Board r r2 r3) $ rowMoves r1 tok
          b2 = fmap (\r -> Board r1 r r3) $ rowMoves r2 tok
          b3 = fmap (\r -> Board r1 r2 r) $ rowMoves r3 tok

utility :: Board -> Float
utility board@(Board _ (Row _ middle _) _)
    | win == 'X'    =  1.0
    | win == 'O'    = -1.0
    | middle == 'X' =  0.5
    | middle == 'O' = -0.5
    | otherwise     =  0.0
    where win = winpos board

cpuPlay :: Board -> Board
cpuPlay board = bestMove
    where plays           = fmap (\b -> (minmax b, b)) $ moves board circle
          (_,bestMove)    = minimumBy cmp plays
          cmp (x,_) (y,_) = compare x y

humanPlay :: Board -> IO ()
humanPlay board = do
    putBoard board
    if winpos board /= empty then do
        if isTie board then do
            putStrLn "O ties with X!"
        else do
            putStrLn "O wins!"
    else do
        pos <- readPos board
        let newBoard = place board pos
        if winpos newBoard /= empty then do
            if isTie newBoard then do
                putStrLn "O ties with X!"
            else do
                putStrLn "X wins!"
        else do
            (humanPlay . cpuPlay) newBoard

readPos :: Board -> IO (Int, Int)
readPos board = do
    putStr "Where will you play (x, y)? "
    move <- getLine
    let coords@(x, y) = read move :: (Int, Int)
    if x < 0 || x > 2 || y < 0 || y > 2 || inPos board (x, y) then do
        putStrLn "Invalid position..."
        readPos board
    else return coords

inPos :: Board -> (Int, Int) -> Bool
inPos (Board (Row t1 t2 t3) (Row t4 t5 t6) (Row t7 t8 t9)) (x, y)
    | x == 0 && y == 0 = t1 /= empty
    | x == 1 && y == 0 = t2 /= empty
    | x == 2 && y == 0 = t3 /= empty
    | x == 0 && y == 1 = t4 /= empty
    | x == 1 && y == 1 = t5 /= empty
    | x == 2 && y == 1 = t6 /= empty
    | x == 0 && y == 2 = t7 /= empty
    | x == 1 && y == 2 = t8 /= empty
    | x == 2 && y == 2 = t9 /= empty

place :: Board -> (Int, Int) -> Board
place (Board (Row t1 t2 t3) (Row t4 t5 t6) (Row t7 t8 t9)) (x, y)
    | x == 0 && y == 0 = Board (Row cross t2 t3) (Row t4 t5 t6) (Row t7 t8 t9)
    | x == 1 && y == 0 = Board (Row t1 cross t3) (Row t4 t5 t6) (Row t7 t8 t9)
    | x == 2 && y == 0 = Board (Row t1 t2 cross) (Row t4 t5 t6) (Row t7 t8 t9)
    | x == 0 && y == 1 = Board (Row t1 t2 t3) (Row cross t5 t6) (Row t7 t8 t9)
    | x == 1 && y == 1 = Board (Row t1 t2 t3) (Row t4 cross t6) (Row t7 t8 t9)
    | x == 2 && y == 1 = Board (Row t1 t2 t3) (Row t4 t5 cross) (Row t7 t8 t9)
    | x == 0 && y == 2 = Board (Row t1 t2 t3) (Row t4 t5 t6) (Row cross t8 t9)
    | x == 1 && y == 2 = Board (Row t1 t2 t3) (Row t4 t5 t6) (Row t7 cross t9)
    | x == 2 && y == 2 = Board (Row t1 t2 t3) (Row t4 t5 t6) (Row t7 t8 cross)

isTie :: Board -> Bool
isTie (Board r1 r2 r3) = rowNotNull r1 && rowNotNull r2 && rowNotNull r3
    where rowNotNull (Row t1 t2 t3) = t1 /= empty && t2 /= empty && t3 /= empty

minmax :: Board -> Float
minmax = minval 2.0 . (\board -> moves board circle)

minval :: Float -> [Board] -> Float
minval s = foldr (\b bs -> min (maxval (utility b) $ moves b cross) bs) s

maxval :: Float -> [Board] -> Float
maxval s = foldr (\b bs -> max (minval (utility b) $ moves b circle) bs) s

winpos :: Board -> Token
winpos (Board (Row t1 t2 t3) (Row t4 t5 t6) (Row t7 t8 t9))
    | t1 == t2 && t2 == t3 = t1 -- horizontal
    | t4 == t5 && t5 == t6 = t4
    | t7 == t8 && t8 == t9 = t7
    | t1 == t4 && t4 == t7 = t1 -- vertical
    | t2 == t5 && t5 == t8 = t2
    | t3 == t6 && t6 == t9 = t3
    | t1 == t5 && t5 == t9 = t1 -- diagonal
    | t3 == t5 && t5 == t7 = t3
    | otherwise            = empty

newBoard :: Board
newBoard = Board emptyRow emptyRow emptyRow
    where emptyRow = Row empty empty empty

putBoard :: Board -> IO ()
putBoard = (\(_:board) -> putStr board) . show

cross :: Token
cross = 'X'

circle :: Token
circle = 'O'

empty :: Token
empty = ' '