module Tak.Types (
Board,
Square,
Piece,
Stone(..),
Colour(..),
Play(..),
Dir(..),
Loc,
GameState(..),
Player(..),
stNextPlayer,
Finished(..),
oppositeColour,
squareIndices
) where
import Prelude hiding (concatMap, elem, foldr)
import Data.Foldable
import Data.Hashable
import Data.Matrix hiding (trace)
import GHC.Generics (Generic)
import Text.ParserCombinators.ReadPrec
import Text.Read
type Board = Matrix Square
type Square = [Piece]
type Piece = (Stone, Colour)
data Stone = Cap | Flat | Standing deriving (Eq, Generic, Read, Show)
instance Hashable Stone
data Colour = Black | White deriving (Eq, Generic)
instance Hashable Colour
data Play = Place Stone Loc | Move Loc Dir [Int] deriving (Eq, Read, Show)
data Dir = PosX | NegX | PosY | NegY deriving (Enum, Eq, Read, Show)
type Loc = (Int, Int)
data Player = Player {
capsRemaining :: Int,
stonesRemaing :: Int
} deriving (Generic, Eq, Show)
instance Hashable Player
data GameState = GameState {
stBoard :: Board,
stWhite :: Player,
stBlack :: Player,
stFinished :: Maybe Finished,
stPlaysNext :: Colour,
stNextTurn :: Int
} deriving (Generic, Eq)
instance Show GameState where
show state = show (stBoard state)
++ "White: " ++ show (stWhite state) ++ "\n"
++ "Black: " ++ show (stBlack state) ++ "\n"
++ "Finished: " ++ show (stFinished state) ++ "\n"
++ show (stPlaysNext state) ++ " to play next, in turn "
++ show (stNextTurn state)
instance Hashable Board where
hashWithSalt salt board = foldr (flip hashWithSalt) salt board
instance Hashable GameState where
hashWithSalt salt state =
salt `hashWithSalt` (stPlaysNext state) `hashWithSalt` (stBoard state)
stNextPlayer :: GameState -> Player
stNextPlayer state = case stPlaysNext state of
White -> stWhite state
Black -> stBlack state
data Finished =
RoadWin Colour
| FlatWin Colour Int Int
| Draw Int Int deriving (Eq, Generic, Show)
instance Hashable Finished
instance Read Board where
readPrec = do
rows <- many readRow
let entries = concatMap (splitRow (length rows)) rows
entries' = map (dropWhile (== ' ')) entries
entries'' = map read entries'
return $ fromList (length rows) (length rows) entries''
where
readRow = do
char '('
row <- charsNotIn ")"
char ')'
char '\n'
return row
splitRow count row =
splitRow' ((length row 1) `div` count) count [] row
splitRow' _ 0 entries _ = entries
splitRow' splitPoint count entries row = do
let (entry, rest) = splitAt splitPoint row
splitRow' splitPoint (count 1) (entries ++ [entry]) rest
char :: Char -> ReadPrec ()
char expected = do
c <- get
if c == expected then return () else pfail
many :: ReadPrec a -> ReadPrec [a]
many parser = (many' []) <++ (return []) where
many' sofar = do
a <- parser
(many' (sofar ++ [a])) <++ (return $ sofar ++ [a])
charsNotIn :: String -> ReadPrec String
charsNotIn chars = charsNotIn' "" where
charsNotIn' sofar = do
c <- get
if c `elem` chars
then pfail
else do
(charsNotIn' $ sofar ++ [c]) <++ return (sofar ++ [c])
instance Show Square where
show square = concatMap show square
instance Read Square where
readPrec = readPieces [] <++ return []
where
readPieces sofar = readPieces' sofar <++ return sofar
readPieces' sofar = do
piece <- readPrec
readPieces $ sofar ++ [piece]
instance Show Piece where
show (Flat, colour) = show colour
show (Standing, colour) = "S" ++ show colour
show (Cap, colour) = "C" ++ show colour
instance Read Piece where
readPrec = standing_or_cap <++ flat
where
flat = do
c <- readPrec
return (Flat, c)
standing_or_cap = do
stone <- get
c <- readPrec
case stone of
'S' -> return (Standing, c)
'C' -> return (Cap, c)
_ -> pfail
instance Show Colour where
show Black = "X"
show White = "O"
instance Read Colour where
readPrec = do
c <- get
case c of
'X' -> return Black
'O' -> return White
_ -> pfail
oppositeColour :: Colour -> Colour
oppositeColour Black = White
oppositeColour White = Black
squareIndices :: Matrix a -> [(Int, Int)]
squareIndices board = [(i, j) | i <- [1 .. nrows board], j <- [1 .. ncols board]]