module Game.Halma.Rules
( MoveRestriction (..)
, RuleOptions (..)
, possibleMoves
, hasFinished
) where
import Game.Halma.Board
import Control.Monad (guard)
import Data.Aeson ((.=), (.:))
import Data.Default
import Data.Function (on)
import Data.Maybe (mapMaybe, isJust, isNothing)
import Data.Monoid ((<>))
import Math.Geometry.Grid
import qualified Data.Aeson as A
import qualified Data.Set as S
import qualified Math.Geometry.Grid.HexagonalInternal as HexGrid
data MoveRestriction
= Allowed
| Temporarily
| Forbidden
deriving (Show, Eq)
instance A.ToJSON MoveRestriction where
toJSON moveRestriction =
case moveRestriction of
Allowed -> "allowed"
Temporarily -> "temporarily"
Forbidden -> "forbidden"
instance A.FromJSON MoveRestriction where
parseJSON =
A.withText "MoveRestriction" $ \text ->
case text of
"allowed" -> pure Allowed
"temporarily" -> pure Temporarily
"forbidden" -> pure Forbidden
_ -> fail "expected 'allowed', 'temporarily' or 'forbidden'"
data RuleOptions
= RuleOptions
{ movingBackwards :: MoveRestriction
, invading :: MoveRestriction
} deriving (Show, Eq)
instance A.ToJSON RuleOptions where
toJSON rules =
A.object
[ "moving_backwards" .= A.toJSON (movingBackwards rules)
, "invading" .= A.toJSON (invading rules)
]
instance A.FromJSON RuleOptions where
parseJSON =
A.withObject "RuleOptions" $ \o -> do
bw <- o .: "moving_backwards"
inv <- o .: "invading"
pure RuleOptions { movingBackwards = bw, invading = inv }
instance Default RuleOptions where
def = RuleOptions { movingBackwards = Temporarily, invading = Allowed }
filterForward :: (Int, Int) -> HalmaDirection -> [(Int, Int)] -> [(Int, Int)]
filterForward startPos halmaDir =
filter $ ((>=) `on` rowsInDirection halmaDir) startPos
filterNonInvading :: Team -> HalmaGrid -> [(Int, Int)] -> [(Int, Int)]
filterNonInvading team grid = filter $ \field -> all
((<= sideLength grid 1) . abs . flip rowsInDirection field)
[leftOf team, leftOf (leftOf team)]
possibleStepMoves
:: RuleOptions
-> HalmaBoard
-> (Int, Int)
-> [(Int, Int)]
possibleStepMoves ruleOptions halmaBoard startPos =
case lookupHalmaBoard startPos halmaBoard of
Nothing -> []
Just piece ->
ruleOptsFilters (pieceTeam piece) $
filter ((== Nothing) . flip lookupHalmaBoard halmaBoard) $
neighbours (getGrid halmaBoard) startPos
where
ruleOptsFilters team =
setFilter movingBackwards (filterForward startPos team) .
setFilter invading (filterNonInvading team (getGrid halmaBoard))
setFilter ruleRestriction filterRule positions =
case ruleRestriction ruleOptions of
Allowed -> positions
Temporarily -> filterRule positions
Forbidden -> filterRule positions
possibleJumpMoves
:: RuleOptions
-> HalmaBoard
-> (Int, Int)
-> [(Int, Int)]
possibleJumpMoves ruleOptions halmaBoard startPos =
case lookupHalmaBoard startPos halmaBoard of
Nothing -> []
Just piece ->
finalRuleOptsFilters (pieceTeam piece) $ S.toList $
allJumpTargets (pieceTeam piece)
where
hexDirections =
[ HexGrid.West, HexGrid.Northwest, HexGrid.Northeast
, HexGrid.East, HexGrid.Southeast, HexGrid.Southwest
]
isEmpty pos = isNothing (lookupHalmaBoard pos halmaBoard)
isOccupied pos = isJust (lookupHalmaBoard pos halmaBoard)
maybeJump p dir = do
next1 <- neighbour (getGrid halmaBoard) p dir
next2 <- neighbour (getGrid halmaBoard) next1 dir
guard (isOccupied next1 && isEmpty next2)
return next2
nextJumpTargets team pos =
continualRuleOptsFilters team pos $
mapMaybe (maybeJump pos) hexDirections
allJumpTargets team =
iter S.empty (nextJumpTargets team startPos)
where
iter set [] = set
iter set (pos:poss) =
if S.member pos set
then iter set poss
else iter (S.insert pos set) (nextJumpTargets team pos ++ poss)
finalRuleOptsFilters team =
setFinalFilter movingBackwards (filterForward startPos team) .
setFinalFilter invading (filterNonInvading team (getGrid halmaBoard))
continualRuleOptsFilters team pos =
setContinualFilter movingBackwards (filterForward pos team) .
setContinualFilter invading (filterNonInvading team (getGrid halmaBoard))
setFinalFilter ruleRestriction filterRule positions =
case ruleRestriction ruleOptions of
Allowed -> positions
Temporarily -> filterRule positions
Forbidden -> filterRule positions
setContinualFilter ruleRestriction filterRule positions =
case ruleRestriction ruleOptions of
Allowed -> positions
Temporarily -> positions
Forbidden -> filterRule positions
possibleMoves
:: RuleOptions
-> HalmaBoard
-> (Int, Int)
-> [(Int, Int)]
possibleMoves = possibleStepMoves <> possibleJumpMoves
hasFinished :: HalmaBoard -> Team -> Bool
hasFinished halmaBoard team =
all hasPieceFromTheRightTeam (endFields (getGrid halmaBoard) team)
where
hasTheRightTeam piece = pieceTeam piece == team
hasPieceFromTheRightTeam pos =
maybe False hasTheRightTeam (lookupHalmaBoard pos halmaBoard)