packages feed

halma (empty) → 0.1.0.0

raw patch · 8 files changed

+789/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +asyncsetup-changed

Dependencies added: HUnit, QuickCheck, async, base, containers, data-default, diagrams-cairo, diagrams-gtk, diagrams-lib, grid, gtk, halma, mtl, mvc, pipes, test-framework, test-framework-hunit, test-framework-quickcheck2, timeit, vector-space-points

Files

+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)+Copyright © 2014-2015 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+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ halma.cabal view
@@ -0,0 +1,61 @@+name:                halma+version:             0.1.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+license:             MIT+license-file:        LICENSE+author:              Tim Baumann+maintainer:          tim@timbaumann.info+copyright:           2014-2015 Tim Baumann+category:            Game+build-type:          Simple+cabal-version:       >= 1.10++library+  ghc-options:         -Wall+  exposed-modules:     Game.Halma.Board,+                       Game.Halma.Rules,+                       Game.Halma.Board.Draw+  build-depends:       base >= 4.6 && < 5,+                       grid >= 7.6.7 && < 7.8,+                       containers >= 0.5 && < 0.6,+                       diagrams-lib >= 1.2.0.7 && < 1.3,+                       data-default >= 0.4 && < 0.6+  hs-source-dirs:      src+  default-language:    Haskell2010++Test-suite tests+  Ghc-options:         -Wall+  Hs-source-dirs:      test+  type:                exitcode-stdio-1.0+  main-is:             Main.hs+  default-language:    Haskell2010+  Build-depends:       halma,+                       grid,+                       HUnit,+                       QuickCheck,+                       base,+                       containers,+                       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 -O2 -Wall+  build-depends:       halma,+                       base >= 4.7 && < 5,+                       diagrams-gtk >= 1.0.1.3 && < 1.1,+                       gtk >= 0.13.4 && < 0.14,+                       mtl,+                       diagrams-lib,+                       diagrams-cairo,+                       pipes >= 4.1.4 && < 4.2,+                       mvc >= 1.0.3 && < 1.1,+                       vector-space-points,+                       async >= 2.0.2 && < 2.1,+                       data-default,+                       timeit >= 1.0 && < 1.1+  default-language:    Haskell2010+  main-is:             halma.hs+
+ halma.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++module Main (main) where++import Game.Halma.Board+import Game.Halma.Rules+import Data.Default+import Game.Halma.Board.Draw+import Graphics.UI.Gtk hiding (get)+import Diagrams.Prelude hiding ((<>))+import Diagrams.TwoD.Size (requiredScale)+import Diagrams.TwoD.Text (Text)+import Diagrams.Backend.Gtk+import Diagrams.Backend.Cairo.Internal (Cairo)+import Data.AffineSpace.Point+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+++sizedCentered :: (Transformable a, Enveloped a, V a ~ R2) => SizeSpec2D -> a -> a+sizedCentered spec d = transform adjustT d+  where+    size = size2D d+    s    = requiredScale spec size+    finalSz = case spec of+      Dims w h -> (w,h)+      _        -> scale s size+    tr = (0.5 *. p2 finalSz) .-. (s *. center2D d)+    adjustT = translation tr <> scaling s++centered :: (Transformable a, Enveloped a, V a ~ R2) => SizeSpec2D -> a -> a+centered spec d = transform adjustT d+  where+    size = size2D d+    s    = requiredScale spec size+    finalSz = case spec of+      Dims w h -> (w,h)+      _        -> scale s size+    tr = (0.5 *. p2 finalSz) .-. center2D d+    adjustT = translation tr+++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+  } 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+                 }++initialState :: State+initialState = State initialMenuState Nothing++data HalmaViewState size =+  HalmaViewState+  { _hvsBoard :: HalmaBoard size+  , _hvsSelectedField :: Maybe (Int, Int)+  , _hvsHighlightedFields :: [(Int, Int)]+  } 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 ViewEvent = Quit QuitType+               | SetMenuState MenuState+               | NewGame+               | FieldClick (Int, Int)+               | EmptyClick+               deriving (Eq, Show)++renderHalmaViewState+  :: Renderable (Path R2) b+  => (Team -> Colour Double)+  -> HalmaViewState size+  -> QDiagram b R2 (Option (Last (Int, Int)))+renderHalmaViewState teamColors (HalmaViewState board startPos highlighted) =+  drawBoard' (getGrid board) drawField+  where+    drawPiece t =+      let c = teamColors t+      in circle 0.25 # fc c # lc (darken 0.5 c)+    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+        (Nothing, Just t) | p `elem` highlighted ->+          drawPiece t # opacity 0.5+        _ -> mempty++data ButtonState a = ButtonActive a+                   | ButtonInactive+                   | ButtonSelected deriving (Eq, Show)++button+  :: (Renderable (Path R2) b, Renderable Text b, Backend b R2)+  => String+  -> ButtonState a+  -> QDiagram b R2 (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++renderMenu+  :: (Renderable (Path R2) b, Renderable Text b, Backend b R2)+  => MenuState+  -> QDiagram b R2 (Option (Last MenuState))+renderMenu (MenuState gridSize nop) =+  ((===) `F.on` (centerX . horizontal)) sizeButtons playerButtons+  where+    setPlayers = MenuState gridSize+    playerButtonAction nop' = if (nop == nop') then ButtonSelected else ButtonActive (setPlayers nop')+    horizontal = foldl (|||) mempty+    (sizeButtons, playerButtons) = case gridSize of+      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 R2 (Option (Last ViewEvent))+renderViewState _teamColors (w,h) (MenuView menuState) =+  let menuDiagram   = fmap (fmap SetMenuState) <$> renderMenu menuState+      newGameButton = button "New Game" (ButtonActive NewGame) # padY 1.5+      reposition    = centered (Dims w h) . toGtkCoords+  in reposition (menuDiagram === newGameButton)+renderViewState teamColors (w,h) (HalmaView halmaViewState) =+  let resize = sizedCentered (Dims w h) . toGtkCoords . pad 1.05+      quitGameButton =+        toGtkCoords $ padY 1.3 $ alignX (-1) $+        button "Quit Game" $ ButtonActive $ Quit QuitGame+      field = resize (fmap (fmap FieldClick) <$> renderHalmaViewState teamColors halmaViewState)+  in quitGameButton `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) = noSelectionLoop+  where+    team = currentPlayer turnCounter+    noSelectionLoop = do+      yield $ HalmaViewState board Nothing []+      event <- await+      case event of+        EmptyClick -> noSelectionLoop+        FieldClick p | lookupHalmaBoard p board == Just team ->+          selectionLoop p+        FieldClick _ -> noSelectionLoop+        Quit quitType -> return quitType+        _ -> return QuitApp+    selectionLoop startPos = do+      let possible = possibleMoves ruleOptions board startPos+      yield $ HalmaViewState board (Just startPos) possible+      event <- await+      case event of+        EmptyClick -> noSelectionLoop+        FieldClick p | p `elem` possible -> do+          let Right board' = movePiece startPos p board+              halmaState' = HalmaState ruleOptions board' (nextTurn turnCounter)+          State menuState _halmaState <- MS.get+          MS.put $ State menuState (Just halmaState')+          gameLoop halmaState'+        FieldClick p | lookupHalmaBoard p board == Just team ->+          selectionLoop p+        FieldClick _ -> noSelectionLoop+        Quit quitType -> return quitType+        _ -> return QuitApp++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
+ src/Game/Halma/Board.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}++module Game.Halma.Board+  ( HalmaGridSize (..), HalmaGrid (..)+  , sideLength, numberOfFields+  , HalmaDirection (..)+  , oppositeDirection+  , rowsInDirection+  , corner+  , Team+  , startCorner, endCorner+  , startFields, endFields+  , HalmaBoard, getGrid, toMap, fromMap+  , lookupHalmaBoard+  , 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 Data.Maybe (fromJust)+import qualified Data.Map.Strict as M++data HalmaGridSize = S | L++data HalmaGrid :: HalmaGridSize -> * where+  SmallGrid :: HalmaGrid 'S+  LargeGrid :: HalmaGrid 'L++instance Eq (HalmaGrid size) where+  _ == _ = True++instance Ord (HalmaGrid size) where+  _ `compare` _ = EQ++instance Show (HalmaGrid size) where+  show SmallGrid = "SmallGrid"+  show LargeGrid = "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++-- | Total number of fields on a halma board of the given size.+numberOfFields :: HalmaGrid size -> Int+numberOfFields SmallGrid = 121+numberOfFields LargeGrid = 181++-- | The six corners of a star-shaped halma board.+data HalmaDirection = North | Northeast | Southeast | South | Southwest | Northwest+  deriving (Eq, Show, Read, Ord, Bounded, Enum, Generic)++oppositeDirection :: HalmaDirection -> HalmaDirection+oppositeDirection North = South+oppositeDirection South = North+oppositeDirection Northeast = Southwest+oppositeDirection Southwest = Northeast+oppositeDirection Northwest = Southeast+oppositeDirection Southeast = Northwest++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)++neighbour' :: HI.HexDirection -> (Int, Int) -> (Int, Int)+neighbour' dir = fromJust . flip (neighbour HI.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))+        ++-- | The corner corresponding to a direction on a star-shaped board of the+-- given size.+corner :: HalmaGrid size -> 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)++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+  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++instance FiniteGrid (HalmaGrid L) where+  type Size (HalmaGrid L) = ()+  size _ = ()+  maxPossibleDistance _ = 20++instance BoundedGrid (HalmaGrid size) 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 = corner++-- | The position of the end zone corner of a team.+endCorner :: HalmaGrid size -> 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)++-- | The end zone of the given team.+endFields :: HalmaGrid size -> Team -> [(Int, Int)]+endFields halmaGrid = startFields halmaGrid . oppositeDirection++-- | 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)++instance Show (HalmaBoard size) where+  show (HalmaBoard halmaGrid m) = "fromMap " ++ show halmaGrid ++ " (" ++ show m ++ ")"++-- | 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]++-- | Lookup whether a position on the board is occupied, and +lookupHalmaBoard :: (Int, Int) -> HalmaBoard size -> Maybe Team+lookupHalmaBoard p = M.lookup p . toMap++-- | 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) =+  case M.lookup startPos m of+    Nothing -> Left "cannot make move: start position is empty"+    Just team ->+      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++initialBoard :: HalmaGrid size -> (Team -> Bool) -> HalmaBoard size+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)
+ src/Game/Halma/Board/Draw.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}++module Game.Halma.Board.Draw+  ( defaultTeamColours+  , drawBoard', drawBoard+  ) where++import Game.Halma.Board+import Math.Geometry.Grid+import Diagrams.Prelude++defaultTeamColours :: Team -> Colour Double+defaultTeamColours North = yellow+defaultTeamColours South = red+defaultTeamColours Northwest = cyan+defaultTeamColours Northeast = orange+defaultTeamColours Southwest = pink+defaultTeamColours Southeast = blue++-- | Render the board using the helper function for drawing the fields.+-- Supports querying for field positions.+drawBoard'+  :: Renderable (Path R2) b+  => HalmaGrid size+  -> ((Int,Int) -> Diagram b R2)+  -> QDiagram b R2 (Option (Last (Int, Int)))+drawBoard' grid drawField =+    targets `atop`+    (mconcat+      [ pieces # lw ultraThin+      , 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++-- | Render the board using the given team colors. Supports querying for field+-- positions.+drawBoard+  :: Renderable (Path R2) b+  => HalmaBoard size+  -> (Team -> Colour Double)+  -> QDiagram b R2 (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+
+ src/Game/Halma/Rules.hs view
@@ -0,0 +1,89 @@+module Game.Halma.Rules+  ( RuleOptions (..)+  , possibleMoves+  , hasFinished+  ) where++import Math.Geometry.Grid+import qualified Math.Geometry.Grid.HexagonalInternal as HI+import Game.Halma.Board+import Data.Default+import Data.Function (on)+import Data.Maybe (catMaybes)+import Control.Monad (guard)+import qualified Data.Set as S++data RuleOptions =+  RuleOptions { backwardsMovesAllowed :: Bool -- ^ May pieces be moved towards the start corner of the team?+              } deriving (Show, Eq)++instance Default RuleOptions where+  def = RuleOptions { backwardsMovesAllowed = False }++forwardMovesOnly+  :: RuleOptions+  -> (Int, Int)+  -> HalmaDirection+  -> [(Int, Int)]+  -> [(Int, Int)]+forwardMovesOnly ruleOptions startPos halmaDir =+  if backwardsMovesAllowed ruleOptions+  then id+  else filter (((>=) `on` rowsInDirection halmaDir) startPos)++possibleStepMoves+  :: RuleOptions+  -> HalmaBoard size+  -> (Int, Int)+  -> [(Int, Int)]+possibleStepMoves ruleOptions halmaBoard startPos =+  case lookupHalmaBoard startPos halmaBoard of+    Nothing -> []+    Just team ->+      forwardMovesOnly ruleOptions startPos team $+      filter ((== Nothing) . flip lookupHalmaBoard halmaBoard) $+      neighbours (getGrid halmaBoard) startPos++possibleJumpMoves+  :: RuleOptions+  -> HalmaBoard size+  -> (Int, Int)+  -> [(Int, Int)]+possibleJumpMoves ruleOptions halmaBoard startPos =+  case lookupHalmaBoard startPos halmaBoard of+    Nothing -> []+    Just team ->+      forwardMovesOnly ruleOptions startPos team $+      S.toList $ go S.empty (jumpTargets startPos)+  where hexDirections =+          [ HI.West, HI.Northwest, HI.Northeast+          , HI.East, HI.Southeast, HI.Southwest+          ]+        isEmpty = (== Nothing) . flip lookupHalmaBoard halmaBoard+        maybeJump p dir = do+          next1 <- neighbour (getGrid halmaBoard) p dir+          next2 <- neighbour (getGrid halmaBoard) next1 dir+          guard $ not (isEmpty next1) && isEmpty next2+          return next2+        jumpTargets p = catMaybes $ map (maybeJump p) hexDirections+        go set [] = set+        go set (p:ps) =+          if S.member p set+          then go set ps+          else go (S.insert p set) (jumpTargets p ++ ps)++-- | Computes all possible moves for a piece.+possibleMoves+  :: RuleOptions+  -> HalmaBoard size+  -> (Int, Int)+  -> [(Int, Int)]+possibleMoves ruleOptions halmaBoard startPos =+  possibleStepMoves ruleOptions halmaBoard startPos +++  possibleJumpMoves ruleOptions halmaBoard startPos++-- | Has a team all of it's pieces in the end zone?+hasFinished :: HalmaBoard size -> Team -> Bool+hasFinished halmaBoard team =+  all ((==) (Just team) . flip lookupHalmaBoard halmaBoard)+      (endFields (getGrid halmaBoard) team)
+ test/Main.hs view
@@ -0,0 +1,11 @@+module Main (main) where++import Test.Framework+import qualified Game.Halma.Board.Tests+import qualified Game.Halma.Rules.Tests++main :: IO ()+main = defaultMain+  [ Game.Halma.Board.Tests.tests+  , Game.Halma.Rules.Tests.tests+  ]