8
\$\begingroup\$

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

\$\endgroup\$
3
  • 1
    \$\begingroup\$ 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. \$\endgroup\$
    – pedrofurla
    Nov 21 at 1:15
  • \$\begingroup\$ @pedrofuria what are options guards? \$\endgroup\$ Nov 21 at 2:10
  • \$\begingroup\$ guards with two branchs \$\endgroup\$
    – pedrofurla
    Nov 21 at 15:18
1
\$\begingroup\$

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.