goatee 0.2.0 → 0.3.0

raw patch · 24 files changed

+1190/−412 lines, 24 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• goatee.cabal +4/−4
• src/Game/Goatee/App.hs +2/−2
• src/Game/Goatee/Common.hs +10/−0
• src/Game/Goatee/Common/Bigfloat.hs +2/−2
• src/Game/Goatee/Lib/Board.hs +135/−60
• src/Game/Goatee/Lib/Monad.hs +223/−53
• src/Game/Goatee/Lib/Parser.hs +3/−3
• src/Game/Goatee/Lib/Property.hs +4/−7
• src/Game/Goatee/Lib/Property/Base.hs +58/−26
• src/Game/Goatee/Lib/Property/Info.hs +273/−151
• src/Game/Goatee/Lib/Property/Parser.hs +11/−9
• src/Game/Goatee/Lib/Property/Renderer.hs +10/−0
• src/Game/Goatee/Lib/Property/Value.hs +10/−1
• src/Game/Goatee/Lib/Renderer/Tree.hs +1/−1
• src/Game/Goatee/Lib/Tree.hs +5/−4
• src/Game/Goatee/Lib/Types.hs +18/−7
• tests/Game/Goatee/CommonTest.hs +17/−0
• tests/Game/Goatee/Lib/BoardTest.hs +36/−3
• tests/Game/Goatee/Lib/MonadTest.hs +318/−57
• tests/Game/Goatee/Lib/ParserTestUtils.hs +1/−1
• tests/Game/Goatee/Lib/Property/ParserTest.hs +1/−0
• tests/Game/Goatee/Lib/PropertyTest.hs +32/−19
• tests/Game/Goatee/Lib/TestUtils.hs +2/−2
• tests/Game/Goatee/Lib/TypesTest.hs +14/−0

@@ -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 <bog@khumba.net> maintainer: Bryan Gardiner <bog@khumba.net> 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:

@@ -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

@@ -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 ()

@@ -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 (+)

@@ -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.

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

@@ -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 })

@@ -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

@@ -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) --

@@ -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

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

@@ -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

@@ -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)

@@ -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 ")"

@@ -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) $

@@ -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

@@ -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

@@ -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

@@ -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"),

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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))   ]