diff --git a/goatee.cabal b/goatee.cabal --- a/goatee.cabal +++ b/goatee.cabal @@ -1,10 +1,10 @@ name: goatee -version: 0.2.0 +version: 0.3.0 synopsis: A monadic take on a 2,500-year-old board game - library. category: Game license: AGPL-3 license-file: LICENSE -copyright: Copyright 2014 Bryan Gardiner +copyright: Copyright 2014-2015 Bryan Gardiner author: Bryan Gardiner maintainer: Bryan Gardiner homepage: http://khumba.net/projects/goatee @@ -53,7 +53,7 @@ FunctionalDependencies MultiParamTypeClasses UndecidableInstances - ghc-options: -W -fwarn-incomplete-patterns + ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind hs-source-dirs: src other-modules: Game.Goatee.Lib.Property.Base @@ -70,7 +70,7 @@ HUnit >= 1.2 && < 1.3, mtl >= 2.1 && < 2.3, parsec >= 3.1 && < 3.2 - ghc-options: -W -fwarn-incomplete-patterns + ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind hs-source-dirs: tests main-is: Test.hs other-modules: diff --git a/src/Game/Goatee/App.hs b/src/Game/Goatee/App.hs --- a/src/Game/Goatee/App.hs +++ b/src/Game/Goatee/App.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 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 @@ -29,7 +29,7 @@ -- | A user-presentable copyright message. applicationCopyright :: String -applicationCopyright = "Copyright 2014 Bryan Gardiner" +applicationCopyright = "Copyright 2014-2015 Bryan Gardiner" -- | The home page for Goatee on the web. applicationWebsite :: String 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 @@ -24,6 +24,7 @@ andEithers, for, mapTuple, + mapInvert, whenMaybe, cond, if', @@ -37,6 +38,8 @@ import Control.Arrow ((***)) import Control.Monad (forM_, join, when) import Data.Either (partitionEithers) +import qualified Data.Map as Map +import Data.Map (Map) -- | Drops the element at an index from a list. If the index is out of bounds -- then the list is returned unmodified. @@ -78,6 +81,13 @@ -- | Transforms both values in a homogeneous tuple. mapTuple :: (a -> b) -> (a, a) -> (b, b) mapTuple = join (***) + +-- | Inverts a map, collecting all of the keys that map to a single value in one +-- list in the result map. No guarantees are made on the order of the keys in +-- each value's list. If you want the results in ascending order, apply +-- @'Data.Map.map' 'Data.List.sort'@ to the result. +mapInvert :: Ord v => Map k v -> Map v [k] +mapInvert = Map.fromListWith (++) . map (\(k, v) -> (v, [k])) . Map.assocs -- | Executes the monadic function if a 'Maybe' contains a value. whenMaybe :: Monad m => Maybe a -> (a -> m ()) -> m () diff --git a/src/Game/Goatee/Common/Bigfloat.hs b/src/Game/Goatee/Common/Bigfloat.hs --- a/src/Game/Goatee/Common/Bigfloat.hs +++ b/src/Game/Goatee/Common/Bigfloat.hs @@ -23,7 +23,7 @@ ) where import Data.Char (isDigit, isSpace) -import Data.Function (on) +import Data.Ord (comparing) import Prelude hiding (exponent, significand) -- | A base-10, infinite-precision, floating-point number. Implemented as an @@ -59,7 +59,7 @@ in xe == ye && xv == yv instance Ord Bigfloat where - compare = (uncurry (compare `on` significand) .) . normalize2 + compare = (uncurry (comparing significand) .) . normalize2 instance Num Bigfloat where (+) = lift2 (+) diff --git a/src/Game/Goatee/Lib/Board.hs b/src/Game/Goatee/Lib/Board.hs --- a/src/Game/Goatee/Lib/Board.hs +++ b/src/Game/Goatee/Lib/Board.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 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 @@ -22,9 +22,11 @@ RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode, gameInfoToProperties, BoardState(..), boardWidth, boardHeight, - CoordState(..), rootBoardState, boardCoordState, mapBoardCoords, + CoordState(..), emptyBoardState, rootBoardState, emptyCoordState, boardCoordState, + boardCoordModify, mapBoardCoords, isValidMove, isCurrentValidMove, - Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren, + Cursor, cursorParent, cursorChildIndex, cursorNode, cursorBoard, + rootCursor, cursorRoot, cursorChild, cursorChildren, cursorChildCount, cursorChildPlayingAt, cursorProperties, cursorModifyNode, cursorVariations, @@ -166,6 +168,10 @@ -- ^ 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. + , boardHasCoordMarks :: Bool + -- ^ Whether any of the board's 'CoordState's have a 'Mark' set on them. + -- This is an optimization to make it more efficient to clear marks in the + -- common case where there are no marks set. , boardArrows :: ArrowList , boardLines :: LineList , boardLabels :: LabelList @@ -210,7 +216,7 @@ , coordMark :: Maybe Mark , coordVisible :: Bool , coordDimmed :: Bool - } + } deriving (Eq) instance Show CoordState where show c = if not $ coordVisible c @@ -234,6 +240,7 @@ { boardCoordStates = coords , boardHasInvisible = False , boardHasDimmed = False + , boardHasCoordMarks = False , boardArrows = [] , boardLines = [] , boardLabels = [] @@ -247,18 +254,13 @@ , rootInfoHeight = height , rootInfoVariationMode = defaultVariationMode } - emptyCoord = CoordState { coordStar = False - , coordStone = Nothing - , coordMark = Nothing - , coordVisible = True - , coordDimmed = False - } - starCoord = emptyCoord { coordStar = True } + starCoordState = emptyCoordState { coordStar = True } isStarPoint' = isStarPoint width height - coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord) + coords = map (\y -> map (\x -> if isStarPoint' x y then starCoordState else emptyCoordState) [0..width-1]) [0..height-1] +-- Initializes a 'BoardState' from the properties on a given root 'Node'. rootBoardState :: Node -> BoardState rootBoardState rootNode = foldr applyProperty @@ -267,10 +269,27 @@ where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $ findProperty propertySZ rootNode +-- | A 'CoordState' for an empty point on the board. +emptyCoordState :: CoordState +emptyCoordState = CoordState + { coordStar = False + , coordStone = Nothing + , coordMark = Nothing + , coordVisible = True + , coordDimmed = False + } + -- | Returns the 'CoordState' for a coordinate on a board. boardCoordState :: Coord -> BoardState -> CoordState boardCoordState (x, y) board = boardCoordStates board !! y !! x +-- | Modifies a 'BoardState' by updating the 'CoordState' at a single point. +boardCoordModify :: BoardState -> Coord -> (CoordState -> CoordState) -> BoardState +boardCoordModify board (x, y) f = + board { boardCoordStates = + listUpdate (listUpdate f x) y $ boardCoordStates board + } + -- | Maps a function over each 'CoordState' in a 'BoardState', returning a -- list-of-lists with the function's values. The function is called like @fn y -- x coordState@. @@ -289,11 +308,23 @@ updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board } +-- | Given a 'BoardState' for a parent node, and a child node, this function +-- constructs the 'BoardState' for the child node. +boardChild :: BoardState -> Node -> BoardState +boardChild = + -- This function first prepares the board (clearing temporary marks, etc.) + -- then applies the child node's properties to the board. It is done in two + -- stages because various points in this module apply the steps themselves. + boardApplyChild . boardResetForChild + -- | 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 +-- Clears marks. This is the first step of 'boardChild'. +boardResetForChild :: BoardState -> BoardState +boardResetForChild board = + board { boardCoordStates = + (if boardHasCoordMarks board then map (map clearMark) else id) $ + boardCoordStates board + , boardHasCoordMarks = False , boardArrows = [] , boardLines = [] , boardLabels = [] @@ -302,6 +333,11 @@ Nothing -> coord Just _ -> coord { coordMark = Nothing } +-- | Applies a child node's properties to a prepared 'BoardState'. This is the +-- second step of 'boardChild'. +boardApplyChild :: BoardState -> Node -> BoardState +boardApplyChild = flip applyProperties + -- | Sets all points on a board to be visible (if given true) or invisible (if -- given false). setBoardVisible :: Bool -> BoardState -> BoardState @@ -366,24 +402,29 @@ applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board } applyProperty (CR coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board + updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords + board { boardHasCoordMarks = True } applyProperty (DD coords) board = let coords' = expandCoordList coords board' = clearBoardDimmed board in if null coords' then board' else updateCoordStates (\state -> state { coordDimmed = True }) coords' - board { boardHasDimmed = True } + 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 + updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords + board { boardHasCoordMarks = True } applyProperty (SL coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board + updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords + board { boardHasCoordMarks = True } applyProperty (SQ coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board + updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords + board { boardHasCoordMarks = True } applyProperty (TR coords) board = - updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board + updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords + board { boardHasCoordMarks = True } applyProperty (AP {}) board = board applyProperty (CA {}) board = board @@ -657,29 +698,66 @@ -- | 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. +data Cursor = Cursor + { cursorParent' :: Maybe Cursor + -- ^ The cursor of the parent node in the tree. This is the cursor that was + -- used to construct this cursor. For a root node, this is @Nothing@. + -- + -- If this cursor's node is modified (with 'cursorModifyNode'), then this + -- parent cursor (if present) is /not/ updated to have the modified current + -- node as a child; the public 'cursorParent' takes care of this. + , 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' :: CursorNode + -- ^ The game tree node about which the cursor stores information. The + -- 'CursorNode' keeps track of whether the current node has been modified + -- since last visiting the cursor's parent (if it exists; if it doesn't, + -- then the current node is never considered modified, although in this case + -- it doesn't matter). 'cursorNode' is the public export. + + , cursorBoard :: BoardState + -- ^ The complete board state for the current node. + } deriving (Show) -- TODO Better Show Cursor instance. + +-- | Keeps track of a cursor's node. Also records whether the node has been +-- modified, and uses separate data constructors to force consideration of this. +data CursorNode = + UnmodifiedNode { getCursorNode :: Node } + | ModifiedNode { getCursorNode :: Node } + deriving (Show) + +-- | The cursor for the node above this cursor's node in the game tree. The +-- node of the parent cursor is the parent of the cursor's node. +-- +-- This is @Nothing@ iff the cursor's node has no parent. +cursorParent :: Cursor -> Maybe Cursor +cursorParent cursor = case cursorParent' cursor of + Nothing -> Nothing + p@(Just parent) -> case cursorNode' cursor of + -- If the current node hasn't been modified, then 'parent' is still the + -- correct parent cursor for the current node. + UnmodifiedNode _ -> p + -- If the current node /has/ been modified, then we need to update the + -- parent node's child list to include the modified node rather than the + -- original. We do this one step at a time whenever we walk up the tree. + ModifiedNode node -> + Just $ flip cursorModifyNode parent $ \pnode -> + pnode { nodeChildren = listUpdate (const node) (cursorChildIndex cursor) $ + nodeChildren pnode } + +-- | The game tree node about which the cursor stores information. +cursorNode :: Cursor -> Node +cursorNode = getCursorNode . cursorNode' + -- | Returns a cursor for a root node. rootCursor :: Node -> Cursor rootCursor node = - Cursor { cursorParent = Nothing + Cursor { cursorParent' = Nothing , cursorChildIndex = -1 - , cursorNode = node + , cursorNode' = UnmodifiedNode node , cursorBoard = rootBoardState node } @@ -690,21 +768,21 @@ cursorChild :: Cursor -> Int -> Cursor cursorChild cursor index = - Cursor { cursorParent = Just cursor + Cursor { cursorParent' = Just cursor , cursorChildIndex = index - , cursorNode = child - , cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor + , cursorNode' = UnmodifiedNode child + , cursorBoard = boardChild (cursorBoard cursor) child } -- 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 + let board = boardResetForChild $ cursorBoard cursor + in map (\(index, child) -> Cursor { cursorParent' = Just cursor , cursorChildIndex = index - , cursorNode = child - , cursorBoard = applyProperties child board + , cursorNode' = UnmodifiedNode child + , cursorBoard = boardApplyChild board child }) $ zip [0..] $ nodeChildren @@ -726,19 +804,16 @@ 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 + let node = fn $ cursorNode cursor + maybeParent = cursorParent' cursor + in cursor { cursorNode' = + -- If we're at a root node, then there is no need to mark the node + -- as modified, since we'll never move up. + (if isJust maybeParent then ModifiedNode else UnmodifiedNode) node + , cursorBoard = case maybeParent of + Nothing -> rootBoardState node + Just parent -> boardChild (cursorBoard parent) node + } -- | Returns the variations to display for a cursor. The returned list contains -- the location and color of 'B' and 'W' properties in variation nodes. diff --git a/src/Game/Goatee/Lib/Monad.hs b/src/Game/Goatee/Lib/Monad.hs --- a/src/Game/Goatee/Lib/Monad.hs +++ b/src/Game/Goatee/Lib/Monad.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 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 @@ -15,6 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License -- along with Goatee. If not, see . +{-# LANGUAGE CPP #-} + -- | A monad for working with game trees. module Game.Goatee.Lib.Monad ( -- * The Go monad @@ -37,7 +39,10 @@ ) where import Control.Applicative ((<$>), Applicative ((<*>), pure)) -import Control.Monad (ap, liftM, when) +#if !MIN_VERSION_containers(0,5,0) +import Control.Arrow (second) +#endif +import Control.Monad ((<=<), ap, forM, forM_, liftM, msum, unless, when) import Control.Monad.Identity (Identity, runIdentity) import qualified Control.Monad.State as State import Control.Monad.State (MonadState, StateT, get, put) @@ -45,12 +50,15 @@ 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 qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromMaybe, isNothing) +import Data.Ord (comparing) 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.Tree hiding (addChild, addChildAt, deleteChildAt) import Game.Goatee.Lib.Types -- | The internal state of a Go monad transformer. @go@ is the type of @@ -118,9 +126,10 @@ 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 () +-- | Internal function. Takes a 'Step' in the Go monad and returns whether that +-- step was successful (i.e. if there was a node to mode to). Updates the path +-- stack accordingly. +takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m Bool takeStepM step = case step of GoUp _ -> goUp' GoDown index -> goDown' index @@ -138,14 +147,26 @@ 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 up to the parent node, fires a 'navigationEvent', then returns + -- true. If already at the root of the tree, then none of this happens and + -- false is returned. + goUp :: go Bool - -- | Navigates down the tree to the child with the given index. The child - -- must exist. Fires a 'navigationEvent' after moving. - goDown :: Int -> go () + -- | Navigates down the tree to the child with the given index, fires a + -- 'navigationEvent', then returns true. If the requested child doesn't + -- exist, then none of this happens and false is returned. + goDown :: Int -> go Bool + -- | If possible, moves to the sibling node immediately to the left of the + -- current one. Returns whether a move was made (i.e. whether there was a + -- left sibling). Fires 'navigationEvent's while moving. + goLeft :: go Bool + + -- | If possible, moves to the sibling node immediately to the right of the + -- current one. Returns whether a move was made (i.e. whether there was a + -- right sibling). Fires 'navigationEvent's while moving. + goRight :: go Bool + -- | Navigates up to the root of the tree. Fires 'navigationEvent's for each -- step. goToRoot :: go () @@ -176,25 +197,27 @@ 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 () + -- | Modifies the set of properties on the current node. Fires + -- 'propertiesModifiedEvent' after modifying if the new property set is + -- different from the old property set (order is irrelevant). + modifyProperties :: ([Property] -> [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 :: ValuedDescriptor v d => 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. + -- the same name, if one exists. Fires 'propertiesModifiedEvent' if the + -- property has changed. putProperty :: Property -> go () - putProperty property = modifyProperty (propertyInfo property) $ const $ Just property + putProperty property = modifyProperty property $ const $ Just property - -- | Deletes a property from the current node, if it's set. + -- | Deletes a property from the current node, if it's set, and fires + -- 'propertiesModifiedEvent'. -- -- Note that although a 'Property' is a 'Descriptor', giving a valued -- @Property@ here will not cause deletion to match on the value of the @@ -209,17 +232,18 @@ -- | 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. + -- existing on the node, and a 'Just' marks the property's presence. Fires + -- 'propertiesModifiedEvent' if the property changed. 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 () + -- property's presence. Fires 'propertiesModifiedEvent' if the property + -- changed. This function does not do any validation to check that the + -- resulting tree state is valid. + modifyPropertyValue :: ValuedDescriptor v d => d -> (Maybe v -> Maybe v) -> go () modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old -> propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old) @@ -227,8 +251,8 @@ -- 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 () + -- set. Fires 'propertiesModifiedEvent' if the property changed. + modifyPropertyString :: (Stringlike s, ValuedDescriptor s d) => d -> (String -> String) -> go () modifyPropertyString descriptor fn = modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of "" -> Nothing @@ -237,6 +261,21 @@ -- the conversion back to a string for emptiness. in if null $ sgfToString sgf then Nothing else Just sgf + -- | Mutates the list-valued property attached to the current node + -- according to the given function. 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. + -- + -- Fires 'propertiesModifiedEvent' if the property changed. + -- + -- See also 'modifyPropertyCoords'. + modifyPropertyList :: ValuedDescriptor [v] d => d -> ([v] -> [v]) -> go () + modifyPropertyList descriptor fn = + modifyPropertyValue descriptor $ \value -> case fn $ fromMaybe [] value of + [] -> Nothing + value' -> Just value' + -- | 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 @@ -247,7 +286,9 @@ -- 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 () + -- + -- Fires 'propertiesModifiedEvent' if the property changed. + modifyPropertyCoords :: ValuedDescriptor CoordList d => d -> ([Coord] -> [Coord]) -> go () modifyPropertyCoords descriptor fn = modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of [] -> Nothing @@ -263,6 +304,111 @@ -- then fires a 'variationModeChangedEvent' if the variation mode has changed. modifyVariationMode :: (VariationMode -> VariationMode) -> go () + -- | Retrieves the stone assigned in the current node to a point by 'AB', + -- 'AE', or 'AW'. The possible results are: + -- + -- * @Nothing@: No stone has been assigned to the point. The point could + -- still be in any state, e.g. from a play on the current node or some + -- property in an ancestor node. + -- + -- * @Just Nothing@: The point has been assigned to be empty. + -- + -- * @Just (Just Color)@: The point has been assigned to have a stone of the + -- given color. + getAssignedStone :: Coord -> go (Maybe (Maybe Color)) + getAssignedStone coord = + fmap msum $ forM stoneAssignmentProperties $ \descriptor -> + ((\coords -> if coord `elem` coords + then Just $ stoneAssignmentPropertyToStone descriptor + else Nothing) <=< + fmap expandCoordList) <$> + getPropertyValue descriptor + + -- | Looks up all stones that are assigned by 'AB', 'AE', or 'AW' properties + -- on the current node. Returns a map from each point to the stone that is + -- assigned to the point. + getAllAssignedStones :: go (Map Coord (Maybe Color)) + getAllAssignedStones = + fmap Map.unions $ forM stoneAssignmentProperties $ \descriptor -> + let stone = stoneAssignmentPropertyToStone descriptor + in Map.fromList . map (\coord -> (coord, stone)) . maybe [] expandCoordList <$> + getPropertyValue descriptor + + -- | Modifies the state of currently assigned stones, keeping in mind that it + -- is invalid to mix 'MoveProperty' and 'SetupProperty' properties in a single + -- node. This function has the behaviour of a user changing stone assignments + -- in a UI. How this function works is: + -- + -- * Pick a node to work with. If there is a move property on the current + -- node and there is not already a setup property on the current node, then + -- we'll create and modify a new child node. Otherwise, either there are no + -- move properties on the node (so we can add setup properties at will), or + -- there are both move and setup properties on the node (the node is already + -- invalid), so we'll just modify the current node. + -- + -- * If we're modifying the current node, then apply the modification function + -- to the state of stone assignment for each coordinate. See + -- 'getAssignedStone' for the meaning of @Maybe (Maybe Color)@. Modify the + -- properties in the node as necessary to apply the result + -- ('propertiesModifiedEvent'). (__NOTE:__ Currently one event is fired for + -- each property modified; this may change in the future.) + -- + -- * If we need to create a child node, then apply the modification function + -- to 'Nothing' to determine if we're actually adding assignments. If the + -- function returns a 'Just', then we create a child node with the necessary + -- assignment properties, insert it ('childAddedEvent'), then navigate to it + -- ('navigationEvent'). If the function returns 'Nothing', then + -- 'modifyAssignedStones' does nothing. + modifyAssignedStones :: [Coord] -> (Maybe (Maybe Color) -> Maybe (Maybe Color)) -> go () + modifyAssignedStones coords f = do + needChild <- ((&&) <$> notElem SetupProperty <*> elem MoveProperty) . + map propertyType <$> + getProperties + if needChild + then case f Nothing of + Nothing -> return () + Just assignedStone -> do + addChild emptyNode { nodeProperties = + [propertyBuilder (stoneToStoneAssignmentProperty assignedStone) $ + buildCoordList coords] + } + ok <- goDown =<< subtract 1 . length . cursorChildren <$> getCursor + unless ok $ fail "GoT.modifyAssignedStones: Failed to move to new child." + else do + -- Get a map from getAllAssignedStones: Map Coord (Maybe Color) + allAssignedStones <- getAllAssignedStones + let -- For each coord in coords, modify the map. + allAssignedStones' = foldr (Map.alter f) allAssignedStones coords + -- Invert both maps. + byStone, byStone' :: Map (Maybe Color) [Coord] + byStone = mapInvert allAssignedStones + byStone' = mapInvert allAssignedStones' + -- Compute a diff between the two maps. + diff :: Map (Maybe Color) ([Coord], [Coord]) +#if MIN_VERSION_containers(0,5,0) + diff = Map.mergeWithKey + (\_ oldCoords newCoords -> if newCoords == oldCoords + then Nothing + else Just (oldCoords, newCoords)) + (Map.map $ \oldCoords -> (oldCoords, [])) + (Map.map $ \newCoords -> ([], newCoords)) + byStone + byStone' +#else + -- GHC 7.4.2 / containers <0.5.0 don't provide map merging. + diff = (\partialDiff -> + foldr (\(stone, new) -> + Map.alter (Just . maybe ([], new) (second $ const new)) + stone) + partialDiff + (Map.assocs byStone')) $ + Map.map (\old -> (old, [])) byStone +#endif + -- Modify the AB,AE,AW properties for the stones that have changed lists. + forM_ (Map.assocs diff) $ \(stone, (oldCoords, newCoords)) -> + when (newCoords /= oldCoords) $ + modifyPropertyCoords (stoneToStoneAssignmentProperty stone) $ const newCoords + -- | Returns the 'Mark' at a point on the current node. getMark :: Coord -> go (Maybe Mark) getMark = liftM coordMark . getCoordState @@ -270,9 +416,9 @@ -- | 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 + modifyMark f coord = do maybeOldMark <- getMark coord - case (maybeOldMark, fn maybeOldMark) of + case (maybeOldMark, f maybeOldMark) of (Just oldMark, Nothing) -> remove oldMark (Nothing, Just newMark) -> add newMark (Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark @@ -406,8 +552,26 @@ [] -> pathStack path:paths -> (GoUp index:path):paths - goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp + goLeft = do + cursor <- getCursor + case (cursorParent cursor, cursorChildIndex cursor) of + (Nothing, _) -> return False + (Just _, 0) -> return False + (Just _, n) -> do True <- goUp + True <- goDown $ n - 1 + return True + goRight = do + cursor <- getCursor + case (cursorParent cursor, cursorChildIndex cursor) of + (Nothing, _) -> return False + (Just parent, n) | n == cursorChildCount parent - 1 -> return False + (Just _, n) -> do True <- goUp + True <- goDown $ n + 1 + return True + + goToRoot = whileM goUp $ return () + goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode where findGameInfoNode = do cursor <- getCursor @@ -429,8 +593,9 @@ -- 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 + return $ if null path then Nothing else Just $ head path) $ \step -> do + ok <- takeStepM step $ \((_:steps):paths) -> steps:paths + unless ok $ fail "popPosition: Failed to retrace steps." -- Finally, drop the empty top of the path stack. modifyState $ \state -> case statePathStack state of @@ -445,20 +610,20 @@ -- following popPosition. case statePathStack state of x:y:xs -> putState $ state { statePathStack = (x ++ y):xs } - _:[] -> putState $ state { statePathStack = [] } + [_] -> putState $ state { statePathStack = [] } [] -> fail "dropPosition: No position to drop from the stack." modifyProperties fn = do oldCursor <- getCursor let oldProperties = cursorProperties oldCursor - newProperties <- fn oldProperties + 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) $ + when (sortBy (comparing propertyName) newProperties /= + sortBy (comparing propertyName) oldProperties) $ fire propertiesModifiedEvent (\f -> f oldProperties newProperties) -- The current game info changes when modifying game info properties on the @@ -483,10 +648,10 @@ 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 _, Nothing) -> modifyProperties $ remove descriptor + (Nothing, Just value') -> modifyProperties $ add value' (Just value, Just value') | value /= value' -> - modifyProperties $ return . add value' . remove descriptor + modifyProperties $ add value' . remove descriptor _ -> return () where remove descriptor = filter (not . propertyPredicate descriptor) add value = (value:) @@ -498,9 +663,9 @@ when (gameInfoRootInfo info /= gameInfoRootInfo info') $ fail "Illegal modification of root info in modifyGameInfo." pushPosition - goToGameInfoNode True + _ <- goToGameInfoNode True modifyProperties $ \props -> - return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props + gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props popPosition return info' @@ -549,11 +714,12 @@ childCount <- cursorChildCount <$> getCursor if index < 0 || index >= childCount then return NodeDeleteBadIndex - else do goDown index + else do goDown index >>= + \ok -> unless ok $ fail "GoT.deleteChildAt: Internal error, index isn't valid." childCursor <- getCursor deletingNodeOnPath <- doesPathStackEnterCurrentNode <$> pure childCursor <*> getPathStack - goUp + goUp >>= \ok -> unless ok $ fail "GoT.deleteChildAt: Internal error, can't go up." if deletingNodeOnPath then return NodeDeleteOnPathStack else do cursor <- getCursor @@ -579,14 +745,15 @@ -- | 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 () +-- appropriate, finally returning true. When at the root of the tree, none of +-- this happens and false is returned. +goUp' :: Monad m => (PathStack -> PathStack) -> GoT m Bool 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 + Nothing -> return False Just parent -> do let index = cursorChildIndex cursor putState state { stateCursor = parent @@ -599,17 +766,19 @@ when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $ fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) (boardGameInfo $ cursorBoard parent)) + return True -- | 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 () +-- appropriate, finally returning true. When the child index is invalid, none +-- of this happens and false is returned. +goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m Bool 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 + [] -> return False child:_ -> do putState state { stateCursor = child , statePathStack = pathStackFn pathStack @@ -621,6 +790,7 @@ when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $ fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor) (boardGameInfo $ cursorBoard child)) + return True -- | Returns the current path stack. getPathStack :: Monad m => GoT m PathStack @@ -680,7 +850,7 @@ (==) = (==) `F.on` eventName instance Ord (Event go h) where - compare = compare `F.on` eventName + compare = comparing eventName instance Show (Event go h) where show = eventName diff --git a/src/Game/Goatee/Lib/Parser.hs b/src/Game/Goatee/Lib/Parser.hs --- a/src/Game/Goatee/Lib/Parser.hs +++ b/src/Game/Goatee/Lib/Parser.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 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 @@ -107,10 +107,10 @@ gameTreeParser :: Parser Node gameTreeParser = do - char '(' + _ <- char '(' nodes <- spaces *> many1 (nodeParser <* spaces) "sequence" subtrees <- many (gameTreeParser <* spaces) "subtrees" - char ')' + _ <- char ')' let (sequence, [final]) = splitAt (length nodes - 1) nodes return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] }) (final { nodeChildren = subtrees }) diff --git a/src/Game/Goatee/Lib/Property.hs b/src/Game/Goatee/Lib/Property.hs --- a/src/Game/Goatee/Lib/Property.hs +++ b/src/Game/Goatee/Lib/Property.hs @@ -17,12 +17,9 @@ -- | Structures and functions for working with SGF node properties. module Game.Goatee.Lib.Property ( - module Exported, - PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, + module Game.Goatee.Lib.Property.Base, + module Game.Goatee.Lib.Property.Info, ) 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 +import Game.Goatee.Lib.Property.Base +import Game.Goatee.Lib.Property.Info diff --git a/src/Game/Goatee/Lib/Property/Base.hs b/src/Game/Goatee/Lib/Property/Base.hs --- a/src/Game/Goatee/Lib/Property/Base.hs +++ b/src/Game/Goatee/Lib/Property/Base.hs @@ -27,12 +27,11 @@ Property (..), -- * Property metadata PropertyType (..), - Descriptor (..), - SomeDescriptor (..), - ValuedDescriptor (..), + Descriptor (..), ValuedDescriptor (..), + AnyDescriptor (..), AnyValuedDescriptor (..), AnyCoordListDescriptor, PropertyInfo, ValuedPropertyInfo (ValuedPropertyInfo), - -- * Property declaration + -- * (Internal) Property metadata declaration defProperty, defValuedProperty, ) where @@ -47,7 +46,10 @@ ) import Text.ParserCombinators.Parsec (Parser) --- | An SGF property that gives a node meaning. +-- | An SGF property that gives a node meaning. A property is /known/ if its +-- meaning is defined by the SGF specification, and /unknown/ otherwise. Known +-- properties each have their own data constructors. Unknown properties are +-- represented by the 'UnknownProperty' data constructor. data Property = -- Move properties. B (Maybe Coord) -- ^ Black move (nothing iff pass). @@ -150,7 +152,13 @@ | GeneralProperty -- ^ May appear anywhere in the game tree. deriving (Eq, Show) --- | A class for types that contain metadata about a 'Property'. +-- | A class for types that contain metadata about a 'Property'. The main +-- instance of this class is 'Property' itself; 'Property's can be treated as +-- though they have metadata directly. When referring to a property in general +-- rather than a specific instance, use the values of 'PropertyInfo' and +-- 'ValuedPropertyInfo'. +-- +-- See also 'ValuedDescriptor'. class Descriptor a where -- | Returns the name of the property, as used in SGF files. propertyName :: a -> String @@ -178,19 +186,8 @@ -- 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 +-- | A class for 'Descriptor's of properties that also contain values. +class (Descriptor a, Eq v) => ValuedDescriptor v a | 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 @@ -198,8 +195,42 @@ -- | Builds a property from a given value. propertyBuilder :: a -> v -> Property +-- | An existential type for any property descriptor. 'AnyDescriptor' has a +-- 'Descriptor' instance, so there is no need to extract the value with a +-- pattern match before using 'Descriptor' methods. +data AnyDescriptor = forall a. Descriptor a => AnyDescriptor a + +instance Descriptor AnyDescriptor where + propertyName (AnyDescriptor d) = propertyName d + propertyType (AnyDescriptor d) = propertyType d + propertyInherited (AnyDescriptor d) = propertyInherited d + propertyPredicate (AnyDescriptor d) = propertyPredicate d + propertyValueParser (AnyDescriptor d) = propertyValueParser d + propertyValueRenderer (AnyDescriptor d) = propertyValueRenderer d + propertyValueRendererPretty (AnyDescriptor d) = propertyValueRendererPretty d + +-- | An existential type for any descriptor of a property that holds a value of +-- a specific type. Has instances for 'Descriptor' and 'ValuedDescriptor', +-- similar to 'AnyDescriptor'. +data AnyValuedDescriptor v = forall a. ValuedDescriptor v a => AnyValuedDescriptor a + +instance Descriptor (AnyValuedDescriptor v) where + propertyName (AnyValuedDescriptor d) = propertyName d + propertyType (AnyValuedDescriptor d) = propertyType d + propertyInherited (AnyValuedDescriptor d) = propertyInherited d + propertyPredicate (AnyValuedDescriptor d) = propertyPredicate d + propertyValueParser (AnyValuedDescriptor d) = propertyValueParser d + propertyValueRenderer (AnyValuedDescriptor d) = propertyValueRenderer d + propertyValueRendererPretty (AnyValuedDescriptor d) = propertyValueRendererPretty d + +instance Eq v => ValuedDescriptor v (AnyValuedDescriptor v) where + propertyValue (AnyValuedDescriptor d) = propertyValue d + propertyBuilder (AnyValuedDescriptor d) = propertyBuilder d + +type AnyCoordListDescriptor = AnyValuedDescriptor CoordList + -- | Metadata for a property that does not contain a value. Corresponds to a --- single nullary data constructor of 'Property'. +-- nullary data constructor of 'Property'. data PropertyInfo = PropertyInfo { propertyInfoName :: String -- ^ The SGF textual name for the property. @@ -220,8 +251,8 @@ propertyValueRenderer _ _ = pvtRenderer nonePvt () propertyValueRendererPretty _ _ = pvtRendererPretty nonePvt () --- | Metadata for a property that contains a value. Corresponds to a single --- unary data constructor of 'Property'. +-- | Metadata for a property that contains a value. Corresponds to a +-- non-nullary data constructor of 'Property'. data ValuedPropertyInfo v = ValuedPropertyInfo { valuedPropertyInfoName :: String -- ^ The SGF textual name for the property (also the name of the data @@ -259,12 +290,12 @@ pvtRendererPretty (valuedPropertyInfoValueType descriptor) $ valuedPropertyInfoValue descriptor property -instance Eq v => ValuedDescriptor (ValuedPropertyInfo v) v where +instance Eq v => ValuedDescriptor v (ValuedPropertyInfo v) where propertyValue = valuedPropertyInfoValue propertyBuilder = valuedPropertyInfoBuilder --- | Template Haskell function to declare a property that does not contain a --- value. +-- | Internal to this module, do not use outside. Template Haskell function to +-- declare a property that does not contain a value. -- -- > $(defProperty "KO" 'MoveProperty False) -- @@ -287,7 +318,8 @@ [] ] --- | Template Haskell function to declare a property that contains a value. +-- | Internal to this module, do not use outside. Template Haskell function to +-- declare a property that contains a value. -- -- > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter) -- diff --git a/src/Game/Goatee/Lib/Property/Info.hs b/src/Game/Goatee/Lib/Property/Info.hs --- a/src/Game/Goatee/Lib/Property/Info.hs +++ b/src/Game/Goatee/Lib/Property/Info.hs @@ -21,8 +21,92 @@ -- | Property metadata declarations. -- -- Import "Game.Goatee.Lib.Property" rather than importing this module. -module Game.Goatee.Lib.Property.Info where +module Game.Goatee.Lib.Property.Info ( + -- * Known property metadata + propertyB, + propertyKO, + propertyMN, + propertyW, + propertyAB, + propertyAE, + propertyAW, + propertyPL, + + propertyC, + propertyDM, + propertyGB, + propertyGW, + propertyHO, + propertyN, + propertyUC, + propertyV, + + propertyBM, + propertyDO, + propertyIT, + propertyTE, + + propertyAR, + propertyCR, + propertyDD, + propertyLB, + propertyLN, + propertyMA, + propertySL, + propertySQ, + propertyTR, + + propertyAP, + propertyCA, + propertyFF, + propertyGM, + propertyST, + propertySZ, + + propertyAN, + propertyBR, + propertyBT, + propertyCP, + propertyDT, + propertyEV, + propertyGC, + propertyGN, + propertyON, + propertyOT, + propertyPB, + propertyPC, + propertyPW, + propertyRE, + propertyRO, + propertyRU, + propertySO, + propertyTM, + propertyUS, + propertyWR, + propertyWT, + + propertyBL, + propertyOB, + propertyOW, + propertyWL, + + propertyVW, + + propertyHA, + propertyKM, + propertyTB, + propertyTW, + + -- * Property metadata utilities + allKnownDescriptors, + propertyUnknown, + propertyInfo, + descriptorForName, descriptorForName', + stoneAssignmentProperties, stoneAssignmentPropertyToStone, stoneToStoneAssignmentProperty, + markProperty, + ) where + import Control.Arrow ((&&&)) import qualified Data.Map as Map import Data.Map (Map) @@ -64,7 +148,7 @@ $(defValuedProperty "CR" 'GeneralProperty False 'coordListPvt) $(defValuedProperty "DD" 'GeneralProperty True 'coordListPvt) $(defValuedProperty "LB" 'GeneralProperty False 'labelListPvt) -$(defValuedProperty "LN" 'GeneralProperty False 'coordPairListPvt) +$(defValuedProperty "LN" 'GeneralProperty False 'lineListPvt) $(defValuedProperty "MA" 'GeneralProperty False 'coordListPvt) $(defValuedProperty "SL" 'GeneralProperty False 'coordListPvt) $(defValuedProperty "SQ" 'GeneralProperty False 'coordListPvt) @@ -126,172 +210,179 @@ $(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 +-- | A list of descriptors for all known 'Property's. +allKnownDescriptors :: [AnyDescriptor] +allKnownDescriptors = + [ AnyDescriptor propertyB + , AnyDescriptor propertyKO + , AnyDescriptor propertyMN + , AnyDescriptor propertyW - , SomeDescriptor propertyAB - , SomeDescriptor propertyAE - , SomeDescriptor propertyAW - , SomeDescriptor propertyPL + , AnyDescriptor propertyAB + , AnyDescriptor propertyAE + , AnyDescriptor propertyAW + , AnyDescriptor propertyPL - , SomeDescriptor propertyC - , SomeDescriptor propertyDM - , SomeDescriptor propertyGB - , SomeDescriptor propertyGW - , SomeDescriptor propertyHO - , SomeDescriptor propertyN - , SomeDescriptor propertyUC - , SomeDescriptor propertyV + , AnyDescriptor propertyC + , AnyDescriptor propertyDM + , AnyDescriptor propertyGB + , AnyDescriptor propertyGW + , AnyDescriptor propertyHO + , AnyDescriptor propertyN + , AnyDescriptor propertyUC + , AnyDescriptor propertyV - , SomeDescriptor propertyBM - , SomeDescriptor propertyDO - , SomeDescriptor propertyIT - , SomeDescriptor propertyTE + , AnyDescriptor propertyBM + , AnyDescriptor propertyDO + , AnyDescriptor propertyIT + , AnyDescriptor propertyTE - , SomeDescriptor propertyAR - , SomeDescriptor propertyCR - , SomeDescriptor propertyDD - , SomeDescriptor propertyLB - , SomeDescriptor propertyLN - , SomeDescriptor propertyMA - , SomeDescriptor propertySL - , SomeDescriptor propertySQ - , SomeDescriptor propertyTR + , AnyDescriptor propertyAR + , AnyDescriptor propertyCR + , AnyDescriptor propertyDD + , AnyDescriptor propertyLB + , AnyDescriptor propertyLN + , AnyDescriptor propertyMA + , AnyDescriptor propertySL + , AnyDescriptor propertySQ + , AnyDescriptor propertyTR - , SomeDescriptor propertyAP - , SomeDescriptor propertyCA - , SomeDescriptor propertyFF - , SomeDescriptor propertyGM - , SomeDescriptor propertyST - , SomeDescriptor propertySZ + , AnyDescriptor propertyAP + , AnyDescriptor propertyCA + , AnyDescriptor propertyFF + , AnyDescriptor propertyGM + , AnyDescriptor propertyST + , AnyDescriptor 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 + , AnyDescriptor propertyAN + , AnyDescriptor propertyBR + , AnyDescriptor propertyBT + , AnyDescriptor propertyCP + , AnyDescriptor propertyDT + , AnyDescriptor propertyEV + , AnyDescriptor propertyGC + , AnyDescriptor propertyGN + , AnyDescriptor propertyON + , AnyDescriptor propertyOT + , AnyDescriptor propertyPB + , AnyDescriptor propertyPC + , AnyDescriptor propertyPW + , AnyDescriptor propertyRE + , AnyDescriptor propertyRO + , AnyDescriptor propertyRU + , AnyDescriptor propertySO + , AnyDescriptor propertyTM + , AnyDescriptor propertyUS + , AnyDescriptor propertyWR + , AnyDescriptor propertyWT - , SomeDescriptor propertyBL - , SomeDescriptor propertyOB - , SomeDescriptor propertyOW - , SomeDescriptor propertyWL + , AnyDescriptor propertyBL + , AnyDescriptor propertyOB + , AnyDescriptor propertyOW + , AnyDescriptor propertyWL - , SomeDescriptor propertyVW + , AnyDescriptor propertyVW - , SomeDescriptor propertyHA - , SomeDescriptor propertyKM - , SomeDescriptor propertyTB - , SomeDescriptor propertyTW + , AnyDescriptor propertyHA + , AnyDescriptor propertyKM + , AnyDescriptor propertyTB + , AnyDescriptor propertyTW ] -propertyInfo :: Property -> SomeDescriptor +-- | Builds a 'ValuedPropertyInfo' for an unknown property with the given name. +-- /Does not check that the name is actually unknown./ +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) + +-- | Returns a descriptor for any 'Property', known or unknown. Because a +-- 'Property' has a 'Descriptor' instance, this function is not normally +-- necessary for use outside of this module, but it can be used to throw away a +-- value associated with a 'Property' and retain only the metadata. +propertyInfo :: Property -> AnyDescriptor propertyInfo property = case property of - B {} -> SomeDescriptor propertyB - KO {} -> SomeDescriptor propertyKO - MN {} -> SomeDescriptor propertyMN - W {} -> SomeDescriptor propertyW + B {} -> AnyDescriptor propertyB + KO {} -> AnyDescriptor propertyKO + MN {} -> AnyDescriptor propertyMN + W {} -> AnyDescriptor propertyW - AB {} -> SomeDescriptor propertyAB - AE {} -> SomeDescriptor propertyAE - AW {} -> SomeDescriptor propertyAW - PL {} -> SomeDescriptor propertyPL + AB {} -> AnyDescriptor propertyAB + AE {} -> AnyDescriptor propertyAE + AW {} -> AnyDescriptor propertyAW + PL {} -> AnyDescriptor 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 + C {} -> AnyDescriptor propertyC + DM {} -> AnyDescriptor propertyDM + GB {} -> AnyDescriptor propertyGB + GW {} -> AnyDescriptor propertyGW + HO {} -> AnyDescriptor propertyHO + N {} -> AnyDescriptor propertyN + UC {} -> AnyDescriptor propertyUC + V {} -> AnyDescriptor propertyV - BM {} -> SomeDescriptor propertyBM - DO {} -> SomeDescriptor propertyDO - IT {} -> SomeDescriptor propertyIT - TE {} -> SomeDescriptor propertyTE + BM {} -> AnyDescriptor propertyBM + DO {} -> AnyDescriptor propertyDO + IT {} -> AnyDescriptor propertyIT + TE {} -> AnyDescriptor 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 + AR {} -> AnyDescriptor propertyAR + CR {} -> AnyDescriptor propertyCR + DD {} -> AnyDescriptor propertyDD + LB {} -> AnyDescriptor propertyLB + LN {} -> AnyDescriptor propertyLN + MA {} -> AnyDescriptor propertyMA + SL {} -> AnyDescriptor propertySL + SQ {} -> AnyDescriptor propertySQ + TR {} -> AnyDescriptor propertyTR - AP {} -> SomeDescriptor propertyAP - CA {} -> SomeDescriptor propertyCA - FF {} -> SomeDescriptor propertyFF - GM {} -> SomeDescriptor propertyGM - ST {} -> SomeDescriptor propertyST - SZ {} -> SomeDescriptor propertySZ + AP {} -> AnyDescriptor propertyAP + CA {} -> AnyDescriptor propertyCA + FF {} -> AnyDescriptor propertyFF + GM {} -> AnyDescriptor propertyGM + ST {} -> AnyDescriptor propertyST + SZ {} -> AnyDescriptor 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 + AN {} -> AnyDescriptor propertyAN + BR {} -> AnyDescriptor propertyBR + BT {} -> AnyDescriptor propertyBT + CP {} -> AnyDescriptor propertyCP + DT {} -> AnyDescriptor propertyDT + EV {} -> AnyDescriptor propertyEV + GC {} -> AnyDescriptor propertyGC + GN {} -> AnyDescriptor propertyGN + ON {} -> AnyDescriptor propertyON + OT {} -> AnyDescriptor propertyOT + PB {} -> AnyDescriptor propertyPB + PC {} -> AnyDescriptor propertyPC + PW {} -> AnyDescriptor propertyPW + RE {} -> AnyDescriptor propertyRE + RO {} -> AnyDescriptor propertyRO + RU {} -> AnyDescriptor propertyRU + SO {} -> AnyDescriptor propertySO + TM {} -> AnyDescriptor propertyTM + US {} -> AnyDescriptor propertyUS + WR {} -> AnyDescriptor propertyWR + WT {} -> AnyDescriptor propertyWT - BL {} -> SomeDescriptor propertyBL - OB {} -> SomeDescriptor propertyOB - OW {} -> SomeDescriptor propertyOW - WL {} -> SomeDescriptor propertyWL + BL {} -> AnyDescriptor propertyBL + OB {} -> AnyDescriptor propertyOB + OW {} -> AnyDescriptor propertyOW + WL {} -> AnyDescriptor propertyWL - VW {} -> SomeDescriptor propertyVW + VW {} -> AnyDescriptor propertyVW - HA {} -> SomeDescriptor propertyHA - KM {} -> SomeDescriptor propertyKM - TB {} -> SomeDescriptor propertyTB - TW {} -> SomeDescriptor propertyTW + HA {} -> AnyDescriptor propertyHA + KM {} -> AnyDescriptor propertyKM + TB {} -> AnyDescriptor propertyTB + TW {} -> AnyDescriptor propertyTW - UnknownProperty name _ -> SomeDescriptor $ propertyUnknown name + UnknownProperty name _ -> AnyDescriptor $ propertyUnknown name instance Descriptor Property where propertyName = propertyName . propertyInfo @@ -302,14 +393,45 @@ propertyValueRenderer = propertyValueRenderer . propertyInfo propertyValueRendererPretty = propertyValueRendererPretty . propertyInfo -descriptorsByName :: Map String SomeDescriptor -descriptorsByName = Map.fromList $ map (propertyName &&& id) allDescriptors +descriptorsByName :: Map String AnyDescriptor +descriptorsByName = Map.fromList $ map (propertyName &&& id) allKnownDescriptors -descriptorForName :: String -> SomeDescriptor -descriptorForName name = fromMaybe (SomeDescriptor $ propertyUnknown name) $ descriptorForName' name +-- | Returns a descriptor for the given property name. The name does not have +-- to be for a known property; an unknown property will use 'propertyUnknown'. +descriptorForName :: String -> AnyDescriptor +descriptorForName name = fromMaybe (AnyDescriptor $ propertyUnknown name) $ descriptorForName' name -descriptorForName' :: String -> Maybe SomeDescriptor +-- | Returns a descriptor for a known property with the given name, or 'Nothing' +-- if the name does not belong to a known property. +descriptorForName' :: String -> Maybe AnyDescriptor descriptorForName' = flip Map.lookup descriptorsByName + +-- | Descriptors for setup properties that assign stones to the board. For use +-- with 'stoneAssignmentPropertyToStone' and 'stoneToStoneAssignmentProperty'. +stoneAssignmentProperties :: [AnyCoordListDescriptor] +stoneAssignmentProperties = + [ AnyValuedDescriptor propertyAB + , AnyValuedDescriptor propertyAE + , AnyValuedDescriptor propertyAW + ] + +-- | Converts a descriptor in 'stoneAssignmentProperties' to the type of stone +-- it assigns. +stoneAssignmentPropertyToStone :: AnyCoordListDescriptor -> Maybe Color +stoneAssignmentPropertyToStone (AnyValuedDescriptor d) = case propertyName d of + "AB" -> Just Black + "AE" -> Nothing + "AW" -> Just White + _ -> error $ "stoneAssignmentPropertyToColor: " ++ show (propertyName d) ++ + " is not a stone assignment property." + +-- | Converts a type of stone assignment to a descriptor in +-- 'stoneAssignmentProperties'. +stoneToStoneAssignmentProperty :: Maybe Color -> AnyCoordListDescriptor +stoneToStoneAssignmentProperty stone = case stone of + Nothing -> AnyValuedDescriptor propertyAE + Just Black -> AnyValuedDescriptor propertyAB + Just White -> AnyValuedDescriptor propertyAW -- | Returns the descriptor for a mark. markProperty :: Mark -> ValuedPropertyInfo CoordList diff --git a/src/Game/Goatee/Lib/Property/Parser.hs b/src/Game/Goatee/Lib/Property/Parser.hs --- a/src/Game/Goatee/Lib/Property/Parser.hs +++ b/src/Game/Goatee/Lib/Property/Parser.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 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 @@ -16,8 +16,6 @@ -- 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, @@ -26,6 +24,7 @@ doubleParser, gameResultParser, labelListParser, + lineListParser, moveParser, noneParser, integralParser, @@ -81,7 +80,7 @@ compose :: Parser a -> Parser b -> Parser (a, b) compose first second = do x <- first - char ':' + _ <- char ':' y <- second return (x, y) @@ -126,7 +125,7 @@ "list of points" where coordListEntry = do x0 <- line y0 <- line - choice [do char ':' + choice [do _ <- char ':' x1 <- line y1 <- line return $ coordR ((x0, y0), (x1, y1)), @@ -138,7 +137,7 @@ where coordPair = do x0 <- line y0 <- line - char ':' + _ <- char ':' x1 <- line y1 <- line return ((x0, y0), (x1, y1)) @@ -156,6 +155,9 @@ labelListParser = listOf (compose coord $ simpleText True) "list of points and labels" +lineListParser :: Parser [Line] +lineListParser = map (uncurry Line) <$> coordPairListParser "list of lines" + moveParser :: Parser (Maybe Coord) moveParser = char '[' *> (Nothing <$ char ']' <|> Just <$> coord <* char ']') @@ -200,12 +202,12 @@ sizeParser :: Parser (Int, Int) sizeParser = - (do char '[' + (do _ <- char '[' width <- integral height <- choice [width <$ char ']', - do char ':' + do _ <- char ':' height <- integral - char ']' + _ <- char ']' -- TODO We should warn here rather than aborting. when (width == height) $ fail $ show width ++ "x" ++ show height ++ " square board " ++ diff --git a/src/Game/Goatee/Lib/Property/Renderer.hs b/src/Game/Goatee/Lib/Property/Renderer.hs --- a/src/Game/Goatee/Lib/Property/Renderer.hs +++ b/src/Game/Goatee/Lib/Property/Renderer.hs @@ -38,6 +38,8 @@ renderIntegralPretty, renderLabelListBracketed, renderLabelListPretty, + renderLineListBracketed, + renderLineListPretty, renderMoveBracketed, renderMovePretty, renderNoneBracketed, @@ -253,6 +255,14 @@ tell ":" renderStringlikePretty text) list + +renderLineListBracketed :: [Line] -> Render () +renderLineListBracketed = rendererOf "line list bracketed" $ + renderCoordPairListBracketed . map lineToPair + +renderLineListPretty :: [Line] -> Render () +renderLineListPretty = rendererOf "line list pretty" $ + renderCoordPairListPretty . map lineToPair renderMoveBracketed :: Maybe Coord -> Render () renderMoveBracketed = rendererOf "move bracketed" $ maybe (tell "[]") renderCoordBracketed diff --git a/src/Game/Goatee/Lib/Property/Value.hs b/src/Game/Goatee/Lib/Property/Value.hs --- a/src/Game/Goatee/Lib/Property/Value.hs +++ b/src/Game/Goatee/Lib/Property/Value.hs @@ -17,7 +17,8 @@ -- | Metadata about the types of property values. -- --- Import "Game.Goatee.Lib.Property" rather than importing this module. +-- This module is internal to "Game.Goatee.Lib.Property"; you should not need +-- these structures elsewhere. module Game.Goatee.Lib.Property.Value ( PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty, colorPvt, @@ -28,6 +29,7 @@ gameResultPvt, integralPvt, labelListPvt, + lineListPvt, movePvt, nonePvt, realPvt, @@ -106,6 +108,13 @@ { pvtParser = P.labelListParser , pvtRenderer = R.renderLabelListBracketed , pvtRendererPretty = R.renderLabelListPretty + } + +lineListPvt :: PropertyValueType [Line] +lineListPvt = PropertyValueType + { pvtParser = P.lineListParser + , pvtRenderer = R.renderLineListBracketed + , pvtRendererPretty = R.renderLineListPretty } movePvt :: PropertyValueType (Maybe Coord) diff --git a/src/Game/Goatee/Lib/Renderer/Tree.hs b/src/Game/Goatee/Lib/Renderer/Tree.hs --- a/src/Game/Goatee/Lib/Renderer/Tree.hs +++ b/src/Game/Goatee/Lib/Renderer/Tree.hs @@ -43,7 +43,7 @@ (\node' -> do renderNode node' case nodeChildren node' of [] -> return $ Left Nothing - child:[] -> return $ Right child + [child] -> return $ Right child children -> return $ Left $ Just children) >>= maybe (return ()) (mapM_ renderGameTree) tell ")" diff --git a/src/Game/Goatee/Lib/Tree.hs b/src/Game/Goatee/Lib/Tree.hs --- a/src/Game/Goatee/Lib/Tree.hs +++ b/src/Game/Goatee/Lib/Tree.hs @@ -30,6 +30,7 @@ import Control.Monad.Writer (Writer, execWriter, tell) import Data.Function (on) import Data.List (find, groupBy, intercalate, nub, sortBy) +import Data.Ord (comparing) import Data.Version (showVersion) import Game.Goatee.App (applicationName) import Game.Goatee.Common @@ -74,7 +75,7 @@ n2 = nodeWithDeepEquality node2 in propertiesSorted n1 == propertiesSorted n2 && deepChildren n1 == deepChildren n2 - where propertiesSorted = sortBy (compare `on` show) . nodeProperties + where propertiesSorted = sortBy (comparing show) . nodeProperties deepChildren = map NodeWithDeepEquality . nodeChildren -- | A node with no properties and no children. @@ -103,11 +104,11 @@ findProperty' = find . propertyPredicate -- | Retrieves the value of a property in a node's property list. -findPropertyValue :: ValuedDescriptor a v => a -> Node -> Maybe v +findPropertyValue :: ValuedDescriptor v a => 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' :: ValuedDescriptor v a => a -> [Property] -> Maybe v findPropertyValue' descriptor properties = propertyValue descriptor <$> findProperty' descriptor properties @@ -181,7 +182,7 @@ -> Writer [String] () validateNodeDuplicates props getTaggedElts errAction = let groups = groupBy ((==) `on` fst) $ - sortBy (compare `on` fst) $ + sortBy (comparing fst) $ concatMap getTaggedElts props in forM_ groups $ \group -> unless (null $ tail group) $ diff --git a/src/Game/Goatee/Lib/Types.hs b/src/Game/Goatee/Lib/Types.hs --- a/src/Game/Goatee/Lib/Types.hs +++ b/src/Game/Goatee/Lib/Types.hs @@ -39,7 +39,7 @@ Color (..), cnot, VariationMode (..), VariationModeSource (..), defaultVariationMode, toVariationMode, fromVariationMode, - ArrowList, LineList, LabelList, Mark (..), + ArrowList, LineList, Line (..), lineToPair, LabelList, Mark (..), GameResult (..), WinReason (..), Ruleset (..), RulesetType (..), fromRuleset, toRuleset, @@ -352,12 +352,12 @@ -- | An SGF double value: either 1 or 2, nothing else. data DoubleValue = Double1 | Double2 - deriving (Eq, Show) + deriving (Bounded, Enum, Eq, Ord, Show) -- | Stone color: black or white. data Color = Black | White - deriving (Eq, Show) + deriving (Bounded, Enum, Eq, Ord, Show) -- | Returns the logical negation of a stone color, yang for yin and -- yin for yang. @@ -380,7 +380,7 @@ -- ^ Show children of the current move. | ShowCurrentVariations -- ^ Show alternatives to the current move. - deriving (Bounded, Enum, Eq, Show) + deriving (Bounded, Enum, Eq, Ord, Show) -- | The default variation mode as defined by the SGF spec is @VariationMode -- ShowChildVariations True@. @@ -409,15 +409,26 @@ type ArrowList = [(Coord, Coord)] -- | A list of lines, each specified as @(startCoord, endCoord)@. -type LineList = [(Coord, Coord)] +type LineList = [Line] +-- | An undirected line between two coordinates. +data Line = Line Coord Coord + deriving (Show) + +instance Eq Line where + (Line a b) == (Line c d) = a == c && b == d || a == d && b == c + +-- | Converts a 'Line' to a pair of 'Coord's representing the line's endpoints. +lineToPair :: Line -> (Coord, Coord) +lineToPair (Line a b) = (a, b) + -- | 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) + deriving (Bounded, Enum, Eq, Ord, Show) data GameResult = GameResultWin Color WinReason | GameResultDraw @@ -484,7 +495,7 @@ | RulesetIng | RulesetJapanese | RulesetNewZealand - deriving (Bounded, Enum, Eq, Show) + deriving (Bounded, Enum, Eq, Ord, Show) -- | Returns the string representation for a ruleset. fromRuleset :: Ruleset -> String 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 @@ -22,6 +22,9 @@ import Control.Monad.State (get, put, runStateT) import Control.Monad.Writer (execWriter, tell) import Data.IORef (modifyIORef, newIORef, readIORef) +import Data.List (sort) +import qualified Data.Map as Map +import Data.Map (Map) import Game.Goatee.Common import Test.HUnit ((~:), (@=?), Test (TestList), assertFailure) @@ -34,6 +37,7 @@ , andEithersTests , forTests , mapTupleTests + , mapInvertTests , whenMaybeTests , condTests , if'Tests @@ -144,6 +148,19 @@ mapTupleTests = "mapTuple" ~: TestList [ "updates both values" ~: (9, 16) @=? mapTuple (^ 2) (3, 4) + ] + +mapInvertTests = "mapInvert" ~: TestList + [ "accepts an empty map" ~: + Map.empty @=? mapInvert (Map.empty :: Map () ()) + + , "inverts a map with no duplicates" ~: + Map.map sort (Map.fromList [(1, ["one"]), (2, ["two"]), (3, ["three"])]) @=? + Map.map sort (mapInvert (Map.fromList [("one", 1), ("two", 2), ("three", 3)])) + + , "inverts a map with duplicates" ~: + Map.map sort (Map.fromList [('a', [1, 3]), ('b', [2]), ('c', [4, 5])]) @=? + Map.map sort (mapInvert (Map.fromList [(1, 'a'), (2, 'b'), (3, 'a'), (4, 'c'), (5, 'c')])) ] whenMaybeTests = "whenMaybeTests" ~: TestList diff --git a/tests/Game/Goatee/Lib/BoardTest.hs b/tests/Game/Goatee/Lib/BoardTest.hs --- a/tests/Game/Goatee/Lib/BoardTest.hs +++ b/tests/Game/Goatee/Lib/BoardTest.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 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 @@ -17,6 +17,7 @@ module Game.Goatee.Lib.BoardTest (tests) where +import Game.Goatee.Common import Game.Goatee.Lib.Board import Game.Goatee.Lib.Property import Game.Goatee.Lib.TestInstances () @@ -27,6 +28,7 @@ tests = "Game.Goatee.Lib.Board" ~: TestList [ boardCoordStateTests + , boardCoordModifyTests , moveNumberTests , markupPropertiesTests , visibilityPropertyTests @@ -52,6 +54,18 @@ coordMark (boardCoordState (1,1) board) @?= Just MarkX ] +boardCoordModifyTests = "boardCoordModify" ~: TestList + [ "modifies a single coord" ~: + let state = emptyCoordState + state' = emptyCoordState { coordStone = Just White } + state'' = emptyCoordState { coordMark = Just MarkTriangle } + expectedStates = [[state, state'], [state'', state]] + actualStates = boardCoordStates $ + (\board -> boardCoordModify board (1, 0) (const state')) $ + (\board -> boardCoordModify board (0, 1) (const state'')) $ + rootBoardState $ rootNode $ Just (2, 2) + in expectedStates @=? actualStates + ] moveNumberTests = "move number" ~: TestList [ "starts at zero" ~: @@ -98,7 +112,7 @@ , "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))]]) + , "LN" ~: [Line (0,0) (1,1)] @=? boardLines (rootCoord $ node [LN [Line (0,0) (1,1)]]) ] , "clears annotations when moving to a child node" ~: do @@ -110,13 +124,32 @@ TR $ coords [(1,1)], AR [((0,0), (2,1))], LB [((2,1), st "Empty")], - LN [((1,1), (2,0))]] $ + LN [Line (1,1) (2,0)]] $ node [] board = cursorBoard $ child 0 $ rootCursor root mapM_ (mapM_ ((Nothing @=?) . coordMark)) $ boardCoordStates board [] @=? boardArrows board [] @=? boardLines board [] @=? boardLabels board + + , "boardHasCoordMarks" ~: TestList + [ "defaults to false" ~: + False @=? boardHasCoordMarks (cursorBoard $ rootCursor $ node []) + + , "is true when marks are present" ~: + True @=? boardHasCoordMarks (cursorBoard $ rootCursor $ node [CR $ coord1 (0,0)]) + + , "is set to false when moving to a child node" ~: + False @=? boardHasCoordMarks (cursorBoard $ child 0 $ rootCursor $ + node1 [CR $ coord1 (0,0)] $ node []) + + , "all marks set it to true" ~: TestList + (for [minBound..] $ \mark -> + let p = markProperty mark + in propertyName p ~: + True @=? boardHasCoordMarks (cursorBoard $ rootCursor $ + node [propertyBuilder p $ coord1 (0,0)])) + ] ] where rootCoord = cursorBoard . rootCursor st = toSimpleText diff --git a/tests/Game/Goatee/Lib/MonadTest.hs b/tests/Game/Goatee/Lib/MonadTest.hs --- a/tests/Game/Goatee/Lib/MonadTest.hs +++ b/tests/Game/Goatee/Lib/MonadTest.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 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 @@ -21,8 +21,11 @@ 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.List (sortBy, unfoldr) +import qualified Data.Map as Map import Data.Maybe (fromJust, maybeToList) +import Data.Monoid (Monoid) +import Data.Ord (comparing) import Game.Goatee.Common import Game.Goatee.Lib.Board import Game.Goatee.Lib.Monad @@ -32,7 +35,7 @@ import Game.Goatee.Lib.Tree (emptyNode, nodeChildren) import Game.Goatee.Lib.Types import Game.Goatee.Test.Common -import Test.HUnit ((~:), (@=?), (@?=), Test (TestList)) +import Test.HUnit ((~:), (@=?), (@?=), Assertion, Test (TestList), assertFailure) {-# ANN module "HLint: ignore Reduce duplication" #-} @@ -55,9 +58,13 @@ , modifyPropertyTests , modifyPropertyValueTests , modifyPropertyStringTests + , modifyPropertyListTests , modifyPropertyCoordsTests , modifyGameInfoTests , modifyVariationModeTests + , getAssignedStoneTests + , getAllAssignedStonesTests + , modifyAssignedStonesTests , getMarkTests , modifyMarkTests , addChildTests @@ -93,24 +100,70 @@ ] navigationTests = "navigation" ~: TestList - [ "navigates down a tree" ~: + [ "navigates down a tree" ~: do 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] + action = do tell . (:[]) =<< goDown 0 + tell . (:[]) =<< goDown 1 + tell . (:[]) =<< goDown 0 + ((_, cursor'), log) = runWriter $ runGoT action cursor + cursorProperties cursor' @?= [B Nothing] + log @?= [True, True, False] - , "navigates up a tree" ~: + , "navigates up a tree" ~: do 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)] + action = replicateM_ 3 (tell . (:[]) =<< goUp) + ((_, cursor'), log) = runWriter $ runGoT action cursor + cursorProperties cursor' @?= [B $ Just (0,0)] + log @?= [True, True, False] + , "navigates to the left" ~: + let cursor = child 2 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node' [W $ Just (1,1)] + [node [B $ Just (2,2)], + node [B $ Just (3,3)], + node [B $ Just (4,4)]] + action = do tell . (:[]) . show =<< goLeft + tell . (:[]) . show =<< getProperties + tell . (:[]) . show =<< goLeft + tell . (:[]) . show =<< getProperties + tell . (:[]) . show =<< goLeft + tell . (:[]) . show =<< getProperties + log = execWriter $ runGoT action cursor + in log @?= ["True", + "[B (Just (3,3))]", + "True", + "[B (Just (2,2))]", + "False", + "[B (Just (2,2))]"] + + , "navigates to the right" ~: + let cursor = child 0 $ child 0 $ rootCursor $ + node1 [B $ Just (0,0)] $ + node' [W $ Just (1,1)] + [node [B $ Just (2,2)], + node [B $ Just (3,3)], + node [B $ Just (4,4)]] + action = do tell . (:[]) . show =<< goRight + tell . (:[]) . show =<< getProperties + tell . (:[]) . show =<< goRight + tell . (:[]) . show =<< getProperties + tell . (:[]) . show =<< goRight + tell . (:[]) . show =<< getProperties + log = execWriter $ runGoT action cursor + in log @?= ["True", + "[B (Just (3,3))]", + "True", + "[B (Just (4,4))]", + "False", + "[B (Just (4,4))]"] + , "invokes handlers when navigating" ~: let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] action = do on navigationEvent $ \step -> case step of @@ -119,8 +172,9 @@ on navigationEvent $ \step -> case step of GoDown index -> tell ["Down " ++ show index] _ -> return () - goDown 0 - goUp + True <- goDown 0 + True <- goUp + return () (_, _, log) = runLoggedGo action cursor in log @?= ["Down 0", "Up 0"] @@ -223,8 +277,8 @@ , "should fire navigation handlers while popping" ~: do let cursor = rootCursor $ node1 [B Nothing] $ node [W Nothing] action = do pushPosition - goDown 0 - goUp + True <- goDown 0 + True <- goUp on navigationEvent $ \step -> tell [step] popPosition execWriter (runGoT action cursor) @?= [GoDown 0, GoUp 0] @@ -240,9 +294,14 @@ [W (Just x)] -> tell ["W " ++ show x] xs -> error $ "Unexpected properties: " ++ show xs navigate = do log >> pushPosition - goUp >> goDown 1 + True <- goUp + True <- goDown 1 log >> pushPosition - goUp >> goUp >> goDown 1 >> goDown 0 + True <- goUp + True <- goUp + True <- goDown 1 + True <- goDown 0 + return () propertiesTests = "properties" ~: TestList [ "getProperties" ~: TestList @@ -259,20 +318,20 @@ , "modifyProperties" ~: TestList [ "adds properties" ~: let cursor = rootCursor $ node [FF 1] - action = do modifyProperties $ \props -> return $ props ++ [B Nothing, W Nothing] + action = do modifyProperties $ \props -> 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 + action = do modifyProperties $ \props -> 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] + modifyProperties $ const [FF 2] log = execWriter (runGoT action cursor) in log @?= [([FF 1], [FF 2])] ] @@ -440,6 +499,47 @@ in cursorProperties result @?= [] ] +modifyPropertyListTests = "modifyPropertyList" ~: TestList + [ "adds a property where there was none" ~: + let cursor = rootCursor $ node [] + arrows = [((0,0), (1,1)), ((0,1), (1,0))] + action = modifyPropertyList propertyAR $ \[] -> arrows + in [AR arrows] @=? cursorProperties (execGo action cursor) + + , "removes a property where there was one" ~: + let lines = [Line (0,0) (0,1), Line (1,0) (1,1)] + cursor = rootCursor $ node [LN lines] + action = modifyPropertyList propertyLN $ \old -> + if old == lines then [] else error $ "Unexpected old value: " ++ show old + in [] @=? cursorProperties (execGo action cursor) + + , "modifies an existing property" ~: + let lines = [Line (0,0) (0,1), Line (1,0) (1,1)] + lines' = [head lines] + cursor = rootCursor $ node [LN lines] + action = modifyPropertyList propertyLN $ \old -> + if old == lines then lines' else error $ "Unexpected old value: " ++ show old + in [LN lines'] @=? cursorProperties (execGo action cursor) + + , "fires propertiesModifiedEvent when changed" ~: + let lines = [Line (0,0) (0,1), Line (1,0) (1,1)] + lines' = [head lines] + cursor = rootCursor $ node [LN lines] + action = do + on propertiesModifiedEvent $ \old new -> tell [(old, new)] + modifyPropertyList propertyLN $ \old -> + if old == lines then lines' else error $ "Unexpected old value: " ++ show old + in [([LN lines], [LN lines'])] @=? execWriter (runGoT action cursor) + + , "doesn't fire propertiesModifiedEvent when not changed" ~: + let lines = [Line (0,0) (0,1), Line (1,0) (1,1)] + cursor = rootCursor $ node [LN lines] + action = do + on propertiesModifiedEvent $ \old new -> tell [(old, new)] + modifyPropertyList propertyLN id + in [] @=? execWriter (runGoT action cursor) + ] + modifyPropertyCoordsTests = "modifyPropertyCoords" ~: TestList [ "adds a property where there was none" ~: let cursor = rootCursor $ node [] @@ -562,6 +662,161 @@ cursorNode (execGo (modifyVariationMode fn) $ rootCursor $ node $ ST <$> maybeToList maybeInitialST) +getAssignedStoneTests = "getAssignedStone" ~: TestList + [ "should return Nothing for a point without an assignment" ~: + evalGo (getAssignedStone (0,0)) cursor @?= Nothing + + , "should return Nothing for an assignment in a parent node" ~: + evalGo (getAssignedStone (1,0)) cursor @?= Nothing + + , "should return Just for assigned points" ~: do + evalGo (getAssignedStone (2,0)) cursor @?= Just (Just Black) + evalGo (getAssignedStone (3,0)) cursor @?= Just (Just White) + evalGo (getAssignedStone (4,0)) cursor @?= Just Nothing + ] + where cursor = child 0 $ rootCursor $ + root 5 1 [AB $ coord1 (1,0), + AW $ coord1 (4,0)] + [node [AB $ coord1 (2,0), + AW $ coord1 (3,0), + AE $ coord1 (4,0)]] + +getAllAssignedStonesTests = "getAllAssignedStones" ~: TestList + [ "returns empty given no stone assignments" ~: do + Map.empty @=? evalGo getAllAssignedStones (rootCursor $ node []) + Map.empty @=? evalGo getAllAssignedStones (rootCursor $ node [B $ Just (0,0)]) + + , "ignores stone assignments in a parent node" ~: + Map.empty @=? + evalGo getAllAssignedStones (child 0 $ rootCursor $ root 1 1 [AB $ coord1 (0,0)] [node []]) + + , "finds a single stone assignment" ~: + Map.fromList [((0,0), Just Black)] @=? + evalGo getAllAssignedStones (rootCursor $ root 1 1 [AB $ coord1 (0,0)] []) + + , "finds multiple stone assignments" ~: + Map.fromList [((0,0), Just Black), + ((1,0), Just Black), + ((3,0), Just White), + ((4,0), Nothing), + ((5,0), Just Black)] @=? + evalGo getAllAssignedStones (rootCursor $ + root 6 1 [AB $ buildCoordList [(0,0), (1,0), (5,0)], + AW $ coord1 (3,0), + AE $ coord1 (4,0)] + []) + ] + +modifyAssignedStonesTests = "modifyAssignedStones" ~: TestList + [ "adds assignments to a node without" ~: + forM_ [Nothing, Just Black, Just White] $ \stone -> + test (rootCursor $ root 2 2 [] []) + (do modifyAssignedStones [(1,1)] $ const $ Just stone + getAllAssignedStones) + (Map.fromList [((1,1), stone)]) + noLogAssertion + + , "adds assignments to a node with existing assignments of the same type" ~: + test (rootCursor $ root 2 2 [AE $ coord1 (0,0)] []) + (do modifyAssignedStones [(0,1), (1,1)] $ const $ Just Nothing + getAllAssignedStones) + (Map.fromList [((0,0), Nothing), ((0,1), Nothing), ((1,1), Nothing)]) + noLogAssertion + + , "adds assignments to a node with existing assignments of a different type" ~: + test (rootCursor $ root 2 2 [AE $ coord1 (0,0)] []) + (do modifyAssignedStones [(0,1), (1,1)] $ const $ Just $ Just White + getAllAssignedStones) + (Map.fromList [((0,0), Nothing), ((0,1), Just White), ((1,1), Just White)]) + noLogAssertion + + , "assigning overwrites overlapping assignments of a different type" ~: + test (rootCursor $ root 2 2 [AE $ coord1 (0,0), AB $ coord1 (0,1), AW $ coord1 (1,1)] []) + (do modifyAssignedStones [(0,0), (0,1), (1,0), (1,1)] $ const $ Just $ Just White + getAllAssignedStones) + (Map.fromList $ (\coord -> (coord, Just White)) <$> [(0,0), (0,1), (1,0), (1,1)]) + noLogAssertion + + , "fires propertiesModifiedEvents when assignments change" ~: + test (rootCursor $ root 2 2 [AE $ coord1 (0,0), AB $ coord1 (0,1), AW $ coord1 (1,1)] []) + (do logPropertyChanges + modifyAssignedStones [(0,0), (0,1), (1,0), (1,1)] $ \old -> case old of + Just (Just color) -> Just $ Just $ cnot color + _ -> old) + () + (Just $ \log -> case log of + -- Expect two events, since we're swapping AB and AW. But don't + -- expect them in a particular order; just assert the start and end + -- states. + [(initial, _), (_, final)] -> + (initial, final) @=? ([AB $ coord1 (0,1), AE $ coord1 (0,0), AW $ coord1 (1,1)], + [AB $ coord1 (1,1), AE $ coord1 (0,0), AW $ coord1 (0,1)]) + _ -> assertFailure $ "Expected two events: " ++ show log) + + , "doesn't fire a propertiesModifiedEvent when assignments don't change" ~: + test (rootCursor $ root 2 2 [AE $ coord1 (0,0), AB $ coord1 (0,1), AW $ coord1 (1,1)] []) + (do on propertiesModifiedEvent $ \old new -> + tell [(sortBy (comparing propertyName) $ + filter ((`elem` ["AB", "AE", "AW"]) . propertyName) old, + sortBy (comparing propertyName) $ + filter ((`elem` ["AB", "AE", "AW"]) . propertyName) new)] + modifyAssignedStones [(0,0), (0,1), (1,0), (1,1)] id) + () + (Just (@?= [])) + + , "creates a child if the current node has a move property with no setup property" ~: + test (rootCursor $ root 2 1 [B $ Just (0,0)] []) + (do modifyAssignedStones [(1,0)] $ const $ Just $ Just White + goToRoot + cursorNode <$> getCursor) + (root 2 1 [B $ Just (0,0)] [node [AW $ coord1 (1,0)]]) + noLogAssertion + + , "doesn't create a child if the current node has a move property and a setup property" ~: + test (rootCursor $ root 3 1 [B $ Just (0,0), AB $ coord1 (1,0)] []) + (do logEventNames + modifyAssignedStones [(2,0)] $ const $ Just $ Just White + cursorNode <$> getCursor) + (root 3 1 [B $ Just (0,0), AB $ coord1 (1,0), AW $ coord1 (2,0)] []) + (Just (@?= ["Properties modified."])) + + , "fires the correct events when the current node has a move property" ~: + test (rootCursor $ root 2 1 [B $ Just (0,0)] []) + (do logEventNames + modifyAssignedStones [(1,0)] $ const $ Just $ Just White) + () + -- No propertiesModifiedEvent is fired: the child is added with the + -- assignment property already present. + (Just (@?= ["Child added.", "Navigated."])) + ] + where test :: (Eq a, Show a, Eq b, Monoid b, Show b) + => Cursor + -> GoT (Writer b) a + -> a + -> Maybe (b -> Assertion) + -> Assertion + test cursor action expected maybeLogAssertion = do + let (actual, log) = runWriter $ evalGoT action cursor + expected @=? actual + whenMaybe maybeLogAssertion ($ log) + + logPropertyChanges :: GoT (Writer [([Property], [Property])]) () + logPropertyChanges = + on propertiesModifiedEvent $ \old new -> + tell [(sortBy (comparing propertyName) $ + filter ((`elem` ["AB", "AE", "AW"]) . propertyName) old, + sortBy (comparing propertyName) $ + filter ((`elem` ["AB", "AE", "AW"]) . propertyName) new)] + + logEventNames :: GoT (Writer [String]) () + logEventNames = do + on0 childAddedEvent $ tell ["Child added."] + on0 navigationEvent $ tell ["Navigated."] + on0 propertiesModifiedEvent $ tell ["Properties modified."] + + noLogAssertion :: Maybe (() -> Assertion) + noLogAssertion = Nothing + getMarkTests = "getMark" ~: TestList [ "returns Nothing for no mark" ~: do Nothing @=? evalGo (getMark (0,0)) (rootCursor $ node []) @@ -681,7 +936,7 @@ [ "basic case just not needing updating" ~: let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] action = do pushPosition - goUp + True <- goUp addChildAt 1 $ node [W $ Just (0,0)] popPosition in cursorNode (execGo action cursor) @?= node [W Nothing] @@ -689,7 +944,7 @@ , "basic case just needing updating" ~: let cursor = child 0 $ rootCursor $ node' [B Nothing] [node [W Nothing]] action = do pushPosition - goUp + True <- goUp addChildAt 0 $ node [W $ Just (0,0)] popPosition in cursorNode (execGo action cursor) @?= node [W Nothing] @@ -697,9 +952,9 @@ , "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 + action = do True <- goDown 1 pushPosition - goUp + True <- goUp addChildAt 0 $ node [W Nothing] popPosition in cursorNode (execGo action cursor) @?= node [W $ Just (1,1)] @@ -710,13 +965,13 @@ 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 + action = do True <- and <$> sequence [goDown 1, goDown 2, goDown 3] pushPosition replicateM_ 3 goUp pushPosition - goDown 1 >> goDown 2 >> goDown 2 >> goUp >> goDown 1 + True <- and <$> sequence [goDown 1, goDown 2, goDown 2, goUp, goDown 1] addChildAt 0 $ node1 [] $ node [] - goDown 0 >> goDown 0 + True <- and <$> sequence [goDown 0, goDown 0] goToRoot popPosition popPosition @@ -725,8 +980,8 @@ , "updates paths with GoUp correctly" ~: let cursor = rootCursor $ node1 [B $ Just (0,0)] $ node [W $ Just (1,1)] action = do pushPosition - goDown 0 - goUp + True <- goDown 0 + True <- goUp addChildAt 0 $ node [B $ Just (2,2)] on navigationEvent $ \step -> tell [step] popPosition @@ -780,19 +1035,19 @@ , "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 + action = do True <- goDown 0 pushPosition - goUp - deleteChildAt 1 + True <- goUp + NodeDeleteOk <- 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 + action = do True <- goDown 1 pushPosition - goUp - deleteChildAt 0 + True <- goUp + NodeDeleteOk <- deleteChildAt 0 popPosition in cursorNode (execGo action cursor) @?= node [W $ Just (0,0)] @@ -800,10 +1055,10 @@ 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 + action = do True <- goDown 2 pushPosition - goUp - deleteChildAt 0 + True <- goUp + NodeDeleteOk <- deleteChildAt 0 popPosition in cursorNode (execGo action cursor) @?= node [W $ Just (2,2)] @@ -813,30 +1068,34 @@ 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 + action = do True <- and <$> sequence [goDown 1, goDown 2, goDown 3] pushPosition - goUp - deleteChildAt 1 + True <- goUp + NodeDeleteOk <- deleteChildAt 1 pushPosition - goToRoot >> goDown 0 >> goDown 2 + goToRoot + True <- goDown 0 + True <- goDown 2 pushPosition - goUp - deleteChildAt 0 - goToRoot >> goDown 1 >> goDown 2 - deleteChildAt 1 + True <- goUp + NodeDeleteOk <- deleteChildAt 0 + goToRoot + True <- goDown 1 + True <- goDown 2 + NodeDeleteOk <- 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 + action = do True <- goDown 1 pushPosition - goUp + True <- goUp pushPosition - goDown 0 + True <- goDown 0 pushPosition - goUp + True <- goUp deleteChildAt 1 in second cursorNode (runGo action $ rootCursor base) @?= (NodeDeleteOnPathStack, base) @@ -849,7 +1108,8 @@ node1 [B $ Just (0,0)] $ node [W $ Just (0,0), GN $ toSimpleText "Foo"] action = do on gameInfoChangedEvent onInfo - goDown 0 + True <- goDown 0 + return () in execWriter (runGoT action cursor) @?= [(Nothing, Just $ toSimpleText "Foo")] , "fires when navigating up" ~: @@ -857,7 +1117,8 @@ node1 [B $ Just (0,0)] $ node [W $ Just (0,0), GN $ toSimpleText "Foo"] action = do on gameInfoChangedEvent onInfo - goUp + True <- goUp + return () in execWriter (runGoT action cursor) @?= [(Just $ toSimpleText "Foo", Nothing)] , "fires from within popPosition" ~: @@ -865,8 +1126,8 @@ node1 [B $ Just (0,0)] $ node [W $ Just (0,0), GN $ toSimpleText "Foo"] action = do pushPosition - goDown 0 - goUp + True <- goDown 0 + True <- goUp on gameInfoChangedEvent onInfo popPosition in execWriter (runGoT action cursor) @?= @@ -875,9 +1136,9 @@ , "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 [] + modifyProperties $ const [GN $ toSimpleText "Foo"] + modifyProperties $ const [GN $ toSimpleText "Bar"] + modifyProperties $ const [] in execWriter (runGoT action cursor) @?= [(Nothing, Just $ toSimpleText "Foo"), (Just $ toSimpleText "Foo", Just $ toSimpleText "Bar"), diff --git a/tests/Game/Goatee/Lib/ParserTestUtils.hs b/tests/Game/Goatee/Lib/ParserTestUtils.hs --- a/tests/Game/Goatee/Lib/ParserTestUtils.hs +++ b/tests/Game/Goatee/Lib/ParserTestUtils.hs @@ -35,7 +35,7 @@ parseOrFail input cont = case parseString input of Left error -> assertFailure $ "Failed to parse SGF: " ++ error Right (Collection roots) -> case roots of - root:[] -> cont root + [root] -> cont root _ -> assertFailure $ "Expected a single root node, got: " ++ show roots -- Parses a string as a complete SGF document and expects failure. diff --git a/tests/Game/Goatee/Lib/Property/ParserTest.hs b/tests/Game/Goatee/Lib/Property/ParserTest.hs --- a/tests/Game/Goatee/Lib/Property/ParserTest.hs +++ b/tests/Game/Goatee/Lib/Property/ParserTest.hs @@ -23,6 +23,7 @@ import Game.Goatee.Common import Game.Goatee.Lib.ParserTestUtils import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Property.Parser import Game.Goatee.Lib.TestInstances () import Game.Goatee.Lib.TestUtils import Game.Goatee.Lib.Types diff --git a/tests/Game/Goatee/Lib/PropertyTest.hs b/tests/Game/Goatee/Lib/PropertyTest.hs --- a/tests/Game/Goatee/Lib/PropertyTest.hs +++ b/tests/Game/Goatee/Lib/PropertyTest.hs @@ -34,27 +34,40 @@ , "root properties" ~: rootProperties @=? filterTo RootProperty allProperties , "setup properties" ~: setupProperties @=? filterTo SetupProperty allProperties - , "inherited properties" ~: [DD cl] @=? filter propertyInherited allProperties + , "inherited properties" ~: [DD cl, VW 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] + moveProperties = [ -- Move properties. + B Nothing, KO, MN 1, W Nothing + -- Move annotation properties. + , BM db, DO, IT, TE db + -- Timing properties. + , BL rv, OB 1, OW 1, WL rv + ] + 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 + -- Miscellaneous properties. + , VW cl + -- Go-specific properties. + , TB cl, TW 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 + -- Go-specific properties. + , HA 1, KM rv + ] allProperties = moveProperties ++ setupProperties ++ generalProperties ++ rootProperties ++ gameInfoProperties cl = emptyCoordList diff --git a/tests/Game/Goatee/Lib/TestUtils.hs b/tests/Game/Goatee/Lib/TestUtils.hs --- a/tests/Game/Goatee/Lib/TestUtils.hs +++ b/tests/Game/Goatee/Lib/TestUtils.hs @@ -25,8 +25,8 @@ sortProperties, ) where -import Data.Function (on) import Data.List (sortBy) +import Data.Ord (comparing) import Game.Goatee.Lib.Board import Game.Goatee.Lib.Property import Game.Goatee.Lib.Tree @@ -59,4 +59,4 @@ -- -- TODO Probably better to have a compare-unordered operator. sortProperties :: [Property] -> [Property] -sortProperties = sortBy (compare `on` show) +sortProperties = sortBy $ comparing show diff --git a/tests/Game/Goatee/Lib/TypesTest.hs b/tests/Game/Goatee/Lib/TypesTest.hs --- a/tests/Game/Goatee/Lib/TypesTest.hs +++ b/tests/Game/Goatee/Lib/TypesTest.hs @@ -30,6 +30,7 @@ , handicapStonesTests , simpleTextTests , cnotTests + , lineTests ] expandCoordListTests = "expandCoordList" ~: TestList @@ -237,4 +238,17 @@ cnotTests = "cnot" ~: TestList [ "changes Black to White" ~: White @=? cnot Black , "changes White to Black" ~: Black @=? cnot White + ] + +lineTests = "Line" ~: TestList + [ "Eq instance" ~: TestList + [ "Line a b == Line a b" ~: Line (1,2) (3,4) @=? Line (1,2) (3,4) + , "Line a b == Line b a" ~: Line (1,2) (3,4) @=? Line (3,4) (1,2) + , "Line a b /= Line c b" ~: do Line (1,2) (3,4) @/=? Line (0,2) (3,4) + Line (1,2) (3,4) @/=? Line (1,0) (3,4) + , "Line a b /= Line a c" ~: do Line (1,2) (3,4) @/=? Line (1,2) (0,4) + Line (1,2) (3,4) @/=? Line (1,2) (3,0) + ] + , "lineToPair" ~: + ((10,2), (5,7)) @=? lineToPair (Line (10,2) (5,7)) ]