Created
October 10, 2019 16:32
-
-
Save peterszerzo/22b063ba5b155bb0ca4baec648d4679a to your computer and use it in GitHub Desktop.
Tic-tac-toe in Haskell
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module TicTacToe where | |
import Control.Monad.State | |
import Data.Char | |
import Data.List | |
import qualified Data.Map as Map | |
import Data.Maybe | |
import qualified System.Process as Process | |
-- Cell | |
data Cell = X | O deriving (Eq, Ord) | |
-- Coord | |
data Coord = | |
C11 | |
| C12 | |
| C13 | |
| C21 | |
| C22 | |
| C23 | |
| C31 | |
| C32 | |
| C33 deriving (Eq, Ord) | |
nextCoord :: Coord -> Coord | |
nextCoord C11 = C12 | |
nextCoord C12 = C13 | |
nextCoord C13 = C21 | |
nextCoord C21 = C22 | |
nextCoord C22 = C23 | |
nextCoord C23 = C31 | |
nextCoord C31 = C32 | |
nextCoord C32 = C33 | |
nextCoord C33 = C11 | |
nextCoordToEmpty :: Grid -> Coord -> Coord | |
nextCoordToEmpty grid coord = | |
let | |
next = nextCoord coord | |
in | |
case Map.lookup next grid of | |
Just _ -> | |
nextCoordToEmpty grid next | |
Nothing -> | |
next | |
-- Grid | |
type Grid = Map.Map Coord Cell | |
initGrid :: Grid | |
initGrid = Map.empty | |
isGridFull :: Grid -> Bool | |
isGridFull = (==) 9 . Map.size | |
-- Game state | |
data Game = | |
Game | |
{ grid :: Grid | |
, cursor :: Coord | |
} | |
initGame :: Game | |
initGame = Game initGrid C11 | |
winner :: Grid -> Maybe (Maybe Cell) | |
winner grid = | |
case (winnerHelper winningCellCombinations grid, isGridFull grid) of | |
(Just mark, _) -> | |
Just (Just mark) | |
(Nothing, True) -> | |
Just Nothing | |
_ -> | |
Nothing | |
winnerHelper :: [[Coord]] -> Grid -> Maybe Cell | |
winnerHelper [] _ = Nothing | |
winnerHelper (head:tail) grid = maybe (winnerHelper tail grid) id $ extractIfAllIdentical $ fmap (flip Map.lookup $ grid) $ head | |
winningCellCombinations :: [[Coord]] | |
winningCellCombinations = | |
[ -- rows | |
[ C11, C12, C13 ] | |
, [ C21, C22, C23 ] | |
, [ C31, C32, C33 ] | |
-- columns | |
, [ C11, C21, C31 ] | |
, [ C12, C22, C32 ] | |
, [ C13, C23, C33 ] | |
-- diagonals | |
, [ C11, C22, C33 ] | |
, [ C31, C22, C13 ] | |
] | |
-- Update game | |
data Msg = Mark | Move | |
updateGame :: Msg -> Game -> Game | |
updateGame msg (Game grid cursor) = | |
case msg of | |
Mark -> | |
let | |
newGrid = (Map.insert cursor (currentMark grid) grid) | |
in | |
Game newGrid (nextCoordToEmpty newGrid cursor) | |
Move -> | |
Game grid (nextCoordToEmpty grid cursor) | |
currentMark :: Grid -> Cell | |
currentMark grid = | |
case rem (Map.size grid) 2 of | |
0 -> X | |
_ -> O | |
winnerText :: Maybe (Maybe Cell) -> String | |
winnerText cell = | |
case cell of | |
Just (Just X) -> "X wins" | |
Just (Just O) -> "O wins" | |
Just Nothing -> "Tie" | |
Nothing -> "Game is on" | |
-- View | |
viewGame :: Game -> String | |
viewGame (Game grid cursor) = | |
foldl (++) "" | |
. intersperse "\n" | |
. fmap (foldl (++) "" . fmap (viewCell cursor grid)) | |
$ [ | |
[ C11, C12, C13 ], | |
[ C21, C22, C23 ], | |
[ C31, C32, C33 ] | |
] | |
viewCell :: Coord -> Grid -> Coord -> String | |
viewCell cursor grid coord = | |
case (cursor == coord, Map.lookup coord grid) of | |
(True, _) -> "[*]" | |
(False, Just X) -> "[X]" | |
(False, Just O) -> "[O]" | |
(False, Nothing) -> "[ ]" | |
-- Entry point | |
main :: IO () | |
main = | |
mainWithState initGame | |
mainWithState :: Game -> IO () | |
mainWithState game = do | |
Process.system "clear" | |
winner <- return $ winner (grid game) | |
putStrLn $ padText 2 $ foldl (++) "" $ intersperse "\n" $ | |
[ "Tic Tac Toe" | |
, "" | |
, winnerText winner | |
, "" | |
, padText 2 $ viewGame game | |
, "" | |
, "[space+enter] - draw mark" | |
, "[m+enter] - move cursor" | |
, "[x+enter] - exit" | |
, "[r+enter] - new game" | |
] | |
guess <- getChar | |
case (winner, guess) of | |
(Just _, 'r') -> mainWithState initGame | |
(Nothing, ' ') -> mainWithState (updateGame Mark game) | |
(Nothing, 'm') -> mainWithState (updateGame Move game) | |
(_, 'x') -> return () | |
_ -> mainWithState game | |
-- Helpers | |
extractIfAllIdentical :: (Eq a) => [a] -> Maybe a | |
extractIfAllIdentical = extractIfAllIdenticalHelper Nothing | |
extractIfAllIdenticalHelper :: (Eq a) => Maybe a -> [a] -> Maybe a | |
extractIfAllIdenticalHelper res [] = res | |
extractIfAllIdenticalHelper res (head:tail) = | |
case res of | |
Just val -> | |
if val == head then extractIfAllIdenticalHelper res tail else Nothing | |
Nothing -> | |
extractIfAllIdenticalHelper (Just head) tail | |
padText :: Int -> String -> String | |
padText colPad = | |
foldl (++) "" | |
. intersperse "\n" | |
. fmap (\line -> replicate colPad ' ' ++ line) | |
. lines |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment