module Game.Goatee.Sgf.Board (
RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode,
gameInfoToProperties,
BoardState(..), boardWidth, boardHeight,
CoordState(..), rootBoardState, boardCoordState, mapBoardCoords,
isValidMove, isCurrentValidMove,
Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren,
cursorChildCount, cursorChildPlayingAt, cursorProperties,
cursorModifyNode,
cursorVariations,
colorToMove,
) 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.Sgf.Property
import Game.Goatee.Sgf.Tree
import Game.Goatee.Sgf.Types
data RootInfo = RootInfo { rootInfoWidth :: Int
, rootInfoHeight :: Int
, rootInfoVariationMode :: VariationMode
} deriving (Eq, Show)
data GameInfo = GameInfo { gameInfoRootInfo :: RootInfo
, gameInfoBlackName :: Maybe String
, gameInfoBlackTeamName :: Maybe String
, gameInfoBlackRank :: Maybe String
, gameInfoWhiteName :: Maybe String
, gameInfoWhiteTeamName :: Maybe String
, gameInfoWhiteRank :: Maybe String
, gameInfoRuleset :: Maybe Ruleset
, gameInfoBasicTimeSeconds :: Maybe Rational
, gameInfoOvertime :: Maybe String
, gameInfoResult :: Maybe GameResult
, gameInfoGameName :: Maybe String
, gameInfoGameComment :: Maybe String
, gameInfoOpeningComment :: Maybe String
, gameInfoEvent :: Maybe String
, gameInfoRound :: Maybe String
, gameInfoPlace :: Maybe String
, gameInfoDatesPlayed :: Maybe String
, gameInfoSource :: Maybe String
, gameInfoCopyright :: Maybe String
, gameInfoAnnotatorName :: Maybe String
, gameInfoEntererName :: Maybe String
} 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 . toSimpleText) gameInfoBlackName
copy (BT . toSimpleText) gameInfoBlackTeamName
copy (BR . toSimpleText) gameInfoBlackRank
copy (PW . toSimpleText) gameInfoWhiteName
copy (WT . toSimpleText) gameInfoWhiteTeamName
copy (WR . toSimpleText) gameInfoWhiteRank
copy RU gameInfoRuleset
copy TM gameInfoBasicTimeSeconds
copy (OT . toSimpleText) gameInfoOvertime
copy RE gameInfoResult
copy (GN . toSimpleText) gameInfoGameName
copy (GC . toSimpleText) gameInfoGameComment
copy (ON . toSimpleText) gameInfoOpeningComment
copy (EV . toSimpleText) gameInfoEvent
copy (RO . toSimpleText) gameInfoRound
copy (PC . toSimpleText) gameInfoPlace
copy (DT . toSimpleText) gameInfoDatesPlayed
copy (SO . toSimpleText) gameInfoSource
copy (CP . toSimpleText) gameInfoCopyright
copy (AN . toSimpleText) gameInfoAnnotatorName
copy (US . toSimpleText) gameInfoEntererName
where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x]
data BoardState = BoardState {
boardCoordStates :: [[CoordState]]
, boardHasInvisible :: Bool
, boardHasDimmed :: 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
}
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
, boardArrows = []
, boardLines = []
, boardLabels = []
, boardMoveNumber = 0
, boardPlayerTurn = Black
, boardBlackCaptures = 0
, boardWhiteCaptures = 0
, boardGameInfo = emptyGameInfo rootInfo
}
where rootInfo = RootInfo { rootInfoWidth = width
, rootInfoHeight = height
, rootInfoVariationMode = defaultVariationMode
}
emptyCoord = CoordState { coordStar = False
, coordStone = Nothing
, coordMark = Nothing
, coordVisible = True
, coordDimmed = False
}
starCoord = emptyCoord { coordStar = True }
isStarPoint' = isStarPoint width height
coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord)
[0..width1])
[0..height1]
rootBoardState :: Node -> BoardState
rootBoardState rootNode =
foldr applyProperty
(emptyBoardState width height)
(nodeProperties rootNode)
where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $
findProperty propertySZ rootNode
boardCoordState :: Coord -> BoardState -> CoordState
boardCoordState (x, y) board = boardCoordStates board !! y !! x
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 -> BoardState
boardChild board =
board { boardCoordStates = map (map clearMark) $ boardCoordStates board
, boardArrows = []
, boardLines = []
, boardLabels = []
}
where clearMark coord = case coordMark coord of
Nothing -> coord
Just _ -> coord { coordMark = Nothing }
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 }
isStarPoint :: Int -> Int -> Int -> Int -> Bool
isStarPoint width height
| width == 9 && height == 9 = isStarPoint9
| width == 13 && height == 13 = isStarPoint13
| width == 19 && height == 19 = isStarPoint19
| otherwise = const $ const False
isStarPoint' :: [Int] -> Int -> Int -> Bool
isStarPoint' ixs x y = x `elem` ixs && y `elem` ixs
isStarPoint9, isStarPoint13, isStarPoint19 :: Int -> Int -> Bool
isStarPoint9 = isStarPoint' [2, 4, 6]
isStarPoint13 = isStarPoint' [3, 6, 9]
isStarPoint19 = isStarPoint' [3, 9, 15]
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
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
applyProperty (SL coords) board =
updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board
applyProperty (SQ coords) board =
updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board
applyProperty (TR coords) board =
updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board
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 $ fromSimpleText str })
board
applyProperty (BR str) board =
updateBoardInfo (\info -> info { gameInfoBlackRank = Just $ fromSimpleText str })
board
applyProperty (BT str) board =
updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just $ fromSimpleText str })
board
applyProperty (CP str) board =
updateBoardInfo (\info -> info { gameInfoCopyright = Just $ fromSimpleText str })
board
applyProperty (DT str) board =
updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just $ fromSimpleText str })
board
applyProperty (EV str) board =
updateBoardInfo (\info -> info { gameInfoEvent = Just $ fromSimpleText str })
board
applyProperty (GC str) board =
updateBoardInfo (\info -> info { gameInfoGameComment = Just $ fromSimpleText str })
board
applyProperty (GN str) board =
updateBoardInfo (\info -> info { gameInfoGameName = Just $ fromSimpleText str })
board
applyProperty (ON str) board =
updateBoardInfo (\info -> info { gameInfoOpeningComment = Just $ fromSimpleText str })
board
applyProperty (OT str) board =
updateBoardInfo (\info -> info { gameInfoOvertime = Just $ fromSimpleText str })
board
applyProperty (PB str) board =
updateBoardInfo (\info -> info { gameInfoBlackName = Just $ fromSimpleText str })
board
applyProperty (PC str) board =
updateBoardInfo (\info -> info { gameInfoPlace = Just $ fromSimpleText str })
board
applyProperty (PW str) board =
updateBoardInfo (\info -> info { gameInfoWhiteName = Just $ fromSimpleText str })
board
applyProperty (RE result) board =
updateBoardInfo (\info -> info { gameInfoResult = Just result })
board
applyProperty (RO str) board =
updateBoardInfo (\info -> info { gameInfoRound = Just $ fromSimpleText str })
board
applyProperty (RU ruleset) board =
updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset })
board
applyProperty (SO str) board =
updateBoardInfo (\info -> info { gameInfoSource = Just $ fromSimpleText str })
board
applyProperty (TM seconds) board =
updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds })
board
applyProperty (US str) board =
updateBoardInfo (\info -> info { gameInfoEntererName = Just $ fromSimpleText str })
board
applyProperty (WR str) board =
updateBoardInfo (\info -> info { gameInfoWhiteRank = Just $ fromSimpleText str })
board
applyProperty (WT str) board =
updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just $ fromSimpleText str })
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 (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 :: Node
, cursorBoard :: BoardState
} deriving (Show)
rootCursor :: Node -> Cursor
rootCursor node =
Cursor { cursorParent = Nothing
, cursorChildIndex = 1
, cursorNode = 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 = child
, cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor
}
where child = (!! index) $ nodeChildren $ cursorNode cursor
cursorChildren :: Cursor -> [Cursor]
cursorChildren cursor =
let board = boardChild $ cursorBoard cursor
in map (\(index, child) -> Cursor { cursorParent = Just cursor
, cursorChildIndex = index
, cursorNode = child
, cursorBoard = applyProperties child board
})
$ zip [0..]
$ nodeChildren
$ cursorNode cursor
cursorChildCount :: Cursor -> Int
cursorChildCount = length . nodeChildren . cursorNode
cursorChildPlayingAt :: Coord -> Cursor -> Maybe Cursor
cursorChildPlayingAt coord cursor =
let children = cursorChildren cursor
color = boardPlayerTurn $ cursorBoard cursor
hasMove = elem $ colorToMove color coord
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
in case cursorParent cursor of
Nothing -> rootCursor node'
Just parentCursor ->
let index = cursorChildIndex cursor
parentCursor' = cursorModifyNode
(\parentNode ->
parentNode { nodeChildren = listUpdate (const node')
index
(nodeChildren parentNode)
})
parentCursor
in cursorChild parentCursor' index
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 $ listDeleteIndex (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)]
_ -> []
colorToMove :: Color -> Coord -> Property
colorToMove color coord =
case color of
Black -> B $ Just coord
White -> W $ Just coord