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
scorePositionusing the state monad? See [Line 63 inPosition.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
