module Game.Halma.Board
( HalmaGrid (..)
, sideLength, numberOfFields
, HalmaDirection (..)
, oppositeDirection
, leftOf
, rowsInDirection
, corner
, Team
, startCorner, endCorner
, startFields, endFields
, Piece (..)
, HalmaBoard, getGrid, toMap, fromMap
, lookupHalmaBoard
, Move (..)
, movePiece
, initialBoard
) where
import Control.Monad (unless)
import Data.Aeson ((.=), (.:))
import Data.List (sort)
import Data.Maybe (fromJust)
import Data.Word (Word8)
import GHC.Generics (Generic)
import qualified Data.Aeson as A
import qualified Data.Map.Strict as M
import qualified Math.Geometry.Grid as Grid
import qualified Math.Geometry.GridInternal as Grid
import qualified Math.Geometry.Grid.Hexagonal as HexGrid
import qualified Math.Geometry.Grid.HexagonalInternal as HexGrid
data HalmaGrid
= SmallGrid
| LargeGrid
deriving (Eq, Show, Ord)
instance A.ToJSON HalmaGrid where
toJSON grid =
case grid of
SmallGrid -> "SmallGrid"
LargeGrid -> "LargeGrid"
instance A.FromJSON HalmaGrid where
parseJSON =
A.withText "HalmaGrid" $ \case
"SmallGrid" -> pure SmallGrid
"LargeGrid" -> pure LargeGrid
_other -> fail "expected string 'SmallGrid' or 'LargeGrid'"
sideLength :: HalmaGrid -> Int
sideLength grid =
case grid of
SmallGrid -> 5
LargeGrid -> 6
numberOfFields :: HalmaGrid -> Int
numberOfFields grid =
case grid of
SmallGrid -> 121
LargeGrid -> 181
data HalmaDirection
= North
| Northeast
| Southeast
| South
| Southwest
| Northwest
deriving (Eq, Show, Read, Ord, Bounded, Enum, Generic)
instance A.ToJSON HalmaDirection where
toJSON dir =
case dir of
North -> "N"
Northeast -> "NE"
Southeast -> "SE"
South -> "S"
Southwest -> "SW"
Northwest -> "NW"
instance A.FromJSON HalmaDirection where
parseJSON =
A.withText "HalmaDirection" $ \text ->
case text of
"N" -> pure North
"NE" -> pure Northeast
"SE" -> pure Southeast
"S" -> pure South
"SW" -> pure Southwest
"NW" -> pure Northwest
_ -> fail "expected a Halma direction (one of N, NE, SE, S, SW, NW)"
oppositeDirection :: HalmaDirection -> HalmaDirection
oppositeDirection dir =
case dir of
North -> South
South -> North
Northeast -> Southwest
Southwest -> Northeast
Northwest -> Southeast
Southeast -> Northwest
leftOf :: HalmaDirection -> HalmaDirection
leftOf dir =
case dir of
North -> Northwest
Northwest -> Southwest
Southwest -> South
South -> Southeast
Southeast -> Northeast
Northeast -> North
getDirs :: HalmaDirection -> (HexGrid.HexDirection, HexGrid.HexDirection)
getDirs dir =
case dir of
North -> (HexGrid.Northwest, HexGrid.Northeast)
South -> (HexGrid.Southwest, HexGrid.Southeast)
Northeast -> (HexGrid.Northeast, HexGrid.East)
Northwest -> (HexGrid.Northwest, HexGrid.West)
Southeast -> (HexGrid.Southeast, HexGrid.East)
Southwest -> (HexGrid.Southwest, HexGrid.West)
neighbour' :: HexGrid.HexDirection -> (Int, Int) -> (Int, Int)
neighbour' dir = fromJust . flip (Grid.neighbour HexGrid.UnboundedHexGrid) dir
rowsInDirection :: HalmaDirection -> (Int, Int) -> Int
rowsInDirection dir =
cramerPlus (neighbour' dir1 (0,0)) (neighbour' dir2 (0,0))
where
(dir1, dir2) = getDirs dir
cramerPlus (a,b) (c,d) (x,y) =
let det = a*d b*c
in det * (x*(db) + y*(ac))
corner :: HalmaGrid -> HalmaDirection -> (Int, Int)
corner halmaGrid direction = (sl*x, sl*y)
where
(d1, d2) = getDirs direction
sl = sideLength halmaGrid 1
(x, y) = neighbour' d1 $ neighbour' d2 (0, 0)
instance Grid.Grid HalmaGrid where
type Index HalmaGrid = (Int, Int)
type Direction HalmaGrid = HexGrid.HexDirection
indices halmaGrid =
filter (Grid.contains halmaGrid) roughBoard
where
sl = sideLength halmaGrid 1
roughBoard = Grid.indices (HexGrid.hexHexGrid (2*sl + 1))
neighbours = Grid.neighboursBasedOn HexGrid.UnboundedHexGrid
distance = Grid.distanceBasedOn HexGrid.UnboundedHexGrid
directionTo = Grid.directionToBasedOn HexGrid.UnboundedHexGrid
contains halmaGrid (x, y) = atLeastTwo (test x) (test y) (test z)
where
z = x + y
test i = abs i <= sl
sl = sideLength halmaGrid 1
atLeastTwo True True _ = True
atLeastTwo True False True = True
atLeastTwo False True True = True
atLeastTwo _ _ _ = False
instance Grid.FiniteGrid HalmaGrid where
type Size HalmaGrid = HalmaGrid
size = id
maxPossibleDistance = \case
SmallGrid -> 16
LargeGrid -> 20
instance Grid.BoundedGrid HalmaGrid where
tileSideCount _ = 6
type Team = HalmaDirection
startCorner :: HalmaGrid -> Team -> (Int, Int)
startCorner = corner
endCorner :: HalmaGrid -> Team -> (Int, Int)
endCorner halmaGrid = corner halmaGrid . oppositeDirection
startFields :: HalmaGrid -> Team -> [(Int, Int)]
startFields halmaGrid team = filter ((<= 4) . dist) (Grid.indices halmaGrid)
where dist = Grid.distance halmaGrid (startCorner halmaGrid team)
endFields :: HalmaGrid -> Team -> [(Int, Int)]
endFields halmaGrid = startFields halmaGrid . oppositeDirection
data Piece
= Piece
{ pieceTeam :: Team
, pieceNumber :: Word8
} deriving (Show, Eq, Ord)
instance A.ToJSON Piece where
toJSON piece =
A.object
[ "team" .= A.toJSON (pieceTeam piece)
, "number" .= A.toJSON (pieceNumber piece)
]
instance A.FromJSON Piece where
parseJSON =
A.withObject "Piece" $ \o -> do
team <- o .: "team"
number <- o .: "number"
unless (1 <= number && number <= 15) $
fail "pieces must have a number between 1 and 15!"
pure Piece { pieceTeam = team, pieceNumber = number }
data HalmaBoard =
HalmaBoard
{ getGrid :: HalmaGrid
, toMap :: M.Map (Int, Int) Piece
} deriving (Eq, Show)
instance A.ToJSON HalmaBoard where
toJSON board =
A.object
[ "grid" .= A.toJSON (getGrid board)
, "occupied_fields" .= map fieldToJSON (M.assocs (toMap board))
]
where
fieldToJSON ((x, y), piece) =
A.object
[ "x" .= x
, "y" .= y
, "piece" .= A.toJSON piece
]
instance A.FromJSON HalmaBoard where
parseJSON =
A.withObject "HalmaGrid size" $ \o -> do
grid <- o .: "grid"
fieldVals <- o .: "occupied_fields"
fieldsMap <- M.fromList <$> mapM parseFieldFromJSON fieldVals
case fromMap grid fieldsMap of
Just board -> pure board
Nothing ->
fail "the JSON describing the occupied fields violates some invariant!"
where
parseFieldFromJSON =
A.withObject "field" $ \o -> do
x <- o .: "x"
y <- o .: "y"
piece <- o .: "piece"
pure ((x, y), piece)
fromMap
:: HalmaGrid
-> M.Map (Grid.Index HalmaGrid) Piece
-> Maybe HalmaBoard
fromMap halmaGrid m =
if invariantsHold then
Just (HalmaBoard halmaGrid m)
else
Nothing
where
invariantsHold = indicesCorrect && rightTeamPieces
list = M.toList m
indicesCorrect = all (Grid.contains halmaGrid . fst) list
allTeams = [minBound..maxBound]
rightTeamPieces = all rightNumberOfTeamPieces allTeams
rightNumberOfTeamPieces team =
let teamPieces = filter ((== team) . pieceTeam) (map snd list)
in null teamPieces || sort teamPieces == map (Piece team) [1..15]
lookupHalmaBoard :: (Int, Int) -> HalmaBoard -> Maybe Piece
lookupHalmaBoard p = M.lookup p . toMap
data Move
= Move
{ moveFrom :: (Int, Int)
, moveTo :: (Int, Int)
} deriving (Show, Eq)
instance A.ToJSON Move where
toJSON move =
A.object
[ "from" .= coordsToJSON (moveFrom move)
, "to" .= coordsToJSON (moveTo move)
]
where
coordsToJSON (x, y) = A.object [ "x" .= x, "y" .= y ]
instance A.FromJSON Move where
parseJSON =
A.withObject "Move" $ \o -> do
from <- parseCoordsFromJSON =<< o .: "from"
to <- parseCoordsFromJSON =<< o .: "to"
pure Move { moveFrom = from, moveTo = to }
where
parseCoordsFromJSON =
A.withObject "(Int, Int)" $ \o ->
(,) <$> o .: "x" <*> o .: "y"
movePiece
:: Move
-> HalmaBoard
-> Either String HalmaBoard
movePiece Move { moveFrom = startPos, moveTo = endPos } (HalmaBoard halmaGrid m) =
case M.lookup startPos m of
Nothing -> Left "cannot make move: start position is empty"
Just piece ->
case M.lookup endPos m of
Just otherPiece ->
Left $
"cannot make move: end position is occupied by team " ++
show (pieceTeam otherPiece)
Nothing ->
let m' = M.insert endPos piece (M.delete startPos m)
in Right (HalmaBoard halmaGrid m')
initialBoard :: HalmaGrid -> (Team -> Bool) -> HalmaBoard
initialBoard halmaGrid chosenTeams = HalmaBoard halmaGrid (M.fromList lineUps)
where
allTeams = [minBound..maxBound]
lineUps = concatMap lineUp allTeams
mkPiece team number position =
(position, Piece { pieceTeam = team, pieceNumber = number })
lineUp team =
if chosenTeams team
then zipWith (mkPiece team) [1..15] (startFields halmaGrid team)
else []