-- 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 <http://www.gnu.org/licenses/>.

-- | 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
  { RootInfo -> Int
rootInfoWidth :: Int
  , RootInfo -> Int
rootInfoHeight :: Int
  , RootInfo -> VariationMode
rootInfoVariationMode :: VariationMode
  } deriving (RootInfo -> RootInfo -> Bool
(RootInfo -> RootInfo -> Bool)
-> (RootInfo -> RootInfo -> Bool) -> Eq RootInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RootInfo -> RootInfo -> Bool
$c/= :: RootInfo -> RootInfo -> Bool
== :: RootInfo -> RootInfo -> Bool
$c== :: RootInfo -> RootInfo -> Bool
Eq, Int -> RootInfo -> ShowS
[RootInfo] -> ShowS
RootInfo -> String
(Int -> RootInfo -> ShowS)
-> (RootInfo -> String) -> ([RootInfo] -> ShowS) -> Show RootInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RootInfo] -> ShowS
$cshowList :: [RootInfo] -> ShowS
show :: RootInfo -> String
$cshow :: RootInfo -> String
showsPrec :: Int -> RootInfo -> ShowS
$cshowsPrec :: Int -> RootInfo -> ShowS
Show)

-- | Properties that are specified in game info nodes.
data GameInfo = GameInfo
  { GameInfo -> RootInfo
gameInfoRootInfo :: RootInfo

  , GameInfo -> Maybe SimpleText
gameInfoBlackName :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoBlackTeamName :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoBlackRank :: Maybe SimpleText

  , GameInfo -> Maybe SimpleText
gameInfoWhiteName :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoWhiteTeamName :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoWhiteRank :: Maybe SimpleText

  , GameInfo -> Maybe Ruleset
gameInfoRuleset :: Maybe Ruleset
  , GameInfo -> Maybe RealValue
gameInfoBasicTimeSeconds :: Maybe RealValue
  , GameInfo -> Maybe SimpleText
gameInfoOvertime :: Maybe SimpleText
  , GameInfo -> Maybe GameResult
gameInfoResult :: Maybe GameResult

  , GameInfo -> Maybe SimpleText
gameInfoGameName :: Maybe SimpleText
  , GameInfo -> Maybe Text
gameInfoGameComment :: Maybe Text
  , GameInfo -> Maybe SimpleText
gameInfoOpeningComment :: Maybe SimpleText

  , GameInfo -> Maybe SimpleText
gameInfoEvent :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoRound :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoPlace :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoDatesPlayed :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoSource :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoCopyright :: Maybe SimpleText

  , GameInfo -> Maybe SimpleText
gameInfoAnnotatorName :: Maybe SimpleText
  , GameInfo -> Maybe SimpleText
gameInfoEntererName :: Maybe SimpleText
  } deriving (GameInfo -> GameInfo -> Bool
(GameInfo -> GameInfo -> Bool)
-> (GameInfo -> GameInfo -> Bool) -> Eq GameInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GameInfo -> GameInfo -> Bool
$c/= :: GameInfo -> GameInfo -> Bool
== :: GameInfo -> GameInfo -> Bool
$c== :: GameInfo -> GameInfo -> Bool
Eq, Int -> GameInfo -> ShowS
[GameInfo] -> ShowS
GameInfo -> String
(Int -> GameInfo -> ShowS)
-> (GameInfo -> String) -> ([GameInfo] -> ShowS) -> Show GameInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GameInfo] -> ShowS
$cshowList :: [GameInfo] -> ShowS
show :: GameInfo -> String
$cshow :: GameInfo -> String
showsPrec :: Int -> GameInfo -> ShowS
$cshowsPrec :: Int -> GameInfo -> ShowS
Show)

-- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data.
emptyGameInfo :: RootInfo -> GameInfo
emptyGameInfo :: RootInfo -> GameInfo
emptyGameInfo RootInfo
rootInfo = GameInfo :: RootInfo
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe Ruleset
-> Maybe RealValue
-> Maybe SimpleText
-> Maybe GameResult
-> Maybe SimpleText
-> Maybe Text
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> Maybe SimpleText
-> GameInfo
GameInfo
  { gameInfoRootInfo :: RootInfo
gameInfoRootInfo = RootInfo
rootInfo

  , gameInfoBlackName :: Maybe SimpleText
gameInfoBlackName = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoBlackTeamName :: Maybe SimpleText
gameInfoBlackTeamName = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoBlackRank :: Maybe SimpleText
gameInfoBlackRank = Maybe SimpleText
forall a. Maybe a
Nothing

  , gameInfoWhiteName :: Maybe SimpleText
gameInfoWhiteName = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoWhiteTeamName :: Maybe SimpleText
gameInfoWhiteTeamName = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoWhiteRank :: Maybe SimpleText
gameInfoWhiteRank = Maybe SimpleText
forall a. Maybe a
Nothing

  , gameInfoRuleset :: Maybe Ruleset
gameInfoRuleset = Maybe Ruleset
forall a. Maybe a
Nothing
  , gameInfoBasicTimeSeconds :: Maybe RealValue
gameInfoBasicTimeSeconds = Maybe RealValue
forall a. Maybe a
Nothing
  , gameInfoOvertime :: Maybe SimpleText
gameInfoOvertime = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoResult :: Maybe GameResult
gameInfoResult = Maybe GameResult
forall a. Maybe a
Nothing

  , gameInfoGameName :: Maybe SimpleText
gameInfoGameName = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoGameComment :: Maybe Text
gameInfoGameComment = Maybe Text
forall a. Maybe a
Nothing
  , gameInfoOpeningComment :: Maybe SimpleText
gameInfoOpeningComment = Maybe SimpleText
forall a. Maybe a
Nothing

  , gameInfoEvent :: Maybe SimpleText
gameInfoEvent = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoRound :: Maybe SimpleText
gameInfoRound = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoPlace :: Maybe SimpleText
gameInfoPlace = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoDatesPlayed :: Maybe SimpleText
gameInfoDatesPlayed = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoSource :: Maybe SimpleText
gameInfoSource = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoCopyright :: Maybe SimpleText
gameInfoCopyright = Maybe SimpleText
forall a. Maybe a
Nothing

  , gameInfoAnnotatorName :: Maybe SimpleText
gameInfoAnnotatorName = Maybe SimpleText
forall a. Maybe a
Nothing
  , gameInfoEntererName :: Maybe SimpleText
gameInfoEntererName = Maybe SimpleText
forall a. Maybe a
Nothing
  }

-- | Returns whether a node contains any game info properties.
internalIsGameInfoNode :: Node -> Bool
internalIsGameInfoNode :: Node -> Bool
internalIsGameInfoNode = (Property -> Bool) -> [Property] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((PropertyType
GameInfoProperty PropertyType -> PropertyType -> Bool
forall a. Eq a => a -> a -> Bool
==) (PropertyType -> Bool)
-> (Property -> PropertyType) -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType) ([Property] -> Bool) -> (Node -> [Property]) -> Node -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Property]
nodeProperties

-- | Converts a 'GameInfo' into a list of 'Property's that can be used to
-- reconstruct the 'GameInfo'.
gameInfoToProperties :: GameInfo -> [Property]
gameInfoToProperties :: GameInfo -> [Property]
gameInfoToProperties GameInfo
info = Writer [Property] () -> [Property]
forall w a. Writer w a -> w
execWriter (Writer [Property] () -> [Property])
-> Writer [Property] () -> [Property]
forall a b. (a -> b) -> a -> b
$ do
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
PB GameInfo -> Maybe SimpleText
gameInfoBlackName
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
BT GameInfo -> Maybe SimpleText
gameInfoBlackTeamName
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
BR GameInfo -> Maybe SimpleText
gameInfoBlackRank

  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
PW GameInfo -> Maybe SimpleText
gameInfoWhiteName
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
WT GameInfo -> Maybe SimpleText
gameInfoWhiteTeamName
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
WR GameInfo -> Maybe SimpleText
gameInfoWhiteRank

  (Ruleset -> Property)
-> (GameInfo -> Maybe Ruleset) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy Ruleset -> Property
RU GameInfo -> Maybe Ruleset
gameInfoRuleset
  (RealValue -> Property)
-> (GameInfo -> Maybe RealValue) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy RealValue -> Property
TM GameInfo -> Maybe RealValue
gameInfoBasicTimeSeconds
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
OT GameInfo -> Maybe SimpleText
gameInfoOvertime
  (GameResult -> Property)
-> (GameInfo -> Maybe GameResult) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy GameResult -> Property
RE GameInfo -> Maybe GameResult
gameInfoResult

  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
GN GameInfo -> Maybe SimpleText
gameInfoGameName
  (Text -> Property)
-> (GameInfo -> Maybe Text) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy Text -> Property
GC GameInfo -> Maybe Text
gameInfoGameComment
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
ON GameInfo -> Maybe SimpleText
gameInfoOpeningComment

  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
EV GameInfo -> Maybe SimpleText
gameInfoEvent
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
RO GameInfo -> Maybe SimpleText
gameInfoRound
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
PC GameInfo -> Maybe SimpleText
gameInfoPlace
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
DT GameInfo -> Maybe SimpleText
gameInfoDatesPlayed
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
SO GameInfo -> Maybe SimpleText
gameInfoSource
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
CP GameInfo -> Maybe SimpleText
gameInfoCopyright

  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
AN GameInfo -> Maybe SimpleText
gameInfoAnnotatorName
  (SimpleText -> Property)
-> (GameInfo -> Maybe SimpleText) -> Writer [Property] ()
forall (m :: * -> *) a t.
MonadWriter [a] m =>
(t -> a) -> (GameInfo -> Maybe t) -> m ()
copy SimpleText -> Property
US GameInfo -> Maybe SimpleText
gameInfoEntererName
  where copy :: (t -> a) -> (GameInfo -> Maybe t) -> m ()
copy t -> a
ctor GameInfo -> Maybe t
accessor = Maybe t -> (t -> m ()) -> m ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenMaybe (GameInfo -> Maybe t
accessor GameInfo
info) ((t -> m ()) -> m ()) -> (t -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \t
x -> [a] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [t -> a
ctor t
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
  { BoardState -> [[CoordState]]
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').
  , BoardState -> Bool
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."
  , BoardState -> Bool
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.
  , BoardState -> Bool
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.
  , BoardState -> ArrowList
boardArrows :: ArrowList
  , BoardState -> LineList
boardLines :: LineList
  , BoardState -> LabelList
boardLabels :: LabelList
  , BoardState -> Integer
boardMoveNumber :: Integer
  , BoardState -> Color
boardPlayerTurn :: Color
  , BoardState -> Int
boardBlackCaptures :: Int
  , BoardState -> Int
boardWhiteCaptures :: Int
  , BoardState -> GameInfo
boardGameInfo :: GameInfo
  }

instance Show BoardState where
  show :: BoardState -> String
show BoardState
board = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Writer [String] () -> [String]
forall w a. Writer w a -> w
execWriter (Writer [String] () -> [String]) -> Writer [String] () -> [String]
forall a b. (a -> b) -> a -> b
$ do
    [String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"Board: (Move ", Integer -> String
forall a. Show a => a -> String
show (BoardState -> Integer
boardMoveNumber BoardState
board),
          String
", ", Color -> String
forall a. Show a => a -> String
show (BoardState -> Color
boardPlayerTurn BoardState
board), String
"'s turn, B:",
          Int -> String
forall a. Show a => a -> String
show (BoardState -> Int
boardBlackCaptures BoardState
board), String
", W:",
          Int -> String
forall a. Show a => a -> String
show (BoardState -> Int
boardWhiteCaptures BoardState
board), String
")\n"]
    [String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (([CoordState] -> String) -> [[CoordState]] -> [String])
-> [[CoordState]] -> ([CoordState] -> String) -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([CoordState] -> String) -> [[CoordState]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (BoardState -> [[CoordState]]
boardCoordStates BoardState
board) (([CoordState] -> String) -> [String])
-> ([CoordState] -> String) -> [String]
forall a b. (a -> b) -> a -> b
$
          \[CoordState]
row -> [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (CoordState -> String) -> [CoordState] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CoordState -> String
forall a. Show a => a -> String
show [CoordState]
row]

    let arrows :: ArrowList
arrows = BoardState -> ArrowList
boardArrows BoardState
board
    let lines :: LineList
lines = BoardState -> LineList
boardLines BoardState
board
    let labels :: LabelList
labels = BoardState -> LabelList
boardLabels BoardState
board
    Bool -> Writer [String] () -> Writer [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ArrowList -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ArrowList
arrows) (Writer [String] () -> Writer [String] ())
-> Writer [String] () -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$ [String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"\nArrows: ", ArrowList -> String
forall a. Show a => a -> String
show ArrowList
arrows]
    Bool -> Writer [String] () -> Writer [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LineList -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LineList
lines) (Writer [String] () -> Writer [String] ())
-> Writer [String] () -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$ [String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"\nLines: ", LineList -> String
forall a. Show a => a -> String
show LineList
lines]
    Bool -> Writer [String] () -> Writer [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LabelList -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LabelList
labels) (Writer [String] () -> Writer [String] ())
-> Writer [String] () -> Writer [String] ()
forall a b. (a -> b) -> a -> b
$ [String] -> Writer [String] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
"\nLabels: ", LabelList -> String
forall a. Show a => a -> String
show LabelList
labels]

-- | Returns the width of the board, in stones.
boardWidth :: BoardState -> Int
boardWidth :: BoardState -> Int
boardWidth = RootInfo -> Int
rootInfoWidth (RootInfo -> Int) -> (BoardState -> RootInfo) -> BoardState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameInfo -> RootInfo
gameInfoRootInfo (GameInfo -> RootInfo)
-> (BoardState -> GameInfo) -> BoardState -> RootInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoardState -> GameInfo
boardGameInfo

-- | Returns the height of the board, in stones.
boardHeight :: BoardState -> Int
boardHeight :: BoardState -> Int
boardHeight = RootInfo -> Int
rootInfoHeight (RootInfo -> Int) -> (BoardState -> RootInfo) -> BoardState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GameInfo -> RootInfo
gameInfoRootInfo (GameInfo -> RootInfo)
-> (BoardState -> GameInfo) -> BoardState -> RootInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoardState -> GameInfo
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
  { CoordState -> Bool
coordStar :: Bool
    -- ^ Whether this point is a star point.
  , CoordState -> Maybe Color
coordStone :: Maybe Color
  , CoordState -> Maybe Mark
coordMark :: Maybe Mark
  , CoordState -> Bool
coordVisible :: Bool
  , CoordState -> Bool
coordDimmed :: Bool
  } deriving (CoordState -> CoordState -> Bool
(CoordState -> CoordState -> Bool)
-> (CoordState -> CoordState -> Bool) -> Eq CoordState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CoordState -> CoordState -> Bool
$c/= :: CoordState -> CoordState -> Bool
== :: CoordState -> CoordState -> Bool
$c== :: CoordState -> CoordState -> Bool
Eq)

instance Show CoordState where
  show :: CoordState -> String
show CoordState
c = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CoordState -> Bool
coordVisible CoordState
c
           then String
"--"
           else let stoneChar :: Char
stoneChar = case CoordState -> Maybe Color
coordStone CoordState
c of
                      Maybe Color
Nothing -> if CoordState -> Bool
coordStar CoordState
c then Char
'*' else Char
'\''
                      Just Color
Black -> Char
'X'
                      Just Color
White -> Char
'O'
                    markChar :: Char
markChar = case CoordState -> Maybe Mark
coordMark CoordState
c of
                      Maybe Mark
Nothing -> Char
' '
                      Just Mark
MarkCircle -> Char
'o'
                      Just Mark
MarkSquare -> Char
's'
                      Just Mark
MarkTriangle -> Char
'v'
                      Just Mark
MarkX -> Char
'x'
                      Just Mark
MarkSelected -> Char
'!'
                in [Char
stoneChar, Char
markChar]

-- | Creates a 'BoardState' for an empty board of the given width and height.
emptyBoardState :: Int -> Int -> BoardState
emptyBoardState :: Int -> Int -> BoardState
emptyBoardState Int
width Int
height = BoardState :: [[CoordState]]
-> Bool
-> Bool
-> Bool
-> ArrowList
-> LineList
-> LabelList
-> Integer
-> Color
-> Int
-> Int
-> GameInfo
-> BoardState
BoardState
  { boardCoordStates :: [[CoordState]]
boardCoordStates = [[CoordState]]
coords
  , boardHasInvisible :: Bool
boardHasInvisible = Bool
False
  , boardHasDimmed :: Bool
boardHasDimmed = Bool
False
  , boardHasCoordMarks :: Bool
boardHasCoordMarks = Bool
False
  , boardArrows :: ArrowList
boardArrows = []
  , boardLines :: LineList
boardLines = []
  , boardLabels :: LabelList
boardLabels = []
  , boardMoveNumber :: Integer
boardMoveNumber = Integer
0
  , boardPlayerTurn :: Color
boardPlayerTurn = Color
Black
  , boardBlackCaptures :: Int
boardBlackCaptures = Int
0
  , boardWhiteCaptures :: Int
boardWhiteCaptures = Int
0
  , boardGameInfo :: GameInfo
boardGameInfo = RootInfo -> GameInfo
emptyGameInfo RootInfo
rootInfo
  }
  where rootInfo :: RootInfo
rootInfo = RootInfo :: Int -> Int -> VariationMode -> RootInfo
RootInfo { rootInfoWidth :: Int
rootInfoWidth = Int
width
                            , rootInfoHeight :: Int
rootInfoHeight = Int
height
                            , rootInfoVariationMode :: VariationMode
rootInfoVariationMode = VariationMode
defaultVariationMode
                            }
        starCoordState :: CoordState
starCoordState = CoordState
emptyCoordState { coordStar :: Bool
coordStar = Bool
True }
        isStarPoint' :: Int -> Int -> Bool
isStarPoint' = Int -> Int -> Int -> Int -> Bool
isStarPoint Int
width Int
height
        coords :: [[CoordState]]
coords = (Int -> [CoordState]) -> [Int] -> [[CoordState]]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
y -> (Int -> CoordState) -> [Int] -> [CoordState]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> if Int -> Int -> Bool
isStarPoint' Int
x Int
y then CoordState
starCoordState else CoordState
emptyCoordState)
                                [Int
0..Int
widthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1])
                     [Int
0..Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

-- Initializes a 'BoardState' from the properties on a given root 'Node'.
rootBoardState :: Node -> BoardState
rootBoardState :: Node -> BoardState
rootBoardState Node
rootNode =
  (Property -> BoardState -> BoardState)
-> BoardState -> [Property] -> BoardState
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Property -> BoardState -> BoardState
applyProperty
        (Int -> Int -> BoardState
emptyBoardState Int
width Int
height)
        (Node -> [Property]
nodeProperties Node
rootNode)
  where SZ Int
width Int
height = Property -> Maybe Property -> Property
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Property
SZ Int
boardSizeDefault Int
boardSizeDefault) (Maybe Property -> Property) -> Maybe Property -> Property
forall a b. (a -> b) -> a -> b
$
                          ValuedPropertyInfo (Int, Int) -> Node -> Maybe Property
forall a. Descriptor a => a -> Node -> Maybe Property
findProperty ValuedPropertyInfo (Int, Int)
propertySZ Node
rootNode

-- | A 'CoordState' for an empty point on the board.
emptyCoordState :: CoordState
emptyCoordState :: CoordState
emptyCoordState = CoordState :: Bool -> Maybe Color -> Maybe Mark -> Bool -> Bool -> CoordState
CoordState
  { coordStar :: Bool
coordStar = Bool
False
  , coordStone :: Maybe Color
coordStone = Maybe Color
forall a. Maybe a
Nothing
  , coordMark :: Maybe Mark
coordMark = Maybe Mark
forall a. Maybe a
Nothing
  , coordVisible :: Bool
coordVisible = Bool
True
  , coordDimmed :: Bool
coordDimmed = Bool
False
  }

-- | Returns the 'CoordState' for a coordinate on a board.
boardCoordState :: Coord -> BoardState -> CoordState
boardCoordState :: (Int, Int) -> BoardState -> CoordState
boardCoordState (Int
x, Int
y) BoardState
board = BoardState -> [[CoordState]]
boardCoordStates BoardState
board [[CoordState]] -> Int -> [CoordState]
forall a. [a] -> Int -> a
!! Int
y [CoordState] -> Int -> CoordState
forall a. [a] -> Int -> a
!! Int
x

-- | Modifies a 'BoardState' by updating the 'CoordState' at a single point.
boardCoordModify :: BoardState -> Coord -> (CoordState -> CoordState) -> BoardState
boardCoordModify :: BoardState
-> (Int, Int) -> (CoordState -> CoordState) -> BoardState
boardCoordModify BoardState
board (Int
x, Int
y) CoordState -> CoordState
f =
  BoardState
board { boardCoordStates :: [[CoordState]]
boardCoordStates =
          ([CoordState] -> [CoordState])
-> Int -> [[CoordState]] -> [[CoordState]]
forall a. Show a => (a -> a) -> Int -> [a] -> [a]
listUpdate ((CoordState -> CoordState) -> Int -> [CoordState] -> [CoordState]
forall a. Show a => (a -> a) -> Int -> [a] -> [a]
listUpdate CoordState -> CoordState
f Int
x) Int
y ([[CoordState]] -> [[CoordState]])
-> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> a -> b
$ BoardState -> [[CoordState]]
boardCoordStates BoardState
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 :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]]
mapBoardCoords Int -> Int -> CoordState -> a
fn BoardState
board =
  (Int -> [CoordState] -> [a]) -> [Int] -> [[CoordState]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [CoordState] -> [a]
applyRow [Int
0..] ([[CoordState]] -> [[a]]) -> [[CoordState]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ BoardState -> [[CoordState]]
boardCoordStates BoardState
board
  where applyRow :: Int -> [CoordState] -> [a]
applyRow Int
y = (Int -> CoordState -> a) -> [Int] -> [CoordState] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> CoordState -> a
fn Int
y) [Int
0..]

-- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a
-- 'BoardState'.
updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState
updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState
updateRootInfo RootInfo -> RootInfo
fn BoardState
board = ((GameInfo -> GameInfo) -> BoardState -> BoardState)
-> BoardState -> (GameInfo -> GameInfo) -> BoardState
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo BoardState
board ((GameInfo -> GameInfo) -> BoardState)
-> (GameInfo -> GameInfo) -> BoardState
forall a b. (a -> b) -> a -> b
$ \GameInfo
gameInfo ->
  GameInfo
gameInfo { gameInfoRootInfo :: RootInfo
gameInfoRootInfo = RootInfo -> RootInfo
fn (RootInfo -> RootInfo) -> RootInfo -> RootInfo
forall a b. (a -> b) -> a -> b
$ GameInfo -> RootInfo
gameInfoRootInfo GameInfo
gameInfo }

-- | Applies a function to update the 'GameInfo' of a 'BoardState'.
updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo GameInfo -> GameInfo
fn BoardState
board = BoardState
board { boardGameInfo :: GameInfo
boardGameInfo = GameInfo -> GameInfo
fn (GameInfo -> GameInfo) -> GameInfo -> GameInfo
forall a b. (a -> b) -> a -> b
$ BoardState -> GameInfo
boardGameInfo BoardState
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 :: 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.
  BoardState -> Node -> BoardState
boardApplyChild (BoardState -> Node -> BoardState)
-> (BoardState -> BoardState) -> BoardState -> Node -> BoardState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoardState -> BoardState
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 :: BoardState -> BoardState
boardResetForChild BoardState
board =
  BoardState
board { boardCoordStates :: [[CoordState]]
boardCoordStates =
            (if BoardState -> Bool
boardHasCoordMarks BoardState
board then ([CoordState] -> [CoordState]) -> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> [a] -> [b]
map ((CoordState -> CoordState) -> [CoordState] -> [CoordState]
forall a b. (a -> b) -> [a] -> [b]
map CoordState -> CoordState
clearMark) else [[CoordState]] -> [[CoordState]]
forall a. a -> a
id) ([[CoordState]] -> [[CoordState]])
-> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> a -> b
$
            BoardState -> [[CoordState]]
boardCoordStates BoardState
board
        , boardHasCoordMarks :: Bool
boardHasCoordMarks = Bool
False
        , boardArrows :: ArrowList
boardArrows = []
        , boardLines :: LineList
boardLines = []
        , boardLabels :: LabelList
boardLabels = []
        }
  where clearMark :: CoordState -> CoordState
clearMark CoordState
coord = case CoordState -> Maybe Mark
coordMark CoordState
coord of
          Maybe Mark
Nothing -> CoordState
coord
          Just Mark
_ -> CoordState
coord { coordMark :: Maybe Mark
coordMark = Maybe Mark
forall a. Maybe a
Nothing }

-- | Applies a child node's properties to a prepared 'BoardState'.  This is the
-- second step of 'boardChild'.
boardApplyChild :: BoardState -> Node -> BoardState
boardApplyChild :: BoardState -> Node -> BoardState
boardApplyChild = (Node -> BoardState -> BoardState)
-> BoardState -> Node -> BoardState
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node -> BoardState -> BoardState
applyProperties

-- | Sets all points on a board to be visible (if given true) or invisible (if
-- given false).
setBoardVisible :: Bool -> BoardState -> BoardState
setBoardVisible :: Bool -> BoardState -> BoardState
setBoardVisible Bool
visible BoardState
board =
  if Bool
visible
  then if BoardState -> Bool
boardHasInvisible BoardState
board
       then BoardState
board { boardCoordStates :: [[CoordState]]
boardCoordStates = ([CoordState] -> [CoordState]) -> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> [a] -> [b]
map ((CoordState -> CoordState) -> [CoordState] -> [CoordState]
forall a b. (a -> b) -> [a] -> [b]
map ((CoordState -> CoordState) -> [CoordState] -> [CoordState])
-> (CoordState -> CoordState) -> [CoordState] -> [CoordState]
forall a b. (a -> b) -> a -> b
$ Bool -> CoordState -> CoordState
setVisible Bool
True) ([[CoordState]] -> [[CoordState]])
-> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> a -> b
$ BoardState -> [[CoordState]]
boardCoordStates BoardState
board
                  , boardHasInvisible :: Bool
boardHasInvisible = Bool
False
                  }
       else BoardState
board
  else BoardState
board { boardCoordStates :: [[CoordState]]
boardCoordStates = ([CoordState] -> [CoordState]) -> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> [a] -> [b]
map ((CoordState -> CoordState) -> [CoordState] -> [CoordState]
forall a b. (a -> b) -> [a] -> [b]
map ((CoordState -> CoordState) -> [CoordState] -> [CoordState])
-> (CoordState -> CoordState) -> [CoordState] -> [CoordState]
forall a b. (a -> b) -> a -> b
$ Bool -> CoordState -> CoordState
setVisible Bool
False) ([[CoordState]] -> [[CoordState]])
-> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> a -> b
$ BoardState -> [[CoordState]]
boardCoordStates BoardState
board
             , boardHasInvisible :: Bool
boardHasInvisible = Bool
True
             }
  where setVisible :: Bool -> CoordState -> CoordState
setVisible Bool
vis CoordState
coord = CoordState
coord { coordVisible :: Bool
coordVisible = Bool
vis }

-- | Resets all points on a board not to be dimmed.
clearBoardDimmed :: BoardState -> BoardState
clearBoardDimmed :: BoardState -> BoardState
clearBoardDimmed BoardState
board =
  if BoardState -> Bool
boardHasDimmed BoardState
board
  then BoardState
board { boardCoordStates :: [[CoordState]]
boardCoordStates = ([CoordState] -> [CoordState]) -> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> [a] -> [b]
map ((CoordState -> CoordState) -> [CoordState] -> [CoordState]
forall a b. (a -> b) -> [a] -> [b]
map CoordState -> CoordState
clearDim) ([[CoordState]] -> [[CoordState]])
-> [[CoordState]] -> [[CoordState]]
forall a b. (a -> b) -> a -> b
$ BoardState -> [[CoordState]]
boardCoordStates BoardState
board
             , boardHasDimmed :: Bool
boardHasDimmed = Bool
False
             }
  else BoardState
board
  where clearDim :: CoordState -> CoordState
clearDim CoordState
coord = CoordState
coord { coordDimmed :: Bool
coordDimmed = Bool
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 :: Property -> BoardState -> BoardState
applyProperty (B Maybe (Int, Int)
maybeXy) BoardState
board = Color -> BoardState -> BoardState
updateBoardForMove Color
Black (BoardState -> BoardState) -> BoardState -> BoardState
forall a b. (a -> b) -> a -> b
$ case Maybe (Int, Int)
maybeXy of
  Maybe (Int, Int)
Nothing -> BoardState
board  -- Pass.
  Just (Int, Int)
xy -> BoardState -> ApplyMoveResult -> BoardState
getApplyMoveResult BoardState
board (ApplyMoveResult -> BoardState) -> ApplyMoveResult -> BoardState
forall a b. (a -> b) -> a -> b
$
             ApplyMoveParams
-> Color -> (Int, Int) -> BoardState -> ApplyMoveResult
applyMove ApplyMoveParams
playTheDarnMoveGoParams Color
Black (Int, Int)
xy BoardState
board
applyProperty Property
KO BoardState
board = BoardState
board
applyProperty (MN Integer
moveNum) BoardState
board = BoardState
board { boardMoveNumber :: Integer
boardMoveNumber = Integer
moveNum }
applyProperty (W Maybe (Int, Int)
maybeXy) BoardState
board = Color -> BoardState -> BoardState
updateBoardForMove Color
White (BoardState -> BoardState) -> BoardState -> BoardState
forall a b. (a -> b) -> a -> b
$ case Maybe (Int, Int)
maybeXy of
  Maybe (Int, Int)
Nothing -> BoardState
board  -- Pass.
  Just (Int, Int)
xy -> BoardState -> ApplyMoveResult -> BoardState
getApplyMoveResult BoardState
board (ApplyMoveResult -> BoardState) -> ApplyMoveResult -> BoardState
forall a b. (a -> b) -> a -> b
$
             ApplyMoveParams
-> Color -> (Int, Int) -> BoardState -> ApplyMoveResult
applyMove ApplyMoveParams
playTheDarnMoveGoParams Color
White (Int, Int)
xy BoardState
board

applyProperty (AB CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordStone :: Maybe Color
coordStone = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Black }) CoordList
coords BoardState
board
applyProperty (AW CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordStone :: Maybe Color
coordStone = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
White }) CoordList
coords BoardState
board
applyProperty (AE CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordStone :: Maybe Color
coordStone = Maybe Color
forall a. Maybe a
Nothing }) CoordList
coords BoardState
board
applyProperty (PL Color
color) BoardState
board = BoardState
board { boardPlayerTurn :: Color
boardPlayerTurn = Color
color }

applyProperty (C {}) BoardState
board = BoardState
board
applyProperty (DM {}) BoardState
board = BoardState
board
applyProperty (GB {}) BoardState
board = BoardState
board
applyProperty (GW {}) BoardState
board = BoardState
board
applyProperty (HO {}) BoardState
board = BoardState
board
applyProperty (N {}) BoardState
board = BoardState
board
applyProperty (UC {}) BoardState
board = BoardState
board
applyProperty (V {}) BoardState
board = BoardState
board

applyProperty (BM {}) BoardState
board = BoardState
board
applyProperty (DO {}) BoardState
board = BoardState
board
applyProperty (IT {}) BoardState
board = BoardState
board
applyProperty (TE {}) BoardState
board = BoardState
board

applyProperty (AR ArrowList
arrows) BoardState
board = BoardState
board { boardArrows :: ArrowList
boardArrows = ArrowList
arrows ArrowList -> ArrowList -> ArrowList
forall a. [a] -> [a] -> [a]
++ BoardState -> ArrowList
boardArrows BoardState
board }
applyProperty (CR CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordMark :: Maybe Mark
coordMark = Mark -> Maybe Mark
forall a. a -> Maybe a
Just Mark
MarkCircle }) CoordList
coords
  BoardState
board { boardHasCoordMarks :: Bool
boardHasCoordMarks = Bool
True }
applyProperty (DD CoordList
coords) BoardState
board =
  let coords' :: [(Int, Int)]
coords' = CoordList -> [(Int, Int)]
expandCoordList CoordList
coords
      board' :: BoardState
board' = BoardState -> BoardState
clearBoardDimmed BoardState
board
  in if [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
coords'
     then BoardState
board'
     else (CoordState -> CoordState)
-> [(Int, Int)] -> BoardState -> BoardState
updateCoordStates (\CoordState
state -> CoordState
state { coordDimmed :: Bool
coordDimmed = Bool
True }) [(Int, Int)]
coords'
          BoardState
board' { boardHasDimmed :: Bool
boardHasDimmed = Bool
True }
applyProperty (LB LabelList
labels) BoardState
board = BoardState
board { boardLabels :: LabelList
boardLabels = LabelList
labels LabelList -> LabelList -> LabelList
forall a. [a] -> [a] -> [a]
++ BoardState -> LabelList
boardLabels BoardState
board }
applyProperty (LN LineList
lines) BoardState
board = BoardState
board { boardLines :: LineList
boardLines = LineList
lines LineList -> LineList -> LineList
forall a. [a] -> [a] -> [a]
++ BoardState -> LineList
boardLines BoardState
board }
applyProperty (MA CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordMark :: Maybe Mark
coordMark = Mark -> Maybe Mark
forall a. a -> Maybe a
Just Mark
MarkX }) CoordList
coords
  BoardState
board { boardHasCoordMarks :: Bool
boardHasCoordMarks = Bool
True }
applyProperty (SL CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordMark :: Maybe Mark
coordMark = Mark -> Maybe Mark
forall a. a -> Maybe a
Just Mark
MarkSelected }) CoordList
coords
  BoardState
board { boardHasCoordMarks :: Bool
boardHasCoordMarks = Bool
True }
applyProperty (SQ CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordMark :: Maybe Mark
coordMark = Mark -> Maybe Mark
forall a. a -> Maybe a
Just Mark
MarkSquare }) CoordList
coords
  BoardState
board { boardHasCoordMarks :: Bool
boardHasCoordMarks = Bool
True }
applyProperty (TR CoordList
coords) BoardState
board =
  (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' (\CoordState
state -> CoordState
state { coordMark :: Maybe Mark
coordMark = Mark -> Maybe Mark
forall a. a -> Maybe a
Just Mark
MarkTriangle }) CoordList
coords
  BoardState
board { boardHasCoordMarks :: Bool
boardHasCoordMarks = Bool
True }

applyProperty (AP {}) BoardState
board = BoardState
board
applyProperty (CA {}) BoardState
board = BoardState
board
applyProperty (FF {}) BoardState
board = BoardState
board
applyProperty (GM {}) BoardState
board = BoardState
board
applyProperty (ST VariationMode
variationMode) BoardState
board =
  (RootInfo -> RootInfo) -> BoardState -> BoardState
updateRootInfo (\RootInfo
info -> RootInfo
info { rootInfoVariationMode :: VariationMode
rootInfoVariationMode = VariationMode
variationMode }) BoardState
board
applyProperty (SZ {}) BoardState
board = BoardState
board

applyProperty (AN SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoAnnotatorName :: Maybe SimpleText
gameInfoAnnotatorName = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (BR SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoBlackRank :: Maybe SimpleText
gameInfoBlackRank = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (BT SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoBlackTeamName :: Maybe SimpleText
gameInfoBlackTeamName = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (CP SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoCopyright :: Maybe SimpleText
gameInfoCopyright = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (DT SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoDatesPlayed :: Maybe SimpleText
gameInfoDatesPlayed = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (EV SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoEvent :: Maybe SimpleText
gameInfoEvent = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (GC Text
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoGameComment :: Maybe Text
gameInfoGameComment = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
str }) BoardState
board
applyProperty (GN SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoGameName :: Maybe SimpleText
gameInfoGameName = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (ON SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoOpeningComment :: Maybe SimpleText
gameInfoOpeningComment = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (OT SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoOvertime :: Maybe SimpleText
gameInfoOvertime = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (PB SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoBlackName :: Maybe SimpleText
gameInfoBlackName = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (PC SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoPlace :: Maybe SimpleText
gameInfoPlace = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (PW SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoWhiteName :: Maybe SimpleText
gameInfoWhiteName = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (RE GameResult
result) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoResult :: Maybe GameResult
gameInfoResult = GameResult -> Maybe GameResult
forall a. a -> Maybe a
Just GameResult
result }) BoardState
board
applyProperty (RO SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoRound :: Maybe SimpleText
gameInfoRound = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (RU Ruleset
ruleset) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoRuleset :: Maybe Ruleset
gameInfoRuleset = Ruleset -> Maybe Ruleset
forall a. a -> Maybe a
Just Ruleset
ruleset }) BoardState
board
applyProperty (SO SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoSource :: Maybe SimpleText
gameInfoSource = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (TM RealValue
seconds) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoBasicTimeSeconds :: Maybe RealValue
gameInfoBasicTimeSeconds = RealValue -> Maybe RealValue
forall a. a -> Maybe a
Just RealValue
seconds }) BoardState
board
applyProperty (US SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoEntererName :: Maybe SimpleText
gameInfoEntererName = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (WR SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoWhiteRank :: Maybe SimpleText
gameInfoWhiteRank = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board
applyProperty (WT SimpleText
str) BoardState
board =
  (GameInfo -> GameInfo) -> BoardState -> BoardState
updateBoardInfo (\GameInfo
info -> GameInfo
info { gameInfoWhiteTeamName :: Maybe SimpleText
gameInfoWhiteTeamName = SimpleText -> Maybe SimpleText
forall a. a -> Maybe a
Just SimpleText
str }) BoardState
board

applyProperty (BL {}) BoardState
board = BoardState
board
applyProperty (OB {}) BoardState
board = BoardState
board
applyProperty (OW {}) BoardState
board = BoardState
board
applyProperty (WL {}) BoardState
board = BoardState
board

applyProperty (VW CoordList
coords) BoardState
board =
  let coords' :: [(Int, Int)]
coords' = CoordList -> [(Int, Int)]
expandCoordList CoordList
coords
  in if [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
coords'
     then Bool -> BoardState -> BoardState
setBoardVisible Bool
True BoardState
board
     else (CoordState -> CoordState)
-> [(Int, Int)] -> BoardState -> BoardState
updateCoordStates (\CoordState
state -> CoordState
state { coordVisible :: Bool
coordVisible = Bool
True }) [(Int, Int)]
coords' (BoardState -> BoardState) -> BoardState -> BoardState
forall a b. (a -> b) -> a -> b
$
          Bool -> BoardState -> BoardState
setBoardVisible Bool
False BoardState
board

applyProperty (HA {}) BoardState
board = BoardState
board
applyProperty (KM {}) BoardState
board = BoardState
board
applyProperty (TB {}) BoardState
board = BoardState
board
applyProperty (TW {}) BoardState
board = BoardState
board

applyProperty (UnknownProperty {}) BoardState
board = BoardState
board

applyProperties :: Node -> BoardState -> BoardState
applyProperties :: Node -> BoardState -> BoardState
applyProperties Node
node BoardState
board = (Property -> BoardState -> BoardState)
-> BoardState -> [Property] -> BoardState
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Property -> BoardState -> BoardState
applyProperty BoardState
board (Node -> [Property]
nodeProperties Node
node)

-- | Applies the transformation function to all of a board's coordinates
-- referred to by the 'CoordList'.
updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState
updateCoordStates :: (CoordState -> CoordState)
-> [(Int, Int)] -> BoardState -> BoardState
updateCoordStates CoordState -> CoordState
fn [(Int, Int)]
coords BoardState
board =
  BoardState
board { boardCoordStates :: [[CoordState]]
boardCoordStates = ((Int, Int) -> [[CoordState]] -> [[CoordState]])
-> [[CoordState]] -> [(Int, Int)] -> [[CoordState]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int) -> [[CoordState]] -> [[CoordState]]
applyFn (BoardState -> [[CoordState]]
boardCoordStates BoardState
board) [(Int, Int)]
coords }
  where applyFn :: (Int, Int) -> [[CoordState]] -> [[CoordState]]
applyFn (Int
x, Int
y) = ([CoordState] -> [CoordState])
-> Int -> [[CoordState]] -> [[CoordState]]
forall a. Show a => (a -> a) -> Int -> [a] -> [a]
listUpdate (Int -> [CoordState] -> [CoordState]
updateRow Int
x) Int
y
        updateRow :: Int -> [CoordState] -> [CoordState]
updateRow = (CoordState -> CoordState) -> Int -> [CoordState] -> [CoordState]
forall a. Show a => (a -> a) -> Int -> [a] -> [a]
listUpdate CoordState -> CoordState
fn

updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState
updateCoordStates' CoordState -> CoordState
fn CoordList
coords = (CoordState -> CoordState)
-> [(Int, Int)] -> BoardState -> BoardState
updateCoordStates CoordState -> CoordState
fn (CoordList -> [(Int, Int)]
expandCoordList CoordList
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 :: Color -> BoardState -> BoardState
updateBoardForMove Color
movedPlayer BoardState
board =
  BoardState
board { boardMoveNumber :: Integer
boardMoveNumber = BoardState -> Integer
boardMoveNumber BoardState
board Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
        , boardPlayerTurn :: Color
boardPlayerTurn = Color -> Color
cnot Color
movedPlayer
        }

-- | A structure that configures how 'applyMove' should handle moves that are
-- normally illegal in Go.
data ApplyMoveParams = ApplyMoveParams
  { ApplyMoveParams -> Bool
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.
  , ApplyMoveParams -> Bool
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 (Int -> ApplyMoveParams -> ShowS
[ApplyMoveParams] -> ShowS
ApplyMoveParams -> String
(Int -> ApplyMoveParams -> ShowS)
-> (ApplyMoveParams -> String)
-> ([ApplyMoveParams] -> ShowS)
-> Show ApplyMoveParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplyMoveParams] -> ShowS
$cshowList :: [ApplyMoveParams] -> ShowS
show :: ApplyMoveParams -> String
$cshow :: ApplyMoveParams -> String
showsPrec :: Int -> ApplyMoveParams -> ShowS
$cshowsPrec :: Int -> ApplyMoveParams -> ShowS
Show)

-- | As an argument to 'applyMove', causes illegal moves to be treated as
-- errors.
standardGoMoveParams :: ApplyMoveParams
standardGoMoveParams :: ApplyMoveParams
standardGoMoveParams = ApplyMoveParams :: Bool -> Bool -> ApplyMoveParams
ApplyMoveParams
  { allowSuicide :: Bool
allowSuicide = Bool
False
  , allowOverwrite :: Bool
allowOverwrite = Bool
False
  }

-- | As an argument to 'applyMove', causes illegal moves to be played
-- unconditionally.
playTheDarnMoveGoParams :: ApplyMoveParams
playTheDarnMoveGoParams :: ApplyMoveParams
playTheDarnMoveGoParams = ApplyMoveParams :: Bool -> Bool -> ApplyMoveParams
ApplyMoveParams
  { allowSuicide :: Bool
allowSuicide = Bool
True
  , allowOverwrite :: Bool
allowOverwrite = Bool
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 :: BoardState -> ApplyMoveResult -> BoardState
getApplyMoveResult BoardState
defaultBoard ApplyMoveResult
result = BoardState -> Maybe BoardState -> BoardState
forall a. a -> Maybe a -> a
fromMaybe BoardState
defaultBoard (Maybe BoardState -> BoardState) -> Maybe BoardState -> BoardState
forall a b. (a -> b) -> a -> b
$ ApplyMoveResult -> Maybe BoardState
getApplyMoveResult' ApplyMoveResult
result

getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState
getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState
getApplyMoveResult' ApplyMoveResult
result = case ApplyMoveResult
result of
  ApplyMoveOk BoardState
board -> BoardState -> Maybe BoardState
forall a. a -> Maybe a
Just BoardState
board
  ApplyMoveCapture BoardState
board Color
color Int
points -> BoardState -> Maybe BoardState
forall a. a -> Maybe a
Just (BoardState -> Maybe BoardState) -> BoardState -> Maybe BoardState
forall a b. (a -> b) -> a -> b
$ case Color
color of
    Color
Black -> BoardState
board { boardBlackCaptures :: Int
boardBlackCaptures = BoardState -> Int
boardBlackCaptures BoardState
board Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
points }
    Color
White -> BoardState
board { boardWhiteCaptures :: Int
boardWhiteCaptures = BoardState -> Int
boardWhiteCaptures BoardState
board Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
points }
  ApplyMoveResult
ApplyMoveSuicideError -> Maybe BoardState
forall a. Maybe a
Nothing
  ApplyMoveOverwriteError Color
_ -> Maybe BoardState
forall a. Maybe a
Nothing

-- | Internal data structure, only for move application code.  Represents a
-- group of stones.
data ApplyMoveGroup = ApplyMoveGroup
  { ApplyMoveGroup -> (Int, Int)
applyMoveGroupOrigin :: Coord
  , ApplyMoveGroup -> [(Int, Int)]
applyMoveGroupCoords :: [Coord]
  , ApplyMoveGroup -> Int
applyMoveGroupLiberties :: Int
  } deriving (Int -> ApplyMoveGroup -> ShowS
[ApplyMoveGroup] -> ShowS
ApplyMoveGroup -> String
(Int -> ApplyMoveGroup -> ShowS)
-> (ApplyMoveGroup -> String)
-> ([ApplyMoveGroup] -> ShowS)
-> Show ApplyMoveGroup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplyMoveGroup] -> ShowS
$cshowList :: [ApplyMoveGroup] -> ShowS
show :: ApplyMoveGroup -> String
$cshow :: ApplyMoveGroup -> String
showsPrec :: Int -> ApplyMoveGroup -> ShowS
$cshowsPrec :: Int -> ApplyMoveGroup -> ShowS
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 :: ApplyMoveParams
-> Color -> (Int, Int) -> BoardState -> ApplyMoveResult
applyMove ApplyMoveParams
params Color
color (Int, Int)
xy BoardState
board =
  let currentStone :: Maybe Color
currentStone = CoordState -> Maybe Color
coordStone (CoordState -> Maybe Color) -> CoordState -> Maybe Color
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> BoardState -> CoordState
boardCoordState (Int, Int)
xy BoardState
board
  in case Maybe Color
currentStone of
    Just Color
color -> if ApplyMoveParams -> Bool
allowOverwrite ApplyMoveParams
params
                  then ApplyMoveResult
moveResult
                  else Color -> ApplyMoveResult
ApplyMoveOverwriteError Color
color
    Maybe Color
Nothing -> ApplyMoveResult
moveResult
  where boardWithMove :: BoardState
boardWithMove = (CoordState -> CoordState)
-> [(Int, Int)] -> BoardState -> BoardState
updateCoordStates (\CoordState
state -> CoordState
state { coordStone :: Maybe Color
coordStone = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
color })
                                          [(Int, Int)
xy]
                                          BoardState
board
        (BoardState
boardWithCaptures, Int
points) = ((Int, Int) -> (BoardState, Int) -> (BoardState, Int))
-> (BoardState, Int) -> [(Int, Int)] -> (BoardState, Int)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Color -> (Int, Int) -> (BoardState, Int) -> (BoardState, Int)
maybeCapture (Color -> (Int, Int) -> (BoardState, Int) -> (BoardState, Int))
-> Color -> (Int, Int) -> (BoardState, Int) -> (BoardState, Int)
forall a b. (a -> b) -> a -> b
$ Color -> Color
cnot Color
color)
                                            (BoardState
boardWithMove, Int
0)
                                            (BoardState -> (Int, Int) -> [(Int, Int)]
adjacentPoints BoardState
boardWithMove (Int, Int)
xy)
        playedGroup :: ApplyMoveGroup
playedGroup = BoardState -> (Int, Int) -> ApplyMoveGroup
computeGroup BoardState
boardWithCaptures (Int, Int)
xy
        moveResult :: ApplyMoveResult
moveResult
          | ApplyMoveGroup -> Int
applyMoveGroupLiberties ApplyMoveGroup
playedGroup Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
            if Int
points Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
            then String -> ApplyMoveResult
forall a. HasCallStack => String -> a
error String
"Cannot commit suicide and capture at the same time."
            else if ApplyMoveParams -> Bool
allowSuicide ApplyMoveParams
params
                 then let (BoardState
boardWithSuicide, Int
suicidePoints) =
                            (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int)
applyMoveCapture (BoardState
boardWithCaptures, Int
0) ApplyMoveGroup
playedGroup
                      in BoardState -> Color -> Int -> ApplyMoveResult
ApplyMoveCapture BoardState
boardWithSuicide (Color -> Color
cnot Color
color) Int
suicidePoints
                 else ApplyMoveResult
ApplyMoveSuicideError
          | Int
points Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = BoardState -> Color -> Int -> ApplyMoveResult
ApplyMoveCapture BoardState
boardWithCaptures Color
color Int
points
          | Bool
otherwise = BoardState -> ApplyMoveResult
ApplyMoveOk BoardState
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 -> (Int, Int) -> (BoardState, Int) -> (BoardState, Int)
maybeCapture Color
color (Int, Int)
xy result :: (BoardState, Int)
result@(BoardState
board, Int
_) =
  if CoordState -> Maybe Color
coordStone ((Int, Int) -> BoardState -> CoordState
boardCoordState (Int, Int)
xy BoardState
board) Maybe Color -> Maybe Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Color -> Maybe Color
forall a. a -> Maybe a
Just Color
color
  then (BoardState, Int)
result
  else let group :: ApplyMoveGroup
group = BoardState -> (Int, Int) -> ApplyMoveGroup
computeGroup BoardState
board (Int, Int)
xy
       in if ApplyMoveGroup -> Int
applyMoveGroupLiberties ApplyMoveGroup
group Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
          then (BoardState, Int)
result
          else (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int)
applyMoveCapture (BoardState, Int)
result ApplyMoveGroup
group

computeGroup :: BoardState -> Coord -> ApplyMoveGroup
computeGroup :: BoardState -> (Int, Int) -> ApplyMoveGroup
computeGroup BoardState
board (Int, Int)
xy =
  if Maybe Color -> Bool
forall a. Maybe a -> Bool
isNothing (CoordState -> Maybe Color
coordStone (CoordState -> Maybe Color) -> CoordState -> Maybe Color
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> BoardState -> CoordState
boardCoordState (Int, Int)
xy BoardState
board)
  then String -> ApplyMoveGroup
forall a. HasCallStack => String -> a
error String
"computeGroup called on an empty point."
  else let groupCoords :: [(Int, Int)]
groupCoords = BoardState -> (Int, Int) -> [(Int, Int)]
bucketFill BoardState
board (Int, Int)
xy
       in ApplyMoveGroup :: (Int, Int) -> [(Int, Int)] -> Int -> ApplyMoveGroup
ApplyMoveGroup { applyMoveGroupOrigin :: (Int, Int)
applyMoveGroupOrigin = (Int, Int)
xy
                         , applyMoveGroupCoords :: [(Int, Int)]
applyMoveGroupCoords = [(Int, Int)]
groupCoords
                         , applyMoveGroupLiberties :: Int
applyMoveGroupLiberties = BoardState -> [(Int, Int)] -> Int
getLibertiesOfGroup BoardState
board [(Int, Int)]
groupCoords
                         }

applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int)
applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int)
applyMoveCapture (BoardState
board, Int
points) ApplyMoveGroup
group =
  ((CoordState -> CoordState)
-> [(Int, Int)] -> BoardState -> BoardState
updateCoordStates (\CoordState
state -> CoordState
state { coordStone :: Maybe Color
coordStone = Maybe Color
forall a. Maybe a
Nothing })
                     (ApplyMoveGroup -> [(Int, Int)]
applyMoveGroupCoords ApplyMoveGroup
group)
                     BoardState
board,
   Int
points Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Int, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ApplyMoveGroup -> [(Int, Int)]
applyMoveGroupCoords ApplyMoveGroup
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 :: BoardState -> (Int, Int) -> [(Int, Int)]
adjacentPoints BoardState
board (Int
x, Int
y) = Writer [(Int, Int)] () -> [(Int, Int)]
forall w a. Writer w a -> w
execWriter (Writer [(Int, Int)] () -> [(Int, Int)])
-> Writer [(Int, Int)] () -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ do
  Bool -> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Writer [(Int, Int)] () -> Writer [(Int, Int)] ())
-> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Writer [(Int, Int)] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
y)]
  Bool -> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Writer [(Int, Int)] () -> Writer [(Int, Int)] ())
-> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Writer [(Int, Int)] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Int
x, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
  Bool -> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< BoardState -> Int
boardWidth BoardState
board Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Writer [(Int, Int)] () -> Writer [(Int, Int)] ())
-> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Writer [(Int, Int)] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y)]
  Bool -> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< BoardState -> Int
boardHeight BoardState
board Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Writer [(Int, Int)] () -> Writer [(Int, Int)] ())
-> Writer [(Int, Int)] () -> Writer [(Int, Int)] ()
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> Writer [(Int, Int)] ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Int
x, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 :: BoardState -> [(Int, Int)] -> Int
getLibertiesOfGroup BoardState
board [(Int, Int)]
groupCoords =
  [(Int, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int, Int)] -> Int) -> [(Int, Int)] -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> [(Int, Int)]
forall a. Eq a => [a] -> [a]
nub ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, Int) -> [(Int, Int)]
findLiberties [(Int, Int)]
groupCoords
  where findLiberties :: (Int, Int) -> [(Int, Int)]
findLiberties (Int, Int)
xy = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int, Int)
xy' -> Maybe Color -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Color -> Bool) -> Maybe Color -> Bool
forall a b. (a -> b) -> a -> b
$ CoordState -> Maybe Color
coordStone (CoordState -> Maybe Color) -> CoordState -> Maybe Color
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> BoardState -> CoordState
boardCoordState (Int, Int)
xy' BoardState
board)
                                  (BoardState -> (Int, Int) -> [(Int, Int)]
adjacentPoints BoardState
board (Int, Int)
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 :: BoardState -> (Int, Int) -> [(Int, Int)]
bucketFill BoardState
board (Int, Int)
xy0 = Set (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
bucketFill' Set (Int, Int)
forall a. Set a
Set.empty [(Int, Int)
xy0]
  where bucketFill' :: Set (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
bucketFill' Set (Int, Int)
known [] = Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
Set.toList Set (Int, Int)
known
        bucketFill' Set (Int, Int)
known ((Int, Int)
xy:[(Int, Int)]
xys) =
          if (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Int, Int)
xy Set (Int, Int)
known
          then Set (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
bucketFill' Set (Int, Int)
known [(Int, Int)]
xys
          else let new :: [(Int, Int)]
new = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Color
stone0 Maybe Color -> Maybe Color -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Color -> Bool)
-> ((Int, Int) -> Maybe Color) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoordState -> Maybe Color
coordStone (CoordState -> Maybe Color)
-> ((Int, Int) -> CoordState) -> (Int, Int) -> Maybe Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> BoardState -> CoordState)
-> BoardState -> (Int, Int) -> CoordState
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int, Int) -> BoardState -> CoordState
boardCoordState BoardState
board)
                                (BoardState -> (Int, Int) -> [(Int, Int)]
adjacentPoints BoardState
board (Int, Int)
xy)
               in Set (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
bucketFill' ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Int, Int)
xy Set (Int, Int)
known) ([(Int, Int)]
new [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
xys)
        stone0 :: Maybe Color
stone0 = CoordState -> Maybe Color
coordStone (CoordState -> Maybe Color) -> CoordState -> Maybe Color
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> BoardState -> CoordState
boardCoordState (Int, Int)
xy0 BoardState
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 :: BoardState -> Color -> (Int, Int) -> Bool
isValidMove BoardState
board Color
color coord :: (Int, Int)
coord@(Int
x, Int
y) =
  let w :: Int
w = BoardState -> Int
boardWidth BoardState
board
      h :: Int
h = BoardState -> Int
boardHeight BoardState
board
  in Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h Bool -> Bool -> Bool
&&
     Maybe BoardState -> Bool
forall a. Maybe a -> Bool
isJust (ApplyMoveResult -> Maybe BoardState
getApplyMoveResult' (ApplyMoveResult -> Maybe BoardState)
-> ApplyMoveResult -> Maybe BoardState
forall a b. (a -> b) -> a -> b
$ ApplyMoveParams
-> Color -> (Int, Int) -> BoardState -> ApplyMoveResult
applyMove ApplyMoveParams
standardGoMoveParams Color
color (Int, Int)
coord BoardState
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 :: BoardState -> (Int, Int) -> Bool
isCurrentValidMove BoardState
board = BoardState -> Color -> (Int, Int) -> Bool
isValidMove BoardState
board (BoardState -> Color
boardPlayerTurn BoardState
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
  { Cursor -> Maybe 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.

  , Cursor -> Int
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.

  , Cursor -> CursorNode
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.

  , Cursor -> BoardState
cursorBoard :: BoardState
    -- ^ The complete board state for the current node.
  } deriving (Int -> Cursor -> ShowS
[Cursor] -> ShowS
Cursor -> String
(Int -> Cursor -> ShowS)
-> (Cursor -> String) -> ([Cursor] -> ShowS) -> Show Cursor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cursor] -> ShowS
$cshowList :: [Cursor] -> ShowS
show :: Cursor -> String
$cshow :: Cursor -> String
showsPrec :: Int -> Cursor -> ShowS
$cshowsPrec :: Int -> Cursor -> ShowS
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 { CursorNode -> Node
getCursorNode :: Node }
  | ModifiedNode { getCursorNode :: Node }
  deriving (Int -> CursorNode -> ShowS
[CursorNode] -> ShowS
CursorNode -> String
(Int -> CursorNode -> ShowS)
-> (CursorNode -> String)
-> ([CursorNode] -> ShowS)
-> Show CursorNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CursorNode] -> ShowS
$cshowList :: [CursorNode] -> ShowS
show :: CursorNode -> String
$cshow :: CursorNode -> String
showsPrec :: Int -> CursorNode -> ShowS
$cshowsPrec :: Int -> CursorNode -> ShowS
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 -> Maybe Cursor
cursorParent Cursor
cursor = case Cursor -> Maybe Cursor
cursorParent' Cursor
cursor of
  Maybe Cursor
Nothing -> Maybe Cursor
forall a. Maybe a
Nothing
  p :: Maybe Cursor
p@(Just Cursor
parent) -> case Cursor -> CursorNode
cursorNode' Cursor
cursor of
    -- If the current node hasn't been modified, then 'parent' is still the
    -- correct parent cursor for the current node.
    UnmodifiedNode Node
_ -> Maybe Cursor
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
node ->
      Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just (Cursor -> Maybe Cursor) -> Cursor -> Maybe Cursor
forall a b. (a -> b) -> a -> b
$ ((Node -> Node) -> Cursor -> Cursor)
-> Cursor -> (Node -> Node) -> Cursor
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Node -> Node) -> Cursor -> Cursor
cursorModifyNode Cursor
parent ((Node -> Node) -> Cursor) -> (Node -> Node) -> Cursor
forall a b. (a -> b) -> a -> b
$ \Node
pnode ->
      Node
pnode { nodeChildren :: [Node]
nodeChildren = (Node -> Node) -> Int -> [Node] -> [Node]
forall a. Show a => (a -> a) -> Int -> [a] -> [a]
listUpdate (Node -> Node -> Node
forall a b. a -> b -> a
const Node
node) (Cursor -> Int
cursorChildIndex Cursor
cursor) ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$
                             Node -> [Node]
nodeChildren Node
pnode }

-- | The game tree node about which the cursor stores information.
cursorNode :: Cursor -> Node
cursorNode :: Cursor -> Node
cursorNode = CursorNode -> Node
getCursorNode (CursorNode -> Node) -> (Cursor -> CursorNode) -> Cursor -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> CursorNode
cursorNode'

-- | Returns a cursor for a root node.
rootCursor :: Node -> Cursor
rootCursor :: Node -> Cursor
rootCursor Node
node =
  Cursor :: Maybe Cursor -> Int -> CursorNode -> BoardState -> Cursor
Cursor { cursorParent' :: Maybe Cursor
cursorParent' = Maybe Cursor
forall a. Maybe a
Nothing
         , cursorChildIndex :: Int
cursorChildIndex = -Int
1
         , cursorNode' :: CursorNode
cursorNode' = Node -> CursorNode
UnmodifiedNode Node
node
         , cursorBoard :: BoardState
cursorBoard = Node -> BoardState
rootBoardState Node
node
         }

cursorRoot :: Cursor -> Cursor
cursorRoot :: Cursor -> Cursor
cursorRoot Cursor
cursor = case Cursor -> Maybe Cursor
cursorParent Cursor
cursor of
  Maybe Cursor
Nothing -> Cursor
cursor
  Just Cursor
parent -> Cursor -> Cursor
cursorRoot Cursor
parent

cursorChild :: Cursor -> Int -> Cursor
cursorChild :: Cursor -> Int -> Cursor
cursorChild Cursor
cursor Int
index =
  Cursor :: Maybe Cursor -> Int -> CursorNode -> BoardState -> Cursor
Cursor { cursorParent' :: Maybe Cursor
cursorParent' = Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cursor
cursor
         , cursorChildIndex :: Int
cursorChildIndex = Int
index
         , cursorNode' :: CursorNode
cursorNode' = Node -> CursorNode
UnmodifiedNode Node
child
         , cursorBoard :: BoardState
cursorBoard = BoardState -> Node -> BoardState
boardChild (Cursor -> BoardState
cursorBoard Cursor
cursor) Node
child
         }
  -- TODO Better handling or messaging for out-of-bounds:
  where child :: Node
child = ([Node] -> Int -> Node
forall a. [a] -> Int -> a
!! Int
index) ([Node] -> Node) -> [Node] -> Node
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
nodeChildren (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ Cursor -> Node
cursorNode Cursor
cursor

cursorChildren :: Cursor -> [Cursor]
cursorChildren :: Cursor -> [Cursor]
cursorChildren Cursor
cursor =
  let board :: BoardState
board = BoardState -> BoardState
boardResetForChild (BoardState -> BoardState) -> BoardState -> BoardState
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
cursor
  in ((Int, Node) -> Cursor) -> [(Int, Node)] -> [Cursor]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
index, Node
child) -> Cursor :: Maybe Cursor -> Int -> CursorNode -> BoardState -> Cursor
Cursor { cursorParent' :: Maybe Cursor
cursorParent' = Cursor -> Maybe Cursor
forall a. a -> Maybe a
Just Cursor
cursor
                                    , cursorChildIndex :: Int
cursorChildIndex = Int
index
                                    , cursorNode' :: CursorNode
cursorNode' = Node -> CursorNode
UnmodifiedNode Node
child
                                    , cursorBoard :: BoardState
cursorBoard = BoardState -> Node -> BoardState
boardApplyChild BoardState
board Node
child
                                    })
     ([(Int, Node)] -> [Cursor]) -> [(Int, Node)] -> [Cursor]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Node] -> [(Int, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
     ([Node] -> [(Int, Node)]) -> [Node] -> [(Int, Node)]
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
nodeChildren
     (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ Cursor -> Node
cursorNode Cursor
cursor

cursorChildCount :: Cursor -> Int
cursorChildCount :: Cursor -> Int
cursorChildCount = [Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Node] -> Int) -> (Cursor -> [Node]) -> Cursor -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node]
nodeChildren (Node -> [Node]) -> (Cursor -> Node) -> Cursor -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Node
cursorNode

cursorChildPlayingAt :: Maybe Coord -> Cursor -> Maybe Cursor
cursorChildPlayingAt :: Maybe (Int, Int) -> Cursor -> Maybe Cursor
cursorChildPlayingAt Maybe (Int, Int)
move Cursor
cursor =
  let children :: [Cursor]
children = Cursor -> [Cursor]
cursorChildren Cursor
cursor
      color :: Color
color = BoardState -> Color
boardPlayerTurn (BoardState -> Color) -> BoardState -> Color
forall a b. (a -> b) -> a -> b
$ Cursor -> BoardState
cursorBoard Cursor
cursor
      hasMove :: [Property] -> Bool
hasMove = Property -> [Property] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Property -> [Property] -> Bool) -> Property -> [Property] -> Bool
forall a b. (a -> b) -> a -> b
$ Color -> Maybe (Int, Int) -> Property
moveToProperty Color
color Maybe (Int, Int)
move
  in (Cursor -> Bool) -> [Cursor] -> Maybe Cursor
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ([Property] -> Bool
hasMove ([Property] -> Bool) -> (Cursor -> [Property]) -> Cursor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Property]
nodeProperties (Node -> [Property]) -> (Cursor -> Node) -> Cursor -> [Property]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Node
cursorNode) [Cursor]
children

-- | This is simply @'nodeProperties' . 'cursorNode'@.
cursorProperties :: Cursor -> [Property]
cursorProperties :: Cursor -> [Property]
cursorProperties = Node -> [Property]
nodeProperties (Node -> [Property]) -> (Cursor -> Node) -> Cursor -> [Property]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Node
cursorNode

cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor
cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor
cursorModifyNode Node -> Node
fn Cursor
cursor =
  let node :: Node
node = Node -> Node
fn (Node -> Node) -> Node -> Node
forall a b. (a -> b) -> a -> b
$ Cursor -> Node
cursorNode Cursor
cursor
      maybeParent :: Maybe Cursor
maybeParent = Cursor -> Maybe Cursor
cursorParent' Cursor
cursor
  in Cursor
cursor { cursorNode' :: CursorNode
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 Maybe Cursor -> Bool
forall a. Maybe a -> Bool
isJust Maybe Cursor
maybeParent then Node -> CursorNode
ModifiedNode else Node -> CursorNode
UnmodifiedNode) Node
node
            , cursorBoard :: BoardState
cursorBoard = case Maybe Cursor
maybeParent of
              Maybe Cursor
Nothing -> Node -> BoardState
rootBoardState Node
node
              Just Cursor
parent -> BoardState -> Node -> BoardState
boardChild (Cursor -> BoardState
cursorBoard Cursor
parent) Node
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 :: VariationModeSource -> Cursor -> [((Int, Int), Color)]
cursorVariations VariationModeSource
source Cursor
cursor =
  case VariationModeSource
source of
    VariationModeSource
ShowChildVariations -> [Node] -> [((Int, Int), Color)]
collectPlays ([Node] -> [((Int, Int), Color)])
-> [Node] -> [((Int, Int), Color)]
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
nodeChildren (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ Cursor -> Node
cursorNode Cursor
cursor
    VariationModeSource
ShowCurrentVariations ->
      case Cursor -> Maybe Cursor
cursorParent Cursor
cursor of
        Maybe Cursor
Nothing -> []
        Just Cursor
parent -> [Node] -> [((Int, Int), Color)]
collectPlays ([Node] -> [((Int, Int), Color)])
-> [Node] -> [((Int, Int), Color)]
forall a b. (a -> b) -> a -> b
$ Int -> [Node] -> [Node]
forall a. Int -> [a] -> [a]
listDeleteAt (Cursor -> Int
cursorChildIndex Cursor
cursor) ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$
                       Node -> [Node]
nodeChildren (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ Cursor -> Node
cursorNode Cursor
parent
  where collectPlays :: [Node] -> [(Coord, Color)]
        collectPlays :: [Node] -> [((Int, Int), Color)]
collectPlays = (Node -> [((Int, Int), Color)]) -> [Node] -> [((Int, Int), Color)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node -> [((Int, Int), Color)]
collectPlays'
        collectPlays' :: Node -> [((Int, Int), Color)]
collectPlays' = (Property -> [((Int, Int), Color)])
-> [Property] -> [((Int, Int), Color)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Property -> [((Int, Int), Color)]
collectPlays'' ([Property] -> [((Int, Int), Color)])
-> (Node -> [Property]) -> Node -> [((Int, Int), Color)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Property]
nodeProperties
        collectPlays'' :: Property -> [((Int, Int), Color)]
collectPlays'' Property
prop = case Property
prop of
          B (Just (Int, Int)
xy) -> [((Int, Int)
xy, Color
Black)]
          W (Just (Int, Int)
xy) -> [((Int, Int)
xy, Color
White)]
          Property
_ -> []

moveToProperty :: Color -> Maybe Coord -> Property
moveToProperty :: Color -> Maybe (Int, Int) -> Property
moveToProperty Color
color =
  case Color
color of
    Color
Black -> Maybe (Int, Int) -> Property
B
    Color
White -> Maybe (Int, Int) -> Property
W