-- This file is part of Goatee. -- -- Copyright 2014-2021 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- Goatee is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with Goatee. If not, see . -- | Data structures that wrap and provide a higher-level interface to the SGF -- game tree, including a zipper that navigates the tree and provides the -- current board state. module Game.Goatee.Lib.Board ( RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode, gameInfoToProperties, BoardState(..), boardWidth, boardHeight, CoordState(..), emptyBoardState, rootBoardState, emptyCoordState, boardCoordState, boardCoordModify, mapBoardCoords, isValidMove, isCurrentValidMove, Cursor, cursorParent, cursorChildIndex, cursorNode, cursorBoard, rootCursor, cursorRoot, cursorChild, cursorChildren, cursorChildCount, cursorChildPlayingAt, cursorProperties, cursorModifyNode, cursorVariations, moveToProperty, ) where import Control.Monad (unless, when) import Control.Monad.Writer (execWriter, tell) import Data.List (find, intercalate, nub) import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Set as Set import Game.Goatee.Common import Game.Goatee.Lib.Property import Game.Goatee.Lib.Tree import Game.Goatee.Lib.Types -- TODO Stop using errors everywhere, they're not testable. -- | Properties that are specified in the root nodes of game trees. data RootInfo = RootInfo { rootInfoWidth :: Int , rootInfoHeight :: Int , rootInfoVariationMode :: VariationMode } deriving (Eq, Show) -- | Properties that are specified in game info nodes. data GameInfo = GameInfo { gameInfoRootInfo :: RootInfo , gameInfoBlackName :: Maybe SimpleText , gameInfoBlackTeamName :: Maybe SimpleText , gameInfoBlackRank :: Maybe SimpleText , gameInfoWhiteName :: Maybe SimpleText , gameInfoWhiteTeamName :: Maybe SimpleText , gameInfoWhiteRank :: Maybe SimpleText , gameInfoRuleset :: Maybe Ruleset , gameInfoBasicTimeSeconds :: Maybe RealValue , gameInfoOvertime :: Maybe SimpleText , gameInfoResult :: Maybe GameResult , gameInfoGameName :: Maybe SimpleText , gameInfoGameComment :: Maybe Text , gameInfoOpeningComment :: Maybe SimpleText , gameInfoEvent :: Maybe SimpleText , gameInfoRound :: Maybe SimpleText , gameInfoPlace :: Maybe SimpleText , gameInfoDatesPlayed :: Maybe SimpleText , gameInfoSource :: Maybe SimpleText , gameInfoCopyright :: Maybe SimpleText , gameInfoAnnotatorName :: Maybe SimpleText , gameInfoEntererName :: Maybe SimpleText } deriving (Eq, Show) -- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data. emptyGameInfo :: RootInfo -> GameInfo emptyGameInfo rootInfo = GameInfo { gameInfoRootInfo = rootInfo , gameInfoBlackName = Nothing , gameInfoBlackTeamName = Nothing , gameInfoBlackRank = Nothing , gameInfoWhiteName = Nothing , gameInfoWhiteTeamName = Nothing , gameInfoWhiteRank = Nothing , gameInfoRuleset = Nothing , gameInfoBasicTimeSeconds = Nothing , gameInfoOvertime = Nothing , gameInfoResult = Nothing , gameInfoGameName = Nothing , gameInfoGameComment = Nothing , gameInfoOpeningComment = Nothing , gameInfoEvent = Nothing , gameInfoRound = Nothing , gameInfoPlace = Nothing , gameInfoDatesPlayed = Nothing , gameInfoSource = Nothing , gameInfoCopyright = Nothing , gameInfoAnnotatorName = Nothing , gameInfoEntererName = Nothing } -- | Returns whether a node contains any game info properties. internalIsGameInfoNode :: Node -> Bool internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties -- | Converts a 'GameInfo' into a list of 'Property's that can be used to -- reconstruct the 'GameInfo'. gameInfoToProperties :: GameInfo -> [Property] gameInfoToProperties info = execWriter $ do copy PB gameInfoBlackName copy BT gameInfoBlackTeamName copy BR gameInfoBlackRank copy PW gameInfoWhiteName copy WT gameInfoWhiteTeamName copy WR gameInfoWhiteRank copy RU gameInfoRuleset copy TM gameInfoBasicTimeSeconds copy OT gameInfoOvertime copy RE gameInfoResult copy GN gameInfoGameName copy GC gameInfoGameComment copy ON gameInfoOpeningComment copy EV gameInfoEvent copy RO gameInfoRound copy PC gameInfoPlace copy DT gameInfoDatesPlayed copy SO gameInfoSource copy CP gameInfoCopyright copy AN gameInfoAnnotatorName copy US gameInfoEntererName where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x] -- | An object that corresponds to a node in some game tree, and represents the -- state of the game at that node, including board position, player turn and -- captures, and also board annotations. data BoardState = BoardState { boardCoordStates :: [[CoordState]] -- ^ The state of individual points on the board. Stored in row-major order. -- Point @(x, y)@ can be accessed via @!! y !! x@ (but prefer -- 'boardCoordState'). , boardHasInvisible :: Bool -- ^ Whether any of the board's 'CoordState's are invisible. This is an -- optimization to make it more efficient to set the board to "all visible." , boardHasDimmed :: Bool -- ^ Whether any of the board's 'CoordState's are dimmed. This is an -- optimization to make it more efficient to clear all dimming from the -- board. , boardHasCoordMarks :: Bool -- ^ Whether any of the board's 'CoordState's have a 'Mark' set on them. -- This is an optimization to make it more efficient to clear marks in the -- common case where there are no marks set. , boardArrows :: ArrowList , boardLines :: LineList , boardLabels :: LabelList , boardMoveNumber :: Integer , boardPlayerTurn :: Color , boardBlackCaptures :: Int , boardWhiteCaptures :: Int , boardGameInfo :: GameInfo } instance Show BoardState where show board = concat $ execWriter $ do tell ["Board: (Move ", show (boardMoveNumber board), ", ", show (boardPlayerTurn board), "'s turn, B:", show (boardBlackCaptures board), ", W:", show (boardWhiteCaptures board), ")\n"] tell [intercalate "\n" $ flip map (boardCoordStates board) $ \row -> unwords $ map show row] let arrows = boardArrows board let lines = boardLines board let labels = boardLabels board unless (null arrows) $ tell ["\nArrows: ", show arrows] unless (null lines) $ tell ["\nLines: ", show lines] unless (null labels) $ tell ["\nLabels: ", show labels] -- | Returns the width of the board, in stones. boardWidth :: BoardState -> Int boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo -- | Returns the height of the board, in stones. boardHeight :: BoardState -> Int boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo -- | Used by 'BoardState' to represent the state of a single point on the board. -- Records whether a stone is present, as well as annotations and visibility -- properties. data CoordState = CoordState { coordStar :: Bool -- ^ Whether this point is a star point. , coordStone :: Maybe Color , coordMark :: Maybe Mark , coordVisible :: Bool , coordDimmed :: Bool } deriving (Eq) instance Show CoordState where show c = if not $ coordVisible c then "--" else let stoneChar = case coordStone c of Nothing -> if coordStar c then '*' else '\'' Just Black -> 'X' Just White -> 'O' markChar = case coordMark c of Nothing -> ' ' Just MarkCircle -> 'o' Just MarkSquare -> 's' Just MarkTriangle -> 'v' Just MarkX -> 'x' Just MarkSelected -> '!' in [stoneChar, markChar] -- | Creates a 'BoardState' for an empty board of the given width and height. emptyBoardState :: Int -> Int -> BoardState emptyBoardState width height = BoardState { boardCoordStates = coords , boardHasInvisible = False , boardHasDimmed = False , boardHasCoordMarks = False , boardArrows = [] , boardLines = [] , boardLabels = [] , boardMoveNumber = 0 , boardPlayerTurn = Black , boardBlackCaptures = 0 , boardWhiteCaptures = 0 , boardGameInfo = emptyGameInfo rootInfo } where rootInfo = RootInfo { rootInfoWidth = width , rootInfoHeight = height , rootInfoVariationMode = defaultVariationMode } starCoordState = emptyCoordState { coordStar = True } isStarPoint' = isStarPoint width height coords = map (\y -> map (\x -> if isStarPoint' x y then starCoordState else emptyCoordState) [0..width-1]) [0..height-1] -- Initializes a 'BoardState' from the properties on a given root 'Node'. rootBoardState :: Node -> BoardState rootBoardState rootNode = foldr applyProperty (emptyBoardState width height) (nodeProperties rootNode) where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ findProperty propertySZ rootNode -- | A 'CoordState' for an empty point on the board. emptyCoordState :: CoordState emptyCoordState = CoordState { coordStar = False , coordStone = Nothing , coordMark = Nothing , coordVisible = True , coordDimmed = False } -- | Returns the 'CoordState' for a coordinate on a board. boardCoordState :: Coord -> BoardState -> CoordState boardCoordState (x, y) board = boardCoordStates board !! y !! x -- | Modifies a 'BoardState' by updating the 'CoordState' at a single point. boardCoordModify :: BoardState -> Coord -> (CoordState -> CoordState) -> BoardState boardCoordModify board (x, y) f = board { boardCoordStates = listUpdate (listUpdate f x) y $ boardCoordStates board } -- | Maps a function over each 'CoordState' in a 'BoardState', returning a -- list-of-lists with the function's values. The function is called like @fn y -- x coordState@. mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]] mapBoardCoords fn board = zipWith applyRow [0..] $ boardCoordStates board where applyRow y = zipWith (fn y) [0..] -- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a -- 'BoardState'. updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo -> gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo } -- | Applies a function to update the 'GameInfo' of a 'BoardState'. updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board } -- | Given a 'BoardState' for a parent node, and a child node, this function -- constructs the 'BoardState' for the child node. boardChild :: BoardState -> Node -> BoardState boardChild = -- This function first prepares the board (clearing temporary marks, etc.) -- then applies the child node's properties to the board. It is done in two -- stages because various points in this module apply the steps themselves. boardApplyChild . boardResetForChild -- | Performs necessary updates to a 'BoardState' between nodes in the tree. -- Clears marks. This is the first step of 'boardChild'. boardResetForChild :: BoardState -> BoardState boardResetForChild board = board { boardCoordStates = (if boardHasCoordMarks board then map (map clearMark) else id) $ boardCoordStates board , boardHasCoordMarks = False , boardArrows = [] , boardLines = [] , boardLabels = [] } where clearMark coord = case coordMark coord of Nothing -> coord Just _ -> coord { coordMark = Nothing } -- | Applies a child node's properties to a prepared 'BoardState'. This is the -- second step of 'boardChild'. boardApplyChild :: BoardState -> Node -> BoardState boardApplyChild = flip applyProperties -- | Sets all points on a board to be visible (if given true) or invisible (if -- given false). setBoardVisible :: Bool -> BoardState -> BoardState setBoardVisible visible board = if visible then if boardHasInvisible board then board { boardCoordStates = map (map $ setVisible True) $ boardCoordStates board , boardHasInvisible = False } else board else board { boardCoordStates = map (map $ setVisible False) $ boardCoordStates board , boardHasInvisible = True } where setVisible vis coord = coord { coordVisible = vis } -- | Resets all points on a board not to be dimmed. clearBoardDimmed :: BoardState -> BoardState clearBoardDimmed board = if boardHasDimmed board then board { boardCoordStates = map (map clearDim) $ boardCoordStates board , boardHasDimmed = False } else board where clearDim coord = coord { coordDimmed = False } -- | Applies a property to a 'BoardState'. This function covers all properties -- that modify 'BoardState's, including making moves, adding markup, and so on. applyProperty :: Property -> BoardState -> BoardState applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of Nothing -> board -- Pass. Just xy -> getApplyMoveResult board $ applyMove playTheDarnMoveGoParams Black xy board applyProperty KO board = board applyProperty (MN moveNum) board = board { boardMoveNumber = moveNum } applyProperty (W maybeXy) board = updateBoardForMove White $ case maybeXy of Nothing -> board -- Pass. Just xy -> getApplyMoveResult board $ applyMove playTheDarnMoveGoParams White xy board applyProperty (AB coords) board = updateCoordStates' (\state -> state { coordStone = Just Black }) coords board applyProperty (AW coords) board = updateCoordStates' (\state -> state { coordStone = Just White }) coords board applyProperty (AE coords) board = updateCoordStates' (\state -> state { coordStone = Nothing }) coords board applyProperty (PL color) board = board { boardPlayerTurn = color } applyProperty (C {}) board = board applyProperty (DM {}) board = board applyProperty (GB {}) board = board applyProperty (GW {}) board = board applyProperty (HO {}) board = board applyProperty (N {}) board = board applyProperty (UC {}) board = board applyProperty (V {}) board = board applyProperty (BM {}) board = board applyProperty (DO {}) board = board applyProperty (IT {}) board = board applyProperty (TE {}) board = board applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board } applyProperty (CR coords) board = updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board { boardHasCoordMarks = True } applyProperty (DD coords) board = let coords' = expandCoordList coords board' = clearBoardDimmed board in if null coords' then board' else updateCoordStates (\state -> state { coordDimmed = True }) coords' board' { boardHasDimmed = True } applyProperty (LB labels) board = board { boardLabels = labels ++ boardLabels board } applyProperty (LN lines) board = board { boardLines = lines ++ boardLines board } applyProperty (MA coords) board = updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords board { boardHasCoordMarks = True } applyProperty (SL coords) board = updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board { boardHasCoordMarks = True } applyProperty (SQ coords) board = updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board { boardHasCoordMarks = True } applyProperty (TR coords) board = updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board { boardHasCoordMarks = True } applyProperty (AP {}) board = board applyProperty (CA {}) board = board applyProperty (FF {}) board = board applyProperty (GM {}) board = board applyProperty (ST variationMode) board = updateRootInfo (\info -> info { rootInfoVariationMode = variationMode }) board applyProperty (SZ {}) board = board applyProperty (AN str) board = updateBoardInfo (\info -> info { gameInfoAnnotatorName = Just str }) board applyProperty (BR str) board = updateBoardInfo (\info -> info { gameInfoBlackRank = Just str }) board applyProperty (BT str) board = updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just str }) board applyProperty (CP str) board = updateBoardInfo (\info -> info { gameInfoCopyright = Just str }) board applyProperty (DT str) board = updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just str }) board applyProperty (EV str) board = updateBoardInfo (\info -> info { gameInfoEvent = Just str }) board applyProperty (GC str) board = updateBoardInfo (\info -> info { gameInfoGameComment = Just str }) board applyProperty (GN str) board = updateBoardInfo (\info -> info { gameInfoGameName = Just str }) board applyProperty (ON str) board = updateBoardInfo (\info -> info { gameInfoOpeningComment = Just str }) board applyProperty (OT str) board = updateBoardInfo (\info -> info { gameInfoOvertime = Just str }) board applyProperty (PB str) board = updateBoardInfo (\info -> info { gameInfoBlackName = Just str }) board applyProperty (PC str) board = updateBoardInfo (\info -> info { gameInfoPlace = Just str }) board applyProperty (PW str) board = updateBoardInfo (\info -> info { gameInfoWhiteName = Just str }) board applyProperty (RE result) board = updateBoardInfo (\info -> info { gameInfoResult = Just result }) board applyProperty (RO str) board = updateBoardInfo (\info -> info { gameInfoRound = Just str }) board applyProperty (RU ruleset) board = updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset }) board applyProperty (SO str) board = updateBoardInfo (\info -> info { gameInfoSource = Just str }) board applyProperty (TM seconds) board = updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds }) board applyProperty (US str) board = updateBoardInfo (\info -> info { gameInfoEntererName = Just str }) board applyProperty (WR str) board = updateBoardInfo (\info -> info { gameInfoWhiteRank = Just str }) board applyProperty (WT str) board = updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just str }) board applyProperty (BL {}) board = board applyProperty (OB {}) board = board applyProperty (OW {}) board = board applyProperty (WL {}) board = board applyProperty (VW coords) board = let coords' = expandCoordList coords in if null coords' then setBoardVisible True board else updateCoordStates (\state -> state { coordVisible = True }) coords' $ setBoardVisible False board applyProperty (HA {}) board = board applyProperty (KM {}) board = board applyProperty (TB {}) board = board applyProperty (TW {}) board = board applyProperty (UnknownProperty {}) board = board applyProperties :: Node -> BoardState -> BoardState applyProperties node board = foldr applyProperty board (nodeProperties node) -- | Applies the transformation function to all of a board's coordinates -- referred to by the 'CoordList'. updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState updateCoordStates fn coords board = board { boardCoordStates = foldr applyFn (boardCoordStates board) coords } where applyFn (x, y) = listUpdate (updateRow x) y updateRow = listUpdate fn updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState updateCoordStates' fn coords = updateCoordStates fn (expandCoordList coords) -- | Updates properties of a 'BoardState' given that the player of the given -- color has just made a move. Increments the move number and updates the -- player turn. updateBoardForMove :: Color -> BoardState -> BoardState updateBoardForMove movedPlayer board = board { boardMoveNumber = boardMoveNumber board + 1 , boardPlayerTurn = cnot movedPlayer } -- | A structure that configures how 'applyMove' should handle moves that are -- normally illegal in Go. data ApplyMoveParams = ApplyMoveParams { allowSuicide :: Bool -- ^ If false, suicide will cause 'applyMove' to return -- 'ApplyMoveSuicideError'. If true, suicide will kill the -- friendly group and give points to the opponent. , allowOverwrite :: Bool -- ^ If false, playing on an occupied point will cause -- 'applyMove' to return 'ApplyMoveOverwriteError' with the -- color of the stone occupying the point. If true, -- playing on an occupied point will overwrite the point -- (the previous stone vanishes), then capture rules are -- applied as normal. } deriving (Show) -- | As an argument to 'applyMove', causes illegal moves to be treated as -- errors. standardGoMoveParams :: ApplyMoveParams standardGoMoveParams = ApplyMoveParams { allowSuicide = False , allowOverwrite = False } -- | As an argument to 'applyMove', causes illegal moves to be played -- unconditionally. playTheDarnMoveGoParams :: ApplyMoveParams playTheDarnMoveGoParams = ApplyMoveParams { allowSuicide = True , allowOverwrite = True } -- | The possible results from 'applyMove'. data ApplyMoveResult = ApplyMoveOk BoardState -- ^ The move was accepted; playing it resulted in the given board without -- capture. | ApplyMoveCapture BoardState Color Int -- ^ The move was accepted; playing it resulted in the given board with a -- capture. The specified side gained the number of points given. | ApplyMoveSuicideError -- ^ Playing the move would result in suicide, which is forbidden. | ApplyMoveOverwriteError Color -- ^ There is already a stone of the specified color on the target point, -- and overwriting is forbidden. -- | If the 'ApplyMoveResult' represents a successful move, then the resulting -- 'BoardState' is returned, otherwise, the default 'BoardState' given is -- returned. getApplyMoveResult :: BoardState -> ApplyMoveResult -> BoardState getApplyMoveResult defaultBoard result = fromMaybe defaultBoard $ getApplyMoveResult' result getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState getApplyMoveResult' result = case result of ApplyMoveOk board -> Just board ApplyMoveCapture board color points -> Just $ case color of Black -> board { boardBlackCaptures = boardBlackCaptures board + points } White -> board { boardWhiteCaptures = boardWhiteCaptures board + points } ApplyMoveSuicideError -> Nothing ApplyMoveOverwriteError _ -> Nothing -- | Internal data structure, only for move application code. Represents a -- group of stones. data ApplyMoveGroup = ApplyMoveGroup { applyMoveGroupOrigin :: Coord , applyMoveGroupCoords :: [Coord] , applyMoveGroupLiberties :: Int } deriving (Show) -- | Places a stone of a color at a point on a board, and runs move validation -- and capturing logic according to the given parameters. Returns whether the -- move was successful, and the result if so. applyMove :: ApplyMoveParams -> Color -> Coord -> BoardState -> ApplyMoveResult applyMove params color xy board = let currentStone = coordStone $ boardCoordState xy board in case currentStone of Just color -> if allowOverwrite params then moveResult else ApplyMoveOverwriteError color Nothing -> moveResult where boardWithMove = updateCoordStates (\state -> state { coordStone = Just color }) [xy] board (boardWithCaptures, points) = foldr (maybeCapture $ cnot color) (boardWithMove, 0) (adjacentPoints boardWithMove xy) playedGroup = computeGroup boardWithCaptures xy moveResult | applyMoveGroupLiberties playedGroup == 0 = if points /= 0 then error "Cannot commit suicide and capture at the same time." else if allowSuicide params then let (boardWithSuicide, suicidePoints) = applyMoveCapture (boardWithCaptures, 0) playedGroup in ApplyMoveCapture boardWithSuicide (cnot color) suicidePoints else ApplyMoveSuicideError | points /= 0 = ApplyMoveCapture boardWithCaptures color points | otherwise = ApplyMoveOk boardWithCaptures -- | Capture if there is a liberty-less group of a color at a point on -- a board. Removes captured stones from the board and accumulates -- points for captured stones. maybeCapture :: Color -> Coord -> (BoardState, Int) -> (BoardState, Int) maybeCapture color xy result@(board, _) = if coordStone (boardCoordState xy board) /= Just color then result else let group = computeGroup board xy in if applyMoveGroupLiberties group /= 0 then result else applyMoveCapture result group computeGroup :: BoardState -> Coord -> ApplyMoveGroup computeGroup board xy = if isNothing (coordStone $ boardCoordState xy board) then error "computeGroup called on an empty point." else let groupCoords = bucketFill board xy in ApplyMoveGroup { applyMoveGroupOrigin = xy , applyMoveGroupCoords = groupCoords , applyMoveGroupLiberties = getLibertiesOfGroup board groupCoords } applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int) applyMoveCapture (board, points) group = (updateCoordStates (\state -> state { coordStone = Nothing }) (applyMoveGroupCoords group) board, points + length (applyMoveGroupCoords group)) -- | Returns a list of the four coordinates that are adjacent to the -- given coordinate on the board, excluding coordinates that are out -- of bounds. adjacentPoints :: BoardState -> Coord -> [Coord] adjacentPoints board (x, y) = execWriter $ do when (x > 0) $ tell [(x - 1, y)] when (y > 0) $ tell [(x, y - 1)] when (x < boardWidth board - 1) $ tell [(x + 1, y)] when (y < boardHeight board - 1) $ tell [(x, y + 1)] -- | Takes a list of coordinates that comprise a group (e.g. a list -- returned from 'bucketFill') and returns the number of liberties the -- group has. Does no error checking to ensure that the list refers -- to a single or maximal group. getLibertiesOfGroup :: BoardState -> [Coord] -> Int getLibertiesOfGroup board groupCoords = length $ nub $ concatMap findLiberties groupCoords where findLiberties xy = filter (\xy' -> isNothing $ coordStone $ boardCoordState xy' board) (adjacentPoints board xy) -- | Expands a single coordinate on a board into a list of all the -- coordinates connected to it by some continuous path of stones of -- the same color (or empty spaces). bucketFill :: BoardState -> Coord -> [Coord] bucketFill board xy0 = bucketFill' Set.empty [xy0] where bucketFill' known [] = Set.toList known bucketFill' known (xy:xys) = if Set.member xy known then bucketFill' known xys else let new = filter ((stone0 ==) . coordStone . flip boardCoordState board) (adjacentPoints board xy) in bucketFill' (Set.insert xy known) (new ++ xys) stone0 = coordStone $ boardCoordState xy0 board -- | Returns whether it is legal to place a stone of the given color at a point -- on a board. Accepts out-of-bound coordinates and returns false. isValidMove :: BoardState -> Color -> Coord -> Bool -- TODO Should out-of-bound coordinates be accepted? isValidMove board color coord@(x, y) = let w = boardWidth board h = boardHeight board in x >= 0 && y >= 0 && x < w && y < h && isJust (getApplyMoveResult' $ applyMove standardGoMoveParams color coord board) -- | Returns whether it is legal for the current player to place a stone at a -- point on a board. Accepts out-of-bound coordinates and returns false. isCurrentValidMove :: BoardState -> Coord -> Bool isCurrentValidMove board = isValidMove board (boardPlayerTurn board) -- | A pointer to a node in a game tree that also holds information -- about the current state of the game at that node. data Cursor = Cursor { cursorParent' :: Maybe Cursor -- ^ The cursor of the parent node in the tree. This is the cursor that was -- used to construct this cursor. For a root node, this is @Nothing@. -- -- If this cursor's node is modified (with 'cursorModifyNode'), then this -- parent cursor (if present) is /not/ updated to have the modified current -- node as a child; the public 'cursorParent' takes care of this. , cursorChildIndex :: Int -- ^ The index of this cursor's node in its parent's child list. When the -- cursor's node has no parent, the value in this field is not specified. , cursorNode' :: CursorNode -- ^ The game tree node about which the cursor stores information. The -- 'CursorNode' keeps track of whether the current node has been modified -- since last visiting the cursor's parent (if it exists; if it doesn't, -- then the current node is never considered modified, although in this case -- it doesn't matter). 'cursorNode' is the public export. , cursorBoard :: BoardState -- ^ The complete board state for the current node. } deriving (Show) -- TODO Better Show Cursor instance. -- | Keeps track of a cursor's node. Also records whether the node has been -- modified, and uses separate data constructors to force consideration of this. data CursorNode = UnmodifiedNode { getCursorNode :: Node } | ModifiedNode { getCursorNode :: Node } deriving (Show) -- | The cursor for the node above this cursor's node in the game tree. The -- node of the parent cursor is the parent of the cursor's node. -- -- This is @Nothing@ iff the cursor's node has no parent. cursorParent :: Cursor -> Maybe Cursor cursorParent cursor = case cursorParent' cursor of Nothing -> Nothing p@(Just parent) -> case cursorNode' cursor of -- If the current node hasn't been modified, then 'parent' is still the -- correct parent cursor for the current node. UnmodifiedNode _ -> p -- If the current node /has/ been modified, then we need to update the -- parent node's child list to include the modified node rather than the -- original. We do this one step at a time whenever we walk up the tree. ModifiedNode node -> Just $ flip cursorModifyNode parent $ \pnode -> pnode { nodeChildren = listUpdate (const node) (cursorChildIndex cursor) $ nodeChildren pnode } -- | The game tree node about which the cursor stores information. cursorNode :: Cursor -> Node cursorNode = getCursorNode . cursorNode' -- | Returns a cursor for a root node. rootCursor :: Node -> Cursor rootCursor node = Cursor { cursorParent' = Nothing , cursorChildIndex = -1 , cursorNode' = UnmodifiedNode node , cursorBoard = rootBoardState node } cursorRoot :: Cursor -> Cursor cursorRoot cursor = case cursorParent cursor of Nothing -> cursor Just parent -> cursorRoot parent cursorChild :: Cursor -> Int -> Cursor cursorChild cursor index = Cursor { cursorParent' = Just cursor , cursorChildIndex = index , cursorNode' = UnmodifiedNode child , cursorBoard = boardChild (cursorBoard cursor) child } -- TODO Better handling or messaging for out-of-bounds: where child = (!! index) $ nodeChildren $ cursorNode cursor cursorChildren :: Cursor -> [Cursor] cursorChildren cursor = let board = boardResetForChild $ cursorBoard cursor in map (\(index, child) -> Cursor { cursorParent' = Just cursor , cursorChildIndex = index , cursorNode' = UnmodifiedNode child , cursorBoard = boardApplyChild board child }) $ zip [0..] $ nodeChildren $ cursorNode cursor cursorChildCount :: Cursor -> Int cursorChildCount = length . nodeChildren . cursorNode cursorChildPlayingAt :: Maybe Coord -> Cursor -> Maybe Cursor cursorChildPlayingAt move cursor = let children = cursorChildren cursor color = boardPlayerTurn $ cursorBoard cursor hasMove = elem $ moveToProperty color move in find (hasMove . nodeProperties . cursorNode) children -- | This is simply @'nodeProperties' . 'cursorNode'@. cursorProperties :: Cursor -> [Property] cursorProperties = nodeProperties . cursorNode cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor cursorModifyNode fn cursor = let node = fn $ cursorNode cursor maybeParent = cursorParent' cursor in cursor { cursorNode' = -- If we're at a root node, then there is no need to mark the node -- as modified, since we'll never move up. (if isJust maybeParent then ModifiedNode else UnmodifiedNode) node , cursorBoard = case maybeParent of Nothing -> rootBoardState node Just parent -> boardChild (cursorBoard parent) node } -- | Returns the variations to display for a cursor. The returned list contains -- the location and color of 'B' and 'W' properties in variation nodes. -- Variation nodes are either children of the current node, or siblings of the -- current node, depending on the variation mode source. cursorVariations :: VariationModeSource -> Cursor -> [(Coord, Color)] cursorVariations source cursor = case source of ShowChildVariations -> collectPlays $ nodeChildren $ cursorNode cursor ShowCurrentVariations -> case cursorParent cursor of Nothing -> [] Just parent -> collectPlays $ listDeleteAt (cursorChildIndex cursor) $ nodeChildren $ cursorNode parent where collectPlays :: [Node] -> [(Coord, Color)] collectPlays = concatMap collectPlays' collectPlays' = concatMap collectPlays'' . nodeProperties collectPlays'' prop = case prop of B (Just xy) -> [(xy, Black)] W (Just xy) -> [(xy, White)] _ -> [] moveToProperty :: Color -> Maybe Coord -> Property moveToProperty color = case color of Black -> B White -> W