Tic Tac Toe in Haskell - finished?

yujiri8 profile image Ryan Westlund ・4 min read

I posted an early implementation of this before and it was pretty popular, so I got around to implementing some AI and stuff! Hope it's not considered too spammy to post about this again.

import Data.List
import Data.Maybe
import Text.Read
import System.Random

data State = X | O | Blank deriving (Eq, Read)
type Board = [[State]]
type MoveSource = Board -> IO (Int, Int)

instance Show State where
  show X = "X"
  show O = "O"
  show Blank = " "

showBoard :: Board -> String
showBoard board =
    let printedRows = map (\row -> (show $ row !! 0) ++ "|" ++ (show $ row !! 1) ++ "|" ++ (show $ row !! 2)) board
    in (intercalate "\n-----\n" printedRows) ++ "\n"

board = [[Blank, Blank, Blank], [Blank, Blank, Blank], [Blank, Blank, Blank]]

main = do
  (winner, finalState) <- playGame humanMove (aiMove O) board X
  putStrLn "\nGame over!"
  putStr $ showBoard finalState
  if winner /= Blank
    then putStrLn $ "\nWinner:" ++ show winner
    else putStrLn "Draw."

humanMove :: MoveSource
humanMove board = do
  putStr $ showBoard board
  putStr "Enter row/col (1-3):"
  line <- getLine
  let rowMaybe = readMaybe (line !! 0 :"") :: Maybe Int
      colMaybe = readMaybe (line !! 1 :"") :: Maybe Int
  if rowMaybe == Nothing || colMaybe == Nothing
    then do
      putStrLn "Bad input. Try again."
      humanMove board
    else do
      let row = (fromJust rowMaybe) - 1
          col = (fromJust colMaybe) - 1
      if (row < 0) || (row > 2) || (col < 0) || (col > 2)
        then do
          putStrLn "Bad coords. Try again."
          humanMove board
        else do
          if not $ checkState board Blank (row, col)
            then do
              putStrLn $ (show (row, col)) ++ "is taken:"
              putStr (showBoard board)
              putStrLn "Spot taken. Try again."
              humanMove board
            else pure (row, col)

aiMove :: State -> MoveSource
aiMove symbol board =
  let instaWin = canWin board symbol
      instaLose = canWin board (if symbol == O then X else O)
      options = openSpaces board
  in case instaWin of
    Just instaWin -> pure instaWin
    Nothing ->
      case instaLose of
        Just instaLose -> pure instaLose
        Nothing -> do
          i <- randomRIO (0, length options)
          pure $ options !! i

playGame :: MoveSource -> MoveSource -> Board -> State -> IO (State, Board)
playGame xMoveSource oMoveSource board currentTurn = do
  move <- if currentTurn == X
    then xMoveSource board
    else oMoveSource board
  let nextTurn = if currentTurn == X then O else X
      newBoard = makeMove move currentTurn board
  if gameOver newBoard /= Nothing
    then pure $ (fromJust $ gameOver newBoard, newBoard)
    else playGame xMoveSource oMoveSource newBoard nextTurn

makeMove :: (Int, Int) -> State -> Board -> Board
makeMove (row, col) state board =
  let oldrow = board !! row
      newrow = editList oldrow col state
  in editList board row newrow

gameOver :: Board -> Maybe State
gameOver board =
  let xWon = any id $ fmap (checkPattern board X) waysToWin
      oWon = any id $ fmap (checkPattern board O) waysToWin
      draw = all id $ fmap (\row -> all id $ fmap (/= Blank) row) board
  if xWon
    then Just X
    else if oWon
      then Just O
      else if draw
        then Just Blank
        else Nothing

-- a generic helper to update a list item in-place
editList :: [a] -> Int -> a -> [a]
editList list i new = (take i list) ++ new : (drop (i+1) list)

-- checks whether each of a list of positions is in a given state
checkPattern :: Board -> State -> [(Int, Int)] -> Bool
checkPattern board state pattern =
  all id $ fmap (checkState board state) pattern

checkState :: Board -> State -> (Int, Int) -> Bool
checkState board state coord =
  let row = board !! (fst coord)
      slot = row !! (snd coord)
  in slot == state

waysToWin = [
  [(0,0), (0,1), (0,2)],
  [(1,0), (1,1), (1,2)],
  [(2,0), (2,1), (2,2)],
  [(0,0), (1,0), (2,0)],
  [(0,1), (1,1), (2,1)],
  [(0,2), (1,2), (2,2)],
  [(0,0), (1,1), (2,2)],
  [(0,2), (1,1), (2,0)]]

allSpaces = [(row, col) | row <- [0..2], col <- [0..2]]

openSpaces board = filter (checkState board Blank) allSpaces

wouldWin :: Board -> State -> (Int, Int) -> Bool
wouldWin board state move =
  let hypotheticalBoard = makeMove move state board
      result = gameOver hypotheticalBoard
  in result == Just state

canWin :: Board -> State -> Maybe (Int, Int)
canWin board state =
  let outcomes = (\move -> (move, wouldWin board state move)) <$> (openSpaces board)
      winningMoves = filter snd outcomes
  in if not $ null winningMoves
    then Just $ fst (winningMoves !! 0)
    else Nothing

To be honest, it took me about an hour to get the canWin stuff implemented properly. My initial approach involved not having wouldWin as a separate function, and I got thrown off for a while by needing to recall which move led to the winning state found. As you can see, I ended up using the lambda in let outcomes to pack it into a tuple (not really a solution I'm fond of). In fact the unreadability of my early attempts to solve that problem were what led me to think of putting out wouldWin. I also remembered that <$> exists as an infix synonym for fmap. I like it more.

I don't think I'll be putting more work into this project unless someone has refactor suggestions, but I feel like I've gained a real increase in ability from it.

I do regret the decision to use row, col instead of x, y. Not sure what possessed me to do that. But w/e.

On another note, I feel like this has decreased my appreciation for the value of automatic currying. There were still some places where I ended up having to use lambdas anyway, and evenin the cases I eliminated them it didn't seem like as much as improvement as I expected. Like in the filter snd outcomes case. I used to have filter (\(move, result) -> result) outcomes, but at the same time, I feel like the old way was clearer. IDK.

Posted on by:

yujiri8 profile

Ryan Westlund


I'm a programmer, writer, and philosopher. My Github account is yujiri8; all my content besides code is at yujiri.xyz.


markdown guide