diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/halma.cabal b/halma.cabal --- a/halma.cabal +++ b/halma.cabal @@ -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 diff --git a/halma.hs b/halma.hs deleted file mode 100644 --- a/halma.hs +++ /dev/null @@ -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 diff --git a/src/Game/Halma/AI/Base.hs b/src/Game/Halma/AI/Base.hs --- a/src/Game/Halma/AI/Base.hs +++ b/src/Game/Halma/AI/Base.hs @@ -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 } diff --git a/src/Game/Halma/AI/Competitive.hs b/src/Game/Halma/AI/Competitive.hs --- a/src/Game/Halma/AI/Competitive.hs +++ b/src/Game/Halma/AI/Competitive.hs @@ -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 diff --git a/src/Game/Halma/AI/Ignorant.hs b/src/Game/Halma/AI/Ignorant.hs --- a/src/Game/Halma/AI/Ignorant.hs +++ b/src/Game/Halma/AI/Ignorant.hs @@ -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 diff --git a/src/Game/Halma/Board.hs b/src/Game/Halma/Board.hs --- a/src/Game/Halma/Board.hs +++ b/src/Game/Halma/Board.hs @@ -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 [] diff --git a/src/Game/Halma/Board/Draw.hs b/src/Game/Halma/Board/Draw.hs --- a/src/Game/Halma/Board/Draw.hs +++ b/src/Game/Halma/Board/Draw.hs @@ -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 diff --git a/src/Game/Halma/Configuration.hs b/src/Game/Halma/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Game/Halma/Configuration.hs @@ -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) diff --git a/src/Game/Halma/Rules.hs b/src/Game/Halma/Rules.hs --- a/src/Game/Halma/Rules.hs +++ b/src/Game/Halma/Rules.hs @@ -1,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) diff --git a/src/Game/TurnCounter.hs b/src/Game/TurnCounter.hs new file mode 100644 --- /dev/null +++ b/src/Game/TurnCounter.hs @@ -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 diff --git a/test/Game/Halma/Board/Tests.hs b/test/Game/Halma/Board/Tests.hs --- a/test/Game/Halma/Board/Tests.hs +++ b/test/Game/Halma/Board/Tests.hs @@ -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 ]