halma 0.2.0.1 → 0.3.0.0

raw patch · 12 files changed

+823/−789 lines, 12 filesdep +aesondep −asyncdep −diagrams-cairodep −diagrams-gtkdep ~data-defaultdep ~diagrams-libPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson

Dependencies removed: async, diagrams-cairo, diagrams-gtk, gtk, mtl, mvc, pipes, timeit

Dependency ranges changed: data-default, diagrams-lib

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• halma.cabal +9/−23
• halma.hs +0/−380
• src/Game/Halma/AI/Base.hs +33/−32
• src/Game/Halma/AI/Competitive.hs +68/−54
• src/Game/Halma/AI/Ignorant.hs +30/−20
• src/Game/Halma/Board.hs +276/−125
• src/Game/Halma/Board/Draw.hs +33/−28
• src/Game/Halma/Configuration.hs +137/−0
• src/Game/Halma/Rules.hs +116/−69
• src/Game/TurnCounter.hs +57/−0
• test/Game/Halma/Board/Tests.hs +63/−57

@@ -1,5 +1,5 @@ The MIT License (MIT)-Copyright © 2014-2015 Tim Baumann, http://timbaumann.info+Copyright © 2015-2016 Tim Baumann, http://timbaumann.info  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal

@@ -1,5 +1,5 @@ name:                halma-version:             0.2.0.1+version:             0.3.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@@ -7,7 +7,7 @@ license-file:        LICENSE author:              Tim Baumann maintainer:          tim@timbaumann.info-copyright:           2014-2015 Tim Baumann+copyright:           2014-2017 Tim Baumann category:            Game build-type:          Simple cabal-version:       >= 1.10@@ -20,16 +20,19 @@ library   ghc-options:         -Wall   exposed-modules:     Game.Halma.Board,+                       Game.Halma.Configuration,                        Game.Halma.Rules,                        Game.Halma.Board.Draw,                        Game.Halma.AI.Base,-                       Game.Halma.AI.Ignorant-                       Game.Halma.AI.Competitive+                       Game.Halma.AI.Ignorant,+                       Game.Halma.AI.Competitive,+                       Game.TurnCounter   build-depends:       base >= 4.6 && < 5,                        grid >= 7.7.1 && < 7.9,                        containers >= 0.5 && < 0.6,-                       diagrams-lib >= 1.3 && < 1.4,-                       data-default >= 0.4 && < 0.6+                       diagrams-lib >= 1.3 && < 1.5,+                       data-default >= 0.4 && < 0.8,+                       aeson >= 0.11 && < 1.2   hs-source-dirs:      src   default-language:    Haskell2010 @@ -50,20 +53,3 @@                        test-framework >= 0.6 && < 0.9,                        test-framework-hunit >= 0.3.0 && < 0.4,                        test-framework-quickcheck2 >= 0.3.0 && < 0.4--Executable halma-  Ghc-options:         -threaded -Wall-  build-depends:       halma,-                       base >= 4.6 && < 5,-                       diagrams-gtk >= 1.0.1.3 && < 1.4,-                       gtk >= 0.13.4 && < 0.14,-                       mtl,-                       diagrams-lib >= 1.3,-                       diagrams-cairo,-                       pipes >= 4.1.4 && < 4.2,-                       mvc >= 1.0.3 && < 1.2,-                       async >= 2.0.2 && < 2.1,-                       data-default,-                       timeit >= 1.0 && < 1.1-  default-language:    Haskell2010-  main-is:             halma.hs

@@ -1,380 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# 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 ((<>), set)-import Diagrams.TwoD.Text (Text)-import Diagrams.Backend.Gtk-import Diagrams.Backend.Cairo.Internal (Cairo)-import Data.Maybe (isJust)-import MVC-import qualified Pipes.Prelude as PP-import qualified Control.Monad.State.Strict as MS-import Control.Concurrent.Async (async, wait)-import Control.Concurrent.MVar-import GHC.Conc (getNumCapabilities, setNumCapabilities)-import System.TimeIt-import Control.Monad (when)-import qualified Data.Function as F---centered, sizedCentered-  :: (Transformable a, Enveloped a, V a ~ V2, N a ~ Double)-  => SizeSpec V2 Double -> a -> a-centered spec d = transform adjustT d-  where-    adjustT = translation $ (0.5 *. P (specToSize 0 spec)) .-. centerPoint d-sizedCentered spec = centered spec . sized spec--data TurnCounter p = TurnCounter-  { _tcPlayers :: [p]-  , _tcCounter :: Int-  } deriving (Eq, Show)--newTurnCounter :: [p] -> TurnCounter p-newTurnCounter = flip TurnCounter 0--nextTurn :: TurnCounter p -> TurnCounter p-nextTurn (TurnCounter ps c) = TurnCounter ps (c+1)--currentPlayer :: TurnCounter p -> p-currentPlayer (TurnCounter ps c) = ps !! (c `mod` length ps)--_currentRound :: TurnCounter p -> Int-_currentRound (TurnCounter ps c) = c `div` length ps---data HalmaState size =-  HalmaState-  { hsRuleOptions :: RuleOptions-  , hsBoard :: HalmaBoard size-  , hsTurnCounter :: TurnCounter Team-  , hsLastMoved :: Maybe (Int, Int)-  } deriving (Eq, Show)--data NumberOfPlayers :: HalmaGridSize -> * where-  TwoPlayers   :: NumberOfPlayers size-  ThreePlayers :: NumberOfPlayers size-  FourPlayers  :: NumberOfPlayers 'L-  FivePlayers  :: NumberOfPlayers 'L-  SixPlayers   :: NumberOfPlayers 'L--deriving instance Show (NumberOfPlayers size)--instance Eq (NumberOfPlayers size) where-  a == b = show a == show b--getPlayers :: NumberOfPlayers size -> [Team]-getPlayers TwoPlayers   = [North, South]-getPlayers ThreePlayers = [Northeast, South, Northwest]-getPlayers FourPlayers  = [Northeast, Southeast, Southwest, Northwest]-getPlayers FivePlayers  = [Northeast, Southeast, South, Southwest, Northwest]-getPlayers SixPlayers   = [minBound..maxBound]--data MenuState where-  MenuState :: HalmaGrid size -> NumberOfPlayers size -> MenuState--deriving instance Show MenuState--instance Eq MenuState where-  a == b = show a == show b--initialMenuState :: MenuState-initialMenuState = MenuState SmallGrid TwoPlayers--data State where-  State :: MenuState -> Maybe (HalmaState size) -> State--deriving instance Show State--newGame :: State -> State-newGame (State ms@(MenuState halmaGrid nop) _) = State ms (Just halmaState)-  where-    players = getPlayers nop-    halmaState = -      HalmaState { hsRuleOptions = def-                 , hsBoard = initialBoard halmaGrid (flip elem players)-                 , hsTurnCounter = newTurnCounter players-                 , hsLastMoved = Nothing-                 }--initialState :: State-initialState = State initialMenuState Nothing--data HalmaViewState size =-  HalmaViewState-  { _hvsBoard :: HalmaBoard size-  , _hvsSelectedField :: Maybe (Int, Int)-  , _hvsHighlightedFields :: [(Int, Int)]-  , _hvsLastMoved :: Maybe (Int, Int)-  , _hvsFinishedPlayers :: [Team]-  , _hvsCompetitiveAIAllowed :: Bool-  } deriving (Eq, Show)--data ViewState where-  MenuView :: MenuState -> ViewState-  HalmaView :: HalmaViewState size -> ViewState--deriving instance Show ViewState--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-  :: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b)-  => (Team -> Colour Double)-  -> HalmaViewState size-  -> QDiagram b V2 Double (Option (Last (Int, Int)))-renderHalmaViewState teamColors (HalmaViewState board startPos highlighted lastMoved _ _) =-  drawBoard' (getGrid board) drawField-  where-    drawPiece t lastMoved' =-      let c = teamColors t-      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 p == lastMoved)-        (Nothing, Just t) | p `elem` highlighted ->-          drawPiece t False # opacity 0.5-        _ -> mempty--data ButtonState a = ButtonActive a-                   | ButtonInactive-                   | ButtonSelected deriving (Eq, Show)--button-  :: (Renderable (Path V2 Double) b, Renderable (Text Double) b)-  => String-  -> ButtonState 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-      ButtonActive _ -> ( text txt # fontSizeO 13-                        , roundedRect 110 26 6 # fc lightgray-                        )-      ButtonInactive -> ( text txt # fontSizeO 13 # fc gray-                        , roundedRect 110 26 6 # fc lightgray # lc gray-                        )-      ButtonSelected -> ( text txt # fontSizeO 13-                        , roundedRect 110 26 6 # fc yellow # lc black # lw thick-                        )--    val' = case buttonState of-      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 V2 Double) b, Renderable (Text Double) b)-  => 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) = 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-                     ThreePlayers -> ThreePlayers-                     _ -> error "impossible"-        in ( [ button "Small Grid" ButtonSelected-             , button "Large Grid" $ ButtonActive $ MenuState LargeGrid nopL-             ]-           , [ button "Two Players" $ playerButtonAction TwoPlayers-             , button "Three Players" $ playerButtonAction ThreePlayers-             ] ++ map (flip button ButtonInactive) ["Four Players", "Five Players", "Six Players"]-           )-      LargeGrid ->-        let nopS = case nop of-                     TwoPlayers -> TwoPlayers-                     _ -> ThreePlayers-        in ( [ button "Small Grid" $ ButtonActive $ MenuState SmallGrid nopS-             , button "Large Grid" ButtonSelected-             ]-           , map (\(numStr, nop') -> button (numStr ++ " Players") (playerButtonAction nop')) $-             [ ("Two", TwoPlayers), ("Three", ThreePlayers), ("Four", FourPlayers)-             , ("Five", FivePlayers), ("Six", SixPlayers)-             ]-           )--renderViewState-  :: (Team -> Colour Double)-  -> (Double, Double)-  -> ViewState-  -> 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 (r2 (w, h))) . toGtkCoords-  in reposition (menuDiagram === newGameButton)-renderViewState teamColors (w,h) (HalmaView halmaViewState) =-  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 toGtkCoords (buttons === finishedSigns) `atop` field--external :: Managed (View ViewState, Controller ViewEvent)-external = managed $ \f -> do-  _ <- initGUI-  window <- windowNew-  canvas <- drawingAreaNew-  set window [ containerBorderWidth := 0, containerChild := canvas ]--  viewState <- newEmptyMVar-  (veOutput, veInput) <- spawn (bounded 1)--  let figure winSize =-        fmap (maybe mempty (renderViewState defaultTeamColours winSize))-             (tryReadMVar viewState)-      resizedFigure = do-        drawWin <- widgetGetDrawWindow canvas-        (w, h) <- drawableGetSize drawWin-        figure (fromIntegral w, fromIntegral h)-      renderFigure = tryEvent $ do-        win <- eventWindow-        liftIO $ putStr "Render time: "-        liftIO $ timeIt $ resizedFigure >>= renderToGtk win-      updateViewState vs = do-        _ <- tryTakeMVar viewState-        putMVar viewState vs-        widgetQueueDraw canvas -- send redraw request to canvas-      handleClick = tryEvent $ do-        _click <- eventClick-        (x,y) <- eventCoordinates-        fig <- liftIO resizedFigure-        let result = runQuery (query fig) (P (r2 (x, y)))-            event = maybe EmptyClick getLast $ getOption result-        liftIO $ print event-        void $ liftIO $ atomically $ send veOutput event-      handleDestroy = do-        _ <- atomically $ send veOutput $ Quit QuitApp-        mainQuit--  _ <- canvas `on` sizeRequest $ return (Requisition 650 450)-  _ <- canvas `on` exposeEvent $ renderFigure-  _ <- canvas `on` buttonPressEvent $ handleClick-  _ <- window `onDestroy` handleDestroy--  res <- async $ f (asSink updateViewState, asInput veInput)-  widgetShowAll window-  mainGUI-  wait res--gameLoop :: HalmaState size -> Pipe ViewEvent (HalmaViewState size) (MS.State State) QuitType-gameLoop (HalmaState ruleOptions board turnCounter lastMoved) = noSelectionLoop-  where-    team = currentPlayer turnCounter-    finishedPlayers = filter (hasFinished board) (_tcPlayers turnCounter)-    noSelectionLoop = do-      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 Nothing finishedPlayers-                             (length (_tcPlayers turnCounter)==2)-      event <- await-      case event of-        EmptyClick -> noSelectionLoop-        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-  st@(State menuState mHalmaState) <- MS.get-  case mHalmaState of-    Just halmaState -> do-      quitType <- gameLoop halmaState >-> PP.map HalmaView-      when (quitType == QuitGame) $-        MS.put (State menuState Nothing) >> pipe-    Nothing -> do-      yield $ MenuView menuState-      event <- await-      case event of-        SetMenuState menuState' -> MS.put (State menuState' Nothing) >> pipe-        NewGame -> MS.put (newGame st) >> pipe-        _ -> pipe--main :: IO ()-main = do-  -- we need at least two threads:-  -- * one for the GTK event loop-  -- * one for the MVC pipeline-  caps <- getNumCapabilities-  when (caps < 2) $ setNumCapabilities 2-  void $ runMVC initialState (asPipe pipe) external

@@ -1,30 +1,29 @@ module Game.Halma.AI.Base   ( Move   , outcome-  , Rating(..)-  , teamRating+  , Rating (..)+  , rateTeam   , 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))+import Data.List (sort)+import Math.Geometry.Grid+import qualified Data.Map.Strict as M -outcome :: HalmaBoard size -> Move size -> HalmaBoard size-outcome board (source, destination) =-  case movePiece source destination board of+outcome :: HalmaBoard -> Move -> HalmaBoard+outcome board move =+  case movePiece move board of     Left err -> error $ "cannot compute outcome: " ++ err     Right board' -> board' -data Rating = WinIn Int-            | Rating Float-            | LossIn Int+data Rating+  = WinIn Int+  | Rating Float+  | LossIn Int   deriving (Show, Eq)  instance Ord Rating where@@ -40,24 +39,26 @@   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]+rateTeam :: Team -> HalmaBoard -> Rating+rateTeam team board+  | hasFinished board team =+      WinIn 0+  | otherwise =+      Rating . negate . sum $ zipWith (*) pieceWeightingList (sort distances)+  where+    grid = getGrid board+    distanceToEndCorner = fromIntegral . distance grid (endCorner grid team)+    distances = map distanceToEndCorner (allOwnPieces board team)+    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)+allOwnPieces :: HalmaBoard -> Team -> [Index HalmaGrid]+allOwnPieces board team =+  map fst $ filter (isMyPiece . snd) $ M.assocs (toMap board)+  where+    isMyPiece piece = pieceTeam piece == team -allLegalMoves :: RuleOptions -> HalmaBoard size -> Team -> [Move size]-allLegalMoves opts board team =-  concatMap-    ( \piecePos -> [(piecePos, destination)-                    | destination <- possibleMoves opts board piecePos] )-    $ allOwnPieces board team+allLegalMoves :: RuleOptions -> HalmaBoard -> Team -> [Move]+allLegalMoves opts board team = do+  piecePos <- allOwnPieces board team+  endPos <- possibleMoves opts board piecePos+  pure Move { moveFrom = piecePos, moveTo = endPos }

@@ -2,82 +2,96 @@   ( aiMove   ) where -import Data.List (sortBy)-import Data.Ord (comparing) import Game.Halma.Board import Game.Halma.Rules import Game.Halma.AI.Base +import Data.List (sortOn) --- The perspective of the first team as opposed to the second team.+-- | 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 +rate :: Perspective -> HalmaBoard -> Rating+rate (t0, t1) board = rateTeam t0 board `against` rateTeam 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 -> Perspective -> Move+aiMove opts board persp =+  snd $ prunedMinMaxSearch 3 opts board persp Nothing --- Find the best move or one that reaches the given bound.+-- | Find the best move or one that reaches the given bound. prunedMinMaxSearch   :: Int   -> RuleOptions-  -> HalmaBoard size+  -> HalmaBoard   -> Perspective   -> Maybe Rating-  -> (Rating, Move size)+  -> (Rating, Move) 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-+  where+    allOptions =+      sortIfUseful $ do+        move <- allLegalMoves opts board (fst persp)+        pure (rate persp (outcome board move), move)+    sortIfUseful =+      if depth <= 2 then+        id+      else+        sortOn (flipRating . fst)+    go :: Maybe (Rating, Move) -> [(Rating, Move)] -> (Rating, Move)+    go Nothing (option@(rating, _move):options) =+      if isWin rating then+        option+      else+        go (Just $ nextLevel option Nothing) options+    go (Just (currentMax, bestMove)) [] = (currentMax, bestMove)+    go (Just (currentMax, bestMove)) (option@(rating, move):options) =+      if isWin rating then+        option+      else if newRating <= currentMax then+        go (Just (currentMax, bestMove)) options+      else if boundReached newRating then+        (newRating, move)+      else+        go (Just (newRating, move)) options+      where newRating = fst $ nextLevel option (Just currentMax)+    go Nothing [] = error "no legal moves found"+    nextLevel (rating, move) mCurrentMax =+      let newRating =+            if depth <= 1 then+              rating+            else+              pushRating $ flipRating $ fst $+              prunedMinMaxSearch+                (depth-1) opts (outcome board move)+                (flipPersp persp) (fmap flipRating mCurrentMax)+      in (newRating, move)+    boundReached dep = maybe False (dep >=) mBound  isWin :: Rating -> Bool-isWin (WinIn _) = True-isWin _ = False+isWin rating =+  case rating of+    WinIn _ -> True+    _ -> False  flipRating :: Rating -> Rating-flipRating (WinIn n) = LossIn n-flipRating (LossIn n) = WinIn n-flipRating (Rating r) = Rating (-r)+flipRating rating =+  case rating of+    WinIn n -> LossIn n+    LossIn n -> WinIn n+    Rating r -> Rating (-r)  pushRating :: Rating -> Rating-pushRating (WinIn n) = WinIn (n+1)-pushRating (LossIn n) = WinIn (n+1)-pushRating (Rating r) = Rating r+pushRating rating =+  case rating of+    WinIn n -> WinIn (n+1)+    LossIn n -> WinIn (n+1)+    Rating r -> Rating r

@@ -2,31 +2,41 @@   ( aiMove   ) where -import Data.List (maximumBy)-import Data.Ord (comparing) import Game.Halma.Board import Game.Halma.Rules import Game.Halma.AI.Base +import Data.List (maximumBy)+import Data.Ord (comparing) -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+ignorantFixedDepth :: Int -> RuleOptions -> Team -> HalmaBoard -> Rating+ignorantFixedDepth n opts team board =+  if n <= 0 then+    rateTeam team board+  else if hasFinished board team then+    WinIn 0+  else+    beingSomewhatGreedy (rateTeam 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+beingSomewhatGreedy x y =+  case (x, y) of+    (WinIn n, _)  -> WinIn n+    (LossIn n, _) -> LossIn n+    (_, WinIn n)  -> WinIn (n+1)+    (_, LossIn n) -> LossIn (n+1)+    (Rating a, Rating b) ->+      let greedyness = 0.1+      in Rating (greedyness*a + (1-greedyness)*b) -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+aiMove :: RuleOptions -> HalmaBoard -> Team -> Move+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

@@ -1,11 +1,13 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}  module Game.Halma.Board-  ( HalmaGridSize (..), HalmaGrid (..)+  ( HalmaGrid (..)   , sideLength, numberOfFields   , HalmaDirection (..)   , oppositeDirection@@ -15,192 +17,341 @@   , Team   , startCorner, endCorner   , startFields, endFields+  , Piece (..)   , HalmaBoard, getGrid, toMap, fromMap   , lookupHalmaBoard+  , Move (..)   , movePiece   , initialBoard   ) where -import GHC.Generics (Generic)-import Math.Geometry.Grid-import Math.Geometry.Grid.Hexagonal-import qualified Math.Geometry.Grid.HexagonalInternal as HI-import Math.Geometry.GridInternal+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--data HalmaGridSize = S | L--data HalmaGrid :: HalmaGridSize -> * where-  SmallGrid :: HalmaGrid 'S-  LargeGrid :: HalmaGrid 'L+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 -instance Eq (HalmaGrid size) where-  _ == _ = True+data HalmaGrid+  = SmallGrid+  | LargeGrid+  deriving (Eq, Show, Ord) -instance Ord (HalmaGrid size) where-  _ `compare` _ = EQ+instance A.ToJSON HalmaGrid where+  toJSON grid =+    case grid of+      SmallGrid -> "SmallGrid"+      LargeGrid -> "LargeGrid" -instance Show (HalmaGrid size) where-  show SmallGrid = "SmallGrid"-  show 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'"  -- | Numbers of fields on each straight edge of a star-shaped halma board of the -- given size.-sideLength :: HalmaGrid size -> Int-sideLength SmallGrid = 5-sideLength LargeGrid = 6+sideLength :: HalmaGrid -> Int+sideLength grid =+  case grid of+    SmallGrid -> 5+    LargeGrid -> 6  -- | Total number of fields on a halma board of the given size.-numberOfFields :: HalmaGrid size -> Int-numberOfFields SmallGrid = 121-numberOfFields LargeGrid = 181+numberOfFields :: HalmaGrid -> Int+numberOfFields grid =+  case grid of+    SmallGrid -> 121+    LargeGrid -> 181  -- | The six corners of a star-shaped halma board.-data HalmaDirection = North | Northeast | Southeast | South | Southwest | Northwest+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 North = South-oppositeDirection South = North-oppositeDirection Northeast = Southwest-oppositeDirection Southwest = Northeast-oppositeDirection Northwest = Southeast-oppositeDirection Southeast = Northwest+oppositeDirection dir =+  case dir of+    North -> South+    South -> North+    Northeast -> Southwest+    Southwest -> Northeast+    Northwest -> Southeast+    Southeast -> Northwest  leftOf :: HalmaDirection -> HalmaDirection-leftOf North = Northwest-leftOf Northwest = Southwest-leftOf Southwest = South-leftOf South = Southeast-leftOf Southeast = Northeast-leftOf Northeast = North-+leftOf dir =+  case dir of+    North -> Northwest+    Northwest -> Southwest+    Southwest -> South+    South -> Southeast+    Southeast -> Northeast+    Northeast -> North -getDirs :: HalmaDirection -> (HI.HexDirection, HI.HexDirection)-getDirs North = (HI.Northwest, HI.Northeast)-getDirs South = (HI.Southwest, HI.Southeast)-getDirs Northeast = (HI.Northeast, HI.East)-getDirs Northwest = (HI.Northwest, HI.West)-getDirs Southeast = (HI.Southeast, HI.East)-getDirs Southwest = (HI.Southwest, HI.West)+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' :: HI.HexDirection -> (Int, Int) -> (Int, Int)-neighbour' dir = fromJust . flip (neighbour HI.UnboundedHexGrid) dir+neighbour' :: HexGrid.HexDirection -> (Int, Int) -> (Int, Int)+neighbour' dir = fromJust . flip (Grid.neighbour HexGrid.UnboundedHexGrid) dir  -- | From the point of view of the given corner: On which row lies the given -- field? The row through the center is row zero, rows nearer to the corner have -- positive, rows nearer to the opposite corner negative numbers. 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) =-          -- Computes (e+f) where (e,f) is the solution of M*(e,f) = (x,y)-          -- where M is the matrix with column vectors (a,b) and (c,d).-          -- Precondition: det(M) = 1/det(M), i.e. det(M) `elem` [-1,1].-          let det = a*d - b*c-          in det * (x*(d-b) + y*(a-c))-        +rowsInDirection dir =+  cramerPlus (neighbour' dir1 (0,0)) (neighbour' dir2 (0,0))+  where+    (dir1, dir2) = getDirs dir+    cramerPlus (a,b) (c,d) (x,y) =+      -- Computes (e+f) where (e,f) is the solution of M*(e,f) = (x,y)+      -- where M is the matrix with column vectors (a,b) and (c,d).+      -- Precondition: det(M) = 1/det(M), i.e. det(M) `elem` [-1,1].+      let det = a*d - b*c+      in det * (x*(d-b) + y*(a-c))  -- | The corner corresponding to a direction on a star-shaped board of the -- given size.-corner :: HalmaGrid size -> HalmaDirection -> (Int, Int)+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)+  where+    (d1, d2) = getDirs direction+    sl = sideLength halmaGrid - 1+    (x, y) = neighbour' d1 $ neighbour' d2 (0, 0) -instance Grid (HalmaGrid size) where-  type Index (HalmaGrid size) = (Int, Int)-  type Direction (HalmaGrid size) = HI.HexDirection-  indices halmaGrid = filter (contains halmaGrid) roughBoard-    where sl = sideLength halmaGrid - 1-          roughBoard = indices (hexHexGrid (2*sl + 1))-  neighbours = neighboursBasedOn HI.UnboundedHexGrid-  distance = distanceBasedOn HI.UnboundedHexGrid-  directionTo = directionToBasedOn HI.UnboundedHexGrid+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 FiniteGrid (HalmaGrid 'S) where-  type Size (HalmaGrid 'S) = ()-  size _ = ()-  maxPossibleDistance _ = 16+    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 FiniteGrid (HalmaGrid 'L) where-  type Size (HalmaGrid 'L) = ()-  size _ = ()-  maxPossibleDistance _ = 20+instance Grid.FiniteGrid HalmaGrid where+  type Size HalmaGrid = HalmaGrid+  size = id+  maxPossibleDistance = \case+    SmallGrid -> 16+    LargeGrid -> 20 -instance BoundedGrid (HalmaGrid size) where+instance Grid.BoundedGrid HalmaGrid where   tileSideCount _ = 6  -- | The corner where the team starts. type Team = HalmaDirection  -- | The position of the corner field where a team starts.-startCorner :: HalmaGrid size -> Team -> (Int, Int)+startCorner :: HalmaGrid -> Team -> (Int, Int) startCorner = corner  -- | The position of the end zone corner of a team.-endCorner :: HalmaGrid size -> Team -> (Int, Int)+endCorner :: HalmaGrid -> Team -> (Int, Int) endCorner halmaGrid = corner halmaGrid . oppositeDirection  -- | The start positions of a team's pieces.-startFields :: HalmaGrid size -> Team -> [(Int, Int)]-startFields halmaGrid team = filter ((<= 4) . dist) (indices halmaGrid)-  where dist = distance halmaGrid (startCorner halmaGrid team)+startFields :: HalmaGrid -> Team -> [(Int, Int)]+startFields halmaGrid team = filter ((<= 4) . dist) (Grid.indices halmaGrid)+  where dist = Grid.distance halmaGrid (startCorner halmaGrid team)  -- | The end zone of the given team.-endFields :: HalmaGrid size -> Team -> [(Int, Int)]+endFields :: HalmaGrid -> Team -> [(Int, Int)] endFields halmaGrid = startFields halmaGrid . oppositeDirection +-- | Halma gaming piece+data Piece+  = Piece+  { pieceTeam :: Team  -- ^ player+  , pieceNumber :: Word8 -- ^ number between 1 and 15+  } 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 }+ -- | Map from board positions to the team occupying that position.-data HalmaBoard size =-       HalmaBoard { getGrid :: HalmaGrid size-                  , toMap :: M.Map (Int, Int) Team-                  } deriving (Eq)+data HalmaBoard =+  HalmaBoard+  { getGrid :: HalmaGrid+  , toMap :: M.Map (Int, Int) Piece+  } deriving (Eq, Show) -instance Show (HalmaBoard size) where-  show (HalmaBoard halmaGrid m) = "fromMap " ++ show halmaGrid ++ " (" ++ show m ++ ")"+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+          ] --- | Construct halma boards. Satisfies @fromMap (getGrid board) (toMap board) = Just board@.-fromMap :: HalmaGrid size -> M.Map (Index (HalmaGrid size)) Team -> Maybe (HalmaBoard size)-fromMap halmaGrid m = if invariantsHold then Just (HalmaBoard halmaGrid m) else Nothing-  where invariantsHold = indicesCorrect && rightTeamPieces-        list = M.toList m-        indicesCorrect = all (contains halmaGrid . fst) list-        rightTeamPieces = all rightNumberOfTeamPieces [minBound..maxBound]-        rightNumberOfTeamPieces team =-          length (filter ((== team) . snd) list) `elem` [0,15]+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) --- | Lookup whether a position on the board is occupied, and -lookupHalmaBoard :: (Int, Int) -> HalmaBoard size -> Maybe Team+-- | Construct halma boards. Satisfies+-- @fromMap (getGrid board) (toMap board) = Just board@.+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]++-- | Lookup whether a position on the board is occupied, and+lookupHalmaBoard :: (Int, Int) -> HalmaBoard -> Maybe Piece lookupHalmaBoard p = M.lookup p . toMap +-- | A move of piece on a (Halma) board.+data Move+  = Move+  { moveFrom :: (Int, Int) -- ^ start position+  , moveTo :: (Int, Int) -- ^ end position, must be different from start position+  } 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"+ -- | Move a piece on the halma board. This function does not check whether the -- move is valid according to the Halma rules. movePiece-  :: (Int, Int) -- ^ start position-  -> (Int, Int) -- ^ end position-  -> HalmaBoard size-  -> Either String (HalmaBoard size)-movePiece startPos endPos (HalmaBoard halmaGrid m) =+  :: 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 team ->+    Just piece ->       case M.lookup endPos m of-        Just team' -> Left $ "cannot make move: end position is occupied by team " ++ show team'-        Nothing -> Right $ HalmaBoard halmaGrid $ M.insert endPos team $ M.delete startPos m+        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 size -> (Team -> Bool) -> HalmaBoard size+initialBoard :: HalmaGrid -> (Team -> Bool) -> HalmaBoard initialBoard halmaGrid chosenTeams = HalmaBoard halmaGrid (M.fromList lineUps)-  where lineUps = concatMap (\team -> if chosenTeams team then lineUp team else [])-                            [minBound..maxBound]-        lineUp team = map (flip (,) team) (startFields halmaGrid team)+  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 []

@@ -6,23 +6,27 @@   ) where  import Game.Halma.Board-import Math.Geometry.Grid+ import Diagrams.Prelude+import Math.Geometry.Grid  defaultTeamColours :: Team -> Colour Double-defaultTeamColours North = yellow-defaultTeamColours South = red-defaultTeamColours Northwest = cyan-defaultTeamColours Northeast = orange-defaultTeamColours Southwest = pink-defaultTeamColours Southeast = blue+defaultTeamColours team =+  -- colors from http://clrs.cc/+  case team of+    North     -> sRGB24read "#0074D9" -- blue+    Northeast -> sRGB24read "#2ECC40" -- green+    Northwest -> sRGB24read "#B10DC9" -- purple+    South     -> sRGB24read "#FF4136" -- red+    Southeast -> sRGB24read "#111111" -- black+    Southwest -> sRGB24read "#FF851B" -- orange  -- | Render the board using the helper function for drawing the fields. -- Supports querying for field positions. drawBoard'   :: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b)-  => HalmaGrid size-  -> ((Int,Int) -> Diagram b)+  => HalmaGrid+  -> ((Int, Int) -> Diagram b)   -> QDiagram b V2 Double (Option (Last (Int, Int))) drawBoard' grid drawField =     targets `atop`@@ -31,29 +35,30 @@       , circles 0.15 # fc gray # lw none       , gridLines # lc gray # lw thin       ] # value (Option Nothing))-  where dirX = unitX-        dirY = rotateBy (1/6) unitX-        toCoord (x, y) = p2 $ unr2 $ fromIntegral x *^ dirX ^+^ fromIntegral y *^ dirY-        justLast = Option . Just . Last-        clickTarget = circle 0.4 # lw none-        targets = position $ map (\f -> (toCoord f, clickTarget # value (justLast f))) fields-        fields = indices grid-        circles r = position $ zip (map toCoord fields) $ repeat $ circle r-        gridLines =-          mconcat $ map (\(p, q) -> fromVertices [toCoord p, toCoord q]) $-          concatMap (\f -> map ((,) f) $ filter (>= f) (neighbours grid f)) fields-        pieces = position $ map (\p -> (toCoord p, drawField p)) fields+  where+    dirX = unitX+    dirY = rotateBy (1/6) unitX+    toCoord (x, y) = p2 $ unr2 $ fromIntegral x *^ dirX ^+^ fromIntegral y *^ dirY+    justLast = Option . Just . Last+    clickTarget = circle 0.4 # lw none+    targets = position $ map (\f -> (toCoord f, clickTarget # value (justLast f))) fields+    fields = indices grid+    circles r = position $ zip (map toCoord fields) $ repeat $ circle r+    gridLines =+      mconcat $ map (\(p, q) -> fromVertices [toCoord p, toCoord q]) $+      concatMap (\f -> map ((,) f) $ filter (>= f) (neighbours grid f)) fields+    pieces = position $ map (\p -> (toCoord p, drawField p)) fields  -- | Render the board using the given team colors. Supports querying for field -- positions. drawBoard   :: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b)-  => HalmaBoard size+  => HalmaBoard   -> (Team -> Colour Double)   -> QDiagram b V2 Double (Option (Last (Int, Int)))-drawBoard halmaBoard teamColors = drawBoard' (getGrid halmaBoard) drawField-  where drawPiece t =-          let c = teamColors t-          in circle 0.25 # fc c # lc (darken 0.5 c)-        drawField = maybe mempty drawPiece . flip lookupHalmaBoard halmaBoard-+drawBoard halmaBoard teamColours = drawBoard' (getGrid halmaBoard) drawField+  where+    drawPiece piece =+      let c = teamColours (pieceTeam piece)+      in circle 0.25 # fc c # lc (darken 0.5 c)+    drawField = maybe mempty drawPiece . flip lookupHalmaBoard halmaBoard

@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module Game.Halma.Configuration+  ( HalmaPlayers (..)+  , Configuration, configurationGrid, configurationPlayers+  , configuration+  , twoPlayersOnSmallGrid, threePlayersOnSmallGrid+  , playersOnLargeGrid+  , setSmallGrid, setLargeGrid+  , addPlayerToConfig+  , newGame+  ) where++import Game.Halma.Board+import Game.TurnCounter++import Data.Aeson ((.=), (.:))+import Data.Foldable (toList)+import qualified Data.Aeson as A++data HalmaPlayers a+  = TwoPlayers a a+  | ThreePlayers a a a+  | FourPlayers a a a a+  | FivePlayers a a a a a+  | SixPlayers a a a a a a+  deriving (Eq, Show, Functor, Foldable, Traversable)++instance A.ToJSON a => A.ToJSON (HalmaPlayers a) where+  toJSON = A.toJSON . toList++instance A.FromJSON a => A.FromJSON (HalmaPlayers a) where+  parseJSON val = do+    parsedPlayers <- A.parseJSON val+    case parsedPlayers of+      [a,b] -> pure (TwoPlayers a b)+      [a,b,c] -> pure (ThreePlayers a b c)+      [a,b,c,d] -> pure (FourPlayers a b c d)+      [a,b,c,d,e] -> pure (FivePlayers a b c d e)+      [a,b,c,d,e,f] -> pure (SixPlayers a b c d e f)+      _ ->+        fail $ "unexpected count of players for a Halma board: " ++ show (length parsedPlayers)++getPlayers :: HalmaPlayers a -> [(Team, a)]+getPlayers halmaPlayers =+  case halmaPlayers of+    TwoPlayers a b ->+      [(North, a), (South, b)]+    ThreePlayers a b c ->+      [(Northeast, a), (South, b), (Northwest, c)]+    FourPlayers a b c d ->+      [(Northeast, a), (Southeast, b), (Southwest, c), (Northwest, d)]+    FivePlayers a b c d e ->+      [(Northeast, a), (Southeast, b), (South, c), (Southwest, d), (Northwest, e)]+    SixPlayers a b c d e f ->+      [(North, a), (Northeast, b), (Southeast, c), (South, d), (Southwest, e), (Northwest, f)]++data Configuration a+  = Configuration+  { configurationGrid :: HalmaGrid+  , configurationPlayers :: HalmaPlayers a+  } deriving (Eq, Show, Functor, Foldable, Traversable)++configuration :: HalmaGrid -> HalmaPlayers a -> Maybe (Configuration a)+configuration grid players =+  if grid /= SmallGrid || length players <= 3 then+    Just+      Configuration+        { configurationGrid = grid+        , configurationPlayers = players+        }+  else+    Nothing++instance A.ToJSON a => A.ToJSON (Configuration a) where+  toJSON config =+    A.object+      [ "grid" .= configurationGrid config+      , "players" .= configurationPlayers config+      ]++instance A.FromJSON a => A.FromJSON (Configuration a) where+  parseJSON =+    A.withObject "Configuration" $ \o -> do+      grid <- o .: "grid"+      players <- o .: "players"+      case configuration grid players of+        Nothing -> fail "too many players for small grid!"+        Just config -> pure config++twoPlayersOnSmallGrid :: a -> a -> Configuration a+twoPlayersOnSmallGrid a b = Configuration SmallGrid (TwoPlayers a b)++threePlayersOnSmallGrid :: a -> a -> a -> Configuration a+threePlayersOnSmallGrid a b c = Configuration SmallGrid (ThreePlayers a b c)++playersOnLargeGrid :: HalmaPlayers a -> Configuration a+playersOnLargeGrid players = Configuration LargeGrid players++setSmallGrid :: Configuration a -> Maybe (Configuration a)+setSmallGrid config =+  if length (configurationPlayers config) <= 3 then+    Just (config { configurationGrid = SmallGrid })+  else+    Nothing++setLargeGrid :: Configuration a -> Configuration a+setLargeGrid config =+  config { configurationGrid = LargeGrid }++addPlayerToConfig :: a -> Configuration a -> Configuration a+addPlayerToConfig new config =+  case configurationPlayers config of+    TwoPlayers a b ->+      Configuration (configurationGrid config) (ThreePlayers a b new)+    ThreePlayers a b c ->+      Configuration LargeGrid (FourPlayers a b c new)+    FourPlayers a b c d ->+      Configuration LargeGrid (FivePlayers a b c d new)+    FivePlayers a b c d e ->+      Configuration LargeGrid (SixPlayers a b c d e new)+    SixPlayers {} -> config++newGame :: Configuration a -> (HalmaBoard, TurnCounter (Team, a))+newGame config =+  ( initialBoard (configurationGrid config) isActive+  , newTurnCounter parties+  )+  where+    parties = getPlayers (configurationPlayers config)+    isActive color = color `elem` (fst <$> parties)

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Game.Halma.Rules   ( MoveRestriction (..)   , RuleOptions (..)@@ -5,114 +7,159 @@   , hasFinished   ) where -import Math.Geometry.Grid-import qualified Math.Geometry.Grid.HexagonalInternal as HI import Game.Halma.Board++import Control.Monad (guard)+import Data.Aeson ((.=), (.:)) import Data.Default import Data.Function (on)-import Data.Maybe (catMaybes)-import Control.Monad (guard)+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 -- 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+data MoveRestriction+  = Allowed     -- ^ moves of this kind of field are allowed+  | Temporarily -- ^ the player can pass the field but cannot occupy it+  | Forbidden   -- ^ the player can't pass or occupy the field   deriving (Show, Eq) -data RuleOptions =-  RuleOptions { movingBackwards :: MoveRestriction -- ^ May pieces be moved backwards?-              , invading :: MoveRestriction -- ^ May pieces be moved into other star corners?-              } 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 -- ^ May pieces be moved backwards?+  , invading :: MoveRestriction -- ^ May pieces be moved into other star corners?+  } 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 }+  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 size -> [(Int, Int)] -> [(Int, Int)]+filterNonInvading :: Team -> HalmaGrid -> [(Int, Int)] -> [(Int, Int)] filterNonInvading team grid = filter $ \field -> all-  ((<= sideLength grid - 1) . abs . flip rowsInDirection field) +  ((<= sideLength grid - 1) . abs . flip rowsInDirection field)   [leftOf team, leftOf (leftOf team)]- + possibleStepMoves   :: RuleOptions-  -> HalmaBoard size+  -> HalmaBoard   -> (Int, Int)   -> [(Int, Int)] possibleStepMoves ruleOptions halmaBoard startPos =   case lookupHalmaBoard startPos halmaBoard of     Nothing -> []-    Just team ->-      ruleOptsFilters $+    Just piece ->+      ruleOptsFilters (pieceTeam piece) $       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+  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 size+  -> HalmaBoard   -> (Int, Int)   -> [(Int, Int)] possibleJumpMoves ruleOptions halmaBoard startPos =   case lookupHalmaBoard startPos halmaBoard of     Nothing -> []-    Just team ->-      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+    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  -- | Computes all possible moves for a piece. possibleMoves   :: RuleOptions-  -> HalmaBoard size+  -> HalmaBoard   -> (Int, Int)   -> [(Int, Int)]-possibleMoves ruleOptions halmaBoard startPos =-  possibleStepMoves ruleOptions halmaBoard startPos ++-  possibleJumpMoves ruleOptions halmaBoard startPos+possibleMoves = possibleStepMoves <> possibleJumpMoves  -- | Has a team all of it's pieces in the end zone?-hasFinished :: HalmaBoard size -> Team -> Bool+hasFinished :: HalmaBoard -> Team -> Bool hasFinished halmaBoard team =-  all ((==) (Just team) . flip lookupHalmaBoard halmaBoard)-      (endFields (getGrid halmaBoard) team)+  all hasPieceFromTheRightTeam (endFields (getGrid halmaBoard) team)+  where+    hasTheRightTeam piece = pieceTeam piece == team+    hasPieceFromTheRightTeam pos =+      maybe False hasTheRightTeam (lookupHalmaBoard pos halmaBoard)

@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveFunctor #-}++module Game.TurnCounter+  ( TurnCounter (..)+  , newTurnCounter+  , nextTurn, nextTurnWith+  , previousTurn, previousTurnWith+  , currentPlayer+  , nextPlayer+  , previousPlayer+  , currentRound+  ) where++import Data.List (find)++data TurnCounter p+  = TurnCounter+  { tcPlayers :: [p]+  , tcCounter :: Int+  } deriving (Eq, Show, Functor)++newTurnCounter :: [p] -> TurnCounter p+newTurnCounter players =+  TurnCounter+    { tcPlayers = players+    , tcCounter = 0+    }++nextTurn :: TurnCounter p -> TurnCounter p+nextTurn (TurnCounter ps c) = TurnCounter ps (c+1)++nextTurnWith :: (p -> Bool) -> TurnCounter p -> Maybe (TurnCounter p)+nextTurnWith predicate tc =+  find (predicate . currentPlayer) $+  take (length (tcPlayers tc)) $+  iterate nextTurn (nextTurn tc)++previousTurn :: TurnCounter p -> TurnCounter p+previousTurn (TurnCounter ps c) = TurnCounter ps (c-1)++previousTurnWith :: (p -> Bool) -> TurnCounter p -> Maybe (TurnCounter p)+previousTurnWith predicate tc =+  find (predicate . currentPlayer) $+  take (length (tcPlayers tc)) $+  iterate previousTurn (previousTurn tc)++currentPlayer :: TurnCounter p -> p+currentPlayer (TurnCounter ps c) = ps !! (c `mod` length ps)++nextPlayer :: TurnCounter p -> p+nextPlayer = currentPlayer . nextTurn++previousPlayer :: TurnCounter p -> p+previousPlayer = currentPlayer . previousTurn++currentRound :: TurnCounter p -> Int+currentRound (TurnCounter ps c) = c `div` length ps

@@ -5,21 +5,19 @@  module Game.Halma.Board.Tests (tests) where +import Control.Monad (forM_)+import Data.List (permutations, sortBy)+import Data.Maybe (isJust, fromJust)+import Data.Function (on)+import Game.Halma.Board+import Math.Geometry.Grid import Test.HUnit hiding (Test) import Test.QuickCheck hiding (Result) import Test.Framework import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty)--import Data.List (permutations, sortBy)-import Data.Maybe (isJust, fromJust)-import Data.Function (on)-import Control.Monad (forM_) import qualified Data.Map.Strict as M--import Math.Geometry.Grid-import qualified Math.Geometry.Grid.HexagonalInternal as HI-import Game.Halma.Board+import qualified Math.Geometry.Grid.HexagonalInternal as HexGrid  testRowsInDirection :: Assertion testRowsInDirection =@@ -39,11 +37,11 @@   [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-    distCenter :: HalmaGrid s -> (Int, Int) -> Int+    distCenter :: HalmaGrid -> (Int, Int) -> Int     distCenter hg = distance hg (0, 0)-    fieldsAtDistance :: HalmaGrid s -> Int -> [(Int, Int)]+    fieldsAtDistance :: HalmaGrid -> Int -> [(Int, Int)]     fieldsAtDistance hg d = filter ((== d) . distCenter hg) (indices hg)-    actual :: HalmaGrid s -> [Int]+    actual :: HalmaGrid -> [Int]     actual hg = map (length . fieldsAtDistance hg) [0,1..]  testBoundaryLength :: Assertion@@ -54,24 +52,28 @@ testDirectionTo :: Assertion testDirectionTo = do   let c = corner SmallGrid-  [HI.Northeast] @=? directionTo SmallGrid (c South) (c Southeast)-  [HI.Northeast] @=? directionTo SmallGrid (c South) (c Northeast)+  [HexGrid.Northeast] @=? directionTo SmallGrid (c South) (c Southeast)+  [HexGrid.Northeast] @=? directionTo SmallGrid (c South) (c Northeast)   assertOneOf     (directionTo SmallGrid (c South) (c North))-    (permutations [HI.Northeast, HI.Northwest])+    (permutations [HexGrid.Northeast, HexGrid.Northwest])  assertOneOf :: (Eq a, Show a) => a -> [a] -> Assertion assertOneOf actual validResults = assertBool msg (actual `elem` validResults)   where msg = "Expected '" ++ show actual ++ "' to be one of '" ++ show validResults ++ "'" -numbersCorrect :: HalmaGrid size -> [Maybe Team] -> Bool-numbersCorrect halmaGrid = go 15 15 (numberOfFields halmaGrid - 2*15)-  where go :: Int -> Int -> Int -> [Maybe Team] -> Bool-        go 0 0 0 [] = True-        go !n !s !e (Just North : rs) = go (n-1) s e rs-        go !n !s !e (Just South : rs) = go n (s-1) e rs-        go !n !s !e (Nothing : rs) = go n s (e-1) rs-        go _ _ _ _ = False+numbersCorrect :: HalmaGrid -> [Maybe Piece] -> Bool+numbersCorrect grid = go 15 15 (numberOfFields grid - 2*15)+  where+    go :: Int -> Int -> Int -> [Maybe Piece] -> Bool+    go 0 0 0 [] = True+    go _ _ _ [] = False+    go !n !s !e (piece : pieces) =+      case pieceTeam <$> piece of+        Just North -> go (n-1) s e pieces+        Just South -> go n (s-1) e pieces+        Just _otherTeam -> False+        Nothing -> go n s (e-1) pieces  testInitialBoard :: Assertion testInitialBoard = ass SmallGrid >> ass LargeGrid@@ -79,62 +81,66 @@     ass hg = assertBool "Expected 15 pieces of team north and south" $ numbersCorrect hg (pieces hg)     pieces hg = map (\p -> lookupHalmaBoard p (initialBoard hg twoPlayers)) (indices hg)     twoPlayers :: Team -> Bool-    twoPlayers North = True-    twoPlayers South = True-    twoPlayers _ = False+    twoPlayers team = team `elem` [North, South]  arbitraryPerm :: [a] -> Gen [a] arbitraryPerm xs =   fmap (map fst . sortBy (compare `on` snd) . zip xs)        (vectorOf (length xs) arbitrary :: Gen [Double]) -genBoard :: HalmaGrid size -> Gen (HalmaBoard size)-genBoard halmaGrid = do-  pieces <- arbitraryPerm (indices halmaGrid)+genBoard :: HalmaGrid -> Gen HalmaBoard+genBoard grid = do+  pieces <- arbitraryPerm (indices grid)   let (northTeam, restPieces) = splitAt 15 pieces       southTeam = take 15 restPieces-  return $ fromJust $ fromMap halmaGrid $ M.fromList $-    map (flip (,) North) northTeam ++-    map (flip (,) South) southTeam+  return $ fromJust $ fromMap grid $ M.fromList $+    mkPieces North northTeam +++    mkPieces South southTeam+  where+    mkPieces team positions =+      let mkPiece pos ix = (pos, Piece { pieceNumber = ix, pieceTeam = team})+      in zipWith mkPiece positions [1..15] -instance Arbitrary (HalmaBoard 'S) where-  arbitrary = genBoard SmallGrid+instance Arbitrary HalmaGrid where+  arbitrary = elements [SmallGrid, LargeGrid] -instance Arbitrary (HalmaBoard 'L) where-  arbitrary = genBoard LargeGrid+instance Arbitrary HalmaBoard where+  arbitrary = do+    grid <- arbitrary+    genBoard grid -genHalmaGridPos :: HalmaGrid size -> Gen (Int, Int)-genHalmaGridPos halmaGrid = elements (indices halmaGrid)+genHalmaGridPos :: HalmaGrid -> Gen (Int, Int)+genHalmaGridPos grid = elements (indices grid) -prop_fromMap :: HalmaBoard size -> Bool+prop_fromMap :: HalmaBoard -> Bool prop_fromMap halmaBoard = fromMap (getGrid halmaBoard) (toMap halmaBoard) == Just halmaBoard -prop_moveNumbersInvariant :: HalmaBoard size -> Gen Bool-prop_moveNumbersInvariant halmaBoard = do-  let halmaGrid = getGrid halmaBoard-  startPos <- genHalmaGridPos halmaGrid-  endPos <- genHalmaGridPos halmaGrid-  case movePiece startPos endPos halmaBoard of+prop_moveNumbersInvariant :: HalmaBoard -> Gen Bool+prop_moveNumbersInvariant board = do+  let grid = getGrid board+  startPos <- genHalmaGridPos grid+  endPos <- genHalmaGridPos grid+  let move = Move { moveFrom = startPos, moveTo = endPos }+  case movePiece move board of     Left _err ->       -- may only fail when there is no piece on the start position or a piece       -- on the end position-      return $ lookupHalmaBoard startPos halmaBoard == Nothing || isJust (lookupHalmaBoard endPos halmaBoard)-    Right halmaBoard' -> do-      let pieces = map (\p -> lookupHalmaBoard p halmaBoard') (indices halmaGrid)-      return $ lookupHalmaBoard endPos halmaBoard' == lookupHalmaBoard startPos halmaBoard &&-               lookupHalmaBoard endPos halmaBoard  == lookupHalmaBoard startPos halmaBoard' &&-               numbersCorrect halmaGrid pieces-+      return $ lookupHalmaBoard startPos board == Nothing || isJust (lookupHalmaBoard endPos board)+    Right board' -> do+      let pieces = map (\p -> lookupHalmaBoard p board') (indices grid)+      return $+        lookupHalmaBoard endPos board' == lookupHalmaBoard startPos board &&+        lookupHalmaBoard endPos board  == lookupHalmaBoard startPos board' &&+        numbersCorrect grid pieces  tests :: Test-tests = testGroup "Game.Halma.Board.Tests"+tests =+  testGroup "Game.Halma.Board.Tests"   [ testCase "testRowsInDirection" testRowsInDirection   , testCase "testDistancesFromCenter" testDistancesFromCenter   , testCase "testBoundaryLength" testBoundaryLength   , testCase "testDirectionTo" testDirectionTo   , testCase "testInitialBoard" testInitialBoard-  , testProperty "prop_fromMap(S)" (prop_fromMap :: HalmaBoard 'S -> Bool)-  , testProperty "prop_fromMap(L)" (prop_fromMap :: HalmaBoard 'L -> Bool)-  , testProperty "prop_moveNumbersInvariant(S)" (prop_moveNumbersInvariant :: HalmaBoard 'S -> Gen Bool)-  , testProperty "prop_moveNumbersInvariant(L)" (prop_moveNumbersInvariant :: HalmaBoard 'L -> Gen Bool)+  , testProperty "prop_fromMap" prop_fromMap+  , testProperty "prop_moveNumbersInvariant" prop_moveNumbersInvariant   ]