halma 0.1.0.1 → 0.2.0.0

raw patch · 9 files changed

+356/−105 lines, 9 filesdep −vector-space-pointsdep ~basedep ~diagrams-gtkdep ~diagrams-libPVP ok

version bump matches the API change (PVP)

Dependencies removed: vector-space-points

Dependency ranges changed: base, diagrams-gtk, diagrams-lib, grid

API changes (from Hackage documentation)

Files

• halma.cabal +10/−8
• halma.hs +80/−51
• src/Game/Halma/AI/Base.hs +63/−0
• src/Game/Halma/AI/Competitive.hs +83/−0
• src/Game/Halma/AI/Ignorant.hs +32/−0
• src/Game/Halma/Board.hs +14/−4
• src/Game/Halma/Board/Draw.hs +6/−6
• src/Game/Halma/Rules.hs +61/−32
• test/Game/Halma/Board/Tests.hs +7/−4

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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

@@ -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