Haskell Tic Tac Toe with CLI and Gloss GUI

Board.hs

module Board where

import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.List (intercalate)

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

newtype Board = Board (Map (Int, Int) (Maybe Player))
    deriving (Eq, Ord)

initBoard :: Board
initBoard = Board $ Map.fromList [((x, y), Nothing) | x <- [0..2], y <- [0..2]]

getMark :: Board -> (Int, Int) -> Maybe Player
getMark (Board board) (x, y)
    | x < 0 || x > 2 || y < 0 || y > 2 = error "Invalid coordinates"
    | otherwise = board ! (x, y)

putMark :: Board -> Player -> (Int, Int) -> Maybe Board
putMark (Board board) player (x, y)
    | x < 0 || x > 2 || y < 0 || y > 2 = error $ "Invalid coordinates" ++ show (x, y)
    | board ! (x, y) /= Nothing = Nothing
    | otherwise = Just $ Board $ Map.insert (x, y) (Just player) board

emptySquares :: Board -> [(Int, Int)]
emptySquares (Board board) = [(x, y) | x <- [0..2], y <- [0..2], board ! (x, y) == Nothing]

instance Show Board where
    show (Board board) = 
        intercalate "\n- - - \n" 
            [ ( intercalate "|" [prettyShow $ board ! (x, y) | y <- [0..2]] ) 
                | x <- [0..2]]
            where
                prettyShow Nothing = " "
                prettyShow (Just X) = "X"
                prettyShow (Just O) = "O"

allX :: Board
allX = Board $ Map.fromList [((x, y), Just X) | x <- [0..2], y <- [0..2]]

allO :: Board
allO = Board $ Map.fromList [((x, y), Just O) | x <- [0..2], y <- [0..2]]

GameCLI.hs

module GameCLI where

import Control.Monad.State
import Control.Concurrent
import qualified Data.Map as Map

import Board 
import Position

getCoordinates :: IO (Int, Int)
getCoordinates = do
  putStrLn "Enter coordinates (row, column):"
  row <- getLine
  column <- getLine
  pure (read row, read column)

getPlayerMove :: Position -> IO Position
getPlayerMove pos@(Position board player) = do
  move <- getCoordinates
  case putMark board player move of
      Nothing -> do
          putStrLn "Please Try Again"
          getPlayerMove pos
      Just newBoard -> pure (Position newBoard (nextPlayer player))

gameLoop :: Position -> KnowledgeBase -> IO ()
gameLoop pos@(Position board player) kb = do
    case (boardWinner board) of
        Just X -> putStrLn "X Wins!"
        Just O -> putStrLn "O Wins!"
        Nothing -> do
            nextPos <- getPlayerMove pos
            threadDelay 1000000
            let (nextPos', newKB) = runState (bestResponse nextPos) kb
            putStrLn "Computer's move:"
            print $ curBoard nextPos'
            gameLoop nextPos' newKB



main :: IO ()
main = do
    putStrLn "Welcome to the game of Tic Tac Toe!"
    putStrLn "Enter your name: "
    name <- getLine
    putStrLn $ "Hello " ++ name ++ ", let's play!"
    print initBoard
    gameLoop (Position initBoard X) Map.empty

GlossUI.hs

module GlossUI where

import Data.Map (Map)
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.State
import Control.Applicative
import Graphics.Gloss
import Graphics.Gloss.Interface.Pure.Game
import Debug.Trace

import Board
import Position

-- copying some code from https://gist.github.com/gallais/0d61677fe97aa01a12d5

data GameState = GameState {
      pos :: Position
    , kb :: KnowledgeBase
    , playersTurn :: Bool
    , needToEval :: Bool
    }
    deriving Show

type Size = Float

resize :: Size -> Path -> Path
resize k = fmap (\ (x, y) -> (x * k, y * k))

drawO :: Size -> (Int, Int) -> Picture
drawO k (i, j) =
  let x' = k * (fromIntegral j - 1)
      y' = k * (1 - fromIntegral i)
  in color (greyN 0.8) $ translate x' y' $ thickCircle (0.1 * k) (0.3 * k)

drawX :: Size -> (Int, Int) -> Picture
drawX k (i, j) =
  let x' = k * (fromIntegral j - 1)
      y' = k * (1 - fromIntegral i)
  in color black $ translate x' y' $ Pictures
     $ fmap (polygon . resize k)
     [ [ (-0.35, -0.25), (-0.25, -0.35), (0.35,0.25), (0.25, 0.35) ]
     , [ (0.35, -0.25), (0.25, -0.35), (-0.35,0.25), (-0.25, 0.35) ]
     ]

drawBoard :: Size -> Board -> Picture
drawBoard k b = Pictures $ grid : markPics where

  markPics = [drawAt (i, j) (getMark b (i, j)) | i <- [0..2], j <- [0..2]]

  drawAt :: (Int, Int) -> (Maybe Player) -> Picture
  drawAt (_, _) Nothing = Blank
  drawAt (i, j) (Just X) = drawX k (i, j)
  drawAt (i, j) (Just O) = drawO k (i, j)

  grid :: Picture
  grid = color black $ Pictures $ fmap (line . resize k)
       [ [(-1.5, -0.5), (1.5 , -0.5)]
       , [(-1.5, 0.5) , (1.5 , 0.5)]
       , [(-0.5, -1.5), (-0.5, 1.5)]
       , [(0.5 , -1.5), (0.5 , 1.5)]
       ]

checkCoordinateY :: Size -> Float -> Maybe Int
checkCoordinateY k f' =
  let f = f' / k
  in  2    <$ guard (-1.5 < f && f < -0.5)
  <|> 1    <$ guard (-0.5 < f && f < 0.5)
  <|> 0    <$ guard (0.5  < f && f < 1.5)

checkCoordinateX :: Size -> Float -> Maybe Int
checkCoordinateX k f' =
  let f = f' / k
  in  0    <$ guard (-1.5 < f && f < -0.5)
  <|> 1    <$ guard (-0.5 < f && f < 0.5)
  <|> 2    <$ guard (0.5  < f && f < 1.5)

getCoordinates :: Size -> (Float, Float) -> Maybe (Int, Int)
getCoordinates k (x, y) =
  (,) <$> checkCoordinateY k y <*> checkCoordinateX k x

gameUpdate' :: Size -> Event -> GameState -> GameState
gameUpdate' _ e gs
  | playersTurn gs == False || needToEval gs = gs
gameUpdate' k (EventKey (MouseButton LeftButton) Down _ (x', y')) gs =
    let newBoard = do 
            (i, j) <- getCoordinates k (x', y')
            putMark (curBoard $ pos gs) (curPlayer $ pos gs) (i, j)
    in case newBoard of
        Nothing -> gs
        Just b' -> gs { pos = Position { 
                              curBoard = b'
                            , curPlayer = nextPlayer (curPlayer $ pos gs) 
                            }
                      , playersTurn = False
                      , needToEval = True
                      }
gameUpdate' _ _ gs = gs

gameTime :: Float -> GameState -> GameState
-- let the player move
gameTime _ gs
  | playersTurn gs && not (needToEval gs) = gs
-- check if player has won
gameTime t gs
  | (needToEval gs) =
      case (boardWinner $ curBoard $ pos gs) of
        Just X -> gs { pos = (pos gs) { curBoard = allX } }
        Just O -> gs { pos = (pos gs) { curBoard = allO } }
        Nothing -> gs { needToEval = False }
-- make computers move
gameTime _ gs =
    let (pos', kb') = runState (bestResponse $ pos gs) (kb gs)
    in GameState {pos = pos', kb = kb', playersTurn = True, needToEval = True}

initGameState :: GameState
initGameState = 
  GameState {
      pos = Position {
        curBoard = initBoard
      , curPlayer = X
      }
    , kb = Map.empty
    , playersTurn = True
    , needToEval = False
    }

main :: IO ()
main =
  let window = InWindow "Tic Tac Toe" (300, 300) (10, 10)
      size   = 100.0
  in play 
        window 
        white 
        1 
        initGameState
        (\ gs -> drawBoard size $ curBoard $ pos gs) 
        (gameUpdate' size) 
        gameTime

Position.hs

module Position where

import Control.Applicative
import Control.Monad.State
import Data.Maybe 
import Data.Map (Map)
import Data.List (minimumBy)
import qualified Data.Map as Map

import Board 

data Position = Position { curBoard :: Board, curPlayer :: Player }
    deriving (Eq, Ord, Show)

type Line = [(Int, Int)]

winningLines :: [Line]
winningLines = [ [(x, y) | x <- [0..2]] | y <- [0..2]] ++ -- vertical lines
               [ [(x, y) | y <- [0..2]] | x <- [0..2]] ++ -- horizontal lines
               [[(0, 0), (1, 1), (2, 2)], -- main diagonal
                [(0, 2), (1, 1), (2, 0)]] -- off diagonal 

lineWinner :: Board -> Line -> Maybe Player
lineWinner b l
    | all (== Just X) marks = Just X
    | all (== Just O) marks = Just O
    | otherwise = Nothing 
    where 
       marks = map (getMark b) l 

boardWinner :: Board -> Maybe Player
boardWinner b = foldr (<|>) Nothing $ map (lineWinner b) winningLines

nextPlayer :: Player -> Player
nextPlayer X = O
nextPlayer O = X

succPositions :: Position -> [Position]
succPositions (Position b p) = newPosition . fromJust . markSquare <$> (emptySquares b)
    where
        newPosition b' = Position { curBoard = b', curPlayer = nextPlayer p }
        markSquare = putMark b p

isDraw :: Board -> Bool
isDraw b = null (emptySquares b) && isNothing (boardWinner b)

data Label = Win | Lose | Draw
    deriving (Show, Eq)
data Score = Score { label :: Label, height :: Int }
    deriving (Show, Eq)

instance Ord Score where
    (Score Win i) <= (Score Win j) = i >= j
    (Score Win _) <= _ = False
    (Score Lose i) <= (Score Lose j) = i <= j
    (Score Lose _) <= _  = True
    (Score Draw i) <= (Score Draw j) = i >= j
    (Score Draw _) <= (Score Win _) = True 
    (Score Draw _) <= (Score Lose _) = False

type KnowledgeBase = Map Position Score

scorePosition :: Position -> State KnowledgeBase Score
scorePosition pos@(Position b p)
    | isDraw b = pure $ Score { label = Draw, height = 0 }
    | (boardWinner b) == Just p = pure $ Score { label = Win, height = 0 }
    | Just _ <- (boardWinner b) = pure $ Score { label = Lose, height = 0 }
scorePosition pos@(Position b p) = 
    do
        knowledge <- gets (Map.lookup pos)
        case knowledge of
            Just s -> return s
            Nothing -> do
                let nextPositions = succPositions pos
                nextScores <- mapM scorePosition nextPositions
                let bestSuccScore = minimum nextScores
                let score = curScore bestSuccScore
                modify (Map.insert pos score)
                return score

bestResponse :: Position -> State KnowledgeBase Position
bestResponse pos@(Position b p) = 
    do
        let nextPositions = succPositions pos
        nextScores <- mapM scorePosition nextPositions
        let bestSucc = snd $ minimumBy (\(s1, p1) (s2, p2) -> compare s1 s2) $ zip nextScores nextPositions
        return bestSucc

-- given the minimum score among the successors,
-- compute the current score
curScore :: Score -> Score
curScore (Score Win i) = Score Lose (i + 1)
curScore (Score Lose i) = Score Win (i + 1)
curScore (Score Draw i) = Score Draw (i + 1)

fabulous, up and running. thank you

have you ever beaten "the machine"?

Happy to help.

No, you cannot beat the machine. The machine calculates the winning move and always either forces a draw or a win. You can read the bestResponse function in the code above to see how it does it.

@andrepadez if you are still interested, I invite you to check out lectures 6 and 7 in here

@Agnishom thank you so much. I think i'll follow the course