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
data RootInfo = RootInfo
{ rootInfoWidth :: Int
, rootInfoHeight :: Int
, rootInfoVariationMode :: VariationMode
} deriving (Eq, Show)
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 (Show)
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
}
internalIsGameInfoNode :: Node -> Bool
internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties
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]
data BoardState = BoardState
{ boardCoordStates :: [[CoordState]]
, boardHasInvisible :: Bool
, boardHasDimmed :: Bool
, boardHasCoordMarks :: Bool
, 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]
boardWidth :: BoardState -> Int
boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo
boardHeight :: BoardState -> Int
boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo
data CoordState = CoordState
{ coordStar :: Bool
, 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]
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]
rootBoardState :: Node -> BoardState
rootBoardState rootNode =
foldr applyProperty
(emptyBoardState width height)
(nodeProperties rootNode)
where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $
findProperty propertySZ rootNode
emptyCoordState :: CoordState
emptyCoordState = CoordState
{ coordStar = False
, coordStone = Nothing
, coordMark = Nothing
, coordVisible = True
, coordDimmed = False
}
boardCoordState :: Coord -> BoardState -> CoordState
boardCoordState (x, y) board = boardCoordStates board !! y !! x
boardCoordModify :: BoardState -> Coord -> (CoordState -> CoordState) -> BoardState
boardCoordModify board (x, y) f =
board { boardCoordStates =
listUpdate (listUpdate f x) y $ boardCoordStates board
}
mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]]
mapBoardCoords fn board =
zipWith applyRow [0..] $ boardCoordStates board
where applyRow y = zipWith (fn y) [0..]
updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState
updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo ->
gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo }
updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board }
boardChild :: BoardState -> Node -> BoardState
boardChild =
boardApplyChild . boardResetForChild
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 }
boardApplyChild :: BoardState -> Node -> BoardState
boardApplyChild = flip applyProperties
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 }
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 }
applyProperty :: Property -> BoardState -> BoardState
applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of
Nothing -> board
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
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)
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)
updateBoardForMove :: Color -> BoardState -> BoardState
updateBoardForMove movedPlayer board =
board { boardMoveNumber = boardMoveNumber board + 1
, boardPlayerTurn = cnot movedPlayer
}
data ApplyMoveParams = ApplyMoveParams
{ allowSuicide :: Bool
, allowOverwrite :: Bool
} deriving (Show)
standardGoMoveParams :: ApplyMoveParams
standardGoMoveParams = ApplyMoveParams
{ allowSuicide = False
, allowOverwrite = False
}
playTheDarnMoveGoParams :: ApplyMoveParams
playTheDarnMoveGoParams = ApplyMoveParams
{ allowSuicide = True
, allowOverwrite = True
}
data ApplyMoveResult =
ApplyMoveOk BoardState
| ApplyMoveCapture BoardState Color Int
| ApplyMoveSuicideError
| ApplyMoveOverwriteError Color
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
data ApplyMoveGroup = ApplyMoveGroup
{ applyMoveGroupOrigin :: Coord
, applyMoveGroupCoords :: [Coord]
, applyMoveGroupLiberties :: Int
} deriving (Show)
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
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))
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)]
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)
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
isValidMove :: BoardState -> Color -> Coord -> Bool
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)
isCurrentValidMove :: BoardState -> Coord -> Bool
isCurrentValidMove board = isValidMove board (boardPlayerTurn board)
data Cursor = Cursor
{ cursorParent' :: Maybe Cursor
, cursorChildIndex :: Int
, cursorNode' :: CursorNode
, cursorBoard :: BoardState
} deriving (Show)
data CursorNode =
UnmodifiedNode { getCursorNode :: Node }
| ModifiedNode { getCursorNode :: Node }
deriving (Show)
cursorParent :: Cursor -> Maybe Cursor
cursorParent cursor = case cursorParent' cursor of
Nothing -> Nothing
p@(Just parent) -> case cursorNode' cursor of
UnmodifiedNode _ -> p
ModifiedNode node ->
Just $ flip cursorModifyNode parent $ \pnode ->
pnode { nodeChildren = listUpdate (const node) (cursorChildIndex cursor) $
nodeChildren pnode }
cursorNode :: Cursor -> Node
cursorNode = getCursorNode . cursorNode'
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
}
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
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 isJust maybeParent then ModifiedNode else UnmodifiedNode) node
, cursorBoard = case maybeParent of
Nothing -> rootBoardState node
Just parent -> boardChild (cursorBoard parent) node
}
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