module Game.Goatee.Lib.Board (
RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode,
gameInfoToProperties,
BoardState(..), boardWidth, boardHeight,
CoordState(..), emptyBoardState, rootBoardState, emptyCoordState, boardCoordState,
boardCoordModify, mapBoardCoords,
isValidMove, isCurrentValidMove,
Cursor, cursorParent, cursorChildIndex, cursorNode, cursorBoard,
rootCursor, cursorRoot, cursorChild, cursorChildren,
cursorChildCount, cursorChildPlayingAt, cursorProperties,
cursorModifyNode,
cursorVariations,
moveToProperty,
) where
import Control.Monad (unless, when)
import Control.Monad.Writer (execWriter, tell)
import Data.List (find, intercalate, nub)
import Data.Maybe (fromMaybe, isJust, isNothing)
import qualified Data.Set as Set
import Game.Goatee.Common
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.Tree
import Game.Goatee.Lib.Types
data RootInfo = RootInfo
{ 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)
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
, :: Maybe Text
, :: 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)
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
}
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
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]
data BoardState = BoardState
{ BoardState -> [[CoordState]]
boardCoordStates :: [[CoordState]]
, BoardState -> Bool
boardHasInvisible :: Bool
, BoardState -> Bool
boardHasDimmed :: Bool
, BoardState -> Bool
boardHasCoordMarks :: Bool
, 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]
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
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
data CoordState = CoordState
{ CoordState -> Bool
coordStar :: Bool
, 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]
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]
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
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
}
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
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
}
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..]
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 }
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 }
boardChild :: BoardState -> Node -> BoardState
boardChild :: BoardState -> Node -> BoardState
boardChild =
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
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 }
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
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 }
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 }
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
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
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)
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)
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
}
data ApplyMoveParams = ApplyMoveParams
{ ApplyMoveParams -> Bool
allowSuicide :: Bool
, ApplyMoveParams -> Bool
allowOverwrite :: Bool
} 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)
standardGoMoveParams :: ApplyMoveParams
standardGoMoveParams :: ApplyMoveParams
standardGoMoveParams = ApplyMoveParams :: Bool -> Bool -> ApplyMoveParams
ApplyMoveParams
{ allowSuicide :: Bool
allowSuicide = Bool
False
, allowOverwrite :: Bool
allowOverwrite = Bool
False
}
playTheDarnMoveGoParams :: ApplyMoveParams
playTheDarnMoveGoParams :: ApplyMoveParams
playTheDarnMoveGoParams = ApplyMoveParams :: Bool -> Bool -> ApplyMoveParams
ApplyMoveParams
{ allowSuicide :: Bool
allowSuicide = Bool
True
, allowOverwrite :: Bool
allowOverwrite = Bool
True
}
data ApplyMoveResult =
ApplyMoveOk BoardState
| ApplyMoveCapture BoardState Color Int
| ApplyMoveSuicideError
| ApplyMoveOverwriteError Color
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
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)
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
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))
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)]
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)
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
isValidMove :: BoardState -> Color -> Coord -> Bool
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)
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)
data Cursor = Cursor
{ Cursor -> Maybe Cursor
cursorParent' :: Maybe Cursor
, Cursor -> Int
cursorChildIndex :: Int
, Cursor -> CursorNode
cursorNode' :: CursorNode
, Cursor -> BoardState
cursorBoard :: BoardState
} 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)
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)
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
UnmodifiedNode Node
_ -> Maybe Cursor
p
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 }
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'
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
}
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
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 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
}
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