Haskell Tic-Tac-Toe (with automation and GUI)

Question

There are already many Tic Tac Toe posts. But as far as I can tell, none of the ones in Haskell are complete with a GUI

Here is my implementation with Gloss. Gist Link for convenience

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]]

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)

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

I would like some feedback on the following:

• Is the best way to implement the scorePosition using the state monad? See [Line 63 in Position.hs]
• In general, is there a better way to implement the mechanism to pick the next move?
• Is there a better way to implement the main UI loop in GlossUI.hs? Or is the way of marking explicit points in the state space the best way?
• Is it a better idea to define the board in some other way in Board.hs?
• Anything else that is worth changing?

---

later edit: I made certain changes to my code. If you are curious, see Link

• pedrofurla: two small tips: gloss has scale, you can use it instead of resize; don't do two options guards, specially if you need to re-evaluate a expression, that's what ifs are meant for.
• Agnishom Chattopadhyay: @pedrofuria what are options guards?
• pedrofurla: guards with two branchs

Answer 1

For tic-tac-toe the efficiency of the scoring function doesn't matter much; you can do exhaustive search (as in your scorePosition) because the search space is very small.

Perhaps you could encode the positions as a product-of-sum type rather than a tuple of integers, which would eliminate a bunch of error checking:

data Coord = C1 | C2 | C3 deriving (Eq, Ord, Show, Enum, Bounded)
type Pos = (Coord, Coord)

Re. code review : your Position and Board modules are very readable.

However for larger games (like chess) you need to prioritize the search schedule.