diff --git a/goatee.cabal b/goatee.cabal --- a/goatee.cabal +++ b/goatee.cabal @@ -1,5 +1,5 @@ name: goatee -version: 0.1.1 +version: 0.2.0 synopsis: A monadic take on a 2,500-year-old board game - library. category: Game license: AGPL-3 @@ -14,13 +14,11 @@ build-type: Simple data-files: LICENSE description: - Goatee is a Go library and game editor, written in Haskell. It provides a GUI - for recording, studying, and editing game records. Underneath this is a - portable library for manipulating SGF files, to build UIs and tools. - . - Goatee, the library and GUI, aims to be full-featured, supporting all of the SGF - spec and allowing for full customization of the game records you create. - Currently it is in an alpha stage, supporting basic game viewing and editing. + Goatee is a Go library and game editor, written in Haskell. It provides a + GUI for recording, studying, and editing game records. Underneath this is a + portable library for manipulating SGF files to build UIs and tools. Goatee + aims to be full-featured by supporting all of the SGF spec and allowing for + full and easy customization of the game records you create. . This package is the shared library. @@ -34,19 +32,20 @@ containers >= 0.4 && < 0.6, mtl >= 2.1 && < 2.3, parsec >= 3.1 && < 3.2, - template-haskell >= 2.7 && < 2.9 + template-haskell >= 2.7 && < 3.0 exposed-modules: Game.Goatee.App Game.Goatee.Common - Game.Goatee.Sgf.Board - Game.Goatee.Sgf.Monad - Game.Goatee.Sgf.Parser - Game.Goatee.Sgf.Property - Game.Goatee.Sgf.Property.Parser - Game.Goatee.Sgf.Renderer - Game.Goatee.Sgf.Renderer.Tree - Game.Goatee.Sgf.Tree - Game.Goatee.Sgf.Types + Game.Goatee.Common.Bigfloat + Game.Goatee.Lib.Board + Game.Goatee.Lib.Monad + Game.Goatee.Lib.Parser + Game.Goatee.Lib.Property + Game.Goatee.Lib.Property.Parser + Game.Goatee.Lib.Renderer + Game.Goatee.Lib.Renderer.Tree + Game.Goatee.Lib.Tree + Game.Goatee.Lib.Types extensions: ExistentialQuantification FlexibleContexts @@ -57,10 +56,10 @@ ghc-options: -W -fwarn-incomplete-patterns hs-source-dirs: src other-modules: - Game.Goatee.Sgf.Property.Base - Game.Goatee.Sgf.Property.Info - Game.Goatee.Sgf.Property.Renderer - Game.Goatee.Sgf.Property.Value + Game.Goatee.Lib.Property.Base + Game.Goatee.Lib.Property.Info + Game.Goatee.Lib.Property.Renderer + Game.Goatee.Lib.Property.Value Paths_goatee test-suite test-goatee @@ -70,25 +69,24 @@ goatee, HUnit >= 1.2 && < 1.3, mtl >= 2.1 && < 2.3, - parsec >= 3.1 && < 3.2, - test-framework >= 0.6 && < 0.9, - test-framework-hunit >= 0.2 && < 0.4 + parsec >= 3.1 && < 3.2 ghc-options: -W -fwarn-incomplete-patterns hs-source-dirs: tests main-is: Test.hs other-modules: + Game.Goatee.Common.BigfloatTest Game.Goatee.CommonTest - Game.Goatee.Sgf.BoardTest - Game.Goatee.Sgf.MonadTest - Game.Goatee.Sgf.ParserTest - Game.Goatee.Sgf.ParserTestUtils - Game.Goatee.Sgf.Property.ParserTest - Game.Goatee.Sgf.PropertyTest - Game.Goatee.Sgf.RoundTripTest - Game.Goatee.Sgf.TestInstances - Game.Goatee.Sgf.TestUtils - Game.Goatee.Sgf.TreeTest - Game.Goatee.Sgf.TypesTest + Game.Goatee.Lib.BoardTest + Game.Goatee.Lib.MonadTest + Game.Goatee.Lib.ParserTest + Game.Goatee.Lib.ParserTestUtils + Game.Goatee.Lib.Property.ParserTest + Game.Goatee.Lib.PropertyTest + Game.Goatee.Lib.RoundTripTest + Game.Goatee.Lib.TestInstances + Game.Goatee.Lib.TestUtils + Game.Goatee.Lib.TreeTest + Game.Goatee.Lib.TypesTest Game.Goatee.Test.Common Test type: exitcode-stdio-1.0 diff --git a/src/Game/Goatee/Common.hs b/src/Game/Goatee/Common.hs --- a/src/Game/Goatee/Common.hs +++ b/src/Game/Goatee/Common.hs @@ -17,13 +17,10 @@ -- | Common utilities used throughout the project. module Game.Goatee.Common ( - listDeleteIndex, + listDeleteAt, + listInsertAt, listReplace, listUpdate, - fromLeft, - fromRight, - onLeft, - onRight, andEithers, for, mapTuple, @@ -35,19 +32,25 @@ whileM, whileM', doWhileM, - Seq(..), ) where import Control.Arrow ((***)) import Control.Monad (forM_, join, when) import Data.Either (partitionEithers) -import Data.Monoid (Monoid, mempty, mappend) -- | Drops the element at an index from a list. If the index is out of bounds -- then the list is returned unmodified. -listDeleteIndex :: Int -> [a] -> [a] -listDeleteIndex index list = take index list ++ drop (index + 1) list +listDeleteAt :: Int -> [a] -> [a] +listDeleteAt index list = take index list ++ drop (index + 1) list +-- | Inserts the element into the list before the given position. If the +-- position is less than 0 or greater than the length of the list, then the +-- index is clamped to this range. +listInsertAt :: Int -> a -> [a] -> [a] +listInsertAt index x xs = + let (before, after) = splitAt index xs + in before ++ x : after + -- | @listReplace old new list@ replaces all occurrences of @old@ with @new@ in -- @list@. listReplace :: Eq a => a -> a -> [a] -> [a] @@ -62,27 +65,6 @@ listSet' _ _ = error ("Cannot update index " ++ show ix ++ " of list " ++ show xs ++ ".") --- | Extracts a left value from an 'Either'. -fromLeft :: Either a b -> a -fromLeft (Left a) = a -fromLeft _ = error "fromLeft given a Right." - --- | Extracts a right value from an 'Either'. -fromRight :: Either a b -> b -fromRight (Right b) = b -fromRight _ = error "fromRight given a Left." - --- | Transforms the left value of an 'Either', leaving a right value alone. -onLeft :: (a -> c) -> Either a b -> Either c b -f `onLeft` e = case e of - Left x -> Left $ f x - Right y -> Right y - --- | Transforms the right value of an 'Either', leaving a left value alone. --- This is just 'fmap', but looks nicer when used beside 'onLeft'. -onRight :: (b -> c) -> Either a b -> Either a c -onRight = fmap - -- | If any item is a 'Left', then the list of 'Left's is returned, otherwise -- the list of 'Right's is returned. andEithers :: [Either a b] -> Either [a] [b] @@ -148,13 +130,3 @@ case value of Right next -> doWhileM next body Left end -> return end - --- | This sequences @()@-valued monadic actions as a monoid. If @m@ is some --- monad, then @Seq m@ is a monoid where 'mempty' does nothing and 'mappend' --- sequences actions via '>>'. -newtype Seq m = Seq (m ()) - -instance Monad m => Monoid (Seq m) where - mempty = Seq $ return () - - (Seq x) `mappend` (Seq y) = Seq (x >> y) diff --git a/src/Game/Goatee/Common/Bigfloat.hs b/src/Game/Goatee/Common/Bigfloat.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Common/Bigfloat.hs @@ -0,0 +1,183 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Base-10 arbitrary-precision floating-point numbers. +module Game.Goatee.Common.Bigfloat ( + Bigfloat, encode, + significand, exponent, + fromDouble, toDouble, + ) where + +import Data.Char (isDigit, isSpace) +import Data.Function (on) +import Prelude hiding (exponent, significand) + +-- | A base-10, infinite-precision, floating-point number. Implemented as an +-- infinite-precision significand together with an exponent, such that the +-- numeric value is equal to @'significand' f * (10 ^ 'exponent' f)@. The +-- exponent is a limited-precision 'Int', because some operations may break if +-- the exponent is larger (specifically 'show' and 'toDouble'). This shouldn't +-- be an issue for Goatee. +-- +-- These values form an integral domain. +-- +-- The 'Show' instance always outputs in decimal notation, never scientific +-- notation. Examples: +-- +-- > 300 (never trailing .0 if there's no fractional part) +-- > 0.1 (never redundant trailing or leading zeros) +-- +-- Similarly, the 'Read' instance accepts numbers matching the regex +-- @-?\\d+(\\.\\d+)?(e-?\\d+)?@. Scientific exponent notation is supported for +-- reading, for ease of converting 'Double's to 'Bigfloat's. +data Bigfloat = Bigfloat + { significand :: !Integer + , exponent :: !Int + } + +zero, one, negOne :: Bigfloat +zero = Bigfloat 0 0 +one = Bigfloat 1 0 +negOne = Bigfloat (-1) 0 + +instance Eq Bigfloat where + x == y = let (Bigfloat xv xe, Bigfloat yv ye) = normalize2 x y + in xe == ye && xv == yv + +instance Ord Bigfloat where + compare = (uncurry (compare `on` significand) .) . normalize2 + +instance Num Bigfloat where + (+) = lift2 (+) + (-) = lift2 (-) + Bigfloat xv xe * Bigfloat yv ye = reduce $ Bigfloat (xv * yv) (xe + ye) + negate (Bigfloat v e) = Bigfloat (-v) e + abs x@(Bigfloat v e) = if v >= 0 then x else Bigfloat (-v) e + signum (Bigfloat v _) + | v == 0 = zero + | v > 0 = one + | otherwise = negOne + fromInteger v = reduce $ Bigfloat v 0 + +instance Show Bigfloat where + show (Bigfloat v e) = + let (addSign, vs) = if v >= 0 + then (id, show v) + else (('-':), show (-v)) + vl = length vs + in addSign $ case e of + 0 -> vs + e | e > 0 -> vs ++ replicate e '0' + | e <= -vl -> '0' : '.' : replicate ((-e) - vl) '0' ++ vs + _ -> let (hd, tl) = splitAt (vl + e) vs + in hd ++ '.' : tl + +instance Read Bigfloat where + readsPrec _ s = + let (s', neg) = case s of + '-':s' -> (s', True) + _ -> (s, False) + (whole, s'') = span isDigit s' + in if null whole + then [] + else case s'' of + '.':s''' -> let (fractional, s'''') = span isDigit s''' + in if null fractional + then [] + else succeedIfTerminatedProperly neg whole fractional s'''' + s''' -> succeedIfTerminatedProperly neg whole [] s''' + where succeedIfTerminatedProperly neg whole fractional rest = + let makeResult exp = + encode (fromInteger $ + read $ + (if neg then ('-':) else id) $ + whole ++ fractional) + (-length fractional + exp) + in if isValidEndOfNumber rest + then [(makeResult 0, rest)] + else case rest of + 'e':exps -> let (addExpNeg, exps') = case exps of + '-':exps' -> (('-':), exps') + _ -> (id, exps) + (hd, tl) = span isDigit exps' + in if null hd + then [] + else let exp = read (addExpNeg exps') :: Int + in [(makeResult exp, tl) | isValidEndOfNumber tl] + _ -> [] + isValidEndOfNumber rest = case rest of + [] -> True + c:_ | isSpace c -> True + _ -> False + +-- | @encode significand exponent@ creates a 'Bigfloat' value whose numeric +-- value is @significand * (10 ^ exponent)@. +encode :: Integer -> Int -> Bigfloat +encode = (reduce .) . Bigfloat + +-- | Converts a 'Double' to a 'Bigfloat' (with as much precision as the 'Double' +-- 'Show' instance provides). +fromDouble :: Double -> Bigfloat +fromDouble = read . show + +-- | Converts a 'Bigfloat' to a 'Double', lossily. +toDouble :: Bigfloat -> Double +toDouble = read . show + +-- | @shift amount float@ adds @shift@ zeros onto the right side of @float@'s +-- numerator while keeping the numeric value the same. @amount@ must be +-- non-negative. +shift :: Int -> Bigfloat -> Bigfloat +shift amount float@(Bigfloat v e) = + if amount < 0 + then error $ "bigfloatShift: Can't shift by a negative amount. amount = " ++ + show amount ++ ", float = " ++ show float + else Bigfloat (v * 10 ^ amount) (e - amount) + +-- | Reduces a 'Bigfloat' to canonical form, keeping the numeric value the same +-- but removing trailing zeros from the numerator. +reduce :: Bigfloat -> Bigfloat +reduce x@(Bigfloat v e) = + if v == 0 + then zero + else let zeros = length $ takeWhile (== '0') $ reverse $ show v + in if zeros == 0 + then x + else Bigfloat (v `div` (10 ^ zeros)) (e + zeros) + +-- | Converts two 'Bigfloat's so that they have the same number of decimal +-- places, so that 'Integer' arithmetic may be performed directly on their +-- 'significand's. +normalize2 :: Bigfloat -> Bigfloat -> (Bigfloat, Bigfloat) +normalize2 x y = + let xe = exponent x + ye = exponent y + in if xe == ye + then (x, y) + else if xe < ye + then (x, shift (ye - xe) y) + else (shift (xe - ye) x, y) + +-- | Lifts a function on two 'Integer's to a function on 'Bigfloat's. +-- +-- This is not exported from this module because it's not a general lift +-- function: the given function only operates on the significands, so operations +-- that require the exponent (such as multiplication) can't use this function. +lift2 :: (Integer -> Integer -> Integer) -> Bigfloat -> Bigfloat -> Bigfloat +lift2 f x y = + let (Bigfloat xv xe, Bigfloat yv _) = normalize2 x y + in reduce $ Bigfloat (f xv yv) xe diff --git a/src/Game/Goatee/Lib/Board.hs b/src/Game/Goatee/Lib/Board.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Board.hs @@ -0,0 +1,768 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +-- | Data structures that wrap and provide a higher-level interface to the SGF +-- game tree, including a zipper that navigates the tree and provides the +-- current board state. +module Game.Goatee.Lib.Board ( + RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode, + gameInfoToProperties, + BoardState(..), boardWidth, boardHeight, + CoordState(..), rootBoardState, boardCoordState, mapBoardCoords, + isValidMove, isCurrentValidMove, + Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren, + cursorChildCount, cursorChildPlayingAt, cursorProperties, + cursorModifyNode, + cursorVariations, + moveToProperty, + ) where + +import Control.Monad (unless, when) +import Control.Monad.Writer (execWriter, tell) +import Data.List (find, intercalate, nub) +import Data.Maybe (fromMaybe, isJust, isNothing) +import qualified Data.Set as Set +import Game.Goatee.Common +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Tree +import Game.Goatee.Lib.Types + +-- TODO Stop using errors everywhere, they're not testable. + +-- | Properties that are specified in the root nodes of game trees. +data RootInfo = RootInfo + { rootInfoWidth :: Int + , rootInfoHeight :: Int + , rootInfoVariationMode :: VariationMode + } deriving (Eq, Show) + +-- | Properties that are specified in game info nodes. +data GameInfo = GameInfo + { gameInfoRootInfo :: RootInfo + + , gameInfoBlackName :: Maybe SimpleText + , gameInfoBlackTeamName :: Maybe SimpleText + , gameInfoBlackRank :: Maybe SimpleText + + , gameInfoWhiteName :: Maybe SimpleText + , gameInfoWhiteTeamName :: Maybe SimpleText + , gameInfoWhiteRank :: Maybe SimpleText + + , gameInfoRuleset :: Maybe Ruleset + , gameInfoBasicTimeSeconds :: Maybe RealValue + , gameInfoOvertime :: Maybe SimpleText + , gameInfoResult :: Maybe GameResult + + , gameInfoGameName :: Maybe SimpleText + , gameInfoGameComment :: Maybe Text + , gameInfoOpeningComment :: Maybe SimpleText + + , gameInfoEvent :: Maybe SimpleText + , gameInfoRound :: Maybe SimpleText + , gameInfoPlace :: Maybe SimpleText + , gameInfoDatesPlayed :: Maybe SimpleText + , gameInfoSource :: Maybe SimpleText + , gameInfoCopyright :: Maybe SimpleText + + , gameInfoAnnotatorName :: Maybe SimpleText + , gameInfoEntererName :: Maybe SimpleText + } deriving (Show) + +-- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data. +emptyGameInfo :: RootInfo -> GameInfo +emptyGameInfo rootInfo = GameInfo + { gameInfoRootInfo = rootInfo + + , gameInfoBlackName = Nothing + , gameInfoBlackTeamName = Nothing + , gameInfoBlackRank = Nothing + + , gameInfoWhiteName = Nothing + , gameInfoWhiteTeamName = Nothing + , gameInfoWhiteRank = Nothing + + , gameInfoRuleset = Nothing + , gameInfoBasicTimeSeconds = Nothing + , gameInfoOvertime = Nothing + , gameInfoResult = Nothing + + , gameInfoGameName = Nothing + , gameInfoGameComment = Nothing + , gameInfoOpeningComment = Nothing + + , gameInfoEvent = Nothing + , gameInfoRound = Nothing + , gameInfoPlace = Nothing + , gameInfoDatesPlayed = Nothing + , gameInfoSource = Nothing + , gameInfoCopyright = Nothing + + , gameInfoAnnotatorName = Nothing + , gameInfoEntererName = Nothing + } + +-- | Returns whether a node contains any game info properties. +internalIsGameInfoNode :: Node -> Bool +internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties + +-- | Converts a 'GameInfo' into a list of 'Property's that can be used to +-- reconstruct the 'GameInfo'. +gameInfoToProperties :: GameInfo -> [Property] +gameInfoToProperties info = execWriter $ do + copy PB gameInfoBlackName + copy BT gameInfoBlackTeamName + copy BR gameInfoBlackRank + + copy PW gameInfoWhiteName + copy WT gameInfoWhiteTeamName + copy WR gameInfoWhiteRank + + copy RU gameInfoRuleset + copy TM gameInfoBasicTimeSeconds + copy OT gameInfoOvertime + copy RE gameInfoResult + + copy GN gameInfoGameName + copy GC gameInfoGameComment + copy ON gameInfoOpeningComment + + copy EV gameInfoEvent + copy RO gameInfoRound + copy PC gameInfoPlace + copy DT gameInfoDatesPlayed + copy SO gameInfoSource + copy CP gameInfoCopyright + + copy AN gameInfoAnnotatorName + copy US gameInfoEntererName + where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x] + +-- | An object that corresponds to a node in some game tree, and represents the +-- state of the game at that node, including board position, player turn and +-- captures, and also board annotations. +data BoardState = BoardState + { boardCoordStates :: [[CoordState]] + -- ^ The state of individual points on the board. Stored in row-major order. + -- Point @(x, y)@ can be accessed via @!! y !! x@ (but prefer + -- 'boardCoordState'). + , boardHasInvisible :: Bool + -- ^ Whether any of the board's 'CoordState's are invisible. This is an + -- optimization to make it more efficient to set the board to "all visible." + , boardHasDimmed :: Bool + -- ^ Whether any of the board's 'CoordState's are dimmed. This is an + -- optimization to make it more efficient to clear all dimming from the + -- board. + , boardArrows :: ArrowList + , boardLines :: LineList + , boardLabels :: LabelList + , boardMoveNumber :: Integer + , boardPlayerTurn :: Color + , boardBlackCaptures :: Int + , boardWhiteCaptures :: Int + , boardGameInfo :: GameInfo + } + +instance Show BoardState where + show board = concat $ execWriter $ do + tell ["Board: (Move ", show (boardMoveNumber board), + ", ", show (boardPlayerTurn board), "'s turn, B:", + show (boardBlackCaptures board), ", W:", + show (boardWhiteCaptures board), ")\n"] + tell [intercalate "\n" $ flip map (boardCoordStates board) $ + \row -> unwords $ map show row] + + let arrows = boardArrows board + let lines = boardLines board + let labels = boardLabels board + unless (null arrows) $ tell ["\nArrows: ", show arrows] + unless (null lines) $ tell ["\nLines: ", show lines] + unless (null labels) $ tell ["\nLabels: ", show labels] + +-- | Returns the width of the board, in stones. +boardWidth :: BoardState -> Int +boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo + +-- | Returns the height of the board, in stones. +boardHeight :: BoardState -> Int +boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo + +-- | Used by 'BoardState' to represent the state of a single point on the board. +-- Records whether a stone is present, as well as annotations and visibility +-- properties. +data CoordState = CoordState + { coordStar :: Bool + -- ^ Whether this point is a star point. + , coordStone :: Maybe Color + , coordMark :: Maybe Mark + , coordVisible :: Bool + , coordDimmed :: Bool + } + +instance Show CoordState where + show c = if not $ coordVisible c + then "--" + else let stoneChar = case coordStone c of + Nothing -> if coordStar c then '*' else '\'' + Just Black -> 'X' + Just White -> 'O' + markChar = case coordMark c of + Nothing -> ' ' + Just MarkCircle -> 'o' + Just MarkSquare -> 's' + Just MarkTriangle -> 'v' + Just MarkX -> 'x' + Just MarkSelected -> '!' + in [stoneChar, markChar] + +-- | Creates a 'BoardState' for an empty board of the given width and height. +emptyBoardState :: Int -> Int -> BoardState +emptyBoardState width height = BoardState + { boardCoordStates = coords + , boardHasInvisible = False + , boardHasDimmed = False + , boardArrows = [] + , boardLines = [] + , boardLabels = [] + , boardMoveNumber = 0 + , boardPlayerTurn = Black + , boardBlackCaptures = 0 + , boardWhiteCaptures = 0 + , boardGameInfo = emptyGameInfo rootInfo + } + where rootInfo = RootInfo { rootInfoWidth = width + , rootInfoHeight = height + , rootInfoVariationMode = defaultVariationMode + } + emptyCoord = CoordState { coordStar = False + , coordStone = Nothing + , coordMark = Nothing + , coordVisible = True + , coordDimmed = False + } + starCoord = emptyCoord { coordStar = True } + isStarPoint' = isStarPoint width height + coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord) + [0..width-1]) + [0..height-1] + +rootBoardState :: Node -> BoardState +rootBoardState rootNode = + foldr applyProperty + (emptyBoardState width height) + (nodeProperties rootNode) + where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ + findProperty propertySZ rootNode + +-- | Returns the 'CoordState' for a coordinate on a board. +boardCoordState :: Coord -> BoardState -> CoordState +boardCoordState (x, y) board = boardCoordStates board !! y !! x + +-- | Maps a function over each 'CoordState' in a 'BoardState', returning a +-- list-of-lists with the function's values. The function is called like @fn y +-- x coordState@. +mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]] +mapBoardCoords fn board = + zipWith applyRow [0..] $ boardCoordStates board + where applyRow y = zipWith (fn y) [0..] + +-- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a +-- 'BoardState'. +updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState +updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo -> + gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo } + +-- | Applies a function to update the 'GameInfo' of a 'BoardState'. +updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState +updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board } + +-- | Performs necessary updates to a 'BoardState' between nodes in the tree. +-- Clears marks. +boardChild :: BoardState -> BoardState +boardChild board = + board { boardCoordStates = map (map clearMark) $ boardCoordStates board + , boardArrows = [] + , boardLines = [] + , boardLabels = [] + } + where clearMark coord = case coordMark coord of + Nothing -> coord + Just _ -> coord { coordMark = Nothing } + +-- | Sets all points on a board to be visible (if given true) or invisible (if +-- given false). +setBoardVisible :: Bool -> BoardState -> BoardState +setBoardVisible visible board = + if visible + then if boardHasInvisible board + then board { boardCoordStates = map (map $ setVisible True) $ boardCoordStates board + , boardHasInvisible = False + } + else board + else board { boardCoordStates = map (map $ setVisible False) $ boardCoordStates board + , boardHasInvisible = True + } + where setVisible vis coord = coord { coordVisible = vis } + +-- | Resets all points on a board not to be dimmed. +clearBoardDimmed :: BoardState -> BoardState +clearBoardDimmed board = + if boardHasDimmed board + then board { boardCoordStates = map (map clearDim) $ boardCoordStates board + , boardHasDimmed = False + } + else board + where clearDim coord = coord { coordDimmed = False } + +-- | Applies a property to a 'BoardState'. This function covers all properties +-- that modify 'BoardState's, including making moves, adding markup, and so on. +applyProperty :: Property -> BoardState -> BoardState + +applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of + Nothing -> board -- Pass. + Just xy -> getApplyMoveResult board $ + applyMove playTheDarnMoveGoParams Black xy board +applyProperty KO board = board +applyProperty (MN moveNum) board = board { boardMoveNumber = moveNum } +applyProperty (W maybeXy) board = updateBoardForMove White $ case maybeXy of + Nothing -> board -- Pass. + Just xy -> getApplyMoveResult board $ + applyMove playTheDarnMoveGoParams White xy board + +applyProperty (AB coords) board = + updateCoordStates' (\state -> state { coordStone = Just Black }) coords board +applyProperty (AW coords) board = + updateCoordStates' (\state -> state { coordStone = Just White }) coords board +applyProperty (AE coords) board = + updateCoordStates' (\state -> state { coordStone = Nothing }) coords board +applyProperty (PL color) board = board { boardPlayerTurn = color } + +applyProperty (C {}) board = board +applyProperty (DM {}) board = board +applyProperty (GB {}) board = board +applyProperty (GW {}) board = board +applyProperty (HO {}) board = board +applyProperty (N {}) board = board +applyProperty (UC {}) board = board +applyProperty (V {}) board = board + +applyProperty (BM {}) board = board +applyProperty (DO {}) board = board +applyProperty (IT {}) board = board +applyProperty (TE {}) board = board + +applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board } +applyProperty (CR coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board +applyProperty (DD coords) board = + let coords' = expandCoordList coords + board' = clearBoardDimmed board + in if null coords' + then board' + else updateCoordStates (\state -> state { coordDimmed = True }) coords' + board { boardHasDimmed = True } +applyProperty (LB labels) board = board { boardLabels = labels ++ boardLabels board } +applyProperty (LN lines) board = board { boardLines = lines ++ boardLines board } +applyProperty (MA coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords board +applyProperty (SL coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board +applyProperty (SQ coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board +applyProperty (TR coords) board = + updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board + +applyProperty (AP {}) board = board +applyProperty (CA {}) board = board +applyProperty (FF {}) board = board +applyProperty (GM {}) board = board +applyProperty (ST variationMode) board = + updateRootInfo (\info -> info { rootInfoVariationMode = variationMode }) board +applyProperty (SZ {}) board = board + +applyProperty (AN str) board = + updateBoardInfo (\info -> info { gameInfoAnnotatorName = Just str }) board +applyProperty (BR str) board = + updateBoardInfo (\info -> info { gameInfoBlackRank = Just str }) board +applyProperty (BT str) board = + updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just str }) board +applyProperty (CP str) board = + updateBoardInfo (\info -> info { gameInfoCopyright = Just str }) board +applyProperty (DT str) board = + updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just str }) board +applyProperty (EV str) board = + updateBoardInfo (\info -> info { gameInfoEvent = Just str }) board +applyProperty (GC str) board = + updateBoardInfo (\info -> info { gameInfoGameComment = Just str }) board +applyProperty (GN str) board = + updateBoardInfo (\info -> info { gameInfoGameName = Just str }) board +applyProperty (ON str) board = + updateBoardInfo (\info -> info { gameInfoOpeningComment = Just str }) board +applyProperty (OT str) board = + updateBoardInfo (\info -> info { gameInfoOvertime = Just str }) board +applyProperty (PB str) board = + updateBoardInfo (\info -> info { gameInfoBlackName = Just str }) board +applyProperty (PC str) board = + updateBoardInfo (\info -> info { gameInfoPlace = Just str }) board +applyProperty (PW str) board = + updateBoardInfo (\info -> info { gameInfoWhiteName = Just str }) board +applyProperty (RE result) board = + updateBoardInfo (\info -> info { gameInfoResult = Just result }) board +applyProperty (RO str) board = + updateBoardInfo (\info -> info { gameInfoRound = Just str }) board +applyProperty (RU ruleset) board = + updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset }) board +applyProperty (SO str) board = + updateBoardInfo (\info -> info { gameInfoSource = Just str }) board +applyProperty (TM seconds) board = + updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds }) board +applyProperty (US str) board = + updateBoardInfo (\info -> info { gameInfoEntererName = Just str }) board +applyProperty (WR str) board = + updateBoardInfo (\info -> info { gameInfoWhiteRank = Just str }) board +applyProperty (WT str) board = + updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just str }) board + +applyProperty (BL {}) board = board +applyProperty (OB {}) board = board +applyProperty (OW {}) board = board +applyProperty (WL {}) board = board + +applyProperty (VW coords) board = + let coords' = expandCoordList coords + in if null coords' + then setBoardVisible True board + else updateCoordStates (\state -> state { coordVisible = True }) coords' $ + setBoardVisible False board + +applyProperty (HA {}) board = board +applyProperty (KM {}) board = board +applyProperty (TB {}) board = board +applyProperty (TW {}) board = board + +applyProperty (UnknownProperty {}) board = board + +applyProperties :: Node -> BoardState -> BoardState +applyProperties node board = foldr applyProperty board (nodeProperties node) + +-- | Applies the transformation function to all of a board's coordinates +-- referred to by the 'CoordList'. +updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState +updateCoordStates fn coords board = + board { boardCoordStates = foldr applyFn (boardCoordStates board) coords } + where applyFn (x, y) = listUpdate (updateRow x) y + updateRow = listUpdate fn + +updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState +updateCoordStates' fn coords = updateCoordStates fn (expandCoordList coords) + +-- | Updates properties of a 'BoardState' given that the player of the given +-- color has just made a move. Increments the move number and updates the +-- player turn. +updateBoardForMove :: Color -> BoardState -> BoardState +updateBoardForMove movedPlayer board = + board { boardMoveNumber = boardMoveNumber board + 1 + , boardPlayerTurn = cnot movedPlayer + } + +-- | A structure that configures how 'applyMove' should handle moves that are +-- normally illegal in Go. +data ApplyMoveParams = ApplyMoveParams + { allowSuicide :: Bool + -- ^ If false, suicide will cause 'applyMove' to return + -- 'ApplyMoveSuicideError'. If true, suicide will kill the + -- friendly group and give points to the opponent. + , allowOverwrite :: Bool + -- ^ If false, playing on an occupied point will cause + -- 'applyMove' to return 'ApplyMoveOverwriteError' with the + -- color of the stone occupying the point. If true, + -- playing on an occupied point will overwrite the point + -- (the previous stone vanishes), then capture rules are + -- applied as normal. + } deriving (Show) + +-- | As an argument to 'applyMove', causes illegal moves to be treated as +-- errors. +standardGoMoveParams :: ApplyMoveParams +standardGoMoveParams = ApplyMoveParams + { allowSuicide = False + , allowOverwrite = False + } + +-- | As an argument to 'applyMove', causes illegal moves to be played +-- unconditionally. +playTheDarnMoveGoParams :: ApplyMoveParams +playTheDarnMoveGoParams = ApplyMoveParams + { allowSuicide = True + , allowOverwrite = True + } + +-- | The possible results from 'applyMove'. +data ApplyMoveResult = + ApplyMoveOk BoardState + -- ^ The move was accepted; playing it resulted in the given board without + -- capture. + | ApplyMoveCapture BoardState Color Int + -- ^ The move was accepted; playing it resulted in the given board with a + -- capture. The specified side gained the number of points given. + | ApplyMoveSuicideError + -- ^ Playing the move would result in suicide, which is forbidden. + | ApplyMoveOverwriteError Color + -- ^ There is already a stone of the specified color on the target point, + -- and overwriting is forbidden. + +-- | If the 'ApplyMoveResult' represents a successful move, then the resulting +-- 'BoardState' is returned, otherwise, the default 'BoardState' given is +-- returned. +getApplyMoveResult :: BoardState -> ApplyMoveResult -> BoardState +getApplyMoveResult defaultBoard result = fromMaybe defaultBoard $ getApplyMoveResult' result + +getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState +getApplyMoveResult' result = case result of + ApplyMoveOk board -> Just board + ApplyMoveCapture board color points -> Just $ case color of + Black -> board { boardBlackCaptures = boardBlackCaptures board + points } + White -> board { boardWhiteCaptures = boardWhiteCaptures board + points } + ApplyMoveSuicideError -> Nothing + ApplyMoveOverwriteError _ -> Nothing + +-- | Internal data structure, only for move application code. Represents a +-- group of stones. +data ApplyMoveGroup = ApplyMoveGroup + { applyMoveGroupOrigin :: Coord + , applyMoveGroupCoords :: [Coord] + , applyMoveGroupLiberties :: Int + } deriving (Show) + +-- | Places a stone of a color at a point on a board, and runs move validation +-- and capturing logic according to the given parameters. Returns whether the +-- move was successful, and the result if so. +applyMove :: ApplyMoveParams -> Color -> Coord -> BoardState -> ApplyMoveResult +applyMove params color xy board = + let currentStone = coordStone $ boardCoordState xy board + in case currentStone of + Just color -> if allowOverwrite params + then moveResult + else ApplyMoveOverwriteError color + Nothing -> moveResult + where boardWithMove = updateCoordStates (\state -> state { coordStone = Just color }) + [xy] + board + (boardWithCaptures, points) = foldr (maybeCapture $ cnot color) + (boardWithMove, 0) + (adjacentPoints boardWithMove xy) + playedGroup = computeGroup boardWithCaptures xy + moveResult + | applyMoveGroupLiberties playedGroup == 0 = + if points /= 0 + then error "Cannot commit suicide and capture at the same time." + else if allowSuicide params + then let (boardWithSuicide, suicidePoints) = + applyMoveCapture (boardWithCaptures, 0) playedGroup + in ApplyMoveCapture boardWithSuicide (cnot color) suicidePoints + else ApplyMoveSuicideError + | points /= 0 = ApplyMoveCapture boardWithCaptures color points + | otherwise = ApplyMoveOk boardWithCaptures + +-- | Capture if there is a liberty-less group of a color at a point on +-- a board. Removes captured stones from the board and accumulates +-- points for captured stones. +maybeCapture :: Color -> Coord -> (BoardState, Int) -> (BoardState, Int) +maybeCapture color xy result@(board, _) = + if coordStone (boardCoordState xy board) /= Just color + then result + else let group = computeGroup board xy + in if applyMoveGroupLiberties group /= 0 + then result + else applyMoveCapture result group + +computeGroup :: BoardState -> Coord -> ApplyMoveGroup +computeGroup board xy = + if isNothing (coordStone $ boardCoordState xy board) + then error "computeGroup called on an empty point." + else let groupCoords = bucketFill board xy + in ApplyMoveGroup { applyMoveGroupOrigin = xy + , applyMoveGroupCoords = groupCoords + , applyMoveGroupLiberties = getLibertiesOfGroup board groupCoords + } + +applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int) +applyMoveCapture (board, points) group = + (updateCoordStates (\state -> state { coordStone = Nothing }) + (applyMoveGroupCoords group) + board, + points + length (applyMoveGroupCoords group)) + +-- | Returns a list of the four coordinates that are adjacent to the +-- given coordinate on the board, excluding coordinates that are out +-- of bounds. +adjacentPoints :: BoardState -> Coord -> [Coord] +adjacentPoints board (x, y) = execWriter $ do + when (x > 0) $ tell [(x - 1, y)] + when (y > 0) $ tell [(x, y - 1)] + when (x < boardWidth board - 1) $ tell [(x + 1, y)] + when (y < boardHeight board - 1) $ tell [(x, y + 1)] + +-- | Takes a list of coordinates that comprise a group (e.g. a list +-- returned from 'bucketFill') and returns the number of liberties the +-- group has. Does no error checking to ensure that the list refers +-- to a single or maximal group. +getLibertiesOfGroup :: BoardState -> [Coord] -> Int +getLibertiesOfGroup board groupCoords = + length $ nub $ concatMap findLiberties groupCoords + where findLiberties xy = filter (\xy' -> isNothing $ coordStone $ boardCoordState xy' board) + (adjacentPoints board xy) + +-- | Expands a single coordinate on a board into a list of all the +-- coordinates connected to it by some continuous path of stones of +-- the same color (or empty spaces). +bucketFill :: BoardState -> Coord -> [Coord] +bucketFill board xy0 = bucketFill' Set.empty [xy0] + where bucketFill' known [] = Set.toList known + bucketFill' known (xy:xys) = + if Set.member xy known + then bucketFill' known xys + else let new = filter ((stone0 ==) . coordStone . flip boardCoordState board) + (adjacentPoints board xy) + in bucketFill' (Set.insert xy known) (new ++ xys) + stone0 = coordStone $ boardCoordState xy0 board + +-- | Returns whether it is legal to place a stone of the given color at a point +-- on a board. Accepts out-of-bound coordinates and returns false. +isValidMove :: BoardState -> Color -> Coord -> Bool +-- TODO Should out-of-bound coordinates be accepted? +isValidMove board color coord@(x, y) = + let w = boardWidth board + h = boardHeight board + in x >= 0 && y >= 0 && x < w && y < h && + isJust (getApplyMoveResult' $ applyMove standardGoMoveParams color coord board) + +-- | Returns whether it is legal for the current player to place a stone at a +-- point on a board. Accepts out-of-bound coordinates and returns false. +isCurrentValidMove :: BoardState -> Coord -> Bool +isCurrentValidMove board = isValidMove board (boardPlayerTurn board) + +-- | A pointer to a node in a game tree that also holds information +-- about the current state of the game at that node. +data Cursor = Cursor { cursorParent :: Maybe Cursor + -- ^ The cursor 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. + , cursorChildIndex :: Int + -- ^ The index of this cursor's node in its parent's + -- child list. When the cursor's node has no parent, + -- the value in this field is not specified. + , cursorNode :: Node + -- ^ The game tree node about which the cursor stores + -- information. + , cursorBoard :: BoardState + -- ^ The complete board state for the current node. + } deriving (Show) -- TODO Better Show Cursor instance. + +-- | Returns a cursor for a root node. +rootCursor :: Node -> Cursor +rootCursor node = + Cursor { cursorParent = Nothing + , cursorChildIndex = -1 + , cursorNode = node + , cursorBoard = rootBoardState node + } + +cursorRoot :: Cursor -> Cursor +cursorRoot cursor = case cursorParent cursor of + Nothing -> cursor + Just parent -> cursorRoot parent + +cursorChild :: Cursor -> Int -> Cursor +cursorChild cursor index = + Cursor { cursorParent = Just cursor + , cursorChildIndex = index + , cursorNode = child + , cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor + } + -- TODO Better handling or messaging for out-of-bounds: + where child = (!! index) $ nodeChildren $ cursorNode cursor + +cursorChildren :: Cursor -> [Cursor] +cursorChildren cursor = + let board = boardChild $ cursorBoard cursor + in map (\(index, child) -> Cursor { cursorParent = Just cursor + , cursorChildIndex = index + , cursorNode = child + , cursorBoard = applyProperties child board + }) + $ zip [0..] + $ nodeChildren + $ cursorNode cursor + +cursorChildCount :: Cursor -> Int +cursorChildCount = length . nodeChildren . cursorNode + +cursorChildPlayingAt :: Maybe Coord -> Cursor -> Maybe Cursor +cursorChildPlayingAt move cursor = + let children = cursorChildren cursor + color = boardPlayerTurn $ cursorBoard cursor + hasMove = elem $ moveToProperty color move + in find (hasMove . nodeProperties . cursorNode) children + +-- | This is simply @'nodeProperties' . 'cursorNode'@. +cursorProperties :: Cursor -> [Property] +cursorProperties = nodeProperties . cursorNode + +cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor +cursorModifyNode fn cursor = + let node' = fn $ cursorNode cursor + in case cursorParent cursor of + Nothing -> rootCursor node' + Just parentCursor -> + let index = cursorChildIndex cursor + parentCursor' = cursorModifyNode + (\parentNode -> + parentNode { nodeChildren = listUpdate (const node') + index + (nodeChildren parentNode) + }) + parentCursor + in cursorChild parentCursor' index + +-- | Returns the variations to display for a cursor. The returned list contains +-- the location and color of 'B' and 'W' properties in variation nodes. +-- Variation nodes are either children of the current node, or siblings of the +-- current node, depending on the variation mode source. +cursorVariations :: VariationModeSource -> Cursor -> [(Coord, Color)] +cursorVariations source cursor = + case source of + ShowChildVariations -> collectPlays $ nodeChildren $ cursorNode cursor + ShowCurrentVariations -> + case cursorParent cursor of + Nothing -> [] + Just parent -> collectPlays $ listDeleteAt (cursorChildIndex cursor) $ + nodeChildren $ cursorNode parent + where collectPlays :: [Node] -> [(Coord, Color)] + collectPlays = concatMap collectPlays' + collectPlays' = concatMap collectPlays'' . nodeProperties + collectPlays'' prop = case prop of + B (Just xy) -> [(xy, Black)] + W (Just xy) -> [(xy, White)] + _ -> [] + +moveToProperty :: Color -> Maybe Coord -> Property +moveToProperty color = + case color of + Black -> B + White -> W diff --git a/src/Game/Goatee/Lib/Monad.hs b/src/Game/Goatee/Lib/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Monad.hs @@ -0,0 +1,793 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | A monad for working with game trees. +module Game.Goatee.Lib.Monad ( + -- * The Go monad + MonadGo (..), + GoT, GoM, + runGoT, runGo, + evalGoT, evalGo, + execGoT, execGo, + Step (..), + NodeDeleteResult (..), + -- * Event handling + Event, AnyEvent (..), eventName, fire, eventHandlerFromAction, + -- * Events + childAddedEvent, ChildAddedHandler, + childDeletedEvent, ChildDeletedHandler, + gameInfoChangedEvent, GameInfoChangedHandler, + navigationEvent, NavigationHandler, + propertiesModifiedEvent, PropertiesModifiedHandler, + variationModeChangedEvent, VariationModeChangedHandler, + ) where + +import Control.Applicative ((<$>), Applicative ((<*>), pure)) +import Control.Monad (ap, liftM, when) +import Control.Monad.Identity (Identity, runIdentity) +import qualified Control.Monad.State as State +import Control.Monad.State (MonadState, StateT, get, put) +import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) +import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer) +import qualified Data.Function as F +import Data.List (delete, find, mapAccumL, nub, sortBy) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Game.Goatee.Common +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Property +import qualified Game.Goatee.Lib.Tree as Tree +import Game.Goatee.Lib.Tree hiding (addChild, addChildAt) +import Game.Goatee.Lib.Types + +-- | The internal state of a Go monad transformer. @go@ is the type of +-- Go monad or transformer (instance of 'GoMonad'). +data GoState go = GoState + { stateCursor :: Cursor + -- ^ The current position in the game tree. + , statePathStack :: PathStack + -- ^ The current path stack. + + -- Event handlers. + , stateChildAddedHandlers :: [ChildAddedHandler go] + -- ^ Handlers for 'childAddedEvent'. + , stateChildDeletedHandlers :: [ChildDeletedHandler go] + -- ^ Handlers for 'childDeletedEvent'. + , stateGameInfoChangedHandlers :: [GameInfoChangedHandler go] + -- ^ Handlers for 'gameInfoChangedEvent'. + , stateNavigationHandlers :: [NavigationHandler go] + -- ^ Handlers for 'navigationEvent'. + , statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go] + -- ^ Handlers for 'propertiesModifiedEvent'. + , stateVariationModeChangedHandlers :: [VariationModeChangedHandler go] + -- ^ Handlers for 'variationModeChangedEvent'. + } + +-- | A path stack is a record of previous places visited in a game tree. It is +-- encoded a list of paths (steps) to each previous memorized position. +-- +-- The positions saved in calls to 'pushPosition' correspond to entries in the +-- outer list here, with the first sublist representing the last call. The +-- sublist contains the steps in order that will trace the path back to the +-- saved position. +type PathStack = [[Step]] + +-- | A simplified constructor function for 'GoState'. +initialState :: Cursor -> GoState m +initialState cursor = GoState { stateCursor = cursor + , statePathStack = [] + , stateChildAddedHandlers = [] + , stateChildDeletedHandlers = [] + , stateGameInfoChangedHandlers = [] + , stateNavigationHandlers = [] + , statePropertiesModifiedHandlers = [] + , stateVariationModeChangedHandlers = [] + } + +-- | A single step along a game tree. Either up or down. +data Step = + GoUp Int + -- ^ Represents a step up from a child with the given index. + | GoDown Int + -- ^ Represents a step down to the child with the given index. + deriving (Eq, Show) + +-- | Reverses a step, such that taking a step then it's reverse will leave you +-- where you started. +reverseStep :: Step -> Step +reverseStep step = case step of + GoUp index -> GoDown index + GoDown index -> GoUp index + +-- | Takes a 'Step' from a 'Cursor', returning a new 'Cursor'. +takeStep :: Step -> Cursor -> Cursor +takeStep (GoUp _) cursor = fromMaybe (error $ "takeStep: Can't go up from " ++ show cursor ++ ".") $ + cursorParent cursor +takeStep (GoDown index) cursor = cursorChild cursor index + +-- | Internal function. Takes a 'Step' in the Go monad. Updates the path stack +-- accordingly. +takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m () +takeStepM step = case step of + GoUp _ -> goUp' + GoDown index -> goDown' index + +-- | A monad (transformer) for navigating and mutating 'Cursor's, and +-- remembering previous locations. See 'GoT' and 'GoM'. +-- +-- The monad supports handlers for events raised during actions it takes, such +-- as navigating through the tree and modifying nodes. +class (Functor go, Applicative go, Monad go) => MonadGo go where + -- | Returns the current cursor. + getCursor :: go Cursor + + -- | Returns the 'CoordState' at the given point. + getCoordState :: Coord -> go CoordState + getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor + + -- | Navigates up the tree. It must be valid to do so, otherwise 'fail' is + -- called. Fires a 'navigationEvent' after moving. + goUp :: go () + + -- | Navigates down the tree to the child with the given index. The child + -- must exist. Fires a 'navigationEvent' after moving. + goDown :: Int -> go () + + -- | Navigates up to the root of the tree. Fires 'navigationEvent's for each + -- step. + goToRoot :: go () + + -- | Navigates up the tree to the node containing game info properties, if + -- any. Returns true if a game info node was found. + goToGameInfoNode :: Bool + -- ^ When no node with game info is found, then if false, + -- return to the original node, otherwise finish at the + -- root node. + -> go Bool + + -- | Pushes the current location in the game tree onto an internal position + -- stack, such that 'popPosition' is capable of navigating back to the same + -- position, even if the game tree has been modified (though the old position + -- must still exist in the tree to return to it). + pushPosition :: go () + + -- | Returns to the last position pushed onto the internal position stack via + -- 'pushPosition'. This action must be balanced by a 'pushPosition'. + popPosition :: go () + + -- | Drops the last position pushed onto the internal stack by 'pushPosition' + -- off of the stack. This action must be balanced by a 'pushPosition'. + dropPosition :: go () + + -- | Returns the set of properties on the current node. + getProperties :: go [Property] + getProperties = liftM cursorProperties getCursor + + -- | Modifies the set of properties on the current node. + -- + -- The given function must end on the same node on which it started. + modifyProperties :: ([Property] -> go [Property]) -> go () + + -- | Searches for a property on the current node, returning it if found. + getProperty :: Descriptor d => d -> go (Maybe Property) + + -- | Searches for a valued property on the current node, returning its value + -- if found. + getPropertyValue :: ValuedDescriptor d v => d -> go (Maybe v) + getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor + + -- | Sets a property on the current node, replacing an existing property with + -- the same name, if one exists. + putProperty :: Property -> go () + putProperty property = modifyProperty (propertyInfo property) $ const $ Just property + + -- | Deletes a property from the current node, if it's set. + -- + -- Note that although a 'Property' is a 'Descriptor', giving a valued + -- @Property@ here will not cause deletion to match on the value of the + -- property. That is, the following code will result in 'Nothing', because + -- the deletion only cares about the name of the property. + -- + -- > do putProperty $ PL Black + -- > deleteProperty $ PL White + -- > getPropertyValue propertyPL + deleteProperty :: Descriptor d => d -> go () + deleteProperty descriptor = modifyProperty descriptor $ const Nothing + + -- | Calls the given function to modify the state of the given property + -- (descriptor) on the current node. 'Nothing' represents the property not + -- existing on the node, and a 'Just' marks the property's presence. This + -- function does not do any validation to check that the resulting tree state + -- is valid. + modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go () + + -- | Calls the given function to modify the state of the given valued property + -- (descriptor) on the current node. 'Nothing' represents the property not + -- existing on the node, and a 'Just' with the property's value marks the + -- property's presence. This function does not do any validation to check + -- that the resulting tree state is valid. + modifyPropertyValue :: ValuedDescriptor d v => d -> (Maybe v -> Maybe v) -> go () + modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old -> + propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old) + + -- | Mutates the string-valued property attached to the current node according + -- to the given function. The input string will be empty if the current node + -- either has the property with an empty value, or doesn't have the property. + -- Returning an empty string removes the property from the node, if it was + -- set. + modifyPropertyString :: (Stringlike s, ValuedDescriptor d s) => d -> (String -> String) -> go () + modifyPropertyString descriptor fn = + modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of + "" -> Nothing + str -> let sgf = stringToSgf str + -- Because stringToSgf might do processing, we have to check + -- the conversion back to a string for emptiness. + in if null $ sgfToString sgf then Nothing else Just sgf + + -- | Mutates the 'CoordList'-valued property attached to the current node + -- according to the given function. Conversion between @CoordList@ and + -- @[Coord]@ is performed automatically. The input list will be empty if the + -- current node either has the property with an empty value, or doesn't have + -- the property. Returning an empty list removes the property from the node, + -- if it was set. + -- + -- Importantly, this might not be specific enough for properties such as 'DD' + -- and 'VW' where a present, empty list has different semantics from the + -- property not being present. In that case, 'modifyPropertyValue' is better. + modifyPropertyCoords :: ValuedDescriptor d CoordList => d -> ([Coord] -> [Coord]) -> go () + modifyPropertyCoords descriptor fn = + modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of + [] -> Nothing + coords -> Just $ buildCoordList coords + + -- | Mutates the game info for the current path, returning the new info. If + -- the current node or one of its ancestors has game info properties, then + -- that node is modified. Otherwise, properties are inserted on the root + -- node. + modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo + + -- | Sets the game's 'VariationMode' via the 'ST' property on the root node, + -- then fires a 'variationModeChangedEvent' if the variation mode has changed. + modifyVariationMode :: (VariationMode -> VariationMode) -> go () + + -- | Returns the 'Mark' at a point on the current node. + getMark :: Coord -> go (Maybe Mark) + getMark = liftM coordMark . getCoordState + + -- | Calls the given function to modify the presence of a 'Mark' on the + -- current node. + modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go () + modifyMark fn coord = do + maybeOldMark <- getMark coord + case (maybeOldMark, fn maybeOldMark) of + (Just oldMark, Nothing) -> remove oldMark + (Nothing, Just newMark) -> add newMark + (Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark + (Just _, Just _) -> return () + (Nothing, Nothing) -> return () + where remove mark = modifyPropertyCoords (markProperty mark) (delete coord) + add mark = modifyPropertyCoords (markProperty mark) (coord:) + + -- | Adds a child node to the current node at the end of the current node's + -- child list. Fires a 'childAddedEvent' after the child is added. + addChild :: Node -> go () + addChild node = do + childCount <- liftM (length . cursorChildren) getCursor + addChildAt childCount node + + -- | Adds a child node to the current node at the given index, shifting all + -- existing children at and after the index to the right. The index must be + -- in the range @[0, numberOfChildren]@. Fires a 'childAddedEvent' after the + -- child is added. + addChildAt :: Int -> Node -> go () + + -- | Tries to remove the child node at the given index below the current node. + -- Returns a status code indicating whether the deletion succeeded, or why + -- not. + deleteChildAt :: Int -> go NodeDeleteResult + + -- | Registers a new event handler for a given event type. + on :: Event go h -> h -> go () + + -- | Registers a new event handler for a given event type. Unlike 'on', whose + -- handler may receive arguments, the handler given here doesn't receive any + -- arguments. + on0 :: Event go h -> go () -> go () + on0 event handler = on event $ eventHandlerFromAction event handler + +-- | The result of deleting a node. +data NodeDeleteResult = + NodeDeleteOk + -- ^ The node was deleted successfully. + | NodeDeleteBadIndex + -- ^ The node couldn't be deleted, because an invalid index was given. + | NodeDeleteOnPathStack + -- ^ The node couldn't be deleted, because it is on the path stack. + deriving (Bounded, Enum, Eq, Show) + +-- | The standard monad transformer for 'MonadGo'. +newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a } + +-- | The standard monad for 'MonadGo'. +type GoM = GoT Identity + +instance Monad m => Functor (GoT m) where + fmap = liftM + +instance Monad m => Applicative (GoT m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (GoT m) where + return x = GoT $ return x + m >>= f = GoT $ goState . f =<< goState m + fail = lift . fail + +instance MonadTrans GoT where + lift = GoT . lift + +instance MonadIO m => MonadIO (GoT m) where + liftIO = lift . liftIO + +instance MonadState s m => MonadState s (GoT m) where + get = lift get + put = lift . put + +instance MonadWriter w m => MonadWriter w (GoT m) where + writer = lift . writer + tell = lift . tell + listen = GoT . listen . goState + pass = GoT . pass . goState + +-- | Executes a Go monad transformer on a cursor, returning in the underlying +-- monad a tuple that contains the resulting value and the final cursor. +runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor) +runGoT go cursor = do + (value, state) <- State.runStateT (goState go) (initialState cursor) + return (value, stateCursor state) + +-- | Executes a Go monad transformer on a cursor, returning in the underlying +-- monad the value in the transformer. +evalGoT :: Monad m => GoT m a -> Cursor -> m a +evalGoT go cursor = liftM fst $ runGoT go cursor + +-- | Executes a Go monad transformer on a cursor, returning in the underlying +-- monad the final cursor. +execGoT :: Monad m => GoT m a -> Cursor -> m Cursor +execGoT go cursor = liftM snd $ runGoT go cursor + +-- | Runs a Go monad on a cursor. See 'runGoT'. +runGo :: GoM a -> Cursor -> (a, Cursor) +runGo go = runIdentity . runGoT go + +-- | Runs a Go monad on a cursor and returns the value in the monad. +evalGo :: GoM a -> Cursor -> a +evalGo m cursor = fst $ runGo m cursor + +-- | Runs a Go monad on a cursor and returns the final cursor. +execGo :: GoM a -> Cursor -> Cursor +execGo m cursor = snd $ runGo m cursor + +getState :: Monad m => GoT m (GoState (GoT m)) +getState = GoT State.get + +putState :: Monad m => GoState (GoT m) -> GoT m () +putState = GoT . State.put + +modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m () +modifyState = GoT . State.modify + +instance Monad m => MonadGo (GoT m) where + getCursor = liftM stateCursor getState + + -- TODO For goUp and goDown, optimize by seeing checking if (head $ head + -- pathStack) is the step we're taking, and if so, dropping it from the list + -- rather than pushing a fresh step. + goUp = do + index <- liftM cursorChildIndex getCursor + goUp' $ \pathStack -> case pathStack of + [] -> pathStack + path:paths -> (GoDown index:path):paths + + goDown index = goDown' index $ \pathStack -> case pathStack of + [] -> pathStack + path:paths -> (GoUp index:path):paths + + goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp + + goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode + where findGameInfoNode = do + cursor <- getCursor + if hasGameInfo cursor + then dropPosition >> return True + else if isNothing $ cursorParent cursor + then do if goToRootIfNotFound then dropPosition else popPosition + return False + else goUp >> findGameInfoNode + hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor + + pushPosition = modifyState $ \state -> + state { statePathStack = []:statePathStack state } + + popPosition = do + getPathStack >>= \stack -> when (null stack) $ + fail "popPosition: No position to pop from the stack." + + -- Drop each step in the top list of the path stack one at a time, until the + -- top list is empty. + whileM' (do path:_ <- getPathStack + return $ if null path then Nothing else Just $ head path) $ + flip takeStepM $ \((_:steps):paths) -> steps:paths + + -- Finally, drop the empty top of the path stack. + modifyState $ \state -> case statePathStack state of + []:rest -> state { statePathStack = rest } + _ -> error "popPosition: Internal failure, top of path stack is not empty." + + dropPosition = do + state <- getState + -- If there are >=2 positions on the path stack, then we can't simply drop + -- the moves that will return us to the top-of-stack position, because they + -- may still be needed to return to the second-on-stack position by a + -- following popPosition. + case statePathStack state of + x:y:xs -> putState $ state { statePathStack = (x ++ y):xs } + _:[] -> putState $ state { statePathStack = [] } + [] -> fail "dropPosition: No position to drop from the stack." + + modifyProperties fn = do + oldCursor <- getCursor + let oldProperties = cursorProperties oldCursor + newProperties <- fn oldProperties + modifyState $ \state -> + state { stateCursor = cursorModifyNode + (\node -> node { nodeProperties = newProperties }) + oldCursor + } + when (sortBy (compare `F.on` propertyName) newProperties /= + sortBy (compare `F.on` propertyName) oldProperties) $ + fire propertiesModifiedEvent (\f -> f oldProperties newProperties) + + -- The current game info changes when modifying game info properties on the + -- current node. I think comparing game info properties should be faster + -- than comparing 'GameInfo's. + let filterToGameInfo = nub . filter ((GameInfoProperty ==) . propertyType) + oldGameInfo = filterToGameInfo oldProperties + newGameInfo = filterToGameInfo newProperties + when (newGameInfo /= oldGameInfo) $ do + newCursor <- getCursor + fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard oldCursor) + (boardGameInfo $ cursorBoard newCursor)) + + getProperty descriptor = find (propertyPredicate descriptor) <$> getProperties + + modifyProperty descriptor fn = do + cursor <- getCursor + let node = cursorNode cursor + old = findProperty descriptor node + new = fn old + when (maybe False (not . propertyPredicate descriptor) new) $ + fail $ "modifyProperty: May not change property type: " ++ + show old ++ " -> " ++ show new ++ "." + case (old, new) of + (Just _, Nothing) -> modifyProperties $ return . remove descriptor + (Nothing, Just value') -> modifyProperties $ return . add value' + (Just value, Just value') | value /= value' -> + modifyProperties $ return . add value' . remove descriptor + _ -> return () + where remove descriptor = filter (not . propertyPredicate descriptor) + add value = (value:) + + modifyGameInfo fn = do + cursor <- getCursor + let info = boardGameInfo $ cursorBoard cursor + info' = fn info + when (gameInfoRootInfo info /= gameInfoRootInfo info') $ + fail "Illegal modification of root info in modifyGameInfo." + pushPosition + goToGameInfoNode True + modifyProperties $ \props -> + return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props + popPosition + return info' + + modifyVariationMode fn = do + pushPosition + goToRoot + modifyPropertyValue propertyST $ \maybeOld -> + -- If the new variation mode is equal to the old effective variation mode + -- (effective applying the default if the property isn't present), then + -- leave the property unchanged. Otherwise, apply the new variation mode, + -- deleting the property if the default variation mode is selected. We + -- don't delete the property if @maybeOld == Just new == Just + -- defaultVariationMode@, because we don't want to trigger dirtyness + -- unnecessarily. + let old = fromMaybe defaultVariationMode maybeOld + new = fn old + in if new == old + then maybeOld + else if new == defaultVariationMode + then Nothing + else Just new + popPosition + + addChildAt index node = do + cursor <- getCursor + let childCount = cursorChildCount cursor + when (index < 0 || index > childCount) $ fail $ + "Monad.addChildAt: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]." + let cursor' = cursorModifyNode (Tree.addChildAt index node) cursor + modifyState $ \state -> + state { stateCursor = cursor' + , statePathStack = foldPathStack + (\step -> case step of + GoUp n -> GoUp $ if n < index then n else n + 1 + down@(GoDown _) -> down) + (\step -> case step of + up@(GoUp _) -> up + GoDown n -> GoDown $ if n < index then n else n + 1) + id + cursor' + (statePathStack state) + } + fire childAddedEvent ($ index) + + deleteChildAt index = do + childCount <- cursorChildCount <$> getCursor + if index < 0 || index >= childCount + then return NodeDeleteBadIndex + else do goDown index + childCursor <- getCursor + deletingNodeOnPath <- doesPathStackEnterCurrentNode <$> + pure childCursor <*> getPathStack + goUp + if deletingNodeOnPath + then return NodeDeleteOnPathStack + else do cursor <- getCursor + let cursor' = cursorModifyNode (Tree.deleteChildAt index) cursor + modifyState $ \state -> + state { stateCursor = cursor' + , statePathStack = + foldPathStack + (\step -> case step of + GoUp n -> GoUp $ if n < index then n else n - 1 + down@(GoDown _) -> down) + (\step -> case step of + up@(GoUp _) -> up + GoDown n -> GoDown $ if n < index then n else n - 1) + id + cursor' + (statePathStack state) + } + fire childDeletedEvent ($ childCursor) + return NodeDeleteOk + + on event handler = modifyState $ addHandler event handler + +-- | Takes a step up the game tree, updates the path stack according to the +-- given function, then fires navigation and game info changed events as +-- appropriate. +goUp' :: Monad m => (PathStack -> PathStack) -> GoT m () +goUp' pathStackFn = do + state@(GoState { stateCursor = cursor + , statePathStack = pathStack + }) <- getState + case cursorParent cursor of + Nothing -> error $ "goUp': Can't go up from a root cursor: " ++ show cursor + Just parent -> do + let index = cursorChildIndex cursor + putState state { stateCursor = parent + , statePathStack = pathStackFn pathStack + } + fire navigationEvent ($ GoUp index) + + -- The current game info changes when navigating up from a node that has + -- game info properties. + when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $ + fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) + (boardGameInfo $ cursorBoard parent)) + +-- | Takes a step down the game tree, updates the path stack according to the +-- given function, then fires navigation and game info changed events as +-- appropriate. +goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m () +goDown' index pathStackFn = do + state@(GoState { stateCursor = cursor + , statePathStack = pathStack + }) <- getState + case drop index $ cursorChildren cursor of + [] -> error $ "goDown': Cursor does not have a child #" ++ show index ++ ": " ++ show cursor + child:_ -> do + putState state { stateCursor = child + , statePathStack = pathStackFn pathStack + } + fire navigationEvent ($ GoDown index) + + -- The current game info changes when navigating down to a node that has + -- game info properties. + when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $ + fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) + (boardGameInfo $ cursorBoard child)) + +-- | Returns the current path stack. +getPathStack :: Monad m => GoT m PathStack +getPathStack = liftM statePathStack getState + +doesPathStackEnterCurrentNode :: Cursor -> PathStack -> Bool +doesPathStackEnterCurrentNode cursor pathStack = + or $ or <$> foldPathStack (const True) (const False) (const False) cursor pathStack + +-- | Maps over a path stack, updating with the given functions all steps that +-- enter and leave the cursor's current node. +foldPathStack :: (Step -> a) + -> (Step -> a) + -> (Step -> a) + -> Cursor + -> PathStack + -> [[a]] +foldPathStack _ _ _ _ [] = [] +foldPathStack onEnter onExit onOther cursor0 paths = + snd $ mapAccumL updatePath (cursor0, []) paths + where -- updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [a]) + updatePath = mapAccumL updateStep + -- updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), a) + updateStep (cursor, []) step = ((takeStep step cursor, [reverseStep step]), onExit step) + updateStep (cursor, pathToInitial@(stepToInitial:restToInitial)) step = + let pathToInitial' = if stepToInitial == step + then restToInitial + else reverseStep step:pathToInitial + in ((takeStep step cursor, pathToInitial'), + if null pathToInitial' then onEnter step else onOther step) + +-- | Fires all of the handlers for the given event, using the given function to +-- create a Go action from each of the handlers (normally themselves functions +-- that create Go actions, if they're not just Go actions directly, depending on +-- the event). +fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m () +fire event handlerGenerator = do + state <- getState + mapM_ handlerGenerator $ eventStateGetter event state + +-- | A type of event in a Go monad that can be handled by executing an action. +-- @go@ is the type of the Go monad. @h@ is the handler type, a function that +-- takes some arguments relating to the event and returns an action in the Go +-- monad. The arguments to the handler are usually things that would be +-- difficult to recover from the state of the monad alone, for example the +-- 'Step' associated with a 'navigationEvent'. +-- +-- The 'Eq', 'Ord', and 'Show' instances use events' names, via 'eventName'. +data Event go h = Event + { eventName :: String + , eventStateGetter :: GoState go -> [h] + , eventStateSetter :: [h] -> GoState go -> GoState go + , eventHandlerFromAction :: go () -> h + } + +instance Eq (Event go h) where + (==) = (==) `F.on` eventName + +instance Ord (Event go h) where + compare = compare `F.on` eventName + +instance Show (Event go h) where + show = eventName + +-- | An existential type for any event in a particular Go monad. Like 'Event', +-- the 'Eq', 'Ord', and 'Show' instances use events' names, via 'eventName'. +data AnyEvent go = forall h. AnyEvent (Event go h) + +instance Eq (AnyEvent go) where + (AnyEvent e) == (AnyEvent e') = eventName e == eventName e' + +instance Ord (AnyEvent go) where + compare (AnyEvent e) (AnyEvent e') = compare (eventName e) (eventName e') + +instance Show (AnyEvent go) where + show (AnyEvent e) = eventName e + +addHandler :: Event go h -> h -> GoState go -> GoState go +addHandler event handler state = + eventStateSetter event (eventStateGetter event state ++ [handler]) state + +-- | An event corresponding to a child node being added to the current node. +childAddedEvent :: Event go (ChildAddedHandler go) +childAddedEvent = Event + { eventName = "childAddedEvent" + , eventStateGetter = stateChildAddedHandlers + , eventStateSetter = \handlers state -> state { stateChildAddedHandlers = handlers } + , eventHandlerFromAction = const + } + +-- | A handler for 'childAddedEvent's. Called with the index of the child added +-- to the current node. +type ChildAddedHandler go = Int -> go () + +-- | An event corresponding to the deletion of one of the current node's +-- children. +childDeletedEvent :: Event go (ChildDeletedHandler go) +childDeletedEvent = Event + { eventName = "childDeletedEvent" + , eventStateGetter = stateChildDeletedHandlers + , eventStateSetter = \handlers state -> state { stateChildDeletedHandlers = handlers } + , eventHandlerFromAction = const + } + +-- | A handler for 'childDeletedEvent's. It is called with a cursor at the +-- child that was deleted (this cursor is now out of date). +type ChildDeletedHandler go = Cursor -> go () + +-- | An event that is fired when the current game info changes, either by +-- navigating past a node with game info properties, or by modifying the current +-- game info properties. +gameInfoChangedEvent :: Event go (GameInfoChangedHandler go) +gameInfoChangedEvent = Event + { eventName = "gameInfoChangedEvent" + , eventStateGetter = stateGameInfoChangedHandlers + , eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers } + , eventHandlerFromAction = const . const + } + +-- | A handler for 'gameInfoChangedEvent's. It is called with the old game info +-- then the new game info. +type GameInfoChangedHandler go = GameInfo -> GameInfo -> go () + +-- | An event that is fired when a single step up or down in a game tree is +-- made. +navigationEvent :: Event go (NavigationHandler go) +navigationEvent = Event + { eventName = "navigationEvent" + , eventStateGetter = stateNavigationHandlers + , eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers } + , eventHandlerFromAction = const + } + +-- | A handler for 'navigationEvent's. +-- +-- A navigation handler may navigate further, but beware infinite recursion. A +-- navigation handler must end on the same node on which it started. +type NavigationHandler go = Step -> go () + +-- | An event corresponding to a modification to the properties list of the +-- current node. +propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go) +propertiesModifiedEvent = Event + { eventName = "propertiesModifiedEvent" + , eventStateGetter = statePropertiesModifiedHandlers + , eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers } + , eventHandlerFromAction = const . const + } + +-- | A handler for 'propertiesModifiedEvent's. It is called with the old +-- property list then the new property list. +type PropertiesModifiedHandler go = [Property] -> [Property] -> go () + +-- | An event corresponding to a change in the active 'VariationMode'. This can +-- happen when modifying the 'ST' property, and also when navigating between +-- collections (as they have different root nodes). +variationModeChangedEvent :: Event go (VariationModeChangedHandler go) +variationModeChangedEvent = Event + { eventName = "variationModeChangedEvent" + , eventStateGetter = stateVariationModeChangedHandlers + , eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers } + , eventHandlerFromAction = const . const + } +-- TODO Test that this is fired when moving between root nodes in a collection. +-- For now, since we don't support multiple trees in a collection, we don't need +-- to worry about checking for active variation mode change on navigation. + +-- | A handler for 'variationModeChangedEvent's. It is called with the old +-- variation mode then the new variation mode. +type VariationModeChangedHandler go = VariationMode -> VariationMode -> go () diff --git a/src/Game/Goatee/Lib/Parser.hs b/src/Game/Goatee/Lib/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Parser.hs @@ -0,0 +1,129 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | A parser for reading SGF files. +module Game.Goatee.Lib.Parser ( + parseString, + parseFile, + parseSubtree, + propertyParser, + ) where + +import Control.Arrow ((+++)) +import Control.Applicative ((<*), (*>)) +import Data.Maybe (fromMaybe) +import Game.Goatee.Common +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Tree +import Game.Goatee.Lib.Types +import Text.ParserCombinators.Parsec ( + (), Parser, char, eof, many, many1, parse, spaces, upper, + ) + +-- | Parses a string in SGF format. Returns an error string if parsing fails. +parseString :: String -> Either String Collection +parseString str = case parse collectionParser "" str of + Left err -> Left $ show err + Right (Collection roots) -> (concatErrors +++ Collection) $ + andEithers $ + map processRoot roots + where processRoot :: Node -> Either String Node + processRoot = checkFormatVersion . \root -> + let SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ + findProperty propertySZ root + in postProcessTree width height root + + concatErrors errs = "The following errors occurred while parsing:" ++ + concatMap ("\n-> " ++) errs + +-- | Parses a file in SGF format. Returns an error string if parsing fails. +parseFile :: String -> IO (Either String Collection) +parseFile = fmap parseString . readFile + +-- | Parses a node as part of an existing game tree, from textual SGF +-- \"GameTree\" syntax. The 'RootInfo' is needed to supply necessary +-- information from the existing game tree. +parseSubtree :: RootInfo -> String -> Either String Node +parseSubtree rootInfo str = + case parse (spaces *> gameTreeParser <* spaces) "" str of + Left err -> Left $ show err + Right node -> + let width = rootInfoWidth rootInfo + height = rootInfoHeight rootInfo + in Right $ postProcessTree width height node + +-- Ensures that we are parsing an SGF version that we understand. +-- TODO Try to proceed, if it makes sense. +checkFormatVersion :: Node -> Either String Node +checkFormatVersion root = + let version = case findProperty propertyFF root of + Nothing -> defaultFormatVersion + Just (FF x) -> x + x -> error $ "Expected FF or nothing, received " ++ show x ++ "." + in if version `elem` supportedFormatVersions + then Right root + else Left $ + "Unsupported SGF version " ++ show version ++ ". Only versions " ++ + show supportedFormatVersions ++ " are supported." + +postProcessTree :: Int -> Int -> Node -> Node +postProcessTree width height node = + -- SGF allows B[tt] and W[tt] to represent passes on boards <=19x19. + -- Convert any passes from this format to B[] and W[] in a root node and + -- its descendents. + if width <= 19 && height <= 19 then convertNodeTtToPass node else node + +convertNodeTtToPass :: Node -> Node +convertNodeTtToPass node = + node { nodeProperties = map convertPropertyTtToPass $ nodeProperties node + , nodeChildren = map convertNodeTtToPass $ nodeChildren node + } + +convertPropertyTtToPass :: Property -> Property +convertPropertyTtToPass prop = case prop of + B (Just (19, 19)) -> B Nothing + W (Just (19, 19)) -> W Nothing + _ -> prop + +collectionParser :: Parser Collection +collectionParser = + fmap Collection (spaces *> many (gameTreeParser <* spaces) <* eof) + "collection" + +gameTreeParser :: Parser Node +gameTreeParser = do + char '(' + nodes <- spaces *> many1 (nodeParser <* spaces) "sequence" + subtrees <- many (gameTreeParser <* spaces) "subtrees" + char ')' + let (sequence, [final]) = splitAt (length nodes - 1) nodes + return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] }) + (final { nodeChildren = subtrees }) + sequence + +nodeParser :: Parser Node +nodeParser = + fmap (\props -> emptyNode { nodeProperties = props }) + (char ';' *> spaces *> many (propertyParser <* spaces) + "node") + +propertyParser :: Parser Property +propertyParser = do + name <- many1 upper + spaces + propertyValueParser $ descriptorForName name diff --git a/src/Game/Goatee/Lib/Property.hs b/src/Game/Goatee/Lib/Property.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Property.hs @@ -0,0 +1,28 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Structures and functions for working with SGF node properties. +module Game.Goatee.Lib.Property ( + module Exported, + PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, + ) where + +import Game.Goatee.Lib.Property.Base as Exported +import Game.Goatee.Lib.Property.Info as Exported +import Game.Goatee.Lib.Property.Parser as Exported +import Game.Goatee.Lib.Property.Renderer as Exported +import Game.Goatee.Lib.Property.Value diff --git a/src/Game/Goatee/Lib/Property/Base.hs b/src/Game/Goatee/Lib/Property/Base.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Property/Base.hs @@ -0,0 +1,327 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Core property-related data types, and some Template Haskell declarations +-- for defining property metadata. +-- +-- Import "Game.Goatee.Lib.Property" rather than importing this module. +module Game.Goatee.Lib.Property.Base ( + -- * Properties + Property (..), + -- * Property metadata + PropertyType (..), + Descriptor (..), + SomeDescriptor (..), + ValuedDescriptor (..), + PropertyInfo, + ValuedPropertyInfo (ValuedPropertyInfo), + -- * Property declaration + defProperty, defValuedProperty, + ) where + +import Control.Applicative ((<$)) +import Game.Goatee.Lib.Property.Value (PropertyValueType(..), nonePvt) +import Game.Goatee.Lib.Renderer +import Game.Goatee.Lib.Types +import Language.Haskell.TH ( + Info (DataConI), DecsQ, Name, Type (AppT), + appE, appT, caseE, conE, conP, conT, lam1E, match, mkName, newName, + normalB, recP, reify, sigD, stringE, valD, varE, varP, wildP, + ) +import Text.ParserCombinators.Parsec (Parser) + +-- | An SGF property that gives a node meaning. +data Property = + -- Move properties. + B (Maybe Coord) -- ^ Black move (nothing iff pass). + | KO -- ^ Execute move unconditionally (even if illegal). + | MN Integer -- ^ Assign move number. + | W (Maybe Coord) -- ^ White move (nothing iff pass). + + -- Setup properties. + | AB CoordList -- ^ Assign black stones. + | AE CoordList -- ^ Assign empty stones. + | AW CoordList -- ^ Assign white stones. + | PL Color -- ^ Player to play. + + -- Node annotation properties. + | C Text -- ^ Comment. + | DM DoubleValue -- ^ Even position. + | GB DoubleValue -- ^ Good for black. + | GW DoubleValue -- ^ Good for white. + | HO DoubleValue -- ^ Hotspot. + | N SimpleText -- ^ Node name. + | UC DoubleValue -- ^ Unclear position. + | V RealValue -- ^ Node value. + + -- Move annotation properties. + | BM DoubleValue -- ^ Bad move. + | DO -- ^ Doubtful move. + | IT -- ^ Interesting move. + | TE DoubleValue -- ^ Tesuji. + + -- Markup properties. + | AR ArrowList -- ^ Arrows. + | CR CoordList -- ^ Mark points with circles. + | DD CoordList -- ^ Dim points. + | LB LabelList -- ^ Label points with text. + | LN LineList -- ^ Lines. + | MA CoordList -- ^ Mark points with 'X's. + | SL CoordList -- ^ Mark points as selected. + | SQ CoordList -- ^ Mark points with squares. + | TR CoordList -- ^ Mark points with trianges. + + -- Root properties. + | AP SimpleText SimpleText -- ^ Application info. + | CA SimpleText -- ^ Charset for SimpleText and Text. + | FF Int -- ^ File format version. + | GM Int -- ^ Game (must be 1 = Go). + | ST VariationMode -- ^ Variation display format. + | SZ Int Int -- ^ Board size, columns then rows. + + -- Game info properties. + | AN SimpleText -- ^ Name of annotator. + | BR SimpleText -- ^ Rank of black player. + | BT SimpleText -- ^ Name of black team. + | CP SimpleText -- ^ Copyright info. + | DT SimpleText -- ^ Dates played. + | EV SimpleText -- ^ Event name. + | GC Text -- ^ Game comment, or background, or summary. + | GN SimpleText -- ^ Game name. + | ON SimpleText -- ^ Information about the opening. + | OT SimpleText -- ^ The method used for overtime. + | PB SimpleText -- ^ Name of black player. + | PC SimpleText -- ^ Where the game was played. + | PW SimpleText -- ^ Name of white player. + | RE GameResult -- ^ Result of the game. + | RO SimpleText -- ^ Round info. + | RU Ruleset -- ^ Ruleset used. + | SO SimpleText -- ^ Source of the game. + | TM RealValue -- ^ Time limit, in seconds. + | US SimpleText -- ^ Name of user or program who entered the game. + | WR SimpleText -- ^ Rank of white player. + | WT SimpleText -- ^ Name of white team. + + -- Timing properties. + | BL RealValue -- ^ Black time left. + | OB Int -- ^ Black moves left in byo-yomi period. + | OW Int -- ^ White moves left in byo-yomi period. + | WL RealValue -- ^ White time left. + + -- Miscellaneous properties. + -- TODO FG property. + -- TODO PM property. + | VW CoordList -- ^ Set viewing region. + + -- Go-specific properties. + | HA Int -- ^ Handicap stones (>=2). + | KM RealValue -- ^ Komi. + | TB CoordList -- ^ Black territory. + | TW CoordList -- ^ White territory. + + | UnknownProperty String UnknownPropertyValue + + -- TODO Game info, timing, and miscellaneous properties. + -- Also in functions below. + deriving (Eq, Show) + +-- | The property types that SGF uses to group properties. +data PropertyType = MoveProperty -- ^ Cannot mix with setup nodes. + | SetupProperty -- ^ Cannot mix with move nodes. + | RootProperty -- ^ May only appear in root nodes. + | GameInfoProperty -- ^ At most one on any path. + | GeneralProperty -- ^ May appear anywhere in the game tree. + deriving (Eq, Show) + +-- | A class for types that contain metadata about a 'Property'. +class Descriptor a where + -- | Returns the name of the property, as used in SGF files. + propertyName :: a -> String + + -- | Returns the type of the property, as specified by the SGF spec. + propertyType :: a -> PropertyType + + -- | Returns whether the value of the given property is inherited from the + -- lowest ancestor specifying the property, when the property is not set on a + -- node itself. + propertyInherited :: a -> Bool + + -- | Returns whether the given property has the type of a descriptor. + propertyPredicate :: a -> Property -> Bool + + -- | A parser of property values in SGF format (e.g. @"[ab]"@ for a property + -- that takes a point). + propertyValueParser :: a -> Parser Property + + -- | A renderer property values to SGF format (e.g. @B (Just (1,2))@ renders + -- to @"[ab]"@). + propertyValueRenderer :: a -> Property -> Render () + + -- | A renderer for displaying property values in a UI. Displays the value in + -- a human-readable format. + propertyValueRendererPretty :: a -> Property -> Render () + +data SomeDescriptor = forall a. Descriptor a => SomeDescriptor a + +instance Descriptor SomeDescriptor where + propertyName (SomeDescriptor d) = propertyName d + propertyType (SomeDescriptor d) = propertyType d + propertyInherited (SomeDescriptor d) = propertyInherited d + propertyPredicate (SomeDescriptor d) = propertyPredicate d + propertyValueParser (SomeDescriptor d) = propertyValueParser d + propertyValueRenderer (SomeDescriptor d) = propertyValueRenderer d + propertyValueRendererPretty (SomeDescriptor d) = propertyValueRendererPretty d + +-- | A class for 'Descriptor's of 'Property's that also contain values. +class (Descriptor a, Eq v) => ValuedDescriptor a v | a -> v where + -- | Extracts the value from a property of the given type. Behaviour is + -- undefined if the property is not of the given type. + propertyValue :: a -> Property -> v + + -- | Builds a property from a given value. + propertyBuilder :: a -> v -> Property + +-- | Metadata for a property that does not contain a value. Corresponds to a +-- single nullary data constructor of 'Property'. +data PropertyInfo = PropertyInfo + { propertyInfoName :: String + -- ^ The SGF textual name for the property. + , propertyInfoInstance :: Property + -- ^ The single instance of the property. + , propertyInfoType :: PropertyType + -- ^ The SGF property type. + , propertyInfoInherited :: Bool + -- ^ Whether the property is inherited. + } + +instance Descriptor PropertyInfo where + propertyName = propertyInfoName + propertyType = propertyInfoType + propertyInherited = propertyInfoInherited + propertyPredicate = (==) . propertyInfoInstance + propertyValueParser descriptor = propertyInfoInstance descriptor <$ pvtParser nonePvt + propertyValueRenderer _ _ = pvtRenderer nonePvt () + propertyValueRendererPretty _ _ = pvtRendererPretty nonePvt () + +-- | Metadata for a property that contains a value. Corresponds to a single +-- unary data constructor of 'Property'. +data ValuedPropertyInfo v = ValuedPropertyInfo + { valuedPropertyInfoName :: String + -- ^ The SGF textual name for the property (also the name of the data + -- constructor). + , valuedPropertyInfoType :: PropertyType + -- ^ The SGF property type. + , valuedPropertyInfoInherited :: Bool + -- ^ Whether the property is inherited. + , valuedPropertyInfoPredicate :: Property -> Bool + -- ^ A predicate that matches predicates to which this 'ValuedPropertyInfo' + -- applies. + , valuedPropertyInfoValueType :: PropertyValueType v + -- ^ Metadata about the type of the property's value. + , valuedPropertyInfoValue :: Property -> v + -- ^ A function that extracts values from properties to which this + -- 'ValuedPropertyInfo' applies. It is invalid to call this function with a + -- different type of property. + , valuedPropertyInfoBuilder :: v -> Property + -- ^ A function that builds a property containing a value. + } + +instance Descriptor (ValuedPropertyInfo v) where + propertyName = valuedPropertyInfoName + propertyType = valuedPropertyInfoType + propertyInherited = valuedPropertyInfoInherited + propertyPredicate = valuedPropertyInfoPredicate + propertyValueParser descriptor = + fmap (valuedPropertyInfoBuilder descriptor) $ + pvtParser $ + valuedPropertyInfoValueType descriptor + propertyValueRenderer descriptor property = + pvtRenderer (valuedPropertyInfoValueType descriptor) $ + valuedPropertyInfoValue descriptor property + propertyValueRendererPretty descriptor property = + pvtRendererPretty (valuedPropertyInfoValueType descriptor) $ + valuedPropertyInfoValue descriptor property + +instance Eq v => ValuedDescriptor (ValuedPropertyInfo v) v where + propertyValue = valuedPropertyInfoValue + propertyBuilder = valuedPropertyInfoBuilder + +-- | Template Haskell function to declare a property that does not contain a +-- value. +-- +-- > $(defProperty "KO" 'MoveProperty False) +-- +-- This example declares a @propertyKO :: 'PropertyInfo'@ that is a +-- 'MoveProperty' and is not inherited. +defProperty :: String + -- ^ The SGF textual name of the property. + -> Name + -- ^ The name of the 'PropertyType'. + -> Bool + -- ^ Whether the property is inherited. + -> DecsQ +defProperty name propType inherited = do + let propName = mkName name + varName = mkName $ "property" ++ name + sequence [ + sigD varName $ conT $ mkName "PropertyInfo", + valD (varP varName) + (normalB [| PropertyInfo name $(conE propName) $(conE propType) inherited |]) + [] + ] + +-- | Template Haskell function to declare a property that contains a value. +-- +-- > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter) +-- +-- This example declares a @propertyB :: 'ValuedPropertyInfo' (Maybe 'Coord')@ +-- that is a 'MoveProperty' and is not inherited. The value type is +-- automatically inferred. +defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ +defValuedProperty name propType inherited valueType = do + let propName = mkName name + varName = mkName $ "property" ++ name + foo <- newName "foo" + bar <- newName "bar" + DataConI _ (AppT (AppT _ haskellValueType) _) _ _ <- reify propName + sequence [ + sigD varName $ appT (conT ''ValuedPropertyInfo) $ return haskellValueType, + valD (varP varName) + (normalB [| ValuedPropertyInfo + name + $(conE propType) + inherited + $(lam1E (varP foo) $ caseE (varE foo) + [match (recP propName []) + (normalB $ conE $ mkName "True") + [], + match wildP (normalB $ conE $ mkName "False") []]) + $(varE valueType) + $(lam1E (varP foo) $ caseE (varE foo) + [match (conP propName [varP bar]) (normalB $ varE bar) [], + match wildP + (normalB + [| error $ "Property value getter for " ++ $(stringE name) ++ + " applied to " ++ show $(varE foo) ++ "." |]) + []]) + $(lam1E (varP foo) $ appE (conE propName) (varE foo)) + |]) + [] + ] diff --git a/src/Game/Goatee/Lib/Property/Info.hs b/src/Game/Goatee/Lib/Property/Info.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Property/Info.hs @@ -0,0 +1,320 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Property metadata declarations. +-- +-- Import "Game.Goatee.Lib.Property" rather than importing this module. +module Game.Goatee.Lib.Property.Info where + +import Control.Arrow ((&&&)) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Game.Goatee.Lib.Property.Base +import Game.Goatee.Lib.Property.Value +import Game.Goatee.Lib.Types + +-- Move properties. +$(defValuedProperty "B" 'MoveProperty False 'movePvt) +$(defProperty "KO" 'MoveProperty False) +$(defValuedProperty "MN" 'MoveProperty False 'integralPvt) +$(defValuedProperty "W" 'MoveProperty False 'movePvt) + +-- Setup properties. +$(defValuedProperty "AB" 'SetupProperty False 'coordListPvt) +$(defValuedProperty "AE" 'SetupProperty False 'coordListPvt) +$(defValuedProperty "AW" 'SetupProperty False 'coordListPvt) +$(defValuedProperty "PL" 'SetupProperty False 'colorPvt) + +-- Node annotation properties. +$(defValuedProperty "C" 'GeneralProperty False 'textPvt) +$(defValuedProperty "DM" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "GB" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "GW" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "HO" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "N" 'GeneralProperty False 'simpleTextPvt) +$(defValuedProperty "UC" 'GeneralProperty False 'doublePvt) +$(defValuedProperty "V" 'GeneralProperty False 'realPvt) + +-- Move annotation properties. +$(defValuedProperty "BM" 'MoveProperty False 'doublePvt) +$(defProperty "DO" 'MoveProperty False) +$(defProperty "IT" 'MoveProperty False) +$(defValuedProperty "TE" 'MoveProperty False 'doublePvt) + +-- Markup properties. +$(defValuedProperty "AR" 'GeneralProperty False 'coordPairListPvt) +$(defValuedProperty "CR" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "DD" 'GeneralProperty True 'coordListPvt) +$(defValuedProperty "LB" 'GeneralProperty False 'labelListPvt) +$(defValuedProperty "LN" 'GeneralProperty False 'coordPairListPvt) +$(defValuedProperty "MA" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "SL" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "SQ" 'GeneralProperty False 'coordListPvt) +$(defValuedProperty "TR" 'GeneralProperty False 'coordListPvt) + +-- Root properties. +propertyAP :: ValuedPropertyInfo (SimpleText, SimpleText) +propertyAP = ValuedPropertyInfo "AP" RootProperty False + (\x -> case x of { AP {} -> True; _ -> False }) + simpleTextPairPvt + (\(AP x y) -> (x, y)) + (uncurry AP) +$(defValuedProperty "CA" 'RootProperty False 'simpleTextPvt) +$(defValuedProperty "FF" 'RootProperty False 'integralPvt) -- TODO Add parser validation. +$(defValuedProperty "GM" 'RootProperty False 'integralPvt) -- TODO Add parser validation. +$(defValuedProperty "ST" 'RootProperty False 'variationModePvt) +propertySZ :: ValuedPropertyInfo (Int, Int) +propertySZ = ValuedPropertyInfo "SZ" RootProperty False + (\x -> case x of { SZ {} -> True; _ -> False }) + sizePvt + (\(SZ x y) -> (x, y)) + (uncurry SZ) + +-- Game info properties. +$(defValuedProperty "AN" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "BR" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "BT" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "CP" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "DT" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "EV" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "GC" 'GameInfoProperty False 'textPvt) +$(defValuedProperty "GN" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "ON" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "OT" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "PB" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "PC" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "PW" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "RE" 'GameInfoProperty False 'gameResultPvt) +$(defValuedProperty "RO" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "RU" 'GameInfoProperty False 'rulesetPvt) +$(defValuedProperty "SO" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "TM" 'GameInfoProperty False 'realPvt) +$(defValuedProperty "US" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "WR" 'GameInfoProperty False 'simpleTextPvt) +$(defValuedProperty "WT" 'GameInfoProperty False 'simpleTextPvt) + +-- Timing properties. +$(defValuedProperty "BL" 'MoveProperty False 'realPvt) +$(defValuedProperty "OB" 'MoveProperty False 'integralPvt) +$(defValuedProperty "OW" 'MoveProperty False 'integralPvt) +$(defValuedProperty "WL" 'MoveProperty False 'realPvt) + +-- Miscellaneous properties. +$(defValuedProperty "VW" 'GeneralProperty True 'coordElistPvt) + +-- Go-specific properties. +$(defValuedProperty "HA" 'GameInfoProperty False 'integralPvt) +$(defValuedProperty "KM" 'GameInfoProperty False 'realPvt) +$(defValuedProperty "TB" 'GeneralProperty False 'coordElistPvt) +$(defValuedProperty "TW" 'GeneralProperty False 'coordElistPvt) + +propertyUnknown :: String -> ValuedPropertyInfo UnknownPropertyValue +propertyUnknown name = + ValuedPropertyInfo name GeneralProperty False + (\x -> case x of + UnknownProperty name' _ | name' == name -> True + _ -> False) + unknownPropertyPvt + (\(UnknownProperty _ value) -> value) + (UnknownProperty name) + +allDescriptors :: [SomeDescriptor] +allDescriptors = + [ SomeDescriptor propertyB + , SomeDescriptor propertyKO + , SomeDescriptor propertyMN + , SomeDescriptor propertyW + + , SomeDescriptor propertyAB + , SomeDescriptor propertyAE + , SomeDescriptor propertyAW + , SomeDescriptor propertyPL + + , SomeDescriptor propertyC + , SomeDescriptor propertyDM + , SomeDescriptor propertyGB + , SomeDescriptor propertyGW + , SomeDescriptor propertyHO + , SomeDescriptor propertyN + , SomeDescriptor propertyUC + , SomeDescriptor propertyV + + , SomeDescriptor propertyBM + , SomeDescriptor propertyDO + , SomeDescriptor propertyIT + , SomeDescriptor propertyTE + + , SomeDescriptor propertyAR + , SomeDescriptor propertyCR + , SomeDescriptor propertyDD + , SomeDescriptor propertyLB + , SomeDescriptor propertyLN + , SomeDescriptor propertyMA + , SomeDescriptor propertySL + , SomeDescriptor propertySQ + , SomeDescriptor propertyTR + + , SomeDescriptor propertyAP + , SomeDescriptor propertyCA + , SomeDescriptor propertyFF + , SomeDescriptor propertyGM + , SomeDescriptor propertyST + , SomeDescriptor propertySZ + + , SomeDescriptor propertyAN + , SomeDescriptor propertyBR + , SomeDescriptor propertyBT + , SomeDescriptor propertyCP + , SomeDescriptor propertyDT + , SomeDescriptor propertyEV + , SomeDescriptor propertyGC + , SomeDescriptor propertyGN + , SomeDescriptor propertyON + , SomeDescriptor propertyOT + , SomeDescriptor propertyPB + , SomeDescriptor propertyPC + , SomeDescriptor propertyPW + , SomeDescriptor propertyRE + , SomeDescriptor propertyRO + , SomeDescriptor propertyRU + , SomeDescriptor propertySO + , SomeDescriptor propertyTM + , SomeDescriptor propertyUS + , SomeDescriptor propertyWR + , SomeDescriptor propertyWT + + , SomeDescriptor propertyBL + , SomeDescriptor propertyOB + , SomeDescriptor propertyOW + , SomeDescriptor propertyWL + + , SomeDescriptor propertyVW + + , SomeDescriptor propertyHA + , SomeDescriptor propertyKM + , SomeDescriptor propertyTB + , SomeDescriptor propertyTW + ] + +propertyInfo :: Property -> SomeDescriptor +propertyInfo property = case property of + B {} -> SomeDescriptor propertyB + KO {} -> SomeDescriptor propertyKO + MN {} -> SomeDescriptor propertyMN + W {} -> SomeDescriptor propertyW + + AB {} -> SomeDescriptor propertyAB + AE {} -> SomeDescriptor propertyAE + AW {} -> SomeDescriptor propertyAW + PL {} -> SomeDescriptor propertyPL + + C {} -> SomeDescriptor propertyC + DM {} -> SomeDescriptor propertyDM + GB {} -> SomeDescriptor propertyGB + GW {} -> SomeDescriptor propertyGW + HO {} -> SomeDescriptor propertyHO + N {} -> SomeDescriptor propertyN + UC {} -> SomeDescriptor propertyUC + V {} -> SomeDescriptor propertyV + + BM {} -> SomeDescriptor propertyBM + DO {} -> SomeDescriptor propertyDO + IT {} -> SomeDescriptor propertyIT + TE {} -> SomeDescriptor propertyTE + + AR {} -> SomeDescriptor propertyAR + CR {} -> SomeDescriptor propertyCR + DD {} -> SomeDescriptor propertyDD + LB {} -> SomeDescriptor propertyLB + LN {} -> SomeDescriptor propertyLN + MA {} -> SomeDescriptor propertyMA + SL {} -> SomeDescriptor propertySL + SQ {} -> SomeDescriptor propertySQ + TR {} -> SomeDescriptor propertyTR + + AP {} -> SomeDescriptor propertyAP + CA {} -> SomeDescriptor propertyCA + FF {} -> SomeDescriptor propertyFF + GM {} -> SomeDescriptor propertyGM + ST {} -> SomeDescriptor propertyST + SZ {} -> SomeDescriptor propertySZ + + AN {} -> SomeDescriptor propertyAN + BR {} -> SomeDescriptor propertyBR + BT {} -> SomeDescriptor propertyBT + CP {} -> SomeDescriptor propertyCP + DT {} -> SomeDescriptor propertyDT + EV {} -> SomeDescriptor propertyEV + GC {} -> SomeDescriptor propertyGC + GN {} -> SomeDescriptor propertyGN + ON {} -> SomeDescriptor propertyON + OT {} -> SomeDescriptor propertyOT + PB {} -> SomeDescriptor propertyPB + PC {} -> SomeDescriptor propertyPC + PW {} -> SomeDescriptor propertyPW + RE {} -> SomeDescriptor propertyRE + RO {} -> SomeDescriptor propertyRO + RU {} -> SomeDescriptor propertyRU + SO {} -> SomeDescriptor propertySO + TM {} -> SomeDescriptor propertyTM + US {} -> SomeDescriptor propertyUS + WR {} -> SomeDescriptor propertyWR + WT {} -> SomeDescriptor propertyWT + + BL {} -> SomeDescriptor propertyBL + OB {} -> SomeDescriptor propertyOB + OW {} -> SomeDescriptor propertyOW + WL {} -> SomeDescriptor propertyWL + + VW {} -> SomeDescriptor propertyVW + + HA {} -> SomeDescriptor propertyHA + KM {} -> SomeDescriptor propertyKM + TB {} -> SomeDescriptor propertyTB + TW {} -> SomeDescriptor propertyTW + + UnknownProperty name _ -> SomeDescriptor $ propertyUnknown name + +instance Descriptor Property where + propertyName = propertyName . propertyInfo + propertyType = propertyType . propertyInfo + propertyInherited = propertyInherited . propertyInfo + propertyPredicate = propertyPredicate . propertyInfo + propertyValueParser = propertyValueParser . propertyInfo + propertyValueRenderer = propertyValueRenderer . propertyInfo + propertyValueRendererPretty = propertyValueRendererPretty . propertyInfo + +descriptorsByName :: Map String SomeDescriptor +descriptorsByName = Map.fromList $ map (propertyName &&& id) allDescriptors + +descriptorForName :: String -> SomeDescriptor +descriptorForName name = fromMaybe (SomeDescriptor $ propertyUnknown name) $ descriptorForName' name + +descriptorForName' :: String -> Maybe SomeDescriptor +descriptorForName' = flip Map.lookup descriptorsByName + +-- | Returns the descriptor for a mark. +markProperty :: Mark -> ValuedPropertyInfo CoordList +markProperty MarkCircle = propertyCR +markProperty MarkSelected = propertySL +markProperty MarkSquare = propertySQ +markProperty MarkTriangle = propertyTR +markProperty MarkX = propertyMA diff --git a/src/Game/Goatee/Lib/Property/Parser.hs b/src/Game/Goatee/Lib/Property/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Property/Parser.hs @@ -0,0 +1,252 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Parsers of property values. +-- +-- Import "Game.Goatee.Lib.Property" rather than importing this module. +module Game.Goatee.Lib.Property.Parser ( + colorParser, + coordElistParser, + coordListParser, + coordPairListParser, + doubleParser, + gameResultParser, + labelListParser, + moveParser, + noneParser, + integralParser, + realParser, + rulesetParser, + simpleTextPairParser, + simpleTextParser, + sizeParser, + textParser, + unknownPropertyParser, + variationModeParser, + -- * Exposed for testing + compose, + line, + simpleText, + text, + ) where + +import Control.Applicative ((<$), (<$>), (<*), (<*>), (*>)) +import Control.Monad (when) +import Data.Char (isUpper, ord) +import Data.Maybe (catMaybes) +import Data.Monoid (Monoid, mappend, mconcat, mempty) +import qualified Game.Goatee.Common.Bigfloat as BF +import Game.Goatee.Lib.Types +import Text.ParserCombinators.Parsec ( + (), (<|>), Parser, + anyChar, char, choice, digit, many, many1, + noneOf, oneOf, option, space, spaces, string, + try, unexpected, + ) + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +-- Internal parser builders not corresponding to any particular value type. + +-- | A wrapper around 'CoordList' with a 'Monoid' instance used for parsing. +-- The monoid does simple concatenation of the single and rectangle lists, so it +-- is not appropriate for @CoordList@ proper, as it doesn't do duplicate removal +-- between two @CoordList@s. +newtype CoordListMonoid = CoordListMonoid { runCoordListMonoid :: CoordList } + +instance Monoid CoordListMonoid where + mempty = CoordListMonoid emptyCoordList + + mappend (CoordListMonoid x) (CoordListMonoid y) = + CoordListMonoid $ coords' (coordListSingles x ++ coordListSingles y) + (coordListRects x ++ coordListRects y) + +single :: Parser a -> Parser a +single valueParser = char '[' *> valueParser <* char ']' + +compose :: Parser a -> Parser b -> Parser (a, b) +compose first second = do + x <- first + char ':' + y <- second + return (x, y) + +line :: Parser Int +line = toLine <$> line' "line" + where line' = oneOf $ ['a'..'z'] ++ ['A'..'Z'] + toLine c = if isUpper c + then ord c - ord 'A' + 26 + else ord c - ord 'a' + +listOf :: Parser a -> Parser [a] +listOf valueParser = many1 (single valueParser <* spaces) + +number :: Parser String +number = do + addSign <- ('-':) <$ char '-' <|> + id <$ char '+' <|> + return id + addSign <$> many1 digit + +-- Public parsers. + +colorParser :: Parser Color +colorParser = single color "color" + +color :: Parser Color +color = choice [Black <$ char 'B', + White <$ char 'W'] + +coord :: Parser Coord +coord = (,) <$> line <*> line + +coordElistParser :: Parser CoordList +coordElistParser = + try (emptyCoordList <$ string "[]") <|> + coordListParser + "list of points or empty" + +coordListParser :: Parser CoordList +coordListParser = + runCoordListMonoid . mconcat . map CoordListMonoid <$> listOf coordListEntry + "list of points" + where coordListEntry = do x0 <- line + y0 <- line + choice [do char ':' + x1 <- line + y1 <- line + return $ coordR ((x0, y0), (x1, y1)), + return $ coord1 (x0, y0)] + coordR rect = coords' [] [rect] + +coordPairListParser :: Parser [(Coord, Coord)] +coordPairListParser = listOf coordPair "list of point pairs" + where coordPair = do + x0 <- line + y0 <- line + char ':' + x1 <- line + y1 <- line + return ((x0, y0), (x1, y1)) + +doubleParser :: Parser DoubleValue +doubleParser = + single (Double1 <$ char '1' <|> + Double2 <$ char '2') + "double" + +gameResultParser :: Parser GameResult +gameResultParser = single (convertStringlike <$> simpleText False) "game result" + +labelListParser :: Parser [(Coord, SimpleText)] +labelListParser = + listOf (compose coord $ simpleText True) "list of points and labels" + +moveParser :: Parser (Maybe Coord) +moveParser = + char '[' *> (Nothing <$ char ']' <|> Just <$> coord <* char ']') + "move (point or pass)" + +noneParser :: Parser () +noneParser = () <$ string "[]" "none" + +-- This is what the SGF spec calls the Number type, i.e. a signed integer. +integralParser :: (Integral a, Read a) => Parser a +integralParser = single integral "integer" + +integral :: (Integral a, Read a) => Parser a +integral = read <$> number + +realParser :: Parser RealValue +realParser = single real "real" + +real :: Parser RealValue +real = do + whole <- number + -- Try to read a fractional part of the number. + -- If we fail, just return the whole part. + option (fromInteger $ read whole) $ try $ do + fractional <- char '.' *> many1 digit + return $ BF.encode (read $ whole ++ fractional) (-length fractional) + +rulesetParser :: Parser Ruleset +rulesetParser = + single (toRuleset . fromSimpleText <$> simpleText False) "ruleset" + +simpleTextPairParser :: Parser (SimpleText, SimpleText) +simpleTextPairParser = single (compose composedText composedText) "pair of simple texts" + where composedText = simpleText True + +-- | A parser for SGF SimpleText property values. +simpleTextParser :: Parser SimpleText +simpleTextParser = single (simpleText False) "simple text" + +simpleText :: Bool -> Parser SimpleText +simpleText isComposed = toSimpleText <$> text isComposed + +sizeParser :: Parser (Int, Int) +sizeParser = + (do char '[' + width <- integral + height <- choice [width <$ char ']', + do char ':' + height <- integral + char ']' + -- TODO We should warn here rather than aborting. + when (width == height) $ + fail $ show width ++ "x" ++ show height ++ " square board " ++ + " dimensions should be specified with a single number." + return height] + when (width < 1 || width > boardSizeMax || + height < 1 || height > boardSizeMax) $ + fail $ show width ++ "x" ++ show height ++ " board dimensions are invalid. " ++ + "Each dimension must be between 1 and 52 inclusive." + return (width, height)) + "board size (width or width:height)" + +textParser :: Parser Text +textParser = single (toText <$> text False) "text" + +-- | A parser for SGF text property values. Its argument should be true if the +-- text is inside of a composed property value, so @\':\'@ should terminate the +-- value in addition to @']'@. +text :: Bool -> Parser String +text isComposed = catMaybes <$> many textChar' + where textChar' = textChar (if isComposed then ":]\\" else "]\\") + +textChar :: String -> Parser (Maybe Char) +textChar specialChars = + choice [Just <$> char '\n', + Just ' ' <$ space, + try (char '\\' *> (Nothing <$ char '\n' <|> + Just <$> anyChar)), + Just <$> noneOf specialChars] + +unknownPropertyParser :: Parser UnknownPropertyValue +unknownPropertyParser = + single (toUnknownPropertyValue <$> text False) + "unknown property value" + +variationModeParser :: Parser VariationMode +variationModeParser = single variationMode "variation mode" + +variationMode :: Parser VariationMode +variationMode = do + value <- integral + case toVariationMode value of + Just mode -> return mode + Nothing -> unexpected $ "variation mode " ++ show value diff --git a/src/Game/Goatee/Lib/Property/Renderer.hs b/src/Game/Goatee/Lib/Property/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Property/Renderer.hs @@ -0,0 +1,332 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +{-# LANGUAGE CPP #-} + +-- | Renderers of property values. +-- +-- Import "Game.Goatee.Lib.Property" rather than importing this module. +module Game.Goatee.Lib.Property.Renderer ( + renderColorBracketed, + renderColorPretty, + renderCoordElistBracketed, + renderCoordElistPretty, + renderCoordListBracketed, + renderCoordListPretty, + renderCoordPairListBracketed, + renderCoordPairListPretty, + renderDoubleBracketed, + renderDoublePretty, + renderGameResultBracketed, + renderGameResultPretty, + renderGameResultPretty', + renderIntegralBracketed, + renderIntegralPretty, + renderLabelListBracketed, + renderLabelListPretty, + renderMoveBracketed, + renderMovePretty, + renderNoneBracketed, + renderNonePretty, + renderRealBracketed, + renderRealPretty, + renderRulesetBracketed, + renderRulesetPretty, + renderSimpleTextBracketed, + renderSimpleTextPairBracketed, + renderSimpleTextPairPretty, + renderSimpleTextPretty, + renderSizeBracketed, + renderSizePretty, + renderTextBracketed, + renderTextPretty, + renderUnknownPropertyBracketed, + renderUnknownPropertyPretty, + renderVariationModeBracketed, + renderVariationModePretty, + ) where + +import Control.Monad (forM_, void, when) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except (throwError) +#else +import Control.Monad.Error (throwError) +#endif +import Control.Monad.Writer (tell) +import Data.Char (chr, ord) +import Data.List (intersperse) +import qualified Game.Goatee.Common.Bigfloat as BF +import Game.Goatee.Lib.Renderer +import Game.Goatee.Lib.Types + +{-# ANN module "HLint: ignore Use <$>" #-} + +-- Internal renderers not corresponding to any particular value type. + +bracketed :: Render () -> Render () +bracketed x = tell "[" >> x >> tell "]" + +renderLine :: Int -> Render () +renderLine = rendererOf "line" $ \x -> + if x >= 0 && x < 52 + then tell [chr $ x + (if x < 26 then ord 'a' else ord 'A' - 26)] + else throwError $ "renderLine: Index not in [0, 52): " ++ show x + +renderCoord :: Coord -> Render () +renderCoord = rendererOf "coord" $ \(x, y) -> renderLine x >> renderLine y + +renderCoordBracketed :: Coord -> Render () +renderCoordBracketed = fmap bracketed renderCoord + +renderCoordPretty :: Coord -> Render () +renderCoordPretty = rendererOf "coord pretty" $ \(x, y) -> + mapM_ tell ["(", show x, ", ", show y, ")"] + +renderCoordPairPretty :: (Coord, Coord) -> Render () +renderCoordPairPretty = rendererOf "coord pair pretty" $ \(a, b) -> do + renderCoordPretty a + tell "-" + renderCoordPretty b + +renderCoordPair :: (Coord, Coord) -> Render () +renderCoordPair = rendererOf "coord pair" $ \(a, b) -> + renderCoord a >> tell ":" >> renderCoord b + +renderCoordPairBracketed :: (Coord, Coord) -> Render () +renderCoordPairBracketed = fmap bracketed renderCoordPair + +renderShowable :: Show a => a -> Render () +renderShowable = tell . show + +renderStringlike :: (Show a, Stringlike a) => Bool -> a -> Render () +renderStringlike isComposed = + rendererOf (if isComposed then "composed stringlike" else "stringlike") $ \str -> + tell $ escape $ sgfToString str + where escape [] = [] + escape (first:rest) | first `elem` specialChars = '\\':first:escape rest + | otherwise = first:escape rest + -- TODO Deduplicate these characters with the parser: + specialChars = if isComposed then ":]\\" else "]\\" + +-- Note that unlike the serialized SGF version, we don't care about escaping +-- characters in composed strings. +renderStringlikePretty :: (Show a, Stringlike a) => a -> Render () +renderStringlikePretty = rendererOf "stringlike pretty" $ tell . sgfToString + +-- Public renderers. + +renderColorBracketed :: Color -> Render () +renderColorBracketed color = bracketed $ tell $ case color of + Black -> "B" + White -> "W" + +renderColorPretty :: Color -> Render () +renderColorPretty Black = tell "Black" +renderColorPretty White = tell "White" + +renderCoordElistBracketed :: CoordList -> Render () +renderCoordElistBracketed = rendererOf "coord elist bracketed" $ \list -> + if null $ expandCoordList list + then tell "[]" + else renderCoordListNonempty list + +renderCoordElistPretty :: CoordList -> Render () +renderCoordElistPretty = rendererOf "coord elist pretty" $ \list -> + if null $ expandCoordList list + then tell "empty" + else renderCoordListNonemptyPretty list + +renderCoordListBracketed :: CoordList -> Render () +renderCoordListBracketed = rendererOf "coord list bracketed" $ \list -> + if null $ expandCoordList list + then throwError "renderCoordListBracketed: Unexpected empty CoordList." + else renderCoordListNonempty list + +renderCoordListPretty :: CoordList -> Render () +renderCoordListPretty = rendererOf "coord list pretty" $ \list -> + if null $ expandCoordList list + then throwError "renderCoordListPretty: Unexpected empty CoordList." + else renderCoordListNonemptyPretty list + +renderCoordListNonempty :: CoordList -> Render () +renderCoordListNonempty = rendererOf "coord list nonempty" $ \list -> do + mapM_ renderCoordPairBracketed $ coordListRects list + mapM_ renderCoordBracketed $ coordListSingles list + +renderCoordListNonemptyPretty :: CoordList -> Render () +renderCoordListNonemptyPretty = rendererOf "coord list nonempty pretty" $ \list -> + sequence_ $ intersperse (tell ", ") $ + map renderCoordPairPretty (coordListRects list) ++ + map renderCoordPretty (coordListSingles list) + +renderCoordPairListBracketed :: [(Coord, Coord)] -> Render () +renderCoordPairListBracketed = rendererOf "coord pair list bracketed" $ \list -> + if null list + then throwError "renderCoordPairListBracketed: Unexpected empty list." + else mapM_ renderCoordPairBracketed list + +renderCoordPairListPretty :: [(Coord, Coord)] -> Render () +renderCoordPairListPretty list = + if null list + then throwError "renderCoordPairListPretty: Unexpected empty list." + else sequence_ $ intersperse (tell ", ") $ map renderCoordPairPretty list + +renderDoubleBracketed :: DoubleValue -> Render () +renderDoubleBracketed = fmap bracketed $ rendererOf "double" $ \double -> tell $ case double of + Double1 -> "1" + Double2 -> "2" + +renderDoublePretty :: DoubleValue -> Render () +renderDoublePretty = rendererOf "double pretty" $ tell . \double -> case double of + Double1 -> "1" + Double2 -> "2" + +renderGameResultBracketed :: GameResult -> Render () +renderGameResultBracketed = fmap bracketed $ rendererOf "game result" $ \result -> case result of + GameResultWin color reason -> + tell $ + (case color of { Black -> 'B'; White -> 'W' }) : '+' : + (case reason of + WinByScore diff -> show diff + WinByResignation -> "R" + WinByTime -> "T" + WinByForfeit -> "F") + GameResultDraw -> tell "0" + GameResultVoid -> tell "Void" + GameResultUnknown -> tell "?" + GameResultOther text -> renderStringlike False text + +renderGameResultPretty :: GameResult -> Render () +renderGameResultPretty = + rendererOf "game result pretty" $ void . tell . renderGameResultPretty' + +renderGameResultPretty' :: GameResult -> String +renderGameResultPretty' result = case result of + GameResultWin color reason -> + (case color of { Black -> 'B'; White -> 'W' }) : '+' : + (case reason of + WinByScore diff -> show diff + WinByResignation -> "Resign" + WinByTime -> "Time" + WinByForfeit -> "Forfeit") + GameResultDraw -> "Draw" + GameResultVoid -> "Void" + GameResultUnknown -> "Unknown" + GameResultOther text -> sgfToString text + +renderIntegralBracketed :: (Integral a, Show a) => a -> Render () +renderIntegralBracketed = bracketed . rendererOf "integral" renderShowable + +renderIntegralPretty :: (Integral a, Show a) => a -> Render () +renderIntegralPretty = rendererOf "integral pretty" renderShowable + +renderLabelListBracketed :: [(Coord, SimpleText)] -> Render () +renderLabelListBracketed = rendererOf "label list" $ \list -> + if null list + then throwError "renderLabelListBracketed: Unexpected empty list." + else forM_ list $ bracketed . \(coord, text) -> do + renderCoord coord + tell ":" + renderStringlike True text + +renderLabelListPretty :: [(Coord, SimpleText)] -> Render () +renderLabelListPretty = rendererOf "label list pretty" $ \list -> + if null list + then throwError "renderLabelListPretty: Unexpected empty list." + else sequence_ $ intersperse (tell ", ") $ + map (\(coord, text) -> do + renderCoordPretty coord + tell ":" + renderStringlikePretty text) + list + +renderMoveBracketed :: Maybe Coord -> Render () +renderMoveBracketed = rendererOf "move bracketed" $ maybe (tell "[]") renderCoordBracketed + +renderMovePretty :: Maybe Coord -> Render () +renderMovePretty = rendererOf "move pretty" $ maybe (tell "Pass") renderCoordPretty + +renderNoneBracketed :: () -> Render () +renderNoneBracketed = rendererOf "none bracketed" $ tell . const "[]" + +renderNonePretty :: () -> Render () +renderNonePretty = rendererOf "none pretty" $ tell . const "" + +renderRealBracketed :: RealValue -> Render () +renderRealBracketed = + fmap bracketed $ rendererOf "real" (renderShowable :: BF.Bigfloat -> Render ()) + +renderRealPretty :: RealValue -> Render () +renderRealPretty = rendererOf "real pretty" (renderShowable :: BF.Bigfloat -> Render ()) + +renderRulesetBracketed :: Ruleset -> Render () +renderRulesetBracketed = fmap bracketed $ rendererOf "ruleset" $ tell . fromRuleset + +renderRulesetPretty :: Ruleset -> Render () +renderRulesetPretty = rendererOf "ruleset pretty" $ tell . fromRuleset + +renderSimpleTextPairBracketed :: (SimpleText, SimpleText) -> Render () +renderSimpleTextPairBracketed = fmap bracketed $ rendererOf "simple text pair" $ \(a, b) -> do + renderStringlike True a + tell ":" + renderStringlike True b + +renderSimpleTextPairPretty :: (SimpleText, SimpleText) -> Render () +renderSimpleTextPairPretty = rendererOf "simple text pair pretty" $ \(a, b) -> do + renderStringlike True a + tell " " + renderStringlike True b + +renderSimpleTextBracketed :: SimpleText -> Render () +renderSimpleTextBracketed = fmap bracketed $ rendererOf "simple text" $ renderStringlike False + +renderSimpleTextPretty :: SimpleText -> Render () +renderSimpleTextPretty = rendererOf "simple text pretty" $ tell . fromSimpleText + +renderSizeBracketed :: (Int, Int) -> Render () +renderSizeBracketed = fmap bracketed $ rendererOf "size" $ \(x, y) -> do + tell $ show x + when (x /= y) $ tell $ ':' : show y + +renderSizePretty :: (Int, Int) -> Render () +renderSizePretty = rendererOf "size pretty" renderCoordPretty + +renderTextBracketed :: Text -> Render () +renderTextBracketed = fmap bracketed $ rendererOf "text" $ renderStringlike False + +renderTextPretty :: Text -> Render () +renderTextPretty = rendererOf "text pretty" $ tell . fromText + +renderUnknownPropertyBracketed :: UnknownPropertyValue -> Render () +renderUnknownPropertyBracketed = + fmap bracketed $ rendererOf "unknown property" $ renderStringlike False + +renderUnknownPropertyPretty :: UnknownPropertyValue -> Render () +renderUnknownPropertyPretty = + rendererOf "unknown property pretty" $ tell . fromUnknownPropertyValue + +renderVariationModeBracketed :: VariationMode -> Render () +renderVariationModeBracketed = + fmap bracketed $ rendererOf "variation mode" $ tell . show . fromVariationMode + +renderVariationModePretty :: VariationMode -> Render () +renderVariationModePretty = rendererOf "variation mode pretty" $ \(VariationMode source markup) -> + tell $ + (case source of + ShowChildVariations -> "Children" + ShowCurrentVariations -> "Current") ++ " " ++ + (if markup then "Shown" else "Hidden") diff --git a/src/Game/Goatee/Lib/Property/Value.hs b/src/Game/Goatee/Lib/Property/Value.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Property/Value.hs @@ -0,0 +1,179 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Metadata about the types of property values. +-- +-- Import "Game.Goatee.Lib.Property" rather than importing this module. +module Game.Goatee.Lib.Property.Value ( + PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, + colorPvt, + coordElistPvt, + coordListPvt, + coordPairListPvt, + doublePvt, + gameResultPvt, + integralPvt, + labelListPvt, + movePvt, + nonePvt, + realPvt, + rulesetPvt, + simpleTextPairPvt, + simpleTextPvt, + sizePvt, + textPvt, + unknownPropertyPvt, + variationModePvt, + ) where + +import qualified Game.Goatee.Lib.Property.Parser as P +import qualified Game.Goatee.Lib.Property.Renderer as R +import Game.Goatee.Lib.Renderer +import Game.Goatee.Lib.Types +import Text.ParserCombinators.Parsec (Parser) + +data PropertyValueType a = PropertyValueType + { pvtParser :: Parser a + , pvtRenderer :: a -> Render () + , pvtRendererPretty :: a -> Render () + } + +colorPvt :: PropertyValueType Color +colorPvt = PropertyValueType + { pvtParser = P.colorParser + , pvtRenderer = R.renderColorBracketed + , pvtRendererPretty = R.renderColorPretty + } + +coordElistPvt :: PropertyValueType CoordList +coordElistPvt = PropertyValueType + { pvtParser = P.coordElistParser + , pvtRenderer = R.renderCoordElistBracketed + , pvtRendererPretty = R.renderCoordElistPretty + } + +coordListPvt :: PropertyValueType CoordList +coordListPvt = PropertyValueType + { pvtParser = P.coordListParser + , pvtRenderer = R.renderCoordListBracketed + , pvtRendererPretty = R.renderCoordListPretty + } + +coordPairListPvt :: PropertyValueType [(Coord, Coord)] +coordPairListPvt = PropertyValueType + { pvtParser = P.coordPairListParser + , pvtRenderer = R.renderCoordPairListBracketed + , pvtRendererPretty = R.renderCoordPairListPretty + } + +doublePvt :: PropertyValueType DoubleValue +doublePvt = PropertyValueType + { pvtParser = P.doubleParser + , pvtRenderer = R.renderDoubleBracketed + , pvtRendererPretty = R.renderDoublePretty + } + +gameResultPvt :: PropertyValueType GameResult +gameResultPvt = PropertyValueType + { pvtParser = P.gameResultParser + , pvtRenderer = R.renderGameResultBracketed + , pvtRendererPretty = R.renderGameResultPretty + } + +integralPvt :: (Integral a, Read a, Show a) => PropertyValueType a +integralPvt = PropertyValueType + { pvtParser = P.integralParser + , pvtRenderer = R.renderIntegralBracketed + , pvtRendererPretty = R.renderIntegralPretty + } + +labelListPvt :: PropertyValueType [(Coord, SimpleText)] +labelListPvt = PropertyValueType + { pvtParser = P.labelListParser + , pvtRenderer = R.renderLabelListBracketed + , pvtRendererPretty = R.renderLabelListPretty + } + +movePvt :: PropertyValueType (Maybe Coord) +movePvt = PropertyValueType + { pvtParser = P.moveParser + , pvtRenderer = R.renderMoveBracketed + , pvtRendererPretty = R.renderMovePretty + } + +nonePvt :: PropertyValueType () +nonePvt = PropertyValueType + { pvtParser = P.noneParser + , pvtRenderer = R.renderNoneBracketed + , pvtRendererPretty = R.renderNonePretty + } + +realPvt :: PropertyValueType RealValue +realPvt = PropertyValueType + { pvtParser = P.realParser + , pvtRenderer = R.renderRealBracketed + , pvtRendererPretty = R.renderRealPretty + } + +rulesetPvt :: PropertyValueType Ruleset +rulesetPvt = PropertyValueType + { pvtParser = P.rulesetParser + , pvtRenderer = R.renderRulesetBracketed + , pvtRendererPretty = R.renderRulesetPretty + } + +simpleTextPairPvt :: PropertyValueType (SimpleText, SimpleText) +simpleTextPairPvt = PropertyValueType + { pvtParser = P.simpleTextPairParser + , pvtRenderer = R.renderSimpleTextPairBracketed + , pvtRendererPretty = R.renderSimpleTextPairPretty + } + +simpleTextPvt :: PropertyValueType SimpleText +simpleTextPvt = PropertyValueType + { pvtParser = P.simpleTextParser + , pvtRenderer = R.renderSimpleTextBracketed + , pvtRendererPretty = R.renderSimpleTextPretty + } + +sizePvt :: PropertyValueType (Int, Int) +sizePvt = PropertyValueType + { pvtParser = P.sizeParser + , pvtRenderer = R.renderSizeBracketed + , pvtRendererPretty = R.renderSizePretty + } + +textPvt :: PropertyValueType Text +textPvt = PropertyValueType + { pvtParser = P.textParser + , pvtRenderer = R.renderTextBracketed + , pvtRendererPretty = R.renderTextPretty + } + +unknownPropertyPvt :: PropertyValueType UnknownPropertyValue +unknownPropertyPvt = PropertyValueType + { pvtParser = P.unknownPropertyParser + , pvtRenderer = R.renderUnknownPropertyBracketed + , pvtRendererPretty = R.renderUnknownPropertyPretty + } + +variationModePvt :: PropertyValueType VariationMode +variationModePvt = PropertyValueType + { pvtParser = P.variationModeParser + , pvtRenderer = R.renderVariationModeBracketed + , pvtRendererPretty = R.renderVariationModePretty + } diff --git a/src/Game/Goatee/Lib/Renderer.hs b/src/Game/Goatee/Lib/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Renderer.hs @@ -0,0 +1,56 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +{-# LANGUAGE CPP #-} + +-- | Common definitions for a renderer that supports failure. +module Game.Goatee.Lib.Renderer ( + Render, + runRender, + rendererOf, + ) where + +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except (Except, catchError, runExcept, throwError) +#else +import Control.Monad.Error (catchError, throwError) +#endif +import Control.Monad.Writer (WriterT, execWriterT) + +-- | A monad for accumulating string output with the possibility of failure. +#if MIN_VERSION_mtl(2,2,1) +type Render = WriterT String (Except String) +#else +type Render = WriterT String (Either String) +#endif + +-- | Returns either the rendered result on the right, or a message describing a +-- failure on the left. +runRender :: Render a -> Either String String +#if MIN_VERSION_mtl(2,2,1) +runRender = runExcept . execWriterT +#else +runRender = execWriterT +#endif + +-- | Wraps a renderer in an exception handler that, when the renderer or +-- something it calls fails, will add context about this renderer's invocation +-- to the failure message. +rendererOf :: Show a => String -> (a -> Render ()) -> a -> Render () +rendererOf description renderer value = catchError (renderer value) $ \message -> + throwError $ + message ++ "\n while trying to render " ++ description ++ " from " ++ show value ++ "." diff --git a/src/Game/Goatee/Lib/Renderer/Tree.hs b/src/Game/Goatee/Lib/Renderer/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Renderer/Tree.hs @@ -0,0 +1,60 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Functions for serializing SGF trees. +module Game.Goatee.Lib.Renderer.Tree ( + renderCollection, + renderGameTree, + renderProperty, + ) where + +import Control.Monad.Writer (tell) +import Game.Goatee.Common +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Renderer +import Game.Goatee.Lib.Tree + +-- | Renders an SGF 'Collection' to a string. +renderCollection :: Collection -> Render () +renderCollection collection = do + mapM_ renderGameTree $ collectionTrees collection + tell "\n" + +-- | Recursively renders an SGF GameTree (as defined in the spec) rooted at the +-- given node. +renderGameTree :: Node -> Render () +renderGameTree node = do + tell "(" + doWhileM node + (\node' -> do renderNode node' + case nodeChildren node' of + [] -> return $ Left Nothing + child:[] -> return $ Right child + children -> return $ Left $ Just children) + >>= maybe (return ()) (mapM_ renderGameTree) + tell ")" + +-- | Renders a node and its properties without recurring to its children. +renderNode :: Node -> Render () +renderNode node = do + tell "\n;" + mapM_ renderProperty $ nodeProperties node + +renderProperty :: Property -> Render () +renderProperty property = do + tell $ propertyName property + propertyValueRenderer property property diff --git a/src/Game/Goatee/Lib/Tree.hs b/src/Game/Goatee/Lib/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Tree.hs @@ -0,0 +1,188 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | SGF data structures modelling the hierarchical game tree. +module Game.Goatee.Lib.Tree ( + Collection(..), CollectionWithDeepEquality(..), + Node(..), NodeWithDeepEquality(..), + emptyNode, rootNode, + findProperty, findProperty', findPropertyValue, findPropertyValue', + addProperty, addChild, addChildAt, deleteChildAt, + validateNode, + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM_, unless, when) +import Control.Monad.Writer (Writer, execWriter, tell) +import Data.Function (on) +import Data.List (find, groupBy, intercalate, nub, sortBy) +import Data.Version (showVersion) +import Game.Goatee.App (applicationName) +import Game.Goatee.Common +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Types +import Paths_goatee (version) + +-- | An SGF collection of game trees. +data Collection = Collection + { collectionTrees :: [Node] + } deriving (Show) + +-- | See 'NodeWithDeepEquality'. +newtype CollectionWithDeepEquality = CollectionWithDeepEquality + { collectionWithDeepEquality :: Collection + } deriving (Show) + +instance Eq CollectionWithDeepEquality where + (==) = (==) `on` map NodeWithDeepEquality . collectionTrees . collectionWithDeepEquality + +-- | An SGF game tree node. Unlike in the SGF spec, we represent a game tree +-- with nodes uniformly, rather than having the separation between sequences and +-- nodes. +data Node = Node + { nodeProperties :: [Property] + , nodeChildren :: [Node] + } deriving (Show) + +-- | A wrapper around 'Node' with an 'Eq' instance that considers two nodes +-- equal iff they contain the same properties (not necessarily in the same +-- order), and if they contain children (in the same order) whose nodes are +-- recursively equal. +-- +-- This instance is not on 'Node' directly because it is not the only obvious +-- sense of equality (only comparing properties would be another one), and it's +-- also potentially expensive. +newtype NodeWithDeepEquality = NodeWithDeepEquality { nodeWithDeepEquality :: Node } + +instance Eq NodeWithDeepEquality where + node1 == node2 = + let n1 = nodeWithDeepEquality node1 + n2 = nodeWithDeepEquality node2 + in propertiesSorted n1 == propertiesSorted n2 && + deepChildren n1 == deepChildren n2 + where propertiesSorted = sortBy (compare `on` show) . nodeProperties + deepChildren = map NodeWithDeepEquality . nodeChildren + +-- | A node with no properties and no children. +emptyNode :: Node +emptyNode = Node { nodeProperties = [], nodeChildren = [] } + +-- | Returns a fresh root 'Node' with 'AP' set to Goatee and optionally with a +-- board size set via 'SZ'. +rootNode :: Maybe (Int, Int) -> Node +rootNode maybeSize = + let props = FF 4 : + GM 1 : + AP (toSimpleText applicationName) + (toSimpleText $ showVersion version) : + maybe [] ((:[]) . uncurry SZ) maybeSize + in Node { nodeProperties = props + , nodeChildren = [] + } + +-- | Searches for a matching property in a node's property list. +findProperty :: Descriptor a => a -> Node -> Maybe Property +findProperty descriptor node = findProperty' descriptor $ nodeProperties node + +-- | Searches for a matching property in a property list. +findProperty' :: Descriptor a => a -> [Property] -> Maybe Property +findProperty' = find . propertyPredicate + +-- | Retrieves the value of a property in a node's property list. +findPropertyValue :: ValuedDescriptor a v => a -> Node -> Maybe v +findPropertyValue descriptor node = propertyValue descriptor <$> findProperty descriptor node + +-- | Retrieves the value of a property in a property list. +findPropertyValue' :: ValuedDescriptor a v => a -> [Property] -> Maybe v +findPropertyValue' descriptor properties = + propertyValue descriptor <$> findProperty' descriptor properties + +-- | Appends a property to a node's property list. +addProperty :: Property -> Node -> Node +addProperty prop node = node { nodeProperties = nodeProperties node ++ [prop] } + +-- | @addChild child parent@ appends a child node to a node's child list. +addChild :: Node -> Node -> Node +addChild child node = node { nodeChildren = nodeChildren node ++ [child] } + +-- | @addChildAt index child parent@ inserts a child node into a node's child +-- list at the given index, shifting all nodes at or after the given index to +-- the right. If the position is less than 0 or greater than the length of the +-- list, then the index is clamped to this range. +addChildAt :: Int -> Node -> Node -> Node +addChildAt index child node = + let (before, after) = splitAt index $ nodeChildren node + in node { nodeChildren = before ++ child:after } + +-- | @deleteChildAt index node@ deletes the child at the given index from the +-- node. If the index is invalid, @node@ is returned. +deleteChildAt :: Int -> Node -> Node +deleteChildAt index node = + let children = nodeChildren node + in if index < 0 || index > length children + then node + else node { nodeChildren = listDeleteAt index children } + +-- | Returns a list of validation errors for the current node, an +-- empty list if no errors are detected. +validateNode :: Bool -> Bool -> Node -> [String] +validateNode isRoot _{-seenGameNode-} node = execWriter $ do + let props = nodeProperties node + let propTypes = nub $ map propertyType $ nodeProperties node + + -- Check for move and setup properties in a single node. + when (MoveProperty `elem` propTypes && SetupProperty `elem` propTypes) $ + tell ["Node contains move and setup properties."] + + -- Check for root properties in non-root nodes. + let rootProps = filter ((RootProperty ==) . propertyType) props + when (not isRoot && not (null rootProps)) $ + tell $ map (\p -> "Root property found on non-root node: " ++ + show p ++ ".") + rootProps + + -- TODO Check for game-info properties. + + -- Check for coordinates marked multiple times. + validateNodeDuplicates props getMarkedCoords $ \group -> + tell ["Coordinate " ++ show (fst $ head group) ++ + " is specified multiple times in properties " ++ + intercalate ", " (map snd group) ++ "."] + + -- TODO Validate recursively. + + where getMarkedCoords (CR cs) = tagMarkedCoords cs "CR" + getMarkedCoords (MA cs) = tagMarkedCoords cs "MA" + getMarkedCoords (SL cs) = tagMarkedCoords cs "SL" + getMarkedCoords (SQ cs) = tagMarkedCoords cs "SQ" + getMarkedCoords (TR cs) = tagMarkedCoords cs "TR" + getMarkedCoords _ = [] + + tagMarkedCoords cs tag = map (\x -> (x, tag)) $ expandCoordList cs + +validateNodeDuplicates :: (Eq v, Ord v) + => [Property] + -> (Property -> [(v, t)]) + -> ([(v, t)] -> Writer [String] ()) + -> Writer [String] () +validateNodeDuplicates props getTaggedElts errAction = + let groups = groupBy ((==) `on` fst) $ + sortBy (compare `on` fst) $ + concatMap getTaggedElts props + in forM_ groups $ \group -> + unless (null $ tail group) $ + errAction group diff --git a/src/Game/Goatee/Lib/Types.hs b/src/Game/Goatee/Lib/Types.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Lib/Types.hs @@ -0,0 +1,505 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Constants and data types for property values used in SGF game trees. +module Game.Goatee.Lib.Types ( + -- * Constants + supportedFormatVersions, defaultFormatVersion, supportedGameTypes, + boardSizeDefault, boardSizeMin, boardSizeMax, + -- * Board coordinates + Coord, CoordList, coordListSingles, coordListRects, coord1, coords, coords', + emptyCoordList, expandCoordList, buildCoordList, + -- ** Star points and handicap stones + starLines, + isStarPoint, + handicapStones, + -- * Property values + -- ** Text values + Stringlike (..), convertStringlike, + Text, fromText, toText, + SimpleText, fromSimpleText, toSimpleText, + -- ** Other values + UnknownPropertyValue, fromUnknownPropertyValue, toUnknownPropertyValue, + RealValue, + DoubleValue (..), + Color (..), cnot, + VariationMode (..), VariationModeSource (..), defaultVariationMode, + toVariationMode, fromVariationMode, + ArrowList, LineList, LabelList, Mark (..), + GameResult (..), + WinReason (..), + Ruleset (..), RulesetType (..), fromRuleset, toRuleset, + ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Char (isSpace) +import Data.Function (on) +import Data.List (delete, groupBy, partition, sort) +import Data.Maybe (fromMaybe) +import Game.Goatee.Common +import qualified Game.Goatee.Common.Bigfloat as BF + +-- | The FF versions supported by Goatee. Currently only 4. +supportedFormatVersions :: [Int] +supportedFormatVersions = [4] +-- TODO Support FF versions 1-4. + +-- | The default SGF version to use when @FF[]@ is not specified in a root node. +-- +-- This value is actually INCORRECT: SGF defines it to be 1, but because we +-- don't support version 1 yet, for the sake of ignoring this issue (for now!) +-- in tests, we fix the default to be 4. +defaultFormatVersion :: Int +defaultFormatVersion = 4 +-- TODO Fix the default version to be 1 as SGF mandates. + +-- | SGF supports multiple game types. This list contains the game types that +-- Goatee supports, which is only Go (1). +supportedGameTypes :: [Int] +supportedGameTypes = [1 {- Go -}] + +-- | The default size of the board. The FF[4] SGF spec says that the default Go +-- board is 19x19 square. +boardSizeDefault :: Int +boardSizeDefault = 19 + +-- | The minimum board size allowed by FF[4], 1. +boardSizeMin :: Int +boardSizeMin = 1 + +-- | The maximum board size allowed by FF[4], 52. +boardSizeMax :: Int +boardSizeMax = 52 + +-- | A coordinate on a Go board. @(0, 0)@ refers to the upper-left corner of +-- the board. The first component is the horizontal position; the second +-- component is the vertical position. +type Coord = (Int, Int) + +-- | A structure for compact representation of a list of coordinates. Contains +-- a list of individual points, as well as a list of rectangles of points +-- denoted by an ordered pair of the upper-left point and the lower-right point. +-- The union of the single points and points contained within rectangles make up +-- all of the points a @CoordList@ represents. There is no rule saying that +-- adjacent points have to be grouped into rectangles; it's perfectly valid +-- (although possibly inefficient) to never use rectangles. +-- +-- For any @CoordList@, all of the following hold: +-- +-- 1. Any point may be specified at most once, either in the singles list or in +-- a single rectangle. +-- +-- 2. For a rectangle @((x0,y0), (x1,y1))@, @x0 <= x1@ and @y0 <= y1@ and +-- @(x0,y0) /= (x1,y1)@ (otherwise the point belongs in the singles list). +data CoordList = CoordList + { coordListSingles :: [Coord] + -- ^ Returns the single points in a 'CoordList'. + , coordListRects :: [(Coord, Coord)] + -- ^ Returns the rectangles in a 'CoordList'. + } deriving (Show) + +-- | Equality is based on unordered, set equality of the underlying points. +instance Eq CoordList where + (==) = (==) `on` sort . expandCoordList + +-- | Constructs a 'CoordList' containing a single point. +coord1 :: Coord -> CoordList +coord1 xy = CoordList { coordListSingles = [xy] + , coordListRects = [] + } + +-- | Constructs a 'CoordList' containing the given single points. For rectangle +-- detection, use 'buildCoordList'. +coords :: [Coord] -> CoordList +coords singles = CoordList { coordListSingles = singles + , coordListRects = [] + } + +-- | Constructs a 'CoordList' containing the given single points and rectangles. +coords' :: [Coord] -> [(Coord, Coord)] -> CoordList +coords' singles rects = CoordList { coordListSingles = singles + , coordListRects = rects + } + +-- | A 'CoordList' that contains no points. +emptyCoordList :: CoordList +emptyCoordList = CoordList { coordListSingles = [] + , coordListRects = [] + } + +-- | Converts a compact 'CoordList' to a list of coordinates. +expandCoordList :: CoordList -> [Coord] +expandCoordList cl = coordListSingles cl ++ + foldr (\r@((x0, y0), (x1, y1)) rest -> + if x0 > x1 || y0 > y1 + then error ("Invalid coord. rectangle: " ++ show r) + else [(x, y) | x <- [x0..x1], y <- [y0..y1]] ++ rest) + [] + (coordListRects cl) + +-- | Constructs a 'CoordList' from a list of 'Coord's, doing some +-- not-completely-stupid rectangle detection. The order of data in the result +-- is unspecified. +buildCoordList :: [Coord] -> CoordList +-- This algorithm doesn't generate the smallest result. For the following +-- input: +-- +-- F F T T +-- T T T T +-- T T F F +-- +-- It will return [ca:da][ab:db][ac:bc] rather than the shorter [ca:db][ab:bc]. +buildCoordList = toCoordList . generateRects 0 [] . buildTruePairs . toGrid + where -- | Constructs a row-major grid of booleans where an coordinate is true + -- iff it is in the given list. + toGrid :: [Coord] -> [[Bool]] + toGrid [] = [] + toGrid coords = let x1 = maximum $ map fst coords + y1 = maximum $ map snd coords + in [[(x,y) `elem` coords | x <- [0..x1]] | y <- [0..y1]] + + -- | For each row, converts a list of booleans into a list of pairs + -- where each pair represents a consecutive run of true values. The + -- pair indicates the indices of the first and last boolean in each run. + buildTruePairs :: [[Bool]] -> [[(Int, Int)]] + buildTruePairs = map $ + concatMap extractTrueGroups . + groupBy ((==) `on` snd) . + zip [0..] + + -- | Given a run of indexed booleans with the same boolean value within + -- a row, returns @[(startIndex, endIndex)]@ if the value is true, and + -- @[]@ if the value is false. + extractTrueGroups :: [(Int, Bool)] -> [(Int, Int)] + extractTrueGroups list@((start, True):_) = [(start, fst (last list))] + extractTrueGroups _ = [] + + -- | Converts the lists of true pairs for all rows into a list of + -- @(Coord, Coord)@ rectangles. We repeatedly grab the first span in + -- the first row, and see how many leading rows contain that exact span. + -- Then we build a (maybe multi-row) rectangle for the span, remove the + -- span from all leading rows, and repeat. When the first row becomes + -- empty, we drop it and increment a counter that keeps track of our + -- first row's y-position. + generateRects :: Int -> [(Coord, Coord)] -> [[(Int, Int)]] -> [(Coord, Coord)] + generateRects _ acc [] = acc + generateRects topRowOffset acc ([]:rows) = generateRects (topRowOffset + 1) acc rows + generateRects topRowOffset acc rows@((span:_):_) = + let rowsWithSpan = matchRowsWithSpan span rows + rowsWithSpanCount = length rowsWithSpan + in generateRects topRowOffset + (((fst span, topRowOffset), + (snd span, topRowOffset + rowsWithSpanCount - 1)) : acc) + (rowsWithSpan ++ drop rowsWithSpanCount rows) + + -- | Determines how many leading rows contain the given span. A list of + -- all the matching rows is returned, with the span deleted from each. + matchRowsWithSpan :: (Int, Int) -> [[(Int, Int)]] -> [[(Int, Int)]] + matchRowsWithSpan span (row:rows) + | span `elem` row = delete span row : matchRowsWithSpan span rows + | otherwise = [] + matchRowsWithSpan _ [] = [] + + -- | Builds a 'CoordList' from simple @(Coord, Coord)@ rectangles. + toCoordList :: [(Coord, Coord)] -> CoordList + toCoordList rects = + let (singles, properRects) = partition (uncurry (==)) rects + in coords' (map fst singles) properRects + +-- | @starLines width height@ returns 'Just' a list of row/column indices that +-- have star points on a board of the given size, or 'Nothing' if the board size +-- does not have star points defined. +starLines :: Int -> Int -> Maybe [Int] +starLines 19 19 = Just [3, 9, 15] +starLines 13 13 = Just [3, 6, 9] +starLines 9 9 = Just [2, 4, 6] +starLines _ _ = Nothing + +-- | @isStarPoint width height x y@ determines whether @(x, y)@ is a known star +-- point on a board of the given width and height. +isStarPoint :: Int -> Int -> Int -> Int -> Bool +isStarPoint width height x y = + fromMaybe False $ + ((&&) <$> elem x <*> elem y) <$> starLines width height + +-- | @handicapStoneIndices !! k@ the positions of the handicap stones for @k@ +-- handicap stones, betweeen 0 and 9. In the pairs, 0 indicates the first star +-- point along an axis, 1 indicates the second, and 2 indicates the third, in +-- the normal 'Coord' ordering. +handicapStoneIndices :: [[(Int, Int)]] +handicapStoneIndices = + [ [] + , [] -- No single handicap stone for Black; black goes first instead. + , [(2,0), (0,2)] + , (2,2) : handicapStoneIndices !! 2 + , (0,0) : handicapStoneIndices !! 3 + , (1,1) : handicapStoneIndices !! 4 + , (0,1) : (2,1) : handicapStoneIndices !! 4 + , (1,1) : handicapStoneIndices !! 6 + , (1,0) : (1,2) : handicapStoneIndices !! 6 + , (1,1) : handicapStoneIndices !! 8 + ] + +-- | @handicapStones width height handicap@ returns a list of points where +-- handicap stones should be placed for the given handicap, if handicap points +-- are defined for the given board size, otherwise 'Nothing'. +handicapStones :: Int -> Int -> Int -> Maybe [Coord] +handicapStones width height handicap = + if handicap < 0 || handicap >= length handicapStoneIndices + then Nothing + else do positions <- starLines width height + return $ map (mapTuple (positions !!)) (handicapStoneIndices !! handicap) + +-- | A class for SGF data types that are coercable to and from strings. +-- +-- The construction of an SGF value with 'stringToSgf' may process the input, +-- such that the resulting stringlike value does not represent the same string +-- as the input. In other words, the following does *not* necessarily hold: +-- +-- > sgfToString . stringToSgf = id (does not necessarily hold!) +-- +-- The following does hold, however, for a single stringlike type: +-- +-- > stringToSgf . sgfToString = id +-- +-- The 'String' instance is defined with @sgfToString = stringToSgf = +-- id@. For other types, the string returned by 'sgfToString' is in a +-- raw, user-editable format: characters that need to be escaped in +-- serialized SGF aren't escaped, but the returned value is otherwise +-- similar to SGF format. +class Stringlike a where + -- | Extracts the string value from an SGF value. + sgfToString :: a -> String + + -- | Creates an SGF value from a string value. + stringToSgf :: String -> a + +instance Stringlike String where + sgfToString = id + stringToSgf = id + +-- | Converts between 'Stringlike' types via a string. +-- +-- > convertStringlike = stringToSgf . sgfToString +convertStringlike :: (Stringlike a, Stringlike b) => a -> b +convertStringlike = stringToSgf . sgfToString + +-- | An SGF text value. +newtype Text = Text + { fromText :: String + -- ^ Converts an SGF 'Text' to a string. + } deriving (Eq, Show) + +instance Stringlike Text where + sgfToString = fromText + stringToSgf = toText + +-- | Converts a string to an SGF 'Text'. +toText :: String -> Text +toText = Text + +-- | An SGF SimpleText value. +newtype SimpleText = SimpleText + { fromSimpleText :: String + -- ^ Converts an SGF 'SimpleText' to a string. + } deriving (Eq, Show) + +instance Stringlike SimpleText where + sgfToString = fromSimpleText + stringToSgf = toSimpleText + +sanitizeSimpleText :: String -> String +sanitizeSimpleText = map (\c -> if isSpace c then ' ' else c) + +-- | Converts a string to an SGF 'SimpleText', replacing all whitespaces +-- (including newlines) with spaces. +toSimpleText :: String -> SimpleText +toSimpleText = SimpleText . sanitizeSimpleText + +-- | The value type for an 'UnknownProperty'. Currently represented as a +-- string. +data UnknownPropertyValue = UnknownPropertyValue + { fromUnknownPropertyValue :: String + -- ^ Returns the string contained within the 'UnknownProperty' this value is + -- from. + } deriving (Eq, Show) + +instance Stringlike UnknownPropertyValue where + sgfToString = fromUnknownPropertyValue + stringToSgf = toUnknownPropertyValue + +-- | Constructs a value for a 'UnknownProperty'. +toUnknownPropertyValue :: String -> UnknownPropertyValue +toUnknownPropertyValue = UnknownPropertyValue + +-- | An SGF real value is a decimal number of unspecified precision. +type RealValue = BF.Bigfloat + +-- | An SGF double value: either 1 or 2, nothing else. +data DoubleValue = Double1 + | Double2 + deriving (Eq, Show) + +-- | Stone color: black or white. +data Color = Black + | White + deriving (Eq, Show) + +-- | Returns the logical negation of a stone color, yang for yin and +-- yin for yang. +cnot :: Color -> Color +cnot Black = White +cnot White = Black + +-- | SGF flags that control how move variations are to be presented while +-- displaying the game. +data VariationMode = VariationMode + { variationModeSource :: VariationModeSource + -- ^ Which moves to display as variations. + , variationModeBoardMarkup :: Bool + -- ^ Whether to overlay variations on the board. + } deriving (Eq, Show) + +-- | An enumeration that describes which variations are shown. +data VariationModeSource = + ShowChildVariations + -- ^ Show children of the current move. + | ShowCurrentVariations + -- ^ Show alternatives to the current move. + deriving (Bounded, Enum, Eq, Show) + +-- | The default variation mode as defined by the SGF spec is @VariationMode +-- ShowChildVariations True@. +defaultVariationMode :: VariationMode +defaultVariationMode = VariationMode ShowChildVariations True + +-- | Parses a numeric variation mode, returning nothing if the number is +-- invalid. +toVariationMode :: Int -> Maybe VariationMode +toVariationMode n = case n of + 0 -> Just $ VariationMode ShowChildVariations True + 1 -> Just $ VariationMode ShowCurrentVariations True + 2 -> Just $ VariationMode ShowChildVariations False + 3 -> Just $ VariationMode ShowCurrentVariations False + _ -> Nothing + +-- | Returns the integer value for a variation mode. +fromVariationMode :: VariationMode -> Int +fromVariationMode mode = case mode of + VariationMode ShowChildVariations True -> 0 + VariationMode ShowCurrentVariations True -> 1 + VariationMode ShowChildVariations False -> 2 + VariationMode ShowCurrentVariations False -> 3 + +-- | A list of arrows, each specified as @(startCoord, endCoord)@. +type ArrowList = [(Coord, Coord)] + +-- | A list of lines, each specified as @(startCoord, endCoord)@. +type LineList = [(Coord, Coord)] + +-- | A list of labels, each specified with a string and a coordinate about which +-- to center the string. +type LabelList = [(Coord, SimpleText)] + +-- | The markings that SGF supports annotating coordinates with. +data Mark = MarkCircle | MarkSquare | MarkTriangle | MarkX | MarkSelected + deriving (Bounded, Enum, Eq, Show) + +data GameResult = GameResultWin Color WinReason + | GameResultDraw + | GameResultVoid + | GameResultUnknown + | GameResultOther SimpleText + deriving (Eq, Show) + +instance Stringlike GameResult where + sgfToString result = case result of + GameResultWin color reason -> + (case color of { Black -> 'B'; White -> 'W' }) : '+' : + (case reason of + WinByScore diff -> show diff + WinByResignation -> "R" + WinByTime -> "T" + WinByForfeit -> "F") + GameResultDraw -> "0" + GameResultVoid -> "Void" + GameResultUnknown -> "?" + GameResultOther text -> sgfToString text + + stringToSgf str = case str of + "0" -> GameResultDraw + "Draw" -> GameResultDraw + "Void" -> GameResultVoid + "?" -> GameResultUnknown + _ -> + let result = case str of + 'B':'+':winReasonStr -> parseWin (GameResultWin Black) winReasonStr + 'W':'+':winReasonStr -> parseWin (GameResultWin White) winReasonStr + _ -> unknownResult + parseWin builder winReasonStr = case winReasonStr of + "R" -> builder WinByResignation + "Resign" -> builder WinByResignation + "T" -> builder WinByTime + "Time" -> builder WinByTime + "F" -> builder WinByForfeit + "Forfeit" -> builder WinByForfeit + _ -> case reads winReasonStr of + (score, ""):_ -> builder $ WinByScore score + _ -> unknownResult + unknownResult = GameResultOther $ toSimpleText str + in result + +data WinReason = WinByScore RealValue + | WinByResignation + | WinByTime + | WinByForfeit + deriving (Eq, Show) + +-- | A ruleset used for a Go game. Can be one of the rulesets defined by the +-- SGF specification, or a custom string. +data Ruleset = KnownRuleset RulesetType + | UnknownRuleset String + deriving (Eq, Show) + +instance Stringlike Ruleset where + sgfToString = fromRuleset + stringToSgf = toRuleset + +-- | The rulesets defined by the SGF specification, for use with 'Ruleset'. +data RulesetType = RulesetAga + | RulesetIng + | RulesetJapanese + | RulesetNewZealand + deriving (Bounded, Enum, Eq, Show) + +-- | Returns the string representation for a ruleset. +fromRuleset :: Ruleset -> String +fromRuleset ruleset = case ruleset of + KnownRuleset RulesetAga -> "AGA" + KnownRuleset RulesetIng -> "Goe" + KnownRuleset RulesetJapanese -> "Japanese" + KnownRuleset RulesetNewZealand -> "NZ" + UnknownRuleset str -> str + +-- | Parses a string representation of a ruleset. +toRuleset :: String -> Ruleset +toRuleset str = case str of + "AGA" -> KnownRuleset RulesetAga + "Goe" -> KnownRuleset RulesetIng + "Japanese" -> KnownRuleset RulesetJapanese + "NZ" -> KnownRuleset RulesetNewZealand + _ -> UnknownRuleset str diff --git a/src/Game/Goatee/Sgf/Board.hs b/src/Game/Goatee/Sgf/Board.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Board.hs +++ /dev/null @@ -1,792 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 Bryan Gardiner --- --- Goatee is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- Goatee is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with Goatee. If not, see . - --- | Data structures that wrap and provide a higher-level interface to the SGF --- game tree, including a zipper that navigates the tree and provides the --- current board state. -module Game.Goatee.Sgf.Board ( - RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode, - gameInfoToProperties, - BoardState(..), boardWidth, boardHeight, - CoordState(..), rootBoardState, boardCoordState, mapBoardCoords, - isValidMove, isCurrentValidMove, - Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren, - cursorChildCount, cursorChildPlayingAt, cursorProperties, - cursorModifyNode, - cursorVariations, - colorToMove, - ) where - -import Control.Monad (unless, when) -import Control.Monad.Writer (execWriter, tell) -import Data.List (find, intercalate, nub) -import Data.Maybe (fromMaybe, isJust, isNothing) -import qualified Data.Set as Set -import Game.Goatee.Common -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Tree -import Game.Goatee.Sgf.Types - --- TODO Stop using errors everywhere, they're not testable. - --- | Properties that are specified in the root nodes of game trees. -data RootInfo = RootInfo { rootInfoWidth :: Int - , rootInfoHeight :: Int - , rootInfoVariationMode :: VariationMode - } deriving (Eq, Show) - --- | Properties that are specified in game info nodes. -data GameInfo = GameInfo { gameInfoRootInfo :: RootInfo - - , gameInfoBlackName :: Maybe String - , gameInfoBlackTeamName :: Maybe String - , gameInfoBlackRank :: Maybe String - - , gameInfoWhiteName :: Maybe String - , gameInfoWhiteTeamName :: Maybe String - , gameInfoWhiteRank :: Maybe String - - , gameInfoRuleset :: Maybe Ruleset - , gameInfoBasicTimeSeconds :: Maybe Rational - , gameInfoOvertime :: Maybe String - , gameInfoResult :: Maybe GameResult - - , gameInfoGameName :: Maybe String - , gameInfoGameComment :: Maybe String - , gameInfoOpeningComment :: Maybe String - - , gameInfoEvent :: Maybe String - , gameInfoRound :: Maybe String - , gameInfoPlace :: Maybe String - , gameInfoDatesPlayed :: Maybe String - , gameInfoSource :: Maybe String - , gameInfoCopyright :: Maybe String - - , gameInfoAnnotatorName :: Maybe String - , gameInfoEntererName :: Maybe String - } deriving (Show) - --- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data. -emptyGameInfo :: RootInfo -> GameInfo -emptyGameInfo rootInfo = - GameInfo { gameInfoRootInfo = rootInfo - - , gameInfoBlackName = Nothing - , gameInfoBlackTeamName = Nothing - , gameInfoBlackRank = Nothing - - , gameInfoWhiteName = Nothing - , gameInfoWhiteTeamName = Nothing - , gameInfoWhiteRank = Nothing - - , gameInfoRuleset = Nothing - , gameInfoBasicTimeSeconds = Nothing - , gameInfoOvertime = Nothing - , gameInfoResult = Nothing - - , gameInfoGameName = Nothing - , gameInfoGameComment = Nothing - , gameInfoOpeningComment = Nothing - - , gameInfoEvent = Nothing - , gameInfoRound = Nothing - , gameInfoPlace = Nothing - , gameInfoDatesPlayed = Nothing - , gameInfoSource = Nothing - , gameInfoCopyright = Nothing - - , gameInfoAnnotatorName = Nothing - , gameInfoEntererName = Nothing - } - --- | Returns whether a node contains any game info properties. -internalIsGameInfoNode :: Node -> Bool -internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties - --- | Converts a 'GameInfo' into a list of 'Property's that can be used to --- reconstruct the 'GameInfo'. -gameInfoToProperties :: GameInfo -> [Property] -gameInfoToProperties info = execWriter $ do - copy (PB . toSimpleText) gameInfoBlackName - copy (BT . toSimpleText) gameInfoBlackTeamName - copy (BR . toSimpleText) gameInfoBlackRank - - copy (PW . toSimpleText) gameInfoWhiteName - copy (WT . toSimpleText) gameInfoWhiteTeamName - copy (WR . toSimpleText) gameInfoWhiteRank - - copy RU gameInfoRuleset - copy TM gameInfoBasicTimeSeconds - copy (OT . toSimpleText) gameInfoOvertime - copy RE gameInfoResult - - copy (GN . toSimpleText) gameInfoGameName - copy (GC . toSimpleText) gameInfoGameComment - copy (ON . toSimpleText) gameInfoOpeningComment - - copy (EV . toSimpleText) gameInfoEvent - copy (RO . toSimpleText) gameInfoRound - copy (PC . toSimpleText) gameInfoPlace - copy (DT . toSimpleText) gameInfoDatesPlayed - copy (SO . toSimpleText) gameInfoSource - copy (CP . toSimpleText) gameInfoCopyright - - copy (AN . toSimpleText) gameInfoAnnotatorName - copy (US . toSimpleText) gameInfoEntererName - where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x] - --- | An object that corresponds to a node in some game tree, and represents the --- state of the game at that node, including board position, player turn and --- captures, and also board annotations. -data BoardState = BoardState { - boardCoordStates :: [[CoordState]] - -- ^ The state of individual points on the board. Stored in row-major order. - -- Point @(x, y)@ can be accessed via @!! y !! x@ (but prefer - -- 'boardCoordState'). - , boardHasInvisible :: Bool - -- ^ Whether any of the board's 'CoordState's are invisible. This is an - -- optimization to make it more efficient to set the board to "all visible." - , boardHasDimmed :: Bool - -- ^ Whether any of the board's 'CoordState's are dimmed. This is an - -- optimization to make it more efficient to clear all dimming from the - -- board. - , boardArrows :: ArrowList - , boardLines :: LineList - , boardLabels :: LabelList - , boardMoveNumber :: Integer - , boardPlayerTurn :: Color - , boardBlackCaptures :: Int - , boardWhiteCaptures :: Int - , boardGameInfo :: GameInfo - } - -instance Show BoardState where - show board = concat $ execWriter $ do - tell ["Board: (Move ", show (boardMoveNumber board), - ", ", show (boardPlayerTurn board), "'s turn, B:", - show (boardBlackCaptures board), ", W:", - show (boardWhiteCaptures board), ")\n"] - tell [intercalate "\n" $ flip map (boardCoordStates board) $ - \row -> unwords $ map show row] - - let arrows = boardArrows board - let lines = boardLines board - let labels = boardLabels board - unless (null arrows) $ tell ["\nArrows: ", show arrows] - unless (null lines) $ tell ["\nLines: ", show lines] - unless (null labels) $ tell ["\nLabels: ", show labels] - --- | Returns the width of the board, in stones. -boardWidth :: BoardState -> Int -boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo - --- | Returns the height of the board, in stones. -boardHeight :: BoardState -> Int -boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo - --- | Used by 'BoardState' to represent the state of a single point on the board. --- Records whether a stone is present, as well as annotations and visibility --- properties. -data CoordState = CoordState { coordStar :: Bool - -- ^ Whether this point is a star point. - , coordStone :: Maybe Color - , coordMark :: Maybe Mark - , coordVisible :: Bool - , coordDimmed :: Bool - } - -instance Show CoordState where - show c = if not $ coordVisible c - then "--" - else let stoneChar = case coordStone c of - Nothing -> if coordStar c then '*' else '\'' - Just Black -> 'X' - Just White -> 'O' - markChar = case coordMark c of - Nothing -> ' ' - Just MarkCircle -> 'o' - Just MarkSquare -> 's' - Just MarkTriangle -> 'v' - Just MarkX -> 'x' - Just MarkSelected -> '!' - in [stoneChar, markChar] - --- | Creates a 'BoardState' for an empty board of the given width and height. -emptyBoardState :: Int -> Int -> BoardState -emptyBoardState width height = - BoardState { boardCoordStates = coords - , boardHasInvisible = False - , boardHasDimmed = False - , boardArrows = [] - , boardLines = [] - , boardLabels = [] - , boardMoveNumber = 0 - , boardPlayerTurn = Black - , boardBlackCaptures = 0 - , boardWhiteCaptures = 0 - , boardGameInfo = emptyGameInfo rootInfo - } - where rootInfo = RootInfo { rootInfoWidth = width - , rootInfoHeight = height - , rootInfoVariationMode = defaultVariationMode - } - emptyCoord = CoordState { coordStar = False - , coordStone = Nothing - , coordMark = Nothing - , coordVisible = True - , coordDimmed = False - } - starCoord = emptyCoord { coordStar = True } - isStarPoint' = isStarPoint width height - coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord) - [0..width-1]) - [0..height-1] - -rootBoardState :: Node -> BoardState -rootBoardState rootNode = - foldr applyProperty - (emptyBoardState width height) - (nodeProperties rootNode) - where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ - findProperty propertySZ rootNode - --- | Returns the 'CoordState' for a coordinate on a board. -boardCoordState :: Coord -> BoardState -> CoordState -boardCoordState (x, y) board = boardCoordStates board !! y !! x - --- | Maps a function over each 'CoordState' in a 'BoardState', returning a --- list-of-lists with the function's values. The function is called like @fn y --- x coordState@. -mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]] -mapBoardCoords fn board = - zipWith applyRow [0..] $ boardCoordStates board - where applyRow y = zipWith (fn y) [0..] - --- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a --- 'BoardState'. -updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState -updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo -> - gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo } - --- | Applies a function to update the 'GameInfo' of a 'BoardState'. -updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState -updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board } - --- | Performs necessary updates to a 'BoardState' between nodes in the tree. --- Clears marks. -boardChild :: BoardState -> BoardState -boardChild board = - board { boardCoordStates = map (map clearMark) $ boardCoordStates board - , boardArrows = [] - , boardLines = [] - , boardLabels = [] - } - where clearMark coord = case coordMark coord of - Nothing -> coord - Just _ -> coord { coordMark = Nothing } - --- | Sets all points on a board to be visible (if given true) or invisible (if --- given false). -setBoardVisible :: Bool -> BoardState -> BoardState -setBoardVisible visible board = - if visible - then if boardHasInvisible board - then board { boardCoordStates = map (map $ setVisible True) $ boardCoordStates board - , boardHasInvisible = False - } - else board - else board { boardCoordStates = map (map $ setVisible False) $ boardCoordStates board - , boardHasInvisible = True - } - where setVisible vis coord = coord { coordVisible = vis } - --- | Resets all points on a board not to be dimmed. -clearBoardDimmed :: BoardState -> BoardState -clearBoardDimmed board = - if boardHasDimmed board - then board { boardCoordStates = map (map clearDim) $ boardCoordStates board - , boardHasDimmed = False - } - else board - where clearDim coord = coord { coordDimmed = False } - --- |> isStarPoint width height x y --- --- Returns whether @(x, y)@ is a known star point on a board of the given width --- and height. -isStarPoint :: Int -> Int -> Int -> Int -> Bool -isStarPoint width height - | width == 9 && height == 9 = isStarPoint9 - | width == 13 && height == 13 = isStarPoint13 - | width == 19 && height == 19 = isStarPoint19 - | otherwise = const $ const False - -isStarPoint' :: [Int] -> Int -> Int -> Bool -isStarPoint' ixs x y = x `elem` ixs && y `elem` ixs - -isStarPoint9, isStarPoint13, isStarPoint19 :: Int -> Int -> Bool -isStarPoint9 = isStarPoint' [2, 4, 6] -isStarPoint13 = isStarPoint' [3, 6, 9] -isStarPoint19 = isStarPoint' [3, 9, 15] - --- | Applies a property to a 'BoardState'. This function covers all properties --- that modify 'BoardState's, including making moves, adding markup, and so on. -applyProperty :: Property -> BoardState -> BoardState - -applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of - Nothing -> board -- Pass. - Just xy -> getApplyMoveResult board $ - applyMove playTheDarnMoveGoParams Black xy board -applyProperty KO board = board -applyProperty (MN moveNum) board = board { boardMoveNumber = moveNum } -applyProperty (W maybeXy) board = updateBoardForMove White $ case maybeXy of - Nothing -> board -- Pass. - Just xy -> getApplyMoveResult board $ - applyMove playTheDarnMoveGoParams White xy board - -applyProperty (AB coords) board = - updateCoordStates' (\state -> state { coordStone = Just Black }) coords board -applyProperty (AW coords) board = - updateCoordStates' (\state -> state { coordStone = Just White }) coords board -applyProperty (AE coords) board = - updateCoordStates' (\state -> state { coordStone = Nothing }) coords board -applyProperty (PL color) board = board { boardPlayerTurn = color } - -applyProperty (C {}) board = board -applyProperty (DM {}) board = board -applyProperty (GB {}) board = board -applyProperty (GW {}) board = board -applyProperty (HO {}) board = board -applyProperty (N {}) board = board -applyProperty (UC {}) board = board -applyProperty (V {}) board = board - -applyProperty (BM {}) board = board -applyProperty (DO {}) board = board -applyProperty (IT {}) board = board -applyProperty (TE {}) board = board - -applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board } -applyProperty (CR coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board -applyProperty (DD coords) board = - let coords' = expandCoordList coords - board' = clearBoardDimmed board - in if null coords' - then board' - else updateCoordStates (\state -> state { coordDimmed = True }) coords' - board { boardHasDimmed = True } -applyProperty (LB labels) board = board { boardLabels = labels ++ boardLabels board } -applyProperty (LN lines) board = board { boardLines = lines ++ boardLines board } -applyProperty (MA coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords board -applyProperty (SL coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board -applyProperty (SQ coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board -applyProperty (TR coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board - -applyProperty (AP {}) board = board -applyProperty (CA {}) board = board -applyProperty (FF {}) board = board -applyProperty (GM {}) board = board -applyProperty (ST variationMode) board = - updateRootInfo (\info -> info { rootInfoVariationMode = variationMode }) board -applyProperty (SZ {}) board = board - -applyProperty (AN str) board = - updateBoardInfo (\info -> info { gameInfoAnnotatorName = Just $ fromSimpleText str }) - board -applyProperty (BR str) board = - updateBoardInfo (\info -> info { gameInfoBlackRank = Just $ fromSimpleText str }) - board -applyProperty (BT str) board = - updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just $ fromSimpleText str }) - board -applyProperty (CP str) board = - updateBoardInfo (\info -> info { gameInfoCopyright = Just $ fromSimpleText str }) - board -applyProperty (DT str) board = - updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just $ fromSimpleText str }) - board -applyProperty (EV str) board = - updateBoardInfo (\info -> info { gameInfoEvent = Just $ fromSimpleText str }) - board -applyProperty (GC str) board = - updateBoardInfo (\info -> info { gameInfoGameComment = Just $ fromSimpleText str }) - board -applyProperty (GN str) board = - updateBoardInfo (\info -> info { gameInfoGameName = Just $ fromSimpleText str }) - board -applyProperty (ON str) board = - updateBoardInfo (\info -> info { gameInfoOpeningComment = Just $ fromSimpleText str }) - board -applyProperty (OT str) board = - updateBoardInfo (\info -> info { gameInfoOvertime = Just $ fromSimpleText str }) - board -applyProperty (PB str) board = - updateBoardInfo (\info -> info { gameInfoBlackName = Just $ fromSimpleText str }) - board -applyProperty (PC str) board = - updateBoardInfo (\info -> info { gameInfoPlace = Just $ fromSimpleText str }) - board -applyProperty (PW str) board = - updateBoardInfo (\info -> info { gameInfoWhiteName = Just $ fromSimpleText str }) - board -applyProperty (RE result) board = - updateBoardInfo (\info -> info { gameInfoResult = Just result }) - board -applyProperty (RO str) board = - updateBoardInfo (\info -> info { gameInfoRound = Just $ fromSimpleText str }) - board -applyProperty (RU ruleset) board = - updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset }) - board -applyProperty (SO str) board = - updateBoardInfo (\info -> info { gameInfoSource = Just $ fromSimpleText str }) - board -applyProperty (TM seconds) board = - updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds }) - board -applyProperty (US str) board = - updateBoardInfo (\info -> info { gameInfoEntererName = Just $ fromSimpleText str }) - board -applyProperty (WR str) board = - updateBoardInfo (\info -> info { gameInfoWhiteRank = Just $ fromSimpleText str }) - board -applyProperty (WT str) board = - updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just $ fromSimpleText str }) - board - -applyProperty (VW coords) board = - let coords' = expandCoordList coords - in if null coords' - then setBoardVisible True board - else updateCoordStates (\state -> state { coordVisible = True }) coords' $ - setBoardVisible False board - -applyProperty (UnknownProperty {}) board = board - -applyProperties :: Node -> BoardState -> BoardState -applyProperties node board = foldr applyProperty board (nodeProperties node) - --- | Applies the transformation function to all of a board's coordinates --- referred to by the 'CoordList'. -updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState -updateCoordStates fn coords board = - board { boardCoordStates = foldr applyFn (boardCoordStates board) coords } - where applyFn (x, y) = listUpdate (updateRow x) y - updateRow = listUpdate fn - -updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState -updateCoordStates' fn coords = updateCoordStates fn (expandCoordList coords) - --- | Updates properties of a 'BoardState' given that the player of the given --- color has just made a move. Increments the move number and updates the --- player turn. -updateBoardForMove :: Color -> BoardState -> BoardState -updateBoardForMove movedPlayer board = - board { boardMoveNumber = boardMoveNumber board + 1 - , boardPlayerTurn = cnot movedPlayer - } - --- | A structure that configures how 'applyMove' should handle moves that are --- normally illegal in Go. -data ApplyMoveParams = ApplyMoveParams { allowSuicide :: Bool - -- ^ If false, suicide will cause 'applyMove' to return - -- 'ApplyMoveSuicideError'. If true, suicide will kill the - -- friendly group and give points to the opponent. - , allowOverwrite :: Bool - -- ^ If false, playing on an occupied point will cause - -- 'applyMove' to return 'ApplyMoveOverwriteError' with the - -- color of the stone occupying the point. If true, - -- playing on an occupied point will overwrite the point - -- (the previous stone vanishes), then capture rules are - -- applied as normal. - } deriving (Show) - --- | As an argument to 'applyMove', causes illegal moves to be treated as --- errors. -standardGoMoveParams :: ApplyMoveParams -standardGoMoveParams = ApplyMoveParams { allowSuicide = False - , allowOverwrite = False - } - --- | As an argument to 'applyMove', causes illegal moves to be played --- unconditionally. -playTheDarnMoveGoParams :: ApplyMoveParams -playTheDarnMoveGoParams = ApplyMoveParams { allowSuicide = True - , allowOverwrite = True - } - --- | The possible results from 'applyMove'. -data ApplyMoveResult = ApplyMoveOk BoardState - -- ^ The move was accepted; playing it resulted in the - -- given board without capture. - | ApplyMoveCapture BoardState Color Int - -- ^ The move was accepted; playing it resulted in the - -- given board with a capture. The specified side gained - -- the number of points given. - | ApplyMoveSuicideError - -- ^ Playing the move would result in suicide, which is - -- forbidden. - | ApplyMoveOverwriteError Color - -- ^ There is already a stone of the specified color on - -- the target point, and overwriting is forbidden. - --- | If the 'ApplyMoveResult' represents a successful move, then the resulting --- 'BoardState' is returned, otherwise, the default 'BoardState' given is --- returned. -getApplyMoveResult :: BoardState -> ApplyMoveResult -> BoardState -getApplyMoveResult defaultBoard result = fromMaybe defaultBoard $ getApplyMoveResult' result - -getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState -getApplyMoveResult' result = case result of - ApplyMoveOk board -> Just board - ApplyMoveCapture board color points -> Just $ case color of - Black -> board { boardBlackCaptures = boardBlackCaptures board + points } - White -> board { boardWhiteCaptures = boardWhiteCaptures board + points } - ApplyMoveSuicideError -> Nothing - ApplyMoveOverwriteError _ -> Nothing - --- | Internal data structure, only for move application code. Represents a --- group of stones. -data ApplyMoveGroup = ApplyMoveGroup { applyMoveGroupOrigin :: Coord - , applyMoveGroupCoords :: [Coord] - , applyMoveGroupLiberties :: Int - } deriving (Show) - --- | Places a stone of a color at a point on a board, and runs move validation --- and capturing logic according to the given parameters. Returns whether the --- move was successful, and the result if so. -applyMove :: ApplyMoveParams -> Color -> Coord -> BoardState -> ApplyMoveResult -applyMove params color xy board = - let currentStone = coordStone $ boardCoordState xy board - in case currentStone of - Just color -> if allowOverwrite params - then moveResult - else ApplyMoveOverwriteError color - Nothing -> moveResult - where boardWithMove = updateCoordStates (\state -> state { coordStone = Just color }) - [xy] - board - (boardWithCaptures, points) = foldr (maybeCapture $ cnot color) - (boardWithMove, 0) - (adjacentPoints boardWithMove xy) - playedGroup = computeGroup boardWithCaptures xy - moveResult - | applyMoveGroupLiberties playedGroup == 0 = - if points /= 0 - then error "Cannot commit suicide and capture at the same time." - else if allowSuicide params - then let (boardWithSuicide, suicidePoints) = - applyMoveCapture (boardWithCaptures, 0) playedGroup - in ApplyMoveCapture boardWithSuicide (cnot color) suicidePoints - else ApplyMoveSuicideError - | points /= 0 = ApplyMoveCapture boardWithCaptures color points - | otherwise = ApplyMoveOk boardWithCaptures - --- | Capture if there is a liberty-less group of a color at a point on --- a board. Removes captured stones from the board and accumulates --- points for captured stones. -maybeCapture :: Color -> Coord -> (BoardState, Int) -> (BoardState, Int) -maybeCapture color xy result@(board, _) = - if coordStone (boardCoordState xy board) /= Just color - then result - else let group = computeGroup board xy - in if applyMoveGroupLiberties group /= 0 - then result - else applyMoveCapture result group - -computeGroup :: BoardState -> Coord -> ApplyMoveGroup -computeGroup board xy = - if isNothing (coordStone $ boardCoordState xy board) - then error "computeGroup called on an empty point." - else let groupCoords = bucketFill board xy - in ApplyMoveGroup { applyMoveGroupOrigin = xy - , applyMoveGroupCoords = groupCoords - , applyMoveGroupLiberties = getLibertiesOfGroup board groupCoords - } - -applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int) -applyMoveCapture (board, points) group = - (updateCoordStates (\state -> state { coordStone = Nothing }) - (applyMoveGroupCoords group) - board, - points + length (applyMoveGroupCoords group)) - --- | Returns a list of the four coordinates that are adjacent to the --- given coordinate on the board, excluding coordinates that are out --- of bounds. -adjacentPoints :: BoardState -> Coord -> [Coord] -adjacentPoints board (x, y) = execWriter $ do - when (x > 0) $ tell [(x - 1, y)] - when (y > 0) $ tell [(x, y - 1)] - when (x < boardWidth board - 1) $ tell [(x + 1, y)] - when (y < boardHeight board - 1) $ tell [(x, y + 1)] - --- | Takes a list of coordinates that comprise a group (e.g. a list --- returned from 'bucketFill') and returns the number of liberties the --- group has. Does no error checking to ensure that the list refers --- to a single or maximal group. -getLibertiesOfGroup :: BoardState -> [Coord] -> Int -getLibertiesOfGroup board groupCoords = - length $ nub $ concatMap findLiberties groupCoords - where findLiberties xy = filter (\xy' -> isNothing $ coordStone $ boardCoordState xy' board) - (adjacentPoints board xy) - --- | Expands a single coordinate on a board into a list of all the --- coordinates connected to it by some continuous path of stones of --- the same color (or empty spaces). -bucketFill :: BoardState -> Coord -> [Coord] -bucketFill board xy0 = bucketFill' Set.empty [xy0] - where bucketFill' known [] = Set.toList known - bucketFill' known (xy:xys) = - if Set.member xy known - then bucketFill' known xys - else let new = filter ((stone0 ==) . coordStone . flip boardCoordState board) - (adjacentPoints board xy) - in bucketFill' (Set.insert xy known) (new ++ xys) - stone0 = coordStone $ boardCoordState xy0 board - --- | Returns whether it is legal to place a stone of the given color at a point --- on a board. Accepts out-of-bound coordinates and returns false. -isValidMove :: BoardState -> Color -> Coord -> Bool --- TODO Should out-of-bound coordinates be accepted? -isValidMove board color coord@(x, y) = - let w = boardWidth board - h = boardHeight board - in x >= 0 && y >= 0 && x < w && y < h && - isJust (getApplyMoveResult' $ applyMove standardGoMoveParams color coord board) - --- | Returns whether it is legal for the current player to place a stone at a --- point on a board. Accepts out-of-bound coordinates and returns false. -isCurrentValidMove :: BoardState -> Coord -> Bool -isCurrentValidMove board = isValidMove board (boardPlayerTurn board) - --- | A pointer to a node in a game tree that also holds information --- about the current state of the game at that node. -data Cursor = Cursor { cursorParent :: Maybe Cursor - -- ^ The cursor 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. - , cursorChildIndex :: Int - -- ^ The index of this cursor's node in its parent's - -- child list. When the cursor's node has no parent, - -- the value in this field is not specified. - , cursorNode :: Node - -- ^ The game tree node about which the cursor stores - -- information. - , cursorBoard :: BoardState - -- ^ The complete board state for the current node. - } deriving (Show) -- TODO Better Show Cursor instance. - --- | Returns a cursor for a root node. -rootCursor :: Node -> Cursor -rootCursor node = - Cursor { cursorParent = Nothing - , cursorChildIndex = -1 - , cursorNode = node - , cursorBoard = rootBoardState node - } - -cursorRoot :: Cursor -> Cursor -cursorRoot cursor = case cursorParent cursor of - Nothing -> cursor - Just parent -> cursorRoot parent - -cursorChild :: Cursor -> Int -> Cursor -cursorChild cursor index = - Cursor { cursorParent = Just cursor - , cursorChildIndex = index - , cursorNode = child - , cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor - } - -- TODO Better handling or messaging for out-of-bounds: - where child = (!! index) $ nodeChildren $ cursorNode cursor - -cursorChildren :: Cursor -> [Cursor] -cursorChildren cursor = - let board = boardChild $ cursorBoard cursor - in map (\(index, child) -> Cursor { cursorParent = Just cursor - , cursorChildIndex = index - , cursorNode = child - , cursorBoard = applyProperties child board - }) - $ zip [0..] - $ nodeChildren - $ cursorNode cursor - -cursorChildCount :: Cursor -> Int -cursorChildCount = length . nodeChildren . cursorNode - -cursorChildPlayingAt :: Coord -> Cursor -> Maybe Cursor -cursorChildPlayingAt coord cursor = - let children = cursorChildren cursor - color = boardPlayerTurn $ cursorBoard cursor - hasMove = elem $ colorToMove color coord - in find (hasMove . nodeProperties . cursorNode) children - --- | This is simply @'nodeProperties' . 'cursorNode'@. -cursorProperties :: Cursor -> [Property] -cursorProperties = nodeProperties . cursorNode - -cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor -cursorModifyNode fn cursor = - let node' = fn $ cursorNode cursor - in case cursorParent cursor of - Nothing -> rootCursor node' - Just parentCursor -> - let index = cursorChildIndex cursor - parentCursor' = cursorModifyNode - (\parentNode -> - parentNode { nodeChildren = listUpdate (const node') - index - (nodeChildren parentNode) - }) - parentCursor - in cursorChild parentCursor' index - --- | Returns the variations to display for a cursor. The returned list contains --- the location and color of 'B' and 'W' properties in variation nodes. --- Variation nodes are either children of the current node, or siblings of the --- current node, depending on the variation mode source. -cursorVariations :: VariationModeSource -> Cursor -> [(Coord, Color)] -cursorVariations source cursor = - case source of - ShowChildVariations -> collectPlays $ nodeChildren $ cursorNode cursor - ShowCurrentVariations -> - case cursorParent cursor of - Nothing -> [] - Just parent -> collectPlays $ listDeleteIndex (cursorChildIndex cursor) $ - nodeChildren $ cursorNode parent - where collectPlays :: [Node] -> [(Coord, Color)] - collectPlays = concatMap collectPlays' - collectPlays' = concatMap collectPlays'' . nodeProperties - collectPlays'' prop = case prop of - B (Just xy) -> [(xy, Black)] - W (Just xy) -> [(xy, White)] - _ -> [] - -colorToMove :: Color -> Coord -> Property -colorToMove color coord = - case color of - Black -> B $ Just coord - White -> W $ Just coord diff --git a/src/Game/Goatee/Sgf/Monad.hs b/src/Game/Goatee/Sgf/Monad.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Monad.hs +++ /dev/null @@ -1,690 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | A monad for working with game trees. -module Game.Goatee.Sgf.Monad ( - -- * The Go monad - GoT, GoM, - runGoT, runGo, - evalGoT, evalGo, - execGoT, execGo, - getCursor, getCoordState, - -- * Navigation - Step(..), goUp, goDown, goToRoot, goToGameInfoNode, - -- * Remembering positions - pushPosition, popPosition, dropPosition, - -- * Properties - getProperties, - modifyProperties, - getProperty, - getPropertyValue, - putProperty, - deleteProperty, - modifyProperty, - modifyPropertyValue, - modifyPropertyString, - modifyPropertyCoords, - modifyGameInfo, - modifyVariationMode, - getMark, - modifyMark, - -- * Children - addChild, - -- * Event handling - Event, on, fire, - -- * Events - childAddedEvent, ChildAddedHandler, - gameInfoChangedEvent, GameInfoChangedHandler, - navigationEvent, NavigationHandler, - propertiesModifiedEvent, PropertiesModifiedHandler, - variationModeChangedEvent, VariationModeChangedHandler, - ) where - -import Control.Applicative ((<$>), Applicative ((<*>), pure)) -import Control.Monad (ap, liftM, when) -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) -import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer) -import qualified Control.Monad.State as State -import Control.Monad.State (StateT) -import Data.List (delete, find, mapAccumL, nub) -import Data.Maybe (fromMaybe, isJust, isNothing) -import Game.Goatee.Common -import Game.Goatee.Sgf.Board -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Tree hiding (addChild) -import Game.Goatee.Sgf.Types - --- | The internal state of a Go monad transformer. @go@ is the type of --- Go monad or transformer (instance of 'GoMonad'). -data GoState go = GoState { stateCursor :: Cursor - -- ^ The current position in the game tree. - , statePathStack :: PathStack - -- ^ The current path stack. - - -- Event handlers. - , stateChildAddedHandlers :: [ChildAddedHandler go] - -- ^ Handlers for 'childAddedEvent'. - , stateGameInfoChangedHandlers :: [GameInfoChangedHandler go] - -- ^ Handlers for 'gameInfoChangedEvent'. - , stateNavigationHandlers :: [NavigationHandler go] - -- ^ Handlers for 'navigationEvent'. - , statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go] - -- ^ Handlers for 'propertiesModifiedEvent'. - , stateVariationModeChangedHandlers :: [VariationModeChangedHandler go] - -- ^ Handlers for 'variationModeChangedEvent'. - } - --- | A path stack is a record of previous places visited in a game tree. It is --- encoded a list of paths (steps) to each previous memorized position. --- --- The positions saved in calls to 'pushPosition' correspond to entries in the --- outer list here, with the first sublist representing the last call. The --- sublist contains the steps in order that will trace the path back to the --- saved position. -type PathStack = [[Step]] - --- | A simplified constructor function for 'GoState'. -initialState :: Cursor -> GoState m -initialState cursor = GoState { stateCursor = cursor - , statePathStack = [] - , stateChildAddedHandlers = [] - , stateGameInfoChangedHandlers = [] - , stateNavigationHandlers = [] - , statePropertiesModifiedHandlers = [] - , stateVariationModeChangedHandlers = [] - } - --- | A single step along a game tree. Either up or down. -data Step = GoUp Int - -- ^ Represents a step up from a child with the given index. - | GoDown Int - -- ^ Represents a step down to the child with the given index. - deriving (Eq, Show) - --- | Reverses a step, such that taking a step then it's reverse will leave you --- where you started. -reverseStep :: Step -> Step -reverseStep step = case step of - GoUp index -> GoDown index - GoDown index -> GoUp index - --- | Takes a 'Step' from a 'Cursor', returning a new 'Cursor'. -takeStep :: Step -> Cursor -> Cursor -takeStep (GoUp _) cursor = fromMaybe (error $ "takeStep: Can't go up from " ++ show cursor ++ ".") $ - cursorParent cursor -takeStep (GoDown index) cursor = cursorChild cursor index - --- | Internal function. Takes a 'Step' in the Go monad. Updates the path stack --- accordingly. -takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m () -takeStepM step = case step of - GoUp _ -> goUp' - GoDown index -> goDown' index - --- | A monad (transformer) for navigating and mutating 'Cursor's, and --- remembering previous locations. See 'GoT' and 'GoM'. --- --- The monad supports handlers for events raised during actions it takes, such --- as navigating through the tree and modifying nodes. -class Monad go => MonadGo go where - -- | Returns the current cursor. - getCursor :: go Cursor - - -- | Returns the 'CoordState' at the given point. - getCoordState :: Coord -> go CoordState - getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor - - -- | Navigates up the tree. It must be valid to do so, otherwise 'fail' is - -- called. Fires a 'navigationEvent' after moving. - goUp :: go () - - -- | Navigates down the tree to the child with the given index. The child - -- must exist. Fires a 'navigationEvent' after moving. - goDown :: Int -> go () - - -- | Navigates up to the root of the tree. Fires 'navigationEvent's for each - -- step. - goToRoot :: go () - - -- | Navigates up the tree to the node containing game info properties, if - -- any. Returns true if a game info node was found. - goToGameInfoNode :: Bool - -- ^ When no node with game info is found, then if false, - -- return to the original node, otherwise finish at the - -- root node. - -> go Bool - - -- | Pushes the current location in the game tree onto an internal position - -- stack, such that 'popPosition' is capable of navigating back to the same - -- position, even if the game tree has been modified (though the old position - -- must still exist in the tree to return to it). - pushPosition :: go () - - -- | Returns to the last position pushed onto the internal position stack via - -- 'pushPosition'. This action must be balanced by a 'pushPosition'. - popPosition :: go () - - -- | Drops the last position pushed onto the internal stack by 'pushPosition' - -- off of the stack. This action must be balanced by a 'pushPosition'. - dropPosition :: go () - - -- | Returns the set of properties on the current node. - getProperties :: go [Property] - getProperties = liftM cursorProperties getCursor - - -- | Modifies the set of properties on the current node. - -- - -- The given function must end on the same node on which it started. - modifyProperties :: ([Property] -> go [Property]) -> go () - - -- | Searches for a property on the current node, returning it if found. - getProperty :: Descriptor d => d -> go (Maybe Property) - - -- | Searches for a valued property on the current node, returning its value - -- if found. - getPropertyValue :: ValuedDescriptor d v => d -> go (Maybe v) - getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor - - -- | Sets a property on the current node, replacing an existing property with - -- the same name, if one exists. - putProperty :: Property -> go () - putProperty property = modifyProperty (propertyInfo property) $ const $ Just property - - -- | Deletes a property from the current node, if it's set. - -- - -- Note that although a 'Property' is a 'Descriptor', giving a valued - -- @Property@ here will not cause deletion to match on the value of the - -- property. That is, the following code will result in 'Nothing', because - -- the deletion only cares about the name of the property. - -- - -- > do putProperty $ PL Black - -- > deleteProperty $ PL White - -- > getPropertyValue propertyPL - deleteProperty :: Descriptor d => d -> go () - deleteProperty descriptor = modifyProperty descriptor $ const Nothing - - -- | Calls the given function to modify the state of the given property - -- (descriptor) on the current node. 'Nothing' represents the property not - -- existing on the node, and a 'Just' marks the property's presence. This - -- function does not do any validation to check that the resulting tree state - -- is valid. - modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go () - - -- | Calls the given function to modify the state of the given valued property - -- (descriptor) on the current node. 'Nothing' represents the property not - -- existing on the node, and a 'Just' with the property's value marks the - -- property's presence. This function does not do any validation to check - -- that the resulting tree state is valid. - modifyPropertyValue :: ValuedDescriptor d v => d -> (Maybe v -> Maybe v) -> go () - modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old -> - propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old) - - -- | Mutates the string-valued property attached to the current node according - -- to the given function. The input string will be empty if the current node - -- either has the property with an empty value, or doesn't have the property. - -- Returning an empty string removes the property from the node, if it was - -- set. - modifyPropertyString :: (Stringlike s, ValuedDescriptor d s) => d -> (String -> String) -> go () - modifyPropertyString descriptor fn = - modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of - "" -> Nothing - str -> let sgf = stringToSgf str - -- Because stringToSgf might do processing, we have to check - -- the conversion back to a string for emptiness. - in if null $ sgfToString sgf then Nothing else Just sgf - - -- | Mutates the 'CoordList'-valued property attached to the current node - -- according to the given function. Conversion between @CoordList@ and - -- @[Coord]@ is performed automatically. The input list will be empty if the - -- current node either has the property with an empty value, or doesn't have - -- the property. Returning an empty list removes the property from the node, - -- if it was set. - -- - -- Importantly, this might not be specific enough for properties such as 'DD' - -- and 'VW' where a present, empty list has different semantics from the - -- property not being present. In that case, 'modifyPropertyValue' is better. - modifyPropertyCoords :: ValuedDescriptor d CoordList => d -> ([Coord] -> [Coord]) -> go () - modifyPropertyCoords descriptor fn = - modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of - [] -> Nothing - coords -> Just $ buildCoordList coords - - -- | Mutates the game info for the current path, returning the new info. If - -- the current node or one of its ancestors has game info properties, then - -- that node is modified. Otherwise, properties are inserted on the root - -- node. - modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo - - -- | Sets the game's 'VariationMode' via the 'ST' property on the root node, - -- then fires a 'variationModeChangedEvent' if the variation mode has changed. - modifyVariationMode :: (VariationMode -> VariationMode) -> go () - - -- | Returns the 'Mark' at a point on the current node. - getMark :: Coord -> go (Maybe Mark) - getMark = liftM coordMark . getCoordState - - -- | Calls the given function to modify the presence of a 'Mark' on the - -- current node. - modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go () - modifyMark fn coord = do - maybeOldMark <- getMark coord - case (maybeOldMark, fn maybeOldMark) of - (Just oldMark, Nothing) -> remove oldMark - (Nothing, Just newMark) -> add newMark - (Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark - (Just _, Just _) -> return () - (Nothing, Nothing) -> return () - where remove mark = modifyPropertyCoords (markProperty mark) (delete coord) - add mark = modifyPropertyCoords (markProperty mark) (coord:) - - -- | Adds a child node to the current node at the given index, shifting all - -- existing children at and after the index to the right. The index must in - -- the range @[0, numberOfChildren]@. Fires a 'childAddedEvent' after the - -- child is added. - addChild :: Int -> Node -> go () - - -- | Registers a new event handler for a given event type. - on :: Event go h -> h -> go () - --- | The regular monad transformer for 'MonadGo'. -newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a } - --- | The regular monad for 'MonadGo'. -type GoM = GoT Identity - -instance Monad m => Functor (GoT m) where - fmap = liftM - -instance Monad m => Applicative (GoT m) where - pure = return - (<*>) = ap - -instance Monad m => Monad (GoT m) where - return x = GoT $ return x - m >>= f = GoT $ goState . f =<< goState m - fail = lift . fail - -instance MonadTrans GoT where - lift = GoT . lift - -instance MonadIO m => MonadIO (GoT m) where - liftIO = lift . liftIO - -instance MonadWriter w m => MonadWriter w (GoT m) where - writer = lift . writer - tell = lift . tell - listen = GoT . listen . goState - pass = GoT . pass . goState - --- | Executes a Go monad transformer on a cursor, returning in the underlying --- monad a tuple that contains the resulting value and the final cursor. -runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor) -runGoT go cursor = do - (value, state) <- State.runStateT (goState go) (initialState cursor) - return (value, stateCursor state) - --- | Executes a Go monad transformer on a cursor, returning in the underlying --- monad the value in the transformer. -evalGoT :: Monad m => GoT m a -> Cursor -> m a -evalGoT go cursor = liftM fst $ runGoT go cursor - --- | Executes a Go monad transformer on a cursor, returning in the underlying --- monad the final cursor. -execGoT :: Monad m => GoT m a -> Cursor -> m Cursor -execGoT go cursor = liftM snd $ runGoT go cursor - --- | Runs a Go monad on a cursor. See 'runGoT'. -runGo :: GoM a -> Cursor -> (a, Cursor) -runGo go = runIdentity . runGoT go - --- | Runs a Go monad on a cursor and returns the value in the monad. -evalGo :: GoM a -> Cursor -> a -evalGo m cursor = fst $ runGo m cursor - --- | Runs a Go monad on a cursor and returns the final cursor. -execGo :: GoM a -> Cursor -> Cursor -execGo m cursor = snd $ runGo m cursor - -getState :: Monad m => GoT m (GoState (GoT m)) -getState = GoT State.get - -putState :: Monad m => GoState (GoT m) -> GoT m () -putState = GoT . State.put - -modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m () -modifyState = GoT . State.modify - -instance Monad m => MonadGo (GoT m) where - getCursor = liftM stateCursor getState - - goUp = do - index <- liftM cursorChildIndex getCursor - goUp' $ \pathStack -> case pathStack of - [] -> pathStack - path:paths -> (GoDown index:path):paths - - goDown index = goDown' index $ \pathStack -> case pathStack of - [] -> pathStack - path:paths -> (GoUp index:path):paths - - goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp - - goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode - where findGameInfoNode = do - cursor <- getCursor - if hasGameInfo cursor - then dropPosition >> return True - else if isNothing $ cursorParent cursor - then do if goToRootIfNotFound then dropPosition else popPosition - return False - else goUp >> findGameInfoNode - hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor - - pushPosition = modifyState $ \state -> - state { statePathStack = []:statePathStack state } - - popPosition = do - getPathStack >>= \stack -> when (null stack) $ - fail "popPosition: No position to pop from the stack." - - -- Drop each step in the top list of the path stack one at a time, until the - -- top list is empty. - whileM' (do path:_ <- getPathStack - return $ if null path then Nothing else Just $ head path) $ - flip takeStepM $ \((_:steps):paths) -> steps:paths - - -- Finally, drop the empty top of the path stack. - modifyState $ \state -> case statePathStack state of - []:rest -> state { statePathStack = rest } - _ -> error "popPosition: Internal failure, top of path stack is not empty." - - dropPosition = do - state <- getState - -- If there are >=2 positions on the path stack, then we can't simply drop - -- the moves that will return us to the top-of-stack position, because they - -- may still be needed to return to the second-on-stack position by a - -- following popPosition. - case statePathStack state of - x:y:xs -> putState $ state { statePathStack = (x ++ y):xs } - _:[] -> putState $ state { statePathStack = [] } - [] -> fail "dropPosition: No position to drop from the stack." - - modifyProperties fn = do - oldCursor <- getCursor - let oldProperties = cursorProperties oldCursor - newProperties <- fn oldProperties - modifyState $ \state -> - state { stateCursor = cursorModifyNode - (\node -> node { nodeProperties = newProperties }) - oldCursor - } - fire propertiesModifiedEvent (\f -> f oldProperties newProperties) - - -- The current game info changes when modifying game info properties on the - -- current node. I think comparing game info properties should be faster - -- than comparing 'GameInfo's. - let filterToGameInfo = nub . filter ((GameInfoProperty ==) . propertyType) - oldGameInfo = filterToGameInfo oldProperties - newGameInfo = filterToGameInfo newProperties - when (newGameInfo /= oldGameInfo) $ do - newCursor <- getCursor - fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard oldCursor) - (boardGameInfo $ cursorBoard newCursor)) - - getProperty descriptor = find (propertyPredicate descriptor) <$> getProperties - - modifyProperty descriptor fn = do - cursor <- getCursor - let node = cursorNode cursor - old = findProperty descriptor node - new = fn old - when (maybe False (not . propertyPredicate descriptor) new) $ - fail $ "modifyProperty: May not change property type: " ++ - show old ++ " -> " ++ show new ++ "." - case (old, new) of - (Just _, Nothing) -> modifyProperties $ return . remove descriptor - (Nothing, Just value') -> modifyProperties $ return . add value' - (Just value, Just value') | value /= value' -> - modifyProperties $ return . add value' . remove descriptor - _ -> return () - where remove descriptor = filter (not . propertyPredicate descriptor) - add value = (value:) - - modifyGameInfo fn = do - cursor <- getCursor - let info = boardGameInfo $ cursorBoard cursor - info' = fn info - when (gameInfoRootInfo info /= gameInfoRootInfo info') $ - fail "Illegal modification of root info in modifyGameInfo." - pushPosition - goToGameInfoNode True - modifyProperties $ \props -> - return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props - popPosition - return info' - - modifyVariationMode fn = do - pushPosition - goToRoot - modifyPropertyValue propertyST $ \maybeOld -> - -- If the new variation mode is equal to the old effective variation mode - -- (effective applying the default if the property isn't present), then - -- leave the property unchanged. Otherwise, apply the new variation mode, - -- deleting the property if the default variation mode is selected. We - -- don't delete the property if @maybeOld == Just new == Just - -- defaultVariationMode@, because we don't want to trigger dirtyness - -- unnecessarily. - let old = fromMaybe defaultVariationMode maybeOld - new = fn old - in if new == old - then maybeOld - else if new == defaultVariationMode - then Nothing - else Just new - popPosition - - addChild index node = do - cursor <- getCursor - let childCount = cursorChildCount cursor - when (index < 0 || index > childCount) $ fail $ - "Monad.addChild: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]." - let cursor' = cursorModifyNode (addChildAt index node) cursor - modifyState $ \state -> - state { stateCursor = cursor' - , statePathStack = updatePathStackCurrentNode - (\step -> case step of - GoUp n -> GoUp $ if n < index then n else n + 1 - down@(GoDown _) -> down) - (\step -> case step of - up@(GoUp _) -> up - GoDown n -> GoDown $ if n < index then n else n + 1) - cursor' - (statePathStack state) - } - fire childAddedEvent (\f -> f index (cursorChild cursor' index)) - - on event handler = modifyState $ addHandler event handler - --- | Takes a step up the game tree, updates the path stack according to the --- given function, then fires navigation and game info changed events as --- appropriate. -goUp' :: Monad m => (PathStack -> PathStack) -> GoT m () -goUp' pathStackFn = do - state@(GoState { stateCursor = cursor - , statePathStack = pathStack - }) <- getState - case cursorParent cursor of - Nothing -> fail $ "goUp': Can't go up from a root cursor: " ++ show cursor - Just parent -> do - let index = cursorChildIndex cursor - putState state { stateCursor = parent - , statePathStack = pathStackFn pathStack - } - fire navigationEvent ($ GoUp index) - - -- The current game info changes when navigating up from a node that has - -- game info properties. - when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $ - fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) - (boardGameInfo $ cursorBoard parent)) - --- | Takes a step down the game tree, updates the path stack according to the --- given function, then fires navigation and game info changed events as --- appropriate. -goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m () -goDown' index pathStackFn = do - state@(GoState { stateCursor = cursor - , statePathStack = pathStack - }) <- getState - case drop index $ cursorChildren cursor of - [] -> fail $ "goDown': Cursor does not have a child #" ++ show index ++ ": " ++ show cursor - child:_ -> do - putState state { stateCursor = child - , statePathStack = pathStackFn pathStack - } - fire navigationEvent ($ GoDown index) - - -- The current game info changes when navigating down to a node that has - -- game info properties. - when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $ - fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) - (boardGameInfo $ cursorBoard child)) - --- | Returns the current path stack. -getPathStack :: Monad m => GoT m PathStack -getPathStack = liftM statePathStack getState - --- | Maps over a path stack, updating with the given functions all steps that --- enter and leave the cursor's current node. -updatePathStackCurrentNode :: (Step -> Step) - -> (Step -> Step) - -> Cursor - -> PathStack - -> PathStack -updatePathStackCurrentNode _ _ _ [] = [] -updatePathStackCurrentNode onEnter onExit cursor0 paths = - snd $ mapAccumL updatePath (cursor0, []) paths - where updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [Step]) - updatePath = mapAccumL updateStep - updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), Step) - updateStep (cursor, []) step = ((takeStep step cursor, [reverseStep step]), onExit step) - updateStep (cursor, pathToInitial@(stepToInitial:restToInitial)) step = - let pathToInitial' = if stepToInitial == step - then restToInitial - else reverseStep step:pathToInitial - in ((takeStep step cursor, pathToInitial'), - if null pathToInitial' then onEnter step else step) - --- | Fires all of the handlers for the given event, using the given function to --- create a Go action from each of the handlers (normally themselves functions --- that create Go actions, if they're not just Go actions directly, depending on --- the event). -fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m () -fire event handlerGenerator = do - state <- getState - mapM_ handlerGenerator $ eventStateGetter event state - --- | A type of event in the Go monad transformer that can be handled by --- executing an action. @go@ is the type of the type of the Go --- monad/transformer. @h@ is the type of monad or monadic function which will --- be used by Go actions that can trigger the event. For example, a navigation --- event is characterized by a 'Step' that cannot easily be recovered from the --- regular monad state, and comparing before-and-after states would be a pain. --- So @h@ for navigation events is @'Step' -> go ()@; a handler takes a 'Step' --- and returns a Go action to run as a result. -data Event go h = Event { eventName :: String - , eventStateGetter :: GoState go -> [h] - , eventStateSetter :: [h] -> GoState go -> GoState go - } - -instance Show (Event go h) where - show = eventName - -addHandler :: Event go h -> h -> GoState go -> GoState go -addHandler event handler state = - eventStateSetter event (eventStateGetter event state ++ [handler]) state - --- | An event corresponding to a child node being added to the current node. -childAddedEvent :: Event go (ChildAddedHandler go) -childAddedEvent = Event { - eventName = "childAddedEvent" - , eventStateGetter = stateChildAddedHandlers - , eventStateSetter = \handlers state -> state { stateChildAddedHandlers = handlers } - } - --- | A handler for 'childAddedEvent's. -type ChildAddedHandler go = Int -> Cursor -> go () - --- | An event that is fired when the current game info changes, either by --- navigating past a node with game info properties, or by modifying the current --- game info properties. -gameInfoChangedEvent :: Event go (GameInfoChangedHandler go) -gameInfoChangedEvent = Event { - eventName = "gameInfoChangedEvent" - , eventStateGetter = stateGameInfoChangedHandlers - , eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers } - } - --- | A handler for 'gameInfoChangedEvent's. It is called with the old game info --- then the new game info. -type GameInfoChangedHandler go = GameInfo -> GameInfo -> go () - --- | An event that is fired when a single step up or down in a game tree is --- made. -navigationEvent :: Event go (NavigationHandler go) -navigationEvent = Event { - eventName = "navigationEvent" - , eventStateGetter = stateNavigationHandlers - , eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers } - } - --- | A handler for 'navigationEvent's. --- --- A navigation handler may navigate further, but beware infinite recursion. A --- navigation handler must end on the same node on which it started. -type NavigationHandler go = Step -> go () - --- | An event corresponding to a modification to the properties list of the --- current node. -propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go) -propertiesModifiedEvent = Event { - eventName = "propertiesModifiedEvent" - , eventStateGetter = statePropertiesModifiedHandlers - , eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers } - } - --- | A handler for 'propertiesModifiedEvent's. It is called with the old --- property list then the new property list. -type PropertiesModifiedHandler go = [Property] -> [Property] -> go () - --- | An event corresponding to a change in the active 'VariationMode'. This can --- happen when modifying the 'ST' property, and also when navigating between --- collections (as they have different root nodes). -variationModeChangedEvent :: Event go (VariationModeChangedHandler go) -variationModeChangedEvent = Event { - eventName = "variationModeChangedEvent" - , eventStateGetter = stateVariationModeChangedHandlers - , eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers } - } --- TODO Test that this is fired when moving between root nodes in a collection. --- For now, since we don't support multiple trees in a collection, we don't need --- to worry about checking for active variation mode change on navigation. - --- | A handler for 'variationModeChangedEvent's. It is called with the old --- variation mode then the new variation mode. -type VariationModeChangedHandler go = VariationMode -> VariationMode -> go () diff --git a/src/Game/Goatee/Sgf/Parser.hs b/src/Game/Goatee/Sgf/Parser.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Parser.hs +++ /dev/null @@ -1,113 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | A parser for reading SGF files. -module Game.Goatee.Sgf.Parser ( - parseString, - parseFile, - ) where - -import Control.Applicative ((<*), (*>)) -import Data.Maybe (fromMaybe) -import Game.Goatee.Common -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Tree -import Game.Goatee.Sgf.Types -import Text.ParserCombinators.Parsec ( - (), Parser, char, eof, many, many1, parse, spaces, upper, - ) - --- | Parses a string in SGF format. Returns an error string if parsing fails. -parseString :: String -> Either String Collection -parseString str = case parse collection "" str of - Left err -> Left $ show err - Right (Collection roots) -> onLeft concatErrors $ - onRight Collection $ - andEithers $ - map processRoot roots - where processRoot :: Node -> Either String Node - processRoot = checkFormatVersion . ttToPass - - -- Ensures that we are parsing an SGF version that we understand. - -- TODO Try to proceed, if it makes sense. - checkFormatVersion :: Node -> Either String Node - checkFormatVersion root = - let version = case findProperty propertyFF root of - Nothing -> defaultFormatVersion - Just (FF x) -> x - x -> error $ "Expected FF or nothing, received " ++ show x ++ "." - in if version `elem` supportedFormatVersions - then Right root - else Left $ - "Unsupported SGF version " ++ show version ++ ". Only versions " ++ - show supportedFormatVersions ++ " are supported." - - -- SGF allows B[tt] and W[tt] to represent passes on boards <=19x19. - -- Convert any passes from this format to B[] and W[] in a root node and - -- its descendents. - ttToPass :: Node -> Node - ttToPass root = - let SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ - findProperty propertySZ root - in if width <= 19 && height <= 19 - then ttToPass' width height root - else root - - -- Convert a node and its descendents. - ttToPass' width height node = - node { nodeProperties = map ttToPass'' $ nodeProperties node - , nodeChildren = map (ttToPass' width height) $ nodeChildren node - } - - -- Convert a property. - ttToPass'' prop = case prop of - B (Just (19, 19)) -> B Nothing - W (Just (19, 19)) -> W Nothing - _ -> prop - - concatErrors errs = "The following errors occurred while parsing:" ++ - concatMap ("\n-> " ++) errs - --- | Parses a file in SGF format. Returns an error string if parsing fails. -parseFile :: String -> IO (Either String Collection) -parseFile = fmap parseString . readFile - -collection :: Parser Collection -collection = fmap Collection (spaces *> many (gameTree <* spaces) <* eof) - "collection" - -gameTree :: Parser Node -gameTree = do - char '(' - nodes <- spaces *> many1 (node <* spaces) "sequence" - subtrees <- many (gameTree <* spaces) "subtrees" - char ')' - let (sequence, [final]) = splitAt (length nodes - 1) nodes - return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] }) - (final { nodeChildren = subtrees }) - sequence - -node :: Parser Node -node = fmap (\props -> emptyNode { nodeProperties = props }) - (char ';' *> spaces *> many (property <* spaces) - "node") - -property :: Parser Property -property = do - name <- many1 upper - spaces - propertyValueParser $ descriptorForName name diff --git a/src/Game/Goatee/Sgf/Property.hs b/src/Game/Goatee/Sgf/Property.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Property.hs +++ /dev/null @@ -1,27 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | Structures and functions for working with SGF node properties. -module Game.Goatee.Sgf.Property ( - module Game.Goatee.Sgf.Property.Base, - module Game.Goatee.Sgf.Property.Info, - PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, - ) where - -import Game.Goatee.Sgf.Property.Base -import Game.Goatee.Sgf.Property.Info -import Game.Goatee.Sgf.Property.Value diff --git a/src/Game/Goatee/Sgf/Property/Base.hs b/src/Game/Goatee/Sgf/Property/Base.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Property/Base.hs +++ /dev/null @@ -1,314 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_HADDOCK hide #-} - --- | Core property-related data types, and some Template Haskell declarations --- for defining property metadata. --- --- Import "Game.Goatee.Sgf.Property" rather than importing this module. -module Game.Goatee.Sgf.Property.Base ( - -- * Properties - Property (..), - -- * Property metadata - PropertyType (..), - Descriptor (..), - SomeDescriptor (..), - ValuedDescriptor (..), - PropertyInfo, - ValuedPropertyInfo (ValuedPropertyInfo), - -- * Property declaration - defProperty, defValuedProperty, - ) where - -import Control.Applicative ((<$)) -import Game.Goatee.Sgf.Property.Value (PropertyValueType(..), nonePvt) -import Game.Goatee.Sgf.Renderer -import Game.Goatee.Sgf.Types -import Language.Haskell.TH ( - Info (DataConI), DecsQ, Name, Type (AppT), - appE, appT, caseE, conE, conP, conT, lam1E, match, mkName, newName, - normalB, recP, reify, sigD, stringE, valD, varE, varP, wildP, - ) -import Text.ParserCombinators.Parsec (Parser) - --- | An SGF property that gives a node meaning. -data Property = - -- Move properties. - B (Maybe Coord) -- ^ Black move (nothing iff pass). - | KO -- ^ Execute move unconditionally (even if illegal). - | MN Integer -- ^ Assign move number. - | W (Maybe Coord) -- ^ White move (nothing iff pass). - - -- Setup properties. - | AB CoordList -- ^ Assign black stones. - | AE CoordList -- ^ Assign empty stones. - | AW CoordList -- ^ Assign white stones. - | PL Color -- ^ Player to play. - - -- Node annotation properties. - | C Text -- ^ Comment. - | DM DoubleValue -- ^ Even position. - | GB DoubleValue -- ^ Good for black. - | GW DoubleValue -- ^ Good for white. - | HO DoubleValue -- ^ Hotspot. - | N SimpleText -- ^ Node name. - | UC DoubleValue -- ^ Unclear position. - | V RealValue -- ^ Node value. - - -- Move annotation properties. - | BM DoubleValue -- ^ Bad move. - | DO -- ^ Doubtful move. - | IT -- ^ Interesting move. - | TE DoubleValue -- ^ Tesuji. - - -- Markup properties. - | AR ArrowList -- ^ Arrows. - | CR CoordList -- ^ Mark points with circles. - | DD CoordList -- ^ Dim points. - | LB LabelList -- ^ Label points with text. - | LN LineList -- ^ Lines. - | MA CoordList -- ^ Mark points with 'X's. - | SL CoordList -- ^ Mark points as selected. - | SQ CoordList -- ^ Mark points with squares. - | TR CoordList -- ^ Mark points with trianges. - - -- Root properties. - | AP SimpleText SimpleText -- ^ Application info. - | CA SimpleText -- ^ Charset for SimpleText and Text. - | FF Int -- ^ File format version. - | GM Int -- ^ Game (must be 1 = Go). - | ST VariationMode -- ^ Variation display format. - | SZ Int Int -- ^ Board size, columns then rows. - - -- Game info properties. - | AN SimpleText -- ^ Name of annotator. - | BR SimpleText -- ^ Rank of black player. - | BT SimpleText -- ^ Name of black team. - | CP SimpleText -- ^ Copyright info. - | DT SimpleText -- ^ Dates played. - | EV SimpleText -- ^ Event name. - | GC SimpleText -- ^ Game comment, or background, or summary. - | GN SimpleText -- ^ Game name. - | ON SimpleText -- ^ Information about the opening. - | OT SimpleText -- ^ The method used for overtime. - | PB SimpleText -- ^ Name of black player. - | PC SimpleText -- ^ Where the game was played. - | PW SimpleText -- ^ Name of white player. - | RE GameResult -- ^ Result of the game. - | RO SimpleText -- ^ Round info. - | RU Ruleset -- ^ Ruleset used. - | SO SimpleText -- ^ Source of the game. - | TM RealValue -- ^ Time limit, in seconds. - | US SimpleText -- ^ Name of user or program who entered the game. - | WR SimpleText -- ^ Rank of white player. - | WT SimpleText -- ^ Name of white team. - - -- Miscellaneous properties. - | VW CoordList -- ^ Set viewing region. - - | UnknownProperty String UnknownPropertyValue - - -- TODO Game info, timing, and miscellaneous properties. - -- Also in functions below. - deriving (Eq, Show) - --- | The property types that SGF uses to group properties. -data PropertyType = MoveProperty -- ^ Cannot mix with setup nodes. - | SetupProperty -- ^ Cannot mix with move nodes. - | RootProperty -- ^ May only appear in root nodes. - | GameInfoProperty -- ^ At most one on any path. - | GeneralProperty -- ^ May appear anywhere in the game tree. - deriving (Eq, Show) - --- | A class for types that contain metadata about a 'Property'. -class Descriptor a where - -- | Returns the name of the property, as used in SGF files. - propertyName :: a -> String - - -- | Returns the type of the property, as specified by the SGF spec. - propertyType :: a -> PropertyType - - -- | Returns whether the value of the given property is inherited from the - -- lowest ancestor specifying the property, when the property is not set on a - -- node itself. - propertyInherited :: a -> Bool - - -- | Returns whether the given property has the type of a descriptor. - propertyPredicate :: a -> Property -> Bool - - -- | A parser of property values in SGF format (e.g. @"[ab]"@ for a property - -- that takes a point). - propertyValueParser :: a -> Parser Property - - -- | A renderer property values to SGF format (e.g. @B (Just (1,2))@ renders - -- to @"[ab]"@). - propertyValueRenderer :: a -> Property -> Render () - - -- | A renderer for displaying property values in a UI. Displays the value in - -- a human-readable format. - propertyValueRendererPretty :: a -> Property -> Render () - -data SomeDescriptor = forall a. Descriptor a => SomeDescriptor a - -instance Descriptor SomeDescriptor where - propertyName (SomeDescriptor d) = propertyName d - propertyType (SomeDescriptor d) = propertyType d - propertyInherited (SomeDescriptor d) = propertyInherited d - propertyPredicate (SomeDescriptor d) = propertyPredicate d - propertyValueParser (SomeDescriptor d) = propertyValueParser d - propertyValueRenderer (SomeDescriptor d) = propertyValueRenderer d - propertyValueRendererPretty (SomeDescriptor d) = propertyValueRendererPretty d - --- | A class for 'Descriptor's of 'Property's that also contain values. -class (Descriptor a, Eq v) => ValuedDescriptor a v | a -> v where - -- | Extracts the value from a property of the given type. Behaviour is - -- undefined if the property is not of the given type. - propertyValue :: a -> Property -> v - - -- | Builds a property from a given value. - propertyBuilder :: a -> v -> Property - --- | Metadata for a property that does not contain a value. Corresponds to a --- single nullary data constructor of 'Property'. -data PropertyInfo = PropertyInfo { - propertyInfoName :: String - -- ^ The SGF textual name for the property. - , propertyInfoInstance :: Property - -- ^ The single instance of the property. - , propertyInfoType :: PropertyType - -- ^ The SGF property type. - , propertyInfoInherited :: Bool - -- ^ Whether the property is inherited. - } - -instance Descriptor PropertyInfo where - propertyName = propertyInfoName - propertyType = propertyInfoType - propertyInherited = propertyInfoInherited - propertyPredicate = (==) . propertyInfoInstance - propertyValueParser descriptor = propertyInfoInstance descriptor <$ pvtParser nonePvt - propertyValueRenderer _ _ = pvtRenderer nonePvt () - propertyValueRendererPretty _ _ = pvtRendererPretty nonePvt () - --- | Metadata for a property that contains a value. Corresponds to a single --- unary data constructor of 'Property'. -data ValuedPropertyInfo v = ValuedPropertyInfo { - valuedPropertyInfoName :: String - -- ^ The SGF textual name for the property (also the name of the data - -- constructor). - , valuedPropertyInfoType :: PropertyType - -- ^ The SGF property type. - , valuedPropertyInfoInherited :: Bool - -- ^ Whether the property is inherited. - , valuedPropertyInfoPredicate :: Property -> Bool - -- ^ A predicate that matches predicates to which this 'ValuedPropertyInfo' - -- applies. - , valuedPropertyInfoValueType :: PropertyValueType v - -- ^ Metadata about the type of the property's value. - , valuedPropertyInfoValue :: Property -> v - -- ^ A function that extracts values from properties to which this - -- 'ValuedPropertyInfo' applies. It is invalid to call this function with a - -- different type of property. - , valuedPropertyInfoBuilder :: v -> Property - -- ^ A function that builds a property containing a value. - } - -instance Descriptor (ValuedPropertyInfo v) where - propertyName = valuedPropertyInfoName - propertyType = valuedPropertyInfoType - propertyInherited = valuedPropertyInfoInherited - propertyPredicate = valuedPropertyInfoPredicate - propertyValueParser descriptor = - fmap (valuedPropertyInfoBuilder descriptor) $ - pvtParser $ - valuedPropertyInfoValueType descriptor - propertyValueRenderer descriptor property = - pvtRenderer (valuedPropertyInfoValueType descriptor) $ - valuedPropertyInfoValue descriptor property - propertyValueRendererPretty descriptor property = - pvtRendererPretty (valuedPropertyInfoValueType descriptor) $ - valuedPropertyInfoValue descriptor property - -instance Eq v => ValuedDescriptor (ValuedPropertyInfo v) v where - propertyValue = valuedPropertyInfoValue - propertyBuilder = valuedPropertyInfoBuilder - --- | Template Haskell function to declare a property that does not contain a --- value. --- --- > $(defProperty "KO" 'MoveProperty False) --- --- This example declares a @propertyKO :: 'PropertyInfo'@ that is a --- 'MoveProperty' and is not inherited. -defProperty :: String - -- ^ The SGF textual name of the property. - -> Name - -- ^ The name of the 'PropertyType'. - -> Bool - -- ^ Whether the property is inherited. - -> DecsQ -defProperty name propType inherited = do - let propName = mkName name - varName = mkName $ "property" ++ name - foo <- newName "foo" - sequence [ - sigD varName $ conT $ mkName "PropertyInfo", - valD (varP varName) - (normalB [| PropertyInfo name $(conE propName) $(conE propType) inherited |]) - [] - ] - --- | Template Haskell function to declare a property that contains a value. --- --- > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter) --- --- This example declares a @propertyB :: 'ValuedPropertyInfo' (Maybe 'Coord')@ --- that is a 'MoveProperty' and is not inherited. The value type is --- automatically inferred. -defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ -defValuedProperty name propType inherited valueType = do - let propName = mkName name - varName = mkName $ "property" ++ name - foo <- newName "foo" - bar <- newName "bar" - DataConI _ (AppT (AppT _ haskellValueType) _) _ _ <- reify propName - sequence [ - sigD varName $ appT (conT ''ValuedPropertyInfo) $ return haskellValueType, - valD (varP varName) - (normalB [| ValuedPropertyInfo - name - $(conE propType) - inherited - $(lam1E (varP foo) $ caseE (varE foo) - [match (recP propName []) - (normalB $ conE $ mkName "True") - [], - match wildP (normalB $ conE $ mkName "False") []]) - $(varE valueType) - $(lam1E (varP foo) $ caseE (varE foo) - [match (conP propName [varP bar]) (normalB $ varE bar) [], - match wildP - (normalB - [| error $ "Property value getter for " ++ $(stringE name) ++ - " applied to " ++ show $(varE foo) ++ "." |]) - []]) - $(lam1E (varP foo) $ appE (conE propName) (varE foo)) - |]) - [] - ] diff --git a/src/Game/Goatee/Sgf/Property/Info.hs b/src/Game/Goatee/Sgf/Property/Info.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Property/Info.hs +++ /dev/null @@ -1,288 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_HADDOCK hide #-} - --- | Property metadata declarations. --- --- Import "Game.Goatee.Sgf.Property" rather than importing this module. -module Game.Goatee.Sgf.Property.Info where - -import Control.Arrow ((&&&)) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Game.Goatee.Sgf.Property.Base -import Game.Goatee.Sgf.Property.Value -import Game.Goatee.Sgf.Types - --- Move properties. -$(defValuedProperty "B" 'MoveProperty False 'movePvt) -$(defProperty "KO" 'MoveProperty False) -$(defValuedProperty "MN" 'MoveProperty False 'integralPvt) -$(defValuedProperty "W" 'MoveProperty False 'movePvt) - --- Setup properties. -$(defValuedProperty "AB" 'SetupProperty False 'coordListPvt) -$(defValuedProperty "AE" 'SetupProperty False 'coordListPvt) -$(defValuedProperty "AW" 'SetupProperty False 'coordListPvt) -$(defValuedProperty "PL" 'SetupProperty False 'colorPvt) - --- Node annotation properties. -$(defValuedProperty "C" 'GeneralProperty False 'textPvt) -$(defValuedProperty "DM" 'GeneralProperty False 'doublePvt) -$(defValuedProperty "GB" 'GeneralProperty False 'doublePvt) -$(defValuedProperty "GW" 'GeneralProperty False 'doublePvt) -$(defValuedProperty "HO" 'GeneralProperty False 'doublePvt) -$(defValuedProperty "N" 'GeneralProperty False 'simpleTextPvt) -$(defValuedProperty "UC" 'GeneralProperty False 'doublePvt) -$(defValuedProperty "V" 'GeneralProperty False 'realPvt) - --- Move annotation properties. -$(defValuedProperty "BM" 'MoveProperty False 'doublePvt) -$(defProperty "DO" 'MoveProperty False) -$(defProperty "IT" 'MoveProperty False) -$(defValuedProperty "TE" 'MoveProperty False 'doublePvt) - --- Markup properties. -$(defValuedProperty "AR" 'GeneralProperty False 'coordPairListPvt) -$(defValuedProperty "CR" 'GeneralProperty False 'coordListPvt) -$(defValuedProperty "DD" 'GeneralProperty True 'coordListPvt) -$(defValuedProperty "LB" 'GeneralProperty False 'labelListPvt) -$(defValuedProperty "LN" 'GeneralProperty False 'coordPairListPvt) -$(defValuedProperty "MA" 'GeneralProperty False 'coordListPvt) -$(defValuedProperty "SL" 'GeneralProperty False 'coordListPvt) -$(defValuedProperty "SQ" 'GeneralProperty False 'coordListPvt) -$(defValuedProperty "TR" 'GeneralProperty False 'coordListPvt) - --- Root properties. -propertyAP :: ValuedPropertyInfo (SimpleText, SimpleText) -propertyAP = ValuedPropertyInfo "AP" RootProperty False - (\x -> case x of { AP {} -> True; _ -> False }) - simpleTextPairPvt - (\(AP x y) -> (x, y)) - (uncurry AP) -$(defValuedProperty "CA" 'RootProperty False 'simpleTextPvt) -$(defValuedProperty "FF" 'RootProperty False 'integralPvt) -- TODO Add parser validation. -$(defValuedProperty "GM" 'RootProperty False 'integralPvt) -- TODO Add parser validation. -$(defValuedProperty "ST" 'RootProperty False 'variationModePvt) -propertySZ :: ValuedPropertyInfo (Int, Int) -propertySZ = ValuedPropertyInfo "SZ" RootProperty False - (\x -> case x of { SZ {} -> True; _ -> False }) - sizePvt - (\(SZ x y) -> (x, y)) - (uncurry SZ) - --- Game info properties. -$(defValuedProperty "AN" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "BR" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "BT" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "CP" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "DT" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "EV" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "GC" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "GN" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "ON" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "OT" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "PB" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "PC" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "PW" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "RE" 'GameInfoProperty False 'gameResultPvt) -$(defValuedProperty "RO" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "RU" 'GameInfoProperty False 'rulesetPvt) -$(defValuedProperty "SO" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "TM" 'GameInfoProperty False 'realPvt) -$(defValuedProperty "US" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "WR" 'GameInfoProperty False 'simpleTextPvt) -$(defValuedProperty "WT" 'GameInfoProperty False 'simpleTextPvt) - --- Miscellaneous properties. -$(defValuedProperty "VW" 'GeneralProperty True 'coordElistPvt) - -propertyUnknown :: String -> ValuedPropertyInfo UnknownPropertyValue -propertyUnknown name = - ValuedPropertyInfo name GeneralProperty False - (\x -> case x of - UnknownProperty name' _ | name' == name -> True - _ -> False) - unknownPropertyPvt - (\(UnknownProperty _ value) -> value) - (UnknownProperty name) - -allDescriptors :: [SomeDescriptor] -allDescriptors = [ - SomeDescriptor propertyB - , SomeDescriptor propertyKO - , SomeDescriptor propertyMN - , SomeDescriptor propertyW - - , SomeDescriptor propertyAB - , SomeDescriptor propertyAE - , SomeDescriptor propertyAW - , SomeDescriptor propertyPL - - , SomeDescriptor propertyC - , SomeDescriptor propertyDM - , SomeDescriptor propertyGB - , SomeDescriptor propertyGW - , SomeDescriptor propertyHO - , SomeDescriptor propertyN - , SomeDescriptor propertyUC - , SomeDescriptor propertyV - - , SomeDescriptor propertyBM - , SomeDescriptor propertyDO - , SomeDescriptor propertyIT - , SomeDescriptor propertyTE - - , SomeDescriptor propertyAR - , SomeDescriptor propertyCR - , SomeDescriptor propertyDD - , SomeDescriptor propertyLB - , SomeDescriptor propertyLN - , SomeDescriptor propertyMA - , SomeDescriptor propertySL - , SomeDescriptor propertySQ - , SomeDescriptor propertyTR - - , SomeDescriptor propertyAP - , SomeDescriptor propertyCA - , SomeDescriptor propertyFF - , SomeDescriptor propertyGM - , SomeDescriptor propertyST - , SomeDescriptor propertySZ - - , SomeDescriptor propertyAN - , SomeDescriptor propertyBR - , SomeDescriptor propertyBT - , SomeDescriptor propertyCP - , SomeDescriptor propertyDT - , SomeDescriptor propertyEV - , SomeDescriptor propertyGC - , SomeDescriptor propertyGN - , SomeDescriptor propertyON - , SomeDescriptor propertyOT - , SomeDescriptor propertyPB - , SomeDescriptor propertyPC - , SomeDescriptor propertyPW - , SomeDescriptor propertyRE - , SomeDescriptor propertyRO - , SomeDescriptor propertyRU - , SomeDescriptor propertySO - , SomeDescriptor propertyTM - , SomeDescriptor propertyUS - , SomeDescriptor propertyWR - , SomeDescriptor propertyWT - - , SomeDescriptor propertyVW - ] - -propertyInfo :: Property -> SomeDescriptor -propertyInfo property = case property of - B {} -> SomeDescriptor propertyB - KO {} -> SomeDescriptor propertyKO - MN {} -> SomeDescriptor propertyMN - W {} -> SomeDescriptor propertyW - - AB {} -> SomeDescriptor propertyAB - AE {} -> SomeDescriptor propertyAE - AW {} -> SomeDescriptor propertyAW - PL {} -> SomeDescriptor propertyPL - - C {} -> SomeDescriptor propertyC - DM {} -> SomeDescriptor propertyDM - GB {} -> SomeDescriptor propertyGB - GW {} -> SomeDescriptor propertyGW - HO {} -> SomeDescriptor propertyHO - N {} -> SomeDescriptor propertyN - UC {} -> SomeDescriptor propertyUC - V {} -> SomeDescriptor propertyV - - BM {} -> SomeDescriptor propertyBM - DO {} -> SomeDescriptor propertyDO - IT {} -> SomeDescriptor propertyIT - TE {} -> SomeDescriptor propertyTE - - AR {} -> SomeDescriptor propertyAR - CR {} -> SomeDescriptor propertyCR - DD {} -> SomeDescriptor propertyDD - LB {} -> SomeDescriptor propertyLB - LN {} -> SomeDescriptor propertyLN - MA {} -> SomeDescriptor propertyMA - SL {} -> SomeDescriptor propertySL - SQ {} -> SomeDescriptor propertySQ - TR {} -> SomeDescriptor propertyTR - - AP {} -> SomeDescriptor propertyAP - CA {} -> SomeDescriptor propertyCA - FF {} -> SomeDescriptor propertyFF - GM {} -> SomeDescriptor propertyGM - ST {} -> SomeDescriptor propertyST - SZ {} -> SomeDescriptor propertySZ - - AN {} -> SomeDescriptor propertyAN - BR {} -> SomeDescriptor propertyBR - BT {} -> SomeDescriptor propertyBT - CP {} -> SomeDescriptor propertyCP - DT {} -> SomeDescriptor propertyDT - EV {} -> SomeDescriptor propertyEV - GC {} -> SomeDescriptor propertyGC - GN {} -> SomeDescriptor propertyGN - ON {} -> SomeDescriptor propertyON - OT {} -> SomeDescriptor propertyOT - PB {} -> SomeDescriptor propertyPB - PC {} -> SomeDescriptor propertyPC - PW {} -> SomeDescriptor propertyPW - RE {} -> SomeDescriptor propertyRE - RO {} -> SomeDescriptor propertyRO - RU {} -> SomeDescriptor propertyRU - SO {} -> SomeDescriptor propertySO - TM {} -> SomeDescriptor propertyTM - US {} -> SomeDescriptor propertyUS - WR {} -> SomeDescriptor propertyWR - WT {} -> SomeDescriptor propertyWT - - VW {} -> SomeDescriptor propertyVW - - UnknownProperty name _ -> SomeDescriptor $ propertyUnknown name - -instance Descriptor Property where - propertyName = propertyName . propertyInfo - propertyType = propertyType . propertyInfo - propertyInherited = propertyInherited . propertyInfo - propertyPredicate = propertyPredicate . propertyInfo - propertyValueParser = propertyValueParser . propertyInfo - propertyValueRenderer = propertyValueRenderer . propertyInfo - propertyValueRendererPretty = propertyValueRendererPretty . propertyInfo - -descriptorsByName :: Map String SomeDescriptor -descriptorsByName = Map.fromList $ map (propertyName &&& id) allDescriptors - -descriptorForName :: String -> SomeDescriptor -descriptorForName name = fromMaybe (SomeDescriptor $ propertyUnknown name) $ descriptorForName' name - -descriptorForName' :: String -> Maybe SomeDescriptor -descriptorForName' = flip Map.lookup descriptorsByName - --- | Returns the descriptor for a mark. -markProperty :: Mark -> ValuedPropertyInfo CoordList -markProperty MarkCircle = propertyCR -markProperty MarkSelected = propertySL -markProperty MarkSquare = propertySQ -markProperty MarkTriangle = propertyTR -markProperty MarkX = propertyMA diff --git a/src/Game/Goatee/Sgf/Property/Parser.hs b/src/Game/Goatee/Sgf/Property/Parser.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Property/Parser.hs +++ /dev/null @@ -1,275 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | Parsers of property values. --- --- Import "Game.Goatee.Sgf.Property" rather than importing this module. -module Game.Goatee.Sgf.Property.Parser ( - colorParser, - coordElistParser, - coordListParser, - coordPairListParser, - doubleParser, - gameResultParser, - labelListParser, - moveParser, - noneParser, - integralParser, - realParser, - rulesetParser, - simpleTextPairParser, - simpleTextParser, - sizeParser, - textParser, - unknownPropertyParser, - variationModeParser, - -- * Exposed for testing - compose, - line, - simpleText, - text, - ) where - -import Control.Applicative ((<$), (<$>), (<*), (<*>), (*>)) -import Control.Monad (when) -import Data.Char (isUpper, ord) -import Data.Maybe (catMaybes) -import Data.Monoid (Monoid, mappend, mconcat, mempty) -import Game.Goatee.Sgf.Types -import Text.ParserCombinators.Parsec ( - (), (<|>), Parser, - anyChar, char, choice, digit, eof, many, many1, - noneOf, oneOf, option, parse, space, spaces, string, - try, unexpected, - ) - -{-# ANN module "HLint: ignore Reduce duplication" #-} - --- Internal parser builders not corresponding to any particular value type. - --- | A wrapper around 'CoordList' with a 'Monoid' instance used for parsing. --- The monoid does simple concatenation of the single and rectangle lists, so it --- is not appropriate for @CoordList@ proper, as it doesn't do duplicate removal --- between two @CoordList@s. -newtype CoordListMonoid = CoordListMonoid { runCoordListMonoid :: CoordList } - -instance Monoid CoordListMonoid where - mempty = CoordListMonoid emptyCoordList - - mappend (CoordListMonoid x) (CoordListMonoid y) = - CoordListMonoid $ coords' (coordListSingles x ++ coordListSingles y) - (coordListRects x ++ coordListRects y) - -single :: Parser a -> Parser a -single valueParser = char '[' *> valueParser <* char ']' - -compose :: Parser a -> Parser b -> Parser (a, b) -compose first second = do - x <- first - char ':' - y <- second - return (x, y) - -line :: Parser Int -line = toLine <$> line' "line" - where line' = oneOf $ ['a'..'z'] ++ ['A'..'Z'] - toLine c = if isUpper c - then ord c - ord 'A' + 26 - else ord c - ord 'a' - -listOf :: Parser a -> Parser [a] -listOf valueParser = many1 (single valueParser <* spaces) - -number :: Parser (String, Bool) -number = do - sign <- "-" <$ char '-' <|> - "" <$ char '+' <|> - return "" - digits <- many1 digit - return (sign ++ digits, not $ null sign) - --- Public parsers. - -colorParser :: Parser Color -colorParser = single color "color" - -color :: Parser Color -color = choice [Black <$ char 'B', - White <$ char 'W'] - -coord :: Parser Coord -coord = (,) <$> line <*> line - -coordElistParser :: Parser CoordList -coordElistParser = - try (emptyCoordList <$ string "[]") <|> - coordListParser - "list of points or empty" - -coordListParser :: Parser CoordList -coordListParser = - runCoordListMonoid . mconcat . map CoordListMonoid <$> listOf coordListEntry - "list of points" - where coordListEntry = do x0 <- line - y0 <- line - choice [do char ':' - x1 <- line - y1 <- line - return $ coordR ((x0, y0), (x1, y1)), - return $ coord1 (x0, y0)] - coordR rect = coords' [] [rect] - -coordPairListParser :: Parser [(Coord, Coord)] -coordPairListParser = listOf coordPair "list of point pairs" - where coordPair = do - x0 <- line - y0 <- line - char ':' - x1 <- line - y1 <- line - return ((x0, y0), (x1, y1)) - -doubleParser :: Parser DoubleValue -doubleParser = - single (Double1 <$ char '1' <|> - Double2 <$ char '2') - "double" - -gameResultParser :: Parser GameResult -gameResultParser = single (parseGameResult <$> simpleText False) "game result" - where parseGameResult text = case fromSimpleText text of - "0" -> GameResultDraw - "Draw" -> GameResultDraw - "Void" -> GameResultVoid - "?" -> GameResultUnknown - rawText -> case parse gameResultWin "" rawText of - Left _ -> GameResultOther text - Right win -> win - -gameResultWin :: Parser GameResult -gameResultWin = GameResultWin <$> color <* char '+' <*> winReason <* eof - -winReason :: Parser WinReason -winReason = - WinByScore <$> try real <|> - WinByResignation <$ try (string "Resign") <|> - WinByResignation <$ try (string "R") <|> - WinByTime <$ try (string "Time") <|> - WinByTime <$ try (string "T") <|> - WinByForfeit <$ try (string "Forfeit") <|> - WinByForfeit <$ try (string "F") - -labelListParser :: Parser [(Coord, SimpleText)] -labelListParser = - listOf (compose coord $ simpleText True) "list of points and labels" - -moveParser :: Parser (Maybe Coord) -moveParser = - char '[' *> (Nothing <$ char ']' <|> Just <$> coord <* char ']') - "move (point or pass)" - -noneParser :: Parser () -noneParser = () <$ string "[]" "none" - --- This is what the SGF spec calls the Number type, i.e. a signed integer. -integralParser :: (Integral a, Read a) => Parser a -integralParser = single integral "integer" - -integral :: (Integral a, Read a) => Parser a -integral = read . fst <$> number - -realParser :: Parser RealValue -realParser = single real "real" - -real :: Parser RealValue -real = do - (whole, isNegative) <- number - let wholePart = toRational (read whole :: Integer) - -- Try to read a fractional part of the number. - -- If we fail, just return the whole part. - option wholePart $ try $ do - fractionalStr <- char '.' *> many1 digit - let fractionalPart = toRational (read fractionalStr) / 10 ^ length fractionalStr - return $ (if isNegative then (-) else (+)) wholePart fractionalPart - -rulesetParser :: Parser Ruleset -rulesetParser = - single (toRuleset . fromSimpleText <$> simpleText False) "ruleset" - -simpleTextPairParser :: Parser (SimpleText, SimpleText) -simpleTextPairParser = single (compose composedText composedText) "pair of simple texts" - where composedText = simpleText True - --- | A parser for SGF SimpleText property values. -simpleTextParser :: Parser SimpleText -simpleTextParser = single (simpleText False) "simple text" - -simpleText :: Bool -> Parser SimpleText -simpleText isComposed = toSimpleText <$> text isComposed - -sizeParser :: Parser (Int, Int) -sizeParser = - (do char '[' - width <- integral - height <- choice [width <$ char ']', - do char ':' - height <- integral - char ']' - -- TODO We should warn here rather than aborting. - when (width == height) $ - fail $ show width ++ "x" ++ show height ++ " square board " ++ - " dimensions should be specified with a single number." - return height] - when (width < 1 || width > boardSizeMax || - height < 1 || height > boardSizeMax) $ - fail $ show width ++ "x" ++ show height ++ " board dimensions are invalid. " ++ - "Each dimension must be between 1 and 52 inclusive." - return (width, height)) - "board size (width or width:height)" - -textParser :: Parser Text -textParser = single (toText <$> text False) "text" - --- | A parser for SGF text property values. Its argument should be true if the --- text is inside of a composed property value, so @\':\'@ should terminate the --- value in addition to @']'@. -text :: Bool -> Parser String -text isComposed = catMaybes <$> many textChar' - where textChar' = textChar (if isComposed then ":]\\" else "]\\") - -textChar :: String -> Parser (Maybe Char) -textChar specialChars = - choice [Just <$> char '\n', - Just ' ' <$ space, - try (char '\\' *> (Nothing <$ char '\n' <|> - Just <$> anyChar)), - Just <$> noneOf specialChars] - -unknownPropertyParser :: Parser UnknownPropertyValue -unknownPropertyParser = - single (toUnknownPropertyValue <$> text False) - "unknown property value" - -variationModeParser :: Parser VariationMode -variationModeParser = single variationMode "variation mode" - -variationMode :: Parser VariationMode -variationMode = do - value <- integral - case toVariationMode value of - Just mode -> return mode - Nothing -> unexpected $ "variation mode " ++ show value diff --git a/src/Game/Goatee/Sgf/Property/Renderer.hs b/src/Game/Goatee/Sgf/Property/Renderer.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Property/Renderer.hs +++ /dev/null @@ -1,326 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -{-# LANGUAGE CPP #-} - --- | Renderers of property values. --- --- Import "Game.Goatee.Sgf.Property" rather than importing this module. -module Game.Goatee.Sgf.Property.Renderer ( - renderColorBracketed, - renderColorPretty, - renderCoordElistBracketed, - renderCoordElistPretty, - renderCoordListBracketed, - renderCoordListPretty, - renderCoordPairListBracketed, - renderCoordPairListPretty, - renderDoubleBracketed, - renderDoublePretty, - renderGameResultBracketed, - renderGameResultPretty, - renderIntegralBracketed, - renderIntegralPretty, - renderLabelListBracketed, - renderLabelListPretty, - renderMoveBracketed, - renderMovePretty, - renderNoneBracketed, - renderNonePretty, - renderRealBracketed, - renderRealPretty, - renderRulesetBracketed, - renderRulesetPretty, - renderSimpleTextBracketed, - renderSimpleTextPairBracketed, - renderSimpleTextPairPretty, - renderSimpleTextPretty, - renderSizeBracketed, - renderSizePretty, - renderTextBracketed, - renderTextPretty, - renderUnknownPropertyBracketed, - renderUnknownPropertyPretty, - renderVariationModeBracketed, - renderVariationModePretty, - ) where - -import Control.Monad (forM_, when) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except (throwError) -#else -import Control.Monad.Error (throwError) -#endif -import Control.Monad.Writer (tell) -import Data.Char (chr, ord) -import Data.List (intersperse) -import Game.Goatee.Sgf.Renderer -import Game.Goatee.Sgf.Types - -{-# ANN module "HLint: ignore Use <$>" #-} - --- Internal renderers not corresponding to any particular value type. - -bracketed :: Render () -> Render () -bracketed x = tell "[" >> x >> tell "]" - -renderLine :: Int -> Render () -renderLine = rendererOf "line" $ \x -> - if x >= 0 && x < 52 - then tell [chr $ x + (if x < 26 then ord 'a' else ord 'A' - 26)] - else throwError $ "renderLine: Index not in [0, 52): " ++ show x - -renderCoord :: Coord -> Render () -renderCoord = rendererOf "coord" $ \(x, y) -> renderLine x >> renderLine y - -renderCoordBracketed :: Coord -> Render () -renderCoordBracketed = fmap bracketed renderCoord - -renderCoordPretty :: Coord -> Render () -renderCoordPretty = rendererOf "coord pretty" $ \(x, y) -> - mapM_ tell ["(", show x, ", ", show y, ")"] - -renderCoordPairPretty :: (Coord, Coord) -> Render () -renderCoordPairPretty = rendererOf "coord pair pretty" $ \(a, b) -> do - renderCoordPretty a - tell "-" - renderCoordPretty b - -renderCoordPair :: (Coord, Coord) -> Render () -renderCoordPair = rendererOf "coord pair" $ \(a, b) -> - renderCoord a >> tell ":" >> renderCoord b - -renderCoordPairBracketed :: (Coord, Coord) -> Render () -renderCoordPairBracketed = fmap bracketed renderCoordPair - -renderShowable :: Show a => a -> Render () -renderShowable = tell . show - -renderStringlike :: (Show a, Stringlike a) => Bool -> a -> Render () -renderStringlike isComposed = - rendererOf (if isComposed then "composed stringlike" else "stringlike") $ \str -> - tell $ escape $ sgfToString str - where escape [] = [] - escape (first:rest) | first `elem` specialChars = '\\':first:escape rest - | otherwise = first:escape rest - -- TODO Deduplicate these characters with the parser: - specialChars = if isComposed then ":]\\" else "]\\" - --- Note that unlike the serialized SGF version, we don't care about escaping --- characters in composed strings. -renderStringlikePretty :: (Show a, Stringlike a) => a -> Render () -renderStringlikePretty = rendererOf "stringlike pretty" $ tell . sgfToString - --- Public renderers. - -renderColorBracketed :: Color -> Render () -renderColorBracketed color = bracketed $ tell $ case color of - Black -> "[B]" - White -> "[W]" - -renderColorPretty :: Color -> Render () -renderColorPretty Black = tell "Black" -renderColorPretty White = tell "White" - -renderCoordElistBracketed :: CoordList -> Render () -renderCoordElistBracketed = rendererOf "coord elist bracketed" $ \list -> - if null $ expandCoordList list - then tell "[]" - else renderCoordListNonempty list - -renderCoordElistPretty :: CoordList -> Render () -renderCoordElistPretty = rendererOf "coord elist pretty" $ \list -> - if null $ expandCoordList list - then tell "empty" - else renderCoordListNonemptyPretty list - -renderCoordListBracketed :: CoordList -> Render () -renderCoordListBracketed = rendererOf "coord list bracketed" $ \list -> - if null $ expandCoordList list - then throwError "renderCoordListBracketed: Unexpected empty CoordList." - else renderCoordListNonempty list - -renderCoordListPretty :: CoordList -> Render () -renderCoordListPretty = rendererOf "coord list pretty" $ \list -> - if null $ expandCoordList list - then throwError "renderCoordListPretty: Unexpected empty CoordList." - else renderCoordListNonemptyPretty list - -renderCoordListNonempty :: CoordList -> Render () -renderCoordListNonempty = rendererOf "coord list nonempty" $ \list -> do - mapM_ renderCoordPairBracketed $ coordListRects list - mapM_ renderCoordBracketed $ coordListSingles list - -renderCoordListNonemptyPretty :: CoordList -> Render () -renderCoordListNonemptyPretty = rendererOf "coord list nonempty pretty" $ \list -> - sequence_ $ intersperse (tell ", ") $ - map renderCoordPairPretty (coordListRects list) ++ - map renderCoordPretty (coordListSingles list) - -renderCoordPairListBracketed :: [(Coord, Coord)] -> Render () -renderCoordPairListBracketed = rendererOf "coord pair list bracketed" $ \list -> - if null list - then throwError "renderCoordPairListBracketed: Unexpected empty list." - else mapM_ renderCoordPairBracketed list - -renderCoordPairListPretty :: [(Coord, Coord)] -> Render () -renderCoordPairListPretty list = - if null list - then throwError "renderCoordPairListPretty: Unexpected empty list." - else sequence_ $ intersperse (tell ", ") $ map renderCoordPairPretty list - -renderDoubleBracketed :: DoubleValue -> Render () -renderDoubleBracketed = fmap bracketed $ rendererOf "double" $ \double -> tell $ case double of - Double1 -> "1" - Double2 -> "2" - -renderDoublePretty :: DoubleValue -> Render () -renderDoublePretty = rendererOf "double pretty" $ tell . \double -> case double of - Double1 -> "1" - Double2 -> "2" - -renderGameResultBracketed :: GameResult -> Render () -renderGameResultBracketed = fmap bracketed $ rendererOf "game result" $ \result -> case result of - GameResultWin color reason -> - tell $ - (case color of { Black -> 'B'; White -> 'W' }) : '+' : - (case reason of - WinByScore diff -> show diff - WinByResignation -> "R" - WinByTime -> "T" - WinByForfeit -> "F") - GameResultDraw -> tell "0" - GameResultVoid -> tell "Void" - GameResultUnknown -> tell "?" - GameResultOther text -> renderStringlike False text - -renderGameResultPretty :: GameResult -> Render () -renderGameResultPretty = rendererOf "game result pretty" $ \result -> case result of - GameResultWin color reason -> - tell $ - (case color of { Black -> 'B'; White -> 'W' }) : '+' : - (case reason of - WinByScore diff -> show diff - WinByResignation -> "Resign" - WinByTime -> "Time" - WinByForfeit -> "Forfeit") - GameResultDraw -> tell "Draw" - GameResultVoid -> tell "Void" - GameResultUnknown -> tell "Unknown" - GameResultOther text -> renderStringlikePretty text - -renderIntegralBracketed :: (Integral a, Show a) => a -> Render () -renderIntegralBracketed = bracketed . rendererOf "integral" renderShowable - -renderIntegralPretty :: (Integral a, Show a) => a -> Render () -renderIntegralPretty = rendererOf "integral pretty" renderShowable - -renderLabelListBracketed :: [(Coord, SimpleText)] -> Render () -renderLabelListBracketed = rendererOf "label list" $ \list -> - if null list - then throwError "renderLabelListBracketed: Unexpected empty list." - else forM_ list $ bracketed . \(coord, text) -> do - renderCoord coord - tell ":" - renderStringlike True text - -renderLabelListPretty :: [(Coord, SimpleText)] -> Render () -renderLabelListPretty = rendererOf "label list pretty" $ \list -> - if null list - then throwError "renderLabelListPretty: Unexpected empty list." - else sequence_ $ intersperse (tell ", ") $ - map (\(coord, text) -> do - renderCoordPretty coord - tell ":" - renderStringlikePretty text) - list - -renderMoveBracketed :: Maybe Coord -> Render () -renderMoveBracketed = rendererOf "move bracketed" $ maybe (tell "[]") renderCoordBracketed - -renderMovePretty :: Maybe Coord -> Render () -renderMovePretty = rendererOf "move pretty" $ maybe (tell "Pass") renderCoordPretty - -renderNoneBracketed :: () -> Render () -renderNoneBracketed = rendererOf "none bracketed" $ tell . const "[]" - -renderNonePretty :: () -> Render () -renderNonePretty = rendererOf "none pretty" $ tell . const "" - -renderRealBracketed :: RealValue -> Render () -renderRealBracketed = fmap bracketed $ rendererOf "real" $ renderShowable . fromRational - -renderRealPretty :: RealValue -> Render () -renderRealPretty = rendererOf "real pretty" renderShowable - -renderRulesetBracketed :: Ruleset -> Render () -renderRulesetBracketed = fmap bracketed $ rendererOf "ruleset" $ tell . fromRuleset - -renderRulesetPretty :: Ruleset -> Render () -renderRulesetPretty = rendererOf "ruleset pretty" $ tell . fromRuleset - -renderSimpleTextPairBracketed :: (SimpleText, SimpleText) -> Render () -renderSimpleTextPairBracketed = fmap bracketed $ rendererOf "simple text pair" $ \(a, b) -> do - renderStringlike True a - tell ":" - renderStringlike True b - -renderSimpleTextPairPretty :: (SimpleText, SimpleText) -> Render () -renderSimpleTextPairPretty = fmap bracketed $ rendererOf "simple text pair pretty" $ \(a, b) -> do - renderStringlike True a - tell " " - renderStringlike True b - -renderSimpleTextBracketed :: SimpleText -> Render () -renderSimpleTextBracketed = fmap bracketed $ rendererOf "simple text" $ renderStringlike False - -renderSimpleTextPretty :: SimpleText -> Render () -renderSimpleTextPretty = fmap bracketed $ rendererOf "simple text pretty" $ tell . fromSimpleText - -renderSizeBracketed :: (Int, Int) -> Render () -renderSizeBracketed = fmap bracketed $ rendererOf "size" $ \(x, y) -> do - tell $ show x - when (x /= y) $ tell $ ':' : show y - -renderSizePretty :: (Int, Int) -> Render () -renderSizePretty = rendererOf "size pretty" renderCoordPretty - -renderTextBracketed :: Text -> Render () -renderTextBracketed = fmap bracketed $ rendererOf "text" $ renderStringlike False - -renderTextPretty :: Text -> Render () -renderTextPretty = fmap bracketed $ rendererOf "text pretty" $ tell . fromText - -renderUnknownPropertyBracketed :: UnknownPropertyValue -> Render () -renderUnknownPropertyBracketed = - fmap bracketed $ rendererOf "unknown property" $ renderStringlike False - -renderUnknownPropertyPretty :: UnknownPropertyValue -> Render () -renderUnknownPropertyPretty = - rendererOf "unknown property pretty" $ tell . fromUnknownPropertyValue - -renderVariationModeBracketed :: VariationMode -> Render () -renderVariationModeBracketed = - fmap bracketed $ rendererOf "variation mode" $ tell . show . fromVariationMode - -renderVariationModePretty :: VariationMode -> Render () -renderVariationModePretty = rendererOf "variation mode pretty" $ \(VariationMode source markup) -> - tell $ - (case source of - ShowChildVariations -> "Children" - ShowCurrentVariations -> "Current") ++ " " ++ - (if markup then "Shown" else "Hidden") diff --git a/src/Game/Goatee/Sgf/Property/Value.hs b/src/Game/Goatee/Sgf/Property/Value.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Property/Value.hs +++ /dev/null @@ -1,179 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | Metadata about the types of property values. --- --- Import "Game.Goatee.Sgf.Property" rather than importing this module. -module Game.Goatee.Sgf.Property.Value ( - PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, - colorPvt, - coordElistPvt, - coordListPvt, - coordPairListPvt, - doublePvt, - gameResultPvt, - integralPvt, - labelListPvt, - movePvt, - nonePvt, - realPvt, - rulesetPvt, - simpleTextPairPvt, - simpleTextPvt, - sizePvt, - textPvt, - unknownPropertyPvt, - variationModePvt, - ) where - -import qualified Game.Goatee.Sgf.Property.Parser as P -import qualified Game.Goatee.Sgf.Property.Renderer as R -import Game.Goatee.Sgf.Renderer -import Game.Goatee.Sgf.Types -import Text.ParserCombinators.Parsec (Parser) - -data PropertyValueType a = PropertyValueType { - pvtParser :: Parser a - , pvtRenderer :: a -> Render () - , pvtRendererPretty :: a -> Render () - } - -colorPvt :: PropertyValueType Color -colorPvt = PropertyValueType { - pvtParser = P.colorParser - , pvtRenderer = R.renderColorBracketed - , pvtRendererPretty = R.renderColorPretty - } - -coordElistPvt :: PropertyValueType CoordList -coordElistPvt = PropertyValueType { - pvtParser = P.coordElistParser - , pvtRenderer = R.renderCoordElistBracketed - , pvtRendererPretty = R.renderCoordElistPretty - } - -coordListPvt :: PropertyValueType CoordList -coordListPvt = PropertyValueType { - pvtParser = P.coordListParser - , pvtRenderer = R.renderCoordListBracketed - , pvtRendererPretty = R.renderCoordListPretty - } - -coordPairListPvt :: PropertyValueType [(Coord, Coord)] -coordPairListPvt = PropertyValueType { - pvtParser = P.coordPairListParser - , pvtRenderer = R.renderCoordPairListBracketed - , pvtRendererPretty = R.renderCoordPairListPretty - } - -doublePvt :: PropertyValueType DoubleValue -doublePvt = PropertyValueType { - pvtParser = P.doubleParser - , pvtRenderer = R.renderDoubleBracketed - , pvtRendererPretty = R.renderDoublePretty - } - -gameResultPvt :: PropertyValueType GameResult -gameResultPvt = PropertyValueType { - pvtParser = P.gameResultParser - , pvtRenderer = R.renderGameResultBracketed - , pvtRendererPretty = R.renderGameResultPretty - } - -integralPvt :: (Integral a, Read a, Show a) => PropertyValueType a -integralPvt = PropertyValueType { - pvtParser = P.integralParser - , pvtRenderer = R.renderIntegralBracketed - , pvtRendererPretty = R.renderIntegralPretty - } - -labelListPvt :: PropertyValueType [(Coord, SimpleText)] -labelListPvt = PropertyValueType { - pvtParser = P.labelListParser - , pvtRenderer = R.renderLabelListBracketed - , pvtRendererPretty = R.renderLabelListPretty - } - -movePvt :: PropertyValueType (Maybe Coord) -movePvt = PropertyValueType { - pvtParser = P.moveParser - , pvtRenderer = R.renderMoveBracketed - , pvtRendererPretty = R.renderMovePretty - } - -nonePvt :: PropertyValueType () -nonePvt = PropertyValueType { - pvtParser = P.noneParser - , pvtRenderer = R.renderNoneBracketed - , pvtRendererPretty = R.renderNonePretty - } - -realPvt :: PropertyValueType RealValue -realPvt = PropertyValueType { - pvtParser = P.realParser - , pvtRenderer = R.renderRealBracketed - , pvtRendererPretty = R.renderRealPretty - } - -rulesetPvt :: PropertyValueType Ruleset -rulesetPvt = PropertyValueType { - pvtParser = P.rulesetParser - , pvtRenderer = R.renderRulesetBracketed - , pvtRendererPretty = R.renderRulesetPretty - } - -simpleTextPairPvt :: PropertyValueType (SimpleText, SimpleText) -simpleTextPairPvt = PropertyValueType { - pvtParser = P.simpleTextPairParser - , pvtRenderer = R.renderSimpleTextPairBracketed - , pvtRendererPretty = R.renderSimpleTextPairPretty - } - -simpleTextPvt :: PropertyValueType SimpleText -simpleTextPvt = PropertyValueType { - pvtParser = P.simpleTextParser - , pvtRenderer = R.renderSimpleTextBracketed - , pvtRendererPretty = R.renderSimpleTextPretty - } - -sizePvt :: PropertyValueType (Int, Int) -sizePvt = PropertyValueType { - pvtParser = P.sizeParser - , pvtRenderer = R.renderSizeBracketed - , pvtRendererPretty = R.renderSizePretty - } - -textPvt :: PropertyValueType Text -textPvt = PropertyValueType { - pvtParser = P.textParser - , pvtRenderer = R.renderTextBracketed - , pvtRendererPretty = R.renderTextPretty - } - -unknownPropertyPvt :: PropertyValueType UnknownPropertyValue -unknownPropertyPvt = PropertyValueType { - pvtParser = P.unknownPropertyParser - , pvtRenderer = R.renderUnknownPropertyBracketed - , pvtRendererPretty = R.renderUnknownPropertyPretty - } - -variationModePvt :: PropertyValueType VariationMode -variationModePvt = PropertyValueType { - pvtParser = P.variationModeParser - , pvtRenderer = R.renderVariationModeBracketed - , pvtRendererPretty = R.renderVariationModePretty - } diff --git a/src/Game/Goatee/Sgf/Renderer.hs b/src/Game/Goatee/Sgf/Renderer.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Renderer.hs +++ /dev/null @@ -1,56 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -{-# LANGUAGE CPP #-} - --- | Common definitions for a renderer that supports failure. -module Game.Goatee.Sgf.Renderer ( - Render, - runRender, - rendererOf, - ) where - -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except (Except, catchError, runExcept, throwError) -#else -import Control.Monad.Error (catchError, throwError) -#endif -import Control.Monad.Writer (WriterT, execWriterT) - --- | A monad for accumulating string output with the possibility of failure. -#if MIN_VERSION_mtl(2,2,1) -type Render = WriterT String (Except String) -#else -type Render = WriterT String (Either String) -#endif - --- | Returns either the rendered result on the right, or a message describing a --- failure on the left. -runRender :: Render a -> Either String String -#if MIN_VERSION_mtl(2,2,1) -runRender = runExcept . execWriterT -#else -runRender = execWriterT -#endif - --- | Wraps a renderer in an exception handler that, when the renderer or --- something it calls fails, will add context about this renderer's invocation --- to the failure message. -rendererOf :: Show a => String -> (a -> Render ()) -> a -> Render () -rendererOf description renderer value = catchError (renderer value) $ \message -> - throwError $ - message ++ "\n while trying to render " ++ description ++ " from " ++ show value ++ "." diff --git a/src/Game/Goatee/Sgf/Renderer/Tree.hs b/src/Game/Goatee/Sgf/Renderer/Tree.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Renderer/Tree.hs +++ /dev/null @@ -1,56 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | Functions for serializing SGF trees. -module Game.Goatee.Sgf.Renderer.Tree ( - renderCollection, - ) where - -import Control.Monad (forM_) -import Control.Monad.Writer (tell) -import Game.Goatee.Common -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Renderer -import Game.Goatee.Sgf.Tree - --- | Renders an SGF 'Collection' to a string. -renderCollection :: Collection -> Render () -renderCollection collection = do - mapM_ renderGameTree $ collectionTrees collection - tell "\n" - --- | Recursively renders an SGF GameTree (as defined in the spec) rooted at the --- given node. -renderGameTree :: Node -> Render () -renderGameTree node = do - tell "(" - doWhileM node - (\node' -> do renderNode node' - case nodeChildren node' of - [] -> return $ Left Nothing - child:[] -> return $ Right child - children -> return $ Left $ Just children) - >>= maybe (return ()) (mapM_ renderGameTree) - tell ")" - --- | Renders a node and its properties without recurring to its children. -renderNode :: Node -> Render () -renderNode node = do - tell "\n;" - forM_ (nodeProperties node) $ \property -> do - tell $ propertyName property - propertyValueRenderer property property diff --git a/src/Game/Goatee/Sgf/Tree.hs b/src/Game/Goatee/Sgf/Tree.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Tree.hs +++ /dev/null @@ -1,175 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | SGF data structures modelling the hierarchical game tree. -module Game.Goatee.Sgf.Tree ( - Collection(..), CollectionWithDeepEquality(..), - Node(..), NodeWithDeepEquality(..), - emptyNode, rootNode, - findProperty, findProperty', findPropertyValue, findPropertyValue', - addProperty, addChild, addChildAt, - validateNode, - ) where - -import Control.Applicative ((<$>)) -import Control.Monad (forM_, unless, when) -import Control.Monad.Writer (Writer, execWriter, tell) -import Data.Function (on) -import Data.List (find, groupBy, intercalate, nub, sortBy) -import Data.Version (showVersion) -import Game.Goatee.App (applicationName) -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Types -import Paths_goatee (version) - --- | An SGF collection of game trees. -data Collection = Collection { collectionTrees :: [Node] - } deriving (Show) - --- | See 'NodeWithDeepEquality'. -newtype CollectionWithDeepEquality = CollectionWithDeepEquality { - collectionWithDeepEquality :: Collection - } deriving (Show) - -instance Eq CollectionWithDeepEquality where - (==) = (==) `on` map NodeWithDeepEquality . collectionTrees . collectionWithDeepEquality - --- | An SGF game tree node. Unlike in the SGF spec, we represent a game tree --- with nodes uniformly, rather than having the separation between sequences and --- nodes. -data Node = Node { nodeProperties :: [Property] - , nodeChildren :: [Node] - } deriving (Show) - --- | A wrapper around 'Node' with an 'Eq' instance that considers two nodes --- equal iff they contain the same properties (not necessarily in the same --- order), and if they contain children (in the same order) whose nodes are --- recursively equal. --- --- This instance is not on 'Node' directly because it is not the only obvious --- sense of equality (only comparing properties would be another one), and it's --- also potentially expensive. -newtype NodeWithDeepEquality = NodeWithDeepEquality { nodeWithDeepEquality :: Node } - -instance Eq NodeWithDeepEquality where - node1 == node2 = - let n1 = nodeWithDeepEquality node1 - n2 = nodeWithDeepEquality node2 - in propertiesSorted n1 == propertiesSorted n2 && - deepChildren n1 == deepChildren n2 - where propertiesSorted = sortBy (compare `on` show) . nodeProperties - deepChildren = map NodeWithDeepEquality . nodeChildren - --- | A node with no properties and no children. -emptyNode :: Node -emptyNode = Node { nodeProperties = [], nodeChildren = [] } - --- | Returns a fresh root 'Node' with 'AP' set to Goatee and optionally with a --- board size set via 'SZ'. -rootNode :: Maybe (Int, Int) -> Node -rootNode maybeSize = - let props = FF 4 : - GM 1 : - AP (toSimpleText applicationName) - (toSimpleText $ showVersion version) : - maybe [] ((:[]) . uncurry SZ) maybeSize - in Node { nodeProperties = props - , nodeChildren = [] - } - --- | Searches for a matching property in a node's property list. -findProperty :: Descriptor a => a -> Node -> Maybe Property -findProperty descriptor node = findProperty' descriptor $ nodeProperties node - --- | Searches for a matching property in a property list. -findProperty' :: Descriptor a => a -> [Property] -> Maybe Property -findProperty' = find . propertyPredicate - --- | Retrieves the value of a property in a node's property list. -findPropertyValue :: ValuedDescriptor a v => a -> Node -> Maybe v -findPropertyValue descriptor node = propertyValue descriptor <$> findProperty descriptor node - --- | Retrieves the value of a property in a property list. -findPropertyValue' :: ValuedDescriptor a v => a -> [Property] -> Maybe v -findPropertyValue' descriptor properties = - propertyValue descriptor <$> findProperty' descriptor properties - --- | Appends a property to a node's property list. -addProperty :: Property -> Node -> Node -addProperty prop node = node { nodeProperties = nodeProperties node ++ [prop] } - --- | @addChild child parent@ appends a child node to a node's child list. -addChild :: Node -> Node -> Node -addChild child node = node { nodeChildren = nodeChildren node ++ [child] } - --- | @addChildAt index child parent@ inserts a child node into a node's child --- list at the given index, shifting all nodes at or after the given index to --- the right. The index must be in the range @[0, numberOfChildren]@. -addChildAt :: Int -> Node -> Node -> Node -addChildAt index child node = - let (before, after) = splitAt index $ nodeChildren node - in node { nodeChildren = before ++ child:after } - --- | Returns a list of validation errors for the current node, an --- empty list if no errors are detected. -validateNode :: Bool -> Bool -> Node -> [String] -validateNode isRoot _{-seenGameNode-} node = execWriter $ do - let props = nodeProperties node - let propTypes = nub $ map propertyType $ nodeProperties node - - -- Check for move and setup properties in a single node. - when (MoveProperty `elem` propTypes && SetupProperty `elem` propTypes) $ - tell ["Node contains move and setup properties."] - - -- Check for root properties in non-root nodes. - let rootProps = filter ((RootProperty ==) . propertyType) props - when (not isRoot && not (null rootProps)) $ - tell $ map (\p -> "Root property found on non-root node: " ++ - show p ++ ".") - rootProps - - -- TODO Check for game-info properties. - - -- Check for coordinates marked multiple times. - validateNodeDuplicates props getMarkedCoords $ \group -> - tell ["Coordinate " ++ show (fst $ head group) ++ - " is specified multiple times in properties " ++ - intercalate ", " (map snd group) ++ "."] - - -- TODO Validate recursively. - - where getMarkedCoords (CR cs) = tagMarkedCoords cs "CR" - getMarkedCoords (MA cs) = tagMarkedCoords cs "MA" - getMarkedCoords (SL cs) = tagMarkedCoords cs "SL" - getMarkedCoords (SQ cs) = tagMarkedCoords cs "SQ" - getMarkedCoords (TR cs) = tagMarkedCoords cs "TR" - getMarkedCoords _ = [] - - tagMarkedCoords cs tag = map (\x -> (x, tag)) $ expandCoordList cs - -validateNodeDuplicates :: (Eq v, Ord v) - => [Property] - -> (Property -> [(v, t)]) - -> ([(v, t)] -> Writer [String] ()) - -> Writer [String] () -validateNodeDuplicates props getTaggedElts errAction = - let groups = groupBy ((==) `on` fst) $ - sortBy (compare `on` fst) $ - concatMap getTaggedElts props - in forM_ groups $ \group -> - unless (null $ tail group) $ - errAction group diff --git a/src/Game/Goatee/Sgf/Types.hs b/src/Game/Goatee/Sgf/Types.hs deleted file mode 100644 --- a/src/Game/Goatee/Sgf/Types.hs +++ /dev/null @@ -1,389 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | Constants and data types for property values used in SGF game trees. -module Game.Goatee.Sgf.Types ( - supportedFormatVersions, defaultFormatVersion, supportedGameTypes, - boardSizeDefault, boardSizeMin, boardSizeMax, - Coord, CoordList, coordListSingles, coordListRects, coord1, coords, coords', - emptyCoordList, expandCoordList, buildCoordList, - RealValue, - Stringlike (..), - Text, fromText, toText, - SimpleText, fromSimpleText, toSimpleText, - UnknownPropertyValue, fromUnknownPropertyValue, toUnknownPropertyValue, - DoubleValue (..), - Color (..), cnot, - VariationMode (..), VariationModeSource (..), defaultVariationMode, - toVariationMode, fromVariationMode, - ArrowList, LineList, LabelList, Mark (..), - GameResult (..), - WinReason (..), - Ruleset (..), RulesetType (..), fromRuleset, toRuleset, - ) where - -import Data.Char (isSpace) -import Data.Function (on) -import Data.List (delete, groupBy, partition, sort) - --- TODO Support FF versions 1-4. -supportedFormatVersions :: [Int] -supportedFormatVersions = [4] - --- | The default SGF version to use when @FF[]@ is not specified in a root node. --- --- This value is actually INCORRECT: SGF defines it to be 1, but because we --- don't support version 1 yet, for the sake of ignoring this issue (for now!) --- in tests, we fix the default to be 4. --- --- TODO Fix the default version to be 1 as SGF mandates. -defaultFormatVersion :: Int -defaultFormatVersion = 4 - -supportedGameTypes :: [Int] -supportedGameTypes = [1 {- Go -}] - --- | The default size of the board. The FF[4] SGF spec says that the default Go --- board is 19x19 square. -boardSizeDefault :: Int -boardSizeDefault = 19 - --- | The minimum board size allowed by FF[4], 1. -boardSizeMin :: Int -boardSizeMin = 1 - --- | The maximum board size allowed by FF[4], 52. -boardSizeMax :: Int -boardSizeMax = 52 - --- | A coordinate on a Go board. @(0, 0)@ refers to the upper-left corner of --- the board. The first component is the horizontal position; the second --- component is the vertical position. -type Coord = (Int, Int) - --- | A structure for compact representation of a list of coordinates. Contains --- a list of individual points, as well as a list of rectangles of points --- denoted by an ordered pair of the upper-left point and the lower-right point. --- The union of the single points and points contained within rectangles make up --- all of the points a @CoordList@ represents. There is no rule saying that --- adjacent points have to be grouped into rectangles; it's perfectly valid --- (although possibly inefficient) to never use rectangles. --- --- For any @CoordList@, all of the following hold: --- --- 1. Any point may be specified at most once, either in the singles list or in --- a single rectangle. --- --- 2. For a rectangle @((x0,y0), (x1,y1))@, @x0 <= x1@ and @y0 <= y1@ and --- @(x0,y0) /= (x1,y1)@ (otherwise the point belongs in the singles list). -data CoordList = CoordList { - coordListSingles :: [Coord] - -- ^ Returns the single points in a 'CoordList'. - , coordListRects :: [(Coord, Coord)] - -- ^ Returns the rectangles in a 'CoordList'. - } deriving (Show) - --- | Equality is based on unordered, set equality of the underlying points. -instance Eq CoordList where - (==) = (==) `on` sort . expandCoordList - --- | Constructs a 'CoordList' containing a single point. -coord1 :: Coord -> CoordList -coord1 xy = CoordList { coordListSingles = [xy] - , coordListRects = [] - } - --- | Constructs a 'CoordList' containing the given single points. For rectangle --- detection, use 'buildCoordList'. -coords :: [Coord] -> CoordList -coords singles = CoordList { coordListSingles = singles - , coordListRects = [] - } - --- | Constructs a 'CoordList' containing the given single points and rectangles. -coords' :: [Coord] -> [(Coord, Coord)] -> CoordList -coords' singles rects = CoordList { coordListSingles = singles - , coordListRects = rects - } - --- | A 'CoordList' that contains no points. -emptyCoordList :: CoordList -emptyCoordList = CoordList { coordListSingles = [] - , coordListRects = [] - } - --- | Converts a compact 'CoordList' to a list of coordinates. -expandCoordList :: CoordList -> [Coord] -expandCoordList cl = coordListSingles cl ++ - foldr (\r@((x0, y0), (x1, y1)) rest -> - if x0 > x1 || y0 > y1 - then error ("Invalid coord. rectangle: " ++ show r) - else [(x, y) | x <- [x0..x1], y <- [y0..y1]] ++ rest) - [] - (coordListRects cl) - --- | Constructs a 'CoordList' from a list of 'Coord's, doing some --- not-completely-stupid rectangle detection. The order of data in the result --- is unspecified. -buildCoordList :: [Coord] -> CoordList --- This algorithm doesn't generate the smallest result. For the following --- input: --- --- F F T T --- T T T T --- T T F F --- --- It will return [ca:da][ab:db][ac:bc] rather than the shorter [ca:db][ab:bc]. -buildCoordList = toCoordList . generateRects 0 [] . buildTruePairs . toGrid - where -- | Constructs a row-major grid of booleans where an coordinate is true - -- iff it is in the given list. - toGrid :: [Coord] -> [[Bool]] - toGrid [] = [] - toGrid coords = let x1 = maximum $ map fst coords - y1 = maximum $ map snd coords - in [[(x,y) `elem` coords | x <- [0..x1]] | y <- [0..y1]] - - -- | For each row, converts a list of booleans into a list of pairs - -- where each pair represents a consecutive run of true values. The - -- pair indicates the indices of the first and last boolean in each run. - buildTruePairs :: [[Bool]] -> [[(Int, Int)]] - buildTruePairs = map $ - concatMap extractTrueGroups . - groupBy ((==) `on` snd) . - zip [0..] - - -- | Given a run of indexed booleans with the same boolean value within - -- a row, returns @[(startIndex, endIndex)]@ if the value is true, and - -- @[]@ if the value is false. - extractTrueGroups :: [(Int, Bool)] -> [(Int, Int)] - extractTrueGroups list@((start, True):_) = [(start, fst (last list))] - extractTrueGroups _ = [] - - -- | Converts the lists of true pairs for all rows into a list of - -- @(Coord, Coord)@ rectangles. We repeatedly grab the first span in - -- the first row, and see how many leading rows contain that exact span. - -- Then we build a (maybe multi-row) rectangle for the span, remove the - -- span from all leading rows, and repeat. When the first row becomes - -- empty, we drop it and increment a counter that keeps track of our - -- first row's y-position. - generateRects :: Int -> [(Coord, Coord)] -> [[(Int, Int)]] -> [(Coord, Coord)] - generateRects _ acc [] = acc - generateRects topRowOffset acc ([]:rows) = generateRects (topRowOffset + 1) acc rows - generateRects topRowOffset acc rows@((span:_):_) = - let rowsWithSpan = matchRowsWithSpan span rows - rowsWithSpanCount = length rowsWithSpan - in generateRects topRowOffset - (((fst span, topRowOffset), - (snd span, topRowOffset + rowsWithSpanCount - 1)) : acc) - (rowsWithSpan ++ drop rowsWithSpanCount rows) - - -- | Determines how many leading rows contain the given span. A list of - -- all the matching rows is returned, with the span deleted from each. - matchRowsWithSpan :: (Int, Int) -> [[(Int, Int)]] -> [[(Int, Int)]] - matchRowsWithSpan span (row:rows) - | span `elem` row = delete span row : matchRowsWithSpan span rows - | otherwise = [] - matchRowsWithSpan _ [] = [] - - -- | Builds a 'CoordList' from simple @(Coord, Coord)@ rectangles. - toCoordList :: [(Coord, Coord)] -> CoordList - toCoordList rects = - let (singles, properRects) = partition (uncurry (==)) rects - in coords' (map fst singles) properRects - --- | An SGF real value. -type RealValue = Rational - --- | A class for SGF data types that are coercable to and from strings. --- --- The construction of an SGF value with 'stringToSgf' may process the input, --- such that the resulting stringlike value does not represent the same string --- as the input. In other words, the following does *not* necessarily hold: --- --- > sgfToString . stringToSgf = id (does not necessarily hold!) --- --- The following does hold, however: --- --- > stringToSgf . sgfToString = id -class Stringlike a where - -- | Extracts the string value from an SGF value. - sgfToString :: a -> String - - -- | Creates an SGF value from a string value. - stringToSgf :: String -> a - --- | An SGF text value. -newtype Text = Text { fromText :: String - -- ^ Converts an SGF 'Text' to a string. - } - deriving (Eq, Show) - -instance Stringlike Text where - sgfToString = fromText - stringToSgf = toText - --- | Converts a string to an SGF 'Text'. -toText :: String -> Text -toText = Text - --- | An SGF SimpleText value. -newtype SimpleText = SimpleText { fromSimpleText :: String - -- ^ Converts an SGF 'SimpleText' to a string. - } - deriving (Eq, Show) - -instance Stringlike SimpleText where - sgfToString = fromSimpleText - stringToSgf = toSimpleText - -sanitizeSimpleText :: String -> String -sanitizeSimpleText = map (\c -> if isSpace c then ' ' else c) - --- | Converts a string to an SGF 'SimpleText', replacing all whitespaces --- (including newlines) with spaces. -toSimpleText :: String -> SimpleText -toSimpleText = SimpleText . sanitizeSimpleText - --- | The value type for an 'UnknownProperty'. Currently represented as a --- string. -data UnknownPropertyValue = UnknownPropertyValue { - fromUnknownPropertyValue :: String - -- ^ Returns the string contained within the 'UnknownProperty' this value is - -- from. - } deriving (Eq, Show) - -instance Stringlike UnknownPropertyValue where - sgfToString = fromUnknownPropertyValue - stringToSgf = toUnknownPropertyValue - --- | Constructs a value for a 'UnknownProperty'. -toUnknownPropertyValue :: String -> UnknownPropertyValue -toUnknownPropertyValue = UnknownPropertyValue - --- | An SGF double value: either 1 or 2, nothing else. -data DoubleValue = Double1 - | Double2 - deriving (Eq, Show) - --- | Stone color: black or white. -data Color = Black - | White - deriving (Eq, Show) - --- | Returns the logical negation of a stone color, yang for yin and --- yin for yang. -cnot :: Color -> Color -cnot Black = White -cnot White = Black - --- | SGF flags that control how move variations are to be presented while --- displaying the game. -data VariationMode = VariationMode { - variationModeSource :: VariationModeSource - -- ^ Which moves to display as variations. - , variationModeBoardMarkup :: Bool - -- ^ Whether to overlay variations on the board. - } deriving (Eq, Show) - --- | An enumeration that describes which variations are shown. -data VariationModeSource = - ShowChildVariations - -- ^ Show children of the current move. - | ShowCurrentVariations - -- ^ Show alternatives to the current move. - deriving (Bounded, Enum, Eq, Show) - --- | The default variation mode as defined by the SGF spec is @VariationMode --- ShowChildVariations True@. -defaultVariationMode :: VariationMode -defaultVariationMode = VariationMode ShowChildVariations True - --- | Parses a numeric variation mode, returning nothing if the number is --- invalid. -toVariationMode :: Int -> Maybe VariationMode -toVariationMode n = case n of - 0 -> Just $ VariationMode ShowChildVariations True - 1 -> Just $ VariationMode ShowCurrentVariations True - 2 -> Just $ VariationMode ShowChildVariations False - 3 -> Just $ VariationMode ShowCurrentVariations False - _ -> Nothing - --- | Returns the integer value for a variation mode. -fromVariationMode :: VariationMode -> Int -fromVariationMode mode = case mode of - VariationMode ShowChildVariations True -> 0 - VariationMode ShowCurrentVariations True -> 1 - VariationMode ShowChildVariations False -> 2 - VariationMode ShowCurrentVariations False -> 3 - --- | A list of arrows, each specified as @(startCoord, endCoord)@. -type ArrowList = [(Coord, Coord)] - --- | A list of lines, each specified as @(startCoord, endCoord)@. -type LineList = [(Coord, Coord)] - --- | A list of labels, each specified with a string and a coordinate about which --- to center the string. -type LabelList = [(Coord, SimpleText)] - --- | The markings that SGF supports annotating coordinates with. -data Mark = MarkCircle | MarkSquare | MarkTriangle | MarkX | MarkSelected - deriving (Bounded, Enum, Eq, Show) - -data GameResult = GameResultWin Color WinReason - | GameResultDraw - | GameResultVoid - | GameResultUnknown - | GameResultOther SimpleText - deriving (Eq, Show) - -data WinReason = WinByScore RealValue - | WinByResignation - | WinByTime - | WinByForfeit - deriving (Eq, Show) - --- | A ruleset used for a Go game. Can be one of the rulesets defined by the --- SGF specification, or a custom string. -data Ruleset = KnownRuleset RulesetType - | UnknownRuleset String - deriving (Eq, Show) - --- | The rulesets defined by the SGF specification, for use with 'Ruleset'. -data RulesetType = RulesetAga - | RulesetIng - | RulesetJapanese - | RulesetNewZealand - deriving (Bounded, Enum, Eq, Show) - --- | Returns the string representation for a ruleset. -fromRuleset :: Ruleset -> String -fromRuleset ruleset = case ruleset of - KnownRuleset RulesetAga -> "AGA" - KnownRuleset RulesetIng -> "Goe" - KnownRuleset RulesetJapanese -> "Japanese" - KnownRuleset RulesetNewZealand -> "NZ" - UnknownRuleset str -> str - --- | Parses a string representation of a ruleset. -toRuleset :: String -> Ruleset -toRuleset str = case str of - "AGA" -> KnownRuleset RulesetAga - "Goe" -> KnownRuleset RulesetIng - "Japanese" -> KnownRuleset RulesetJapanese - "NZ" -> KnownRuleset RulesetNewZealand - _ -> UnknownRuleset str diff --git a/tests/Game/Goatee/Common/BigfloatTest.hs b/tests/Game/Goatee/Common/BigfloatTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Common/BigfloatTest.hs @@ -0,0 +1,269 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Common.BigfloatTest (tests) where + +import Game.Goatee.Common.Bigfloat +import Game.Goatee.Test.Common +import Prelude hiding (exponent, significand) +import Test.HUnit ((~:), (@=?), Assertion, Test (TestList)) + +assertBigfloat :: Integer -> Int -> Bigfloat -> Assertion +assertBigfloat v e x = + (v, e) @=? (significand x, exponent x) + +testAddition :: String -> String -> Integer -> Int -> Test +testAddition x y v e = + x ++ " + " ++ y ~: assertBigfloat v e $ read x + read y + +testSubtraction :: String -> String -> Integer -> Int -> Test +testSubtraction x y v e = + x ++ " - " ++ y ~: assertBigfloat v e $ read x - read y + +testMultiplication :: String -> String -> Integer -> Int -> Test +testMultiplication x y v e = + x ++ " * " ++ y ~: assertBigfloat v e $ read x * read y + +tests = "Game.Goatee.Common.Bigfloat" ~: TestList + [ encodeTests + , readInstanceTests + , showInstanceTests + , fromDoubleTests + , toDoubleTests + , numInstanceTests + , eqInstanceTests + , ordInstanceTests + ] + +encodeTests = "encode" ~: TestList + [ "zero" ~: assertBigfloat 0 0 $ encode 0 0 + + , "whole numbers" ~: TestList + [ "1" ~: assertBigfloat 1 0 $ encode 1 0 + , "5" ~: assertBigfloat 5 0 $ encode 5 0 + , "12" ~: assertBigfloat 12 0 $ encode 12 0 + , "1031" ~: assertBigfloat 1031 0 $ encode 1031 0 + + , "-1" ~: assertBigfloat (-1) 0 $ encode (-1) 0 + , "-5" ~: assertBigfloat (-5) 0 $ encode (-5) 0 + , "-12" ~: assertBigfloat (-12) 0 $ encode (-12) 0 + , "-1031" ~: assertBigfloat (-1031) 0 $ encode (-1031) 0 + ] + + , "fractional numbers" ~: TestList + [ "0.1" ~: assertBigfloat 1 (-1) $ encode 1 (-1) + , "0.5" ~: assertBigfloat 5 (-1) $ encode 5 (-1) + , "1.5" ~: assertBigfloat 15 (-1) $ encode 15 (-1) + , "123.456" ~: assertBigfloat 123456 (-3) $ encode 123456 (-3) + , "0.00125" ~: assertBigfloat 125 (-5) $ encode 125 (-5) + + , "-0.1" ~: assertBigfloat (-1) (-1) $ encode (-1) (-1) + , "-0.5" ~: assertBigfloat (-5) (-1) $ encode (-5) (-1) + , "-1.5" ~: assertBigfloat (-15) (-1) $ encode (-15) (-1) + , "-123.456" ~: assertBigfloat (-123456) (-3) $ encode (-123456) (-3) + , "-0.00125" ~: assertBigfloat (-125) (-5) $ encode (-125) (-5) + ] + + , "extreme numbers" ~: TestList + [ "12345678901234567890123456789012345678901234567890" ~: + assertBigfloat 1234567890123456789012345678901234567890123456789 1 $ + encode 12345678901234567890123456789012345678901234567890 0 + + , "0.00000000000000000000000000000000000000000000000001" ~: + assertBigfloat 1 (-50) $ encode 1 (-50) + + , "123456789012345678901234567890.123456789012345678901234567890" ~: + assertBigfloat 12345678901234567890123456789012345678901234567890123456789 (-29) $ + encode 123456789012345678901234567890123456789012345678901234567890 (-30) + ] + + , "reduction" ~: TestList + [ "50.0" ~: assertBigfloat 5 1 $ encode 500 (-1) + , "123.456000" ~: assertBigfloat 123456 (-3) $ encode 123456000 (-6) + + , "-50.0" ~: assertBigfloat (-5) 1 $ encode (-500) (-1) + , "-123.456000" ~: assertBigfloat (-123456) (-3) $ encode (-123456000) (-6) + ] + ] + +readInstanceTests = "Read instance" ~: TestList + [ "0" ~: assertBigfloat 0 0 $ read "0" + , "3" ~: assertBigfloat 3 0 $ read "3" + , "10" ~: assertBigfloat 1 1 $ read "10" + , "51200" ~: assertBigfloat 512 2 $ read "51200" + , "5120" ~: assertBigfloat 512 1 $ read "5120" + , "512" ~: assertBigfloat 512 0 $ read "512" + , "512.0" ~: assertBigfloat 512 0 $ read "512.0" + , "51.2" ~: assertBigfloat 512 (-1) $ read "51.2" + , "05.12" ~: assertBigfloat 512 (-2) $ read "05.12" + , "0.512" ~: assertBigfloat 512 (-3) $ read "0.512" + , "0.051200" ~: assertBigfloat 512 (-4) $ read "0.051200" + + , "-0" ~: assertBigfloat 0 0 $ read "-0" + , "-3" ~: assertBigfloat (-3) 0 $ read "-3" + , "-10" ~: assertBigfloat (-1) 1 $ read "-10" + , "-51200" ~: assertBigfloat (-512) 2 $ read "-51200" + , "-5120" ~: assertBigfloat (-512) 1 $ read "-5120" + , "-512" ~: assertBigfloat (-512) 0 $ read "-512" + , "-512.0" ~: assertBigfloat (-512) 0 $ read "-512.0" + , "-51.2" ~: assertBigfloat (-512) (-1) $ read "-51.2" + , "-05.12" ~: assertBigfloat (-512) (-2) $ read "-05.12" + , "-0.512" ~: assertBigfloat (-512) (-3) $ read "-0.512" + , "-0.051200" ~: assertBigfloat (-512) (-4) $ read "-0.051200" + + , "0e0" ~: assertBigfloat 0 0 $ read "0e0" + , "0e-0" ~: assertBigfloat 0 0 $ read "0e-0" + , "0e1" ~: assertBigfloat 0 0 $ read "0e1" + , "0e-1" ~: assertBigfloat 0 0 $ read "0e-1" + , "0.0e0" ~: assertBigfloat 0 0 $ read "0.0e0" + , "1e0" ~: assertBigfloat 1 0 $ read "1e0" + , "1e1" ~: assertBigfloat 1 1 $ read "1e1" + , "1e2" ~: assertBigfloat 1 2 $ read "1e2" + , "1e-1" ~: assertBigfloat 1 (-1) $ read "1e-1" + , "1e-2" ~: assertBigfloat 1 (-2) $ read "1e-2" + , "100e2" ~: assertBigfloat 1 4 $ read "100e2" + , "100e-1" ~: assertBigfloat 1 1 $ read "100e-1" + , "100e-3" ~: assertBigfloat 1 (-1) $ read "100e-3" + , "0.0002e-5" ~: assertBigfloat 2 (-9) $ read "0.0002e-5" + , "0.0002e2" ~: assertBigfloat 2 (-2) $ read "0.0002e2" + , "0.0002e5" ~: assertBigfloat 2 1 $ read "0.0002e5" + ] + +showInstanceTests = "Show instance" ~: TestList + [ "0" ~: "0" @=? show (encode 0 0) + + , "3" ~: "3" @=? show (encode 3 0) + , "10" ~: "10" @=? show (encode 1 1) + , "51200" ~: "51200" @=? show (encode 512 2) + , "5120" ~: "5120" @=? show (encode 512 1) + , "512" ~: "512" @=? show (encode 512 0) + , "51.2" ~: "51.2" @=? show (encode 512 (-1)) + , "5.12" ~: "5.12" @=? show (encode 512 (-2)) + , "0.512" ~: "0.512" @=? show (encode 512 (-3)) + , "0.0512" ~: "0.0512" @=? show (encode 512 (-4)) + + , "-3" ~: "-3" @=? show (encode (-3) 0) + , "-10" ~: "-10" @=? show (encode (-10) 0) + , "-51200" ~: "-51200" @=? show (encode (-512) 2) + , "-5120" ~: "-5120" @=? show (encode (-512) 1) + , "-512" ~: "-512" @=? show (encode (-512) 0) + , "-51.2" ~: "-51.2" @=? show (encode (-512) (-1)) + , "-5.12" ~: "-5.12" @=? show (encode (-512) (-2)) + , "-0.512" ~: "-0.512" @=? show (encode (-512) (-3)) + , "-0.0512" ~: "-0.0512" @=? show (encode (-512) (-4)) + ] + +fromDoubleTests = "fromDouble" ~: TestList + [ "0" ~: read "0" @=? fromDouble 0 + , "120" ~: read "120" @=? fromDouble 120 + , "12" ~: read "12" @=? fromDouble 12 + , "1.2" ~: read "1.2" @=? fromDouble 1.2 + , "0.12" ~: read "0.12" @=? fromDouble 0.12 + , "0.012" ~: read "0.012" @=? fromDouble 0.012 + , "1234567890123456" ~: read "1234567890123456" @=? fromDouble 1234567890123456 + + , "-0" ~: read "0" @=? fromDouble (-0) + , "-120" ~: read "-120" @=? fromDouble (-120) + , "-12" ~: read "-12" @=? fromDouble (-12) + , "-1.2" ~: read "-1.2" @=? fromDouble (-1.2) + , "-0.12" ~: read "-0.12" @=? fromDouble (-0.12) + , "-0.012" ~: read "-0.012" @=? fromDouble (-0.012) + , "-1234567890123456" ~: read "-1234567890123456" @=? fromDouble (-1234567890123456) + ] + +toDoubleTests = "toDouble" ~: TestList + [ "0" ~: 0 @=? toDouble (read "0") + , "30" ~: 30 @=? toDouble (read "30") + , "0.125" ~: 0.125 @=? toDouble (read "0.125") + , "-1234567890" ~: (-1234567890) @=? toDouble (read "-1234567890") + ] + +numInstanceTests = "Num instance" ~: TestList + [ "addition" ~: TestList + [ testAddition "2" "5" 7 0 + , testAddition "5" "2" 7 0 + , testAddition "123" "4560" 4683 0 + , testAddition "4560" "123" 4683 0 + , testAddition "1000" "0.01" 100001 (-2) + , testAddition "-120" "120" 0 0 + , testAddition "-120" "119.9" (-1) (-1) + ] + + , "subtraction" ~: TestList + [ testSubtraction "2" "5" (-3) 0 + , testSubtraction "5" "2" 3 0 + , testSubtraction "123" "4560" (-4437) 0 + , testSubtraction "4560" "123" 4437 0 + , testSubtraction "1000" "0.01" 99999 (-2) + , testSubtraction "119.9" "120" (-1) (-1) + , testSubtraction "120" "120" 0 0 + ] + + , "multiplication" ~: TestList + [ testMultiplication "0" "0" 0 0 + , testMultiplication "0" "1" 0 0 + , testMultiplication "10" "0" 0 0 + , testMultiplication "10000" "0.001" 1 1 + , testMultiplication "10000" "0.0001" 1 0 + , testMultiplication "10000" "0.00001" 1 (-1) + , testMultiplication "123.456" "10000.4" 12346093824 (-4) + ] + + , "negation" ~: TestList + [ "0" ~: assertBigfloat 0 0 $ negate $ read "0" + , "100" ~: assertBigfloat (-1) 2 $ negate $ read "100" + , "-4.01" ~: assertBigfloat 401 (-2) $ negate $ read "-4.01" + ] + + , "abs" ~: TestList + [ "0" ~: assertBigfloat 0 0 $ abs $ read "0" + , "100" ~: assertBigfloat 1 2 $ abs $ read "100" + , "-4.01" ~: assertBigfloat 401 (-2) $ abs $ read "-4.01" + ] + + , "signum" ~: TestList + [ "0" ~: assertBigfloat 0 0 $ signum $ read "0" + , "100" ~: assertBigfloat 1 0 $ signum $ read "100" + , "-4.01" ~: assertBigfloat (-1) 0 $ signum $ read "-4.01" + ] + + , "fromInteger" ~: TestList + [ "0" ~: assertBigfloat 0 0 (0 :: Bigfloat) + , "100" ~: assertBigfloat 1 2 (100 :: Bigfloat) + , "-12" ~: assertBigfloat (-12) 0 (-12 :: Bigfloat) + ] + ] + +eqInstanceTests = "Eq instance" ~: TestList + [ "0 == 0" ~: encode 0 0 @=? encode 0 0 + , "1 == 1" ~: encode 1 0 @=? encode 1 0 + , "1 == 1.0" ~: encode 1 0 @=? encode 10 (-1) + , "-1 == -1" ~: encode (-1) 0 @=? encode (-1) 0 + + , "0 /= 1" ~: encode 0 0 @/=? encode 1 0 + , "1 /= -1" ~: encode 1 0 @/=? encode (-1) 0 + , "50 /= 5" ~: encode 50 0 @/=? encode 5 0 + , "314 /= 0.314" ~: encode 314 0 @/=? encode 314 (-3) + ] + +ordInstanceTests = "ordering" ~: TestList + [ "0 EQ 0" ~: EQ @=? encode 0 0 `compare` encode 0 0 + , "0 LT 5" ~: LT @=? encode 0 0 `compare` encode 5 0 + , "-1 LT 5" ~: LT @=? encode (-1) 0 `compare` encode 5 0 + , "5 GT 0" ~: GT @=? encode 5 0 `compare` encode 0 0 + , "0.123 LT 123" ~: LT @=? encode 123 (-3) `compare` encode 123 0 + ] diff --git a/tests/Game/Goatee/CommonTest.hs b/tests/Game/Goatee/CommonTest.hs --- a/tests/Game/Goatee/CommonTest.hs +++ b/tests/Game/Goatee/CommonTest.hs @@ -19,178 +19,177 @@ import qualified Control.Monad.State as State import Control.Monad.Identity (runIdentity) -import Control.Monad.State (StateT, get, put, runStateT) +import Control.Monad.State (get, put, runStateT) import Control.Monad.Writer (execWriter, tell) import Data.IORef (modifyIORef, newIORef, readIORef) -import Data.Monoid (mappend, mempty) import Game.Goatee.Common -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?), assertFailure) +import Test.HUnit ((~:), (@=?), Test (TestList), assertFailure) {-# ANN module "HLint: ignore Use camelCase" #-} -tests = testGroup "Game.Goatee.Common" [ - listDeleteIndexTests, - listReplaceTests, - onLeftTests, - onRightTests, - andEithersTests, - forTests, - mapTupleTests, - whenMaybeTests, - condTests, - if'Tests, - andMTests, - forIndexM_Tests, - whileMTests, - whileM'Tests, - doWhileMTests, - seqTests +tests = "Game.Goatee.Common" ~: TestList + [ listDeleteAtTests + , listInsertAtTests + , listReplaceTests + , andEithersTests + , forTests + , mapTupleTests + , whenMaybeTests + , condTests + , if'Tests + , andMTests + , forIndexM_Tests + , whileMTests + , whileM'Tests + , doWhileMTests ] -listDeleteIndexTests = testGroup "listDeleteIndex" [ - testCase "deletes nothing from an empty list" $ do - [] @=? listDeleteIndex (-1) ([] :: [()]) - [] @=? listDeleteIndex 0 ([] :: [()]) - [] @=? listDeleteIndex 1 ([] :: [()]), +listDeleteAtTests = "listDeleteAt" ~: TestList + [ "deletes nothing from an empty list" ~: do + [] @=? listDeleteAt (-1) ([] :: [()]) + [] @=? listDeleteAt 0 ([] :: [()]) + [] @=? listDeleteAt 1 ([] :: [()]) - testCase "deletes the only item from a singleton list" $ - [] @=? listDeleteIndex 0 [()], + , "deletes the only item from a singleton list" ~: + [] @=? listDeleteAt 0 [()] - testCase "deletes the head of a list" $ - [False] @=? listDeleteIndex 0 [True, False], + , "deletes the head of a list" ~: + [False] @=? listDeleteAt 0 [True, False] - testCase "deletes the tail of a list" $ - [Just 0, Nothing] @=? listDeleteIndex 2 [Just 0, Nothing, Just 1], + , "deletes the tail of a list" ~: + [Just 0, Nothing] @=? listDeleteAt 2 [Just 0, Nothing, Just 1] - testCase "deletes an inner item from a list" $ - [Just 0, Just 1] @=? listDeleteIndex 1 [Just 0, Nothing, Just 1], + , "deletes an inner item from a list" ~: + [Just 0, Just 1] @=? listDeleteAt 1 [Just 0, Nothing, Just 1] - testCase "ignores a negative index" $ do - [1, 2, 3] @=? listDeleteIndex (-1) [1, 2, 3] - [1, 2, 3] @=? listDeleteIndex (-2) [1, 2, 3], + , "ignores a negative index" ~: do + [1, 2, 3] @=? listDeleteAt (-1) [1, 2, 3] + [1, 2, 3] @=? listDeleteAt (-2) [1, 2, 3] - testCase "ignores an index too large" $ do - [1, 2, 3] @=? listDeleteIndex 3 [1, 2, 3] - [1, 2, 3] @=? listDeleteIndex 4 [1, 2, 3] + , "ignores an index too large" ~: do + [1, 2, 3] @=? listDeleteAt 3 [1, 2, 3] + [1, 2, 3] @=? listDeleteAt 4 [1, 2, 3] ] -listReplaceTests = testGroup "listReplace" [ - testCase "accepts an empty list" $ - [] @=? listReplace False True [], - - testCase "replaces the first element" $ - [100, 2, 3] @=? listReplace 1 100 [1, 2, 3], - - testCase "replaces the last element" $ - [1, 2, 300] @=? listReplace 3 300 [1, 2, 3], +listInsertAtTests = "listInsertAt" ~: TestList + [ "adds at the beginning of a list" ~: do + let expected = [10, 3, 1, 5, 2] + expected @=? listInsertAt 0 elt base + expected @=? listInsertAt (-1) elt base + expected @=? listInsertAt (-2) elt base - testCase "replaces an interior element" $ - [1, 200, 3] @=? listReplace 2 200 [1, 2, 3], + , "adds in the middle of a list" ~: do + [3, 10, 1, 5, 2] @=? listInsertAt 1 elt base + [3, 1, 10, 5, 2] @=? listInsertAt 2 elt base + [3, 1, 5, 10, 2] @=? listInsertAt 3 elt base - testCase "replaces multiple elements" $ do - [1, 0, 3, 4, 0, 0, 3] @=? listReplace 2 0 [1, 2, 3, 4, 2, 2, 3] - replicate 10 True @=? listReplace False True (replicate 10 False) + , "adds at the end of a list" ~: do + let expected = [3, 1, 5, 2, 10] + expected @=? listInsertAt (length base) elt base + expected @=? listInsertAt (length base + 1) elt base + expected @=? listInsertAt (length base + 2) elt base ] + where base = [3, 1, 5, 2] + elt = 10 -onLeftTests = testGroup "onLeft" [ - testCase "changes a Left" $ - Left 10 @=? onLeft (* 2) (Left 5 :: Either Int ()), +listReplaceTests = "listReplace" ~: TestList + [ "accepts an empty list" ~: + [] @=? listReplace False True [] - testCase "doesn't change a Right" $ - Right False @=? onLeft (* 2) (Right False) - ] + , "replaces the first element" ~: + [100, 2, 3] @=? listReplace 1 100 [1, 2, 3] -onRightTests = testGroup "onRight" [ - testCase "doesn't change a Left" $ - Left False @=? onRight (* 2) (Left False), + , "replaces the last element" ~: + [1, 2, 300] @=? listReplace 3 300 [1, 2, 3] - testCase "changes a Right" $ - Right 10 @=? onRight (* 2) (Right 5 :: Either () Int) + , "replaces an interior element" ~: + [1, 200, 3] @=? listReplace 2 200 [1, 2, 3] + + , "replaces multiple elements" ~: do + [1, 0, 3, 4, 0, 0, 3] @=? listReplace 2 0 [1, 2, 3, 4, 2, 2, 3] + replicate 10 True @=? listReplace False True (replicate 10 False) ] -andEithersTests = testGroup "andEithers" [ - testCase "returns Right for an empty list" $ - Right [] @=? andEithers ([] :: [Either () ()]), +andEithersTests = "andEithers" ~: TestList + [ "returns Right for an empty list" ~: + Right [] @=? andEithers ([] :: [Either () ()]) - testCase "returns Right when given all Rights" $ do + , "returns Right when given all Rights" ~: do Right [1] @=? andEithers [Right 1 :: Either () Int] Right [1, 2] @=? andEithers [Right 1, Right 2 :: Either () Int] - Right [1, 2, 3] @=? andEithers [Right 1, Right 2, Right 3 :: Either () Int], + Right [1, 2, 3] @=? andEithers [Right 1, Right 2, Right 3 :: Either () Int] - testCase "returns Left when there is a single Left" $ do + , "returns Left when there is a single Left" ~: do Left [1] @=? andEithers [Left 1 :: Either Int ()] Left [1] @=? andEithers [Left 1, Right 2] Left [2] @=? andEithers [Right 1, Left 2] Left [2] @=? andEithers [Right 1, Left 2, Right 3] - Left [3] @=? andEithers [Right 1, Right 2, Left 3], + Left [3] @=? andEithers [Right 1, Right 2, Left 3] - testCase "returns Left when there are many Lefts" $ do + , "returns Left when there are many Lefts" ~: do Left [1, 2] @=? andEithers [Left 1, Left 2, Right 3] Left [1, 3] @=? andEithers [Left 1, Right 2, Left 3] Left [2, 3] @=? andEithers [Right 1, Left 2, Left 3] Left [1, 2, 3] @=? andEithers [Left 1, Left 2, Left 3 :: Either Int ()] ] -forTests = testGroup "for" [ - testCase "passes an empty list through" $ - ([] @=?) =<< sequence (for [] $ const $ assertFailure "Nope."), +forTests = "for" ~: TestList + [ "passes an empty list through" ~: + ([] @=?) =<< sequence (for [] $ const $ assertFailure "Nope.") - testCase "operates on each element of a list" $ + , "operates on each element of a list" ~: [2, 2, 4, 6, 10] @=? for [1, 1, 2, 3, 5] (* 2) ] -mapTupleTests = testGroup "mapTuple" [ - testCase "updates both values" $ +mapTupleTests = "mapTuple" ~: TestList + [ "updates both values" ~: (9, 16) @=? mapTuple (^ 2) (3, 4) ] -whenMaybeTests = testGroup "whenMaybeTests" [ - testCase "doesn't invoke its function when given Nothing" $ - 0 @=? State.execState (whenMaybe Nothing $ \x -> State.put (x * 2)) 0, +whenMaybeTests = "whenMaybeTests" ~: TestList + [ "doesn't invoke its function when given Nothing" ~: + 0 @=? State.execState (whenMaybe Nothing $ \x -> State.put (x * 2)) 0 - testCase "invokes its function when given a Just" $ + , "invokes its function when given a Just" ~: 6 @=? State.execState (whenMaybe (Just 3) $ \x -> State.put (x * 2)) 0 ] -condTests = testGroup "cond" [ - testCase "accepts an empty list of cases" $ - True @=? cond True [], +condTests = "cond" ~: TestList + [ "accepts an empty list of cases" ~: + True @=? cond True [] - testCase "returns the default when all cases are false" $ do + , "returns the default when all cases are false" ~: do 0 @=? cond 0 [(False, 1)] 0 @=? cond 0 [(False, 1), (False, 2)] - 0 @=? cond 0 [(False, 1), (False, 2), (False, 3)], + 0 @=? cond 0 [(False, 1), (False, 2), (False, 3)] - testCase "returns a single true case" $ do + , "returns a single true case" ~: do 3 @=? cond 0 [(False, 1), (False, 2), (True, 3)] 2 @=? cond 0 [(False, 1), (True, 2), (False, 3)] - 1 @=? cond 0 [(True, 1), (False, 2), (False, 3)], + 1 @=? cond 0 [(True, 1), (False, 2), (False, 3)] - testCase "returns the first true case" $ do + , "returns the first true case" ~: do 3 @=? cond 0 [(False, 1), (False, 2), (True, 3)] 2 @=? cond 0 [(False, 1), (True, 2), (True, 3)] 1 @=? cond 0 [(True, 1), (True, 2), (True, 3)] ] -if'Tests = testGroup "if'" [ - testCase "detects true" $ "yes" @=? if' "yes" "no" True, - - testCase "detects false" $ "no" @=? if' "yes" "no" False +if'Tests = "if'" ~: TestList + [ "detects true" ~: "yes" @=? if' "yes" "no" True + , "detects false" ~: "no" @=? if' "yes" "no" False ] -andMTests = testGroup "andM" [ - testCase "empty list returns true" $ True @=? runIdentity (andM []), +andMTests = "andM" ~: TestList + [ "empty list returns true" ~: True @=? runIdentity (andM []) - testCase "aborts after an immediate true" $ do + , "aborts after an immediate true" ~: do ref <- newIORef 0 result <- andM [addToRef ref 1 >> return False, addToRef ref 2 >> return True] False @=? result - (1 @=?) =<< readIORef ref, + (1 @=?) =<< readIORef ref - testCase "aborts on a false after trues" $ do + , "aborts on a false after trues" ~: do ref <- newIORef 0 result <- andM [addToRef ref 1 >> return True, addToRef ref 2 >> return True, @@ -198,9 +197,9 @@ addToRef ref 8 >> return False, addToRef ref 16 >> return False] False @=? result - (7 @=?) =<< readIORef ref, + (7 @=?) =<< readIORef ref - testCase "executes all trues" $ do + , "executes all trues" ~: do ref <- newIORef 0 result <- andM [addToRef ref 1 >> return True, addToRef ref 2 >> return True, @@ -211,20 +210,20 @@ ] where addToRef ref num = modifyIORef ref (+ num) -forIndexM_Tests = testGroup "forIndexM_" [ - testCase "does nothing with an empty list" $ - "" @=? execWriter (forIndexM_ [] $ \_ _ -> tell "x"), +forIndexM_Tests = "forIndexM_" ~: TestList + [ "does nothing with an empty list" ~: + "" @=? execWriter (forIndexM_ [] $ \_ _ -> tell "x") - testCase "iterates over all elements in order" $ + , "iterates over all elements in order" ~: "(0,'a')(1,'b')(2,'c')" @=? execWriter (forIndexM_ "abc" $ \index value -> tell $ show (index, value)) ] -whileMTests = testGroup "whileM" [ - testCase "never executes the body if the first test returns false" $ - "" @=? execWriter (whileM (return False) (tell "x")), +whileMTests = "whileM" ~: TestList + [ "never executes the body if the first test returns false" ~: + "" @=? execWriter (whileM (return False) (tell "x")) - testCase "executes repeatedly as expected" $ + , "executes repeatedly as expected" ~: let test = do n <- get tell $ show n if n > 0 @@ -234,38 +233,28 @@ in "3x2x1x0" @=? execWriter (runStateT (whileM test body) 3) ] -whileM'Tests = testGroup "whileM'" [ - testCase "never executes the body if the first test returns Nothing" $ - "" @=? execWriter (whileM' (return Nothing) (const $ tell "x")), +whileM'Tests = "whileM'" ~: TestList + [ "never executes the body if the first test returns Nothing" ~: + "" @=? execWriter (whileM' (return Nothing) (const $ tell "x")) - testCase "executes repeatedly as expected" $ + , "executes repeatedly as expected" ~: let test = get >>= \n -> return $ if n > 0 then Just n else Nothing body n = do tell $ show n put (n - 1) in "321" @=? execWriter (runStateT (whileM' test body) 3) ] -doWhileMTests = testGroup "doWhileM" [ - testCase "executes a constantly-Left body once" $ do +doWhileMTests = "doWhileM" ~: TestList + [ "executes a constantly-Left body once" ~: do countVar <- newIORef 0 result <- doWhileM () (const $ do modifyIORef countVar (+ 1) return $ Left "done") count <- readIORef countVar - (1, "done") @=? (count, result), + (1, "done") @=? (count, result) - testCase "executes until a Left is returned" $ + , "executes until a Left is returned" ~: execWriter (doWhileM 9 $ \n -> do tell $ show n - return $ if n == 0 then Left () else Right $ n - 1) - @=? "9876543210" - ] - -seqTests = testGroup "Seq" [ - testCase "mempty does nothing" $ - let Seq action = mempty - in "" @=? execWriter action, - - testCase "mappend works" $ - let Seq action = Seq (tell "a") `mappend` Seq (tell "b") - in "ab" @=? execWriter action + return $ if n == 0 then Left () else Right $ n - 1) @=? + "9876543210" ] diff --git a/tests/Game/Goatee/Lib/BoardTest.hs b/tests/Game/Goatee/Lib/BoardTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/BoardTest.hs @@ -0,0 +1,195 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.BoardTest (tests) where + +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.TestInstances () +import Game.Goatee.Lib.TestUtils +import Game.Goatee.Lib.Tree +import Game.Goatee.Lib.Types +import Test.HUnit ((~:), (@=?), (@?=), Test (TestList)) + +tests = "Game.Goatee.Lib.Board" ~: TestList + [ boardCoordStateTests + , moveNumberTests + , markupPropertiesTests + , visibilityPropertyTests + , cursorModifyNodeTests + , moveToPropertyTests + ] + +boardCoordStateTests = "boardCoordState" ~: TestList + [ "works for a 1x1 board" ~: do + let state = boardCoordState (0,0) $ rootBoardState $ + node [SZ 1 1, CR $ coord1 (0,0)] + coordStone state @?= Nothing + coordMark state @?= Just MarkCircle + + , "works for a 2x2 board" ~: do + let board = rootBoardState $ + node [SZ 2 2, B $ Just (0,0), TR $ coord1 (0,0), MA $ coord1 (1,1)] + coordStone (boardCoordState (0,0) board) @?= Just Black + coordMark (boardCoordState (0,0) board) @?= Just MarkTriangle + coordStone (boardCoordState (1,0) board) @?= Nothing + coordMark (boardCoordState (1,0) board) @?= Nothing + coordStone (boardCoordState (1,1) board) @?= Nothing + coordMark (boardCoordState (1,1) board) @?= Just MarkX + ] + + +moveNumberTests = "move number" ~: TestList + [ "starts at zero" ~: + 0 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [] $ node [B Nothing]) + + , "advances for nodes with moves" ~: do + 1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [] $ node [B Nothing]) + 1 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [B Nothing] $ node []) + 1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [B Nothing] $ node []) + 2 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [B Nothing] $ node [W Nothing]) + 2 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $ + node1 [B Nothing] $ node1 [W Nothing] $ node []) + 3 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $ + node1 [B Nothing] $ node1 [W Nothing] $ node [B Nothing]) + + , "doesn't advance for non-move nodes" ~: do + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [] $ node []) + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [PL White] $ node []) + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [AB $ coords [(0,0)]] $ node []) + 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ + node1 [IT, TE Double2, GN $ toSimpleText "Title"] $ node []) + ] + +markupPropertiesTests = "markup properties" ~: TestList + [ "adds marks to a BoardState" ~: TestList + [ "CR" ~: Just MarkCircle @=? getMark 0 0 (rootCursor $ node [CR $ coords [(0,0)]]) + , "MA" ~: Just MarkX @=? getMark 0 0 (rootCursor $ node [MA $ coords [(0,0)]]) + , "SL" ~: Just MarkSelected @=? getMark 0 0 (rootCursor $ node [SL $ coords [(0,0)]]) + , "SQ" ~: Just MarkSquare @=? getMark 0 0 (rootCursor $ node [SQ $ coords [(0,0)]]) + , "TR" ~: Just MarkTriangle @=? getMark 0 0 (rootCursor $ node [TR $ coords [(0,0)]]) + , "multiple at once" ~: do + let cursor = rootCursor $ node [SZ 2 2, + CR $ coords [(0,0), (1,1)], + TR $ coords [(1,0)]] + [[Just MarkCircle, Just MarkTriangle], + [Nothing, Just MarkCircle]] + @=? map (map coordMark) (boardCoordStates $ cursorBoard cursor) + ] + + , "adds more complex annotations to a BoardState" ~: TestList + [ "AR" ~: [((0,0), (1,1))] @=? boardArrows (rootCoord $ node [AR [((0,0), (1,1))]]) + , "LB" ~: [((0,0), st "Hi")] @=? boardLabels (rootCoord $ node [LB [((0,0), st "Hi")]]) + , "LN" ~: [((0,0), (1,1))] @=? boardLines (rootCoord $ node [LN [((0,0), (1,1))]]) + ] + + , "clears annotations when moving to a child node" ~: do + let root = node1 [SZ 3 2, + CR $ coords [(0,0)], + MA $ coords [(1,0)], + SL $ coords [(2,0)], + SQ $ coords [(0,1)], + TR $ coords [(1,1)], + AR [((0,0), (2,1))], + LB [((2,1), st "Empty")], + LN [((1,1), (2,0))]] $ + node [] + board = cursorBoard $ child 0 $ rootCursor root + mapM_ (mapM_ ((Nothing @=?) . coordMark)) $ boardCoordStates board + [] @=? boardArrows board + [] @=? boardLines board + [] @=? boardLabels board + ] + where rootCoord = cursorBoard . rootCursor + st = toSimpleText + + getMark :: Int -> Int -> Cursor -> Maybe Mark + getMark x y cursor = coordMark $ boardCoordStates (cursorBoard cursor) !! y !! x + +visibilityPropertyTests = "visibility properties" ~: TestList + [ "boards start with all points undimmed" ~: + replicate 9 (replicate 9 False) @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]) + + , "DD selectively dims points" ~: + let root = node [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]] + in [[True, True, False, True, False], + [True, True, False, False, False]] @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor root) + + , "dimming is inherited" ~: + let root = node1 [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]] $ node [] + in [[True, True, False, True, False], + [True, True, False, False, False]] @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root) + + , "DD[] clears dimming" ~: + let root = node1 [SZ 2 1, DD $ coords [(0,0)]] $ node [DD $ coords []] + in [[False, False]] @=? + map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root) + + , "boards start with all points visible" ~: + replicate 9 (replicate 9 True) @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]) + + , "VW selectively makes points visible" ~: + let root = node [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]] + in [[False, True, True, True, True], + [True, False, True, True, True]] @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor root) + + , "visibility is inherited" ~: + let root = node1 [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]] $ node [] + in [[False, True, True, True, True], + [True, False, True, True, True]] @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root) + + , "VW[] clears dimming" ~: + let root = node1 [SZ 2 1, VW $ coords [(0,0)]] $ node [VW $ coords []] + in [[True, True]] @=? + map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root) + ] + +cursorModifyNodeTests = "cursorModifyNode" ~: TestList + [ "updates the BoardState" ~: + let cursor = child 0 $ rootCursor $ + node1 [SZ 3 1, B $ Just (0,0)] $ + node [W $ Just (1,0)] + modifyProperty prop = case prop of + W (Just (1,0)) -> W $ Just (2,0) + _ -> prop + modifyNode node = node { nodeProperties = map modifyProperty $ nodeProperties node } + result = cursorModifyNode modifyNode cursor + in map (map coordStone) (boardCoordStates $ cursorBoard result) @?= + [[Just Black, Nothing, Just White]] + ] + +moveToPropertyTests = "moveToProperty" ~: TestList + [ "creates Black moves" ~: do + B Nothing @=? moveToProperty Black Nothing + B (Just (3,2)) @=? moveToProperty Black (Just (3,2)) + B (Just (0,0)) @=? moveToProperty Black (Just (0,0)) + + , "creates White moves" ~: do + W Nothing @=? moveToProperty White Nothing + W (Just (18,18)) @=? moveToProperty White (Just (18,18)) + W (Just (15,16)) @=? moveToProperty White (Just (15,16)) + ] diff --git a/tests/Game/Goatee/Lib/MonadTest.hs b/tests/Game/Goatee/Lib/MonadTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/MonadTest.hs @@ -0,0 +1,886 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.MonadTest (tests) where + +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&), second) +import Control.Monad (forM_, liftM, replicateM_, void) +import Control.Monad.Writer (Writer, execWriter, runWriter, tell) +import Data.List (unfoldr) +import Data.Maybe (fromJust, maybeToList) +import Game.Goatee.Common +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Monad +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.TestInstances () +import Game.Goatee.Lib.TestUtils +import Game.Goatee.Lib.Tree (emptyNode, nodeChildren) +import Game.Goatee.Lib.Types +import Game.Goatee.Test.Common +import Test.HUnit ((~:), (@=?), (@?=), Test (TestList)) + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +type LoggedGoM = GoT (Writer [String]) + +runLoggedGo :: LoggedGoM a -> Cursor -> (a, Cursor, [String]) +runLoggedGo go cursor = + let ((value, cursor'), log) = runWriter $ runGoT go cursor + in (value, cursor', log) + +tests = "Game.Goatee.Lib.Monad" ~: TestList + [ monadTests + , navigationTests + , positionStackTests + , propertiesTests + , getPropertyTests + , getPropertyValueTests + , putPropertyTests + , deletePropertyTests + , modifyPropertyTests + , modifyPropertyValueTests + , modifyPropertyStringTests + , modifyPropertyCoordsTests + , modifyGameInfoTests + , modifyVariationModeTests + , getMarkTests + , modifyMarkTests + , addChildTests + , addChildAtTests + , deleteChildAtTests + , gameInfoChangedTests + ] + +monadTests = "monad properties" ~: TestList + [ "returns a value it's given" ~: + let cursor = rootCursor $ node [] + (value, cursor') = runGo (return 3) cursor + in (value, cursorNode cursor') @?= (3, cursorNode cursor) + + , "getCursor works" ~: do + let cursor = rootCursor nodeA + nodeA = node1 [SZ 3 3, B $ Just (0,0)] nodeB + nodeB = node1 [W $ Just (1,1)] nodeC + nodeC = node [B $ Just (2,2)] + nodeA @=? evalGo (liftM cursorNode getCursor) cursor + nodeB @=? evalGo (goDown 0 >> liftM cursorNode getCursor) cursor + nodeC @=? evalGo (goDown 0 >> goDown 0 >> liftM cursorNode getCursor) cursor + + , "getCoordState works" ~: do + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [SZ 2 2, B $ Just (0,0)] $ + node1 [W $ Just (1,0), TR $ coord1 (0,0)] $ + node [B $ Just (0,1), CR $ coord1 (1,0)] + action = mapM getCoordState [(0,0), (1,0), (0,1), (1,1)] + states = evalGo action cursor + map coordStone states @?= [Just Black, Just White, Just Black, Nothing] + map coordMark states @?= [Nothing, Just MarkCircle, Nothing, Nothing] + ] + +navigationTests = "navigation" ~: TestList + [ "navigates down a tree" ~: + let cursor = rootCursor $ + node1 [B $ Just (0,0)] $ + node' [W $ Just (1,1)] [node [B $ Just (2,2)], + node [B Nothing]] + action = goDown 0 >> goDown 1 + (_, cursor') = runGo action cursor + in cursorProperties cursor' @?= [B Nothing] + + , "navigates up a tree" ~: + let cursor = child 1 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node' [W $ Just (1,1)] [node [B $ Just (2,2)], + node [B Nothing]] + action = goUp >> goUp + (_, cursor') = runGo action cursor + in cursorProperties cursor' @?= [B $ Just (0,0)] + + , "invokes handlers when navigating" ~: + let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] + action = do on navigationEvent $ \step -> case step of + GoUp index -> tell ["Up " ++ show index] + _ -> return () + on navigationEvent $ \step -> case step of + GoDown index -> tell ["Down " ++ show index] + _ -> return () + goDown 0 + goUp + (_, _, log) = runLoggedGo action cursor + in log @?= ["Down 0", "Up 0"] + + , "navigates to the root of a tree, invoking handlers" ~: do + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = do on navigationEvent $ \step -> tell [show step] + goToRoot + (_, cursor', log) = runLoggedGo action cursor + cursorProperties cursor' @?= [B $ Just (0,0)] + log @?= ["GoUp 0", "GoUp 0"] + + , "goToGameInfoNode" ~: TestList + [ "can navigate up to find game info" ~: + let props = [PB (toSimpleText ""), B Nothing] + cursor = child 0 $ rootCursor $ node1 props $ node [W Nothing] + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= props + + , "can find game info at the current node" ~: + let props = [PB (toSimpleText ""), W Nothing] + cursor = child 0 $ rootCursor $ node1 [B Nothing] $ node props + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= props + + , "doesn't find game info from a subnode" ~: + let cursor = child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [PB (toSimpleText ""), B Nothing] + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= [W $ Just (1,1)] + + , "can return to the initial node when no game info is found" ~: + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = void $ goToGameInfoNode False + in cursorProperties (execGo action cursor) @?= [B $ Just (2,2)] + + , "can finish at the root node when no game info is found" ~: + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = void $ goToGameInfoNode True + in cursorProperties (execGo action cursor) @?= [B $ Just (0,0)] + ] + ] + +positionStackTests = "position stack" ~: TestList + [ "should push, pop, and drop with no navigation" ~: do + let cursor = rootCursor $ node [] + actions = [pushPosition >> popPosition, + pushPosition >> pushPosition >> popPosition >> popPosition, + pushPosition >> dropPosition, + pushPosition >> pushPosition >> dropPosition >> popPosition, + pushPosition >> pushPosition >> popPosition >> dropPosition] + forM_ actions $ \action -> cursorProperties (execGo action cursor) @?= [] + + , "should backtrack up and down the tree" ~: do + let cursor = child 0 $ child 1 $ rootCursor $ + node' [B $ Just (0,0)] + [node1 [W $ Just (1,1)] $ node [B $ Just (2,2)], + node1 [W Nothing] $ node [B Nothing]] + action = pushPosition >> goUp >> goUp >> goDown 0 >> goDown 0 + cursorProperties (execGo (action >> popPosition) cursor) @?= [B Nothing] + cursorProperties (execGo (action >> dropPosition) cursor) @?= [B $ Just (2,2)] + + , "should pop multiple stacks" ~: do + let cursor = child 0 $ child 0 commonCursor + action = do navigate + log >> popPosition + log >> popPosition + log + execWriter (runGoT action cursor) @?= + ["B (2,2)", "B (3,3)", "B (5,5)", "B (3,3)", "B (2,2)"] + + , "should drop then pop" ~: do + let cursor = child 0 $ child 0 commonCursor + action = do navigate + log >> dropPosition + log >> popPosition + log + execWriter (runGoT action cursor) @?= + ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (2,2)"] + + , "should drop twice" ~: do + let cursor = child 0 $ child 0 commonCursor + action = do navigate + log >> dropPosition + log >> dropPosition + log + execWriter (runGoT action cursor) @?= + ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (5,5)"] + + , "should fire navigation handlers while popping" ~: do + let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] + action = do pushPosition + goDown 0 + goUp + on navigationEvent $ \step -> tell [step] + popPosition + execWriter (runGoT action cursor) @?= [GoDown 0, GoUp 0] + ] + where commonCursor = rootCursor $ + node' [B $ Just (0,0)] + [node' [W $ Just (1,1)] + [node [B $ Just (2,2)], + node [B $ Just (3,3)]], + node1 [W $ Just (4,4)] $ node [B $ Just (5,5)]] + log = getCursor >>= \cursor -> case cursorProperties cursor of + [B (Just x)] -> tell ["B " ++ show x] + [W (Just x)] -> tell ["W " ++ show x] + xs -> error $ "Unexpected properties: " ++ show xs + navigate = do log >> pushPosition + goUp >> goDown 1 + log >> pushPosition + goUp >> goUp >> goDown 1 >> goDown 0 + +propertiesTests = "properties" ~: TestList + [ "getProperties" ~: TestList + [ "returns an empty list" ~: + let cursor = rootCursor $ node [] + in evalGo getProperties cursor @?= [] + + , "returns a non-empty list" ~: + let properties = [PB $ toSimpleText "Foo", B Nothing] + cursor = rootCursor $ node properties + in evalGo getProperties cursor @?= properties + ] + + , "modifyProperties" ~: TestList + [ "adds properties" ~: + let cursor = rootCursor $ node [FF 1] + action = do modifyProperties $ \props -> return $ props ++ [B Nothing, W Nothing] + getProperties + in evalGo action cursor @?= [FF 1, B Nothing, W Nothing] + + , "removes properties" ~: + let cursor = rootCursor $ node [W Nothing, FF 1, B Nothing] + action = do modifyProperties $ \props -> return $ filter (not . isMoveProperty) props + getProperties + in evalGo action cursor @?= [FF 1] + + , "fires a properties modified event" ~: + let cursor = rootCursor $ node [FF 1] + action = do on propertiesModifiedEvent $ \old new -> tell [(old, new)] + modifyProperties $ const $ return [FF 2] + log = execWriter (runGoT action cursor) + in log @?= [([FF 1], [FF 2])] + ] + ] + where isMoveProperty prop = case prop of + B _ -> True + W _ -> True + _ -> False + +getPropertyTests = "getProperty" ~: TestList + [ "doesn't find an unset property" ~: do + Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node []) + Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node [B Nothing]) + + , "finds a set property" ~: do + Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing]) + Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing, DO]) + Just DO @=? evalGo (getProperty propertyDO) (rootCursor $ node [B Nothing, DO]) + ] + +getPropertyValueTests = "getPropertyValue" ~: TestList + [ "doesn't find an unset property" ~: do + Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node []) + Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node [B Nothing]) + + , "finds a set property" ~: do + Just Nothing @=? evalGo (getPropertyValue propertyB) (rootCursor $ node [B Nothing]) + Just (Just (0,0)) @=? + evalGo (getPropertyValue propertyB) (rootCursor $ node [B $ Just (0,0), TE Double1]) + Just Double1 @=? + evalGo (getPropertyValue propertyTE) (rootCursor $ node [B $ Just (0,0), TE Double1]) + ] + +putPropertyTests = "putProperty" ~: TestList + [ "adds an unset property" ~: do + [IT] @=? cursorProperties (execGo (putProperty IT) $ rootCursor $ node []) + [DO, IT] @=? + sortProperties (cursorProperties (execGo (putProperty IT) $ rootCursor $ node [DO])) + + , "replaces an existing property" ~: + [TE Double2] @=? + cursorProperties (execGo (putProperty $ TE Double2) (rootCursor $ node [TE Double1])) + ] + +deletePropertyTests = "deleteProperty" ~: TestList + [ "does nothing when the property isn't set" ~: do + [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node []) + [B Nothing] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [B Nothing]) + + , "removes a property" ~: do + [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [DO]) + -- This is documented behaviour for deleteProperty, the fact that it doesn't + -- matter what the property value is: + [DO] @=? cursorProperties + (execGo (deleteProperty $ B $ Just (0,0)) $ rootCursor $ node [DO, B Nothing]) + ] + +modifyPropertyTests = "modifyProperty" ~: TestList + [ "adds a property to an empty node" ~: + let cursor = rootCursor $ node [] + action = modifyProperty propertyIT (\Nothing -> Just IT) + in cursorProperties (execGo action cursor) @?= [IT] + + , "adds a property to a non-empty node" ~: + let cursor = rootCursor $ node [KO] + action = modifyProperty propertyIT (\Nothing -> Just IT) + in sortProperties (cursorProperties $ execGo action cursor) @?= [IT, KO] + + , "removes a property" ~: do + let cursor = rootCursor $ node [IT, KO] + cursor' = execGo (modifyProperty propertyKO $ \(Just KO) -> Nothing) cursor + cursor'' = execGo (modifyProperty propertyIT $ \(Just IT) -> Nothing) cursor' + cursorProperties cursor' @?= [IT] + cursorProperties cursor'' @?= [] + + , "updates a property" ~: do + let cursor = rootCursor $ node [B $ Just (0,0), BM Double2] + action = modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Just $ B $ Just (1,1) + cursor' = execGo action cursor + action' = modifyProperty propertyBM $ \(Just (BM Double2)) -> Just $ BM Double1 + cursor'' = execGo action' cursor' + sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2] + sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1] + + , "fires an event when modifying a property" ~: do + let cursor = rootCursor $ node [B $ Just (0,0)] + action = do on propertiesModifiedEvent $ \[B (Just (0,0))] [] -> tell [0] + modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Nothing + (cursor', log) = runWriter (execGoT action cursor) + [0] @=? log + [] @=? cursorProperties cursor' + + , "modifying but not actually changing a property doesn't fire an event" ~: do + let cursor = rootCursor $ node [B $ Just (0,0)] + action = do on propertiesModifiedEvent $ \_ _ -> tell ["Event fired."] + modifyProperty propertyB $ \p@(Just (B {})) -> p + (cursor', log) = runWriter (execGoT action cursor) + [B $ Just (0,0)] @=? cursorProperties cursor' + [] @=? log + ] + +modifyPropertyValueTests = "modifyPropertyValue" ~: TestList + [ "adds a property to an empty node" ~: + let cursor = rootCursor $ node [] + action = modifyPropertyValue propertyPL (\Nothing -> Just Black) + in cursorProperties (execGo action cursor) @?= [PL Black] + + , "adds a property to a non-empty node" ~: + let cursor = rootCursor $ node [KO] + action = modifyPropertyValue propertyPL (\Nothing -> Just White) + in sortProperties (cursorProperties $ execGo action cursor) @?= [KO, PL White] + + , "removes a property" ~: do + let cursor = rootCursor $ node [B Nothing, TE Double2] + cursor' = execGo (modifyPropertyValue propertyTE $ \(Just Double2) -> Nothing) cursor + cursor'' = execGo (modifyPropertyValue propertyB $ \(Just Nothing) -> Nothing) cursor' + cursorProperties cursor' @?= [B Nothing] + cursorProperties cursor'' @?= [] + + , "updates a property" ~: do + let cursor = rootCursor $ node [B $ Just (0,0), BM Double2] + action = modifyPropertyValue propertyB $ \(Just (Just (0,0))) -> Just $ Just (1,1) + cursor' = execGo action cursor + action' = modifyPropertyValue propertyBM $ \(Just Double2) -> Just Double1 + cursor'' = execGo action' cursor' + sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2] + sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1] + ] + +modifyPropertyStringTests = + "modifyPropertyString" ~: TestList $ + -- Test a Text property and a SimpleText property. + assumptions ++ genTests "comment" propertyC ++ genTests "game name" propertyGN + where assumptions = let _ = C $ toText "" + _ = GN $ toSimpleText "" + in [] + genTests name property = + [ "adds a " ++ name ~: + let cursor = rootCursor $ node [] + action = modifyPropertyString property (++ "Hello.") + in cursorProperties (execGo action cursor) @?= + [propertyBuilder property $ stringToSgf "Hello."] + + , "removes a " ++ name ~: + let cursor = rootCursor $ node [propertyBuilder property $ stringToSgf "Hello."] + action = modifyPropertyString property $ \value -> case value of + "Hello." -> "" + other -> error $ "Got: " ++ other + in cursorProperties (execGo action cursor) @?= [] + + , "updates a " ++ name ~: + let cursor = child 0 $ rootCursor $ + node1 [propertyBuilder property $ stringToSgf "one"] $ + node [propertyBuilder property $ stringToSgf "two"] + action = modifyPropertyString property $ \value -> case value of + "two" -> "three" + other -> error $ "Got: " ++ other + cursor' = execGo action cursor + in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= + ([propertyBuilder property $ stringToSgf "three"], + [propertyBuilder property $ stringToSgf "one"]) + + , "leaves a non-existant comment" ~: + let result = execGo (modifyPropertyString property id) $ rootCursor $ node [] + in cursorProperties result @?= [] + ] + +modifyPropertyCoordsTests = "modifyPropertyCoords" ~: TestList + [ "adds a property where there was none" ~: + let cursor = rootCursor $ node [] + action = modifyPropertyCoords propertySL $ \[] -> [(0,0), (1,1)] + in [SL $ coords [(0,0), (1,1)]] @=? cursorProperties (execGo action cursor) + + , "removes a property where there was one" ~: + let cursor = rootCursor $ node [TR $ coord1 (5,5)] + action = modifyPropertyCoords propertyTR $ \[(5,5)] -> [] + in [] @=? cursorProperties (execGo action cursor) + + , "modifies an existing property" ~: + let cursor = rootCursor $ node [CR $ coord1 (3,4)] + action = modifyPropertyCoords propertyCR $ \[(3,4)] -> [(2,2)] + in [CR $ coord1 (2,2)] @=? cursorProperties (execGo action cursor) + + , "doesn't affect other properties" ~: + let cursor = rootCursor $ node [SQ $ coord1 (0,0), MA $ coord1 (1,1)] + action = modifyPropertyCoords propertyMA $ \[(1,1)] -> [(2,2)] + in [MA $ coord1 (2,2), SQ $ coord1 (0,0)] @=? + sortProperties (cursorProperties $ execGo action cursor) + ] + +modifyGameInfoTests = "modifyGameInfo" ~: TestList + [ "creates info on the root node, starting with none" ~: TestList + [ "starting from the root node" ~: + let cursor = rootCursor $ node [] + action = modifyGameInfo $ \info -> + info { gameInfoGameName = Just $ toSimpleText "Orange" } + in cursorProperties (execGo action cursor) @?= [GN $ toSimpleText "Orange"] + + , "starting from a non-root node" ~: + let cursor = child 0 $ rootCursor $ node1 [] $ node [B Nothing] + action = modifyGameInfo $ \info -> + info { gameInfoGameName = Just $ toSimpleText "Orange" } + cursor' = execGo action cursor + in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= + ([B Nothing], [GN $ toSimpleText "Orange"]) + ] + + , "modifies existing info on the root" ~: TestList + [ "starting from the root node" ~: + let cursor = rootCursor $ node [GN $ toSimpleText "Orange"] + action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing + , gameInfoBlackName = + Just $ toSimpleText "Peanut butter" + }) + in cursorProperties (execGo action cursor) @?= [PB $ toSimpleText "Peanut butter"] + + , "starting from a non-root node" ~: + let cursor = child 0 $ rootCursor $ node1 [GN $ toSimpleText "Orange"] $ node [B Nothing] + action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing + , gameInfoBlackName = + Just $ toSimpleText "Peanut butter" + }) + cursor' = execGo action cursor + in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= + ([B Nothing], [PB $ toSimpleText "Peanut butter"]) + ] + + , "moves game info from a non-root node to the root" ~: + let cursor = child 0 $ child 0 $ child 0 $ rootCursor $ + node1 [SZ 19 19] $ + node1 [B $ Just (0,0), GN $ toSimpleText "Orange"] $ + node1 [W $ Just (1,1)] $ + node [B $ Just (2,2)] + action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing }) + cursor' = execGo action cursor + action' = modifyGameInfo (\info -> info { gameInfoBlackName = + Just $ toSimpleText "Peanut butter" }) + cursor'' = execGo action' cursor' + -- unfoldr :: (Maybe Cursor -> Maybe ([Property], Maybe Cursor)) + -- -> Maybe Cursor + -- -> [[Property]] + properties = unfoldr (fmap $ cursorProperties &&& cursorParent) + (Just cursor'') + in map sortProperties properties @?= + [[B $ Just (2,2)], + [W $ Just (1,1)], + [B $ Just (0,0)], + [PB $ toSimpleText "Peanut butter", SZ 19 19]] + ] + +modifyVariationModeTests = "modifyVariationMode" ~: TestList + [ "testing modes are not default" ~: do + defaultVariationMode @/=? mode + defaultVariationMode @/=? mode2 + + , "modifies when at a root node" ~: + node1 [ST mode] (node []) @=? + cursorNode (execGo setMode $ rootCursor $ node1 [] $ node []) + + , "modifies when at a non-root node" ~: + node1 [ST mode] (node []) @=? + cursorNode (cursorRoot $ execGo setMode $ child 0 $ rootCursor $ node1 [] $ node []) + + , "leaves an unset ST unset" ~: + assertST Nothing Nothing $ const defaultVariationMode + + , "leaves a default ST alone" ~: + assertST (Just defaultVariationMode) (Just defaultVariationMode) $ const defaultVariationMode + + , "leaves an existing ST alone" ~: + assertST (Just mode) (Just mode) $ const mode + + , "adds an ST property" ~: + assertST (Just mode) Nothing $ const mode + + , "removes an ST property when setting to default" ~: + assertST Nothing (Just mode) $ const defaultVariationMode + + , "modifies an existing ST property" ~: + assertST (Just mode2) (Just mode) $ const mode2 + ] + where mode = VariationMode ShowCurrentVariations True + mode2 = VariationMode ShowChildVariations False + setMode = modifyVariationMode $ const mode + assertST maybeExpectedST maybeInitialST fn = + node (ST <$> maybeToList maybeExpectedST) @=? + cursorNode (execGo (modifyVariationMode fn) $ + rootCursor $ node $ ST <$> maybeToList maybeInitialST) + +getMarkTests = "getMark" ~: TestList + [ "returns Nothing for no mark" ~: do + Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node []) + Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node [W $ Just (0,0)]) + + , "returns Just when a mark is present" ~: do + Just MarkSquare @=? evalGo (getMark (1,2)) (rootCursor $ node [SQ $ coord1 (1,2)]) + Just MarkTriangle @=? evalGo (getMark (1,1)) (rootCursor $ node [B $ Just (1,1), + TR $ coord1 (1,1), + SQ $ coord1 (1,2)]) + + , "matches all marks" ~: forM_ [minBound..maxBound] $ \mark -> + Just mark @=? + evalGo (getMark (0,0)) + (rootCursor $ node [propertyBuilder (markProperty mark) $ coord1 (0,0)]) + ] + +modifyMarkTests = "modifyMark" ~: TestList + [ "creates a mark where there was none" ~: + let cursor = rootCursor $ node [] + action = do modifyMark (\Nothing -> Just MarkX) (0,0) + getMark (0,0) + in Just MarkX @=? evalGo action cursor + + , "removes an existing mark" ~: + let cursor = rootCursor $ node [CR $ coord1 (0,0)] + action = do modifyMark (\(Just MarkCircle) -> Nothing) (0,0) + getMark (0,0) + in Nothing @=? evalGo action cursor + + , "replaces an existing mark" ~: + let cursor = rootCursor $ node [CR $ coord1 (0,0)] + action = do modifyMark (\(Just MarkCircle) -> Just MarkX) (0,0) + getMark (0,0) + in Just MarkX @=? evalGo action cursor + + , "adds on to an existing mark property" ~: + let cursor = rootCursor $ node [MA $ coord1 (0,0)] + action = do modifyMark (\Nothing -> Just MarkX) (1,0) + mapM getMark [(0,0), (1,0)] + in [Just MarkX, Just MarkX] @=? evalGo action cursor + + , "removes from an existing mark property" ~: + let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]] + action = do modifyMark (\(Just MarkX) -> Nothing) (1,0) + modifyMark (\(Just MarkX) -> Nothing) (0,1) + mapM getMark [(0,0), (1,0), (0,1)] + in [Just MarkX, Nothing, Nothing] @=? evalGo action cursor + + , "removes and adds at the same time" ~: + let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]] + action = do modifyMark (\(Just MarkX) -> Just MarkSquare) (0,0) + modifyMark (\(Just MarkX) -> Nothing) (0,1) + mapM getMark [(0,0), (1,0), (0,1)] + in [Just MarkSquare, Just MarkX, Nothing] @=? evalGo action cursor + ] + +addChildTests = "addChild" ~: TestList + [ "adds a first child" ~: do + cursorNode (execGo (addChild emptyNode) $ rootCursor emptyNode) @?= node1 [] emptyNode + cursorNode (execGo (addChild $ node1 [W $ Just (1,1)] $ node [B $ Just (2,2)]) $ rootCursor $ + node [B $ Just (0,0)]) @?= + node1 [B $ Just (0,0)] (node1 [W $ Just (1,1)] $ node [B $ Just (2,2)]) + + , "adds a child to the end of the parent's child list" ~: + cursorNode (execGo (addChild $ node [MN 4]) $ rootCursor $ + node' [B Nothing] [node [MN 2], node [MN 3]]) @?= + node' [B Nothing] [node [MN 2], node [MN 3], node [MN 4]] + + , "fires childAddedEvent after adding a child" ~: + let cursor = rootCursor $ node' [B Nothing] [node [MN 2], node [MN 3]] + action = do on childAddedEvent $ \index -> do + cursor <- getCursor + tell [(index, cursorNode cursor)] + addChild $ node [MN 4] + in execWriter (runGoT action cursor) @?= + [(2, node' [B Nothing] [node [MN 2], node [MN 3], node [MN 4]])] + ] + +addChildAtTests = "addChildAt" ~: TestList + [ "adds an only child" ~: + cursorNode (execGo (addChildAt 0 $ node [B Nothing]) (rootCursor $ node [])) @?= + node' [] [node [B Nothing]] + + , "adds a first child" ~: + cursorNode (execGo (addChildAt 0 $ node [B $ Just (0,0)]) + (rootCursor $ node' [] [node [B $ Just (1,1)]])) @?= + node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)]] + + , "adds a middle child" ~: + cursorNode (execGo (addChildAt 1 $ node [B $ Just (1,1)]) + (rootCursor $ node' [] [node [B $ Just (0,0)], + node [B $ Just (2,2)]])) @?= + node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)], + node [B $ Just (2,2)]] + + , "adds a last child" ~: + cursorNode (execGo (addChildAt 2 $ node [B $ Just (2,2)]) + (rootCursor $ node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)]])) @?= + node' [] [node [B $ Just (0,0)], + node [B $ Just (1,1)], + node [B $ Just (2,2)]] + + , "fires childAddedEvent after adding a child" ~: + let cursor = rootCursor $ node' [B Nothing] [node [MN 2], node [MN 4]] + action = do on childAddedEvent $ \index -> do + cursor <- getCursor + tell [(index, cursorNode cursor)] + addChildAt 1 $ node [MN 3] + in execWriter (runGoT action cursor) @?= + [(1, node' [B Nothing] [node [MN 2], node [MN 3], node [MN 4]])] + + , "path stack correctness" ~: TestList + [ "basic case just not needing updating" ~: + let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] + action = do pushPosition + goUp + addChildAt 1 $ node [W $ Just (0,0)] + popPosition + in cursorNode (execGo action cursor) @?= node [W Nothing] + + , "basic case just needing updating" ~: + let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] + action = do pushPosition + goUp + addChildAt 0 $ node [W $ Just (0,0)] + popPosition + in cursorNode (execGo action cursor) @?= node [W Nothing] + + , "basic case definitely needing updating" ~: + let cursor = rootCursor $ node' [B Nothing] [node [W $ Just (0,0)], + node [W $ Just (1,1)]] + action = do goDown 1 + pushPosition + goUp + addChildAt 0 $ node [W Nothing] + popPosition + in cursorNode (execGo action cursor) @?= node [W $ Just (1,1)] + + , "multiple paths to update" ~: + let at y x = B $ Just (y,x) + level0Node = node' [at 0 0] $ map level1Node [0..1] + level1Node i = node' [at 1 i] $ map level2Node [0..2] + level2Node i = node' [at 2 i] $ map level3Node [0..3] + level3Node i = node [at 3 i] + action = do goDown 1 >> goDown 2 >> goDown 3 + pushPosition + replicateM_ 3 goUp + pushPosition + goDown 1 >> goDown 2 >> goDown 2 >> goUp >> goDown 1 + addChildAt 0 $ node1 [] $ node [] + goDown 0 >> goDown 0 + goToRoot + popPosition + popPosition + in cursorNode (execGo action $ rootCursor level0Node) @?= node [B $ Just (3,3)] + + , "updates paths with GoUp correctly" ~: + let cursor = rootCursor $ node1 [B $ Just (0,0)] $ node [W $ Just (1,1)] + action = do pushPosition + goDown 0 + goUp + addChildAt 0 $ node [B $ Just (2,2)] + on navigationEvent $ \step -> tell [step] + popPosition + log = execWriter (runGoT action cursor) + in log @?= [GoDown 1, GoUp 1] + ] + ] + +deleteChildAtTests = "deleteChildAt" ~: TestList + [ "ignores invalid indices" ~: do + second cursorNode (runGo (deleteChildAt 0) $ rootCursor $ node []) @?= + (NodeDeleteBadIndex, node []) + let base = node' [] [node [MN 0]] + second cursorNode (runGo (deleteChildAt (-2)) $ rootCursor base) @?= (NodeDeleteBadIndex, base) + second cursorNode (runGo (deleteChildAt (-1)) $ rootCursor base) @?= (NodeDeleteBadIndex, base) + second cursorNode (runGo (deleteChildAt 1) $ rootCursor base) @?= (NodeDeleteBadIndex, base) + second cursorNode (runGo (deleteChildAt 2) $ rootCursor base) @?= (NodeDeleteBadIndex, base) + + , "deletes an only child" ~: + let cursor = rootCursor $ node1 [MN 0] $ node [MN 1] + action = deleteChildAt 0 + in second cursorNode (runGo action cursor) @?= (NodeDeleteOk, node [MN 0]) + + , "deletes a first child" ~: + let cursor = rootCursor $ node' [MN 0] [node [MN 1], node [MN 2]] + action = deleteChildAt 0 + in second cursorNode (runGo action cursor) @?= (NodeDeleteOk, node1 [MN 0] $ node [MN 2]) + + , "deletes middle children" ~: do + let base = node' [MN 0] [node [MN 1], node [MN 2], node [MN 3], node [MN 4]] + cursor = rootCursor base + second cursorNode (runGo (deleteChildAt 1) cursor) @?= + (NodeDeleteOk, base { nodeChildren = listDeleteAt 1 $ nodeChildren base }) + second cursorNode (runGo (deleteChildAt 2) cursor) @?= + (NodeDeleteOk, base { nodeChildren = listDeleteAt 2 $ nodeChildren base }) + + , "deletes a final child" ~: do + let base = node' [MN 0] [node [MN 1], node [MN 2], node [MN 3], node [MN 4]] + cursor = rootCursor base + second cursorNode (runGo (deleteChildAt 1) cursor) @?= + (NodeDeleteOk, base { nodeChildren = listDeleteAt 1 $ nodeChildren base }) + second cursorNode (runGo (deleteChildAt 2) cursor) @?= + (NodeDeleteOk, base { nodeChildren = listDeleteAt 2 $ nodeChildren base }) + + , "fires childDeletedEvent after deleting a child" ~: + let cursor = rootCursor $ node' [MN 0] [node [MN 1], node [MN 2]] + action = do on childDeletedEvent $ tell . (:[]) . (cursorChildIndex &&& cursorNode) + deleteChildAt 1 + in execWriter (runGoT action cursor) @?= [(1, cursorNode $ child 1 cursor)] + + , "path stack correctness" ~: TestList + [ "basic case just not needing updating" ~: + let cursor = rootCursor $ node' [B Nothing] [node [W Nothing], node [W $ Just (0,0)]] + action = do goDown 0 + pushPosition + goUp + deleteChildAt 1 + popPosition + in cursorNode (execGo action cursor) @?= node [W Nothing] + + , "basic case just needing updating" ~: + let cursor = rootCursor $ node' [B Nothing] [node [W Nothing], node [W $ Just (0,0)]] + action = do goDown 1 + pushPosition + goUp + deleteChildAt 0 + popPosition + in cursorNode (execGo action cursor) @?= node [W $ Just (0,0)] + + , "basic case definitely needing updating" ~: + let cursor = rootCursor $ node' [B Nothing] [node [W $ Just (0,0)], + node [W $ Just (1,1)], + node [W $ Just (2,2)]] + action = do goDown 2 + pushPosition + goUp + deleteChildAt 0 + popPosition + in cursorNode (execGo action cursor) @?= node [W $ Just (2,2)] + + , "multiple paths to update" ~: + let at y x = B $ Just (y,x) + level0Node = node' [at 0 0] $ map level1Node [0..1] + level1Node i = node' [at 1 i] $ map level2Node [0..2] + level2Node i = node' [at 2 i] $ map level3Node [0..3] + level3Node i = node [at 3 i] + action = do goDown 1 >> goDown 2 >> goDown 3 + pushPosition + goUp + deleteChildAt 1 + pushPosition + goToRoot >> goDown 0 >> goDown 2 + pushPosition + goUp + deleteChildAt 0 + goToRoot >> goDown 1 >> goDown 2 + deleteChildAt 1 + replicateM_ 3 popPosition + in cursorNode (execGo action $ rootCursor level0Node) @?= node [B $ Just (3,3)] + + , "returns an error if a node to delete is on the path stack" ~: + let base = node' [B $ Just (0,0)] [node [W $ Just (1,1)], + node [W $ Just (2,2)]] + action = do goDown 1 + pushPosition + goUp + pushPosition + goDown 0 + pushPosition + goUp + deleteChildAt 1 + in second cursorNode (runGo action $ rootCursor base) @?= + (NodeDeleteOnPathStack, base) + ] + ] + +gameInfoChangedTests = "gameInfoChangedEvent" ~: TestList + [ "fires when navigating down" ~: + let cursor = rootCursor $ + node1 [B $ Just (0,0)] $ + node [W $ Just (0,0), GN $ toSimpleText "Foo"] + action = do on gameInfoChangedEvent onInfo + goDown 0 + in execWriter (runGoT action cursor) @?= [(Nothing, Just $ toSimpleText "Foo")] + + , "fires when navigating up" ~: + let cursor = child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node [W $ Just (0,0), GN $ toSimpleText "Foo"] + action = do on gameInfoChangedEvent onInfo + goUp + in execWriter (runGoT action cursor) @?= [(Just $ toSimpleText "Foo", Nothing)] + + , "fires from within popPosition" ~: + let cursor = rootCursor $ + node1 [B $ Just (0,0)] $ + node [W $ Just (0,0), GN $ toSimpleText "Foo"] + action = do pushPosition + goDown 0 + goUp + on gameInfoChangedEvent onInfo + popPosition + in execWriter (runGoT action cursor) @?= + [(Nothing, Just $ toSimpleText "Foo"), (Just $ toSimpleText "Foo", Nothing)] + + , "fires when modifying properties" ~: + let cursor = rootCursor $ node [] + action = do on gameInfoChangedEvent onInfo + modifyProperties $ const $ return [GN $ toSimpleText "Foo"] + modifyProperties $ const $ return [GN $ toSimpleText "Bar"] + modifyProperties $ const $ return [] + in execWriter (runGoT action cursor) @?= + [(Nothing, Just $ toSimpleText "Foo"), + (Just $ toSimpleText "Foo", Just $ toSimpleText "Bar"), + (Just $ toSimpleText "Bar", Nothing)] + ] + where onInfo old new = tell [(gameInfoGameName old, gameInfoGameName new)] diff --git a/tests/Game/Goatee/Lib/ParserTest.hs b/tests/Game/Goatee/Lib/ParserTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/ParserTest.hs @@ -0,0 +1,240 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.ParserTest (tests) where + +import Control.Monad (forM_) +import Game.Goatee.Lib.ParserTestUtils +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.TestInstances () +import Game.Goatee.Lib.TestUtils +import Game.Goatee.Lib.Tree +import Game.Goatee.Lib.Types +import Test.HUnit ((~:), (@?=), Test (TestList)) + +tests = "Game.Goatee.Lib.Parser" ~: TestList + [ baseCaseTests + , whitespaceTests + , passConversionTests + , movePropertyTests + , setupPropertyTests + , nodeAnnotationPropertyTests + , moveAnnotationPropertyTests + , rootPropertyTests + ] + +baseCaseTests = "base cases" ~: TestList + [ "works with the trivial collection" ~: + parseOrFail "(;)" (@?= emptyNode) + + , "works with only a size property" ~: do + parseOrFail "(;SZ[1])" (@?= root 1 1 [] []) + parseOrFail "(;SZ[9])" (@?= root 9 9 [] []) + ] + +whitespaceTests = "whitespace handling" ~: TestList + [ "parses with no extra whitespace" ~: + parseOrFail "(;SZ[4];AB[aa][bb]AW[cc];W[dd])" + (@?= root 4 4 [] [node1 [AB $ coords [(0,0), (1,1)], AW $ coords [(2,2)]] $ + node [W $ Just (3,3)]]) + + , "parses with spaces between nodes" ~: + parseOrFail "(;SZ[1] ;B[])" (@?= root 1 1 [] [node [B Nothing]]) + + , "parses with spaces between properties" ~: + parseOrFail "(;SZ[1] AB[aa])" (@?= root 1 1 [AB $ coords [(0,0)]] []) + + , "parses with spaces between a property's name and value" ~: + parseOrFail "(;SZ [1])" (@?= root 1 1 [] []) + + , "parses with spaces between property values" ~: + parseOrFail "(;SZ[2]AB[aa] [bb])" (@?= root 2 2 [AB $ coords [(0,0), (1,1)]] []) + + , "parses with spaces between many elements" ~: + parseOrFail " ( ; SZ [4] ; AB [aa:ad] [bb] AW [cc] ; W [dd] ; B [] ) " + (@?= root 4 4 [] [node1 [AB $ coords' [(1,1)] [((0,0), (0,3))], + AW $ coords [(2,2)]] $ + node1 [W $ Just (3,3)] $ + node [B Nothing]]) + + -- TODO Test handling of whitespace between an unknown property name and + -- [value]. + ] + +passConversionTests = "B[tt]/W[tt] pass conversion" ~: TestList + [ "converts B[tt] for a board sizes <=19x19" ~: do + parseOrFail "(;SZ[1];B[tt])" (@?= root 1 1 [] [node [B Nothing]]) + parseOrFail "(;SZ[9];B[tt])" (@?= root 9 9 [] [node [B Nothing]]) + parseOrFail "(;SZ[19];B[tt])" (@?= root 19 19 [] [node [B Nothing]]) + + , "converts W[tt] for a board sizes <=19x19" ~: do + parseOrFail "(;SZ[1];W[tt])" (@?= root 1 1 [] [node [W Nothing]]) + parseOrFail "(;SZ[9];W[tt])" (@?= root 9 9 [] [node [W Nothing]]) + parseOrFail "(;SZ[19];W[tt])" (@?= root 19 19 [] [node [W Nothing]]) + + , "doesn't convert B[tt] for a board sizes >19x19" ~: do + parseOrFail "(;SZ[20];B[tt])" (@?= root 20 20 [] [node [B $ Just (19, 19)]]) + parseOrFail "(;SZ[21];B[tt])" (@?= root 21 21 [] [node [B $ Just (19, 19)]]) + + , "doesn't convert W[tt] for a board sizes >19x19" ~: do + parseOrFail "(;SZ[20];W[tt])" (@?= root 20 20 [] [node [W $ Just (19, 19)]]) + parseOrFail "(;SZ[21];W[tt])" (@?= root 21 21 [] [node [W $ Just (19, 19)]]) + + , "doesn't convert non-move properties" ~: do + -- TODO These should error, rather than parsing fine. + parseOrFail "(;SZ[9];AB[tt])" (@?= root 9 9 [] [node [AB $ coords [(19, 19)]]]) + parseOrFail "(;SZ[9];TR[tt])" (@?= root 9 9 [] [node [TR $ coords [(19, 19)]]]) + ] + +movePropertyTests = "move properties" ~: TestList + [ "B" ~: TestList + [ "parses moves" ~: do + parseOrFail "(;B[aa])" (@?= node [B $ Just (0, 0)]) + parseOrFail "(;B[cp])" (@?= node [B $ Just (2, 15)]) + , "parses passes" ~: + parseOrFail "(;B[])" (@?= node [B Nothing]) + ] + , "KO parses" ~: + parseOrFail "(;KO[])" (@?= node [KO]) + -- TODO Test MN (assert positive). + , "W" ~: TestList + [ "parses moves" ~: do + parseOrFail "(;W[aa])" (@?= node [W $ Just (0, 0)]) + parseOrFail "(;W[cp])" (@?= node [W $ Just (2, 15)]) + , "parses passes" ~: + parseOrFail "(;W[])" (@?= node [W Nothing]) + ] + ] + +setupPropertyTests = "setup properties" ~: TestList + [ "AB parses" ~: do + parseOrFail "(;AB[ab])" (@?= node [AB $ coords [(0, 1)]]) + parseOrFail "(;AB[ab][cd:ef])" (@?= node [AB $ coords' [(0, 1)] [((2, 3), (4, 5))]]) + , "AE parses" ~: do + parseOrFail "(;AE[ae])" (@?= node [AE $ coords [(0, 4)]]) + parseOrFail "(;AE[ae][ff:gg])" (@?= node [AE $ coords' [(0, 4)] [((5, 5), (6, 6))]]) + , "AW parses" ~: do + parseOrFail "(;AW[aw])" (@?= node [AW $ coords [(0, 22)]]) + parseOrFail "(;AW[aw][xy:yz])" (@?= node [AW $ coords' [(0, 22)] [((23, 24), (24, 25))]]) + , "PL parses" ~: do + parseOrFail "(;PL[B])" (@?= node [PL Black]) + parseOrFail "(;PL[W])" (@?= node [PL White]) + ] + +nodeAnnotationPropertyTests = "node annotation properties" ~: TestList + [ "C parses" ~: + parseOrFail "(;C[Me [30k\\]: What is White doing??\\\n\n:(])" + (@?= node [C $ toText "Me [30k]: What is White doing??\n:("]) + , "DM parses" ~: do + parseOrFail "(;DM[1])" (@?= node [DM Double1]) + parseOrFail "(;DM[2])" (@?= node [DM Double2]) + , "GB parses" ~: do + parseOrFail "(;GB[1])" (@?= node [GB Double1]) + parseOrFail "(;GB[2])" (@?= node [GB Double2]) + , "GW parses" ~: do + parseOrFail "(;GW[1])" (@?= node [GW Double1]) + parseOrFail "(;GW[2])" (@?= node [GW Double2]) + , "HO parses" ~: do + parseOrFail "(;HO[1])" (@?= node [HO Double1]) + parseOrFail "(;HO[2])" (@?= node [HO Double2]) + , "N parses" ~: + parseOrFail "(;N[The best\\\n\nmove])" (@?= node [N $ toSimpleText "The best move"]) + , "UC parses" ~: do + parseOrFail "(;UC[1])" (@?= node [UC Double1]) + parseOrFail "(;UC[2])" (@?= node [UC Double2]) + , "V parses" ~: do + parseOrFail "(;V[-34.5])" (@?= node [V $ read "-34.5"]) + parseOrFail "(;V[50])" (@?= node [V $ read "50"]) + ] + +moveAnnotationPropertyTests = "move annotation properties" ~: TestList + [ "BM parses" ~: do + parseOrFail "(;BM[1])" (@?= node [BM Double1]) + parseOrFail "(;BM[2])" (@?= node [BM Double2]) + , "DO parses" ~: + parseOrFail "(;DO[])" (@?= node [DO]) + , "IT parses" ~: + parseOrFail "(;IT[])" (@?= node [IT]) + , "TE parses" ~: do + parseOrFail "(;TE[1])" (@?= node [TE Double1]) + parseOrFail "(;TE[2])" (@?= node [TE Double2]) + ] + +-- TODO Test markup properties. + +rootPropertyTests = "root properties" ~: TestList + [ "AP parses" ~: + parseOrFail "(;AP[GoGoGo:1.2.3])" + (@?= node [AP (toSimpleText "GoGoGo") (toSimpleText "1.2.3")]) + , "CA parses" ~: do + parseOrFail "(;CA[UTF-8])" (@?= node [CA $ toSimpleText "UTF-8"]) + parseOrFail "(;CA[ISO-8859-1])" (@?= node [CA $ toSimpleText "ISO-8859-1"]) + , "FF" ~: TestList + [ "accepts version 4" ~: + parseOrFail "(;FF[4])" (@?= node [FF 4]) + , "rejects versions 1-3" ~: do + parseAndFail "(;FF[1])" + parseAndFail "(;FF[2])" + parseAndFail "(;FF[3])" + ] + , "GM" ~: TestList + [ "parses 1 (Go)" ~: + parseOrFail "(;GM[1])" (@?= node [GM 1]) + , "rejects unsupported games" ~: + forM_ [2..16] $ \x -> parseAndFail $ "(;GM[" ++ show x ++ "]" + ] + , "ST" ~: TestList + [ "parses valid variation modes" ~: do + parseOrFail "(;ST[0])" (@?= node [ST $ VariationMode ShowChildVariations True]) + parseOrFail "(;ST[1])" (@?= node [ST $ VariationMode ShowCurrentVariations True]) + parseOrFail "(;ST[2])" (@?= node [ST $ VariationMode ShowChildVariations False]) + parseOrFail "(;ST[3])" (@?= node [ST $ VariationMode ShowCurrentVariations False]) + , "rejects invalid variation modes" ~: + forM_ [4..10] $ \x -> parseAndFail $ "(;ST[" ++ show x ++ "]" + ] + , "SZ" ~: TestList + [ "parses square boards" ~: + forM_ [1..52] $ \x -> + parseOrFail ("(;SZ[" ++ show x ++ "])") (@?= node [SZ x x]) + , "parses nonsquare boards" ~: do + parseOrFail "(;SZ[1:2])" (@?= node [SZ 1 2]) + parseOrFail "(;SZ[1:9])" (@?= node [SZ 1 9]) + parseOrFail "(;SZ[1:19])" (@?= node [SZ 1 19]) + parseOrFail "(;SZ[2:1])" (@?= node [SZ 2 1]) + parseOrFail "(;SZ[9:1])" (@?= node [SZ 9 1]) + parseOrFail "(;SZ[19:1])" (@?= node [SZ 19 1]) + parseOrFail "(;SZ[19:52])" (@?= node [SZ 19 52]) + parseOrFail "(;SZ[10:16])" (@?= node [SZ 10 16]) + , "rejects invalid sizes" ~: do + -- Boards must have length at least 1... + parseAndFail "(;SZ[0])" + parseAndFail "(;SZ[-1])" + -- ...and at most 52. + parseAndFail "(;SZ[53])" + parseAndFail "(;SZ[54])" + parseAndFail "(;SZ[0:19])" + parseAndFail "(;SZ[19:0])" + parseAndFail "(;SZ[9:53])" + parseAndFail "(;SZ[53:9])" + -- This is specified by the SGF spec: + , "rejects square boards defined with two numbers" ~: do + parseAndFail "(;SZ[1:1])" + parseAndFail "(;SZ[19:19])" + ] + ] + +-- TODO Test the test of the properties. diff --git a/tests/Game/Goatee/Lib/ParserTestUtils.hs b/tests/Game/Goatee/Lib/ParserTestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/ParserTestUtils.hs @@ -0,0 +1,63 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.ParserTestUtils ( + parseOrFail, + parseAndFail, + assertParse, + assertNoParse, + ) where + +import Control.Applicative ((<*)) +import Game.Goatee.Lib.Parser +import Game.Goatee.Lib.Tree +import Test.HUnit (assertFailure) +import Text.ParserCombinators.Parsec (Parser, eof, parse) + +-- Parses a string as a complete SGF document. On success, executes the +-- continuation function with the result. Otherwise, causes an assertion +-- failure. +parseOrFail :: String -> (Node -> IO ()) -> IO () +parseOrFail input cont = case parseString input of + Left error -> assertFailure $ "Failed to parse SGF: " ++ error + Right (Collection roots) -> case roots of + root:[] -> cont root + _ -> assertFailure $ "Expected a single root node, got: " ++ show roots + +-- Parses a string as a complete SGF document and expects failure. +parseAndFail :: String -> IO () +parseAndFail input = case parseString input of + Left _ -> return () + Right result -> assertFailure $ "Expected " ++ show input ++ + " not to parse. Parsed to " ++ show result ++ "." + +-- Parses a string using the given parser and expects the parser to consume the +-- entire input. On success, executes the continuation function with the +-- result. Otherwise, causes an assertion failure. +assertParse :: Parser a -> String -> (a -> IO ()) -> IO () +assertParse parser input cont = case parse (parser <* eof) "" input of + Left error -> assertFailure $ "Failed to parse: " ++ show error + Right result -> cont result + +-- Tries to parse a string using the given parser. If the parse succeeds then +-- this function causes an assertion failure, otherwise this function succeeds. +assertNoParse :: Show a => Parser a -> String -> IO () +assertNoParse parser input = case parse (parser <* eof) "" input of + Left _ -> return () + Right result -> assertFailure $ + "Expected " ++ show input ++ " not to parse. " ++ + "Parsed to " ++ show result ++ "." diff --git a/tests/Game/Goatee/Lib/Property/ParserTest.hs b/tests/Game/Goatee/Lib/Property/ParserTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/Property/ParserTest.hs @@ -0,0 +1,388 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.Property.ParserTest (tests) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM_) +import Data.Maybe (catMaybes) +import Game.Goatee.Common +import Game.Goatee.Lib.ParserTestUtils +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.TestInstances () +import Game.Goatee.Lib.TestUtils +import Game.Goatee.Lib.Types +import Test.HUnit ((~:), (@?=), Test (TestList)) +import Text.ParserCombinators.Parsec (Parser) + +tests = "Game.Goatee.Lib.Property.ParserTest" ~: TestList + [ -- Tests for public parsers. + parserColorTests + , parserDoubleTests + , parserGameResultTests + , parserIntegralTests + , parserMoveTests + , parserRealTests + , parserRulesetTests + , parserSizeTests + , parserVariationModeTests + -- Tests for private parsers. + , lineTests + , simpleTextTests + , simpleTextComposedTests + , textTests + , textComposedTests + -- Miscellaneous tests. + , propertyValueArityTests + ] + +parserColorTests = "colorParser" ~: TestList + [ "parses B" ~: assertParse colorParser "[B]" (@?= Black) + , "parses W" ~: assertParse colorParser "[W]" (@?= White) + ] + +parserDoubleTests = "doubleParser" ~: TestList + [ "parses 1" ~: assertParse doubleParser "[1]" (@?= Double1) + , "parses 2" ~: assertParse doubleParser "[2]" (@?= Double2) + ] + +parserGameResultTests = "gameResultParser" ~: TestList + [ "draw" ~: do + assertParse gameResultParser "[0]" (@?= GameResultDraw) + assertParse gameResultParser "[Draw]" (@?= GameResultDraw) + + , "void" ~: + assertParse gameResultParser "[Void]" (@?= GameResultVoid) + + , "unknown" ~: + assertParse gameResultParser "[?]" (@?= GameResultUnknown) + + , "Black wins by points" ~: do + assertParse gameResultParser "[B+0.5]" (@?= GameResultWin Black (WinByScore $ read "0.5")) + assertParse gameResultParser "[B+11]" (@?= GameResultWin Black (WinByScore $ read "11")) + assertParse gameResultParser "[B+354.5]" (@?= GameResultWin Black (WinByScore $ read "354.5")) + + , "Black wins by resignation" ~: do + assertParse gameResultParser "[B+R]" (@?= GameResultWin Black WinByResignation) + assertParse gameResultParser "[B+Resign]" (@?= GameResultWin Black WinByResignation) + + , "Black wins on time" ~: do + assertParse gameResultParser "[B+T]" (@?= GameResultWin Black WinByTime) + assertParse gameResultParser "[B+Time]" (@?= GameResultWin Black WinByTime) + + , "Black wins by forfeit" ~: do + assertParse gameResultParser "[B+F]" (@?= GameResultWin Black WinByForfeit) + assertParse gameResultParser "[B+Forfeit]" (@?= GameResultWin Black WinByForfeit) + + , "White wins by points" ~: do + assertParse gameResultParser "[W+0.5]" (@?= GameResultWin White (WinByScore $ read "0.5")) + assertParse gameResultParser "[W+11]" (@?= GameResultWin White (WinByScore $ read "11")) + assertParse gameResultParser "[W+354.5]" (@?= GameResultWin White (WinByScore $ read "354.5")) + + , "White wins by resignation" ~: do + assertParse gameResultParser "[W+R]" (@?= GameResultWin White WinByResignation) + assertParse gameResultParser "[W+Resign]" (@?= GameResultWin White WinByResignation) + + , "White wins on time" ~: do + assertParse gameResultParser "[W+T]" (@?= GameResultWin White WinByTime) + assertParse gameResultParser "[W+Time]" (@?= GameResultWin White WinByTime) + + , "White wins by forfeit" ~: do + assertParse gameResultParser "[W+F]" (@?= GameResultWin White WinByForfeit) + assertParse gameResultParser "[W+Forfeit]" (@?= GameResultWin White WinByForfeit) + + , "custom game results" ~: do + assertParseToOther "" + assertParseToOther "Everyone wins." + assertParseToOther "W+Nuclear tesuji" + assertParseToOther "B+Flamingo" + ] + where assertParseToOther input = + assertParse gameResultParser ('[' : input ++ "]") + (@?= GameResultOther (toSimpleText input)) + +parserIntegralTests = "integralParser" ~: TestList $ integerTestsFor integralParser + +parserMoveTests = "moveParser" ~: TestList $ coordTestsFor moveParser Just ++ + [ "parses an empty move as a pass" ~: assertParse moveParser "[]" (@?= Nothing) + ] + +parserRealTests = "realParser" ~: TestList $ integerTestsFor realParser ++ + [ "parses a decimal zero" ~: assertParse realParser "[0.0]" (@?= 0) + + , "parses fractional positive numbers" ~: do + assertParse realParser "[0.5]" (@?= read "0.5") + assertParse realParser "[00.001250]" (@?= read "0.00125") + assertParse realParser "[3.14]" (@?= read "3.14") + assertParse realParser "[10.0]" (@?= read "10") + + , "parses fractional negative numbers" ~: do + assertParse realParser "[-0.5]" (@?= read "-0.5") + assertParse realParser "[-00.001250]" (@?= read "-0.00125") + assertParse realParser "[-3.14]" (@?= read "-3.14") + assertParse realParser "[-10.0]" (@?= read "-10") + ] + +parserRulesetTests = "rulesetParser" ~: TestList + [ "parses known rules" ~: do + assertParse rulesetParser "[AGA]" (@?= KnownRuleset RulesetAga) + assertParse rulesetParser "[Goe]" (@?= KnownRuleset RulesetIng) + assertParse rulesetParser "[Japanese]" (@?= KnownRuleset RulesetJapanese) + assertParse rulesetParser "[NZ]" (@?= KnownRuleset RulesetNewZealand) + + , "parses unknown rules" ~: do + assertParse rulesetParser "[Foo]" (@?= UnknownRuleset "Foo") + assertParse rulesetParser "[First capture]" (@?= UnknownRuleset "First capture") + ] + +parserSizeTests = "size" ~: TestList + [ "parses square boards" ~: do + assertParse sizeParser "[1]" (@?= (1, 1)) + assertParse sizeParser "[4]" (@?= (4, 4)) + assertParse sizeParser "[9]" (@?= (9, 9)) + assertParse sizeParser "[19]" (@?= (19, 19)) + assertParse sizeParser "[52]" (@?= (52, 52)) + + , "parses rectangular boards" ~: do + assertParse sizeParser "[1:2]" (@?= (1, 2)) + assertParse sizeParser "[9:5]" (@?= (9, 5)) + assertParse sizeParser "[19:9]" (@?= (19, 9)) + + , "rejects boards of non-positive size" ~: do + assertNoParse sizeParser "[0]" + assertNoParse sizeParser "[-1]" + assertNoParse sizeParser "[0:5]" + assertNoParse sizeParser "[5:0]" + assertNoParse sizeParser "[0:-2]" + + , "rejects square boards given in rectangular format" ~: do + assertNoParse sizeParser "[1:1]" + assertNoParse sizeParser "[13:13]" + ] + +parserVariationModeTests = "variationModeParser" ~: TestList + [ "mode 0" ~: + assertParse variationModeParser "[0]" (@?= VariationMode ShowChildVariations True) + + , "mode 1" ~: + assertParse variationModeParser "[1]" (@?= VariationMode ShowCurrentVariations True) + + , "mode 2" ~: + assertParse variationModeParser "[2]" (@?= VariationMode ShowChildVariations False) + + , "mode 3" ~: + assertParse variationModeParser "[3]" (@?= VariationMode ShowCurrentVariations False) + ] + +lineTests = "line" ~: TestList + [ "parses all valid values" ~: do + let cases = zip (['a'..'z'] ++ ['A'..'Z']) [0..] + forM_ cases $ \(char, expected) -> + assertParse line [char] (@?= expected) + ] + +simpleTextTests = "simpleText" ~: TestList $ + textTestsFor simpleText fromSimpleText False ++ + textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText False) + +simpleTextComposedTests = "simpleText composed" ~: TestList $ + textTestsFor simpleText fromSimpleText True ++ + textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText True) + +textTests = "text" ~: TestList $ + textTestsFor text id False ++ + textUnescapedNewlinePreservingTests (text False) + +textComposedTests = "text composed" ~: TestList $ + textTestsFor text id True ++ + textUnescapedNewlinePreservingTests (text True) + +propertyValueArityTests = "property value arities" ~: TestList + [ "single values (single)" ~: TestList + [ "accepts a property that requires a single number" ~: + parseOrFail "(;SZ[1])" (@?= node [SZ 1 1]) + + , "accepts a property that requires a single point" ~: + parseOrFail "(;B[dd])" (@?= node [B $ Just (3, 3)]) + ] + + , "lists (listOf)" ~: TestList + [ "doesn't accept an empty list" ~: + parseAndFail "(;AR[])" + + , "accepts a single value" ~: + parseOrFail "(;AR[aa:bb])" (@?= node [AR [((0, 0), (1, 1))]]) + + , "accepts two values" ~: + parseOrFail "(;AR[aa:bb][cc:de])" (@?= node [AR [((0, 0), (1, 1)), + ((2, 2), (3, 4))]]) + ] + + , "point lists (listOfPoint)" ~: TestList + [ "doesn't accept an empty list" ~: + parseAndFail "(;AB[])" + + , "accepts a single point" ~: + parseOrFail "(;AB[aa])" (@?= node [AB $ coords [(0, 0)]]) + + , "accepts two points" ~: + parseOrFail "(;AB[aa][bb])" (@?= node [AB $ coords [(0, 0), (1, 1)]]) + + , "accepts a rectangle" ~: + parseOrFail "(;AB[aa:bb])" (@?= node [AB $ coords' [] [((0, 0), (1, 1))]]) + + , "accepts two rectangles" ~: + parseOrFail "(;AB[aa:bb][cd:de])" (@?= node [AB $ coords' [] [((0, 0), (1, 1)), + ((2, 3), (3, 4))]]) + ] + + , "point elists (elistOfPoint)" ~: TestList + [ "accepts an empty list" ~: + parseOrFail "(;VW[])" (@?= node [VW $ coords []]) + + , "accepts single points" ~: + parseOrFail "(;VW[aa][bb])" (@?= node [VW $ coords [(0, 0), (1, 1)]]) + + , "accepts a rectangle" ~: + parseOrFail "(;VW[aa:bb])" (@?= node [VW $ coords' [] [((0, 0), (1, 1))]]) + + , "accepts two rectangles" ~: + parseOrFail "(;VW[aa:bb][cc:dd])" (@?= node [VW $ coords' [] [((0, 0), (1, 1)), + ((2, 2), (3, 3))]]) + ] + + -- TODO Test that invalid rectangles such as cd:dc fail to parse (or rather, + -- get corrected with a warning). + ] + +integerTestsFor :: (Eq a, Num a, Show a) => Parser a -> [Test] +integerTestsFor parser = + [ "parses 0" ~: do + assertParse parser "[0]" (@?= 0) + assertParse parser "[+0]" (@?= 0) + assertParse parser "[-0]" (@?= 0) + + , "parses positive integers" ~: do + assertParse parser "[1]" (@?= 1) + assertParse parser "[20]" (@?= 20) + assertParse parser "[4294967296]" (@?= (2 ^ 32)) + assertParse parser "[18446744073709551616]" (@?= (2 ^ 64)) + + , "parses positive integers with the plus sign" ~: do + assertParse parser "[+1]" (@?= 1) + assertParse parser "[+20]" (@?= 20) + assertParse parser "[+4294967296]" (@?= (2 ^ 32)) + assertParse parser "[+18446744073709551616]" (@?= (2 ^ 64)) + + , "parses negative integers" ~: do + assertParse parser "[-1]" (@?= (-1)) + assertParse parser "[-20]" (@?= (-20)) + assertParse parser "[-4294967296]" (@?= (- (2 ^ 32))) + assertParse parser "[-18446744073709551616]" (@?= (- (2 ^ 64))) + ] + +coordTestsFor :: (Eq a, Show a) => Parser a -> (Coord -> a) -> [Test] +coordTestsFor parser f = + [ "parses boundary points" ~: do + assertParse parser "[aa]" (@?= f (0, 0)) + assertParse parser "[zz]" (@?= f (25, 25)) + assertParse parser "[AA]" (@?= f (26, 26)) + assertParse parser "[ZZ]" (@?= f (51, 51)) + + , "parses coordinate order correctly" ~: do + assertParse parser "[ab]" (@?= f (0, 1)) + assertParse parser "[ba]" (@?= f (1, 0)) + + , "doesn't parse a partial point" ~: + assertNoParse parser "[a]" + ] + +textTestsFor :: (Bool -> Parser a) -> (a -> String) -> Bool -> [Test] +textTestsFor makeParser toString testComposed = + let rawParser = makeParser testComposed + parser = toString <$> rawParser + composedParser = mapTuple toString <$> compose rawParser rawParser + in catMaybes + [ Just $ "parses an empty string" ~: + assertParse parser "" (@?= "") + + , Just $ "parses a short string" ~: + assertParse parser "Hello, world." (@?= "Hello, world.") + + , Just $ "preserves leading and trailing whitespace" ~: + assertParse parser " \tHi. \t" (@?= " Hi. ") + + , Just $ "parses escaped backslashes" ~: do + assertParse parser "\\\\" (@?= "\\") + assertParse parser "\\\\\\\\" (@?= "\\\\") + assertNoParse parser "\\" + assertNoParse parser "\\\\\\" + + , Just $ "parses escaped ']'s" ~: do + assertParse parser "\\]" (@?= "]") + assertParse parser "\\]\\\\\\]" (@?= "]\\]") + + , Just $ if testComposed + then "parses escaped ':'s" ~: do + assertParse parser "\\:" (@?= ":") + assertParse parser "\\:\\\\\\:" (@?= ":\\:") + assertNoParse parser ":" + else "parses unescaped ':'s" ~: do + assertParse parser ":" (@?= ":") + assertParse parser "::" (@?= "::") + -- An escaped colon should parse just the same. + assertParse parser "\\:" (@?= ":") + + , if not testComposed + then Nothing + else Just $ "supports composed values" ~: do + assertParse composedParser ":" (@?= ("", "")) + assertParse composedParser "a:" (@?= ("a", "")) + assertParse composedParser ":z" (@?= ("", "z")) + assertParse composedParser "a:z" (@?= ("a", "z")) + assertParse composedParser "a\\\\:z" (@?= ("a\\", "z")) + assertParse composedParser "a\\:b:y\\:z" (@?= ("a:b", "y:z")) + assertNoParse composedParser "" + + , -- Tests non-newline whitespace replacement. Newline handling is + -- specific to individual parsers. + Just $ "replaces whitespace with spaces" ~: + assertParse parser "\t\r\f\v" (@?= " ") + + , Just $ "removes escaped newlines" ~: do + assertParse parser "\\\n" (@?= "") + assertParse parser "foo\\\nbar" (@?= "foobar") + assertParse parser "foo \\\n bar" (@?= "foo bar") + ] + +textUnescapedNewlinePreservingTests :: Parser String -> [Test] +textUnescapedNewlinePreservingTests parser = + [ "preserves unescaped newlines" ~: do + assertParse parser "\n" (@?= "\n") + assertParse parser "\n\n" (@?= "\n\n") + assertParse parser "foo\nbar" (@?= "foo\nbar") + assertParse parser "foo \n bar" (@?= "foo \n bar") + ] + +textUnescapedNewlineConvertingTests :: Parser String -> [Test] +textUnescapedNewlineConvertingTests parser = + [ "converts unescaped newlines to spaces" ~: do + assertParse parser "\n" (@?= " ") + assertParse parser "\n\n" (@?= " ") + assertParse parser "foo\nbar" (@?= "foo bar") + assertParse parser "foo \n bar" (@?= "foo bar") + ] diff --git a/tests/Game/Goatee/Lib/PropertyTest.hs b/tests/Game/Goatee/Lib/PropertyTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/PropertyTest.hs @@ -0,0 +1,72 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.PropertyTest (tests) where + +import qualified Data.Set as Set +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Types +import Test.HUnit ((~:), (@=?), Test (TestList)) + +tests = "Game.Goatee.Lib.Property" ~: TestList + [ propertyMetadataTests + , markPropertyTests + ] + +propertyMetadataTests = "property metadata" ~: TestList + [ "game info properties" ~: gameInfoProperties @=? filterTo GameInfoProperty allProperties + , "general properties" ~: generalProperties @=? filterTo GeneralProperty allProperties + , "move properties" ~: moveProperties @=? filterTo MoveProperty allProperties + , "root properties" ~: rootProperties @=? filterTo RootProperty allProperties + , "setup properties" ~: setupProperties @=? filterTo SetupProperty allProperties + + , "inherited properties" ~: [DD cl] @=? filter propertyInherited allProperties + ] + where filterTo propType = filter ((propType ==) . propertyType) + moveProperties = [-- Move properties. + B Nothing, KO, MN 1, W Nothing, + -- Move annotation properties. + BM db, DO, IT, TE db] + setupProperties = [-- Setup properties. + AB cl, AE cl, AW cl, PL Black] + generalProperties = [-- Node annotation properties. + C tx, DM db, GB db, GW db, HO db, N st, UC db, V rv, + -- Markup properties. + AR [], CR cl, DD cl, LB [], LN [], MA cl, SL cl, SQ cl, TR cl, + -- Guess this fits here. + UnknownProperty "" (toUnknownPropertyValue "")] + rootProperties = [-- Root properties. + AP st st, CA st, FF 1, GM 1, ST vm, SZ 1 1] + gameInfoProperties = [-- Game info properties. + AN st, BR st, BT st, CP st, DT st, EV st, GC tx, GN st, ON st, OT st, + PB st, PC st, PW st, RE GameResultVoid, RO st, RU ru, + SO st, TM rv, US st, WR st, WT st] + allProperties = moveProperties ++ setupProperties ++ generalProperties ++ + rootProperties ++ gameInfoProperties + cl = emptyCoordList + db = Double1 + tx = toText "" + st = toSimpleText "" + ru = KnownRuleset RulesetJapanese + rv = 1 + vm = defaultVariationMode + +markPropertyTests = "markProperty" ~: TestList + [ "doesn't repeat properties" ~: + let marks = [minBound..maxBound] + in length marks @=? Set.size (Set.fromList $ map (propertyName . markProperty) marks) + ] diff --git a/tests/Game/Goatee/Lib/RoundTripTest.hs b/tests/Game/Goatee/Lib/RoundTripTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/RoundTripTest.hs @@ -0,0 +1,103 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.RoundTripTest (tests) where + +import Data.Function (on) +import Game.Goatee.Common +import Game.Goatee.Lib.Parser +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Renderer +import Game.Goatee.Lib.Renderer.Tree +import Game.Goatee.Lib.TestUtils +import Game.Goatee.Lib.Tree +import Game.Goatee.Lib.Types +import Test.HUnit ((~:), (@?=), Assertion, Test (TestList), assertFailure) + +testCollection' :: Collection -> Assertion +testCollection' collection = + case runRender $ renderCollection collection of + Left message -> assertFailure $ "Failed to render: " ++ message + Right serialized -> + case parseString serialized of + Left error -> assertFailure $ "Failed to parse: " ++ error ++ + "\n\nEntire SGF: " ++ serialized + Right collection' -> do + on (@?=) CollectionWithDeepEquality collection' collection + case runRender $ renderCollection collection' of + Left message -> assertFailure $ "Second render failed: " ++ message + Right serializedAgain -> serializedAgain @?= serialized + +-- | Returns an assertion that the given node round-trips okay. +testNode' :: Node -> Assertion +testNode' = testCollection' . Collection . (:[]) + +-- | Returns a test with the given string name that round-trips a single node. +testNode :: String -> Node -> Test +testNode label node = label ~: testNode' node + +tests = "Game.Goatee.Lib.RoundTripTest" ~: TestList + [ singleNodeGameTests + , propertyValueTests + ] + +singleNodeGameTests = "games with single nodes" ~: TestList + [ testNode "empty game" $ node [] + , testNode "some default properties" $ node [FF 4, GM 1, ST defaultVariationMode] + ] + +propertyValueTests = "property value types" ~: TestList + [ "color values" ~: TestList + [ testNode "black" $ node [PL Black] + , testNode "white" $ node [PL White] + ] + + , "double values" ~: TestList + [ testNode "1" $ node [DM Double1] + , testNode "2" $ node [DM Double2] + ] + + , "label list values" ~: TestList + [ testNode "one value" $ node [LB [((5,2), toSimpleText "Hi.")]] + , testNode "multiple value" $ node [LB [((5, 2), toSimpleText "Hi."), + ((0, 1), toSimpleText "Bye.")]] + ] + + , testNode "none value" $ node [KO] + + , "point-valued values" ~: TestList $ + for [0..boardSizeMax-1] + (\row -> testNode ("row " ++ show row) $ node [B $ Just (0, row)]) ++ + for [0..boardSizeMax-1] + (\col -> testNode ("row " ++ show col) $ node [B $ Just (col, 0)]) + + , "real values" ~: TestList + [ testNode "0" $ node [TM $ read "0"] + , testNode "0.0" $ node [TM $ read "0.0"] + , testNode "1500" $ node [TM $ read "1500"] + , testNode "150" $ node [TM $ read "150"] + , testNode "15" $ node [TM $ read "15"] + , testNode "1.5" $ node [TM $ read "1.5"] + , testNode "0.15" $ node [TM $ read "0.15"] + , testNode "0.015" $ node [TM $ read "0.015"] + , testNode "0.0015" $ node [TM $ read "0.0015"] + , testNode "60.5" $ node [TM $ read "60.5"] + , testNode "10.1" $ node [TM $ read "10.1"] + ] + ] + +-- TODO Many more round-trip tests. diff --git a/tests/Game/Goatee/Lib/TestInstances.hs b/tests/Game/Goatee/Lib/TestInstances.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/TestInstances.hs @@ -0,0 +1,25 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Test utilities for working with the SGF modules. +module Game.Goatee.Lib.TestInstances () where + +import Data.Function (on) +import Game.Goatee.Lib.Tree (Node, NodeWithDeepEquality (NodeWithDeepEquality)) + +instance Eq Node where + (==) = (==) `on` NodeWithDeepEquality diff --git a/tests/Game/Goatee/Lib/TestUtils.hs b/tests/Game/Goatee/Lib/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/TestUtils.hs @@ -0,0 +1,62 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +-- | Test utilities for working with the SGF modules. +module Game.Goatee.Lib.TestUtils ( + node, + node1, + node', + root, + child, + sortProperties, + ) where + +import Data.Function (on) +import Data.List (sortBy) +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Tree + +node :: [Property] -> Node +node props = emptyNode { nodeProperties = props } + +node1 :: [Property] -> Node -> Node +node1 props child = emptyNode { nodeProperties = props + , nodeChildren = [child] + } + +node' :: [Property] -> [Node] -> Node +node' props children = + emptyNode { nodeProperties = props + , nodeChildren = children + } + +-- | Creates a root node that starts with only a 'SZ' property. This is more +-- minimal than 'rootNode'. +root :: Int -> Int -> [Property] -> [Node] -> Node +root width height props = + foldr addChild $ foldr addProperty emptyNode (SZ width height:props) + +child :: Int -> Cursor -> Cursor +child = flip cursorChild + +-- | Sorts properties by their 'Show' strings, for use in tests that need to +-- check an unordered list of properties. +-- +-- TODO Probably better to have a compare-unordered operator. +sortProperties :: [Property] -> [Property] +sortProperties = sortBy (compare `on` show) diff --git a/tests/Game/Goatee/Lib/TreeTest.hs b/tests/Game/Goatee/Lib/TreeTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/TreeTest.hs @@ -0,0 +1,184 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.TreeTest (tests) where + +import Data.Version (showVersion) +import Game.Goatee.App (applicationName) +import Game.Goatee.Common +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.TestInstances () +import Game.Goatee.Lib.TestUtils +import Game.Goatee.Lib.Tree +import Game.Goatee.Lib.Types +import Game.Goatee.Test.Common +import Paths_goatee (version) +import Test.HUnit ((~:), (@=?), (@?=), Test (TestList)) + +tests = "Game.Goatee.Lib.Tree" ~: TestList + [ emptyNodeTests + , rootNodeTests + , findPropertyTests + , addPropertyTests + , addChildTests + , addChildAtTests + , deleteChildAtTests + ] + +emptyNodeTests = "emptyNode" ~: TestList + [ "has no properties" ~: [] @=? nodeProperties emptyNode + , "has no children" ~: [] @=? nodeChildren emptyNode + ] + +rootNodeTests = "rootNode" ~: TestList + [ "sets SZ correctly" ~: do + assertElem (SZ 9 9) $ nodeProperties $ rootNode $ Just (9, 9) + assertElem (SZ 19 19) $ nodeProperties $ rootNode $ Just (19, 19) + assertElem (SZ 9 5) $ nodeProperties $ rootNode $ Just (9, 5) + + , "sets AP correctly" ~: do + let ap = AP (toSimpleText applicationName) + (toSimpleText $ showVersion version) + assertElem ap $ nodeProperties $ rootNode Nothing + assertElem ap $ nodeProperties $ rootNode $ Just (9, 9) + ] + +findPropertyTests = "findProperty" ~: TestList + [ "returns Nothing for an empty node" ~: + Nothing @=? findProperty propertyB (mk []) + + , "returns Nothing if no properties match" ~: + Nothing @=? findProperty propertyB (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9]) + + , "finds present properties" ~: do + Just (B (Just (2,3))) @=? + findProperty propertyB (mk [B (Just (2,3))]) + Just (W Nothing) @=? + findProperty propertyW (mk [B Nothing, W Nothing]) + Just IT @=? + findProperty propertyIT (mk [IT, GW Double2]) + Just (GW Double2) @=? + findProperty propertyGW (mk [IT, GW Double2]) + + , "doesn't find absent properties" ~: do + Nothing @=? findProperty propertyW (mk [B Nothing]) + Nothing @=? findProperty propertyW (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9]) + ] + where mk properties = emptyNode { nodeProperties = properties } + +addPropertyTests = "addProperty" ~: TestList + [ "adds properties in order" ~: do + let prop1 = B (Just (6,6)) + prop2 = RE GameResultVoid + prop3 = C (toText "Game over.") + node1 = addProperty prop1 emptyNode + node2 = addProperty prop2 node1 + node3 = addProperty prop3 node2 + node1 @?= emptyNode { nodeProperties = [prop1] } + node2 @?= emptyNode { nodeProperties = [prop1, prop2] } + node3 @?= emptyNode { nodeProperties = [prop1, prop2, prop3] } + ] + +addChildTests = "addChild" ~: TestList + [ "adds children in order" ~: do + let node1 = emptyNode { nodeProperties = [B (Just (0,0))] } + node2 = emptyNode { nodeProperties = [W (Just (1,1))] } + node3 = emptyNode { nodeProperties = [B (Just (2,2))] } + node4 = emptyNode { nodeProperties = [W Nothing] } + node2' = addChild node3 node2 + node1' = addChild node2' node1 + node1'' = addChild node4 node1' + node1'' @?= mk [B (Just (0,0))] + [mk [W (Just (1,1))] + [mk [B (Just (2,2))] + []], + mk [W Nothing] + []] + ] + where mk properties children = emptyNode { nodeProperties = properties + , nodeChildren = children + } + +addChildAtTests = "addChildAt" ~: TestList + [ "adds to a childless node" ~: + let parent = node [B Nothing] + child = node [W Nothing] + in node1 [B Nothing] (node [W Nothing]) @=? addChildAt 0 child parent + + , "adds as a first child" ~: do + let expected = base { nodeChildren = newNode : baseChildren } + expected @=? addChildAt 0 newNode base + expected @=? addChildAt (-1) newNode base + expected @=? addChildAt (-2) newNode base + + , "adds as a middle child" ~: do + base { nodeChildren = listInsertAt 1 newNode baseChildren } @=? + addChildAt 1 newNode base + base { nodeChildren = listInsertAt 2 newNode baseChildren } @=? + addChildAt 2 newNode base + + , "adds as a last child" ~: do + let expected = base { nodeChildren = baseChildren ++ [newNode] } + expected @=? addChildAt baseChildCount newNode base + expected @=? addChildAt (baseChildCount + 1) newNode base + expected @=? addChildAt (baseChildCount + 2) newNode base + ] + where base = node' [B $ Just (0,0)] baseChildren + baseChildren = [node [W Nothing], + node [W $ Just (1,1)], + node [W $ Just (9,9)]] + baseChildCount = length $ nodeChildren base + newNode = node [B $ Just (1,1)] + +deleteChildAtTests = "deleteChildAt" ~: TestList + [ "deletes nothing from an empty list" ~: do + emptyNode @=? deleteChildAt (-1) emptyNode + emptyNode @=? deleteChildAt 0 emptyNode + emptyNode @=? deleteChildAt 1 emptyNode + + , "deletes an only child" ~: + node [B Nothing] @=? deleteChildAt 0 (node1 [B Nothing] $ node [W Nothing]) + + , "deletes a first child" ~: + base { nodeChildren = listDeleteAt 0 baseChildren } @=? + deleteChildAt 0 base + + , "deletes middle children" ~: do + base { nodeChildren = listDeleteAt 1 baseChildren } @=? + deleteChildAt 1 base + base { nodeChildren = listDeleteAt 2 baseChildren } @=? + deleteChildAt 2 base + + , "delete a last child" ~: + base { nodeChildren = init baseChildren } @=? + deleteChildAt (baseChildCount - 1) base + + , "has no effect for invalid indices" ~: do + base @=? deleteChildAt (-1) base + base @=? deleteChildAt (-2) base + base @=? deleteChildAt baseChildCount base + base @=? deleteChildAt (baseChildCount + 1) base + base @=? deleteChildAt (baseChildCount + 2) base + ] + where base = node' [B $ Just (0,0)] baseChildren + baseChildren = [node [W Nothing], + node [W $ Just (1,1)], + node [W $ Just (2,2)], + node [W $ Just (9,9)]] + baseChildCount = length $ nodeChildren base + +-- TODO Test validateNode. diff --git a/tests/Game/Goatee/Lib/TypesTest.hs b/tests/Game/Goatee/Lib/TypesTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Lib/TypesTest.hs @@ -0,0 +1,240 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 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 . + +module Game.Goatee.Lib.TypesTest (tests) where + +import Data.List (sort) +import Game.Goatee.Lib.Types +import Game.Goatee.Test.Common +import Test.HUnit ((~:), (@=?), (@?=), Assertion, Test (TestList)) + +tests = "Game.Goatee.Lib.Types" ~: TestList + [ expandCoordListTests + , buildCoordListTests + , starLinesTests + , isStarPointTests + , handicapStonesTests + , simpleTextTests + , cnotTests + ] + +expandCoordListTests = "expandCoordList" ~: TestList + [ "works with an empty CoordList" ~: do + [] @=? expandCoordList (coords []) + [] @=? expandCoordList (coords' [] []) + + , "works for single points" ~: do + [(1,2)] @=? expandCoordList (coord1 (1,2)) + [(3,4), (1,2)] @=? expandCoordList (coords [(3,4), (1,2)]) + let ten = [(i,i) | i <- [1..10]] + ten @=? expandCoordList (coords ten) + + -- TODO Test that a 1x1 rectangle is rejected. + + , "works for a nx1 rect" ~: + [(5,2), (5,3), (5,4)] @=? expandCoordList (coords' [] [((5,2), (5,4))]) + + , "works for a 1xn rect" ~: + [(1,0), (1,1), (1,2), (1,3)] @=? expandCoordList (coords' [] [((1,0), (1,3))]) + + , "works for an mxn rect" ~: + [(m,n) | m <- [2..5], n <- [3..7]] @=? + expandCoordList (coords' [] [((2,3), (5,7))]) + + -- TODO Test that x0 > x1 || y0 > y1 is rejected. + + , "works with multiple rects" ~: + [(0,0), (0,1), (0,2), (3,4), (4,4), (5,4)] @=? + expandCoordList (coords' [] [((0,0), (0,2)), ((3,4), (5,4))]) + + , "concatenates single points and rects" ~: + [(1,1), (0,0), (2,2), (2,3), (2,4)] @=? + expandCoordList (coords' [(1,1), (0,0)] [((2,2), (2,4))]) + ] + +buildCoordListTests = "buildCoordList" ~: TestList + [ "handles the empty case" ~: assertSinglesAndRects [] [] [] + + , "handles one single" ~: + assertSinglesAndRects [(0,1)] [] [(0,1)] + + , "handles multiple singles" ~: + assertSinglesAndRects [(0,0), (1,1)] [] [(0,0), (1,1)] + + , "handles a small rect (1x2)" ~: + assertSinglesAndRects [] [((0,1), (0,2))] [(0,1), (0,2)] + + , "handles a small square (2x2)" ~: + assertSinglesAndRects [] [((1,1), (2,2))] [(x,y) | x <- [1..2], y <- [1..2]] + + , "handles a larger rect" ~: + assertSinglesAndRects [] [((0,0), (2,4))] [(x,y) | x <- [0..2], y <- [0..4]] + + , "handles two rects" ~: + assertSinglesAndRects [] [((0,1), (1,2)), ((3,0), (4,1))] + [(0,1), (1,1), (0,2), (1,2), (3,0), (4,0), (3,1), (4,1)] + + , "handles rects and singles together" ~: + assertSinglesAndRects [(0,0)] [((1,1), (2,2))] + [(0,0), (1,1), (1,2), (2,1), (2,2)] + + , "handles five points together" ~: do + assertCoords [(1,0), (0,1), (1,1), (0,2), (1,2)] + assertCoords [(0,0), (1,0), (0,1), (1,1), (0,2)] + assertCoords [(0,0), (1,0), (2,0), (0,1), (1,1)] + assertCoords [(1,0), (2,0), (0,1), (1,1), (2,1)] + + , "handles a more complex case" ~: + assertCoords [(3,0), (4,0), + (3,1), (4,1), + (0,2), (1,2), (2,2), (3,2), (4,2), + (0,3), (1,3), + (0,4), (1,4), (3,4), (4,4)] + + , "handles a diagonal pattern" ~: + assertCoords [(0,0), (2,0), (4,0), + (1,1), (3,1), (5,1), + (2,2)] + ] + where -- | Asserts that the given grid of booleans parses to a 'CoordList' + -- that has the expected single points (not necessarily in the same + -- order), as well as the expected rectangles (not necessarily in the + -- same order). + assertSinglesAndRects :: [Coord] -> [(Coord, Coord)] -> [Coord] -> Assertion + assertSinglesAndRects expectedSingles expectedRects input = + coords' expectedSingles expectedRects @=? buildCoordList input + + -- | Asserts that the set of points returned from applying + -- 'buildCoordList' to the given grid of booleans is equal to + -- the given set of points. + assertCoords :: [Coord] -> Assertion + assertCoords input = sort input @=? sort (expandCoordList $ buildCoordList input) + +starLinesTests = "starLines" ~: TestList + [ "knows 9x9 boards" ~: Just [2, 4, 6] @=? starLines 9 9 + , "knows 13x13 boards" ~: Just [3, 6, 9] @=? starLines 13 13 + , "knows 19x19 boards" ~: Just [3, 9, 15] @=? starLines 19 19 + , "doesn't know 13x19" ~: Nothing @=? starLines 13 19 + , "doesn't know 10x10" ~: Nothing @=? starLines 10 10 + ] + +isStarPointTests = "isStarPoint" ~: TestList + [ "only knows correct star points on a 9x9 board" ~: + let expected = [(x, y) | x <- [2, 4, 6], y <- [2, 4, 6]] + actual = actualStarPoints 9 9 + in expected @=?* actual + + , "only knows correct star points on a 13x13 board" ~: + let expected = [(x, y) | x <- [3, 6, 9], y <- [3, 6, 9]] + actual = actualStarPoints 13 13 + in expected @=?* actual + + , "only knows correct star points on a 19x19 board" ~: + let expected = [(x, y) | x <- [3, 9, 15], y <- [3, 9, 15]] + actual = actualStarPoints 19 19 + in expected @=?* actual + + , "knows no star poinst on a 5x1 board" ~: + [] @=? actualStarPoints 5 1 + + , "knows no star points on a 15x15 board" ~: + [] @=? actualStarPoints 15 15 + + , "knows no star points on a 20x20 board" ~: + [] @=? actualStarPoints 20 20 + ] + where actualStarPoints width height = + map fst $ filter snd + [((x, y), isStarPoint width height x y) | x <- [0..width-1], y <- [0..height-1]] + +handicapStonesTests = "handicapStones" ~: TestList + [ "returns nothing for invalid handicaps" ~: do + Nothing @=? handicapStones 9 9 (-1) + Nothing @=? handicapStones 9 9 10 + Nothing @=? handicapStones 4 4 25 + + , "9x9 0 handicap" ~: assertHandicap 9 9 0 $ Just [] + , "9x9 1 handicap" ~: assertHandicap 9 9 1 $ Just [] + , "9x9 2 handicap" ~: assertHandicap 9 9 2 $ Just [(2,6), (6,2)] + , "9x9 3 handicap" ~: assertHandicap 9 9 3 $ Just [(2,6), (6,2), (6,6)] + , "9x9 4 handicap" ~: assertHandicap 9 9 4 $ Just [(2,2), (2,6), (6,2), (6,6)] + , "9x9 5 handicap" ~: assertHandicap 9 9 5 $ Just [(2,2), (2,6), (4,4), (6,2), (6,6)] + , "9x9 6 handicap" ~: assertHandicap 9 9 6 $ + Just [(2,2), (2,4), (2,6), (6,2), (6,4), (6,6)] + , "9x9 7 handicap" ~: assertHandicap 9 9 7 $ + Just [(2,2), (2,4), (2,6), (4,4), (6,2), (6,4), (6,6)] + , "9x9 8 handicap" ~: assertHandicap 9 9 8 $ + Just [(2,2), (2,4), (2,6), (4,2), (4,6), (6,2), (6,4), (6,6)] + , "9x9 9 handicap" ~: assertHandicap 9 9 9 $ + Just [(2,2), (2,4), (2,6), (4,2), (4,4), (4,6), (6,2), (6,4), (6,6)] + + , "13x13 0 handicap" ~: assertHandicap 13 13 0 $ Just [] + , "13x13 1 handicap" ~: assertHandicap 13 13 1 $ Just [] + , "13x13 2 handicap" ~: assertHandicap 13 13 2 $ Just [(3,9), (9,3)] + , "13x13 3 handicap" ~: assertHandicap 13 13 3 $ Just [(3,9), (9,3), (9,9)] + , "13x13 4 handicap" ~: assertHandicap 13 13 4 $ Just [(3,3), (3,9), (9,3), (9,9)] + , "13x13 5 handicap" ~: assertHandicap 13 13 5 $ Just [(3,3), (3,9), (6,6), (9,3), (9,9)] + , "13x13 6 handicap" ~: assertHandicap 13 13 6 $ + Just [(3,3), (3,6), (3,9), (9,3), (9,6), (9,9)] + , "13x13 7 handicap" ~: assertHandicap 13 13 7 $ + Just [(3,3), (3,6), (3,9), (6,6), (9,3), (9,6), (9,9)] + , "13x13 8 handicap" ~: assertHandicap 13 13 8 $ + Just [(3,3), (3,6), (3,9), (6,3), (6,9), (9,3), (9,6), (9,9)] + , "13x13 9 handicap" ~: assertHandicap 13 13 9 $ + Just [(3,3), (3,6), (3,9), (6,3), (6,6), (6,9), (9,3), (9,6), (9,9)] + + , "19x19 0 handicap" ~: assertHandicap 19 19 0 $ Just [] + , "19x19 1 handicap" ~: assertHandicap 19 19 1 $ Just [] + , "19x19 2 handicap" ~: assertHandicap 19 19 2 $ Just [(3,15), (15,3)] + , "19x19 3 handicap" ~: assertHandicap 19 19 3 $ Just [(3,15), (15,3), (15,15)] + , "19x19 4 handicap" ~: assertHandicap 19 19 4 $ Just [(3,3), (3,15), (15,3), (15,15)] + , "19x19 5 handicap" ~: assertHandicap 19 19 5 $ Just [(3,3), (3,15), (9,9), (15,3), (15,15)] + , "19x19 6 handicap" ~: assertHandicap 19 19 6 $ + Just [(3,3), (3,9), (3,15), (15,3), (15,9), (15,15)] + , "19x19 7 handicap" ~: assertHandicap 19 19 7 $ + Just [(3,3), (3,9), (3,15), (9,9), (15,3), (15,9), (15,15)] + , "19x19 8 handicap" ~: assertHandicap 19 19 8 $ + Just [(3,3), (3,9), (3,15), (9,3), (9,15), (15,3), (15,9), (15,15)] + , "19x19 9 handicap" ~: assertHandicap 19 19 9 $ + Just [(3,3), (3,9), (3,15), (9,3), (9,9), (9,15), (15,3), (15,9), (15,15)] + ] + where assertHandicap width height handicap maybeExpectedStones = + case (handicapStones width height handicap, maybeExpectedStones) of + (Just actualStones, Just expectedStones) -> actualStones @?=* expectedStones + (actual, _) -> actual @?= maybeExpectedStones + +simpleTextTests = "SimpleText" ~: TestList + [ "accepts the empty string" ~: + "" @=? fromSimpleText (toSimpleText "") + + , "passes through strings without newlines" ~: do + "Hello." @=? fromSimpleText (toSimpleText "Hello.") + "Bad for B." @=? fromSimpleText (toSimpleText "Bad for B.") + "[4k?]" @=? fromSimpleText (toSimpleText "[4k?]") + printableAsciiChars @=? fromSimpleText (toSimpleText printableAsciiChars) + + , "converts newlines to spaces" ~: do + " " @=? fromSimpleText (toSimpleText "\n") + "Hello, world." @=? fromSimpleText (toSimpleText "Hello,\nworld.") + "Hello, world." @=? fromSimpleText (toSimpleText "Hello, \n world.") + " Hello, world. " @=? fromSimpleText (toSimpleText "\nHello, world.\n") + ] + +cnotTests = "cnot" ~: TestList + [ "changes Black to White" ~: White @=? cnot Black + , "changes White to Black" ~: Black @=? cnot White + ] diff --git a/tests/Game/Goatee/Sgf/BoardTest.hs b/tests/Game/Goatee/Sgf/BoardTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/BoardTest.hs +++ /dev/null @@ -1,195 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.BoardTest (tests) where - -import Game.Goatee.Sgf.Board -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.TestInstances () -import Game.Goatee.Sgf.TestUtils -import Game.Goatee.Sgf.Tree -import Game.Goatee.Sgf.Types -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?), (@?=)) - -tests = testGroup "Game.Goatee.Sgf.Board" [ - boardCoordStateTests, - moveNumberTests, - markupPropertiesTests, - visibilityPropertyTests, - cursorModifyNodeTests, - colorToMoveTests - ] - -boardCoordStateTests = testGroup "boardCoordState" [ - testCase "works for a 1x1 board" $ do - let state = boardCoordState (0,0) $ rootBoardState $ - node [SZ 1 1, CR $ coord1 (0,0)] - coordStone state @?= Nothing - coordMark state @?= Just MarkCircle, - - testCase "works for a 2x2 board" $ do - let board = rootBoardState $ - node [SZ 2 2, B $ Just (0,0), TR $ coord1 (0,0), MA $ coord1 (1,1)] - coordStone (boardCoordState (0,0) board) @?= Just Black - coordMark (boardCoordState (0,0) board) @?= Just MarkTriangle - coordStone (boardCoordState (1,0) board) @?= Nothing - coordMark (boardCoordState (1,0) board) @?= Nothing - coordStone (boardCoordState (1,1) board) @?= Nothing - coordMark (boardCoordState (1,1) board) @?= Just MarkX - ] - - -moveNumberTests = testGroup "move number" [ - testCase "starts at zero" $ - 0 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [] $ node [B Nothing]), - - testCase "advances for nodes with moves" $ do - 1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [] $ node [B Nothing]) - 1 @=? boardMoveNumber (cursorBoard $ rootCursor $ node1 [B Nothing] $ node []) - 1 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ node1 [B Nothing] $ node []) - 2 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ - node1 [B Nothing] $ node [W Nothing]) - 2 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $ - node1 [B Nothing] $ node1 [W Nothing] $ node []) - 3 @=? boardMoveNumber (cursorBoard $ child 0 $ child 0 $ rootCursor $ - node1 [B Nothing] $ node1 [W Nothing] $ node [B Nothing]), - - testCase "doesn't advance for non-move nodes" $ do - 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ - node1 [] $ node []) - 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ - node1 [PL White] $ node []) - 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ - node1 [AB $ coords [(0,0)]] $ node []) - 0 @=? boardMoveNumber (cursorBoard $ child 0 $ rootCursor $ - node1 [IT, TE Double2, GN $ toSimpleText "Title"] $ node []) - ] - -markupPropertiesTests = testGroup "markup properties" [ - testGroup "adds marks to a BoardState" [ - testCase "CR" $ Just MarkCircle @=? getMark 0 0 (rootCursor $ node [CR $ coords [(0,0)]]), - testCase "MA" $ Just MarkX @=? getMark 0 0 (rootCursor $ node [MA $ coords [(0,0)]]), - testCase "SL" $ Just MarkSelected @=? getMark 0 0 (rootCursor $ node [SL $ coords [(0,0)]]), - testCase "SQ" $ Just MarkSquare @=? getMark 0 0 (rootCursor $ node [SQ $ coords [(0,0)]]), - testCase "TR" $ Just MarkTriangle @=? getMark 0 0 (rootCursor $ node [TR $ coords [(0,0)]]), - testCase "multiple at once" $ do - let cursor = rootCursor $ node [SZ 2 2, - CR $ coords [(0,0), (1,1)], - TR $ coords [(1,0)]] - [[Just MarkCircle, Just MarkTriangle], - [Nothing, Just MarkCircle]] - @=? map (map coordMark) (boardCoordStates $ cursorBoard cursor) - ], - - testGroup "adds more complex annotations to a BoardState" [ - testCase "AR" $ [((0,0), (1,1))] @=? boardArrows (rootCoord $ node [AR [((0,0), (1,1))]]), - testCase "LB" $ [((0,0), st "Hi")] @=? boardLabels (rootCoord $ node [LB [((0,0), st "Hi")]]), - testCase "LN" $ [((0,0), (1,1))] @=? boardLines (rootCoord $ node [LN [((0,0), (1,1))]]) - ], - - testCase "clears annotations when moving to a child node" $ do - let root = node1 [SZ 3 2, - CR $ coords [(0,0)], - MA $ coords [(1,0)], - SL $ coords [(2,0)], - SQ $ coords [(0,1)], - TR $ coords [(1,1)], - AR [((0,0), (2,1))], - LB [((2,1), st "Empty")], - LN [((1,1), (2,0))]] $ - node [] - board = cursorBoard $ child 0 $ rootCursor root - mapM_ (mapM_ ((Nothing @=?) . coordMark)) $ boardCoordStates board - [] @=? boardArrows board - [] @=? boardLines board - [] @=? boardLabels board - ] - where rootCoord = cursorBoard . rootCursor - st = toSimpleText - - getMark :: Int -> Int -> Cursor -> Maybe Mark - getMark x y cursor = coordMark $ boardCoordStates (cursorBoard cursor) !! y !! x - -visibilityPropertyTests = testGroup "visibility properties" [ - testCase "boards start with all points undimmed" $ - replicate 9 (replicate 9 False) @=? - map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]), - - testCase "DD selectively dims points" $ - let root = node [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]] - in [[True, True, False, True, False], - [True, True, False, False, False]] @=? - map (map coordDimmed) (boardCoordStates $ cursorBoard $ rootCursor root), - - testCase "dimming is inherited" $ - let root = node1 [SZ 5 2, DD $ coords' [(3,0)] [((0,0), (1,1))]] $ node [] - in [[True, True, False, True, False], - [True, True, False, False, False]] @=? - map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root), - - testCase "DD[] clears dimming" $ - let root = node1 [SZ 2 1, DD $ coords [(0,0)]] $ node [DD $ coords []] - in [[False, False]] @=? - map (map coordDimmed) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root), - - testCase "boards start with all points visible" $ - replicate 9 (replicate 9 True) @=? - map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor $ node [SZ 9 9]), - - testCase "VW selectively makes points visible" $ - let root = node [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]] - in [[False, True, True, True, True], - [True, False, True, True, True]] @=? - map (map coordVisible) (boardCoordStates $ cursorBoard $ rootCursor root), - - testCase "visibility is inherited" $ - let root = node1 [SZ 5 2, VW $ coords' [(1,0), (0,1)] [((2,0), (4,1))]] $ node [] - in [[False, True, True, True, True], - [True, False, True, True, True]] @=? - map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root), - - testCase "VW[] clears dimming" $ - let root = node1 [SZ 2 1, VW $ coords [(0,0)]] $ node [VW $ coords []] - in [[True, True]] @=? - map (map coordVisible) (boardCoordStates $ cursorBoard $ child 0 $ rootCursor root) - ] - -cursorModifyNodeTests = testGroup "cursorModifyNode" [ - testCase "updates the BoardState" $ - let cursor = child 0 $ rootCursor $ - node1 [SZ 3 1, B $ Just (0,0)] $ - node [W $ Just (1,0)] - modifyProperty prop = case prop of - W (Just (1,0)) -> W $ Just (2,0) - _ -> prop - modifyNode node = node { nodeProperties = map modifyProperty $ nodeProperties node } - result = cursorModifyNode modifyNode cursor - in map (map coordStone) (boardCoordStates $ cursorBoard result) @?= - [[Just Black, Nothing, Just White]] - ] - -colorToMoveTests = testGroup "colorToMove" [ - testCase "creates Black moves" $ do - B (Just (3,2)) @=? colorToMove Black (3,2) - B (Just (0,0)) @=? colorToMove Black (0,0), - - testCase "creates White moves" $ do - W (Just (18,18)) @=? colorToMove White (18,18) - W (Just (15,16)) @=? colorToMove White (15,16) - ] diff --git a/tests/Game/Goatee/Sgf/MonadTest.hs b/tests/Game/Goatee/Sgf/MonadTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/MonadTest.hs +++ /dev/null @@ -1,736 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.MonadTest (tests) where - -import Control.Applicative ((<$>)) -import Control.Arrow ((&&&)) -import Control.Monad (forM_, liftM, replicateM_, void) -import Control.Monad.Writer (Writer, execWriter, runWriter, tell) -import Data.List (unfoldr) -import Data.Maybe (fromJust, maybeToList) -import Game.Goatee.Sgf.Board -import Game.Goatee.Sgf.Monad -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.TestInstances () -import Game.Goatee.Sgf.TestUtils -import Game.Goatee.Sgf.Types -import Game.Goatee.Test.Common -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?), (@?=)) - -{-# ANN module "HLint: ignore Reduce duplication" #-} - -type LoggedGoM = GoT (Writer [String]) - -runLoggedGo :: LoggedGoM a -> Cursor -> (a, Cursor, [String]) -runLoggedGo go cursor = - let ((value, cursor'), log) = runWriter $ runGoT go cursor - in (value, cursor', log) - -tests = testGroup "Game.Goatee.Sgf.Monad" [ - monadTests, - navigationTests, - positionStackTests, - propertiesTests, - getPropertyTests, - getPropertyValueTests, - putPropertyTests, - deletePropertyTests, - modifyPropertyTests, - modifyPropertyValueTests, - modifyPropertyStringTests, - modifyPropertyCoordsTests, - modifyGameInfoTests, - modifyVariationModeTests, - getMarkTests, - modifyMarkTests, - addChildTests, - gameInfoChangedTests - ] - -monadTests = testGroup "monad properties" [ - testCase "returns a value it's given" $ - let cursor = rootCursor $ node [] - (value, cursor') = runGo (return 3) cursor - in (value, cursorNode cursor') @?= (3, cursorNode cursor), - - testCase "getCursor works" $ do - let cursor = rootCursor nodeA - nodeA = node1 [SZ 3 3, B $ Just (0,0)] nodeB - nodeB = node1 [W $ Just (1,1)] nodeC - nodeC = node [B $ Just (2,2)] - nodeA @=? evalGo (liftM cursorNode getCursor) cursor - nodeB @=? evalGo (goDown 0 >> liftM cursorNode getCursor) cursor - nodeC @=? evalGo (goDown 0 >> goDown 0 >> liftM cursorNode getCursor) cursor, - - testCase "getCoordState works" $ do - let cursor = child 0 $ child 0 $ rootCursor $ - node1 [SZ 2 2, B $ Just (0,0)] $ - node1 [W $ Just (1,0), TR $ coord1 (0,0)] $ - node [B $ Just (0,1), CR $ coord1 (1,0)] - action = mapM getCoordState [(0,0), (1,0), (0,1), (1,1)] - states = evalGo action cursor - map coordStone states @?= [Just Black, Just White, Just Black, Nothing] - map coordMark states @?= [Nothing, Just MarkCircle, Nothing, Nothing] - ] - -navigationTests = testGroup "navigation" [ - testCase "navigates down a tree" $ - let cursor = rootCursor $ - node1 [B $ Just (0,0)] $ - node' [W $ Just (1,1)] [node [B $ Just (2,2)], - node [B Nothing]] - action = goDown 0 >> goDown 1 - (_, cursor') = runGo action cursor - in cursorProperties cursor' @?= [B Nothing], - - testCase "navigates up a tree" $ - let cursor = child 1 $ child 0 $ rootCursor $ - node1 [B $ Just (0,0)] $ - node' [W $ Just (1,1)] [node [B $ Just (2,2)], - node [B Nothing]] - action = goUp >> goUp - (_, cursor') = runGo action cursor - in cursorProperties cursor' @?= [B $ Just (0,0)], - - testCase "invokes handlers when navigating" $ - let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] - action = do on navigationEvent $ \step -> case step of - GoUp index -> tell ["Up " ++ show index] - _ -> return () - on navigationEvent $ \step -> case step of - GoDown index -> tell ["Down " ++ show index] - _ -> return () - goDown 0 - goUp - (_, _, log) = runLoggedGo action cursor - in log @?= ["Down 0", "Up 0"], - - testCase "navigates to the root of a tree, invoking handlers" $ do - let cursor = child 0 $ child 0 $ rootCursor $ - node1 [B $ Just (0,0)] $ - node1 [W $ Just (1,1)] $ - node [B $ Just (2,2)] - action = do on navigationEvent $ \step -> tell [show step] - goToRoot - (_, cursor', log) = runLoggedGo action cursor - cursorProperties cursor' @?= [B $ Just (0,0)] - log @?= ["GoUp 0", "GoUp 0"], - - testGroup "goToGameInfoNode" [ - testCase "can navigate up to find game info" $ - let props = [PB (toSimpleText ""), B Nothing] - cursor = child 0 $ rootCursor $ node1 props $ node [W Nothing] - action = void $ goToGameInfoNode False - in cursorProperties (execGo action cursor) @?= props, - - testCase "can find game info at the current node" $ - let props = [PB (toSimpleText ""), W Nothing] - cursor = child 0 $ rootCursor $ node1 [B Nothing] $ node props - action = void $ goToGameInfoNode False - in cursorProperties (execGo action cursor) @?= props, - - testCase "doesn't find game info from a subnode" $ - let cursor = child 0 $ rootCursor $ - node1 [B $ Just (0,0)] $ - node1 [W $ Just (1,1)] $ - node [PB (toSimpleText ""), B Nothing] - action = void $ goToGameInfoNode False - in cursorProperties (execGo action cursor) @?= [W $ Just (1,1)], - - testCase "can return to the initial node when no game info is found" $ - let cursor = child 0 $ child 0 $ rootCursor $ - node1 [B $ Just (0,0)] $ - node1 [W $ Just (1,1)] $ - node [B $ Just (2,2)] - action = void $ goToGameInfoNode False - in cursorProperties (execGo action cursor) @?= [B $ Just (2,2)], - - testCase "can finish at the root node when no game info is found" $ - let cursor = child 0 $ child 0 $ rootCursor $ - node1 [B $ Just (0,0)] $ - node1 [W $ Just (1,1)] $ - node [B $ Just (2,2)] - action = void $ goToGameInfoNode True - in cursorProperties (execGo action cursor) @?= [B $ Just (0,0)] - ] - ] - -positionStackTests = testGroup "position stack" [ - testCase "should push, pop, and drop with no navigation" $ do - let cursor = rootCursor $ node [] - actions = [pushPosition >> popPosition, - pushPosition >> pushPosition >> popPosition >> popPosition, - pushPosition >> dropPosition, - pushPosition >> pushPosition >> dropPosition >> popPosition, - pushPosition >> pushPosition >> popPosition >> dropPosition] - forM_ actions $ \action -> cursorProperties (execGo action cursor) @?= [], - - testCase "should backtrack up and down the tree" $ do - let cursor = child 0 $ child 1 $ rootCursor $ - node' [B $ Just (0,0)] - [node1 [W $ Just (1,1)] $ node [B $ Just (2,2)], - node1 [W Nothing] $ node [B Nothing]] - action = pushPosition >> goUp >> goUp >> goDown 0 >> goDown 0 - cursorProperties (execGo (action >> popPosition) cursor) @?= [B Nothing] - cursorProperties (execGo (action >> dropPosition) cursor) @?= [B $ Just (2,2)], - - testCase "should pop multiple stacks" $ do - let cursor = child 0 $ child 0 commonCursor - action = do navigate - log >> popPosition - log >> popPosition - log - execWriter (runGoT action cursor) @?= - ["B (2,2)", "B (3,3)", "B (5,5)", "B (3,3)", "B (2,2)"], - - testCase "should drop then pop" $ do - let cursor = child 0 $ child 0 commonCursor - action = do navigate - log >> dropPosition - log >> popPosition - log - execWriter (runGoT action cursor) @?= - ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (2,2)"], - - testCase "should drop twice" $ do - let cursor = child 0 $ child 0 commonCursor - action = do navigate - log >> dropPosition - log >> dropPosition - log - execWriter (runGoT action cursor) @?= - ["B (2,2)", "B (3,3)", "B (5,5)", "B (5,5)", "B (5,5)"], - - testCase "should fire navigation handlers while popping" $ do - let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] - action = do pushPosition - goDown 0 - goUp - on navigationEvent $ \step -> tell [step] - popPosition - execWriter (runGoT action cursor) @?= [GoDown 0, GoUp 0] - ] - where commonCursor = rootCursor $ - node' [B $ Just (0,0)] - [node' [W $ Just (1,1)] - [node [B $ Just (2,2)], - node [B $ Just (3,3)]], - node1 [W $ Just (4,4)] $ node [B $ Just (5,5)]] - log = getCursor >>= \cursor -> case cursorProperties cursor of - [B (Just x)] -> tell ["B " ++ show x] - [W (Just x)] -> tell ["W " ++ show x] - xs -> error $ "Unexpected properties: " ++ show xs - navigate = do log >> pushPosition - goUp >> goDown 1 - log >> pushPosition - goUp >> goUp >> goDown 1 >> goDown 0 - -propertiesTests = testGroup "properties" [ - testGroup "getProperties" [ - testCase "returns an empty list" $ - let cursor = rootCursor $ node [] - in evalGo getProperties cursor @?= [], - - testCase "returns a non-empty list" $ - let properties = [PB $ toSimpleText "Foo", B Nothing] - cursor = rootCursor $ node properties - in evalGo getProperties cursor @?= properties - ], - - testGroup "modifyProperties" [ - testCase "adds properties" $ - let cursor = rootCursor $ node [FF 1] - action = do modifyProperties $ \props -> return $ props ++ [B Nothing, W Nothing] - getProperties - in evalGo action cursor @?= [FF 1, B Nothing, W Nothing], - - testCase "removes properties" $ - let cursor = rootCursor $ node [W Nothing, FF 1, B Nothing] - action = do modifyProperties $ \props -> return $ filter (not . isMoveProperty) props - getProperties - in evalGo action cursor @?= [FF 1], - - testCase "fires a properties modified event" $ - let cursor = rootCursor $ node [FF 1] - action = do on propertiesModifiedEvent $ \old new -> tell [(old, new)] - modifyProperties $ const $ return [FF 2] - log = execWriter (runGoT action cursor) - in log @?= [([FF 1], [FF 2])] - ] - ] - where isMoveProperty prop = case prop of - B _ -> True - W _ -> True - _ -> False - -getPropertyTests = testGroup "getProperty" [ - testCase "doesn't find an unset property" $ do - Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node []) - Nothing @=? evalGo (getProperty propertyW) (rootCursor $ node [B Nothing]), - - testCase "finds a set property" $ do - Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing]) - Just (B Nothing) @=? evalGo (getProperty propertyB) (rootCursor $ node [B Nothing, DO]) - Just DO @=? evalGo (getProperty propertyDO) (rootCursor $ node [B Nothing, DO]) - ] - -getPropertyValueTests = testGroup "getPropertyValue" [ - testCase "doesn't find an unset property" $ do - Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node []) - Nothing @=? evalGo (getPropertyValue propertyW) (rootCursor $ node [B Nothing]), - - testCase "finds a set property" $ do - Just Nothing @=? evalGo (getPropertyValue propertyB) (rootCursor $ node [B Nothing]) - Just (Just (0,0)) @=? - evalGo (getPropertyValue propertyB) (rootCursor $ node [B $ Just (0,0), TE Double1]) - Just Double1 @=? - evalGo (getPropertyValue propertyTE) (rootCursor $ node [B $ Just (0,0), TE Double1]) - ] - -putPropertyTests = testGroup "putProperty" [ - testCase "adds an unset property" $ do - [IT] @=? cursorProperties (execGo (putProperty IT) $ rootCursor $ node []) - [DO, IT] @=? - sortProperties (cursorProperties (execGo (putProperty IT) $ rootCursor $ node [DO])), - - testCase "replaces an existing property" $ - [TE Double2] @=? - cursorProperties (execGo (putProperty $ TE Double2) (rootCursor $ node [TE Double1])) - ] - -deletePropertyTests = testGroup "deleteProperty" [ - testCase "does nothing when the property isn't set" $ do - [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node []) - [B Nothing] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [B Nothing]), - - testCase "removes a property" $ do - [] @=? cursorProperties (execGo (deleteProperty DO) $ rootCursor $ node [DO]) - -- This is documented behaviour for deleteProperty, the fact that it doesn't - -- matter what the property value is: - [DO] @=? cursorProperties - (execGo (deleteProperty $ B $ Just (0,0)) $ rootCursor $ node [DO, B Nothing]) - ] - -modifyPropertyTests = testGroup "modifyProperty" [ - testCase "adds a property to an empty node" $ - let cursor = rootCursor $ node [] - action = modifyProperty propertyIT (\Nothing -> Just IT) - in cursorProperties (execGo action cursor) @?= [IT], - - testCase "adds a property to a non-empty node" $ - let cursor = rootCursor $ node [KO] - action = modifyProperty propertyIT (\Nothing -> Just IT) - in sortProperties (cursorProperties $ execGo action cursor) @?= [IT, KO], - - testCase "removes a property" $ do - let cursor = rootCursor $ node [IT, KO] - cursor' = execGo (modifyProperty propertyKO $ \(Just KO) -> Nothing) cursor - cursor'' = execGo (modifyProperty propertyIT $ \(Just IT) -> Nothing) cursor' - cursorProperties cursor' @?= [IT] - cursorProperties cursor'' @?= [], - - testCase "updates a property" $ do - let cursor = rootCursor $ node [B $ Just (0,0), BM Double2] - action = modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Just $ B $ Just (1,1) - cursor' = execGo action cursor - action' = modifyProperty propertyBM $ \(Just (BM Double2)) -> Just $ BM Double1 - cursor'' = execGo action' cursor' - sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2] - sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1], - - testCase "fires an event when modifying a property" $ do - let cursor = rootCursor $ node [B $ Just (0,0)] - action = do on propertiesModifiedEvent $ \[B (Just (0,0))] [] -> tell [0] - modifyProperty propertyB $ \(Just (B (Just (0,0)))) -> Nothing - (cursor', log) = runWriter (execGoT action cursor) - [0] @=? log - [] @=? cursorProperties cursor', - - testCase "modifying but not actually changing a property doesn't fire an event" $ do - let cursor = rootCursor $ node [B $ Just (0,0)] - action = do on propertiesModifiedEvent $ \_ _ -> tell ["Event fired."] - modifyProperty propertyB $ \p@(Just (B {})) -> p - (cursor', log) = runWriter (execGoT action cursor) - [B $ Just (0,0)] @=? cursorProperties cursor' - [] @=? log - ] - -modifyPropertyValueTests = testGroup "modifyPropertyValue" [ - testCase "adds a property to an empty node" $ - let cursor = rootCursor $ node [] - action = modifyPropertyValue propertyPL (\Nothing -> Just Black) - in cursorProperties (execGo action cursor) @?= [PL Black], - - testCase "adds a property to a non-empty node" $ - let cursor = rootCursor $ node [KO] - action = modifyPropertyValue propertyPL (\Nothing -> Just White) - in sortProperties (cursorProperties $ execGo action cursor) @?= [KO, PL White], - - testCase "removes a property" $ do - let cursor = rootCursor $ node [B Nothing, TE Double2] - cursor' = execGo (modifyPropertyValue propertyTE $ \(Just Double2) -> Nothing) cursor - cursor'' = execGo (modifyPropertyValue propertyB $ \(Just Nothing) -> Nothing) cursor' - cursorProperties cursor' @?= [B Nothing] - cursorProperties cursor'' @?= [], - - testCase "updates a property" $ do - let cursor = rootCursor $ node [B $ Just (0,0), BM Double2] - action = modifyPropertyValue propertyB $ \(Just (Just (0,0))) -> Just $ Just (1,1) - cursor' = execGo action cursor - action' = modifyPropertyValue propertyBM $ \(Just Double2) -> Just Double1 - cursor'' = execGo action' cursor' - sortProperties (cursorProperties cursor') @?= [B $ Just (1,1), BM Double2] - sortProperties (cursorProperties cursor'') @?= [B $ Just (1,1), BM Double1] - ] - -modifyPropertyStringTests = - testGroup "modifyPropertyString" - -- Test a Text property and a SimpleText property. - (assumptions ++ genTests "comment" propertyC ++ genTests "game name" propertyGN) - where assumptions = let _ = C $ toText "" - _ = GN $ toSimpleText "" - in [] - genTests name property = [ - testCase ("adds a " ++ name) $ - let cursor = rootCursor $ node [] - action = modifyPropertyString property (++ "Hello.") - in cursorProperties (execGo action cursor) @?= - [propertyBuilder property $ stringToSgf "Hello."], - - testCase ("removes a " ++ name) $ - let cursor = rootCursor $ node [propertyBuilder property $ stringToSgf "Hello."] - action = modifyPropertyString property $ \value -> case value of - "Hello." -> "" - other -> error $ "Got: " ++ other - in cursorProperties (execGo action cursor) @?= [], - - testCase ("updates a " ++ name) $ - let cursor = child 0 $ rootCursor $ - node1 [propertyBuilder property $ stringToSgf "one"] $ - node [propertyBuilder property $ stringToSgf "two"] - action = modifyPropertyString property $ \value -> case value of - "two" -> "three" - other -> error $ "Got: " ++ other - cursor' = execGo action cursor - in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= - ([propertyBuilder property $ stringToSgf "three"], - [propertyBuilder property $ stringToSgf "one"]), - - testCase "leaves a non-existant comment" $ - let result = execGo (modifyPropertyString property id) $ rootCursor $ node [] - in cursorProperties result @?= [] - ] - -modifyPropertyCoordsTests = testGroup "modifyPropertyCoords" [ - testCase "adds a property where there was none" $ - let cursor = rootCursor $ node [] - action = modifyPropertyCoords propertySL $ \[] -> [(0,0), (1,1)] - in [SL $ coords [(0,0), (1,1)]] @=? cursorProperties (execGo action cursor), - - testCase "removes a property where there was one" $ - let cursor = rootCursor $ node [TR $ coord1 (5,5)] - action = modifyPropertyCoords propertyTR $ \[(5,5)] -> [] - in [] @=? cursorProperties (execGo action cursor), - - testCase "modifies an existing property" $ - let cursor = rootCursor $ node [CR $ coord1 (3,4)] - action = modifyPropertyCoords propertyCR $ \[(3,4)] -> [(2,2)] - in [CR $ coord1 (2,2)] @=? cursorProperties (execGo action cursor), - - testCase "doesn't affect other properties" $ - let cursor = rootCursor $ node [SQ $ coord1 (0,0), MA $ coord1 (1,1)] - action = modifyPropertyCoords propertyMA $ \[(1,1)] -> [(2,2)] - in [MA $ coord1 (2,2), SQ $ coord1 (0,0)] @=? - sortProperties (cursorProperties $ execGo action cursor) - ] - -modifyGameInfoTests = testGroup "modifyGameInfo" [ - testGroup "creates info on the root node, starting with none" [ - testCase "starting from the root node" $ - let cursor = rootCursor $ node [] - action = modifyGameInfo (\info -> info { gameInfoGameName = Just "Orange" }) - in cursorProperties (execGo action cursor) @?= [GN $ toSimpleText "Orange"], - - testCase "starting from a non-root node" $ - let cursor = child 0 $ rootCursor $ node1 [] $ node [B Nothing] - action = modifyGameInfo (\info -> info { gameInfoGameName = Just "Orange" }) - cursor' = execGo action cursor - in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= - ([B Nothing], [GN $ toSimpleText "Orange"]) - ], - - testGroup "modifies existing info on the root" [ - testCase "starting from the root node" $ - let cursor = rootCursor $ node [GN $ toSimpleText "Orange"] - action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing - , gameInfoBlackName = Just "Peanut butter" - }) - in cursorProperties (execGo action cursor) @?= [PB $ toSimpleText "Peanut butter"], - - testCase "starting from a non-root node" $ - let cursor = child 0 $ rootCursor $ node1 [GN $ toSimpleText "Orange"] $ node [B Nothing] - action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing - , gameInfoBlackName = Just "Peanut butter" - }) - cursor' = execGo action cursor - in (cursorProperties cursor', cursorProperties $ fromJust $ cursorParent cursor') @?= - ([B Nothing], [PB $ toSimpleText "Peanut butter"]) - ], - - testCase "moves game info from a non-root node to the root" $ - let cursor = child 0 $ child 0 $ child 0 $ rootCursor $ - node1 [SZ 19 19] $ - node1 [B $ Just (0,0), GN $ toSimpleText "Orange"] $ - node1 [W $ Just (1,1)] $ - node [B $ Just (2,2)] - action = modifyGameInfo (\info -> info { gameInfoGameName = Nothing }) - cursor' = execGo action cursor - action' = modifyGameInfo (\info -> info { gameInfoBlackName = Just "Peanut butter" }) - cursor'' = execGo action' cursor' - -- unfoldr :: (Maybe Cursor -> Maybe ([Property], Maybe Cursor)) - -- -> Maybe Cursor - -- -> [[Property]] - properties = unfoldr (fmap $ cursorProperties &&& cursorParent) - (Just cursor'') - in map sortProperties properties @?= - [[B $ Just (2,2)], - [W $ Just (1,1)], - [B $ Just (0,0)], - [PB $ toSimpleText "Peanut butter", SZ 19 19]] - ] - -modifyVariationModeTests = testGroup "modifyVariationMode" [ - testCase "testing modes are not default" $ do - defaultVariationMode @/=? mode - defaultVariationMode @/=? mode2, - - testCase "modifies when at a root node" $ - node1 [ST mode] (node []) @=? - cursorNode (execGo setMode $ rootCursor $ node1 [] $ node []), - - testCase "modifies when at a non-root node" $ - node1 [ST mode] (node []) @=? - cursorNode (cursorRoot $ execGo setMode $ child 0 $ rootCursor $ node1 [] $ node []), - - testCase "leaves an unset ST unset" $ - assertST Nothing Nothing $ const defaultVariationMode, - - testCase "leaves a default ST alone" $ - assertST (Just defaultVariationMode) (Just defaultVariationMode) $ const defaultVariationMode, - - testCase "leaves an existing ST alone" $ - assertST (Just mode) (Just mode) $ const mode, - - testCase "adds an ST property" $ - assertST (Just mode) Nothing $ const mode, - - testCase "removes an ST property when setting to default" $ - assertST Nothing (Just mode) $ const defaultVariationMode, - - testCase "modifies an existing ST property" $ - assertST (Just mode2) (Just mode) $ const mode2 - ] - where mode = VariationMode ShowCurrentVariations True - mode2 = VariationMode ShowChildVariations False - setMode = modifyVariationMode $ const mode - assertST maybeExpectedST maybeInitialST fn = - node (ST <$> maybeToList maybeExpectedST) @=? - cursorNode (execGo (modifyVariationMode fn) $ - rootCursor $ node $ ST <$> maybeToList maybeInitialST) - -getMarkTests = testGroup "getMark" [ - testCase "returns Nothing for no mark" $ do - Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node []) - Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node [W $ Just (0,0)]), - - testCase "returns Just when a mark is present" $ do - Just MarkSquare @=? evalGo (getMark (1,2)) (rootCursor $ node [SQ $ coord1 (1,2)]) - Just MarkTriangle @=? evalGo (getMark (1,1)) (rootCursor $ node [B $ Just (1,1), - TR $ coord1 (1,1), - SQ $ coord1 (1,2)]), - - testCase "matches all marks" $ forM_ [minBound..maxBound] $ \mark -> - Just mark @=? - evalGo (getMark (0,0)) - (rootCursor $ node [propertyBuilder (markProperty mark) $ coord1 (0,0)]) - ] - -modifyMarkTests = testGroup "modifyMark" [ - testCase "creates a mark where there was none" $ - let cursor = rootCursor $ node [] - action = do modifyMark (\Nothing -> Just MarkX) (0,0) - getMark (0,0) - in Just MarkX @=? evalGo action cursor, - - testCase "removes an existing mark" $ - let cursor = rootCursor $ node [CR $ coord1 (0,0)] - action = do modifyMark (\(Just MarkCircle) -> Nothing) (0,0) - getMark (0,0) - in Nothing @=? evalGo action cursor, - - testCase "replaces an existing mark" $ - let cursor = rootCursor $ node [CR $ coord1 (0,0)] - action = do modifyMark (\(Just MarkCircle) -> Just MarkX) (0,0) - getMark (0,0) - in Just MarkX @=? evalGo action cursor, - - testCase "adds on to an existing mark property" $ - let cursor = rootCursor $ node [MA $ coord1 (0,0)] - action = do modifyMark (\Nothing -> Just MarkX) (1,0) - mapM getMark [(0,0), (1,0)] - in [Just MarkX, Just MarkX] @=? evalGo action cursor, - - testCase "removes from an existing mark property" $ - let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]] - action = do modifyMark (\(Just MarkX) -> Nothing) (1,0) - modifyMark (\(Just MarkX) -> Nothing) (0,1) - mapM getMark [(0,0), (1,0), (0,1)] - in [Just MarkX, Nothing, Nothing] @=? evalGo action cursor, - - testCase "removes and adds at the same time" $ - let cursor = rootCursor $ node [MA $ coords [(0,0), (1,0), (0,1)]] - action = do modifyMark (\(Just MarkX) -> Just MarkSquare) (0,0) - modifyMark (\(Just MarkX) -> Nothing) (0,1) - mapM getMark [(0,0), (1,0), (0,1)] - in [Just MarkSquare, Just MarkX, Nothing] @=? evalGo action cursor - ] - -addChildTests = testGroup "addChild" [ - testCase "adds an only child" $ - cursorNode (execGo (addChild 0 $ node [B Nothing]) (rootCursor $ node [])) - @?= node' [] [node [B Nothing]], - - testCase "adds a first child" $ - cursorNode (execGo (addChild 0 $ node [B $ Just (0,0)]) - (rootCursor $ node' [] [node [B $ Just (1,1)]])) - @?= node' [] [node [B $ Just (0,0)], - node [B $ Just (1,1)]], - - testCase "adds a middle child" $ - cursorNode (execGo (addChild 1 $ node [B $ Just (1,1)]) - (rootCursor $ node' [] [node [B $ Just (0,0)], - node [B $ Just (2,2)]])) - @?= node' [] [node [B $ Just (0,0)], - node [B $ Just (1,1)], - node [B $ Just (2,2)]], - - testCase "adds a last child" $ - cursorNode (execGo (addChild 2 $ node [B $ Just (2,2)]) - (rootCursor $ node' [] [node [B $ Just (0,0)], - node [B $ Just (1,1)]])) - @?= node' [] [node [B $ Just (0,0)], - node [B $ Just (1,1)], - node [B $ Just (2,2)]], - - testGroup "path stack correctness" [ - testCase "basic case just not needing updating" $ - let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] - action = do pushPosition - goUp - addChild 1 $ node [W $ Just (0,0)] - popPosition - in cursorNode (execGo action cursor) @?= node [W Nothing], - - testCase "basic case just needing updating" $ - let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] - action = do pushPosition - goUp - addChild 0 $ node [W $ Just (0,0)] - popPosition - in cursorNode (execGo action cursor) @?= node [W Nothing], - - testCase "basic case definitely needing updating" $ - let cursor = rootCursor $ node' [B Nothing] [node [W $ Just (0,0)], - node [W $ Just (1,1)]] - action = do goDown 1 - pushPosition - goUp - addChild 0 $ node [W Nothing] - popPosition - in cursorNode (execGo action cursor) @?= node [W $ Just (1,1)], - - testCase "multiple paths to update" $ - let at y x = B $ Just (y,x) - level0Node = node' [at 0 0] $ map level1Node [0..1] - level1Node i = node' [at 1 i] $ map level2Node [0..2] - level2Node i = node' [at 2 i] $ map level3Node [0..3] - level3Node i = node [at 3 i] - action = do goDown 1 >> goDown 2 >> goDown 3 - pushPosition - replicateM_ 4 goUp - goDown 1 >> goDown 2 >> goDown 2 >> goUp >> goDown 1 - addChild 0 $ node' [] [node []] - goDown 0 >> goDown 0 - goToRoot - popPosition - in cursorNode (execGo action $ rootCursor level0Node) @?= node [B $ Just (3,3)], - - testCase "updates paths with GoUp correctly" $ - let cursor = rootCursor $ node1 [B $ Just (0,0)] $ node [W $ Just (1,1)] - action = do pushPosition - goDown 0 - goUp - addChild 0 $ node [B $ Just (2,2)] - on navigationEvent $ \step -> tell [step] - popPosition - (_, log) = runWriter (runGoT action cursor) - in log @?= [GoDown 1, GoUp 1] - ] - ] - -gameInfoChangedTests = testGroup "gameInfoChangedEvent" [ - testCase "fires when navigating down" $ - let cursor = rootCursor $ - node1 [B $ Just (0,0)] $ - node [W $ Just (0,0), GN $ toSimpleText "Foo"] - action = do on gameInfoChangedEvent onInfo - goDown 0 - in execWriter (runGoT action cursor) @?= [(Nothing, Just "Foo")], - - testCase "fires when navigating up" $ - let cursor = child 0 $ rootCursor $ - node1 [B $ Just (0,0)] $ - node [W $ Just (0,0), GN $ toSimpleText "Foo"] - action = do on gameInfoChangedEvent onInfo - goUp - in execWriter (runGoT action cursor) @?= [(Just "Foo", Nothing)], - - testCase "fires from within popPosition" $ - let cursor = rootCursor $ - node1 [B $ Just (0,0)] $ - node [W $ Just (0,0), GN $ toSimpleText "Foo"] - action = do pushPosition - goDown 0 - goUp - on gameInfoChangedEvent onInfo - popPosition - in execWriter (runGoT action cursor) @?= - [(Nothing, Just "Foo"), (Just "Foo", Nothing)], - - testCase "fires when modifying properties" $ - let cursor = rootCursor $ node [] - action = do on gameInfoChangedEvent onInfo - modifyProperties $ const $ return [GN $ toSimpleText "Foo"] - modifyProperties $ const $ return [GN $ toSimpleText "Bar"] - modifyProperties $ const $ return [] - in execWriter (runGoT action cursor) @?= - [(Nothing, Just "Foo"), (Just "Foo", Just "Bar"), (Just "Bar", Nothing)] - ] - where onInfo old new = tell [(gameInfoGameName old, gameInfoGameName new)] diff --git a/tests/Game/Goatee/Sgf/ParserTest.hs b/tests/Game/Goatee/Sgf/ParserTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/ParserTest.hs +++ /dev/null @@ -1,242 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.ParserTest (tests) where - -import Control.Monad (forM_) -import Game.Goatee.Sgf.ParserTestUtils -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.TestInstances () -import Game.Goatee.Sgf.TestUtils -import Game.Goatee.Sgf.Tree -import Game.Goatee.Sgf.Types -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@?=)) - -tests = testGroup "Game.Goatee.Sgf.Parser" [ - baseCaseTests, - whitespaceTests, - passConversionTests, - movePropertyTests, - setupPropertyTests, - nodeAnnotationPropertyTests, - moveAnnotationPropertyTests, - rootPropertyTests - ] - -baseCaseTests = testGroup "base cases" [ - testCase "works with the trivial collection" $ - parseOrFail "(;)" (@?= emptyNode), - - testCase "works with only a size property" $ do - parseOrFail "(;SZ[1])" (@?= root 1 1 [] []) - parseOrFail "(;SZ[9])" (@?= root 9 9 [] []) - ] - -whitespaceTests = testGroup "whitespace handling" [ - testCase "parses with no extra whitespace" $ - parseOrFail "(;SZ[4];AB[aa][bb]AW[cc];W[dd])" - (@?= root 4 4 [] [node1 [AB $ coords [(0,0), (1,1)], AW $ coords [(2,2)]] $ - node [W $ Just (3,3)]]), - - testCase "parses with spaces between nodes" $ - parseOrFail "(;SZ[1] ;B[])" (@?= root 1 1 [] [node [B Nothing]]), - - testCase "parses with spaces between properties" $ - parseOrFail "(;SZ[1] AB[aa])" (@?= root 1 1 [AB $ coords [(0,0)]] []), - - testCase "parses with spaces between a property's name and value" $ - parseOrFail "(;SZ [1])" (@?= root 1 1 [] []), - - testCase "parses with spaces between property values" $ - parseOrFail "(;SZ[2]AB[aa] [bb])" (@?= root 2 2 [AB $ coords [(0,0), (1,1)]] []), - - testCase "parses with spaces between many elements" $ - parseOrFail " ( ; SZ [4] ; AB [aa:ad] [bb] AW [cc] ; W [dd] ; B [] ) " - (@?= root 4 4 [] [node1 [AB $ coords' [(1,1)] [((0,0), (0,3))], - AW $ coords [(2,2)]] $ - node1 [W $ Just (3,3)] $ - node [B Nothing]]) - - -- TODO Test handling of whitespace between an unknown property name and - -- [value]. - ] - -passConversionTests = testGroup "B[tt]/W[tt] pass conversion" [ - testCase "converts B[tt] for a board sizes <=19x19" $ do - parseOrFail "(;SZ[1];B[tt])" (@?= root 1 1 [] [node [B Nothing]]) - parseOrFail "(;SZ[9];B[tt])" (@?= root 9 9 [] [node [B Nothing]]) - parseOrFail "(;SZ[19];B[tt])" (@?= root 19 19 [] [node [B Nothing]]), - - testCase "converts W[tt] for a board sizes <=19x19" $ do - parseOrFail "(;SZ[1];W[tt])" (@?= root 1 1 [] [node [W Nothing]]) - parseOrFail "(;SZ[9];W[tt])" (@?= root 9 9 [] [node [W Nothing]]) - parseOrFail "(;SZ[19];W[tt])" (@?= root 19 19 [] [node [W Nothing]]), - - testCase "doesn't convert B[tt] for a board sizes >19x19" $ do - parseOrFail "(;SZ[20];B[tt])" (@?= root 20 20 [] [node [B $ Just (19, 19)]]) - parseOrFail "(;SZ[21];B[tt])" (@?= root 21 21 [] [node [B $ Just (19, 19)]]), - - testCase "doesn't convert W[tt] for a board sizes >19x19" $ do - parseOrFail "(;SZ[20];W[tt])" (@?= root 20 20 [] [node [W $ Just (19, 19)]]) - parseOrFail "(;SZ[21];W[tt])" (@?= root 21 21 [] [node [W $ Just (19, 19)]]), - - testCase "doesn't convert non-move properties" $ do - -- TODO These should error, rather than parsing fine. - parseOrFail "(;SZ[9];AB[tt])" (@?= root 9 9 [] [node [AB $ coords [(19, 19)]]]) - parseOrFail "(;SZ[9];TR[tt])" (@?= root 9 9 [] [node [TR $ coords [(19, 19)]]]) - ] - -movePropertyTests = testGroup "move properties" [ - testGroup "B" [ - testCase "parses moves" $ do - parseOrFail "(;B[aa])" (@?= node [B $ Just (0, 0)]) - parseOrFail "(;B[cp])" (@?= node [B $ Just (2, 15)]), - testCase "parses passes" $ - parseOrFail "(;B[])" (@?= node [B Nothing]) - ], - testCase "KO parses" $ - parseOrFail "(;KO[])" (@?= node [KO]), - -- TODO Test MN (assert positive). - testGroup "W" [ - testCase "parses moves" $ do - parseOrFail "(;W[aa])" (@?= node [W $ Just (0, 0)]) - parseOrFail "(;W[cp])" (@?= node [W $ Just (2, 15)]), - testCase "parses passes" $ - parseOrFail "(;W[])" (@?= node [W Nothing]) - ] - ] - -setupPropertyTests = testGroup "setup properties" [ - testCase "AB parses" $ do - parseOrFail "(;AB[ab])" (@?= node [AB $ coords [(0, 1)]]) - parseOrFail "(;AB[ab][cd:ef])" (@?= node [AB $ coords' [(0, 1)] [((2, 3), (4, 5))]]), - testCase "AE parses" $ do - parseOrFail "(;AE[ae])" (@?= node [AE $ coords [(0, 4)]]) - parseOrFail "(;AE[ae][ff:gg])" (@?= node [AE $ coords' [(0, 4)] [((5, 5), (6, 6))]]), - testCase "AW parses" $ do - parseOrFail "(;AW[aw])" (@?= node [AW $ coords [(0, 22)]]) - parseOrFail "(;AW[aw][xy:yz])" (@?= node [AW $ coords' [(0, 22)] [((23, 24), (24, 25))]]), - testCase "PL parses" $ do - parseOrFail "(;PL[B])" (@?= node [PL Black]) - parseOrFail "(;PL[W])" (@?= node [PL White]) - ] - -nodeAnnotationPropertyTests = testGroup "node annotation properties" [ - testCase "C parses" $ - parseOrFail "(;C[Me [30k\\]: What is White doing??\\\n\n:(])" - (@?= node [C $ toText "Me [30k]: What is White doing??\n:("]), - testCase "DM parses" $ do - parseOrFail "(;DM[1])" (@?= node [DM Double1]) - parseOrFail "(;DM[2])" (@?= node [DM Double2]), - testCase "GB parses" $ do - parseOrFail "(;GB[1])" (@?= node [GB Double1]) - parseOrFail "(;GB[2])" (@?= node [GB Double2]), - testCase "GW parses" $ do - parseOrFail "(;GW[1])" (@?= node [GW Double1]) - parseOrFail "(;GW[2])" (@?= node [GW Double2]), - testCase "HO parses" $ do - parseOrFail "(;HO[1])" (@?= node [HO Double1]) - parseOrFail "(;HO[2])" (@?= node [HO Double2]), - testCase "N parses" $ - parseOrFail "(;N[The best\\\n\nmove])" (@?= node [N $ toSimpleText "The best move"]), - testCase "UC parses" $ do - parseOrFail "(;UC[1])" (@?= node [UC Double1]) - parseOrFail "(;UC[2])" (@?= node [UC Double2]), - testCase "V parses" $ do - parseOrFail "(;V[-34.5])" (@?= node [V (-34.5)]) - parseOrFail "(;V[50])" (@?= node [V 50]) - ] - -moveAnnotationPropertyTests = testGroup "move annotation properties" [ - testCase "BM parses" $ do - parseOrFail "(;BM[1])" (@?= node [BM Double1]) - parseOrFail "(;BM[2])" (@?= node [BM Double2]), - testCase "DO parses" $ - parseOrFail "(;DO[])" (@?= node [DO]), - testCase "IT parses" $ - parseOrFail "(;IT[])" (@?= node [IT]), - testCase "TE parses" $ do - parseOrFail "(;TE[1])" (@?= node [TE Double1]) - parseOrFail "(;TE[2])" (@?= node [TE Double2]) - ] - --- TODO Test markup properties. - -rootPropertyTests = testGroup "root properties" [ - testCase "AP parses" $ - parseOrFail "(;AP[GoGoGo:1.2.3])" - (@?= node [AP (toSimpleText "GoGoGo") (toSimpleText "1.2.3")]), - testCase "CA parses" $ do - parseOrFail "(;CA[UTF-8])" (@?= node [CA $ toSimpleText "UTF-8"]) - parseOrFail "(;CA[ISO-8859-1])" (@?= node [CA $ toSimpleText "ISO-8859-1"]), - testGroup "FF" [ - testCase "accepts version 4" $ - parseOrFail "(;FF[4])" (@?= node [FF 4]), - testCase "rejects versions 1-3" $ do - parseAndFail "(;FF[1])" - parseAndFail "(;FF[2])" - parseAndFail "(;FF[3])" - ], - testGroup "GM" [ - testCase "parses 1 (Go)" $ - parseOrFail "(;GM[1])" (@?= node [GM 1]), - testCase "rejects unsupported games" $ - forM_ [2..16] $ \x -> parseAndFail $ "(;GM[" ++ show x ++ "]" - ], - testGroup "ST" [ - testCase "parses valid variation modes" $ do - parseOrFail "(;ST[0])" (@?= node [ST $ VariationMode ShowChildVariations True]) - parseOrFail "(;ST[1])" (@?= node [ST $ VariationMode ShowCurrentVariations True]) - parseOrFail "(;ST[2])" (@?= node [ST $ VariationMode ShowChildVariations False]) - parseOrFail "(;ST[3])" (@?= node [ST $ VariationMode ShowCurrentVariations False]), - testCase "rejects invalid variation modes" $ - forM_ [4..10] $ \x -> parseAndFail $ "(;ST[" ++ show x ++ "]" - ], - testGroup "SZ" [ - testCase "parses square boards" $ - forM_ [1..52] $ \x -> - parseOrFail ("(;SZ[" ++ show x ++ "])") (@?= node [SZ x x]), - testCase "parses nonsquare boards" $ do - parseOrFail "(;SZ[1:2])" (@?= node [SZ 1 2]) - parseOrFail "(;SZ[1:9])" (@?= node [SZ 1 9]) - parseOrFail "(;SZ[1:19])" (@?= node [SZ 1 19]) - parseOrFail "(;SZ[2:1])" (@?= node [SZ 2 1]) - parseOrFail "(;SZ[9:1])" (@?= node [SZ 9 1]) - parseOrFail "(;SZ[19:1])" (@?= node [SZ 19 1]) - parseOrFail "(;SZ[19:52])" (@?= node [SZ 19 52]) - parseOrFail "(;SZ[10:16])" (@?= node [SZ 10 16]), - testCase "rejects invalid sizes" $ do - -- Boards must have length at least 1... - parseAndFail "(;SZ[0])" - parseAndFail "(;SZ[-1])" - -- ...and at most 52. - parseAndFail "(;SZ[53])" - parseAndFail "(;SZ[54])" - parseAndFail "(;SZ[0:19])" - parseAndFail "(;SZ[19:0])" - parseAndFail "(;SZ[9:53])" - parseAndFail "(;SZ[53:9])", - -- This is specified by the SGF spec: - testCase "rejects square boards defined with two numbers" $ do - parseAndFail "(;SZ[1:1])" - parseAndFail "(;SZ[19:19])" - ] - ] - --- TODO Test the test of the properties. diff --git a/tests/Game/Goatee/Sgf/ParserTestUtils.hs b/tests/Game/Goatee/Sgf/ParserTestUtils.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/ParserTestUtils.hs +++ /dev/null @@ -1,63 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.ParserTestUtils ( - parseOrFail, - parseAndFail, - assertParse, - assertNoParse, - ) where - -import Control.Applicative ((<*)) -import Game.Goatee.Sgf.Parser -import Game.Goatee.Sgf.Tree -import Test.HUnit (assertFailure) -import Text.ParserCombinators.Parsec (Parser, eof, parse) - --- Parses a string as a complete SGF document. On success, executes the --- continuation function with the result. Otherwise, causes an assertion --- failure. -parseOrFail :: String -> (Node -> IO ()) -> IO () -parseOrFail input cont = case parseString input of - Left error -> assertFailure $ "Failed to parse SGF: " ++ error - Right (Collection roots) -> case roots of - root:[] -> cont root - _ -> assertFailure $ "Expected a single root node, got: " ++ show roots - --- Parses a string as a complete SGF document and expects failure. -parseAndFail :: String -> IO () -parseAndFail input = case parseString input of - Left _ -> return () - Right result -> assertFailure $ "Expected " ++ show input ++ - " not to parse. Parsed to " ++ show result ++ "." - --- Parses a string using the given parser and expects the parser to consume the --- entire input. On success, executes the continuation function with the --- result. Otherwise, causes an assertion failure. -assertParse :: Parser a -> String -> (a -> IO ()) -> IO () -assertParse parser input cont = case parse (parser <* eof) "" input of - Left error -> assertFailure $ "Failed to parse: " ++ show error - Right result -> cont result - --- Tries to parse a string using the given parser. If the parse succeeds then --- this function causes an assertion failure, otherwise this function succeeds. -assertNoParse :: Show a => Parser a -> String -> IO () -assertNoParse parser input = case parse (parser <* eof) "" input of - Left _ -> return () - Right result -> assertFailure $ - "Expected " ++ show input ++ " not to parse. " ++ - "Parsed to " ++ show result ++ "." diff --git a/tests/Game/Goatee/Sgf/Property/ParserTest.hs b/tests/Game/Goatee/Sgf/Property/ParserTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/Property/ParserTest.hs +++ /dev/null @@ -1,391 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.Property.ParserTest (tests) where - -import Control.Applicative ((<$>)) -import Control.Monad (forM_) -import Data.Maybe (catMaybes) -import Game.Goatee.Common -import Game.Goatee.Sgf.ParserTestUtils -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Property.Parser -import Game.Goatee.Sgf.TestInstances () -import Game.Goatee.Sgf.TestUtils -import Game.Goatee.Sgf.Types -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@?=)) -import Text.ParserCombinators.Parsec (Parser) - -tests = testGroup "Game.Goatee.Sgf.Property.ParserTest" [ - -- Tests for public parsers. - parserColorTests, - parserDoubleTests, - parserGameResultTests, - parserIntegralTests, - parserMoveTests, - parserRealTests, - parserRulesetTests, - parserSizeTests, - parserVariationModeTests, - -- Tests for private parsers. - lineTests, - simpleTextTests, - simpleTextComposedTests, - textTests, - textComposedTests, - -- Miscellaneous tests. - propertyValueArityTests - ] - -parserColorTests = testGroup "colorParser" [ - testCase "parses B" $ assertParse colorParser "[B]" (@?= Black), - testCase "parses W" $ assertParse colorParser "[W]" (@?= White) - ] - -parserDoubleTests = testGroup "doubleParser" [ - testCase "parses 1" $ assertParse doubleParser "[1]" (@?= Double1), - testCase "parses 2" $ assertParse doubleParser "[2]" (@?= Double2) - ] - -parserGameResultTests = testGroup "gameResultParser" [ - testCase "draw" $ do - assertParse gameResultParser "[0]" (@?= GameResultDraw) - assertParse gameResultParser "[Draw]" (@?= GameResultDraw), - - testCase "void" $ - assertParse gameResultParser "[Void]" (@?= GameResultVoid), - - testCase "unknown" $ - assertParse gameResultParser "[?]" (@?= GameResultUnknown), - - testCase "Black wins by points" $ do - assertParse gameResultParser "[B+0.5]" (@?= GameResultWin Black (WinByScore 0.5)) - assertParse gameResultParser "[B+11]" (@?= GameResultWin Black (WinByScore 11)) - assertParse gameResultParser "[B+354.5]" (@?= GameResultWin Black (WinByScore 354.5)), - - testCase "Black wins by resignation" $ do - assertParse gameResultParser "[B+R]" (@?= GameResultWin Black WinByResignation) - assertParse gameResultParser "[B+Resign]" (@?= GameResultWin Black WinByResignation), - - testCase "Black wins on time" $ do - assertParse gameResultParser "[B+T]" (@?= GameResultWin Black WinByTime) - assertParse gameResultParser "[B+Time]" (@?= GameResultWin Black WinByTime), - - testCase "Black wins by forfeit" $ do - assertParse gameResultParser "[B+F]" (@?= GameResultWin Black WinByForfeit) - assertParse gameResultParser "[B+Forfeit]" (@?= GameResultWin Black WinByForfeit), - - testCase "White wins by points" $ do - assertParse gameResultParser "[W+0.5]" (@?= GameResultWin White (WinByScore 0.5)) - assertParse gameResultParser "[W+11]" (@?= GameResultWin White (WinByScore 11)) - assertParse gameResultParser "[W+354.5]" (@?= GameResultWin White (WinByScore 354.5)), - - testCase "White wins by resignation" $ do - assertParse gameResultParser "[W+R]" (@?= GameResultWin White WinByResignation) - assertParse gameResultParser "[W+Resign]" (@?= GameResultWin White WinByResignation), - - testCase "White wins on time" $ do - assertParse gameResultParser "[W+T]" (@?= GameResultWin White WinByTime) - assertParse gameResultParser "[W+Time]" (@?= GameResultWin White WinByTime), - - testCase "White wins by forfeit" $ do - assertParse gameResultParser "[W+F]" (@?= GameResultWin White WinByForfeit) - assertParse gameResultParser "[W+Forfeit]" (@?= GameResultWin White WinByForfeit), - - testCase "custom game results" $ do - assertParseToOther "" - assertParseToOther "Everyone wins." - assertParseToOther "W+Nuclear tesuji" - assertParseToOther "B+Flamingo" - ] - where assertParseToOther input = - assertParse gameResultParser ('[' : input ++ "]") - (@?= GameResultOther (toSimpleText input)) - -parserIntegralTests = testGroup "integralParser" $ integerTestsFor integralParser - -parserMoveTests = testGroup "moveParser" $ coordTestsFor moveParser Just ++ [ - testCase "parses an empty move as a pass" $ assertParse moveParser "[]" (@?= Nothing) - ] - -parserRealTests = testGroup "realParser" $ integerTestsFor realParser ++ [ - testCase "parses a decimal zero" $ assertParse realParser "[0.0]" (@?= 0), - - testCase "parses fractional positive numbers" $ do - assertParse realParser "[0.5]" (@?= (1/2)) - assertParse realParser "[0.00125]" (@?= (1/800)) - assertParse realParser "[3.14]" (@?= (314/100)) - assertParse realParser "[10.0]" (@?= 10), - - testCase "parses fractional negative numbers" $ do - assertParse realParser "[-0.5]" (@?= (-1/2)) - assertParse realParser "[-0.00125]" (@?= (-1/800)) - assertParse realParser "[-3.14]" (@?= (-314/100)) - assertParse realParser "[-10.0]" (@?= (-10)) - ] - -parserRulesetTests = testGroup "rulesetParser" [ - testCase "parses known rules" $ do - assertParse rulesetParser "[AGA]" (@?= KnownRuleset RulesetAga) - assertParse rulesetParser "[Goe]" (@?= KnownRuleset RulesetIng) - assertParse rulesetParser "[Japanese]" (@?= KnownRuleset RulesetJapanese) - assertParse rulesetParser "[NZ]" (@?= KnownRuleset RulesetNewZealand), - - testCase "parses unknown rules" $ do - assertParse rulesetParser "[Foo]" (@?= UnknownRuleset "Foo") - assertParse rulesetParser "[First capture]" (@?= UnknownRuleset "First capture") - ] - -parserSizeTests = testGroup "size" [ - testCase "parses square boards" $ do - assertParse sizeParser "[1]" (@?= (1, 1)) - assertParse sizeParser "[4]" (@?= (4, 4)) - assertParse sizeParser "[9]" (@?= (9, 9)) - assertParse sizeParser "[19]" (@?= (19, 19)) - assertParse sizeParser "[52]" (@?= (52, 52)), - - testCase "parses rectangular boards" $ do - assertParse sizeParser "[1:2]" (@?= (1, 2)) - assertParse sizeParser "[9:5]" (@?= (9, 5)) - assertParse sizeParser "[19:9]" (@?= (19, 9)), - - testCase "rejects boards of non-positive size" $ do - assertNoParse sizeParser "[0]" - assertNoParse sizeParser "[-1]" - assertNoParse sizeParser "[0:5]" - assertNoParse sizeParser "[5:0]" - assertNoParse sizeParser "[0:-2]", - - testCase "rejects square boards given in rectangular format" $ do - assertNoParse sizeParser "[1:1]" - assertNoParse sizeParser "[13:13]" - ] - -parserVariationModeTests = testGroup "variationModeParser" [ - testCase "mode 0" $ - assertParse variationModeParser "[0]" (@?= VariationMode ShowChildVariations True), - - testCase "mode 1" $ - assertParse variationModeParser "[1]" (@?= VariationMode ShowCurrentVariations True), - - testCase "mode 2" $ - assertParse variationModeParser "[2]" (@?= VariationMode ShowChildVariations False), - - testCase "mode 3" $ - assertParse variationModeParser "[3]" (@?= VariationMode ShowCurrentVariations False) - ] - -lineTests = testGroup "line" [ - testCase "parses all valid values" $ do - let cases = zip (['a'..'z'] ++ ['A'..'Z']) [0..] - forM_ cases $ \(char, expected) -> - assertParse line [char] (@?= expected) - ] - -simpleTextTests = testGroup "simpleText" $ - textTestsFor simpleText fromSimpleText False ++ - textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText False) - -simpleTextComposedTests = testGroup "simpleText composed" $ - textTestsFor simpleText fromSimpleText True ++ - textUnescapedNewlineConvertingTests (fromSimpleText <$> simpleText True) - -textTests = testGroup "text" $ - textTestsFor text id False ++ - textUnescapedNewlinePreservingTests (text False) - -textComposedTests = testGroup "text composed" $ - textTestsFor text id True ++ - textUnescapedNewlinePreservingTests (text True) - -propertyValueArityTests = testGroup "property value arities" [ - testGroup "single values (single)" [ - testCase "accepts a property that requires a single number" $ - parseOrFail "(;SZ[1])" (@?= node [SZ 1 1]), - - testCase "accepts a property that requires a single point" $ - parseOrFail "(;B[dd])" (@?= node [B $ Just (3, 3)]) - ], - - testGroup "lists (listOf)" [ - testCase "doesn't accept an empty list" $ - parseAndFail "(;AR[])", - - testCase "accepts a single value" $ - parseOrFail "(;AR[aa:bb])" (@?= node [AR [((0, 0), (1, 1))]]), - - testCase "accepts two values" $ - parseOrFail "(;AR[aa:bb][cc:de])" (@?= node [AR [((0, 0), (1, 1)), - ((2, 2), (3, 4))]]) - ], - - testGroup "point lists (listOfPoint)" [ - testCase "doesn't accept an empty list" $ - parseAndFail "(;AB[])", - - testCase "accepts a single point" $ - parseOrFail "(;AB[aa])" (@?= node [AB $ coords [(0, 0)]]), - - testCase "accepts two points" $ - parseOrFail "(;AB[aa][bb])" (@?= node [AB $ coords [(0, 0), (1, 1)]]), - - testCase "accepts a rectangle" $ - parseOrFail "(;AB[aa:bb])" (@?= node [AB $ coords' [] [((0, 0), (1, 1))]]), - - testCase "accepts two rectangles" $ - parseOrFail "(;AB[aa:bb][cd:de])" (@?= node [AB $ coords' [] [((0, 0), (1, 1)), - ((2, 3), (3, 4))]]) - ], - - testGroup "point elists (elistOfPoint)" [ - testCase "accepts an empty list" $ - parseOrFail "(;VW[])" (@?= node [VW $ coords []]), - - testCase "accepts single points" $ - parseOrFail "(;VW[aa][bb])" (@?= node [VW $ coords [(0, 0), (1, 1)]]), - - testCase "accepts a rectangle" $ - parseOrFail "(;VW[aa:bb])" (@?= node [VW $ coords' [] [((0, 0), (1, 1))]]), - - testCase "accepts two rectangles" $ - parseOrFail "(;VW[aa:bb][cc:dd])" (@?= node [VW $ coords' [] [((0, 0), (1, 1)), - ((2, 2), (3, 3))]]) - ] - - -- TODO Test that invalid rectangles such as cd:dc fail to parse (or rather, - -- get corrected with a warning). - ] - -integerTestsFor :: (Eq a, Num a, Show a) => Parser a -> [Test] -integerTestsFor parser = [ - testCase "parses 0" $ do - assertParse parser "[0]" (@?= 0) - assertParse parser "[+0]" (@?= 0) - assertParse parser "[-0]" (@?= 0), - - testCase "parses positive integers" $ do - assertParse parser "[1]" (@?= 1) - assertParse parser "[20]" (@?= 20) - assertParse parser "[4294967296]" (@?= (2 ^ 32)) - assertParse parser "[18446744073709551616]" (@?= (2 ^ 64)), - - testCase "parses positive integers with the plus sign" $ do - assertParse parser "[+1]" (@?= 1) - assertParse parser "[+20]" (@?= 20) - assertParse parser "[+4294967296]" (@?= (2 ^ 32)) - assertParse parser "[+18446744073709551616]" (@?= (2 ^ 64)), - - testCase "parses negative integers" $ do - assertParse parser "[-1]" (@?= (-1)) - assertParse parser "[-20]" (@?= (-20)) - assertParse parser "[-4294967296]" (@?= (- (2 ^ 32))) - assertParse parser "[-18446744073709551616]" (@?= (- (2 ^ 64))) - ] - -coordTestsFor :: (Eq a, Show a) => Parser a -> (Coord -> a) -> [Test] -coordTestsFor parser f = [ - testCase "parses boundary points" $ do - assertParse parser "[aa]" (@?= f (0, 0)) - assertParse parser "[zz]" (@?= f (25, 25)) - assertParse parser "[AA]" (@?= f (26, 26)) - assertParse parser "[ZZ]" (@?= f (51, 51)), - - testCase "parses coordinate order correctly" $ do - assertParse parser "[ab]" (@?= f (0, 1)) - assertParse parser "[ba]" (@?= f (1, 0)), - - testCase "doesn't parse a partial point" $ - assertNoParse parser "[a]" - ] - -textTestsFor :: (Bool -> Parser a) -> (a -> String) -> Bool -> [Test] -textTestsFor makeParser toString testComposed = - let rawParser = makeParser testComposed - parser = toString <$> rawParser - composedParser = mapTuple toString <$> compose rawParser rawParser - in catMaybes [ - Just $ testCase "parses an empty string" $ - assertParse parser "" (@?= ""), - - Just $ testCase "parses a short string" $ - assertParse parser "Hello, world." (@?= "Hello, world."), - - Just $ testCase "preserves leading and trailing whitespace" $ - assertParse parser " \tHi. \t" (@?= " Hi. "), - - Just $ testCase "parses escaped backslashes" $ do - assertParse parser "\\\\" (@?= "\\") - assertParse parser "\\\\\\\\" (@?= "\\\\") - assertNoParse parser "\\" - assertNoParse parser "\\\\\\", - - Just $ testCase "parses escaped ']'s" $ do - assertParse parser "\\]" (@?= "]") - assertParse parser "\\]\\\\\\]" (@?= "]\\]"), - - Just $ if testComposed - then testCase "parses escaped ':'s" $ do - assertParse parser "\\:" (@?= ":") - assertParse parser "\\:\\\\\\:" (@?= ":\\:") - assertNoParse parser ":" - else testCase "parses unescaped ':'s" $ do - assertParse parser ":" (@?= ":") - assertParse parser "::" (@?= "::") - -- An escaped colon should parse just the same. - assertParse parser "\\:" (@?= ":"), - - if not testComposed - then Nothing - else Just $ testCase "supports composed values" $ do - assertParse composedParser ":" (@?= ("", "")) - assertParse composedParser "a:" (@?= ("a", "")) - assertParse composedParser ":z" (@?= ("", "z")) - assertParse composedParser "a:z" (@?= ("a", "z")) - assertParse composedParser "a\\\\:z" (@?= ("a\\", "z")) - assertParse composedParser "a\\:b:y\\:z" (@?= ("a:b", "y:z")) - assertNoParse composedParser "", - - -- Tests non-newline whitespace replacement. Newline handling is - -- specific to individual parsers. - Just $ testCase "replaces whitespace with spaces" $ - assertParse parser "\t\r\f\v" (@?= " "), - - Just $ testCase "removes escaped newlines" $ do - assertParse parser "\\\n" (@?= "") - assertParse parser "foo\\\nbar" (@?= "foobar") - assertParse parser "foo \\\n bar" (@?= "foo bar") - ] - -textUnescapedNewlinePreservingTests :: Parser String -> [Test] -textUnescapedNewlinePreservingTests parser = [ - testCase "preserves unescaped newlines" $ do - assertParse parser "\n" (@?= "\n") - assertParse parser "\n\n" (@?= "\n\n") - assertParse parser "foo\nbar" (@?= "foo\nbar") - assertParse parser "foo \n bar" (@?= "foo \n bar") - ] - -textUnescapedNewlineConvertingTests :: Parser String -> [Test] -textUnescapedNewlineConvertingTests parser = [ - testCase "converts unescaped newlines to spaces" $ do - assertParse parser "\n" (@?= " ") - assertParse parser "\n\n" (@?= " ") - assertParse parser "foo\nbar" (@?= "foo bar") - assertParse parser "foo \n bar" (@?= "foo bar") - ] diff --git a/tests/Game/Goatee/Sgf/PropertyTest.hs b/tests/Game/Goatee/Sgf/PropertyTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/PropertyTest.hs +++ /dev/null @@ -1,74 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.PropertyTest (tests) where - -import qualified Data.Set as Set -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Types -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - -tests = testGroup "Game.Goatee.Sgf.Property" [ - propertyMetadataTests, - markPropertyTests - ] - -propertyMetadataTests = testGroup "property metadata" [ - testCase "game info properties" $ gameInfoProperties @=? filterTo GameInfoProperty allProperties, - testCase "general properties" $ generalProperties @=? filterTo GeneralProperty allProperties, - testCase "move properties" $ moveProperties @=? filterTo MoveProperty allProperties, - testCase "root properties" $ rootProperties @=? filterTo RootProperty allProperties, - testCase "setup properties" $ setupProperties @=? filterTo SetupProperty allProperties, - - testCase "inherited properties" $ [DD cl] @=? filter propertyInherited allProperties - ] - where filterTo propType = filter ((propType ==) . propertyType) - moveProperties = [-- Move properties. - B Nothing, KO, MN 1, W Nothing, - -- Move annotation properties. - BM db, DO, IT, TE db] - setupProperties = [-- Setup properties. - AB cl, AE cl, AW cl, PL Black] - generalProperties = [-- Node annotation properties. - C tx, DM db, GB db, GW db, HO db, N st, UC db, V rv, - -- Markup properties. - AR [], CR cl, DD cl, LB [], LN [], MA cl, SL cl, SQ cl, TR cl, - -- Guess this fits here. - UnknownProperty "" (toUnknownPropertyValue "")] - rootProperties = [-- Root properties. - AP st st, CA st, FF 1, GM 1, ST vm, SZ 1 1] - gameInfoProperties = [-- Game info properties. - AN st, BR st, BT st, CP st, DT st, EV st, GC st, GN st, ON st, OT st, - PB st, PC st, PW st, RE GameResultVoid, RO st, RU ru, - SO st, TM rv, US st, WR st, WT st] - allProperties = moveProperties ++ setupProperties ++ generalProperties ++ - rootProperties ++ gameInfoProperties - cl = emptyCoordList - db = Double1 - tx = toText "" - st = toSimpleText "" - ru = KnownRuleset RulesetJapanese - rv = 1 - vm = defaultVariationMode - -markPropertyTests = testGroup "markProperty" [ - testCase "doesn't repeat properties" $ - let marks = [minBound..maxBound] - in length marks @=? Set.size (Set.fromList $ map (propertyName . markProperty) marks) - ] diff --git a/tests/Game/Goatee/Sgf/RoundTripTest.hs b/tests/Game/Goatee/Sgf/RoundTripTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/RoundTripTest.hs +++ /dev/null @@ -1,85 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.RoundTripTest (tests) where - -import Data.Function (on) -import Game.Goatee.Common -import Game.Goatee.Sgf.Parser -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Renderer -import Game.Goatee.Sgf.Renderer.Tree -import Game.Goatee.Sgf.TestUtils -import Game.Goatee.Sgf.Tree -import Game.Goatee.Sgf.Types -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@?=), Assertion, assertFailure) - -testCollection' :: Collection -> Assertion -testCollection' collection = - case runRender $ renderCollection collection of - Left message -> assertFailure $ "Failed to render: " ++ message - Right serialized -> - case parseString serialized of - Left error -> assertFailure $ "Failed to parse: " ++ error ++ - "\n\nEntire SGF: " ++ serialized - Right collection' -> do - on (@?=) CollectionWithDeepEquality collection' collection - case runRender $ renderCollection collection' of - Left message -> assertFailure $ "Second render failed: " ++ message - Right serializedAgain -> serializedAgain @?= serialized - --- | Returns an assertion that the given node round-trips okay. -testNode' :: Node -> Assertion -testNode' = testCollection' . Collection . (:[]) - --- | Returns a test with the given string name that round-trips a single node. -testNode :: String -> Node -> Test -testNode label node = testCase label $ testNode' node - -tests = testGroup "Game.Goatee.Sgf.RoundTripTest" [ - singleNodeGameTests, - propertyValueTests - ] - -singleNodeGameTests = testGroup "games with single nodes" [ - testNode "empty game" $ node [], - testNode "some default properties" $ node [FF 4, GM 1, ST defaultVariationMode] - ] - -propertyValueTests = testGroup "property value types" [ - testGroup "label list values" [ - testNode "one value" $ node [LB [((5,2), toSimpleText "Hi.")]], - testNode "multiple value" $ node [LB [((5, 2), toSimpleText "Hi."), - ((0, 1), toSimpleText "Bye.")]] - ], - - testGroup "point-valued values" $ - for [0..boardSizeMax-1] - (\row -> testNode ("row " ++ show row) $ node [B $ Just (0, row)]) ++ - for [0..boardSizeMax-1] - (\col -> testNode ("row " ++ show col) $ node [B $ Just (col, 0)]), - - testGroup "real values" [ - testNode "1500" $ node [TM 1500], - testNode "60.5" $ node [TM 60.5], - testNode "10.1" $ node [TM 10.1] - ] - ] - --- TODO Many more round-trip tests. diff --git a/tests/Game/Goatee/Sgf/TestInstances.hs b/tests/Game/Goatee/Sgf/TestInstances.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/TestInstances.hs +++ /dev/null @@ -1,25 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | Test utilities for working with the SGF modules. -module Game.Goatee.Sgf.TestInstances () where - -import Data.Function (on) -import Game.Goatee.Sgf.Tree (Node, NodeWithDeepEquality(NodeWithDeepEquality)) - -instance Eq Node where - (==) = (==) `on` NodeWithDeepEquality diff --git a/tests/Game/Goatee/Sgf/TestUtils.hs b/tests/Game/Goatee/Sgf/TestUtils.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/TestUtils.hs +++ /dev/null @@ -1,61 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - --- | Test utilities for working with the SGF modules. -module Game.Goatee.Sgf.TestUtils ( - node, - node1, - node', - root, - child, - sortProperties, - ) where - -import Data.Function (on) -import Data.List (sortBy) -import Game.Goatee.Sgf.Board -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.Tree - -node :: [Property] -> Node -node props = emptyNode { nodeProperties = props } - -node1 :: [Property] -> Node -> Node -node1 props child = emptyNode { nodeProperties = props - , nodeChildren = [child] - } - -node' :: [Property] -> [Node] -> Node -node' props children = emptyNode { nodeProperties = props - , nodeChildren = children - } - --- | Creates a root node that starts with only a 'SZ' property. This is more --- minimal than 'rootNode'. -root :: Int -> Int -> [Property] -> [Node] -> Node -root width height props = - foldr addChild $ foldr addProperty emptyNode (SZ width height:props) - -child :: Int -> Cursor -> Cursor -child = flip cursorChild - --- | Sorts properties by their 'Show' strings, for use in tests that need to --- check an unordered list of properties. --- --- TODO Probably better to have a compare-unordered operator. -sortProperties :: [Property] -> [Property] -sortProperties = sortBy (compare `on` show) diff --git a/tests/Game/Goatee/Sgf/TreeTest.hs b/tests/Game/Goatee/Sgf/TreeTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/TreeTest.hs +++ /dev/null @@ -1,114 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.TreeTest (tests) where - -import Data.Version (showVersion) -import Game.Goatee.App (applicationName) -import Game.Goatee.Sgf.Property -import Game.Goatee.Sgf.TestInstances () -import Game.Goatee.Sgf.Tree -import Game.Goatee.Sgf.Types -import Game.Goatee.Test.Common -import Paths_goatee (version) -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?), (@?=)) - -tests = testGroup "Game.Goatee.Sgf.Tree" [ - emptyNodeTests, - rootNodeTests, - findPropertyTests, - addPropertyTests, - addChildTests - ] - -emptyNodeTests = testGroup "emptyNode" [ - testCase "has no properties" $ [] @=? nodeProperties emptyNode, - testCase "has no children" $ [] @=? nodeChildren emptyNode - ] - -rootNodeTests = testGroup "rootNode" [ - testCase "sets SZ correctly" $ do - assertElem (SZ 9 9) $ nodeProperties $ rootNode $ Just (9, 9) - assertElem (SZ 19 19) $ nodeProperties $ rootNode $ Just (19, 19) - assertElem (SZ 9 5) $ nodeProperties $ rootNode $ Just (9, 5), - - testCase "sets AP correctly" $ do - let ap = AP (toSimpleText applicationName) - (toSimpleText $ showVersion version) - assertElem ap $ nodeProperties $ rootNode Nothing - assertElem ap $ nodeProperties $ rootNode $ Just (9, 9) - ] - -findPropertyTests = testGroup "findProperty" [ - testCase "returns Nothing for an empty node" $ - Nothing @=? findProperty propertyB (mk []), - - testCase "returns Nothing if no properties match" $ - Nothing @=? findProperty propertyB (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9]), - - testCase "finds present properties" $ do - Just (B (Just (2,3))) @=? - findProperty propertyB (mk [B (Just (2,3))]) - Just (W Nothing) @=? - findProperty propertyW (mk [B Nothing, W Nothing]) - Just IT @=? - findProperty propertyIT (mk [IT, GW Double2]) - Just (GW Double2) @=? - findProperty propertyGW (mk [IT, GW Double2]), - - testCase "doesn't find absent properties" $ do - Nothing @=? findProperty propertyW (mk [B Nothing]) - Nothing @=? findProperty propertyW (mk [FF 4, GM 1, ST defaultVariationMode, SZ 9 9]) - ] - where mk properties = emptyNode { nodeProperties = properties } - -addPropertyTests = testGroup "addProperty" [ - testCase "adds properties in order" $ do - let prop1 = B (Just (6,6)) - prop2 = RE GameResultVoid - prop3 = C (toText "Game over.") - node1 = addProperty prop1 emptyNode - node2 = addProperty prop2 node1 - node3 = addProperty prop3 node2 - node1 @?= emptyNode { nodeProperties = [prop1] } - node2 @?= emptyNode { nodeProperties = [prop1, prop2] } - node3 @?= emptyNode { nodeProperties = [prop1, prop2, prop3] } - ] - -addChildTests = testGroup "addChild" [ - testCase "adds children in order" $ do - let node1 = emptyNode { nodeProperties = [B (Just (0,0))] } - node2 = emptyNode { nodeProperties = [W (Just (1,1))] } - node3 = emptyNode { nodeProperties = [B (Just (2,2))] } - node4 = emptyNode { nodeProperties = [W Nothing] } - node2' = addChild node3 node2 - node1' = addChild node2' node1 - node1'' = addChild node4 node1' - node1'' @?= mk [B (Just (0,0))] - [mk [W (Just (1,1))] - [mk [B (Just (2,2))] - []], - mk [W Nothing] - []] - ] - where mk properties children = emptyNode { nodeProperties = properties - , nodeChildren = children - } - --- TODO Test validateNode. diff --git a/tests/Game/Goatee/Sgf/TypesTest.hs b/tests/Game/Goatee/Sgf/TypesTest.hs deleted file mode 100644 --- a/tests/Game/Goatee/Sgf/TypesTest.hs +++ /dev/null @@ -1,146 +0,0 @@ --- This file is part of Goatee. --- --- Copyright 2014 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 . - -module Game.Goatee.Sgf.TypesTest (tests) where - -import Data.List (sort) -import Game.Goatee.Sgf.Types -import Game.Goatee.Test.Common -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?), Assertion) - -tests = testGroup "Game.Goatee.Sgf.Types" [ - expandCoordListTests, - buildCoordListTests, - simpleTextTests, - cnotTests - ] - -expandCoordListTests = testGroup "expandCoordList" [ - testCase "works with an empty CoordList" $ do - [] @=? expandCoordList (coords []) - [] @=? expandCoordList (coords' [] []), - - testCase "works for single points" $ do - [(1,2)] @=? expandCoordList (coord1 (1,2)) - [(3,4), (1,2)] @=? expandCoordList (coords [(3,4), (1,2)]) - let ten = [(i,i) | i <- [1..10]] - ten @=? expandCoordList (coords ten), - - -- TODO Test that a 1x1 rectangle is rejected. - - testCase "works for a nx1 rect" $ - [(5,2), (5,3), (5,4)] @=? expandCoordList (coords' [] [((5,2), (5,4))]), - - testCase "works for a 1xn rect" $ - [(1,0), (1,1), (1,2), (1,3)] @=? expandCoordList (coords' [] [((1,0), (1,3))]), - - testCase "works for an mxn rect" $ - [(m,n) | m <- [2..5], n <- [3..7]] @=? - expandCoordList (coords' [] [((2,3), (5,7))]), - - -- TODO Test that x0 > x1 || y0 > y1 is rejected. - - testCase "works with multiple rects" $ - [(0,0), (0,1), (0,2), (3,4), (4,4), (5,4)] @=? - expandCoordList (coords' [] [((0,0), (0,2)), ((3,4), (5,4))]), - - testCase "concatenates single points and rects" $ - [(1,1), (0,0), (2,2), (2,3), (2,4)] @=? - expandCoordList (coords' [(1,1), (0,0)] [((2,2), (2,4))]) - ] - -buildCoordListTests = testGroup "buildCoordList" [ - testCase "handles the empty case" $ assertSinglesAndRects [] [] [], - - testCase "handles one single" $ - assertSinglesAndRects [(0,1)] [] [(0,1)], - - testCase "handles multiple singles" $ - assertSinglesAndRects [(0,0), (1,1)] [] [(0,0), (1,1)], - - testCase "handles a small rect (1x2)" $ - assertSinglesAndRects [] [((0,1), (0,2))] [(0,1), (0,2)], - - testCase "handles a small square (2x2)" $ - assertSinglesAndRects [] [((1,1), (2,2))] [(x,y) | x <- [1..2], y <- [1..2]], - - testCase "handles a larger rect" $ - assertSinglesAndRects [] [((0,0), (2,4))] [(x,y) | x <- [0..2], y <- [0..4]], - - testCase "handles two rects" $ - assertSinglesAndRects [] [((0,1), (1,2)), ((3,0), (4,1))] - [(0,1), (1,1), (0,2), (1,2), (3,0), (4,0), (3,1), (4,1)], - - testCase "handles rects and singles together" $ - assertSinglesAndRects [(0,0)] [((1,1), (2,2))] - [(0,0), (1,1), (1,2), (2,1), (2,2)], - - testCase "handles five points together" $ do - assertCoords [(1,0), (0,1), (1,1), (0,2), (1,2)] - assertCoords [(0,0), (1,0), (0,1), (1,1), (0,2)] - assertCoords [(0,0), (1,0), (2,0), (0,1), (1,1)] - assertCoords [(1,0), (2,0), (0,1), (1,1), (2,1)], - - testCase "handles a more complex case" $ - assertCoords [(3,0), (4,0), - (3,1), (4,1), - (0,2), (1,2), (2,2), (3,2), (4,2), - (0,3), (1,3), - (0,4), (1,4), (3,4), (4,4)], - - testCase "handles a diagonal pattern" $ - assertCoords [(0,0), (2,0), (4,0), - (1,1), (3,1), (5,1), - (2,2)] - ] - where -- | Asserts that the given grid of booleans parses to a 'CoordList' - -- that has the expected single points (not necessarily in the same - -- order), as well as the expected rectangles (not necessarily in the - -- same order). - assertSinglesAndRects :: [Coord] -> [(Coord, Coord)] -> [Coord] -> Assertion - assertSinglesAndRects expectedSingles expectedRects input = - coords' expectedSingles expectedRects @=? buildCoordList input - - -- | Asserts that the set of points returned from applying - -- 'buildCoordList' to the given grid of booleans is equal to - -- the given set of points. - assertCoords :: [Coord] -> Assertion - assertCoords input = sort input @=? sort (expandCoordList $ buildCoordList input) - -simpleTextTests = testGroup "SimpleText" [ - testCase "accepts the empty string" $ - "" @=? fromSimpleText (toSimpleText ""), - - testCase "passes through strings without newlines" $ do - "Hello." @=? fromSimpleText (toSimpleText "Hello.") - "Bad for B." @=? fromSimpleText (toSimpleText "Bad for B.") - "[4k?]" @=? fromSimpleText (toSimpleText "[4k?]") - printableAsciiChars @=? fromSimpleText (toSimpleText printableAsciiChars), - - testCase "converts newlines to spaces" $ do - " " @=? fromSimpleText (toSimpleText "\n") - "Hello, world." @=? fromSimpleText (toSimpleText "Hello,\nworld.") - "Hello, world." @=? fromSimpleText (toSimpleText "Hello, \n world.") - " Hello, world. " @=? fromSimpleText (toSimpleText "\nHello, world.\n") - ] - -cnotTests = testGroup "cnot" [ - testCase "changes Black to White" $ White @=? cnot Black, - testCase "changes White to Black" $ Black @=? cnot White - ] diff --git a/tests/Game/Goatee/Test/Common.hs b/tests/Game/Goatee/Test/Common.hs --- a/tests/Game/Goatee/Test/Common.hs +++ b/tests/Game/Goatee/Test/Common.hs @@ -18,13 +18,18 @@ -- | Common utilities for testing code. module Game.Goatee.Test.Common ( (@/=?), + (@=?*), + (@?=*), assertElem, printableAsciiChars, ) where import Control.Monad (unless, when) -import Test.HUnit (Assertion, assertFailure) +import Data.List (sort) +import Test.HUnit ((@=?), (@?=), Assertion, assertFailure) +infix 1 @/=?, @=?*, @?=* + -- | Asserts that two values are not equal. Typically, the left argument is a -- constant value that the right, computed argument should not equal, to mirror -- '@=?'. @@ -37,6 +42,14 @@ then "did not expect: " ++ actual' else " this value: " ++ actual' ++ "\nshould not equal: " ++ notExpected' + +-- | Order-insensitive version of '@=?'. +(@=?*) :: (Eq a, Ord a, Show a) => [a] -> [a] -> Assertion +xs @=?* ys = sort xs @=? sort ys + +-- | Order-insensitive version of '@?='. +(@?=*) :: (Eq a, Ord a, Show a) => [a] -> [a] -> Assertion +xs @?=* ys = sort xs @?= sort ys assertElem :: (Eq a, Show a) => a -> [a] -> Assertion assertElem item list = diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -17,27 +17,36 @@ module Main (main) where +import qualified Game.Goatee.Common.BigfloatTest import qualified Game.Goatee.CommonTest -import qualified Game.Goatee.Sgf.BoardTest -import qualified Game.Goatee.Sgf.MonadTest -import qualified Game.Goatee.Sgf.ParserTest -import qualified Game.Goatee.Sgf.Property.ParserTest -import qualified Game.Goatee.Sgf.PropertyTest -import qualified Game.Goatee.Sgf.RoundTripTest -import qualified Game.Goatee.Sgf.TreeTest -import qualified Game.Goatee.Sgf.TypesTest -import Test.Framework (defaultMain) +import qualified Game.Goatee.Lib.BoardTest +import qualified Game.Goatee.Lib.MonadTest +import qualified Game.Goatee.Lib.ParserTest +import qualified Game.Goatee.Lib.Property.ParserTest +import qualified Game.Goatee.Lib.PropertyTest +import qualified Game.Goatee.Lib.RoundTripTest +import qualified Game.Goatee.Lib.TreeTest +import qualified Game.Goatee.Lib.TypesTest +import System.Exit (exitFailure, exitSuccess) +import Test.HUnit (Counts (errors, failures), Test (TestList), runTestTT) -tests = [ Game.Goatee.CommonTest.tests - , Game.Goatee.Sgf.BoardTest.tests - , Game.Goatee.Sgf.MonadTest.tests - , Game.Goatee.Sgf.ParserTest.tests - , Game.Goatee.Sgf.Property.ParserTest.tests - , Game.Goatee.Sgf.PropertyTest.tests - , Game.Goatee.Sgf.RoundTripTest.tests - , Game.Goatee.Sgf.TreeTest.tests - , Game.Goatee.Sgf.TypesTest.tests - ] +tests :: Test +tests = TestList + [ Game.Goatee.Common.BigfloatTest.tests + , Game.Goatee.CommonTest.tests + , Game.Goatee.Lib.BoardTest.tests + , Game.Goatee.Lib.MonadTest.tests + , Game.Goatee.Lib.ParserTest.tests + , Game.Goatee.Lib.Property.ParserTest.tests + , Game.Goatee.Lib.PropertyTest.tests + , Game.Goatee.Lib.RoundTripTest.tests + , Game.Goatee.Lib.TreeTest.tests + , Game.Goatee.Lib.TypesTest.tests + ] main :: IO () -main = defaultMain tests +main = do + counts <- runTestTT tests + if errors counts > 0 || failures counts > 0 + then exitFailure + else exitSuccess