diff --git a/halma.cabal b/halma.cabal --- a/halma.cabal +++ b/halma.cabal @@ -1,5 +1,5 @@ name: halma -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Library implementing Halma rules description: Rules and `diagrams`-based renderer for the board game Halma on a hexagonal grid. homepage: https://github.com/timjb/halma @@ -21,11 +21,14 @@ ghc-options: -Wall exposed-modules: Game.Halma.Board, Game.Halma.Rules, - Game.Halma.Board.Draw + Game.Halma.Board.Draw, + Game.Halma.AI.Base, + Game.Halma.AI.Ignorant + Game.Halma.AI.Competitive build-depends: base >= 4.6 && < 5, - grid >= 7.6.7 && < 7.8, + grid >= 7.7.1 && < 7.9, containers >= 0.5 && < 0.6, - diagrams-lib >= 1.2.0.7 && < 1.3, + diagrams-lib >= 1.3 && < 1.4, data-default >= 0.4 && < 0.6 hs-source-dirs: src default-language: Haskell2010 @@ -51,15 +54,14 @@ Executable halma Ghc-options: -threaded -Wall build-depends: halma, - base >= 4.7 && < 5, - diagrams-gtk >= 1.0.1.3 && < 1.1, + base >= 4.6 && < 5, + diagrams-gtk >= 1.0.1.3 && < 1.4, gtk >= 0.13.4 && < 0.14, mtl, - diagrams-lib, + diagrams-lib >= 1.3, diagrams-cairo, pipes >= 4.1.4 && < 4.2, mvc >= 1.0.3 && < 1.1, - vector-space-points, async >= 2.0.2 && < 2.1, data-default, timeit >= 1.0 && < 1.1 diff --git a/halma.hs b/halma.hs --- a/halma.hs +++ b/halma.hs @@ -3,20 +3,22 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +--{-# LANGUAGE ScopedTypeVariables #-} module Main (main) where import Game.Halma.Board import Game.Halma.Rules +import qualified Game.Halma.AI.Competitive as Competitive +import qualified Game.Halma.AI.Ignorant as Ignorant import Data.Default import Game.Halma.Board.Draw import Graphics.UI.Gtk hiding (get) -import Diagrams.Prelude hiding ((<>)) -import Diagrams.TwoD.Size (requiredScale) +import Diagrams.Prelude hiding ((<>), set) import Diagrams.TwoD.Text (Text) import Diagrams.Backend.Gtk import Diagrams.Backend.Cairo.Internal (Cairo) -import Data.AffineSpace.Point +import Data.Maybe (isJust) import MVC import qualified Pipes.Prelude as PP import qualified Control.Monad.State.Strict as MS @@ -28,28 +30,13 @@ import qualified Data.Function as F -sizedCentered :: (Transformable a, Enveloped a, V a ~ R2) => SizeSpec2D -> a -> a -sizedCentered spec d = transform adjustT d - where - size = size2D d - s = requiredScale spec size - finalSz = case spec of - Dims w h -> (w,h) - _ -> scale s size - tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) - adjustT = translation tr <> scaling s - -centered :: (Transformable a, Enveloped a, V a ~ R2) => SizeSpec2D -> a -> a +centered, sizedCentered + :: (Transformable a, Enveloped a, V a ~ V2, N a ~ Double) + => SizeSpec V2 Double -> a -> a centered spec d = transform adjustT d where - size = size2D d - s = requiredScale spec size - finalSz = case spec of - Dims w h -> (w,h) - _ -> scale s size - tr = (0.5 *. p2 finalSz) .-. center2D d - adjustT = translation tr - + adjustT = translation $ (0.5 *. P (specToSize 0 spec)) .-. centerPoint d +sizedCentered spec = centered spec . sized spec data TurnCounter p = TurnCounter { _tcPlayers :: [p] @@ -74,6 +61,7 @@ { hsRuleOptions :: RuleOptions , hsBoard :: HalmaBoard size , hsTurnCounter :: TurnCounter Team + , hsLastMoved :: Maybe (Int, Int) } deriving (Eq, Show) data NumberOfPlayers :: HalmaGridSize -> * where @@ -119,6 +107,7 @@ HalmaState { hsRuleOptions = def , hsBoard = initialBoard halmaGrid (flip elem players) , hsTurnCounter = newTurnCounter players + , hsLastMoved = Nothing } initialState :: State @@ -129,6 +118,9 @@ { _hvsBoard :: HalmaBoard size , _hvsSelectedField :: Maybe (Int, Int) , _hvsHighlightedFields :: [(Int, Int)] + , _hvsLastMoved :: Maybe (Int, Int) + , _hvsFinishedPlayers :: [Team] + , _hvsCompetitiveAIAllowed :: Bool } deriving (Eq, Show) data ViewState where @@ -139,31 +131,36 @@ data QuitType = QuitGame | QuitApp deriving (Show, Eq) +data AIType = Ignorant | Competitive + deriving (Eq, Show) + data ViewEvent = Quit QuitType | SetMenuState MenuState | NewGame | FieldClick (Int, Int) | EmptyClick + | AIMove AIType deriving (Eq, Show) renderHalmaViewState - :: Renderable (Path R2) b + :: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b) => (Team -> Colour Double) -> HalmaViewState size - -> QDiagram b R2 (Option (Last (Int, Int))) -renderHalmaViewState teamColors (HalmaViewState board startPos highlighted) = + -> QDiagram b V2 Double (Option (Last (Int, Int))) +renderHalmaViewState teamColors (HalmaViewState board startPos highlighted lastMoved _ _) = drawBoard' (getGrid board) drawField where - drawPiece t = + drawPiece t lastMoved' = let c = teamColors t - in circle 0.25 # fc c # lc (darken 0.5 c) + in circle 0.25 # fc c # lc (if lastMoved' then darken 0.2 c else darken 0.5 c) # + if lastMoved' then lw medium else id startField = startPos >>= flip lookupHalmaBoard board drawField p = (if Just p == startPos then lc black . lw thick else id) $ case (lookupHalmaBoard p board, startField) of - (Just t, _) -> drawPiece t + (Just t, _) -> drawPiece t (Just p == lastMoved) (Nothing, Just t) | p `elem` highlighted -> - drawPiece t # opacity 0.5 + drawPiece t False # opacity 0.5 _ -> mempty data ButtonState a = ButtonActive a @@ -171,10 +168,10 @@ | ButtonSelected deriving (Eq, Show) button - :: (Renderable (Path R2) b, Renderable Text b, Backend b R2) + :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => String -> ButtonState a - -> QDiagram b R2 (Option (Last a)) + -> QDiagram b V2 Double (Option (Last a)) button txt buttonState = (label <> background) # value val' # padX 1.05 # padY 1.2 where (label, background) = case buttonState of @@ -192,17 +189,31 @@ ButtonActive val -> Option (Just (Last val)) _ -> Option Nothing +playerFinishedSign + :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) + => Colour Double -> QDiagram b V2 Double (Option (Last a)) +playerFinishedSign color = (label <> background) # value (Option Nothing) # padX 1.05 # padY 1.5 + where + label = text "finished" # fontSizeO 13 + background = roundedRect 110 26 6 # fc color # lw none + renderMenu - :: (Renderable (Path R2) b, Renderable Text b, Backend b R2) + :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => MenuState - -> QDiagram b R2 (Option (Last MenuState)) + -> QDiagram b V2 Double (Option (Last MenuState)) renderMenu (MenuState gridSize nop) = ((===) `F.on` (centerX . horizontal)) sizeButtons playerButtons where setPlayers = MenuState gridSize playerButtonAction nop' = if (nop == nop') then ButtonSelected else ButtonActive (setPlayers nop') horizontal = foldl (|||) mempty - (sizeButtons, playerButtons) = case gridSize of + (sizeButtons, playerButtons) = allButtons + allButtons + :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) + => ( [ QDiagram b V2 Double (Option (Last MenuState)) ] + , [ QDiagram b V2 Double (Option (Last MenuState)) ] + ) + allButtons = case gridSize of SmallGrid -> let nopL = case nop of TwoPlayers -> TwoPlayers @@ -232,19 +243,27 @@ :: (Team -> Colour Double) -> (Double, Double) -> ViewState - -> QDiagram Cairo R2 (Option (Last ViewEvent)) + -> QDiagram Cairo V2 Double (Option (Last ViewEvent)) renderViewState _teamColors (w,h) (MenuView menuState) = let menuDiagram = fmap (fmap SetMenuState) <$> renderMenu menuState newGameButton = button "New Game" (ButtonActive NewGame) # padY 1.5 - reposition = centered (Dims w h) . toGtkCoords + reposition = centered (dims (r2 (w, h))) . toGtkCoords in reposition (menuDiagram === newGameButton) renderViewState teamColors (w,h) (HalmaView halmaViewState) = - let resize = sizedCentered (Dims w h) . toGtkCoords . pad 1.05 - quitGameButton = - toGtkCoords $ padY 1.3 $ alignX (-1) $ - button "Quit Game" $ ButtonActive $ Quit QuitGame + let resize = sizedCentered (dims (r2 (w, h))) . toGtkCoords . pad 1.05 + buttons = padY 1.3 $ quitGameButton === padY 1.3 aiButtons + quitGameButton = button "Quit Game" $ ButtonActive $ Quit QuitGame + aiButtons = button "AI Move" (aiButtonState Ignorant) + === if _hvsCompetitiveAIAllowed halmaViewState + then button "Competitive" (aiButtonState Competitive) else mempty + aiButtonState aiMoveType = + if isJust (_hvsSelectedField halmaViewState) + then ButtonInactive + else ButtonActive $ AIMove aiMoveType + finishedSigns = foldl (===) mempty $ + map (playerFinishedSign . teamColors) $ _hvsFinishedPlayers halmaViewState field = resize (fmap (fmap FieldClick) <$> renderHalmaViewState teamColors halmaViewState) - in quitGameButton `atop` field + in toGtkCoords (buttons === finishedSigns) `atop` field external :: Managed (View ViewState, Controller ViewEvent) external = managed $ \f -> do @@ -294,36 +313,46 @@ wait res gameLoop :: HalmaState size -> Pipe ViewEvent (HalmaViewState size) (MS.State State) QuitType -gameLoop (HalmaState ruleOptions board turnCounter) = noSelectionLoop +gameLoop (HalmaState ruleOptions board turnCounter lastMoved) = noSelectionLoop where team = currentPlayer turnCounter + finishedPlayers = filter (hasFinished board) (_tcPlayers turnCounter) noSelectionLoop = do - yield $ HalmaViewState board Nothing [] + yield $ HalmaViewState board Nothing [] lastMoved finishedPlayers + (length (_tcPlayers turnCounter)==2) event <- await case event of EmptyClick -> noSelectionLoop FieldClick p | lookupHalmaBoard p board == Just team -> selectionLoop p FieldClick _ -> noSelectionLoop + AIMove Ignorant -> performMove $ + Ignorant.aiMove ruleOptions board (currentPlayer turnCounter) + AIMove Competitive -> performMove $ + Competitive.aiMove ruleOptions board + (currentPlayer turnCounter, currentPlayer $ nextTurn turnCounter) Quit quitType -> return quitType _ -> return QuitApp selectionLoop startPos = do let possible = possibleMoves ruleOptions board startPos - yield $ HalmaViewState board (Just startPos) possible + yield $ HalmaViewState board (Just startPos) possible Nothing finishedPlayers + (length (_tcPlayers turnCounter)==2) event <- await case event of EmptyClick -> noSelectionLoop - FieldClick p | p `elem` possible -> do - let Right board' = movePiece startPos p board - halmaState' = HalmaState ruleOptions board' (nextTurn turnCounter) - State menuState _halmaState <- MS.get - MS.put $ State menuState (Just halmaState') - gameLoop halmaState' + FieldClick p | p `elem` possible -> performMove (startPos, p) FieldClick p | lookupHalmaBoard p board == Just team -> selectionLoop p FieldClick _ -> noSelectionLoop Quit quitType -> return quitType _ -> return QuitApp + performMove (source, destination) = do + let Right board' = movePiece source destination board + halmaState' = HalmaState ruleOptions board' (nextTurn turnCounter) (Just destination) + State menuState _halmaState <- MS.get + MS.put $ State menuState (Just halmaState') + gameLoop halmaState' + pipe :: Pipe ViewEvent ViewState (MS.State State) () pipe = do diff --git a/src/Game/Halma/AI/Base.hs b/src/Game/Halma/AI/Base.hs new file mode 100644 --- /dev/null +++ b/src/Game/Halma/AI/Base.hs @@ -0,0 +1,63 @@ +module Game.Halma.AI.Base + ( Move + , outcome + , Rating(..) + , teamRating + , allOwnPieces + , allLegalMoves + ) where + +import Math.Geometry.Grid +import qualified Data.Map.Strict as M +import Data.List (sort) +import Game.Halma.Board +import Game.Halma.Rules + + +type Move size = (Index (HalmaGrid size), Index (HalmaGrid size)) + +outcome :: HalmaBoard size -> Move size -> HalmaBoard size +outcome board (source, destination) = + case movePiece source destination board of + Left err -> error $ "cannot compute outcome: " ++ err + Right board' -> board' + +data Rating = WinIn Int + | Rating Float + | LossIn Int + deriving (Show, Eq) + +instance Ord Rating where + compare (WinIn n) (WinIn m) = compare m n + compare (WinIn _) _ = GT + compare _ (WinIn _) = LT + compare (LossIn n) (LossIn m) = compare n m + compare (LossIn _) _ = LT + compare _ (LossIn _) = GT + compare (Rating a) (Rating b) = compare a b + +instance Bounded Rating where + maxBound = WinIn 0 + minBound = LossIn 0 + + +teamRating :: Team -> HalmaBoard size -> Rating +teamRating team board | hasFinished board team = WinIn 0 + | otherwise = Rating . negate . sum $ + zipWith (*) pieceWeightingList (sort distances) + where distances = map (fromIntegral . distance grid (endCorner grid team)) $ + allOwnPieces board team + grid = getGrid board + pieceWeightingList = replicate 12 2 ++ [3..5] + +allOwnPieces :: HalmaBoard size -> Team -> [Index (HalmaGrid size)] +allOwnPieces board team = + map fst $ filter ((team ==) . snd) $ + M.assocs (toMap board) + +allLegalMoves :: RuleOptions -> HalmaBoard size -> Team -> [Move size] +allLegalMoves opts board team = + concatMap + ( \piecePos -> [(piecePos, destination) + | destination <- possibleMoves opts board piecePos] ) + $ allOwnPieces board team diff --git a/src/Game/Halma/AI/Competitive.hs b/src/Game/Halma/AI/Competitive.hs new file mode 100644 --- /dev/null +++ b/src/Game/Halma/AI/Competitive.hs @@ -0,0 +1,83 @@ +module Game.Halma.AI.Competitive + ( aiMove + ) where + +import Data.List (sortBy) +import Data.Ord (comparing) +import Game.Halma.Board +import Game.Halma.Rules +import Game.Halma.AI.Base + + +-- The perspective of the first team as opposed to the second team. +type Perspective = (Team, Team) + +flipPersp :: Perspective -> Perspective +flipPersp (t0, t1) = (t1, t0) + + +rating :: Perspective -> HalmaBoard size -> Rating +rating (t0, t1) board = teamRating t0 board `against` teamRating t1 board + where (WinIn n) `against` _ = WinIn n + _ `against` (WinIn n) = LossIn n + (Rating r0) `against` (Rating r1) = Rating (r0 - r1) + _ `against` _ = error "unexpected team rating indicating loss" + + +aiMove :: RuleOptions -> HalmaBoard size -> Perspective -> Move size +aiMove opts board persp = snd $ + prunedMinMaxSearch 3 opts board persp Nothing + + +-- Find the best move or one that reaches the given bound. +prunedMinMaxSearch + :: Int + -> RuleOptions + -> HalmaBoard size + -> Perspective + -> Maybe Rating + -> (Rating, Move size) +prunedMinMaxSearch depth opts board persp mBound = + go Nothing allOptions + where allOptions = sortIfUseful [ (rating persp (outcome board move), move) + | move <- allLegalMoves opts board (fst persp) ] + sortIfUseful = if depth<=2 then id + else sortBy (flip $ comparing fst) + go :: Maybe (Rating, Move size) -> [(Rating, Move size)] -> (Rating, Move size) + go Nothing (option:options) = + if isWin (fst option) then option + else go (Just $ nextLevel option Nothing) options + go (Just (currentMax, bestMove)) [] = (currentMax, bestMove) + go (Just (currentMax, bestMove)) (option:options) = + if isWin (fst option) then option + else if newRating <= currentMax + then go (Just (currentMax, bestMove)) options + else if boundReached mBound newRating + then (newRating, snd option) + else go (Just (newRating, snd option)) options + where newRating = fst $ nextLevel option (Just currentMax) + go Nothing [] = error "no legal moves found" + nextLevel option mCurrentMax = + ( if depth>1 + then pushRating . flipRating . fst $ + prunedMinMaxSearch (depth-1) opts (outcome board (snd option)) + (flipPersp persp) (fmap flipRating mCurrentMax) + else fst option + , snd option ) + boundReached Nothing _ = False + boundReached (Just bound) value = value >= bound + + +isWin :: Rating -> Bool +isWin (WinIn _) = True +isWin _ = False + +flipRating :: Rating -> Rating +flipRating (WinIn n) = LossIn n +flipRating (LossIn n) = WinIn n +flipRating (Rating r) = Rating (-r) + +pushRating :: Rating -> Rating +pushRating (WinIn n) = WinIn (n+1) +pushRating (LossIn n) = WinIn (n+1) +pushRating (Rating r) = Rating r diff --git a/src/Game/Halma/AI/Ignorant.hs b/src/Game/Halma/AI/Ignorant.hs new file mode 100644 --- /dev/null +++ b/src/Game/Halma/AI/Ignorant.hs @@ -0,0 +1,32 @@ +module Game.Halma.AI.Ignorant + ( aiMove + ) where + +import Data.List (maximumBy) +import Data.Ord (comparing) +import Game.Halma.Board +import Game.Halma.Rules +import Game.Halma.AI.Base + + +ignorantFixedDepth :: Int -> RuleOptions -> Team -> HalmaBoard size -> Rating +ignorantFixedDepth n opts team board + | n<=0 = teamRating team board + | hasFinished board team = WinIn 0 + | otherwise = beingSomewhatGreedy (teamRating team board) $ maximum $ + map (ignorantFixedDepth (n-1) opts team . outcome board) $ + allLegalMoves opts board team + +beingSomewhatGreedy :: Rating -> Rating -> Rating +beingSomewhatGreedy (WinIn n) _ = WinIn n +beingSomewhatGreedy (LossIn n) _ = LossIn n +beingSomewhatGreedy _ (WinIn n) = WinIn (n+1) +beingSomewhatGreedy _ (LossIn n) = LossIn (n+1) +beingSomewhatGreedy (Rating a) (Rating b) = Rating $ greedyness*a + (1-greedyness)*b + where greedyness = 0.1 + +aiMove :: RuleOptions -> HalmaBoard size -> Team -> Move size +aiMove opts board team = if null legalMoves then error "There is no legal move." + else maximumBy (comparing $ finalRating team . outcome board) legalMoves + where legalMoves = allLegalMoves opts board team + finalRating = ignorantFixedDepth 1 opts diff --git a/src/Game/Halma/Board.hs b/src/Game/Halma/Board.hs --- a/src/Game/Halma/Board.hs +++ b/src/Game/Halma/Board.hs @@ -9,6 +9,7 @@ , sideLength, numberOfFields , HalmaDirection (..) , oppositeDirection + , leftOf , rowsInDirection , corner , Team @@ -67,6 +68,15 @@ oppositeDirection Northwest = Southeast oppositeDirection Southeast = Northwest +leftOf :: HalmaDirection -> HalmaDirection +leftOf North = Northwest +leftOf Northwest = Southwest +leftOf Southwest = South +leftOf South = Southeast +leftOf Southeast = Northeast +leftOf Northeast = North + + getDirs :: HalmaDirection -> (HI.HexDirection, HI.HexDirection) getDirs North = (HI.Northwest, HI.Northeast) getDirs South = (HI.Southwest, HI.Southeast) @@ -118,13 +128,13 @@ atLeastTwo False True True = True atLeastTwo _ _ _ = False -instance FiniteGrid (HalmaGrid S) where - type Size (HalmaGrid S) = () +instance FiniteGrid (HalmaGrid 'S) where + type Size (HalmaGrid 'S) = () size _ = () maxPossibleDistance _ = 16 -instance FiniteGrid (HalmaGrid L) where - type Size (HalmaGrid L) = () +instance FiniteGrid (HalmaGrid 'L) where + type Size (HalmaGrid 'L) = () size _ = () maxPossibleDistance _ = 20 diff --git a/src/Game/Halma/Board/Draw.hs b/src/Game/Halma/Board/Draw.hs --- a/src/Game/Halma/Board/Draw.hs +++ b/src/Game/Halma/Board/Draw.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} module Game.Halma.Board.Draw ( defaultTeamColours @@ -20,10 +20,10 @@ -- | Render the board using the helper function for drawing the fields. -- Supports querying for field positions. drawBoard' - :: Renderable (Path R2) b + :: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b) => HalmaGrid size - -> ((Int,Int) -> Diagram b R2) - -> QDiagram b R2 (Option (Last (Int, Int))) + -> ((Int,Int) -> Diagram b) + -> QDiagram b V2 Double (Option (Last (Int, Int))) drawBoard' grid drawField = targets `atop` (mconcat @@ -47,10 +47,10 @@ -- | Render the board using the given team colors. Supports querying for field -- positions. drawBoard - :: Renderable (Path R2) b + :: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b) => HalmaBoard size -> (Team -> Colour Double) - -> QDiagram b R2 (Option (Last (Int, Int))) + -> QDiagram b V2 Double (Option (Last (Int, Int))) drawBoard halmaBoard teamColors = drawBoard' (getGrid halmaBoard) drawField where drawPiece t = let c = teamColors t diff --git a/src/Game/Halma/Rules.hs b/src/Game/Halma/Rules.hs --- a/src/Game/Halma/Rules.hs +++ b/src/Game/Halma/Rules.hs @@ -1,5 +1,6 @@ module Game.Halma.Rules - ( RuleOptions (..) + ( MoveRestriction (..) + , RuleOptions (..) , possibleMoves , hasFinished ) where @@ -13,24 +14,31 @@ import Control.Monad (guard) import qualified Data.Set as S + +data MoveRestriction = + Allowed -- moves to this kind of field are allowed + | Temporarily -- the player can pass the field but cannot occupy it + | Forbidden -- the player cant pass or occupy the field + deriving (Show, Eq) + data RuleOptions = - RuleOptions { backwardsMovesAllowed :: Bool -- ^ May pieces be moved towards the start corner of the team? + RuleOptions { movingBackwards :: MoveRestriction -- ^ May pieces be moved backwards? + , invading :: MoveRestriction -- ^ May pieces be moved into other star corners? } deriving (Show, Eq) instance Default RuleOptions where - def = RuleOptions { backwardsMovesAllowed = False } + def = RuleOptions { movingBackwards = Temporarily + , invading = Allowed } -forwardMovesOnly - :: RuleOptions - -> (Int, Int) - -> HalmaDirection - -> [(Int, Int)] - -> [(Int, Int)] -forwardMovesOnly ruleOptions startPos halmaDir = - if backwardsMovesAllowed ruleOptions - then id - else filter (((>=) `on` rowsInDirection halmaDir) startPos) +filterForward :: (Int, Int) -> HalmaDirection -> [(Int, Int)] -> [(Int, Int)] +filterForward startPos halmaDir = + filter $ ((>=) `on` rowsInDirection halmaDir) startPos +filterNonInvading :: Team -> HalmaGrid size -> [(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 size @@ -40,9 +48,15 @@ case lookupHalmaBoard startPos halmaBoard of Nothing -> [] Just team -> - forwardMovesOnly ruleOptions startPos team $ + ruleOptsFilters $ filter ((== Nothing) . flip lookupHalmaBoard halmaBoard) $ neighbours (getGrid halmaBoard) startPos + where ruleOptsFilters = setFilter (movingBackwards ruleOptions) + (filterForward startPos team) + . setFilter (invading ruleOptions) + (filterNonInvading team (getGrid halmaBoard)) + setFilter Allowed = const id + setFilter _ = id possibleJumpMoves :: RuleOptions @@ -53,24 +67,39 @@ case lookupHalmaBoard startPos halmaBoard of Nothing -> [] Just team -> - forwardMovesOnly ruleOptions startPos team $ - S.toList $ go S.empty (jumpTargets startPos) - where hexDirections = - [ HI.West, HI.Northwest, HI.Northeast - , HI.East, HI.Southeast, HI.Southwest - ] - isEmpty = (== Nothing) . flip lookupHalmaBoard halmaBoard - maybeJump p dir = do - next1 <- neighbour (getGrid halmaBoard) p dir - next2 <- neighbour (getGrid halmaBoard) next1 dir - guard $ not (isEmpty next1) && isEmpty next2 - return next2 - jumpTargets p = catMaybes $ map (maybeJump p) hexDirections - go set [] = set - go set (p:ps) = - if S.member p set - then go set ps - else go (S.insert p set) (jumpTargets p ++ ps) + finalRuleOptsFilters $ + S.toList $ go S.empty (filteredJumpTargets startPos) + where hexDirections = + [ HI.West, HI.Northwest, HI.Northeast + , HI.East, HI.Southeast, HI.Southwest + ] + isEmpty = (== Nothing) . flip lookupHalmaBoard halmaBoard + maybeJump p dir = do + next1 <- neighbour (getGrid halmaBoard) p dir + next2 <- neighbour (getGrid halmaBoard) next1 dir + guard $ not (isEmpty next1) && isEmpty next2 + return next2 + filteredJumpTargets p = continualRuleOptsFilters p $ jumpTargets p + jumpTargets p = catMaybes $ map (maybeJump p) hexDirections + go set [] = set + go set (p:ps) = + if S.member p set + then go set ps + else go (S.insert p set) (filteredJumpTargets p ++ ps) + finalRuleOptsFilters = + setFinalFilter (movingBackwards ruleOptions) + (filterForward startPos team) + . setFinalFilter (invading ruleOptions) + (filterNonInvading team (getGrid halmaBoard)) + continualRuleOptsFilters pos = + setContinualFilter (movingBackwards ruleOptions) + (filterForward pos team) + . setContinualFilter (invading ruleOptions) + (filterNonInvading team (getGrid halmaBoard)) + setFinalFilter Temporarily = id + setFinalFilter _ = const id + setContinualFilter Forbidden = id + setContinualFilter _ = const id -- | Computes all possible moves for a piece. possibleMoves diff --git a/test/Game/Halma/Board/Tests.hs b/test/Game/Halma/Board/Tests.hs --- a/test/Game/Halma/Board/Tests.hs +++ b/test/Game/Halma/Board/Tests.hs @@ -38,10 +38,13 @@ testDistancesFromCenter = do [1,6,12,18,24,24,18,12,6,0,0,0] @=?* actual SmallGrid [1,6,12,18,24,30,30,24,18,12,6,0,0,0] @=?* actual LargeGrid - where center = (0, 0) - distCenter hg = distance hg center - fieldsAtDistance hg d = filter ((== d) . distCenter hg) (indices hg) - actual hg = map (length . fieldsAtDistance hg) [0,1..] + where + distCenter :: HalmaGrid s -> (Int, Int) -> Int + distCenter hg = distance hg (0, 0) + fieldsAtDistance :: HalmaGrid s -> Int -> [(Int, Int)] + fieldsAtDistance hg d = filter ((== d) . distCenter hg) (indices hg) + actual :: HalmaGrid s -> [Int] + actual hg = map (length . fieldsAtDistance hg) [0,1..] testBoundaryLength :: Assertion testBoundaryLength = do