Tic Tac Toe in Haskell - Barry Van Tassell

Main.hs

module Main (main) where

-- build-depends: base, containers, mtl

import qualified Data.List as L
import Data.Maybe (fromJust)
import Data.Char (digitToInt, toLower)
import qualified Control.Monad.State.Lazy as S

----------------------
-- Types, constants --
----------------------

-- identifies a player, or a player's mark on the board. can be "Empty"
data Player = X | O | Empty deriving (Show)

-- a single play/move represented by (position, marker)
type Move = (Int, Player)

-- X wins is (Just X), tie is (Just Empty), not done is (Nothing)
type GameResult = Maybe Player

-- Each square has a list of possible "win conditions" it participates in.
-- Scores are calculated by adding up each player's possible win conditions (points).
-- Eg. A player with a total of 3 "H1" squares has a full horizontal row, and wins.
data Point = H1 | H2 | H3 | V1 | V2 | V3 | D1 | D2 deriving (Show, Eq, Enum, Ord)

-- assoc list mapping each square with the win conditions it participates in.
-- Eg. the top-left square (0) can assist in winning via the top row (H1) left column (V1)
-- or the "backslash" diagonal (D1).
-- TODO: this should be a Data.Map instead of assoc list
scoreValues :: [(Int, [Point])]
scoreValues = [ (0,[H1,V1,D1]), (1,[H1,V2]),       (2,[H1,V3,D2])
              , (3,[H2,V1]),    (4,[H2,V2,D1,D2]), (5,[H2,V3])
              , (6,[H3,V1,D2]), (7,[H3,V2]),       (8,[H3,V3,D1])
              ]

-- The game state: the board and intermediate player win status.
-- Board state is stored as a[n] historic list of performed moves.
data GameState = GameState { move_hist :: [Move] 
                           , x_score   :: [Point]
                           , o_score   :: [Point]
                           } 
                           deriving (Show)

newState :: GameState
newState = GameState [] [] []
    

--------------------
-- Business logic --
--------------------

main :: IO ()
main = do
    let state = newState

    result <- fromJust <$> gameLoop X state
    case result of
        Empty -> putStrLn "\nIt's a tie!"
        p -> putStrLn $ "\nPlayer " ++ colorSquare p (map toLower $ show p) ++ " wins!"


-- recursive "loop" that queries players, runs stateful operations
gameLoop :: Player -> GameState -> IO GameResult
gameLoop Empty  _     = return Nothing
gameLoop player state = do

    -- get available plays/moves
    let available = S.evalState getAvailableMoves state

    -- show board, query player
    putStrLn "" -- for newline
    printBoard state
    putStrLn $ colorBlue "\n[Player " 
            ++ colorSquare player (map toLower $ show player)
            ++ colorBlue "] Choose: " 
            ++ colorBlue (show available)
    putStr $ colorBlue "> "

    choice <- digitToInt <$> getChar -- crashes if not digit. TODO: catch exception

    -- check input, recurse if wrong
    if choice `notElem` available
    then putStrLn (colorBlue "\nInvalid choice\n") >> gameLoop player state
    else do
        putStrLn "" -- for newline

        -- perform move
        let (result, newstate) = S.runState (playOnce (choice, player)) state

        -- recurse for next player if game not done
        case result of 
            Just p -> printBoard newstate >> return (Just p)
            Nothing -> 
                case player of
                X -> gameLoop O newstate
                O -> gameLoop X newstate

------------------------
-- Stateful functions --
------------------------

-- perform a single move and update/check score
playOnce :: Move -> S.State GameState GameResult
playOnce move = do
    moves <- move_hist <$> S.get
    S.modify (\s-> s{move_hist = move:moves})
    addPoints move
    scoreGame

-- update score state
addPoints :: Move -> S.State GameState ()
addPoints move = do
    x_points <- x_score <$> S.get
    o_points <- o_score <$> S.get
    let new_points = fromJust $ L.lookup (fst move) scoreValues
    case snd move of
        X     -> S.modify' (\s-> s{x_score = new_points++x_points})
        O     -> S.modify' (\s-> s{o_score = new_points++o_points})
        Empty -> return ()
        
-- check score state and report game completion status
scoreGame :: S.State GameState GameResult
scoreGame = do
    x_val <- pointsToScore . x_score <$> S.get
    o_val <- pointsToScore . o_score <$> S.get
    moves <- move_hist <$> S.get
    if      x_val == 3        then return $ Just X -- X wins
    else if o_val == 3        then return $ Just O -- O wins
    else if length moves == 9 then return $ Just Empty -- tie
    else                           return Nothing -- game not over yet

-- which squares are left un-marked?
getAvailableMoves :: S.State GameState [Int]
getAvailableMoves = ([0..8] L.\\) <$> map fst <$> move_hist <$> S.get

-- transform Point list into an actual score (pure)
pointsToScore :: [Point] -> Int
pointsToScore points = if null points then 0
    else L.maximum $ map length $ L.group $ L.sort points


---------------------------
-- output, visualization --
---------------------------

colorSquare :: Player -> String -> String
colorSquare X     s = colorGreen s
colorSquare O     s = colorRed s
colorSquare Empty s = colorWhite s

colorGreen :: String -> String
colorGreen s = "\ESC[92m"++s++"\ESC[0m"

colorRed :: String -> String
colorRed s = "\ESC[31m"++s++"\ESC[0m"

colorBlue :: String -> String
colorBlue s = "\ESC[94m"++s++"\ESC[0m"

colorWhite :: String -> String
colorWhite s = "\ESC[97m"++s++"\ESC[0m"

printBoard :: GameState -> IO ()
printBoard state = 
    let
        moves = move_hist state

        disp _ (Just p) = " " ++ colorSquare p (map toLower (show p))  ++ " "
        disp n _        = colorWhite $ " " ++ show n ++ " "

        horiz = replicate 11 '-'

        prepRow :: [String] -> String
        prepRow = L.intercalate "|"

        splitRows :: [String] -> [[String]]
        splitRows [] = []
        splitRows xs = take 3 xs : splitRows (drop 3 xs)

        createBoard = [disp i $ L.lookup i moves | i <- [0..8]]
    in
        mapM_ putStrLn $ L.intersperse horiz $ map prepRow $ splitRows createBoard