diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/halma.cabal b/halma.cabal new file mode 100644 --- /dev/null +++ b/halma.cabal @@ -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 + diff --git a/halma.hs b/halma.hs new file mode 100644 --- /dev/null +++ b/halma.hs @@ -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 diff --git a/src/Game/Halma/Board.hs b/src/Game/Halma/Board.hs new file mode 100644 --- /dev/null +++ b/src/Game/Halma/Board.hs @@ -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) diff --git a/src/Game/Halma/Board/Draw.hs b/src/Game/Halma/Board/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Game/Halma/Board/Draw.hs @@ -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 + diff --git a/src/Game/Halma/Rules.hs b/src/Game/Halma/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Game/Halma/Rules.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ]