goatee 0.1.1 → 0.2.0

raw patch · 55 files changed

+7056/−6040 lines, 55 filesdep −test-frameworkdep −test-framework-hunitdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies removed: test-framework, test-framework-hunit

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• goatee.cabal +34/−36
• src/Game/Goatee/Common.hs +12/−40
• src/Game/Goatee/Common/Bigfloat.hs +183/−0
• src/Game/Goatee/Lib/Board.hs +768/−0
• src/Game/Goatee/Lib/Monad.hs +793/−0
• src/Game/Goatee/Lib/Parser.hs +129/−0
• src/Game/Goatee/Lib/Property.hs +28/−0
• src/Game/Goatee/Lib/Property/Base.hs +327/−0
• src/Game/Goatee/Lib/Property/Info.hs +320/−0
• src/Game/Goatee/Lib/Property/Parser.hs +252/−0
• src/Game/Goatee/Lib/Property/Renderer.hs +332/−0
• src/Game/Goatee/Lib/Property/Value.hs +179/−0
• src/Game/Goatee/Lib/Renderer.hs +56/−0
• src/Game/Goatee/Lib/Renderer/Tree.hs +60/−0
• src/Game/Goatee/Lib/Tree.hs +188/−0
• src/Game/Goatee/Lib/Types.hs +505/−0
• src/Game/Goatee/Sgf/Board.hs +0/−792
• src/Game/Goatee/Sgf/Monad.hs +0/−690
• src/Game/Goatee/Sgf/Parser.hs +0/−113
• src/Game/Goatee/Sgf/Property.hs +0/−27
• src/Game/Goatee/Sgf/Property/Base.hs +0/−314
• src/Game/Goatee/Sgf/Property/Info.hs +0/−288
• src/Game/Goatee/Sgf/Property/Parser.hs +0/−275
• src/Game/Goatee/Sgf/Property/Renderer.hs +0/−326
• src/Game/Goatee/Sgf/Property/Value.hs +0/−179
• src/Game/Goatee/Sgf/Renderer.hs +0/−56
• src/Game/Goatee/Sgf/Renderer/Tree.hs +0/−56
• src/Game/Goatee/Sgf/Tree.hs +0/−175
• src/Game/Goatee/Sgf/Types.hs +0/−389
• tests/Game/Goatee/Common/BigfloatTest.hs +269/−0
• tests/Game/Goatee/CommonTest.hs +120/−131
• tests/Game/Goatee/Lib/BoardTest.hs +195/−0
• tests/Game/Goatee/Lib/MonadTest.hs +886/−0
• tests/Game/Goatee/Lib/ParserTest.hs +240/−0
• tests/Game/Goatee/Lib/ParserTestUtils.hs +63/−0
• tests/Game/Goatee/Lib/Property/ParserTest.hs +388/−0
• tests/Game/Goatee/Lib/PropertyTest.hs +72/−0
• tests/Game/Goatee/Lib/RoundTripTest.hs +103/−0
• tests/Game/Goatee/Lib/TestInstances.hs +25/−0
• tests/Game/Goatee/Lib/TestUtils.hs +62/−0
• tests/Game/Goatee/Lib/TreeTest.hs +184/−0
• tests/Game/Goatee/Lib/TypesTest.hs +240/−0
• tests/Game/Goatee/Sgf/BoardTest.hs +0/−195
• tests/Game/Goatee/Sgf/MonadTest.hs +0/−736
• tests/Game/Goatee/Sgf/ParserTest.hs +0/−242
• tests/Game/Goatee/Sgf/ParserTestUtils.hs +0/−63
• tests/Game/Goatee/Sgf/Property/ParserTest.hs +0/−391
• tests/Game/Goatee/Sgf/PropertyTest.hs +0/−74
• tests/Game/Goatee/Sgf/RoundTripTest.hs +0/−85
• tests/Game/Goatee/Sgf/TestInstances.hs +0/−25
• tests/Game/Goatee/Sgf/TestUtils.hs +0/−61
• tests/Game/Goatee/Sgf/TreeTest.hs +0/−114
• tests/Game/Goatee/Sgf/TypesTest.hs +0/−146
• tests/Game/Goatee/Test/Common.hs +14/−1
• tests/Test.hs +29/−20

@@ -1,5 +1,5 @@ name: goatee-version: 0.1.1+version: 0.2.0 synopsis: A monadic take on a 2,500-year-old board game - library. category: Game license: AGPL-3@@ -14,13 +14,11 @@ build-type: Simple data-files: LICENSE description:-    Goatee is a Go library and game editor, written in Haskell.  It provides a GUI-    for recording, studying, and editing game records.  Underneath this is a-    portable library for manipulating SGF files, to build UIs and tools.-    .-    Goatee, the library and GUI, aims to be full-featured, supporting all of the SGF-    spec and allowing for full customization of the game records you create.-    Currently it is in an alpha stage, supporting basic game viewing and editing.+    Goatee is a Go library and game editor, written in Haskell.  It provides a+    GUI for recording, studying, and editing game records.  Underneath this is a+    portable library for manipulating SGF files to build UIs and tools.  Goatee+    aims to be full-featured by supporting all of the SGF spec and allowing for+    full and easy customization of the game records you create.     .     This package is the shared library. @@ -34,19 +32,20 @@         containers >= 0.4 && < 0.6,         mtl >= 2.1 && < 2.3,         parsec >= 3.1 && < 3.2,-        template-haskell >= 2.7 && < 2.9+        template-haskell >= 2.7 && < 3.0     exposed-modules:         Game.Goatee.App         Game.Goatee.Common-        Game.Goatee.Sgf.Board-        Game.Goatee.Sgf.Monad-        Game.Goatee.Sgf.Parser-        Game.Goatee.Sgf.Property-        Game.Goatee.Sgf.Property.Parser-        Game.Goatee.Sgf.Renderer-        Game.Goatee.Sgf.Renderer.Tree-        Game.Goatee.Sgf.Tree-        Game.Goatee.Sgf.Types+        Game.Goatee.Common.Bigfloat+        Game.Goatee.Lib.Board+        Game.Goatee.Lib.Monad+        Game.Goatee.Lib.Parser+        Game.Goatee.Lib.Property+        Game.Goatee.Lib.Property.Parser+        Game.Goatee.Lib.Renderer+        Game.Goatee.Lib.Renderer.Tree+        Game.Goatee.Lib.Tree+        Game.Goatee.Lib.Types     extensions:         ExistentialQuantification         FlexibleContexts@@ -57,10 +56,10 @@     ghc-options: -W -fwarn-incomplete-patterns     hs-source-dirs: src     other-modules:-        Game.Goatee.Sgf.Property.Base-        Game.Goatee.Sgf.Property.Info-        Game.Goatee.Sgf.Property.Renderer-        Game.Goatee.Sgf.Property.Value+        Game.Goatee.Lib.Property.Base+        Game.Goatee.Lib.Property.Info+        Game.Goatee.Lib.Property.Renderer+        Game.Goatee.Lib.Property.Value         Paths_goatee  test-suite test-goatee@@ -70,25 +69,24 @@         goatee,         HUnit >= 1.2 && < 1.3,         mtl >= 2.1 && < 2.3,-        parsec >= 3.1 && < 3.2,-        test-framework >= 0.6 && < 0.9,-        test-framework-hunit >= 0.2 && < 0.4+        parsec >= 3.1 && < 3.2     ghc-options: -W -fwarn-incomplete-patterns     hs-source-dirs: tests     main-is: Test.hs     other-modules:+        Game.Goatee.Common.BigfloatTest         Game.Goatee.CommonTest-        Game.Goatee.Sgf.BoardTest-        Game.Goatee.Sgf.MonadTest-        Game.Goatee.Sgf.ParserTest-        Game.Goatee.Sgf.ParserTestUtils-        Game.Goatee.Sgf.Property.ParserTest-        Game.Goatee.Sgf.PropertyTest-        Game.Goatee.Sgf.RoundTripTest-        Game.Goatee.Sgf.TestInstances-        Game.Goatee.Sgf.TestUtils-        Game.Goatee.Sgf.TreeTest-        Game.Goatee.Sgf.TypesTest+        Game.Goatee.Lib.BoardTest+        Game.Goatee.Lib.MonadTest+        Game.Goatee.Lib.ParserTest+        Game.Goatee.Lib.ParserTestUtils+        Game.Goatee.Lib.Property.ParserTest+        Game.Goatee.Lib.PropertyTest+        Game.Goatee.Lib.RoundTripTest+        Game.Goatee.Lib.TestInstances+        Game.Goatee.Lib.TestUtils+        Game.Goatee.Lib.TreeTest+        Game.Goatee.Lib.TypesTest         Game.Goatee.Test.Common         Test     type: exitcode-stdio-1.0

@@ -17,13 +17,10 @@  -- | Common utilities used throughout the project. module Game.Goatee.Common (-  listDeleteIndex,+  listDeleteAt,+  listInsertAt,   listReplace,   listUpdate,-  fromLeft,-  fromRight,-  onLeft,-  onRight,   andEithers,   for,   mapTuple,@@ -35,19 +32,25 @@   whileM,   whileM',   doWhileM,-  Seq(..),   ) where  import Control.Arrow ((***)) import Control.Monad (forM_, join, when) import Data.Either (partitionEithers)-import Data.Monoid (Monoid, mempty, mappend)  -- | Drops the element at an index from a list.  If the index is out of bounds -- then the list is returned unmodified.-listDeleteIndex :: Int -> [a] -> [a]-listDeleteIndex index list = take index list ++ drop (index + 1) list+listDeleteAt :: Int -> [a] -> [a]+listDeleteAt index list = take index list ++ drop (index + 1) list +-- | Inserts the element into the list before the given position.  If the+-- position is less than 0 or greater than the length of the list, then the+-- index is clamped to this range.+listInsertAt :: Int -> a -> [a] -> [a]+listInsertAt index x xs =+  let (before, after) = splitAt index xs+  in before ++ x : after+ -- | @listReplace old new list@ replaces all occurrences of @old@ with @new@ in -- @list@. listReplace :: Eq a => a -> a -> [a] -> [a]@@ -62,27 +65,6 @@         listSet' _ _ = error ("Cannot update index " ++ show ix ++                               " of list " ++ show xs ++ ".") --- | Extracts a left value from an 'Either'.-fromLeft :: Either a b -> a-fromLeft (Left a) = a-fromLeft _ = error "fromLeft given a Right."---- | Extracts a right value from an 'Either'.-fromRight :: Either a b -> b-fromRight (Right b) = b-fromRight _ = error "fromRight given a Left."---- | Transforms the left value of an 'Either', leaving a right value alone.-onLeft :: (a -> c) -> Either a b -> Either c b-f `onLeft` e = case e of-  Left x -> Left $ f x-  Right y -> Right y---- | Transforms the right value of an 'Either', leaving a left value alone.--- This is just 'fmap', but looks nicer when used beside 'onLeft'.-onRight :: (b -> c) -> Either a b -> Either a c-onRight = fmap- -- | If any item is a 'Left', then the list of 'Left's is returned, otherwise -- the list of 'Right's is returned. andEithers :: [Either a b] -> Either [a] [b]@@ -148,13 +130,3 @@   case value of     Right next -> doWhileM next body     Left end -> return end---- | This sequences @()@-valued monadic actions as a monoid.  If @m@ is some--- monad, then @Seq m@ is a monoid where 'mempty' does nothing and 'mappend'--- sequences actions via '>>'.-newtype Seq m = Seq (m ())--instance Monad m => Monoid (Seq m) where-  mempty = Seq $ return ()--  (Seq x) `mappend` (Seq y) = Seq (x >> y)

@@ -0,0 +1,183 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Base-10 arbitrary-precision floating-point numbers.+module Game.Goatee.Common.Bigfloat (+  Bigfloat, encode,+  significand, exponent,+  fromDouble, toDouble,+  ) where++import Data.Char (isDigit, isSpace)+import Data.Function (on)+import Prelude hiding (exponent, significand)++-- | A base-10, infinite-precision, floating-point number.  Implemented as an+-- infinite-precision significand together with an exponent, such that the+-- numeric value is equal to @'significand' f * (10 ^ 'exponent' f)@.  The+-- exponent is a limited-precision 'Int', because some operations may break if+-- the exponent is larger (specifically 'show' and 'toDouble').  This shouldn't+-- be an issue for Goatee.+--+-- These values form an integral domain.+--+-- The 'Show' instance always outputs in decimal notation, never scientific+-- notation.  Examples:+--+-- > 300   (never trailing .0 if there's no fractional part)+-- > 0.1   (never redundant trailing or leading zeros)+--+-- Similarly, the 'Read' instance accepts numbers matching the regex+-- @-?\\d+(\\.\\d+)?(e-?\\d+)?@.  Scientific exponent notation is supported for+-- reading, for ease of converting 'Double's to 'Bigfloat's.+data Bigfloat = Bigfloat+  { significand :: !Integer+  , exponent :: !Int+  }++zero, one, negOne :: Bigfloat+zero = Bigfloat 0 0+one = Bigfloat 1 0+negOne = Bigfloat (-1) 0++instance Eq Bigfloat where+  x == y = let (Bigfloat xv xe, Bigfloat yv ye) = normalize2 x y+           in xe == ye && xv == yv++instance Ord Bigfloat where+  compare = (uncurry (compare `on` significand) .) . normalize2++instance Num Bigfloat where+  (+) = lift2 (+)+  (-) = lift2 (-)+  Bigfloat xv xe * Bigfloat yv ye = reduce $ Bigfloat (xv * yv) (xe + ye)+  negate (Bigfloat v e) = Bigfloat (-v) e+  abs x@(Bigfloat v e) = if v >= 0 then x else Bigfloat (-v) e+  signum (Bigfloat v _)+    | v == 0 = zero+    | v > 0 = one+    | otherwise = negOne+  fromInteger v = reduce $ Bigfloat v 0++instance Show Bigfloat where+  show (Bigfloat v e) =+    let (addSign, vs) = if v >= 0+                        then (id, show v)+                        else (('-':), show (-v))+        vl = length vs+    in addSign $ case e of+      0 -> vs+      e | e > 0 -> vs ++ replicate e '0'+        | e <= -vl -> '0' : '.' : replicate ((-e) - vl) '0' ++ vs+      _ -> let (hd, tl) = splitAt (vl + e) vs+           in hd ++ '.' : tl++instance Read Bigfloat where+  readsPrec _ s =+    let (s', neg) = case s of+          '-':s' -> (s', True)+          _ -> (s, False)+        (whole, s'') = span isDigit s'+    in if null whole+       then []+       else case s'' of+         '.':s''' -> let (fractional, s'''') = span isDigit s'''+                     in if null fractional+                        then []+                        else succeedIfTerminatedProperly neg whole fractional s''''+         s''' -> succeedIfTerminatedProperly neg whole [] s'''+    where succeedIfTerminatedProperly neg whole fractional rest =+            let makeResult exp =+                  encode (fromInteger $+                          read $+                          (if neg then ('-':) else id) $+                          whole ++ fractional)+                         (-length fractional + exp)+            in if isValidEndOfNumber rest+               then [(makeResult 0, rest)]+               else case rest of+                 'e':exps -> let (addExpNeg, exps') = case exps of+                                   '-':exps' -> (('-':), exps')+                                   _ -> (id, exps)+                                 (hd, tl) = span isDigit exps'+                             in if null hd+                                then []+                                else let exp = read (addExpNeg exps') :: Int+                                     in [(makeResult exp, tl) | isValidEndOfNumber tl]+                 _ -> []+          isValidEndOfNumber rest = case rest of+            [] -> True+            c:_ | isSpace c -> True+            _ -> False++-- | @encode significand exponent@ creates a 'Bigfloat' value whose numeric+-- value is @significand * (10 ^ exponent)@.+encode :: Integer -> Int -> Bigfloat+encode = (reduce .) . Bigfloat++-- | Converts a 'Double' to a 'Bigfloat' (with as much precision as the 'Double'+-- 'Show' instance provides).+fromDouble :: Double -> Bigfloat+fromDouble = read . show++-- | Converts a 'Bigfloat' to a 'Double', lossily.+toDouble :: Bigfloat -> Double+toDouble = read . show++-- | @shift amount float@ adds @shift@ zeros onto the right side of @float@'s+-- numerator while keeping the numeric value the same.  @amount@ must be+-- non-negative.+shift :: Int -> Bigfloat -> Bigfloat+shift amount float@(Bigfloat v e) =+  if amount < 0+  then error $ "bigfloatShift: Can't shift by a negative amount.  amount = " +++       show amount ++ ", float = " ++ show float+  else Bigfloat (v * 10 ^ amount) (e - amount)++-- | Reduces a 'Bigfloat' to canonical form, keeping the numeric value the same+-- but removing trailing zeros from the numerator.+reduce :: Bigfloat -> Bigfloat+reduce x@(Bigfloat v e) =+  if v == 0+  then zero+  else let zeros = length $ takeWhile (== '0') $ reverse $ show v+       in if zeros == 0+          then x+          else Bigfloat (v `div` (10 ^ zeros)) (e + zeros)++-- | Converts two 'Bigfloat's so that they have the same number of decimal+-- places, so that 'Integer' arithmetic may be performed directly on their+-- 'significand's.+normalize2 :: Bigfloat -> Bigfloat -> (Bigfloat, Bigfloat)+normalize2 x y =+  let xe = exponent x+      ye = exponent y+  in if xe == ye+     then (x, y)+     else if xe < ye+          then (x, shift (ye - xe) y)+          else (shift (xe - ye) x, y)++-- | Lifts a function on two 'Integer's to a function on 'Bigfloat's.+--+-- This is not exported from this module because it's not a general lift+-- function: the given function only operates on the significands, so operations+-- that require the exponent (such as multiplication) can't use this function.+lift2 :: (Integer -> Integer -> Integer) -> Bigfloat -> Bigfloat -> Bigfloat+lift2 f x y =+  let (Bigfloat xv xe, Bigfloat yv _) = normalize2 x y+  in reduce $ Bigfloat (f xv yv) xe

@@ -0,0 +1,768 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Data structures that wrap and provide a higher-level interface to the SGF+-- game tree, including a zipper that navigates the tree and provides the+-- current board state.+module Game.Goatee.Lib.Board (+  RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode,+  gameInfoToProperties,+  BoardState(..), boardWidth, boardHeight,+  CoordState(..), rootBoardState, boardCoordState, mapBoardCoords,+  isValidMove, isCurrentValidMove,+  Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren,+  cursorChildCount, cursorChildPlayingAt, cursorProperties,+  cursorModifyNode,+  cursorVariations,+  moveToProperty,+  ) where++import Control.Monad (unless, when)+import Control.Monad.Writer (execWriter, tell)+import Data.List (find, intercalate, nub)+import Data.Maybe (fromMaybe, isJust, isNothing)+import qualified Data.Set as Set+import Game.Goatee.Common+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Tree+import Game.Goatee.Lib.Types++-- TODO Stop using errors everywhere, they're not testable.++-- | Properties that are specified in the root nodes of game trees.+data RootInfo = RootInfo+  { rootInfoWidth :: Int+  , rootInfoHeight :: Int+  , rootInfoVariationMode :: VariationMode+  } deriving (Eq, Show)++-- | Properties that are specified in game info nodes.+data GameInfo = GameInfo+  { gameInfoRootInfo :: RootInfo++  , gameInfoBlackName :: Maybe SimpleText+  , gameInfoBlackTeamName :: Maybe SimpleText+  , gameInfoBlackRank :: Maybe SimpleText++  , gameInfoWhiteName :: Maybe SimpleText+  , gameInfoWhiteTeamName :: Maybe SimpleText+  , gameInfoWhiteRank :: Maybe SimpleText++  , gameInfoRuleset :: Maybe Ruleset+  , gameInfoBasicTimeSeconds :: Maybe RealValue+  , gameInfoOvertime :: Maybe SimpleText+  , gameInfoResult :: Maybe GameResult++  , gameInfoGameName :: Maybe SimpleText+  , gameInfoGameComment :: Maybe Text+  , gameInfoOpeningComment :: Maybe SimpleText++  , gameInfoEvent :: Maybe SimpleText+  , gameInfoRound :: Maybe SimpleText+  , gameInfoPlace :: Maybe SimpleText+  , gameInfoDatesPlayed :: Maybe SimpleText+  , gameInfoSource :: Maybe SimpleText+  , gameInfoCopyright :: Maybe SimpleText++  , gameInfoAnnotatorName :: Maybe SimpleText+  , gameInfoEntererName :: Maybe SimpleText+  } deriving (Show)++-- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data.+emptyGameInfo :: RootInfo -> GameInfo+emptyGameInfo rootInfo = GameInfo+  { gameInfoRootInfo = rootInfo++  , gameInfoBlackName = Nothing+  , gameInfoBlackTeamName = Nothing+  , gameInfoBlackRank = Nothing++  , gameInfoWhiteName = Nothing+  , gameInfoWhiteTeamName = Nothing+  , gameInfoWhiteRank = Nothing++  , gameInfoRuleset = Nothing+  , gameInfoBasicTimeSeconds = Nothing+  , gameInfoOvertime = Nothing+  , gameInfoResult = Nothing++  , gameInfoGameName = Nothing+  , gameInfoGameComment = Nothing+  , gameInfoOpeningComment = Nothing++  , gameInfoEvent = Nothing+  , gameInfoRound = Nothing+  , gameInfoPlace = Nothing+  , gameInfoDatesPlayed = Nothing+  , gameInfoSource = Nothing+  , gameInfoCopyright = Nothing++  , gameInfoAnnotatorName = Nothing+  , gameInfoEntererName = Nothing+  }++-- | Returns whether a node contains any game info properties.+internalIsGameInfoNode :: Node -> Bool+internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties++-- | Converts a 'GameInfo' into a list of 'Property's that can be used to+-- reconstruct the 'GameInfo'.+gameInfoToProperties :: GameInfo -> [Property]+gameInfoToProperties info = execWriter $ do+  copy PB gameInfoBlackName+  copy BT gameInfoBlackTeamName+  copy BR gameInfoBlackRank++  copy PW gameInfoWhiteName+  copy WT gameInfoWhiteTeamName+  copy WR gameInfoWhiteRank++  copy RU gameInfoRuleset+  copy TM gameInfoBasicTimeSeconds+  copy OT gameInfoOvertime+  copy RE gameInfoResult++  copy GN gameInfoGameName+  copy GC gameInfoGameComment+  copy ON gameInfoOpeningComment++  copy EV gameInfoEvent+  copy RO gameInfoRound+  copy PC gameInfoPlace+  copy DT gameInfoDatesPlayed+  copy SO gameInfoSource+  copy CP gameInfoCopyright++  copy AN gameInfoAnnotatorName+  copy US gameInfoEntererName+  where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x]++-- | An object that corresponds to a node in some game tree, and represents the+-- state of the game at that node, including board position, player turn and+-- captures, and also board annotations.+data BoardState = BoardState+  { boardCoordStates :: [[CoordState]]+    -- ^ The state of individual points on the board.  Stored in row-major order.+    -- Point @(x, y)@ can be accessed via @!! y !! x@ (but prefer+    -- 'boardCoordState').+  , boardHasInvisible :: Bool+    -- ^ Whether any of the board's 'CoordState's are invisible.  This is an+    -- optimization to make it more efficient to set the board to "all visible."+  , boardHasDimmed :: Bool+    -- ^ Whether any of the board's 'CoordState's are dimmed.  This is an+    -- optimization to make it more efficient to clear all dimming from the+    -- board.+  , boardArrows :: ArrowList+  , boardLines :: LineList+  , boardLabels :: LabelList+  , boardMoveNumber :: Integer+  , boardPlayerTurn :: Color+  , boardBlackCaptures :: Int+  , boardWhiteCaptures :: Int+  , boardGameInfo :: GameInfo+  }++instance Show BoardState where+  show board = concat $ execWriter $ do+    tell ["Board: (Move ", show (boardMoveNumber board),+          ", ", show (boardPlayerTurn board), "'s turn, B:",+          show (boardBlackCaptures board), ", W:",+          show (boardWhiteCaptures board), ")\n"]+    tell [intercalate "\n" $ flip map (boardCoordStates board) $+          \row -> unwords $ map show row]++    let arrows = boardArrows board+    let lines = boardLines board+    let labels = boardLabels board+    unless (null arrows) $ tell ["\nArrows: ", show arrows]+    unless (null lines) $ tell ["\nLines: ", show lines]+    unless (null labels) $ tell ["\nLabels: ", show labels]++-- | Returns the width of the board, in stones.+boardWidth :: BoardState -> Int+boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo++-- | Returns the height of the board, in stones.+boardHeight :: BoardState -> Int+boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo++-- | Used by 'BoardState' to represent the state of a single point on the board.+-- Records whether a stone is present, as well as annotations and visibility+-- properties.+data CoordState = CoordState+  { coordStar :: Bool+    -- ^ Whether this point is a star point.+  , coordStone :: Maybe Color+  , coordMark :: Maybe Mark+  , coordVisible :: Bool+  , coordDimmed :: Bool+  }++instance Show CoordState where+  show c = if not $ coordVisible c+           then "--"+           else let stoneChar = case coordStone c of+                      Nothing -> if coordStar c then '*' else '\''+                      Just Black -> 'X'+                      Just White -> 'O'+                    markChar = case coordMark c of+                      Nothing -> ' '+                      Just MarkCircle -> 'o'+                      Just MarkSquare -> 's'+                      Just MarkTriangle -> 'v'+                      Just MarkX -> 'x'+                      Just MarkSelected -> '!'+                in [stoneChar, markChar]++-- | Creates a 'BoardState' for an empty board of the given width and height.+emptyBoardState :: Int -> Int -> BoardState+emptyBoardState width height = BoardState+  { boardCoordStates = coords+  , boardHasInvisible = False+  , boardHasDimmed = False+  , boardArrows = []+  , boardLines = []+  , boardLabels = []+  , boardMoveNumber = 0+  , boardPlayerTurn = Black+  , boardBlackCaptures = 0+  , boardWhiteCaptures = 0+  , boardGameInfo = emptyGameInfo rootInfo+  }+  where rootInfo = RootInfo { rootInfoWidth = width+                            , rootInfoHeight = height+                            , rootInfoVariationMode = defaultVariationMode+                            }+        emptyCoord = CoordState { coordStar = False+                                , coordStone = Nothing+                                , coordMark = Nothing+                                , coordVisible = True+                                , coordDimmed = False+                                }+        starCoord = emptyCoord { coordStar = True }+        isStarPoint' = isStarPoint width height+        coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord)+                                [0..width-1])+                     [0..height-1]++rootBoardState :: Node -> BoardState+rootBoardState rootNode =+  foldr applyProperty+        (emptyBoardState width height)+        (nodeProperties rootNode)+  where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $+                          findProperty propertySZ rootNode++-- | Returns the 'CoordState' for a coordinate on a board.+boardCoordState :: Coord -> BoardState -> CoordState+boardCoordState (x, y) board = boardCoordStates board !! y !! x++-- | Maps a function over each 'CoordState' in a 'BoardState', returning a+-- list-of-lists with the function's values.  The function is called like @fn y+-- x coordState@.+mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]]+mapBoardCoords fn board =+  zipWith applyRow [0..] $ boardCoordStates board+  where applyRow y = zipWith (fn y) [0..]++-- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a+-- 'BoardState'.+updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState+updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo ->+  gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo }++-- | Applies a function to update the 'GameInfo' of a 'BoardState'.+updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState+updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board }++-- | Performs necessary updates to a 'BoardState' between nodes in the tree.+-- Clears marks.+boardChild :: BoardState -> BoardState+boardChild board =+  board { boardCoordStates = map (map clearMark) $ boardCoordStates board+        , boardArrows = []+        , boardLines = []+        , boardLabels = []+        }+  where clearMark coord = case coordMark coord of+          Nothing -> coord+          Just _ -> coord { coordMark = Nothing }++-- | Sets all points on a board to be visible (if given true) or invisible (if+-- given false).+setBoardVisible :: Bool -> BoardState -> BoardState+setBoardVisible visible board =+  if visible+  then if boardHasInvisible board+       then board { boardCoordStates = map (map $ setVisible True) $ boardCoordStates board+                  , boardHasInvisible = False+                  }+       else board+  else board { boardCoordStates = map (map $ setVisible False) $ boardCoordStates board+             , boardHasInvisible = True+             }+  where setVisible vis coord = coord { coordVisible = vis }++-- | Resets all points on a board not to be dimmed.+clearBoardDimmed :: BoardState -> BoardState+clearBoardDimmed board =+  if boardHasDimmed board+  then board { boardCoordStates = map (map clearDim) $ boardCoordStates board+             , boardHasDimmed = False+             }+  else board+  where clearDim coord = coord { coordDimmed = False }++-- | Applies a property to a 'BoardState'.  This function covers all properties+-- that modify 'BoardState's, including making moves, adding markup, and so on.+applyProperty :: Property -> BoardState -> BoardState++applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of+  Nothing -> board  -- Pass.+  Just xy -> getApplyMoveResult board $+             applyMove playTheDarnMoveGoParams Black xy board+applyProperty KO board = board+applyProperty (MN moveNum) board = board { boardMoveNumber = moveNum }+applyProperty (W maybeXy) board = updateBoardForMove White $ case maybeXy of+  Nothing -> board  -- Pass.+  Just xy -> getApplyMoveResult board $+             applyMove playTheDarnMoveGoParams White xy board++applyProperty (AB coords) board =+  updateCoordStates' (\state -> state { coordStone = Just Black }) coords board+applyProperty (AW coords) board =+  updateCoordStates' (\state -> state { coordStone = Just White }) coords board+applyProperty (AE coords) board =+  updateCoordStates' (\state -> state { coordStone = Nothing }) coords board+applyProperty (PL color) board = board { boardPlayerTurn = color }++applyProperty (C {}) board = board+applyProperty (DM {}) board = board+applyProperty (GB {}) board = board+applyProperty (GW {}) board = board+applyProperty (HO {}) board = board+applyProperty (N {}) board = board+applyProperty (UC {}) board = board+applyProperty (V {}) board = board++applyProperty (BM {}) board = board+applyProperty (DO {}) board = board+applyProperty (IT {}) board = board+applyProperty (TE {}) board = board++applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board }+applyProperty (CR coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board+applyProperty (DD coords) board =+  let coords' = expandCoordList coords+      board' = clearBoardDimmed board+  in if null coords'+     then board'+     else updateCoordStates (\state -> state { coordDimmed = True }) coords'+          board { boardHasDimmed = True }+applyProperty (LB labels) board = board { boardLabels = labels ++ boardLabels board }+applyProperty (LN lines) board = board { boardLines = lines ++ boardLines board }+applyProperty (MA coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords board+applyProperty (SL coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board+applyProperty (SQ coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board+applyProperty (TR coords) board =+  updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board++applyProperty (AP {}) board = board+applyProperty (CA {}) board = board+applyProperty (FF {}) board = board+applyProperty (GM {}) board = board+applyProperty (ST variationMode) board =+  updateRootInfo (\info -> info { rootInfoVariationMode = variationMode }) board+applyProperty (SZ {}) board = board++applyProperty (AN str) board =+  updateBoardInfo (\info -> info { gameInfoAnnotatorName = Just str }) board+applyProperty (BR str) board =+  updateBoardInfo (\info -> info { gameInfoBlackRank = Just str }) board+applyProperty (BT str) board =+  updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just str }) board+applyProperty (CP str) board =+  updateBoardInfo (\info -> info { gameInfoCopyright = Just str }) board+applyProperty (DT str) board =+  updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just str }) board+applyProperty (EV str) board =+  updateBoardInfo (\info -> info { gameInfoEvent = Just str }) board+applyProperty (GC str) board =+  updateBoardInfo (\info -> info { gameInfoGameComment = Just str }) board+applyProperty (GN str) board =+  updateBoardInfo (\info -> info { gameInfoGameName = Just str }) board+applyProperty (ON str) board =+  updateBoardInfo (\info -> info { gameInfoOpeningComment = Just str }) board+applyProperty (OT str) board =+  updateBoardInfo (\info -> info { gameInfoOvertime = Just str }) board+applyProperty (PB str) board =+  updateBoardInfo (\info -> info { gameInfoBlackName = Just str }) board+applyProperty (PC str) board =+  updateBoardInfo (\info -> info { gameInfoPlace = Just str }) board+applyProperty (PW str) board =+  updateBoardInfo (\info -> info { gameInfoWhiteName = Just str }) board+applyProperty (RE result) board =+  updateBoardInfo (\info -> info { gameInfoResult = Just result }) board+applyProperty (RO str) board =+  updateBoardInfo (\info -> info { gameInfoRound = Just str }) board+applyProperty (RU ruleset) board =+  updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset }) board+applyProperty (SO str) board =+  updateBoardInfo (\info -> info { gameInfoSource = Just str }) board+applyProperty (TM seconds) board =+  updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds }) board+applyProperty (US str) board =+  updateBoardInfo (\info -> info { gameInfoEntererName = Just str }) board+applyProperty (WR str) board =+  updateBoardInfo (\info -> info { gameInfoWhiteRank = Just str }) board+applyProperty (WT str) board =+  updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just str }) board++applyProperty (BL {}) board = board+applyProperty (OB {}) board = board+applyProperty (OW {}) board = board+applyProperty (WL {}) board = board++applyProperty (VW coords) board =+  let coords' = expandCoordList coords+  in if null coords'+     then setBoardVisible True board+     else updateCoordStates (\state -> state { coordVisible = True }) coords' $+          setBoardVisible False board++applyProperty (HA {}) board = board+applyProperty (KM {}) board = board+applyProperty (TB {}) board = board+applyProperty (TW {}) board = board++applyProperty (UnknownProperty {}) board = board++applyProperties :: Node -> BoardState -> BoardState+applyProperties node board = foldr applyProperty board (nodeProperties node)++-- | Applies the transformation function to all of a board's coordinates+-- referred to by the 'CoordList'.+updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState+updateCoordStates fn coords board =+  board { boardCoordStates = foldr applyFn (boardCoordStates board) coords }+  where applyFn (x, y) = listUpdate (updateRow x) y+        updateRow = listUpdate fn++updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState+updateCoordStates' fn coords = updateCoordStates fn (expandCoordList coords)++-- | Updates properties of a 'BoardState' given that the player of the given+-- color has just made a move.  Increments the move number and updates the+-- player turn.+updateBoardForMove :: Color -> BoardState -> BoardState+updateBoardForMove movedPlayer board =+  board { boardMoveNumber = boardMoveNumber board + 1+        , boardPlayerTurn = cnot movedPlayer+        }++-- | A structure that configures how 'applyMove' should handle moves that are+-- normally illegal in Go.+data ApplyMoveParams = ApplyMoveParams+  { allowSuicide :: Bool+    -- ^ If false, suicide will cause 'applyMove' to return+    -- 'ApplyMoveSuicideError'.  If true, suicide will kill the+    -- friendly group and give points to the opponent.+  , allowOverwrite :: Bool+    -- ^ If false, playing on an occupied point will cause+    -- 'applyMove' to return 'ApplyMoveOverwriteError' with the+    -- color of the stone occupying the point.  If true,+    -- playing on an occupied point will overwrite the point+    -- (the previous stone vanishes), then capture rules are+    -- applied as normal.+  } deriving (Show)++-- | As an argument to 'applyMove', causes illegal moves to be treated as+-- errors.+standardGoMoveParams :: ApplyMoveParams+standardGoMoveParams = ApplyMoveParams+  { allowSuicide = False+  , allowOverwrite = False+  }++-- | As an argument to 'applyMove', causes illegal moves to be played+-- unconditionally.+playTheDarnMoveGoParams :: ApplyMoveParams+playTheDarnMoveGoParams = ApplyMoveParams+  { allowSuicide = True+  , allowOverwrite = True+  }++-- | The possible results from 'applyMove'.+data ApplyMoveResult =+  ApplyMoveOk BoardState+  -- ^ The move was accepted; playing it resulted in the given board without+  -- capture.+  | ApplyMoveCapture BoardState Color Int+    -- ^ The move was accepted; playing it resulted in the given board with a+    -- capture.  The specified side gained the number of points given.+  | ApplyMoveSuicideError+    -- ^ Playing the move would result in suicide, which is forbidden.+  | ApplyMoveOverwriteError Color+    -- ^ There is already a stone of the specified color on the target point,+    -- and overwriting is forbidden.++-- | If the 'ApplyMoveResult' represents a successful move, then the resulting+-- 'BoardState' is returned, otherwise, the default 'BoardState' given is+-- returned.+getApplyMoveResult :: BoardState -> ApplyMoveResult -> BoardState+getApplyMoveResult defaultBoard result = fromMaybe defaultBoard $ getApplyMoveResult' result++getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState+getApplyMoveResult' result = case result of+  ApplyMoveOk board -> Just board+  ApplyMoveCapture board color points -> Just $ case color of+    Black -> board { boardBlackCaptures = boardBlackCaptures board + points }+    White -> board { boardWhiteCaptures = boardWhiteCaptures board + points }+  ApplyMoveSuicideError -> Nothing+  ApplyMoveOverwriteError _ -> Nothing++-- | Internal data structure, only for move application code.  Represents a+-- group of stones.+data ApplyMoveGroup = ApplyMoveGroup+  { applyMoveGroupOrigin :: Coord+  , applyMoveGroupCoords :: [Coord]+  , applyMoveGroupLiberties :: Int+  } deriving (Show)++-- | Places a stone of a color at a point on a board, and runs move validation+-- and capturing logic according to the given parameters.  Returns whether the+-- move was successful, and the result if so.+applyMove :: ApplyMoveParams -> Color -> Coord -> BoardState -> ApplyMoveResult+applyMove params color xy board =+  let currentStone = coordStone $ boardCoordState xy board+  in case currentStone of+    Just color -> if allowOverwrite params+                  then moveResult+                  else ApplyMoveOverwriteError color+    Nothing -> moveResult+  where boardWithMove = updateCoordStates (\state -> state { coordStone = Just color })+                                          [xy]+                                          board+        (boardWithCaptures, points) = foldr (maybeCapture $ cnot color)+                                            (boardWithMove, 0)+                                            (adjacentPoints boardWithMove xy)+        playedGroup = computeGroup boardWithCaptures xy+        moveResult+          | applyMoveGroupLiberties playedGroup == 0 =+            if points /= 0+            then error "Cannot commit suicide and capture at the same time."+            else if allowSuicide params+                 then let (boardWithSuicide, suicidePoints) =+                            applyMoveCapture (boardWithCaptures, 0) playedGroup+                      in ApplyMoveCapture boardWithSuicide (cnot color) suicidePoints+                 else ApplyMoveSuicideError+          | points /= 0 = ApplyMoveCapture boardWithCaptures color points+          | otherwise = ApplyMoveOk boardWithCaptures++-- | Capture if there is a liberty-less group of a color at a point on+-- a board.  Removes captured stones from the board and accumulates+-- points for captured stones.+maybeCapture :: Color -> Coord -> (BoardState, Int) -> (BoardState, Int)+maybeCapture color xy result@(board, _) =+  if coordStone (boardCoordState xy board) /= Just color+  then result+  else let group = computeGroup board xy+       in if applyMoveGroupLiberties group /= 0+          then result+          else applyMoveCapture result group++computeGroup :: BoardState -> Coord -> ApplyMoveGroup+computeGroup board xy =+  if isNothing (coordStone $ boardCoordState xy board)+  then error "computeGroup called on an empty point."+  else let groupCoords = bucketFill board xy+       in ApplyMoveGroup { applyMoveGroupOrigin = xy+                         , applyMoveGroupCoords = groupCoords+                         , applyMoveGroupLiberties = getLibertiesOfGroup board groupCoords+                         }++applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int)+applyMoveCapture (board, points) group =+  (updateCoordStates (\state -> state { coordStone = Nothing })+                     (applyMoveGroupCoords group)+                     board,+   points + length (applyMoveGroupCoords group))++-- | Returns a list of the four coordinates that are adjacent to the+-- given coordinate on the board, excluding coordinates that are out+-- of bounds.+adjacentPoints :: BoardState -> Coord -> [Coord]+adjacentPoints board (x, y) = execWriter $ do+  when (x > 0) $ tell [(x - 1, y)]+  when (y > 0) $ tell [(x, y - 1)]+  when (x < boardWidth board - 1) $ tell [(x + 1, y)]+  when (y < boardHeight board - 1) $ tell [(x, y + 1)]++-- | Takes a list of coordinates that comprise a group (e.g. a list+-- returned from 'bucketFill') and returns the number of liberties the+-- group has.  Does no error checking to ensure that the list refers+-- to a single or maximal group.+getLibertiesOfGroup :: BoardState -> [Coord] -> Int+getLibertiesOfGroup board groupCoords =+  length $ nub $ concatMap findLiberties groupCoords+  where findLiberties xy = filter (\xy' -> isNothing $ coordStone $ boardCoordState xy' board)+                                  (adjacentPoints board xy)++-- | Expands a single coordinate on a board into a list of all the+-- coordinates connected to it by some continuous path of stones of+-- the same color (or empty spaces).+bucketFill :: BoardState -> Coord -> [Coord]+bucketFill board xy0 = bucketFill' Set.empty [xy0]+  where bucketFill' known [] = Set.toList known+        bucketFill' known (xy:xys) =+          if Set.member xy known+          then bucketFill' known xys+          else let new = filter ((stone0 ==) . coordStone . flip boardCoordState board)+                                (adjacentPoints board xy)+               in bucketFill' (Set.insert xy known) (new ++ xys)+        stone0 = coordStone $ boardCoordState xy0 board++-- | Returns whether it is legal to place a stone of the given color at a point+-- on a board.  Accepts out-of-bound coordinates and returns false.+isValidMove :: BoardState -> Color -> Coord -> Bool+-- TODO Should out-of-bound coordinates be accepted?+isValidMove board color coord@(x, y) =+  let w = boardWidth board+      h = boardHeight board+  in x >= 0 && y >= 0 && x < w && y < h &&+     isJust (getApplyMoveResult' $ applyMove standardGoMoveParams color coord board)++-- | Returns whether it is legal for the current player to place a stone at a+-- point on a board.  Accepts out-of-bound coordinates and returns false.+isCurrentValidMove :: BoardState -> Coord -> Bool+isCurrentValidMove board = isValidMove board (boardPlayerTurn board)++-- | A pointer to a node in a game tree that also holds information+-- about the current state of the game at that node.+data Cursor = Cursor { cursorParent :: Maybe Cursor+                       -- ^ The cursor for the node above this cursor's node in+                       -- the game tree.  The node of the parent cursor is the+                       -- parent of the cursor's node.+                       --+                       -- This is @Nothing@ iff the cursor's node has no parent.+                     , cursorChildIndex :: Int+                       -- ^ The index of this cursor's node in its parent's+                       -- child list.  When the cursor's node has no parent,+                       -- the value in this field is not specified.+                     , cursorNode :: Node+                       -- ^ The game tree node about which the cursor stores+                       -- information.+                     , cursorBoard :: BoardState+                       -- ^ The complete board state for the current node.+                     } deriving (Show) -- TODO Better Show Cursor instance.++-- | Returns a cursor for a root node.+rootCursor :: Node -> Cursor+rootCursor node =+  Cursor { cursorParent = Nothing+         , cursorChildIndex = -1+         , cursorNode = node+         , cursorBoard = rootBoardState node+         }++cursorRoot :: Cursor -> Cursor+cursorRoot cursor = case cursorParent cursor of+  Nothing -> cursor+  Just parent -> cursorRoot parent++cursorChild :: Cursor -> Int -> Cursor+cursorChild cursor index =+  Cursor { cursorParent = Just cursor+         , cursorChildIndex = index+         , cursorNode = child+         , cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor+         }+  -- TODO Better handling or messaging for out-of-bounds:+  where child = (!! index) $ nodeChildren $ cursorNode cursor++cursorChildren :: Cursor -> [Cursor]+cursorChildren cursor =+  let board = boardChild $ cursorBoard cursor+  in map (\(index, child) -> Cursor { cursorParent = Just cursor+                                    , cursorChildIndex = index+                                    , cursorNode = child+                                    , cursorBoard = applyProperties child board+                                    })+     $ zip [0..]+     $ nodeChildren+     $ cursorNode cursor++cursorChildCount :: Cursor -> Int+cursorChildCount = length . nodeChildren . cursorNode++cursorChildPlayingAt :: Maybe Coord -> Cursor -> Maybe Cursor+cursorChildPlayingAt move cursor =+  let children = cursorChildren cursor+      color = boardPlayerTurn $ cursorBoard cursor+      hasMove = elem $ moveToProperty color move+  in find (hasMove . nodeProperties . cursorNode) children++-- | This is simply @'nodeProperties' . 'cursorNode'@.+cursorProperties :: Cursor -> [Property]+cursorProperties = nodeProperties . cursorNode++cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor+cursorModifyNode fn cursor =+  let node' = fn $ cursorNode cursor+  in case cursorParent cursor of+    Nothing -> rootCursor node'+    Just parentCursor ->+      let index = cursorChildIndex cursor+          parentCursor' = cursorModifyNode+                          (\parentNode ->+                            parentNode { nodeChildren = listUpdate (const node')+                                                        index+                                                        (nodeChildren parentNode)+                                       })+                          parentCursor+      in cursorChild parentCursor' index++-- | Returns the variations to display for a cursor.  The returned list contains+-- the location and color of 'B' and 'W' properties in variation nodes.+-- Variation nodes are either children of the current node, or siblings of the+-- current node, depending on the variation mode source.+cursorVariations :: VariationModeSource -> Cursor -> [(Coord, Color)]+cursorVariations source cursor =+  case source of+    ShowChildVariations -> collectPlays $ nodeChildren $ cursorNode cursor+    ShowCurrentVariations ->+      case cursorParent cursor of+        Nothing -> []+        Just parent -> collectPlays $ listDeleteAt (cursorChildIndex cursor) $+                       nodeChildren $ cursorNode parent+  where collectPlays :: [Node] -> [(Coord, Color)]+        collectPlays = concatMap collectPlays'+        collectPlays' = concatMap collectPlays'' . nodeProperties+        collectPlays'' prop = case prop of+          B (Just xy) -> [(xy, Black)]+          W (Just xy) -> [(xy, White)]+          _ -> []++moveToProperty :: Color -> Maybe Coord -> Property+moveToProperty color =+  case color of+    Black -> B+    White -> W

@@ -0,0 +1,793 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | A monad for working with game trees.+module Game.Goatee.Lib.Monad (+  -- * The Go monad+  MonadGo (..),+  GoT, GoM,+  runGoT, runGo,+  evalGoT, evalGo,+  execGoT, execGo,+  Step (..),+  NodeDeleteResult (..),+  -- * Event handling+  Event, AnyEvent (..), eventName, fire, eventHandlerFromAction,+  -- * Events+  childAddedEvent, ChildAddedHandler,+  childDeletedEvent, ChildDeletedHandler,+  gameInfoChangedEvent, GameInfoChangedHandler,+  navigationEvent, NavigationHandler,+  propertiesModifiedEvent, PropertiesModifiedHandler,+  variationModeChangedEvent, VariationModeChangedHandler,+  ) where++import Control.Applicative ((<$>), Applicative ((<*>), pure))+import Control.Monad (ap, liftM, when)+import Control.Monad.Identity (Identity, runIdentity)+import qualified Control.Monad.State as State+import Control.Monad.State (MonadState, StateT, get, put)+import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)+import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer)+import qualified Data.Function as F+import Data.List (delete, find, mapAccumL, nub, sortBy)+import Data.Maybe (fromMaybe, isJust, isNothing)+import Game.Goatee.Common+import Game.Goatee.Lib.Board+import Game.Goatee.Lib.Property+import qualified Game.Goatee.Lib.Tree as Tree+import Game.Goatee.Lib.Tree hiding (addChild, addChildAt)+import Game.Goatee.Lib.Types++-- | The internal state of a Go monad transformer.  @go@ is the type of+-- Go monad or transformer (instance of 'GoMonad').+data GoState go = GoState+  { stateCursor :: Cursor+    -- ^ The current position in the game tree.+  , statePathStack :: PathStack+    -- ^ The current path stack.++    -- Event handlers.+  , stateChildAddedHandlers :: [ChildAddedHandler go]+    -- ^ Handlers for 'childAddedEvent'.+  , stateChildDeletedHandlers :: [ChildDeletedHandler go]+    -- ^ Handlers for 'childDeletedEvent'.+  , stateGameInfoChangedHandlers :: [GameInfoChangedHandler go]+    -- ^ Handlers for 'gameInfoChangedEvent'.+  , stateNavigationHandlers :: [NavigationHandler go]+    -- ^ Handlers for 'navigationEvent'.+  , statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go]+    -- ^ Handlers for 'propertiesModifiedEvent'.+  , stateVariationModeChangedHandlers :: [VariationModeChangedHandler go]+    -- ^ Handlers for 'variationModeChangedEvent'.+  }++-- | A path stack is a record of previous places visited in a game tree.  It is+-- encoded a list of paths (steps) to each previous memorized position.+--+-- The positions saved in calls to 'pushPosition' correspond to entries in the+-- outer list here, with the first sublist representing the last call.  The+-- sublist contains the steps in order that will trace the path back to the+-- saved position.+type PathStack = [[Step]]++-- | A simplified constructor function for 'GoState'.+initialState :: Cursor -> GoState m+initialState cursor = GoState { stateCursor = cursor+                              , statePathStack = []+                              , stateChildAddedHandlers = []+                              , stateChildDeletedHandlers = []+                              , stateGameInfoChangedHandlers = []+                              , stateNavigationHandlers = []+                              , statePropertiesModifiedHandlers = []+                              , stateVariationModeChangedHandlers = []+                              }++-- | A single step along a game tree.  Either up or down.+data Step =+  GoUp Int+  -- ^ Represents a step up from a child with the given index.+  | GoDown Int+    -- ^ Represents a step down to the child with the given index.+  deriving (Eq, Show)++-- | Reverses a step, such that taking a step then it's reverse will leave you+-- where you started.+reverseStep :: Step -> Step+reverseStep step = case step of+  GoUp index -> GoDown index+  GoDown index -> GoUp index++-- | Takes a 'Step' from a 'Cursor', returning a new 'Cursor'.+takeStep :: Step -> Cursor -> Cursor+takeStep (GoUp _) cursor = fromMaybe (error $ "takeStep: Can't go up from " ++ show cursor ++ ".") $+                           cursorParent cursor+takeStep (GoDown index) cursor = cursorChild cursor index++-- | Internal function.  Takes a 'Step' in the Go monad.  Updates the path stack+-- accordingly.+takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m ()+takeStepM step = case step of+  GoUp _ -> goUp'+  GoDown index -> goDown' index++-- | A monad (transformer) for navigating and mutating 'Cursor's, and+-- remembering previous locations.  See 'GoT' and 'GoM'.+--+-- The monad supports handlers for events raised during actions it takes, such+-- as navigating through the tree and modifying nodes.+class (Functor go, Applicative go, Monad go) => MonadGo go where+  -- | Returns the current cursor.+  getCursor :: go Cursor++  -- | Returns the 'CoordState' at the given point.+  getCoordState :: Coord -> go CoordState+  getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor++  -- | Navigates up the tree.  It must be valid to do so, otherwise 'fail' is+  -- called.  Fires a 'navigationEvent' after moving.+  goUp :: go ()++  -- | Navigates down the tree to the child with the given index.  The child+  -- must exist.  Fires a 'navigationEvent' after moving.+  goDown :: Int -> go ()++  -- | Navigates up to the root of the tree.  Fires 'navigationEvent's for each+  -- step.+  goToRoot :: go ()++  -- | Navigates up the tree to the node containing game info properties, if+  -- any.  Returns true if a game info node was found.+  goToGameInfoNode :: Bool+                      -- ^ When no node with game info is found, then if false,+                      -- return to the original node, otherwise finish at the+                      -- root node.+                   -> go Bool++  -- | Pushes the current location in the game tree onto an internal position+  -- stack, such that 'popPosition' is capable of navigating back to the same+  -- position, even if the game tree has been modified (though the old position+  -- must still exist in the tree to return to it).+  pushPosition :: go ()++  -- | Returns to the last position pushed onto the internal position stack via+  -- 'pushPosition'.  This action must be balanced by a 'pushPosition'.+  popPosition :: go ()++  -- | Drops the last position pushed onto the internal stack by 'pushPosition'+  -- off of the stack.  This action must be balanced by a 'pushPosition'.+  dropPosition :: go ()++  -- | Returns the set of properties on the current node.+  getProperties :: go [Property]+  getProperties = liftM cursorProperties getCursor++  -- | Modifies the set of properties on the current node.+  --+  -- The given function must end on the same node on which it started.+  modifyProperties :: ([Property] -> go [Property]) -> go ()++  -- | Searches for a property on the current node, returning it if found.+  getProperty :: Descriptor d => d -> go (Maybe Property)++  -- | Searches for a valued property on the current node, returning its value+  -- if found.+  getPropertyValue :: ValuedDescriptor d v => d -> go (Maybe v)+  getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor++  -- | Sets a property on the current node, replacing an existing property with+  -- the same name, if one exists.+  putProperty :: Property -> go ()+  putProperty property = modifyProperty (propertyInfo property) $ const $ Just property++  -- | Deletes a property from the current node, if it's set.+  --+  -- Note that although a 'Property' is a 'Descriptor', giving a valued+  -- @Property@ here will not cause deletion to match on the value of the+  -- property.  That is, the following code will result in 'Nothing', because+  -- the deletion only cares about the name of the property.+  --+  -- > do putProperty $ PL Black+  -- >    deleteProperty $ PL White+  -- >    getPropertyValue propertyPL+  deleteProperty :: Descriptor d => d -> go ()+  deleteProperty descriptor = modifyProperty descriptor $ const Nothing++  -- | Calls the given function to modify the state of the given property+  -- (descriptor) on the current node.  'Nothing' represents the property not+  -- existing on the node, and a 'Just' marks the property's presence.  This+  -- function does not do any validation to check that the resulting tree state+  -- is valid.+  modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go ()++  -- | Calls the given function to modify the state of the given valued property+  -- (descriptor) on the current node.  'Nothing' represents the property not+  -- existing on the node, and a 'Just' with the property's value marks the+  -- property's presence.  This function does not do any validation to check+  -- that the resulting tree state is valid.+  modifyPropertyValue :: ValuedDescriptor d v => d -> (Maybe v -> Maybe v) -> go ()+  modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old ->+    propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old)++  -- | Mutates the string-valued property attached to the current node according+  -- to the given function.  The input string will be empty if the current node+  -- either has the property with an empty value, or doesn't have the property.+  -- Returning an empty string removes the property from the node, if it was+  -- set.+  modifyPropertyString :: (Stringlike s, ValuedDescriptor d s) => d -> (String -> String) -> go ()+  modifyPropertyString descriptor fn =+    modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of+      "" -> Nothing+      str -> let sgf = stringToSgf str+                 -- Because stringToSgf might do processing, we have to check+                 -- the conversion back to a string for emptiness.+             in if null $ sgfToString sgf then Nothing else Just sgf++  -- | Mutates the 'CoordList'-valued property attached to the current node+  -- according to the given function.  Conversion between @CoordList@ and+  -- @[Coord]@ is performed automatically.  The input list will be empty if the+  -- current node either has the property with an empty value, or doesn't have+  -- the property.  Returning an empty list removes the property from the node,+  -- if it was set.+  --+  -- Importantly, this might not be specific enough for properties such as 'DD'+  -- and 'VW' where a present, empty list has different semantics from the+  -- property not being present.  In that case, 'modifyPropertyValue' is better.+  modifyPropertyCoords :: ValuedDescriptor d CoordList => d -> ([Coord] -> [Coord]) -> go ()+  modifyPropertyCoords descriptor fn =+    modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of+      [] -> Nothing+      coords -> Just $ buildCoordList coords++  -- | Mutates the game info for the current path, returning the new info.  If+  -- the current node or one of its ancestors has game info properties, then+  -- that node is modified.  Otherwise, properties are inserted on the root+  -- node.+  modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo++  -- | Sets the game's 'VariationMode' via the 'ST' property on the root node,+  -- then fires a 'variationModeChangedEvent' if the variation mode has changed.+  modifyVariationMode :: (VariationMode -> VariationMode) -> go ()++  -- | Returns the 'Mark' at a point on the current node.+  getMark :: Coord -> go (Maybe Mark)+  getMark = liftM coordMark . getCoordState++  -- | Calls the given function to modify the presence of a 'Mark' on the+  -- current node.+  modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go ()+  modifyMark fn coord = do+    maybeOldMark <- getMark coord+    case (maybeOldMark, fn maybeOldMark) of+      (Just oldMark, Nothing) -> remove oldMark+      (Nothing, Just newMark) -> add newMark+      (Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark+      (Just _, Just _) -> return ()+      (Nothing, Nothing) -> return ()+    where remove mark = modifyPropertyCoords (markProperty mark) (delete coord)+          add mark = modifyPropertyCoords (markProperty mark) (coord:)++  -- | Adds a child node to the current node at the end of the current node's+  -- child list.  Fires a 'childAddedEvent' after the child is added.+  addChild :: Node -> go ()+  addChild node = do+    childCount <- liftM (length . cursorChildren) getCursor+    addChildAt childCount node++  -- | Adds a child node to the current node at the given index, shifting all+  -- existing children at and after the index to the right.  The index must be+  -- in the range @[0, numberOfChildren]@.  Fires a 'childAddedEvent' after the+  -- child is added.+  addChildAt :: Int -> Node -> go ()++  -- | Tries to remove the child node at the given index below the current node.+  -- Returns a status code indicating whether the deletion succeeded, or why+  -- not.+  deleteChildAt :: Int -> go NodeDeleteResult++  -- | Registers a new event handler for a given event type.+  on :: Event go h -> h -> go ()++  -- | Registers a new event handler for a given event type.  Unlike 'on', whose+  -- handler may receive arguments, the handler given here doesn't receive any+  -- arguments.+  on0 :: Event go h -> go () -> go ()+  on0 event handler = on event $ eventHandlerFromAction event handler++-- | The result of deleting a node.+data NodeDeleteResult =+  NodeDeleteOk+  -- ^ The node was deleted successfully.+  | NodeDeleteBadIndex+    -- ^ The node couldn't be deleted, because an invalid index was given.+  | NodeDeleteOnPathStack+    -- ^ The node couldn't be deleted, because it is on the path stack.+  deriving (Bounded, Enum, Eq, Show)++-- | The standard monad transformer for 'MonadGo'.+newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a }++-- | The standard monad for 'MonadGo'.+type GoM = GoT Identity++instance Monad m => Functor (GoT m) where+  fmap = liftM++instance Monad m => Applicative (GoT m) where+  pure = return+  (<*>) = ap++instance Monad m => Monad (GoT m) where+  return x = GoT $ return x+  m >>= f = GoT $ goState . f =<< goState m+  fail = lift . fail++instance MonadTrans GoT where+  lift = GoT . lift++instance MonadIO m => MonadIO (GoT m) where+  liftIO = lift . liftIO++instance MonadState s m => MonadState s (GoT m) where+  get = lift get+  put = lift . put++instance MonadWriter w m => MonadWriter w (GoT m) where+  writer = lift . writer+  tell = lift . tell+  listen = GoT . listen . goState+  pass = GoT . pass . goState++-- | Executes a Go monad transformer on a cursor, returning in the underlying+-- monad a tuple that contains the resulting value and the final cursor.+runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor)+runGoT go cursor = do+  (value, state) <- State.runStateT (goState go) (initialState cursor)+  return (value, stateCursor state)++-- | Executes a Go monad transformer on a cursor, returning in the underlying+-- monad the value in the transformer.+evalGoT :: Monad m => GoT m a -> Cursor -> m a+evalGoT go cursor = liftM fst $ runGoT go cursor++-- | Executes a Go monad transformer on a cursor, returning in the underlying+-- monad the final cursor.+execGoT :: Monad m => GoT m a -> Cursor -> m Cursor+execGoT go cursor = liftM snd $ runGoT go cursor++-- | Runs a Go monad on a cursor.  See 'runGoT'.+runGo :: GoM a -> Cursor -> (a, Cursor)+runGo go = runIdentity . runGoT go++-- | Runs a Go monad on a cursor and returns the value in the monad.+evalGo :: GoM a -> Cursor -> a+evalGo m cursor = fst $ runGo m cursor++-- | Runs a Go monad on a cursor and returns the final cursor.+execGo :: GoM a -> Cursor -> Cursor+execGo m cursor = snd $ runGo m cursor++getState :: Monad m => GoT m (GoState (GoT m))+getState = GoT State.get++putState :: Monad m => GoState (GoT m) -> GoT m ()+putState = GoT . State.put++modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()+modifyState = GoT . State.modify++instance Monad m => MonadGo (GoT m) where+  getCursor = liftM stateCursor getState++  -- TODO For goUp and goDown, optimize by seeing checking if (head $ head+  -- pathStack) is the step we're taking, and if so, dropping it from the list+  -- rather than pushing a fresh step.+  goUp = do+    index <- liftM cursorChildIndex getCursor+    goUp' $ \pathStack -> case pathStack of+      [] -> pathStack+      path:paths -> (GoDown index:path):paths++  goDown index = goDown' index $ \pathStack -> case pathStack of+    [] -> pathStack+    path:paths -> (GoUp index:path):paths++  goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp++  goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode+    where findGameInfoNode = do+            cursor <- getCursor+            if hasGameInfo cursor+              then dropPosition >> return True+              else if isNothing $ cursorParent cursor+                   then do if goToRootIfNotFound then dropPosition else popPosition+                           return False+                   else goUp >> findGameInfoNode+          hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor++  pushPosition = modifyState $ \state ->+    state { statePathStack = []:statePathStack state }++  popPosition = do+    getPathStack >>= \stack -> when (null stack) $+      fail "popPosition: No position to pop from the stack."++    -- Drop each step in the top list of the path stack one at a time, until the+    -- top list is empty.+    whileM' (do path:_ <- getPathStack+                return $ if null path then Nothing else Just $ head path) $+      flip takeStepM $ \((_:steps):paths) -> steps:paths++    -- Finally, drop the empty top of the path stack.+    modifyState $ \state -> case statePathStack state of+      []:rest -> state { statePathStack = rest }+      _ -> error "popPosition: Internal failure, top of path stack is not empty."++  dropPosition = do+    state <- getState+    -- If there are >=2 positions on the path stack, then we can't simply drop+    -- the moves that will return us to the top-of-stack position, because they+    -- may still be needed to return to the second-on-stack position by a+    -- following popPosition.+    case statePathStack state of+      x:y:xs -> putState $ state { statePathStack = (x ++ y):xs }+      _:[] -> putState $ state { statePathStack = [] }+      [] -> fail "dropPosition: No position to drop from the stack."++  modifyProperties fn = do+    oldCursor <- getCursor+    let oldProperties = cursorProperties oldCursor+    newProperties <- fn oldProperties+    modifyState $ \state ->+      state { stateCursor = cursorModifyNode+                            (\node -> node { nodeProperties = newProperties })+                            oldCursor+            }+    when (sortBy (compare `F.on` propertyName) newProperties /=+          sortBy (compare `F.on` propertyName) oldProperties) $+      fire propertiesModifiedEvent (\f -> f oldProperties newProperties)++    -- The current game info changes when modifying game info properties on the+    -- current node.  I think comparing game info properties should be faster+    -- than comparing 'GameInfo's.+    let filterToGameInfo = nub . filter ((GameInfoProperty ==) . propertyType)+        oldGameInfo = filterToGameInfo oldProperties+        newGameInfo = filterToGameInfo newProperties+    when (newGameInfo /= oldGameInfo) $ do+      newCursor <- getCursor+      fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard oldCursor)+                                         (boardGameInfo $ cursorBoard newCursor))++  getProperty descriptor = find (propertyPredicate descriptor) <$> getProperties++  modifyProperty descriptor fn = do+    cursor <- getCursor+    let node = cursorNode cursor+        old = findProperty descriptor node+        new = fn old+    when (maybe False (not . propertyPredicate descriptor) new) $+      fail $ "modifyProperty: May not change property type: " +++      show old ++ " -> " ++ show new ++ "."+    case (old, new) of+      (Just _, Nothing) -> modifyProperties $ return . remove descriptor+      (Nothing, Just value') -> modifyProperties $ return . add value'+      (Just value, Just value') | value /= value' ->+        modifyProperties $ return . add value' . remove descriptor+      _ -> return ()+    where remove descriptor = filter (not . propertyPredicate descriptor)+          add value = (value:)++  modifyGameInfo fn = do+    cursor <- getCursor+    let info = boardGameInfo $ cursorBoard cursor+        info' = fn info+    when (gameInfoRootInfo info /= gameInfoRootInfo info') $+      fail "Illegal modification of root info in modifyGameInfo."+    pushPosition+    goToGameInfoNode True+    modifyProperties $ \props ->+      return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props+    popPosition+    return info'++  modifyVariationMode fn = do+    pushPosition+    goToRoot+    modifyPropertyValue propertyST $ \maybeOld ->+      -- If the new variation mode is equal to the old effective variation mode+      -- (effective applying the default if the property isn't present), then+      -- leave the property unchanged.  Otherwise, apply the new variation mode,+      -- deleting the property if the default variation mode is selected.  We+      -- don't delete the property if @maybeOld == Just new == Just+      -- defaultVariationMode@, because we don't want to trigger dirtyness+      -- unnecessarily.+      let old = fromMaybe defaultVariationMode maybeOld+          new = fn old+      in if new == old+         then maybeOld+         else if new == defaultVariationMode+              then Nothing+              else Just new+    popPosition++  addChildAt index node = do+    cursor <- getCursor+    let childCount = cursorChildCount cursor+    when (index < 0 || index > childCount) $ fail $+      "Monad.addChildAt: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]."+    let cursor' = cursorModifyNode (Tree.addChildAt index node) cursor+    modifyState $ \state ->+      state { stateCursor = cursor'+            , statePathStack = foldPathStack+                               (\step -> case step of+                                   GoUp n -> GoUp $ if n < index then n else n + 1+                                   down@(GoDown _) -> down)+                               (\step -> case step of+                                   up@(GoUp _) -> up+                                   GoDown n -> GoDown $ if n < index then n else n + 1)+                               id+                               cursor'+                               (statePathStack state)+            }+    fire childAddedEvent ($ index)++  deleteChildAt index = do+    childCount <- cursorChildCount <$> getCursor+    if index < 0 || index >= childCount+      then return NodeDeleteBadIndex+      else do goDown index+              childCursor <- getCursor+              deletingNodeOnPath <- doesPathStackEnterCurrentNode <$>+                                    pure childCursor <*> getPathStack+              goUp+              if deletingNodeOnPath+                then return NodeDeleteOnPathStack+                else do cursor <- getCursor+                        let cursor' = cursorModifyNode (Tree.deleteChildAt index) cursor+                        modifyState $ \state ->+                          state { stateCursor = cursor'+                                , statePathStack =+                                  foldPathStack+                                  (\step -> case step of+                                      GoUp n -> GoUp $ if n < index then n else n - 1+                                      down@(GoDown _) -> down)+                                  (\step -> case step of+                                      up@(GoUp _) -> up+                                      GoDown n -> GoDown $ if n < index then n else n - 1)+                                  id+                                  cursor'+                                  (statePathStack state)+                                }+                        fire childDeletedEvent ($ childCursor)+                        return NodeDeleteOk++  on event handler = modifyState $ addHandler event handler++-- | Takes a step up the game tree, updates the path stack according to the+-- given function, then fires navigation and game info changed events as+-- appropriate.+goUp' :: Monad m => (PathStack -> PathStack) -> GoT m ()+goUp' pathStackFn = do+  state@(GoState { stateCursor = cursor+                 , statePathStack = pathStack+                 }) <- getState+  case cursorParent cursor of+    Nothing -> error $ "goUp': Can't go up from a root cursor: " ++ show cursor+    Just parent -> do+      let index = cursorChildIndex cursor+      putState state { stateCursor = parent+                     , statePathStack = pathStackFn pathStack+                     }+      fire navigationEvent ($ GoUp index)++      -- The current game info changes when navigating up from a node that has+      -- game info properties.+      when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $+        fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)+                                           (boardGameInfo $ cursorBoard parent))++-- | Takes a step down the game tree, updates the path stack according to the+-- given function, then fires navigation and game info changed events as+-- appropriate.+goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m ()+goDown' index pathStackFn = do+  state@(GoState { stateCursor = cursor+                 , statePathStack = pathStack+                 }) <- getState+  case drop index $ cursorChildren cursor of+    [] -> error $ "goDown': Cursor does not have a child #" ++ show index ++ ": " ++ show cursor+    child:_ -> do+      putState state { stateCursor = child+                     , statePathStack = pathStackFn pathStack+                     }+      fire navigationEvent ($ GoDown index)++      -- The current game info changes when navigating down to a node that has+      -- game info properties.+      when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $+        fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)+                                           (boardGameInfo $ cursorBoard child))++-- | Returns the current path stack.+getPathStack :: Monad m => GoT m PathStack+getPathStack = liftM statePathStack getState++doesPathStackEnterCurrentNode :: Cursor -> PathStack -> Bool+doesPathStackEnterCurrentNode cursor pathStack =+  or $ or <$> foldPathStack (const True) (const False) (const False) cursor pathStack++-- | Maps over a path stack, updating with the given functions all steps that+-- enter and leave the cursor's current node.+foldPathStack :: (Step -> a)+              -> (Step -> a)+              -> (Step -> a)+              -> Cursor+              -> PathStack+              -> [[a]]+foldPathStack _ _ _ _ [] = []+foldPathStack onEnter onExit onOther cursor0 paths =+  snd $ mapAccumL updatePath (cursor0, []) paths+  where -- updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [a])+        updatePath = mapAccumL updateStep+        -- updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), a)+        updateStep (cursor, []) step = ((takeStep step cursor, [reverseStep step]), onExit step)+        updateStep (cursor, pathToInitial@(stepToInitial:restToInitial)) step =+          let pathToInitial' = if stepToInitial == step+                               then restToInitial+                               else reverseStep step:pathToInitial+          in ((takeStep step cursor, pathToInitial'),+              if null pathToInitial' then onEnter step else onOther step)++-- | Fires all of the handlers for the given event, using the given function to+-- create a Go action from each of the handlers (normally themselves functions+-- that create Go actions, if they're not just Go actions directly, depending on+-- the event).+fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()+fire event handlerGenerator = do+  state <- getState+  mapM_ handlerGenerator $ eventStateGetter event state++-- | A type of event in a Go monad that can be handled by executing an action.+-- @go@ is the type of the Go monad.  @h@ is the handler type, a function that+-- takes some arguments relating to the event and returns an action in the Go+-- monad.  The arguments to the handler are usually things that would be+-- difficult to recover from the state of the monad alone, for example the+-- 'Step' associated with a 'navigationEvent'.+--+-- The 'Eq', 'Ord', and 'Show' instances use events' names, via 'eventName'.+data Event go h = Event+  { eventName :: String+  , eventStateGetter :: GoState go -> [h]+  , eventStateSetter :: [h] -> GoState go -> GoState go+  , eventHandlerFromAction :: go () -> h+  }++instance Eq (Event go h) where+  (==) = (==) `F.on` eventName++instance Ord (Event go h) where+  compare = compare `F.on` eventName++instance Show (Event go h) where+  show = eventName++-- | An existential type for any event in a particular Go monad.  Like 'Event',+-- the 'Eq', 'Ord', and 'Show' instances use events' names, via 'eventName'.+data AnyEvent go = forall h. AnyEvent (Event go h)++instance Eq (AnyEvent go) where+  (AnyEvent e) == (AnyEvent e') = eventName e == eventName e'++instance Ord (AnyEvent go) where+  compare (AnyEvent e) (AnyEvent e') = compare (eventName e) (eventName e')++instance Show (AnyEvent go) where+  show (AnyEvent e) = eventName e++addHandler :: Event go h -> h -> GoState go -> GoState go+addHandler event handler state =+  eventStateSetter event (eventStateGetter event state ++ [handler]) state++-- | An event corresponding to a child node being added to the current node.+childAddedEvent :: Event go (ChildAddedHandler go)+childAddedEvent = Event+  { eventName = "childAddedEvent"+  , eventStateGetter = stateChildAddedHandlers+  , eventStateSetter = \handlers state -> state { stateChildAddedHandlers = handlers }+  , eventHandlerFromAction = const+  }++-- | A handler for 'childAddedEvent's.  Called with the index of the child added+-- to the current node.+type ChildAddedHandler go = Int -> go ()++-- | An event corresponding to the deletion of one of the current node's+-- children.+childDeletedEvent :: Event go (ChildDeletedHandler go)+childDeletedEvent = Event+  { eventName = "childDeletedEvent"+  , eventStateGetter = stateChildDeletedHandlers+  , eventStateSetter = \handlers state -> state { stateChildDeletedHandlers = handlers }+  , eventHandlerFromAction = const+  }++-- | A handler for 'childDeletedEvent's.  It is called with a cursor at the+-- child that was deleted (this cursor is now out of date).+type ChildDeletedHandler go = Cursor -> go ()++-- | An event that is fired when the current game info changes, either by+-- navigating past a node with game info properties, or by modifying the current+-- game info properties.+gameInfoChangedEvent :: Event go (GameInfoChangedHandler go)+gameInfoChangedEvent = Event+  { eventName = "gameInfoChangedEvent"+  , eventStateGetter = stateGameInfoChangedHandlers+  , eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers }+  , eventHandlerFromAction = const . const+  }++-- | A handler for 'gameInfoChangedEvent's.  It is called with the old game info+-- then the new game info.+type GameInfoChangedHandler go = GameInfo -> GameInfo -> go ()++-- | An event that is fired when a single step up or down in a game tree is+-- made.+navigationEvent :: Event go (NavigationHandler go)+navigationEvent = Event+  { eventName = "navigationEvent"+  , eventStateGetter = stateNavigationHandlers+  , eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers }+  , eventHandlerFromAction = const+  }++-- | A handler for 'navigationEvent's.+--+-- A navigation handler may navigate further, but beware infinite recursion.  A+-- navigation handler must end on the same node on which it started.+type NavigationHandler go = Step -> go ()++-- | An event corresponding to a modification to the properties list of the+-- current node.+propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go)+propertiesModifiedEvent = Event+  { eventName = "propertiesModifiedEvent"+  , eventStateGetter = statePropertiesModifiedHandlers+  , eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers }+  , eventHandlerFromAction = const . const+  }++-- | A handler for 'propertiesModifiedEvent's.  It is called with the old+-- property list then the new property list.+type PropertiesModifiedHandler go = [Property] -> [Property] -> go ()++-- | An event corresponding to a change in the active 'VariationMode'.  This can+-- happen when modifying the 'ST' property, and also when navigating between+-- collections (as they have different root nodes).+variationModeChangedEvent :: Event go (VariationModeChangedHandler go)+variationModeChangedEvent = Event+  { eventName = "variationModeChangedEvent"+  , eventStateGetter = stateVariationModeChangedHandlers+  , eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers }+  , eventHandlerFromAction = const . const+  }+-- TODO Test that this is fired when moving between root nodes in a collection.+-- For now, since we don't support multiple trees in a collection, we don't need+-- to worry about checking for active variation mode change on navigation.++-- | A handler for 'variationModeChangedEvent's.  It is called with the old+-- variation mode then the new variation mode.+type VariationModeChangedHandler go = VariationMode -> VariationMode -> go ()

@@ -0,0 +1,129 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | A parser for reading SGF files.+module Game.Goatee.Lib.Parser (+  parseString,+  parseFile,+  parseSubtree,+  propertyParser,+  ) where++import Control.Arrow ((+++))+import Control.Applicative ((<*), (*>))+import Data.Maybe (fromMaybe)+import Game.Goatee.Common+import Game.Goatee.Lib.Board+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Tree+import Game.Goatee.Lib.Types+import Text.ParserCombinators.Parsec (+  (<?>), Parser, char, eof, many, many1, parse, spaces, upper,+  )++-- | Parses a string in SGF format.  Returns an error string if parsing fails.+parseString :: String -> Either String Collection+parseString str = case parse collectionParser "<collection>" str of+  Left err -> Left $ show err+  Right (Collection roots) -> (concatErrors +++ Collection) $+                              andEithers $+                              map processRoot roots+  where processRoot :: Node -> Either String Node+        processRoot = checkFormatVersion . \root ->+          let SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $+                                findProperty propertySZ root+          in postProcessTree width height root++        concatErrors errs = "The following errors occurred while parsing:" +++                            concatMap ("\n-> " ++) errs++-- | Parses a file in SGF format.  Returns an error string if parsing fails.+parseFile :: String -> IO (Either String Collection)+parseFile = fmap parseString . readFile++-- | Parses a node as part of an existing game tree, from textual SGF+-- \"GameTree\" syntax.  The 'RootInfo' is needed to supply necessary+-- information from the existing game tree.+parseSubtree :: RootInfo -> String -> Either String Node+parseSubtree rootInfo str =+  case parse (spaces *> gameTreeParser <* spaces) "<gameTree>" str of+    Left err -> Left $ show err+    Right node ->+      let width = rootInfoWidth rootInfo+          height = rootInfoHeight rootInfo+      in Right $ postProcessTree width height node++-- Ensures that we are parsing an SGF version that we understand.+-- TODO Try to proceed, if it makes sense.+checkFormatVersion :: Node -> Either String Node+checkFormatVersion root =+  let version = case findProperty propertyFF root of+        Nothing -> defaultFormatVersion+        Just (FF x) -> x+        x -> error $ "Expected FF or nothing, received " ++ show x ++ "."+  in if version `elem` supportedFormatVersions+     then Right root+     else Left $+          "Unsupported SGF version " ++ show version ++ ".  Only versions " +++          show supportedFormatVersions ++ " are supported."++postProcessTree :: Int -> Int -> Node -> Node+postProcessTree width height node =+  -- SGF allows B[tt] and W[tt] to represent passes on boards <=19x19.+  -- Convert any passes from this format to B[] and W[] in a root node and+  -- its descendents.+  if width <= 19 && height <= 19 then convertNodeTtToPass node else node++convertNodeTtToPass :: Node -> Node+convertNodeTtToPass node =+  node { nodeProperties = map convertPropertyTtToPass $ nodeProperties node+       , nodeChildren = map convertNodeTtToPass $ nodeChildren node+       }++convertPropertyTtToPass :: Property -> Property+convertPropertyTtToPass prop = case prop of+  B (Just (19, 19)) -> B Nothing+  W (Just (19, 19)) -> W Nothing+  _ -> prop++collectionParser :: Parser Collection+collectionParser =+  fmap Collection (spaces *> many (gameTreeParser <* spaces) <* eof) <?>+  "collection"++gameTreeParser :: Parser Node+gameTreeParser = do+  char '('+  nodes <- spaces *> many1 (nodeParser <* spaces) <?> "sequence"+  subtrees <- many (gameTreeParser <* spaces) <?> "subtrees"+  char ')'+  let (sequence, [final]) = splitAt (length nodes - 1) nodes+  return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] })+                 (final { nodeChildren = subtrees })+                 sequence++nodeParser :: Parser Node+nodeParser =+  fmap (\props -> emptyNode { nodeProperties = props })+  (char ';' *> spaces *> many (propertyParser <* spaces) <?>+   "node")++propertyParser :: Parser Property+propertyParser = do+  name <- many1 upper+  spaces+  propertyValueParser $ descriptorForName name

@@ -0,0 +1,28 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Structures and functions for working with SGF node properties.+module Game.Goatee.Lib.Property (+  module Exported,+  PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty,+  ) where++import Game.Goatee.Lib.Property.Base as Exported+import Game.Goatee.Lib.Property.Info as Exported+import Game.Goatee.Lib.Property.Parser as Exported+import Game.Goatee.Lib.Property.Renderer as Exported+import Game.Goatee.Lib.Property.Value

@@ -0,0 +1,327 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Core property-related data types, and some Template Haskell declarations+-- for defining property metadata.+--+-- Import "Game.Goatee.Lib.Property" rather than importing this module.+module Game.Goatee.Lib.Property.Base (+  -- * Properties+  Property (..),+  -- * Property metadata+  PropertyType (..),+  Descriptor (..),+  SomeDescriptor (..),+  ValuedDescriptor (..),+  PropertyInfo,+  ValuedPropertyInfo (ValuedPropertyInfo),+  -- * Property declaration+  defProperty, defValuedProperty,+  ) where++import Control.Applicative ((<$))+import Game.Goatee.Lib.Property.Value (PropertyValueType(..), nonePvt)+import Game.Goatee.Lib.Renderer+import Game.Goatee.Lib.Types+import Language.Haskell.TH (+  Info (DataConI), DecsQ, Name, Type (AppT),+  appE, appT, caseE, conE, conP, conT, lam1E, match, mkName, newName,+  normalB, recP, reify, sigD, stringE, valD, varE, varP, wildP,+  )+import Text.ParserCombinators.Parsec (Parser)++-- | An SGF property that gives a node meaning.+data Property =+  -- Move properties.+    B (Maybe Coord)      -- ^ Black move (nothing iff pass).+  | KO                   -- ^ Execute move unconditionally (even if illegal).+  | MN Integer           -- ^ Assign move number.+  | W (Maybe Coord)      -- ^ White move (nothing iff pass).++  -- Setup properties.+  | AB CoordList         -- ^ Assign black stones.+  | AE CoordList         -- ^ Assign empty stones.+  | AW CoordList         -- ^ Assign white stones.+  | PL Color             -- ^ Player to play.++  -- Node annotation properties.+  | C Text               -- ^ Comment.+  | DM DoubleValue       -- ^ Even position.+  | GB DoubleValue       -- ^ Good for black.+  | GW DoubleValue       -- ^ Good for white.+  | HO DoubleValue       -- ^ Hotspot.+  | N SimpleText         -- ^ Node name.+  | UC DoubleValue       -- ^ Unclear position.+  | V RealValue          -- ^ Node value.++  -- Move annotation properties.+  | BM DoubleValue       -- ^ Bad move.+  | DO                   -- ^ Doubtful move.+  | IT                   -- ^ Interesting move.+  | TE DoubleValue       -- ^ Tesuji.++  -- Markup properties.+  | AR ArrowList         -- ^ Arrows.+  | CR CoordList         -- ^ Mark points with circles.+  | DD CoordList         -- ^ Dim points.+  | LB LabelList         -- ^ Label points with text.+  | LN LineList          -- ^ Lines.+  | MA CoordList         -- ^ Mark points with 'X's.+  | SL CoordList         -- ^ Mark points as selected.+  | SQ CoordList         -- ^ Mark points with squares.+  | TR CoordList         -- ^ Mark points with trianges.++  -- Root properties.+  | AP SimpleText SimpleText -- ^ Application info.+  | CA SimpleText        -- ^ Charset for SimpleText and Text.+  | FF Int               -- ^ File format version.+  | GM Int               -- ^ Game (must be 1 = Go).+  | ST VariationMode     -- ^ Variation display format.+  | SZ Int Int           -- ^ Board size, columns then rows.++  -- Game info properties.+  | AN SimpleText        -- ^ Name of annotator.+  | BR SimpleText        -- ^ Rank of black player.+  | BT SimpleText        -- ^ Name of black team.+  | CP SimpleText        -- ^ Copyright info.+  | DT SimpleText        -- ^ Dates played.+  | EV SimpleText        -- ^ Event name.+  | GC Text              -- ^ Game comment, or background, or summary.+  | GN SimpleText        -- ^ Game name.+  | ON SimpleText        -- ^ Information about the opening.+  | OT SimpleText        -- ^ The method used for overtime.+  | PB SimpleText        -- ^ Name of black player.+  | PC SimpleText        -- ^ Where the game was played.+  | PW SimpleText        -- ^ Name of white player.+  | RE GameResult        -- ^ Result of the game.+  | RO SimpleText        -- ^ Round info.+  | RU Ruleset           -- ^ Ruleset used.+  | SO SimpleText        -- ^ Source of the game.+  | TM RealValue         -- ^ Time limit, in seconds.+  | US SimpleText        -- ^ Name of user or program who entered the game.+  | WR SimpleText        -- ^ Rank of white player.+  | WT SimpleText        -- ^ Name of white team.++  -- Timing properties.+  | BL RealValue         -- ^ Black time left.+  | OB Int               -- ^ Black moves left in byo-yomi period.+  | OW Int               -- ^ White moves left in byo-yomi period.+  | WL RealValue         -- ^ White time left.++  -- Miscellaneous properties.+  -- TODO FG property.+  -- TODO PM property.+  | VW CoordList         -- ^ Set viewing region.++  -- Go-specific properties.+  | HA Int               -- ^ Handicap stones (>=2).+  | KM RealValue         -- ^ Komi.+  | TB CoordList         -- ^ Black territory.+  | TW CoordList         -- ^ White territory.++  | UnknownProperty String UnknownPropertyValue++  -- TODO Game info, timing, and miscellaneous properties.+  -- Also in functions below.+  deriving (Eq, Show)++-- | The property types that SGF uses to group properties.+data PropertyType = MoveProperty     -- ^ Cannot mix with setup nodes.+                  | SetupProperty    -- ^ Cannot mix with move nodes.+                  | RootProperty     -- ^ May only appear in root nodes.+                  | GameInfoProperty -- ^ At most one on any path.+                  | GeneralProperty  -- ^ May appear anywhere in the game tree.+                  deriving (Eq, Show)++-- | A class for types that contain metadata about a 'Property'.+class Descriptor a where+  -- | Returns the name of the property, as used in SGF files.+  propertyName :: a -> String++  -- | Returns the type of the property, as specified by the SGF spec.+  propertyType :: a -> PropertyType++  -- | Returns whether the value of the given property is inherited from the+  -- lowest ancestor specifying the property, when the property is not set on a+  -- node itself.+  propertyInherited :: a -> Bool++  -- | Returns whether the given property has the type of a descriptor.+  propertyPredicate :: a -> Property -> Bool++  -- | A parser of property values in SGF format (e.g. @"[ab]"@ for a property+  -- that takes a point).+  propertyValueParser :: a -> Parser Property++  -- | A renderer property values to SGF format (e.g. @B (Just (1,2))@ renders+  -- to @"[ab]"@).+  propertyValueRenderer :: a -> Property -> Render ()++  -- | A renderer for displaying property values in a UI.  Displays the value in+  -- a human-readable format.+  propertyValueRendererPretty :: a -> Property -> Render ()++data SomeDescriptor = forall a. Descriptor a => SomeDescriptor a++instance Descriptor SomeDescriptor where+  propertyName (SomeDescriptor d) = propertyName d+  propertyType (SomeDescriptor d) = propertyType d+  propertyInherited (SomeDescriptor d) = propertyInherited d+  propertyPredicate (SomeDescriptor d) = propertyPredicate d+  propertyValueParser (SomeDescriptor d) = propertyValueParser d+  propertyValueRenderer (SomeDescriptor d) = propertyValueRenderer d+  propertyValueRendererPretty (SomeDescriptor d) = propertyValueRendererPretty d++-- | A class for 'Descriptor's of 'Property's that also contain values.+class (Descriptor a, Eq v) => ValuedDescriptor a v | a -> v where+  -- | Extracts the value from a property of the given type.  Behaviour is+  -- undefined if the property is not of the given type.+  propertyValue :: a -> Property -> v++  -- | Builds a property from a given value.+  propertyBuilder :: a -> v -> Property++-- | Metadata for a property that does not contain a value.  Corresponds to a+-- single nullary data constructor of 'Property'.+data PropertyInfo = PropertyInfo+  { propertyInfoName :: String+    -- ^ The SGF textual name for the property.+  , propertyInfoInstance :: Property+    -- ^ The single instance of the property.+  , propertyInfoType :: PropertyType+    -- ^ The SGF property type.+  , propertyInfoInherited :: Bool+    -- ^ Whether the property is inherited.+  }++instance Descriptor PropertyInfo where+  propertyName = propertyInfoName+  propertyType = propertyInfoType+  propertyInherited = propertyInfoInherited+  propertyPredicate = (==) . propertyInfoInstance+  propertyValueParser descriptor = propertyInfoInstance descriptor <$ pvtParser nonePvt+  propertyValueRenderer _ _ = pvtRenderer nonePvt ()+  propertyValueRendererPretty _ _ = pvtRendererPretty nonePvt ()++-- | Metadata for a property that contains a value.  Corresponds to a single+-- unary data constructor of 'Property'.+data ValuedPropertyInfo v = ValuedPropertyInfo+  { valuedPropertyInfoName :: String+    -- ^ The SGF textual name for the property (also the name of the data+    -- constructor).+  , valuedPropertyInfoType :: PropertyType+    -- ^ The SGF property type.+  , valuedPropertyInfoInherited :: Bool+    -- ^ Whether the property is inherited.+  , valuedPropertyInfoPredicate :: Property -> Bool+    -- ^ A predicate that matches predicates to which this 'ValuedPropertyInfo'+    -- applies.+  , valuedPropertyInfoValueType :: PropertyValueType v+    -- ^ Metadata about the type of the property's value.+  , valuedPropertyInfoValue :: Property -> v+    -- ^ A function that extracts values from properties to which this+    -- 'ValuedPropertyInfo' applies.  It is invalid to call this function with a+    -- different type of property.+  , valuedPropertyInfoBuilder :: v -> Property+    -- ^ A function that builds a property containing a value.+  }++instance Descriptor (ValuedPropertyInfo v) where+  propertyName = valuedPropertyInfoName+  propertyType = valuedPropertyInfoType+  propertyInherited = valuedPropertyInfoInherited+  propertyPredicate = valuedPropertyInfoPredicate+  propertyValueParser descriptor =+    fmap (valuedPropertyInfoBuilder descriptor) $+    pvtParser $+    valuedPropertyInfoValueType descriptor+  propertyValueRenderer descriptor property =+    pvtRenderer (valuedPropertyInfoValueType descriptor) $+    valuedPropertyInfoValue descriptor property+  propertyValueRendererPretty descriptor property =+    pvtRendererPretty (valuedPropertyInfoValueType descriptor) $+    valuedPropertyInfoValue descriptor property++instance Eq v => ValuedDescriptor (ValuedPropertyInfo v) v where+  propertyValue = valuedPropertyInfoValue+  propertyBuilder = valuedPropertyInfoBuilder++-- | Template Haskell function to declare a property that does not contain a+-- value.+--+-- > $(defProperty "KO" 'MoveProperty False)+--+-- This example declares a @propertyKO :: 'PropertyInfo'@ that is a+-- 'MoveProperty' and is not inherited.+defProperty :: String+               -- ^ The SGF textual name of the property.+            -> Name+               -- ^ The name of the 'PropertyType'.+            -> Bool+               -- ^ Whether the property is inherited.+            -> DecsQ+defProperty name propType inherited = do+  let propName = mkName name+      varName = mkName $ "property" ++ name+  sequence [+    sigD varName $ conT $ mkName "PropertyInfo",+    valD (varP varName)+         (normalB [| PropertyInfo name $(conE propName) $(conE propType) inherited |])+         []+    ]++-- | Template Haskell function to declare a property that contains a value.+--+-- > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter)+--+-- This example declares a @propertyB :: 'ValuedPropertyInfo' (Maybe 'Coord')@+-- that is a 'MoveProperty' and is not inherited.  The value type is+-- automatically inferred.+defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ+defValuedProperty name propType inherited valueType = do+  let propName = mkName name+      varName = mkName $ "property" ++ name+  foo <- newName "foo"+  bar <- newName "bar"+  DataConI _ (AppT (AppT _ haskellValueType) _) _ _ <- reify propName+  sequence [+    sigD varName $ appT (conT ''ValuedPropertyInfo) $ return haskellValueType,+    valD (varP varName)+         (normalB [| ValuedPropertyInfo+                     name+                     $(conE propType)+                     inherited+                     $(lam1E (varP foo) $ caseE (varE foo)+                       [match (recP propName [])+                              (normalB $ conE $ mkName "True")+                              [],+                        match wildP (normalB $ conE $ mkName "False") []])+                     $(varE valueType)+                     $(lam1E (varP foo) $ caseE (varE foo)+                       [match (conP propName [varP bar]) (normalB $ varE bar) [],+                        match wildP+                              (normalB+                               [| error $ "Property value getter for " ++ $(stringE name) +++                                  " applied to " ++ show $(varE foo) ++ "." |])+                              []])+                     $(lam1E (varP foo) $ appE (conE propName) (varE foo))+                   |])+         []+    ]

@@ -0,0 +1,320 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Property metadata declarations.+--+-- Import "Game.Goatee.Lib.Property" rather than importing this module.+module Game.Goatee.Lib.Property.Info where++import Control.Arrow ((&&&))+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Game.Goatee.Lib.Property.Base+import Game.Goatee.Lib.Property.Value+import Game.Goatee.Lib.Types++-- Move properties.+$(defValuedProperty "B" 'MoveProperty False 'movePvt)+$(defProperty "KO" 'MoveProperty False)+$(defValuedProperty "MN" 'MoveProperty False 'integralPvt)+$(defValuedProperty "W" 'MoveProperty False 'movePvt)++-- Setup properties.+$(defValuedProperty "AB" 'SetupProperty False 'coordListPvt)+$(defValuedProperty "AE" 'SetupProperty False 'coordListPvt)+$(defValuedProperty "AW" 'SetupProperty False 'coordListPvt)+$(defValuedProperty "PL" 'SetupProperty False 'colorPvt)++-- Node annotation properties.+$(defValuedProperty "C" 'GeneralProperty False 'textPvt)+$(defValuedProperty "DM" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "GB" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "GW" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "HO" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "N" 'GeneralProperty False 'simpleTextPvt)+$(defValuedProperty "UC" 'GeneralProperty False 'doublePvt)+$(defValuedProperty "V" 'GeneralProperty False 'realPvt)++-- Move annotation properties.+$(defValuedProperty "BM" 'MoveProperty False 'doublePvt)+$(defProperty "DO" 'MoveProperty False)+$(defProperty "IT" 'MoveProperty False)+$(defValuedProperty "TE" 'MoveProperty False 'doublePvt)++-- Markup properties.+$(defValuedProperty "AR" 'GeneralProperty False 'coordPairListPvt)+$(defValuedProperty "CR" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "DD" 'GeneralProperty True 'coordListPvt)+$(defValuedProperty "LB" 'GeneralProperty False 'labelListPvt)+$(defValuedProperty "LN" 'GeneralProperty False 'coordPairListPvt)+$(defValuedProperty "MA" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "SL" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "SQ" 'GeneralProperty False 'coordListPvt)+$(defValuedProperty "TR" 'GeneralProperty False 'coordListPvt)++-- Root properties.+propertyAP :: ValuedPropertyInfo (SimpleText, SimpleText)+propertyAP = ValuedPropertyInfo "AP" RootProperty False+             (\x -> case x of { AP {} -> True; _ -> False })+             simpleTextPairPvt+             (\(AP x y) -> (x, y))+             (uncurry AP)+$(defValuedProperty "CA" 'RootProperty False 'simpleTextPvt)+$(defValuedProperty "FF" 'RootProperty False 'integralPvt)  -- TODO Add parser validation.+$(defValuedProperty "GM" 'RootProperty False 'integralPvt)  -- TODO Add parser validation.+$(defValuedProperty "ST" 'RootProperty False 'variationModePvt)+propertySZ :: ValuedPropertyInfo (Int, Int)+propertySZ = ValuedPropertyInfo "SZ" RootProperty False+             (\x -> case x of { SZ {} -> True; _ -> False })+             sizePvt+             (\(SZ x y) -> (x, y))+             (uncurry SZ)++-- Game info properties.+$(defValuedProperty "AN" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "BR" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "BT" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "CP" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "DT" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "EV" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "GC" 'GameInfoProperty False 'textPvt)+$(defValuedProperty "GN" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "ON" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "OT" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "PB" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "PC" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "PW" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "RE" 'GameInfoProperty False 'gameResultPvt)+$(defValuedProperty "RO" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "RU" 'GameInfoProperty False 'rulesetPvt)+$(defValuedProperty "SO" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "TM" 'GameInfoProperty False 'realPvt)+$(defValuedProperty "US" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "WR" 'GameInfoProperty False 'simpleTextPvt)+$(defValuedProperty "WT" 'GameInfoProperty False 'simpleTextPvt)++-- Timing properties.+$(defValuedProperty "BL" 'MoveProperty False 'realPvt)+$(defValuedProperty "OB" 'MoveProperty False 'integralPvt)+$(defValuedProperty "OW" 'MoveProperty False 'integralPvt)+$(defValuedProperty "WL" 'MoveProperty False 'realPvt)++-- Miscellaneous properties.+$(defValuedProperty "VW" 'GeneralProperty True 'coordElistPvt)++-- Go-specific properties.+$(defValuedProperty "HA" 'GameInfoProperty False 'integralPvt)+$(defValuedProperty "KM" 'GameInfoProperty False 'realPvt)+$(defValuedProperty "TB" 'GeneralProperty False 'coordElistPvt)+$(defValuedProperty "TW" 'GeneralProperty False 'coordElistPvt)++propertyUnknown :: String -> ValuedPropertyInfo UnknownPropertyValue+propertyUnknown name =+  ValuedPropertyInfo name GeneralProperty False+  (\x -> case x of+      UnknownProperty name' _ | name' == name -> True+      _ -> False)+  unknownPropertyPvt+  (\(UnknownProperty _ value) -> value)+  (UnknownProperty name)++allDescriptors :: [SomeDescriptor]+allDescriptors =+  [ SomeDescriptor propertyB+  , SomeDescriptor propertyKO+  , SomeDescriptor propertyMN+  , SomeDescriptor propertyW++  , SomeDescriptor propertyAB+  , SomeDescriptor propertyAE+  , SomeDescriptor propertyAW+  , SomeDescriptor propertyPL++  , SomeDescriptor propertyC+  , SomeDescriptor propertyDM+  , SomeDescriptor propertyGB+  , SomeDescriptor propertyGW+  , SomeDescriptor propertyHO+  , SomeDescriptor propertyN+  , SomeDescriptor propertyUC+  , SomeDescriptor propertyV++  , SomeDescriptor propertyBM+  , SomeDescriptor propertyDO+  , SomeDescriptor propertyIT+  , SomeDescriptor propertyTE++  , SomeDescriptor propertyAR+  , SomeDescriptor propertyCR+  , SomeDescriptor propertyDD+  , SomeDescriptor propertyLB+  , SomeDescriptor propertyLN+  , SomeDescriptor propertyMA+  , SomeDescriptor propertySL+  , SomeDescriptor propertySQ+  , SomeDescriptor propertyTR++  , SomeDescriptor propertyAP+  , SomeDescriptor propertyCA+  , SomeDescriptor propertyFF+  , SomeDescriptor propertyGM+  , SomeDescriptor propertyST+  , SomeDescriptor propertySZ++  , SomeDescriptor propertyAN+  , SomeDescriptor propertyBR+  , SomeDescriptor propertyBT+  , SomeDescriptor propertyCP+  , SomeDescriptor propertyDT+  , SomeDescriptor propertyEV+  , SomeDescriptor propertyGC+  , SomeDescriptor propertyGN+  , SomeDescriptor propertyON+  , SomeDescriptor propertyOT+  , SomeDescriptor propertyPB+  , SomeDescriptor propertyPC+  , SomeDescriptor propertyPW+  , SomeDescriptor propertyRE+  , SomeDescriptor propertyRO+  , SomeDescriptor propertyRU+  , SomeDescriptor propertySO+  , SomeDescriptor propertyTM+  , SomeDescriptor propertyUS+  , SomeDescriptor propertyWR+  , SomeDescriptor propertyWT++  , SomeDescriptor propertyBL+  , SomeDescriptor propertyOB+  , SomeDescriptor propertyOW+  , SomeDescriptor propertyWL++  , SomeDescriptor propertyVW++  , SomeDescriptor propertyHA+  , SomeDescriptor propertyKM+  , SomeDescriptor propertyTB+  , SomeDescriptor propertyTW+  ]++propertyInfo :: Property -> SomeDescriptor+propertyInfo property = case property of+  B {} -> SomeDescriptor propertyB+  KO {} -> SomeDescriptor propertyKO+  MN {} -> SomeDescriptor propertyMN+  W {} -> SomeDescriptor propertyW++  AB {} -> SomeDescriptor propertyAB+  AE {} -> SomeDescriptor propertyAE+  AW {} -> SomeDescriptor propertyAW+  PL {} -> SomeDescriptor propertyPL++  C {} -> SomeDescriptor propertyC+  DM {} -> SomeDescriptor propertyDM+  GB {} -> SomeDescriptor propertyGB+  GW {} -> SomeDescriptor propertyGW+  HO {} -> SomeDescriptor propertyHO+  N {} -> SomeDescriptor propertyN+  UC {} -> SomeDescriptor propertyUC+  V {} -> SomeDescriptor propertyV++  BM {} -> SomeDescriptor propertyBM+  DO {} -> SomeDescriptor propertyDO+  IT {} -> SomeDescriptor propertyIT+  TE {} -> SomeDescriptor propertyTE++  AR {} -> SomeDescriptor propertyAR+  CR {} -> SomeDescriptor propertyCR+  DD {} -> SomeDescriptor propertyDD+  LB {} -> SomeDescriptor propertyLB+  LN {} -> SomeDescriptor propertyLN+  MA {} -> SomeDescriptor propertyMA+  SL {} -> SomeDescriptor propertySL+  SQ {} -> SomeDescriptor propertySQ+  TR {} -> SomeDescriptor propertyTR++  AP {} -> SomeDescriptor propertyAP+  CA {} -> SomeDescriptor propertyCA+  FF {} -> SomeDescriptor propertyFF+  GM {} -> SomeDescriptor propertyGM+  ST {} -> SomeDescriptor propertyST+  SZ {} -> SomeDescriptor propertySZ++  AN {} -> SomeDescriptor propertyAN+  BR {} -> SomeDescriptor propertyBR+  BT {} -> SomeDescriptor propertyBT+  CP {} -> SomeDescriptor propertyCP+  DT {} -> SomeDescriptor propertyDT+  EV {} -> SomeDescriptor propertyEV+  GC {} -> SomeDescriptor propertyGC+  GN {} -> SomeDescriptor propertyGN+  ON {} -> SomeDescriptor propertyON+  OT {} -> SomeDescriptor propertyOT+  PB {} -> SomeDescriptor propertyPB+  PC {} -> SomeDescriptor propertyPC+  PW {} -> SomeDescriptor propertyPW+  RE {} -> SomeDescriptor propertyRE+  RO {} -> SomeDescriptor propertyRO+  RU {} -> SomeDescriptor propertyRU+  SO {} -> SomeDescriptor propertySO+  TM {} -> SomeDescriptor propertyTM+  US {} -> SomeDescriptor propertyUS+  WR {} -> SomeDescriptor propertyWR+  WT {} -> SomeDescriptor propertyWT++  BL {} -> SomeDescriptor propertyBL+  OB {} -> SomeDescriptor propertyOB+  OW {} -> SomeDescriptor propertyOW+  WL {} -> SomeDescriptor propertyWL++  VW {} -> SomeDescriptor propertyVW++  HA {} -> SomeDescriptor propertyHA+  KM {} -> SomeDescriptor propertyKM+  TB {} -> SomeDescriptor propertyTB+  TW {} -> SomeDescriptor propertyTW++  UnknownProperty name _ -> SomeDescriptor $ propertyUnknown name++instance Descriptor Property where+  propertyName = propertyName . propertyInfo+  propertyType = propertyType . propertyInfo+  propertyInherited = propertyInherited . propertyInfo+  propertyPredicate = propertyPredicate . propertyInfo+  propertyValueParser = propertyValueParser . propertyInfo+  propertyValueRenderer = propertyValueRenderer . propertyInfo+  propertyValueRendererPretty = propertyValueRendererPretty . propertyInfo++descriptorsByName :: Map String SomeDescriptor+descriptorsByName = Map.fromList $ map (propertyName &&& id) allDescriptors++descriptorForName :: String -> SomeDescriptor+descriptorForName name = fromMaybe (SomeDescriptor $ propertyUnknown name) $ descriptorForName' name++descriptorForName' :: String -> Maybe SomeDescriptor+descriptorForName' = flip Map.lookup descriptorsByName++-- | Returns the descriptor for a mark.+markProperty :: Mark -> ValuedPropertyInfo CoordList+markProperty MarkCircle = propertyCR+markProperty MarkSelected = propertySL+markProperty MarkSquare = propertySQ+markProperty MarkTriangle = propertyTR+markProperty MarkX = propertyMA

@@ -0,0 +1,252 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <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,+  coordListParser,+  coordPairListParser,+  doubleParser,+  gameResultParser,+  labelListParser,+  moveParser,+  noneParser,+  integralParser,+  realParser,+  rulesetParser,+  simpleTextPairParser,+  simpleTextParser,+  sizeParser,+  textParser,+  unknownPropertyParser,+  variationModeParser,+  -- * Exposed for testing+  compose,+  line,+  simpleText,+  text,+  ) where++import Control.Applicative ((<$), (<$>), (<*), (<*>), (*>))+import Control.Monad (when)+import Data.Char (isUpper, ord)+import Data.Maybe (catMaybes)+import Data.Monoid (Monoid, mappend, mconcat, mempty)+import qualified Game.Goatee.Common.Bigfloat as BF+import Game.Goatee.Lib.Types+import Text.ParserCombinators.Parsec (+  (<?>), (<|>), Parser,+  anyChar, char, choice, digit, many, many1,+  noneOf, oneOf, option, space, spaces, string,+  try, unexpected,+  )++{-# ANN module "HLint: ignore Reduce duplication" #-}++-- Internal parser builders not corresponding to any particular value type.++-- | A wrapper around 'CoordList' with a 'Monoid' instance used for parsing.+-- The monoid does simple concatenation of the single and rectangle lists, so it+-- is not appropriate for @CoordList@ proper, as it doesn't do duplicate removal+-- between two @CoordList@s.+newtype CoordListMonoid = CoordListMonoid { runCoordListMonoid :: CoordList }++instance Monoid CoordListMonoid where+  mempty = CoordListMonoid emptyCoordList++  mappend (CoordListMonoid x) (CoordListMonoid y) =+    CoordListMonoid $ coords' (coordListSingles x ++ coordListSingles y)+                              (coordListRects x ++ coordListRects y)++single :: Parser a -> Parser a+single valueParser = char '[' *> valueParser <* char ']'++compose :: Parser a -> Parser b -> Parser (a, b)+compose first second = do+  x <- first+  char ':'+  y <- second+  return (x, y)++line :: Parser Int+line = toLine <$> line' <?> "line"+  where line' = oneOf $ ['a'..'z'] ++ ['A'..'Z']+        toLine c = if isUpper c+                   then ord c - ord 'A' + 26+                   else ord c - ord 'a'++listOf :: Parser a -> Parser [a]+listOf valueParser = many1 (single valueParser <* spaces)++number :: Parser String+number = do+  addSign <- ('-':) <$ char '-' <|>+             id <$ char '+' <|>+             return id+  addSign <$> many1 digit++-- Public parsers.++colorParser :: Parser Color+colorParser = single color <?> "color"++color :: Parser Color+color = choice [Black <$ char 'B',+                White <$ char 'W']++coord :: Parser Coord+coord = (,) <$> line <*> line++coordElistParser :: Parser CoordList+coordElistParser =+  try (emptyCoordList <$ string "[]") <|>+  coordListParser <?>+  "list of points or empty"++coordListParser :: Parser CoordList+coordListParser =+  runCoordListMonoid . mconcat . map CoordListMonoid <$> listOf coordListEntry <?>+  "list of points"+  where coordListEntry = do x0 <- line+                            y0 <- line+                            choice [do char ':'+                                       x1 <- line+                                       y1 <- line+                                       return $ coordR ((x0, y0), (x1, y1)),+                                    return $ coord1 (x0, y0)]+        coordR rect = coords' [] [rect]++coordPairListParser :: Parser [(Coord, Coord)]+coordPairListParser = listOf coordPair <?> "list of point pairs"+  where coordPair = do+          x0 <- line+          y0 <- line+          char ':'+          x1 <- line+          y1 <- line+          return ((x0, y0), (x1, y1))++doubleParser :: Parser DoubleValue+doubleParser =+  single (Double1 <$ char '1' <|>+          Double2 <$ char '2') <?>+  "double"++gameResultParser :: Parser GameResult+gameResultParser = single (convertStringlike <$> simpleText False) <?> "game result"++labelListParser :: Parser [(Coord, SimpleText)]+labelListParser =+  listOf (compose coord $ simpleText True) <?> "list of points and labels"++moveParser :: Parser (Maybe Coord)+moveParser =+  char '[' *> (Nothing <$ char ']' <|> Just <$> coord <* char ']') <?>+  "move (point or pass)"++noneParser :: Parser ()+noneParser = () <$ string "[]" <?> "none"++-- This is what the SGF spec calls the Number type, i.e. a signed integer.+integralParser :: (Integral a, Read a) => Parser a+integralParser = single integral <?> "integer"++integral :: (Integral a, Read a) => Parser a+integral = read <$> number++realParser :: Parser RealValue+realParser = single real <?> "real"++real :: Parser RealValue+real = do+  whole <- number+  -- Try to read a fractional part of the number.+  -- If we fail, just return the whole part.+  option (fromInteger $ read whole) $ try $ do+    fractional <- char '.' *> many1 digit+    return $ BF.encode (read $ whole ++ fractional) (-length fractional)++rulesetParser :: Parser Ruleset+rulesetParser =+  single (toRuleset . fromSimpleText <$> simpleText False) <?> "ruleset"++simpleTextPairParser :: Parser (SimpleText, SimpleText)+simpleTextPairParser = single (compose composedText composedText) <?> "pair of simple texts"+  where composedText = simpleText True++-- | A parser for SGF SimpleText property values.+simpleTextParser :: Parser SimpleText+simpleTextParser = single (simpleText False) <?> "simple text"++simpleText :: Bool -> Parser SimpleText+simpleText isComposed = toSimpleText <$> text isComposed++sizeParser :: Parser (Int, Int)+sizeParser =+  (do char '['+      width <- integral+      height <- choice [width <$ char ']',+                        do char ':'+                           height <- integral+                           char ']'+                           -- TODO We should warn here rather than aborting.+                           when (width == height) $+                             fail $ show width ++ "x" ++ show height ++ " square board " +++                             " dimensions should be specified with a single number."+                           return height]+      when (width < 1 || width > boardSizeMax ||+            height < 1 || height > boardSizeMax) $+        fail $ show width ++ "x" ++ show height ++ " board dimensions are invalid.  " +++        "Each dimension must be between 1 and 52 inclusive."+      return (width, height)) <?>+  "board size (width or width:height)"++textParser :: Parser Text+textParser = single (toText <$> text False) <?> "text"++-- | A parser for SGF text property values.  Its argument should be true if the+-- text is inside of a composed property value, so @\':\'@ should terminate the+-- value in addition to @']'@.+text :: Bool -> Parser String+text isComposed = catMaybes <$> many textChar'+  where textChar' = textChar (if isComposed then ":]\\" else "]\\")++textChar :: String -> Parser (Maybe Char)+textChar specialChars =+  choice [Just <$> char '\n',+          Just ' ' <$ space,+          try (char '\\' *> (Nothing <$ char '\n' <|>+                             Just <$> anyChar)),+          Just <$> noneOf specialChars]++unknownPropertyParser :: Parser UnknownPropertyValue+unknownPropertyParser =+  single (toUnknownPropertyValue <$> text False) <?>+  "unknown property value"++variationModeParser :: Parser VariationMode+variationModeParser = single variationMode <?> "variation mode"++variationMode :: Parser VariationMode+variationMode = do+  value <- integral+  case toVariationMode value of+    Just mode -> return mode+    Nothing -> unexpected $ "variation mode " ++ show value

@@ -0,0 +1,332 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | Renderers of property values.+--+-- Import "Game.Goatee.Lib.Property" rather than importing this module.+module Game.Goatee.Lib.Property.Renderer (+  renderColorBracketed,+  renderColorPretty,+  renderCoordElistBracketed,+  renderCoordElistPretty,+  renderCoordListBracketed,+  renderCoordListPretty,+  renderCoordPairListBracketed,+  renderCoordPairListPretty,+  renderDoubleBracketed,+  renderDoublePretty,+  renderGameResultBracketed,+  renderGameResultPretty,+  renderGameResultPretty',+  renderIntegralBracketed,+  renderIntegralPretty,+  renderLabelListBracketed,+  renderLabelListPretty,+  renderMoveBracketed,+  renderMovePretty,+  renderNoneBracketed,+  renderNonePretty,+  renderRealBracketed,+  renderRealPretty,+  renderRulesetBracketed,+  renderRulesetPretty,+  renderSimpleTextBracketed,+  renderSimpleTextPairBracketed,+  renderSimpleTextPairPretty,+  renderSimpleTextPretty,+  renderSizeBracketed,+  renderSizePretty,+  renderTextBracketed,+  renderTextPretty,+  renderUnknownPropertyBracketed,+  renderUnknownPropertyPretty,+  renderVariationModeBracketed,+  renderVariationModePretty,+  ) where++import Control.Monad (forM_, void, when)+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (throwError)+#else+import Control.Monad.Error (throwError)+#endif+import Control.Monad.Writer (tell)+import Data.Char (chr, ord)+import Data.List (intersperse)+import qualified Game.Goatee.Common.Bigfloat as BF+import Game.Goatee.Lib.Renderer+import Game.Goatee.Lib.Types++{-# ANN module "HLint: ignore Use <$>" #-}++-- Internal renderers not corresponding to any particular value type.++bracketed :: Render () -> Render ()+bracketed x = tell "[" >> x >> tell "]"++renderLine :: Int -> Render ()+renderLine = rendererOf "line" $ \x ->+  if x >= 0 && x < 52+  then tell [chr $ x + (if x < 26 then ord 'a' else ord 'A' - 26)]+  else throwError $ "renderLine: Index not in [0, 52): " ++ show x++renderCoord :: Coord -> Render ()+renderCoord = rendererOf "coord" $ \(x, y) -> renderLine x >> renderLine y++renderCoordBracketed :: Coord -> Render ()+renderCoordBracketed = fmap bracketed renderCoord++renderCoordPretty :: Coord -> Render ()+renderCoordPretty = rendererOf "coord pretty" $ \(x, y) ->+  mapM_ tell ["(", show x, ", ", show y, ")"]++renderCoordPairPretty :: (Coord, Coord) -> Render ()+renderCoordPairPretty = rendererOf "coord pair pretty" $ \(a, b) -> do+  renderCoordPretty a+  tell "-"+  renderCoordPretty b++renderCoordPair :: (Coord, Coord) -> Render ()+renderCoordPair = rendererOf "coord pair" $ \(a, b) ->+  renderCoord a >> tell ":" >> renderCoord b++renderCoordPairBracketed :: (Coord, Coord) -> Render ()+renderCoordPairBracketed = fmap bracketed renderCoordPair++renderShowable :: Show a => a -> Render ()+renderShowable = tell . show++renderStringlike :: (Show a, Stringlike a) => Bool -> a -> Render ()+renderStringlike isComposed =+  rendererOf (if isComposed then "composed stringlike" else "stringlike") $ \str ->+  tell $ escape $ sgfToString str+  where escape [] = []+        escape (first:rest) | first `elem` specialChars = '\\':first:escape rest+                            | otherwise = first:escape rest+        -- TODO Deduplicate these characters with the parser:+        specialChars = if isComposed then ":]\\" else "]\\"++-- Note that unlike the serialized SGF version, we don't care about escaping+-- characters in composed strings.+renderStringlikePretty :: (Show a, Stringlike a) => a -> Render ()+renderStringlikePretty = rendererOf "stringlike pretty" $ tell . sgfToString++-- Public renderers.++renderColorBracketed :: Color -> Render ()+renderColorBracketed color = bracketed $ tell $ case color of+  Black -> "B"+  White -> "W"++renderColorPretty :: Color -> Render ()+renderColorPretty Black = tell "Black"+renderColorPretty White = tell "White"++renderCoordElistBracketed :: CoordList -> Render ()+renderCoordElistBracketed = rendererOf "coord elist bracketed" $ \list ->+  if null $ expandCoordList list+  then tell "[]"+  else renderCoordListNonempty list++renderCoordElistPretty :: CoordList -> Render ()+renderCoordElistPretty = rendererOf "coord elist pretty" $ \list ->+  if null $ expandCoordList list+  then tell "empty"+  else renderCoordListNonemptyPretty list++renderCoordListBracketed :: CoordList -> Render ()+renderCoordListBracketed = rendererOf "coord list bracketed" $ \list ->+  if null $ expandCoordList list+  then throwError "renderCoordListBracketed: Unexpected empty CoordList."+  else renderCoordListNonempty list++renderCoordListPretty :: CoordList -> Render ()+renderCoordListPretty = rendererOf "coord list pretty" $ \list ->+  if null $ expandCoordList list+  then throwError "renderCoordListPretty: Unexpected empty CoordList."+  else renderCoordListNonemptyPretty list++renderCoordListNonempty :: CoordList -> Render ()+renderCoordListNonempty = rendererOf "coord list nonempty" $ \list -> do+  mapM_ renderCoordPairBracketed $ coordListRects list+  mapM_ renderCoordBracketed $ coordListSingles list++renderCoordListNonemptyPretty :: CoordList -> Render ()+renderCoordListNonemptyPretty = rendererOf "coord list nonempty pretty" $ \list ->+  sequence_ $ intersperse (tell ", ") $+  map renderCoordPairPretty (coordListRects list) +++  map renderCoordPretty (coordListSingles list)++renderCoordPairListBracketed :: [(Coord, Coord)] -> Render ()+renderCoordPairListBracketed = rendererOf "coord pair list bracketed" $ \list ->+  if null list+  then throwError "renderCoordPairListBracketed: Unexpected empty list."+  else mapM_ renderCoordPairBracketed list++renderCoordPairListPretty :: [(Coord, Coord)] -> Render ()+renderCoordPairListPretty list =+  if null list+  then throwError "renderCoordPairListPretty: Unexpected empty list."+  else sequence_ $ intersperse (tell ", ") $ map renderCoordPairPretty list++renderDoubleBracketed :: DoubleValue -> Render ()+renderDoubleBracketed = fmap bracketed $ rendererOf "double" $ \double -> tell $ case double of+  Double1 -> "1"+  Double2 -> "2"++renderDoublePretty :: DoubleValue -> Render ()+renderDoublePretty = rendererOf "double pretty" $ tell . \double -> case double of+  Double1 -> "1"+  Double2 -> "2"++renderGameResultBracketed :: GameResult -> Render ()+renderGameResultBracketed = fmap bracketed $ rendererOf "game result" $ \result -> case result of+  GameResultWin color reason ->+    tell $+    (case color of { Black -> 'B'; White -> 'W' }) : '+' :+    (case reason of+        WinByScore diff -> show diff+        WinByResignation -> "R"+        WinByTime -> "T"+        WinByForfeit -> "F")+  GameResultDraw -> tell "0"+  GameResultVoid -> tell "Void"+  GameResultUnknown -> tell "?"+  GameResultOther text -> renderStringlike False text++renderGameResultPretty :: GameResult -> Render ()+renderGameResultPretty =+  rendererOf "game result pretty" $ void . tell . renderGameResultPretty'++renderGameResultPretty' :: GameResult -> String+renderGameResultPretty' result = case result of+  GameResultWin color reason ->+    (case color of { Black -> 'B'; White -> 'W' }) : '+' :+    (case reason of+        WinByScore diff -> show diff+        WinByResignation -> "Resign"+        WinByTime -> "Time"+        WinByForfeit -> "Forfeit")+  GameResultDraw -> "Draw"+  GameResultVoid -> "Void"+  GameResultUnknown -> "Unknown"+  GameResultOther text -> sgfToString text++renderIntegralBracketed :: (Integral a, Show a) => a -> Render ()+renderIntegralBracketed = bracketed . rendererOf "integral" renderShowable++renderIntegralPretty :: (Integral a, Show a) => a -> Render ()+renderIntegralPretty = rendererOf "integral pretty" renderShowable++renderLabelListBracketed :: [(Coord, SimpleText)] -> Render ()+renderLabelListBracketed = rendererOf "label list" $ \list ->+  if null list+  then throwError "renderLabelListBracketed: Unexpected empty list."+  else forM_ list $ bracketed . \(coord, text) -> do+    renderCoord coord+    tell ":"+    renderStringlike True text++renderLabelListPretty :: [(Coord, SimpleText)] -> Render ()+renderLabelListPretty = rendererOf "label list pretty" $ \list ->+  if null list+  then throwError "renderLabelListPretty: Unexpected empty list."+  else sequence_ $ intersperse (tell ", ") $+       map (\(coord, text) -> do+               renderCoordPretty coord+               tell ":"+               renderStringlikePretty text)+       list++renderMoveBracketed :: Maybe Coord -> Render ()+renderMoveBracketed = rendererOf "move bracketed" $ maybe (tell "[]") renderCoordBracketed++renderMovePretty :: Maybe Coord -> Render ()+renderMovePretty = rendererOf "move pretty" $ maybe (tell "Pass") renderCoordPretty++renderNoneBracketed :: () -> Render ()+renderNoneBracketed = rendererOf "none bracketed" $ tell . const "[]"++renderNonePretty :: () -> Render ()+renderNonePretty = rendererOf "none pretty" $ tell . const ""++renderRealBracketed :: RealValue -> Render ()+renderRealBracketed =+  fmap bracketed $ rendererOf "real" (renderShowable :: BF.Bigfloat -> Render ())++renderRealPretty :: RealValue -> Render ()+renderRealPretty = rendererOf "real pretty" (renderShowable :: BF.Bigfloat -> Render ())++renderRulesetBracketed :: Ruleset -> Render ()+renderRulesetBracketed = fmap bracketed $ rendererOf "ruleset" $ tell . fromRuleset++renderRulesetPretty :: Ruleset -> Render ()+renderRulesetPretty = rendererOf "ruleset pretty" $ tell . fromRuleset++renderSimpleTextPairBracketed :: (SimpleText, SimpleText) -> Render ()+renderSimpleTextPairBracketed = fmap bracketed $ rendererOf "simple text pair" $ \(a, b) -> do+  renderStringlike True a+  tell ":"+  renderStringlike True b++renderSimpleTextPairPretty :: (SimpleText, SimpleText) -> Render ()+renderSimpleTextPairPretty = rendererOf "simple text pair pretty" $ \(a, b) -> do+  renderStringlike True a+  tell " "+  renderStringlike True b++renderSimpleTextBracketed :: SimpleText -> Render ()+renderSimpleTextBracketed = fmap bracketed $ rendererOf "simple text" $ renderStringlike False++renderSimpleTextPretty :: SimpleText -> Render ()+renderSimpleTextPretty = rendererOf "simple text pretty" $ tell . fromSimpleText++renderSizeBracketed :: (Int, Int) -> Render ()+renderSizeBracketed = fmap bracketed $ rendererOf "size" $ \(x, y) -> do+  tell $ show x+  when (x /= y) $ tell $ ':' : show y++renderSizePretty :: (Int, Int) -> Render ()+renderSizePretty = rendererOf "size pretty" renderCoordPretty++renderTextBracketed :: Text -> Render ()+renderTextBracketed = fmap bracketed $ rendererOf "text" $ renderStringlike False++renderTextPretty :: Text -> Render ()+renderTextPretty = rendererOf "text pretty" $ tell . fromText++renderUnknownPropertyBracketed :: UnknownPropertyValue -> Render ()+renderUnknownPropertyBracketed =+  fmap bracketed $ rendererOf "unknown property" $ renderStringlike False++renderUnknownPropertyPretty :: UnknownPropertyValue -> Render ()+renderUnknownPropertyPretty =+  rendererOf "unknown property pretty" $ tell . fromUnknownPropertyValue++renderVariationModeBracketed :: VariationMode -> Render ()+renderVariationModeBracketed =+  fmap bracketed $ rendererOf "variation mode" $ tell . show . fromVariationMode++renderVariationModePretty :: VariationMode -> Render ()+renderVariationModePretty = rendererOf "variation mode pretty" $ \(VariationMode source markup) ->+  tell $+  (case source of+      ShowChildVariations -> "Children"+      ShowCurrentVariations -> "Current") ++ " " +++  (if markup then "Shown" else "Hidden")

@@ -0,0 +1,179 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Metadata about the types of property values.+--+-- Import "Game.Goatee.Lib.Property" rather than importing this module.+module Game.Goatee.Lib.Property.Value (+  PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty,+  colorPvt,+  coordElistPvt,+  coordListPvt,+  coordPairListPvt,+  doublePvt,+  gameResultPvt,+  integralPvt,+  labelListPvt,+  movePvt,+  nonePvt,+  realPvt,+  rulesetPvt,+  simpleTextPairPvt,+  simpleTextPvt,+  sizePvt,+  textPvt,+  unknownPropertyPvt,+  variationModePvt,+  ) where++import qualified Game.Goatee.Lib.Property.Parser as P+import qualified Game.Goatee.Lib.Property.Renderer as R+import Game.Goatee.Lib.Renderer+import Game.Goatee.Lib.Types+import Text.ParserCombinators.Parsec (Parser)++data PropertyValueType a = PropertyValueType+  { pvtParser :: Parser a+  , pvtRenderer :: a -> Render ()+  , pvtRendererPretty :: a -> Render ()+  }++colorPvt :: PropertyValueType Color+colorPvt = PropertyValueType+  { pvtParser = P.colorParser+  , pvtRenderer = R.renderColorBracketed+  , pvtRendererPretty = R.renderColorPretty+  }++coordElistPvt :: PropertyValueType CoordList+coordElistPvt = PropertyValueType+  { pvtParser = P.coordElistParser+  , pvtRenderer = R.renderCoordElistBracketed+  , pvtRendererPretty = R.renderCoordElistPretty+  }++coordListPvt :: PropertyValueType CoordList+coordListPvt = PropertyValueType+  { pvtParser = P.coordListParser+  , pvtRenderer = R.renderCoordListBracketed+  , pvtRendererPretty = R.renderCoordListPretty+  }++coordPairListPvt :: PropertyValueType [(Coord, Coord)]+coordPairListPvt = PropertyValueType+  { pvtParser = P.coordPairListParser+  , pvtRenderer = R.renderCoordPairListBracketed+  , pvtRendererPretty = R.renderCoordPairListPretty+  }++doublePvt :: PropertyValueType DoubleValue+doublePvt = PropertyValueType+  { pvtParser = P.doubleParser+  , pvtRenderer = R.renderDoubleBracketed+  , pvtRendererPretty = R.renderDoublePretty+  }++gameResultPvt :: PropertyValueType GameResult+gameResultPvt = PropertyValueType+  { pvtParser = P.gameResultParser+  , pvtRenderer = R.renderGameResultBracketed+  , pvtRendererPretty = R.renderGameResultPretty+  }++integralPvt :: (Integral a, Read a, Show a) => PropertyValueType a+integralPvt = PropertyValueType+  { pvtParser = P.integralParser+  , pvtRenderer = R.renderIntegralBracketed+  , pvtRendererPretty = R.renderIntegralPretty+  }++labelListPvt :: PropertyValueType [(Coord, SimpleText)]+labelListPvt = PropertyValueType+  { pvtParser = P.labelListParser+  , pvtRenderer = R.renderLabelListBracketed+  , pvtRendererPretty = R.renderLabelListPretty+  }++movePvt :: PropertyValueType (Maybe Coord)+movePvt = PropertyValueType+  { pvtParser = P.moveParser+  , pvtRenderer = R.renderMoveBracketed+  , pvtRendererPretty = R.renderMovePretty+  }++nonePvt :: PropertyValueType ()+nonePvt = PropertyValueType+  { pvtParser = P.noneParser+  , pvtRenderer = R.renderNoneBracketed+  , pvtRendererPretty = R.renderNonePretty+  }++realPvt :: PropertyValueType RealValue+realPvt = PropertyValueType+  { pvtParser = P.realParser+  , pvtRenderer = R.renderRealBracketed+  , pvtRendererPretty = R.renderRealPretty+  }++rulesetPvt :: PropertyValueType Ruleset+rulesetPvt = PropertyValueType+  { pvtParser = P.rulesetParser+  , pvtRenderer = R.renderRulesetBracketed+  , pvtRendererPretty = R.renderRulesetPretty+  }++simpleTextPairPvt :: PropertyValueType (SimpleText, SimpleText)+simpleTextPairPvt = PropertyValueType+  { pvtParser = P.simpleTextPairParser+  , pvtRenderer = R.renderSimpleTextPairBracketed+  , pvtRendererPretty = R.renderSimpleTextPairPretty+  }++simpleTextPvt :: PropertyValueType SimpleText+simpleTextPvt = PropertyValueType+  { pvtParser = P.simpleTextParser+  , pvtRenderer = R.renderSimpleTextBracketed+  , pvtRendererPretty = R.renderSimpleTextPretty+  }++sizePvt :: PropertyValueType (Int, Int)+sizePvt = PropertyValueType+  { pvtParser = P.sizeParser+  , pvtRenderer = R.renderSizeBracketed+  , pvtRendererPretty = R.renderSizePretty+  }++textPvt :: PropertyValueType Text+textPvt = PropertyValueType+  { pvtParser = P.textParser+  , pvtRenderer = R.renderTextBracketed+  , pvtRendererPretty = R.renderTextPretty+  }++unknownPropertyPvt :: PropertyValueType UnknownPropertyValue+unknownPropertyPvt = PropertyValueType+  { pvtParser = P.unknownPropertyParser+  , pvtRenderer = R.renderUnknownPropertyBracketed+  , pvtRendererPretty = R.renderUnknownPropertyPretty+  }++variationModePvt :: PropertyValueType VariationMode+variationModePvt = PropertyValueType+  { pvtParser = P.variationModeParser+  , pvtRenderer = R.renderVariationModeBracketed+  , pvtRendererPretty = R.renderVariationModePretty+  }

@@ -0,0 +1,56 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}++-- | Common definitions for a renderer that supports failure.+module Game.Goatee.Lib.Renderer (+  Render,+  runRender,+  rendererOf,+  ) where++#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (Except, catchError, runExcept, throwError)+#else+import Control.Monad.Error (catchError, throwError)+#endif+import Control.Monad.Writer (WriterT, execWriterT)++-- | A monad for accumulating string output with the possibility of failure.+#if MIN_VERSION_mtl(2,2,1)+type Render = WriterT String (Except String)+#else+type Render = WriterT String (Either String)+#endif++-- | Returns either the rendered result on the right, or a message describing a+-- failure on the left.+runRender :: Render a -> Either String String+#if MIN_VERSION_mtl(2,2,1)+runRender = runExcept . execWriterT+#else+runRender = execWriterT+#endif++-- | Wraps a renderer in an exception handler that, when the renderer or+-- something it calls fails, will add context about this renderer's invocation+-- to the failure message.+rendererOf :: Show a => String -> (a -> Render ()) -> a -> Render ()+rendererOf description renderer value = catchError (renderer value) $ \message ->+  throwError $+  message ++ "\n    while trying to render " ++ description ++ " from " ++ show value ++ "."

@@ -0,0 +1,60 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Functions for serializing SGF trees.+module Game.Goatee.Lib.Renderer.Tree (+  renderCollection,+  renderGameTree,+  renderProperty,+  ) where++import Control.Monad.Writer (tell)+import Game.Goatee.Common+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Renderer+import Game.Goatee.Lib.Tree++-- | Renders an SGF 'Collection' to a string.+renderCollection :: Collection -> Render ()+renderCollection collection = do+  mapM_ renderGameTree $ collectionTrees collection+  tell "\n"++-- | Recursively renders an SGF GameTree (as defined in the spec) rooted at the+-- given node.+renderGameTree :: Node -> Render ()+renderGameTree node = do+  tell "("+  doWhileM node+    (\node' -> do renderNode node'+                  case nodeChildren node' of+                    [] -> return $ Left Nothing+                    child:[] -> return $ Right child+                    children -> return $ Left $ Just children)+    >>= maybe (return ()) (mapM_ renderGameTree)+  tell ")"++-- | Renders a node and its properties without recurring to its children.+renderNode :: Node -> Render ()+renderNode node = do+  tell "\n;"+  mapM_ renderProperty $ nodeProperties node++renderProperty :: Property -> Render ()+renderProperty property = do+  tell $ propertyName property+  propertyValueRenderer property property

@@ -0,0 +1,188 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | SGF data structures modelling the hierarchical game tree.+module Game.Goatee.Lib.Tree (+  Collection(..), CollectionWithDeepEquality(..),+  Node(..), NodeWithDeepEquality(..),+  emptyNode, rootNode,+  findProperty, findProperty', findPropertyValue, findPropertyValue',+  addProperty, addChild, addChildAt, deleteChildAt,+  validateNode,+  ) where++import Control.Applicative ((<$>))+import Control.Monad (forM_, unless, when)+import Control.Monad.Writer (Writer, execWriter, tell)+import Data.Function (on)+import Data.List (find, groupBy, intercalate, nub, sortBy)+import Data.Version (showVersion)+import Game.Goatee.App (applicationName)+import Game.Goatee.Common+import Game.Goatee.Lib.Property+import Game.Goatee.Lib.Types+import Paths_goatee (version)++-- | An SGF collection of game trees.+data Collection = Collection+  { collectionTrees :: [Node]+  } deriving (Show)++-- | See 'NodeWithDeepEquality'.+newtype CollectionWithDeepEquality = CollectionWithDeepEquality+  { collectionWithDeepEquality :: Collection+  } deriving (Show)++instance Eq CollectionWithDeepEquality where+  (==) = (==) `on` map NodeWithDeepEquality . collectionTrees . collectionWithDeepEquality++-- | An SGF game tree node.  Unlike in the SGF spec, we represent a game tree+-- with nodes uniformly, rather than having the separation between sequences and+-- nodes.+data Node = Node+  { nodeProperties :: [Property]+  , nodeChildren :: [Node]+  } deriving (Show)++-- | A wrapper around 'Node' with an 'Eq' instance that considers two nodes+-- equal iff they contain the same properties (not necessarily in the same+-- order), and if they contain children (in the same order) whose nodes are+-- recursively equal.+--+-- This instance is not on 'Node' directly because it is not the only obvious+-- sense of equality (only comparing properties would be another one), and it's+-- also potentially expensive.+newtype NodeWithDeepEquality = NodeWithDeepEquality { nodeWithDeepEquality :: Node }++instance Eq NodeWithDeepEquality where+  node1 == node2 =+    let n1 = nodeWithDeepEquality node1+        n2 = nodeWithDeepEquality node2+    in propertiesSorted n1 == propertiesSorted n2 &&+       deepChildren n1 == deepChildren n2+    where propertiesSorted = sortBy (compare `on` show) . nodeProperties+          deepChildren = map NodeWithDeepEquality . nodeChildren++-- | A node with no properties and no children.+emptyNode :: Node+emptyNode = Node { nodeProperties = [], nodeChildren = [] }++-- | Returns a fresh root 'Node' with 'AP' set to Goatee and optionally with a+-- board size set via 'SZ'.+rootNode :: Maybe (Int, Int) -> Node+rootNode maybeSize =+  let props = FF 4 :+              GM 1 :+              AP (toSimpleText applicationName)+                 (toSimpleText $ showVersion version) :+              maybe [] ((:[]) . uncurry SZ) maybeSize+  in Node { nodeProperties = props+          , nodeChildren = []+          }++-- | Searches for a matching property in a node's property list.+findProperty :: Descriptor a => a -> Node -> Maybe Property+findProperty descriptor node = findProperty' descriptor $ nodeProperties node++-- | Searches for a matching property in a property list.+findProperty' :: Descriptor a => a -> [Property] -> Maybe Property+findProperty' = find . propertyPredicate++-- | Retrieves the value of a property in a node's property list.+findPropertyValue :: ValuedDescriptor a v => a -> Node -> Maybe v+findPropertyValue descriptor node = propertyValue descriptor <$> findProperty descriptor node++-- | Retrieves the value of a property in a property list.+findPropertyValue' :: ValuedDescriptor a v => a -> [Property] -> Maybe v+findPropertyValue' descriptor properties =+  propertyValue descriptor <$> findProperty' descriptor properties++-- | Appends a property to a node's property list.+addProperty :: Property -> Node -> Node+addProperty prop node = node { nodeProperties = nodeProperties node ++ [prop] }++-- | @addChild child parent@ appends a child node to a node's child list.+addChild :: Node -> Node -> Node+addChild child node = node { nodeChildren = nodeChildren node ++ [child] }++-- | @addChildAt index child parent@ inserts a child node into a node's child+-- list at the given index, shifting all nodes at or after the given index to+-- the right.  If the position is less than 0 or greater than the length of the+-- list, then the index is clamped to this range.+addChildAt :: Int -> Node -> Node -> Node+addChildAt index child node =+  let (before, after) = splitAt index $ nodeChildren node+  in node { nodeChildren = before ++ child:after }++-- | @deleteChildAt index node@ deletes the child at the given index from the+-- node.  If the index is invalid, @node@ is returned.+deleteChildAt :: Int -> Node -> Node+deleteChildAt index node =+  let children = nodeChildren node+  in if index < 0 || index > length children+     then node+     else node { nodeChildren = listDeleteAt index children }++-- | Returns a list of validation errors for the current node, an+-- empty list if no errors are detected.+validateNode :: Bool -> Bool -> Node -> [String]+validateNode isRoot _{-seenGameNode-} node = execWriter $ do+  let props = nodeProperties node+  let propTypes = nub $ map propertyType $ nodeProperties node++  -- Check for move and setup properties in a single node.+  when (MoveProperty `elem` propTypes && SetupProperty `elem` propTypes) $+    tell ["Node contains move and setup properties."]++  -- Check for root properties in non-root nodes.+  let rootProps = filter ((RootProperty ==) . propertyType) props+  when (not isRoot && not (null rootProps)) $+    tell $ map (\p -> "Root property found on non-root node: " +++                      show p ++ ".")+           rootProps++  -- TODO Check for game-info properties.++  -- Check for coordinates marked multiple times.+  validateNodeDuplicates props getMarkedCoords $ \group ->+    tell ["Coordinate " ++ show (fst $ head group) +++          " is specified multiple times in properties " +++          intercalate ", " (map snd group) ++ "."]++  -- TODO Validate recursively.++  where getMarkedCoords (CR cs) = tagMarkedCoords cs "CR"+        getMarkedCoords (MA cs) = tagMarkedCoords cs "MA"+        getMarkedCoords (SL cs) = tagMarkedCoords cs "SL"+        getMarkedCoords (SQ cs) = tagMarkedCoords cs "SQ"+        getMarkedCoords (TR cs) = tagMarkedCoords cs "TR"+        getMarkedCoords _ = []++        tagMarkedCoords cs tag = map (\x -> (x, tag)) $ expandCoordList cs++validateNodeDuplicates :: (Eq v, Ord v)+                          => [Property]+                          -> (Property -> [(v, t)])+                          -> ([(v, t)] -> Writer [String] ())+                          -> Writer [String] ()+validateNodeDuplicates props getTaggedElts errAction =+  let groups = groupBy ((==) `on` fst) $+               sortBy (compare `on` fst) $+               concatMap getTaggedElts props+  in forM_ groups $ \group ->+       unless (null $ tail group) $+         errAction group

@@ -0,0 +1,505 @@+-- This file is part of Goatee.+--+-- Copyright 2014 Bryan Gardiner+--+-- Goatee is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- Goatee is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.++-- | Constants and data types for property values used in SGF game trees.+module Game.Goatee.Lib.Types (+  -- * Constants+  supportedFormatVersions, defaultFormatVersion, supportedGameTypes,+  boardSizeDefault, boardSizeMin, boardSizeMax,+  -- * Board coordinates+  Coord, CoordList, coordListSingles, coordListRects, coord1, coords, coords',+  emptyCoordList, expandCoordList, buildCoordList,+  -- ** Star points and handicap stones+  starLines,+  isStarPoint,+  handicapStones,+  -- * Property values+  -- ** Text values+  Stringlike (..), convertStringlike,+  Text, fromText, toText,+  SimpleText, fromSimpleText, toSimpleText,+  -- ** Other values+  UnknownPropertyValue, fromUnknownPropertyValue, toUnknownPropertyValue,+  RealValue,+  DoubleValue (..),+  Color (..), cnot,+  VariationMode (..), VariationModeSource (..), defaultVariationMode,+  toVariationMode, fromVariationMode,+  ArrowList, LineList, LabelList, Mark (..),+  GameResult (..),+  WinReason (..),+  Ruleset (..), RulesetType (..), fromRuleset, toRuleset,+  ) where++import Control.Applicative ((<$>), (<*>))+import Data.Char (isSpace)+import Data.Function (on)+import Data.List (delete, groupBy, partition, sort)+import Data.Maybe (fromMaybe)+import Game.Goatee.Common+import qualified Game.Goatee.Common.Bigfloat as BF++-- | The FF versions supported by Goatee.  Currently only 4.+supportedFormatVersions :: [Int]+supportedFormatVersions = [4]+-- TODO Support FF versions 1-4.++-- | The default SGF version to use when @FF[]@ is not specified in a root node.+--+-- This value is actually INCORRECT: SGF defines it to be 1, but because we+-- don't support version 1 yet, for the sake of ignoring this issue (for now!)+-- in tests, we fix the default to be 4.+defaultFormatVersion :: Int+defaultFormatVersion = 4+-- TODO Fix the default version to be 1 as SGF mandates.++-- | SGF supports multiple game types.  This list contains the game types that+-- Goatee supports, which is only Go (1).+supportedGameTypes :: [Int]+supportedGameTypes = [1 {- Go -}]++-- | The default size of the board.  The FF[4] SGF spec says that the default Go+-- board is 19x19 square.+boardSizeDefault :: Int+boardSizeDefault = 19++-- | The minimum board size allowed by FF[4], 1.+boardSizeMin :: Int+boardSizeMin = 1++-- | The maximum board size allowed by FF[4], 52.+boardSizeMax :: Int+boardSizeMax = 52++-- | A coordinate on a Go board.  @(0, 0)@ refers to the upper-left corner of+-- the board.  The first component is the horizontal position; the second+-- component is the vertical position.+type Coord = (Int, Int)++-- | A structure for compact representation of a list of coordinates.  Contains+-- a list of individual points, as well as a list of rectangles of points+-- denoted by an ordered pair of the upper-left point and the lower-right point.+-- The union of the single points and points contained within rectangles make up+-- all of the points a @CoordList@ represents.  There is no rule saying that+-- adjacent points have to be grouped into rectangles; it's perfectly valid+-- (although possibly inefficient) to never use rectangles.+--+-- For any @CoordList@, all of the following hold:+--+-- 1. Any point may be specified at most once, either in the singles list or in+-- a single rectangle.+--+-- 2. For a rectangle @((x0,y0), (x1,y1))@, @x0 <= x1@ and @y0 <= y1@ and+-- @(x0,y0) /= (x1,y1)@ (otherwise the point belongs in the singles list).+data CoordList = CoordList+  { coordListSingles :: [Coord]+  -- ^ Returns the single points in a 'CoordList'.+  , coordListRects :: [(Coord, Coord)]+    -- ^ Returns the rectangles in a 'CoordList'.+  } deriving (Show)++-- | Equality is based on unordered, set equality of the underlying points.+instance Eq CoordList where+  (==) = (==) `on` sort . expandCoordList++-- | Constructs a 'CoordList' containing a single point.+coord1 :: Coord -> CoordList+coord1 xy = CoordList { coordListSingles = [xy]+                      , coordListRects = []+                      }++-- | Constructs a 'CoordList' containing the given single points.  For rectangle+-- detection, use 'buildCoordList'.+coords :: [Coord] -> CoordList+coords singles = CoordList { coordListSingles = singles+                           , coordListRects = []+                           }++-- | Constructs a 'CoordList' containing the given single points and rectangles.+coords' :: [Coord] -> [(Coord, Coord)] -> CoordList+coords' singles rects = CoordList { coordListSingles = singles+                                  , coordListRects = rects+                                  }++-- | A 'CoordList' that contains no points.+emptyCoordList :: CoordList+emptyCoordList = CoordList { coordListSingles = []+                           , coordListRects = []+                           }++-- | Converts a compact 'CoordList' to a list of coordinates.+expandCoordList :: CoordList -> [Coord]+expandCoordList cl = coordListSingles cl +++                     foldr (\r@((x0, y0), (x1, y1)) rest ->+                             if x0 > x1 || y0 > y1+                             then error ("Invalid coord. rectangle: " ++ show r)+                             else [(x, y) | x <- [x0..x1], y <- [y0..y1]] ++ rest)+                           []+                           (coordListRects cl)++-- | Constructs a 'CoordList' from a list of 'Coord's, doing some+-- not-completely-stupid rectangle detection.  The order of data in the result+-- is unspecified.+buildCoordList :: [Coord] -> CoordList+-- This algorithm doesn't generate the smallest result.  For the following+-- input:+--+-- F F T T+-- T T T T+-- T T F F+--+-- It will return [ca:da][ab:db][ac:bc] rather than the shorter [ca:db][ab:bc].+buildCoordList = toCoordList . generateRects 0 [] . buildTruePairs . toGrid+  where -- | Constructs a row-major grid of booleans where an coordinate is true+        -- iff it is in the given list.+        toGrid :: [Coord] -> [[Bool]]+        toGrid [] = []+        toGrid coords = let x1 = maximum $ map fst coords+                            y1 = maximum $ map snd coords+                        in [[(x,y) `elem` coords | x <- [0..x1]] | y <- [0..y1]]++        -- | For each row, converts a list of booleans into a list of pairs+        -- where each pair represents a consecutive run of true values.  The+        -- pair indicates the indices of the first and last boolean in each run.+        buildTruePairs :: [[Bool]] -> [[(Int, Int)]]+        buildTruePairs = map $+                         concatMap extractTrueGroups .+                         groupBy ((==) `on` snd) .+                         zip [0..]++        -- | Given a run of indexed booleans with the same boolean value within+        -- a row, returns @[(startIndex, endIndex)]@ if the value is true, and+        -- @[]@ if the value is false.+        extractTrueGroups :: [(Int, Bool)] -> [(Int, Int)]+        extractTrueGroups list@((start, True):_) = [(start, fst (last list))]+        extractTrueGroups _ = []++        -- | Converts the lists of true pairs for all rows into a list of+        -- @(Coord, Coord)@ rectangles.  We repeatedly grab the first span in+        -- the first row, and see how many leading rows contain that exact span.+        -- Then we build a (maybe multi-row) rectangle for the span, remove the+        -- span from all leading rows, and repeat.  When the first row becomes+        -- empty, we drop it and increment a counter that keeps track of our+        -- first row's y-position.+        generateRects :: Int -> [(Coord, Coord)] -> [[(Int, Int)]] -> [(Coord, Coord)]+        generateRects _ acc [] = acc+        generateRects topRowOffset acc ([]:rows) = generateRects (topRowOffset + 1) acc rows+        generateRects topRowOffset acc rows@((span:_):_) =+          let rowsWithSpan = matchRowsWithSpan span rows+              rowsWithSpanCount = length rowsWithSpan+          in generateRects topRowOffset+                           (((fst span, topRowOffset),+                             (snd span, topRowOffset + rowsWithSpanCount - 1)) : acc)+                           (rowsWithSpan ++ drop rowsWithSpanCount rows)++        -- | Determines how many leading rows contain the given span.  A list of+        -- all the matching rows is returned, with the span deleted from each.+        matchRowsWithSpan :: (Int, Int) -> [[(Int, Int)]] -> [[(Int, Int)]]+        matchRowsWithSpan span (row:rows)+          | span `elem` row = delete span row : matchRowsWithSpan span rows+          | otherwise = []+        matchRowsWithSpan _ [] = []++        -- | Builds a 'CoordList' from simple @(Coord, Coord)@ rectangles.+        toCoordList :: [(Coord, Coord)] -> CoordList+        toCoordList rects =+          let (singles, properRects) = partition (uncurry (==)) rects+          in coords' (map fst singles) properRects++-- | @starLines width height@ returns 'Just' a list of row/column indices that+-- have star points on a board of the given size, or 'Nothing' if the board size+-- does not have star points defined.+starLines :: Int -> Int -> Maybe [Int]+starLines 19 19 = Just [3, 9, 15]+starLines 13 13 = Just [3, 6, 9]+starLines 9 9 = Just [2, 4, 6]+starLines _ _ = Nothing++-- | @isStarPoint width height x y@ determines whether @(x, y)@ is a known star+-- point on a board of the given width and height.+isStarPoint :: Int -> Int -> Int -> Int -> Bool+isStarPoint width height x y =+  fromMaybe False $+  ((&&) <$> elem x <*> elem y) <$> starLines width height++-- | @handicapStoneIndices !! k@ the positions of the handicap stones for @k@+-- handicap stones, betweeen 0 and 9.  In the pairs, 0 indicates the first star+-- point along an axis, 1 indicates the second, and 2 indicates the third, in+-- the normal 'Coord' ordering.+handicapStoneIndices :: [[(Int, Int)]]+handicapStoneIndices =+  [ []+  , []  -- No single handicap stone for Black; black goes first instead.+  , [(2,0), (0,2)]+  , (2,2) : handicapStoneIndices !! 2+  , (0,0) : handicapStoneIndices !! 3+  , (1,1) : handicapStoneIndices !! 4+  , (0,1) : (2,1) : handicapStoneIndices !! 4+  , (1,1) : handicapStoneIndices !! 6+  , (1,0) : (1,2) : handicapStoneIndices !! 6+  , (1,1) : handicapStoneIndices !! 8+  ]++-- | @handicapStones width height handicap@ returns a list of points where+-- handicap stones should be placed for the given handicap, if handicap points+-- are defined for the given board size, otherwise 'Nothing'.+handicapStones :: Int -> Int -> Int -> Maybe [Coord]+handicapStones width height handicap =+  if handicap < 0 || handicap >= length handicapStoneIndices+  then Nothing+  else do positions <- starLines width height+          return $ map (mapTuple (positions !!)) (handicapStoneIndices !! handicap)++-- | A class for SGF data types that are coercable to and from strings.+--+-- The construction of an SGF value with 'stringToSgf' may process the input,+-- such that the resulting stringlike value does not represent the same string+-- as the input.  In other words, the following does *not* necessarily hold:+--+-- > sgfToString . stringToSgf = id   (does not necessarily hold!)+--+-- The following does hold, however, for a single stringlike type:+--+-- > stringToSgf . sgfToString = id+--+-- The 'String' instance is defined with @sgfToString = stringToSgf =+-- id@.  For other types, the string returned by 'sgfToString' is in a+-- raw, user-editable format: characters that need to be escaped in+-- serialized SGF aren't escaped, but the returned value is otherwise+-- similar to SGF format.+class Stringlike a where+  -- | Extracts the string value from an SGF value.+  sgfToString :: a -> String++  -- | Creates an SGF value from a string value.+  stringToSgf :: String -> a++instance Stringlike String where+  sgfToString = id+  stringToSgf = id++-- | Converts between 'Stringlike' types via a string.+--+-- > convertStringlike = stringToSgf . sgfToString+convertStringlike :: (Stringlike a, Stringlike b) => a -> b+convertStringlike = stringToSgf . sgfToString++-- | An SGF text value.+newtype Text = Text+  { fromText :: String+    -- ^ Converts an SGF 'Text' to a string.+  } deriving (Eq, Show)++instance Stringlike Text where+  sgfToString = fromText+  stringToSgf = toText++-- | Converts a string to an SGF 'Text'.+toText :: String -> Text+toText = Text++-- | An SGF SimpleText value.+newtype SimpleText = SimpleText+  { fromSimpleText :: String+    -- ^ Converts an SGF 'SimpleText' to a string.+  } deriving (Eq, Show)++instance Stringlike SimpleText where+  sgfToString = fromSimpleText+  stringToSgf = toSimpleText++sanitizeSimpleText :: String -> String+sanitizeSimpleText = map (\c -> if isSpace c then ' ' else c)++-- | Converts a string to an SGF 'SimpleText', replacing all whitespaces+-- (including newlines) with spaces.+toSimpleText :: String -> SimpleText+toSimpleText = SimpleText . sanitizeSimpleText++-- | The value type for an 'UnknownProperty'.  Currently represented as a+-- string.+data UnknownPropertyValue = UnknownPropertyValue+  { fromUnknownPropertyValue :: String+    -- ^ Returns the string contained within the 'UnknownProperty' this value is+    -- from.+  } deriving (Eq, Show)++instance Stringlike UnknownPropertyValue where+  sgfToString = fromUnknownPropertyValue+  stringToSgf = toUnknownPropertyValue++-- | Constructs a value for a 'UnknownProperty'.+toUnknownPropertyValue :: String -> UnknownPropertyValue+toUnknownPropertyValue = UnknownPropertyValue++-- | An SGF real value is a decimal number of unspecified precision.+type RealValue = BF.Bigfloat++-- | An SGF double value: either 1 or 2, nothing else.+data DoubleValue = Double1+                 | Double2+                 deriving (Eq, Show)++-- | Stone color: black or white.+data Color = Black+           | White+           deriving (Eq, Show)++-- | Returns the logical negation of a stone color, yang for yin and+-- yin for yang.+cnot :: Color -> Color+cnot Black = White+cnot White = Black++-- | SGF flags that control how move variations are to be presented while+-- displaying the game.+data VariationMode = VariationMode+  { variationModeSource :: VariationModeSource+    -- ^ Which moves to display as variations.+  , variationModeBoardMarkup :: Bool+    -- ^ Whether to overlay variations on the board.+  } deriving (Eq, Show)++-- | An enumeration that describes which variations are shown.+data VariationModeSource =+  ShowChildVariations+  -- ^ Show children of the current move.+  | ShowCurrentVariations+    -- ^ Show alternatives to the current move.+  deriving (Bounded, Enum, Eq, Show)++-- | The default variation mode as defined by the SGF spec is @VariationMode+-- ShowChildVariations True@.+defaultVariationMode :: VariationMode+defaultVariationMode = VariationMode ShowChildVariations True++-- | Parses a numeric variation mode, returning nothing if the number is+-- invalid.+toVariationMode :: Int -> Maybe VariationMode+toVariationMode n = case n of+  0 -> Just $ VariationMode ShowChildVariations True+  1 -> Just $ VariationMode ShowCurrentVariations True+  2 -> Just $ VariationMode ShowChildVariations False+  3 -> Just $ VariationMode ShowCurrentVariations False+  _ -> Nothing++-- | Returns the integer value for a variation mode.+fromVariationMode :: VariationMode -> Int+fromVariationMode mode = case mode of+  VariationMode ShowChildVariations True -> 0+  VariationMode ShowCurrentVariations True -> 1+  VariationMode ShowChildVariations False -> 2+  VariationMode ShowCurrentVariations False -> 3++-- | A list of arrows, each specified as @(startCoord, endCoord)@.+type ArrowList = [(Coord, Coord)]++-- | A list of lines, each specified as @(startCoord, endCoord)@.+type LineList = [(Coord, Coord)]++-- | A list of labels, each specified with a string and a coordinate about which+-- to center the string.+type LabelList = [(Coord, SimpleText)]++-- | The markings that SGF supports annotating coordinates with.+data Mark = MarkCircle | MarkSquare | MarkTriangle | MarkX | MarkSelected+          deriving (Bounded, Enum, Eq, Show)++data GameResult = GameResultWin Color WinReason+                | GameResultDraw+                | GameResultVoid+                | GameResultUnknown+                | GameResultOther SimpleText+                deriving (Eq, Show)++instance Stringlike GameResult where+  sgfToString result = case result of+    GameResultWin color reason ->+      (case color of { Black -> 'B'; White -> 'W' }) : '+' :+      (case reason of+          WinByScore diff -> show diff+          WinByResignation -> "R"+          WinByTime -> "T"+          WinByForfeit -> "F")+    GameResultDraw -> "0"+    GameResultVoid -> "Void"+    GameResultUnknown -> "?"+    GameResultOther text -> sgfToString text++  stringToSgf str = case str of+    "0" -> GameResultDraw+    "Draw" -> GameResultDraw+    "Void" -> GameResultVoid+    "?" -> GameResultUnknown+    _ ->+      let result = case str of+            'B':'+':winReasonStr -> parseWin (GameResultWin Black) winReasonStr+            'W':'+':winReasonStr -> parseWin (GameResultWin White) winReasonStr+            _ -> unknownResult+          parseWin builder winReasonStr = case winReasonStr of+            "R" -> builder WinByResignation+            "Resign" -> builder WinByResignation+            "T" -> builder WinByTime+            "Time" -> builder WinByTime+            "F" -> builder WinByForfeit+            "Forfeit" -> builder WinByForfeit+            _ -> case reads winReasonStr of+              (score, ""):_ -> builder $ WinByScore score+              _ -> unknownResult+          unknownResult = GameResultOther $ toSimpleText str+      in result++data WinReason = WinByScore RealValue+               | WinByResignation+               | WinByTime+               | WinByForfeit+               deriving (Eq, Show)++-- | A ruleset used for a Go game.  Can be one of the rulesets defined by the+-- SGF specification, or a custom string.+data Ruleset = KnownRuleset RulesetType+             | UnknownRuleset String+             deriving (Eq, Show)++instance Stringlike Ruleset where+  sgfToString = fromRuleset+  stringToSgf = toRuleset++-- | The rulesets defined by the SGF specification, for use with 'Ruleset'.+data RulesetType = RulesetAga+                 | RulesetIng+                 | RulesetJapanese+                 | RulesetNewZealand+                 deriving (Bounded, Enum, Eq, Show)++-- | Returns the string representation for a ruleset.+fromRuleset :: Ruleset -> String+fromRuleset ruleset = case ruleset of+  KnownRuleset RulesetAga -> "AGA"+  KnownRuleset RulesetIng -> "Goe"+  KnownRuleset RulesetJapanese -> "Japanese"+  KnownRuleset RulesetNewZealand -> "NZ"+  UnknownRuleset str -> str++-- | Parses a string representation of a ruleset.+toRuleset :: String -> Ruleset+toRuleset str = case str of+  "AGA" -> KnownRuleset RulesetAga+  "Goe" -> KnownRuleset RulesetIng+  "Japanese" -> KnownRuleset RulesetJapanese+  "NZ" -> KnownRuleset RulesetNewZealand+  _ -> UnknownRuleset str

@@ -1,792 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.---- | Data structures that wrap and provide a higher-level interface to the SGF--- game tree, including a zipper that navigates the tree and provides the--- current board state.-module Game.Goatee.Sgf.Board (-  RootInfo(..), GameInfo(..), emptyGameInfo, internalIsGameInfoNode,-  gameInfoToProperties,-  BoardState(..), boardWidth, boardHeight,-  CoordState(..), rootBoardState, boardCoordState, mapBoardCoords,-  isValidMove, isCurrentValidMove,-  Cursor(..), rootCursor, cursorRoot, cursorChild, cursorChildren,-  cursorChildCount, cursorChildPlayingAt, cursorProperties,-  cursorModifyNode,-  cursorVariations,-  colorToMove,-  ) where--import Control.Monad (unless, when)-import Control.Monad.Writer (execWriter, tell)-import Data.List (find, intercalate, nub)-import Data.Maybe (fromMaybe, isJust, isNothing)-import qualified Data.Set as Set-import Game.Goatee.Common-import Game.Goatee.Sgf.Property-import Game.Goatee.Sgf.Tree-import Game.Goatee.Sgf.Types---- TODO Stop using errors everywhere, they're not testable.---- | Properties that are specified in the root nodes of game trees.-data RootInfo = RootInfo { rootInfoWidth :: Int-                         , rootInfoHeight :: Int-                         , rootInfoVariationMode :: VariationMode-                         } deriving (Eq, Show)---- | Properties that are specified in game info nodes.-data GameInfo = GameInfo { gameInfoRootInfo :: RootInfo--                         , gameInfoBlackName :: Maybe String-                         , gameInfoBlackTeamName :: Maybe String-                         , gameInfoBlackRank :: Maybe String--                         , gameInfoWhiteName :: Maybe String-                         , gameInfoWhiteTeamName :: Maybe String-                         , gameInfoWhiteRank :: Maybe String--                         , gameInfoRuleset :: Maybe Ruleset-                         , gameInfoBasicTimeSeconds :: Maybe Rational-                         , gameInfoOvertime :: Maybe String-                         , gameInfoResult :: Maybe GameResult--                         , gameInfoGameName :: Maybe String-                         , gameInfoGameComment :: Maybe String-                         , gameInfoOpeningComment :: Maybe String--                         , gameInfoEvent :: Maybe String-                         , gameInfoRound :: Maybe String-                         , gameInfoPlace :: Maybe String-                         , gameInfoDatesPlayed :: Maybe String-                         , gameInfoSource :: Maybe String-                         , gameInfoCopyright :: Maybe String--                         , gameInfoAnnotatorName :: Maybe String-                         , gameInfoEntererName :: Maybe String-                         } deriving (Show)---- | Builds a 'GameInfo' with the given 'RootInfo' and no extra data.-emptyGameInfo :: RootInfo -> GameInfo-emptyGameInfo rootInfo =-  GameInfo { gameInfoRootInfo = rootInfo--           , gameInfoBlackName = Nothing-           , gameInfoBlackTeamName = Nothing-           , gameInfoBlackRank = Nothing--           , gameInfoWhiteName = Nothing-           , gameInfoWhiteTeamName = Nothing-           , gameInfoWhiteRank = Nothing--           , gameInfoRuleset = Nothing-           , gameInfoBasicTimeSeconds = Nothing-           , gameInfoOvertime = Nothing-           , gameInfoResult = Nothing--           , gameInfoGameName = Nothing-           , gameInfoGameComment = Nothing-           , gameInfoOpeningComment = Nothing--           , gameInfoEvent = Nothing-           , gameInfoRound = Nothing-           , gameInfoPlace = Nothing-           , gameInfoDatesPlayed = Nothing-           , gameInfoSource = Nothing-           , gameInfoCopyright = Nothing--           , gameInfoAnnotatorName = Nothing-           , gameInfoEntererName = Nothing-           }---- | Returns whether a node contains any game info properties.-internalIsGameInfoNode :: Node -> Bool-internalIsGameInfoNode = any ((GameInfoProperty ==) . propertyType) . nodeProperties---- | Converts a 'GameInfo' into a list of 'Property's that can be used to--- reconstruct the 'GameInfo'.-gameInfoToProperties :: GameInfo -> [Property]-gameInfoToProperties info = execWriter $ do-  copy (PB . toSimpleText) gameInfoBlackName-  copy (BT . toSimpleText) gameInfoBlackTeamName-  copy (BR . toSimpleText) gameInfoBlackRank--  copy (PW . toSimpleText) gameInfoWhiteName-  copy (WT . toSimpleText) gameInfoWhiteTeamName-  copy (WR . toSimpleText) gameInfoWhiteRank--  copy RU gameInfoRuleset-  copy TM gameInfoBasicTimeSeconds-  copy (OT . toSimpleText) gameInfoOvertime-  copy RE gameInfoResult--  copy (GN . toSimpleText) gameInfoGameName-  copy (GC . toSimpleText) gameInfoGameComment-  copy (ON . toSimpleText) gameInfoOpeningComment--  copy (EV . toSimpleText) gameInfoEvent-  copy (RO . toSimpleText) gameInfoRound-  copy (PC . toSimpleText) gameInfoPlace-  copy (DT . toSimpleText) gameInfoDatesPlayed-  copy (SO . toSimpleText) gameInfoSource-  copy (CP . toSimpleText) gameInfoCopyright--  copy (AN . toSimpleText) gameInfoAnnotatorName-  copy (US . toSimpleText) gameInfoEntererName-  where copy ctor accessor = whenMaybe (accessor info) $ \x -> tell [ctor x]---- | An object that corresponds to a node in some game tree, and represents the--- state of the game at that node, including board position, player turn and--- captures, and also board annotations.-data BoardState = BoardState {-  boardCoordStates :: [[CoordState]]-  -- ^ The state of individual points on the board.  Stored in row-major order.-  -- Point @(x, y)@ can be accessed via @!! y !! x@ (but prefer-  -- 'boardCoordState').-  , boardHasInvisible :: Bool-    -- ^ Whether any of the board's 'CoordState's are invisible.  This is an-    -- optimization to make it more efficient to set the board to "all visible."-  , boardHasDimmed :: Bool-    -- ^ Whether any of the board's 'CoordState's are dimmed.  This is an-    -- optimization to make it more efficient to clear all dimming from the-    -- board.-  , boardArrows :: ArrowList-  , boardLines :: LineList-  , boardLabels :: LabelList-  , boardMoveNumber :: Integer-  , boardPlayerTurn :: Color-  , boardBlackCaptures :: Int-  , boardWhiteCaptures :: Int-  , boardGameInfo :: GameInfo-  }--instance Show BoardState where-  show board = concat $ execWriter $ do-    tell ["Board: (Move ", show (boardMoveNumber board),-          ", ", show (boardPlayerTurn board), "'s turn, B:",-          show (boardBlackCaptures board), ", W:",-          show (boardWhiteCaptures board), ")\n"]-    tell [intercalate "\n" $ flip map (boardCoordStates board) $-          \row -> unwords $ map show row]--    let arrows = boardArrows board-    let lines = boardLines board-    let labels = boardLabels board-    unless (null arrows) $ tell ["\nArrows: ", show arrows]-    unless (null lines) $ tell ["\nLines: ", show lines]-    unless (null labels) $ tell ["\nLabels: ", show labels]---- | Returns the width of the board, in stones.-boardWidth :: BoardState -> Int-boardWidth = rootInfoWidth . gameInfoRootInfo . boardGameInfo---- | Returns the height of the board, in stones.-boardHeight :: BoardState -> Int-boardHeight = rootInfoHeight . gameInfoRootInfo . boardGameInfo---- | Used by 'BoardState' to represent the state of a single point on the board.--- Records whether a stone is present, as well as annotations and visibility--- properties.-data CoordState = CoordState { coordStar :: Bool-                               -- ^ Whether this point is a star point.-                             , coordStone :: Maybe Color-                             , coordMark :: Maybe Mark-                             , coordVisible :: Bool-                             , coordDimmed :: Bool-                             }--instance Show CoordState where-  show c = if not $ coordVisible c-           then "--"-           else let stoneChar = case coordStone c of-                      Nothing -> if coordStar c then '*' else '\''-                      Just Black -> 'X'-                      Just White -> 'O'-                    markChar = case coordMark c of-                      Nothing -> ' '-                      Just MarkCircle -> 'o'-                      Just MarkSquare -> 's'-                      Just MarkTriangle -> 'v'-                      Just MarkX -> 'x'-                      Just MarkSelected -> '!'-                in [stoneChar, markChar]---- | Creates a 'BoardState' for an empty board of the given width and height.-emptyBoardState :: Int -> Int -> BoardState-emptyBoardState width height =-  BoardState { boardCoordStates = coords-             , boardHasInvisible = False-             , boardHasDimmed = False-             , boardArrows = []-             , boardLines = []-             , boardLabels = []-             , boardMoveNumber = 0-             , boardPlayerTurn = Black-             , boardBlackCaptures = 0-             , boardWhiteCaptures = 0-             , boardGameInfo = emptyGameInfo rootInfo-             }-  where rootInfo = RootInfo { rootInfoWidth = width-                            , rootInfoHeight = height-                            , rootInfoVariationMode = defaultVariationMode-                            }-        emptyCoord = CoordState { coordStar = False-                                , coordStone = Nothing-                                , coordMark = Nothing-                                , coordVisible = True-                                , coordDimmed = False-                                }-        starCoord = emptyCoord { coordStar = True }-        isStarPoint' = isStarPoint width height-        coords = map (\y -> map (\x -> if isStarPoint' x y then starCoord else emptyCoord)-                                [0..width-1])-                     [0..height-1]--rootBoardState :: Node -> BoardState-rootBoardState rootNode =-  foldr applyProperty-        (emptyBoardState width height)-        (nodeProperties rootNode)-  where SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $-                          findProperty propertySZ rootNode---- | Returns the 'CoordState' for a coordinate on a board.-boardCoordState :: Coord -> BoardState -> CoordState-boardCoordState (x, y) board = boardCoordStates board !! y !! x---- | Maps a function over each 'CoordState' in a 'BoardState', returning a--- list-of-lists with the function's values.  The function is called like @fn y--- x coordState@.-mapBoardCoords :: (Int -> Int -> CoordState -> a) -> BoardState -> [[a]]-mapBoardCoords fn board =-  zipWith applyRow [0..] $ boardCoordStates board-  where applyRow y = zipWith (fn y) [0..]---- | Applies a function to update the 'RootInfo' within the 'GameInfo' of a--- 'BoardState'.-updateRootInfo :: (RootInfo -> RootInfo) -> BoardState -> BoardState-updateRootInfo fn board = flip updateBoardInfo board $ \gameInfo ->-  gameInfo { gameInfoRootInfo = fn $ gameInfoRootInfo gameInfo }---- | Applies a function to update the 'GameInfo' of a 'BoardState'.-updateBoardInfo :: (GameInfo -> GameInfo) -> BoardState -> BoardState-updateBoardInfo fn board = board { boardGameInfo = fn $ boardGameInfo board }---- | Performs necessary updates to a 'BoardState' between nodes in the tree.--- Clears marks.-boardChild :: BoardState -> BoardState-boardChild board =-  board { boardCoordStates = map (map clearMark) $ boardCoordStates board-        , boardArrows = []-        , boardLines = []-        , boardLabels = []-        }-  where clearMark coord = case coordMark coord of-          Nothing -> coord-          Just _ -> coord { coordMark = Nothing }---- | Sets all points on a board to be visible (if given true) or invisible (if--- given false).-setBoardVisible :: Bool -> BoardState -> BoardState-setBoardVisible visible board =-  if visible-  then if boardHasInvisible board-       then board { boardCoordStates = map (map $ setVisible True) $ boardCoordStates board-                  , boardHasInvisible = False-                  }-       else board-  else board { boardCoordStates = map (map $ setVisible False) $ boardCoordStates board-             , boardHasInvisible = True-             }-  where setVisible vis coord = coord { coordVisible = vis }---- | Resets all points on a board not to be dimmed.-clearBoardDimmed :: BoardState -> BoardState-clearBoardDimmed board =-  if boardHasDimmed board-  then board { boardCoordStates = map (map clearDim) $ boardCoordStates board-             , boardHasDimmed = False-             }-  else board-  where clearDim coord = coord { coordDimmed = False }---- |> isStarPoint width height x y------ Returns whether @(x, y)@ is a known star point on a board of the given width--- and height.-isStarPoint :: Int -> Int -> Int -> Int -> Bool-isStarPoint width height-  | width == 9 && height == 9 = isStarPoint9-  | width == 13 && height == 13 = isStarPoint13-  | width == 19 && height == 19 = isStarPoint19-  | otherwise = const $ const False--isStarPoint' :: [Int] -> Int -> Int -> Bool-isStarPoint' ixs x y = x `elem` ixs && y `elem` ixs--isStarPoint9, isStarPoint13, isStarPoint19 :: Int -> Int -> Bool-isStarPoint9 = isStarPoint' [2, 4, 6]-isStarPoint13 = isStarPoint' [3, 6, 9]-isStarPoint19 = isStarPoint' [3, 9, 15]---- | Applies a property to a 'BoardState'.  This function covers all properties--- that modify 'BoardState's, including making moves, adding markup, and so on.-applyProperty :: Property -> BoardState -> BoardState--applyProperty (B maybeXy) board = updateBoardForMove Black $ case maybeXy of-  Nothing -> board  -- Pass.-  Just xy -> getApplyMoveResult board $-             applyMove playTheDarnMoveGoParams Black xy board-applyProperty KO board = board-applyProperty (MN moveNum) board = board { boardMoveNumber = moveNum }-applyProperty (W maybeXy) board = updateBoardForMove White $ case maybeXy of-  Nothing -> board  -- Pass.-  Just xy -> getApplyMoveResult board $-             applyMove playTheDarnMoveGoParams White xy board--applyProperty (AB coords) board =-  updateCoordStates' (\state -> state { coordStone = Just Black }) coords board-applyProperty (AW coords) board =-  updateCoordStates' (\state -> state { coordStone = Just White }) coords board-applyProperty (AE coords) board =-  updateCoordStates' (\state -> state { coordStone = Nothing }) coords board-applyProperty (PL color) board = board { boardPlayerTurn = color }--applyProperty (C {}) board = board-applyProperty (DM {}) board = board-applyProperty (GB {}) board = board-applyProperty (GW {}) board = board-applyProperty (HO {}) board = board-applyProperty (N {}) board = board-applyProperty (UC {}) board = board-applyProperty (V {}) board = board--applyProperty (BM {}) board = board-applyProperty (DO {}) board = board-applyProperty (IT {}) board = board-applyProperty (TE {}) board = board--applyProperty (AR arrows) board = board { boardArrows = arrows ++ boardArrows board }-applyProperty (CR coords) board =-  updateCoordStates' (\state -> state { coordMark = Just MarkCircle }) coords board-applyProperty (DD coords) board =-  let coords' = expandCoordList coords-      board' = clearBoardDimmed board-  in if null coords'-     then board'-     else updateCoordStates (\state -> state { coordDimmed = True }) coords'-          board { boardHasDimmed = True }-applyProperty (LB labels) board = board { boardLabels = labels ++ boardLabels board }-applyProperty (LN lines) board = board { boardLines = lines ++ boardLines board }-applyProperty (MA coords) board =-  updateCoordStates' (\state -> state { coordMark = Just MarkX }) coords board-applyProperty (SL coords) board =-  updateCoordStates' (\state -> state { coordMark = Just MarkSelected }) coords board-applyProperty (SQ coords) board =-  updateCoordStates' (\state -> state { coordMark = Just MarkSquare }) coords board-applyProperty (TR coords) board =-  updateCoordStates' (\state -> state { coordMark = Just MarkTriangle }) coords board--applyProperty (AP {}) board = board-applyProperty (CA {}) board = board-applyProperty (FF {}) board = board-applyProperty (GM {}) board = board-applyProperty (ST variationMode) board =-  updateRootInfo (\info -> info { rootInfoVariationMode = variationMode }) board-applyProperty (SZ {}) board = board--applyProperty (AN str) board =-  updateBoardInfo (\info -> info { gameInfoAnnotatorName = Just $ fromSimpleText str })-                  board-applyProperty (BR str) board =-  updateBoardInfo (\info -> info { gameInfoBlackRank = Just $ fromSimpleText str })-                  board-applyProperty (BT str) board =-  updateBoardInfo (\info -> info { gameInfoBlackTeamName = Just $ fromSimpleText str })-                  board-applyProperty (CP str) board =-  updateBoardInfo (\info -> info { gameInfoCopyright = Just $ fromSimpleText str })-                  board-applyProperty (DT str) board =-  updateBoardInfo (\info -> info { gameInfoDatesPlayed = Just $ fromSimpleText str })-                  board-applyProperty (EV str) board =-  updateBoardInfo (\info -> info { gameInfoEvent = Just $ fromSimpleText str })-                  board-applyProperty (GC str) board =-  updateBoardInfo (\info -> info { gameInfoGameComment = Just $ fromSimpleText str })-                  board-applyProperty (GN str) board =-  updateBoardInfo (\info -> info { gameInfoGameName = Just $ fromSimpleText str })-                  board-applyProperty (ON str) board =-  updateBoardInfo (\info -> info { gameInfoOpeningComment = Just $ fromSimpleText str })-                  board-applyProperty (OT str) board =-  updateBoardInfo (\info -> info { gameInfoOvertime = Just $ fromSimpleText str })-                  board-applyProperty (PB str) board =-  updateBoardInfo (\info -> info { gameInfoBlackName = Just $ fromSimpleText str })-                  board-applyProperty (PC str) board =-  updateBoardInfo (\info -> info { gameInfoPlace = Just $ fromSimpleText str })-                  board-applyProperty (PW str) board =-  updateBoardInfo (\info -> info { gameInfoWhiteName = Just $ fromSimpleText str })-                  board-applyProperty (RE result) board =-  updateBoardInfo (\info -> info { gameInfoResult = Just result })-                  board-applyProperty (RO str) board =-  updateBoardInfo (\info -> info { gameInfoRound = Just $ fromSimpleText str })-                  board-applyProperty (RU ruleset) board =-  updateBoardInfo (\info -> info { gameInfoRuleset = Just ruleset })-                  board-applyProperty (SO str) board =-  updateBoardInfo (\info -> info { gameInfoSource = Just $ fromSimpleText str })-                  board-applyProperty (TM seconds) board =-  updateBoardInfo (\info -> info { gameInfoBasicTimeSeconds = Just seconds })-                  board-applyProperty (US str) board =-  updateBoardInfo (\info -> info { gameInfoEntererName = Just $ fromSimpleText str })-                  board-applyProperty (WR str) board =-  updateBoardInfo (\info -> info { gameInfoWhiteRank = Just $ fromSimpleText str })-                  board-applyProperty (WT str) board =-  updateBoardInfo (\info -> info { gameInfoWhiteTeamName = Just $ fromSimpleText str })-                  board--applyProperty (VW coords) board =-  let coords' = expandCoordList coords-  in if null coords'-     then setBoardVisible True board-     else updateCoordStates (\state -> state { coordVisible = True }) coords' $-          setBoardVisible False board--applyProperty (UnknownProperty {}) board = board--applyProperties :: Node -> BoardState -> BoardState-applyProperties node board = foldr applyProperty board (nodeProperties node)---- | Applies the transformation function to all of a board's coordinates--- referred to by the 'CoordList'.-updateCoordStates :: (CoordState -> CoordState) -> [Coord] -> BoardState -> BoardState-updateCoordStates fn coords board =-  board { boardCoordStates = foldr applyFn (boardCoordStates board) coords }-  where applyFn (x, y) = listUpdate (updateRow x) y-        updateRow = listUpdate fn--updateCoordStates' :: (CoordState -> CoordState) -> CoordList -> BoardState -> BoardState-updateCoordStates' fn coords = updateCoordStates fn (expandCoordList coords)---- | Updates properties of a 'BoardState' given that the player of the given--- color has just made a move.  Increments the move number and updates the--- player turn.-updateBoardForMove :: Color -> BoardState -> BoardState-updateBoardForMove movedPlayer board =-  board { boardMoveNumber = boardMoveNumber board + 1-        , boardPlayerTurn = cnot movedPlayer-        }---- | A structure that configures how 'applyMove' should handle moves that are--- normally illegal in Go.-data ApplyMoveParams = ApplyMoveParams { allowSuicide :: Bool-                                         -- ^ If false, suicide will cause 'applyMove' to return-                                         -- 'ApplyMoveSuicideError'.  If true, suicide will kill the-                                         -- friendly group and give points to the opponent.-                                       , allowOverwrite :: Bool-                                         -- ^ If false, playing on an occupied point will cause-                                         -- 'applyMove' to return 'ApplyMoveOverwriteError' with the-                                         -- color of the stone occupying the point.  If true,-                                         -- playing on an occupied point will overwrite the point-                                         -- (the previous stone vanishes), then capture rules are-                                         -- applied as normal.-                                       } deriving (Show)---- | As an argument to 'applyMove', causes illegal moves to be treated as--- errors.-standardGoMoveParams :: ApplyMoveParams-standardGoMoveParams = ApplyMoveParams { allowSuicide = False-                                       , allowOverwrite = False-                                       }---- | As an argument to 'applyMove', causes illegal moves to be played--- unconditionally.-playTheDarnMoveGoParams :: ApplyMoveParams-playTheDarnMoveGoParams = ApplyMoveParams { allowSuicide = True-                                          , allowOverwrite = True-                                          }---- | The possible results from 'applyMove'.-data ApplyMoveResult = ApplyMoveOk BoardState-                       -- ^ The move was accepted; playing it resulted in the-                       -- given board without capture.-                     | ApplyMoveCapture BoardState Color Int-                       -- ^ The move was accepted; playing it resulted in the-                       -- given board with a capture.  The specified side gained-                       -- the number of points given.-                     | ApplyMoveSuicideError-                       -- ^ Playing the move would result in suicide, which is-                       -- forbidden.-                     | ApplyMoveOverwriteError Color-                       -- ^ There is already a stone of the specified color on-                       -- the target point, and overwriting is forbidden.---- | If the 'ApplyMoveResult' represents a successful move, then the resulting--- 'BoardState' is returned, otherwise, the default 'BoardState' given is--- returned.-getApplyMoveResult :: BoardState -> ApplyMoveResult -> BoardState-getApplyMoveResult defaultBoard result = fromMaybe defaultBoard $ getApplyMoveResult' result--getApplyMoveResult' :: ApplyMoveResult -> Maybe BoardState-getApplyMoveResult' result = case result of-  ApplyMoveOk board -> Just board-  ApplyMoveCapture board color points -> Just $ case color of-    Black -> board { boardBlackCaptures = boardBlackCaptures board + points }-    White -> board { boardWhiteCaptures = boardWhiteCaptures board + points }-  ApplyMoveSuicideError -> Nothing-  ApplyMoveOverwriteError _ -> Nothing---- | Internal data structure, only for move application code.  Represents a--- group of stones.-data ApplyMoveGroup = ApplyMoveGroup { applyMoveGroupOrigin :: Coord-                                     , applyMoveGroupCoords :: [Coord]-                                     , applyMoveGroupLiberties :: Int-                                     } deriving (Show)---- | Places a stone of a color at a point on a board, and runs move validation--- and capturing logic according to the given parameters.  Returns whether the--- move was successful, and the result if so.-applyMove :: ApplyMoveParams -> Color -> Coord -> BoardState -> ApplyMoveResult-applyMove params color xy board =-  let currentStone = coordStone $ boardCoordState xy board-  in case currentStone of-    Just color -> if allowOverwrite params-                  then moveResult-                  else ApplyMoveOverwriteError color-    Nothing -> moveResult-  where boardWithMove = updateCoordStates (\state -> state { coordStone = Just color })-                                          [xy]-                                          board-        (boardWithCaptures, points) = foldr (maybeCapture $ cnot color)-                                            (boardWithMove, 0)-                                            (adjacentPoints boardWithMove xy)-        playedGroup = computeGroup boardWithCaptures xy-        moveResult-          | applyMoveGroupLiberties playedGroup == 0 =-            if points /= 0-            then error "Cannot commit suicide and capture at the same time."-            else if allowSuicide params-                 then let (boardWithSuicide, suicidePoints) =-                            applyMoveCapture (boardWithCaptures, 0) playedGroup-                      in ApplyMoveCapture boardWithSuicide (cnot color) suicidePoints-                 else ApplyMoveSuicideError-          | points /= 0 = ApplyMoveCapture boardWithCaptures color points-          | otherwise = ApplyMoveOk boardWithCaptures---- | Capture if there is a liberty-less group of a color at a point on--- a board.  Removes captured stones from the board and accumulates--- points for captured stones.-maybeCapture :: Color -> Coord -> (BoardState, Int) -> (BoardState, Int)-maybeCapture color xy result@(board, _) =-  if coordStone (boardCoordState xy board) /= Just color-  then result-  else let group = computeGroup board xy-       in if applyMoveGroupLiberties group /= 0-          then result-          else applyMoveCapture result group--computeGroup :: BoardState -> Coord -> ApplyMoveGroup-computeGroup board xy =-  if isNothing (coordStone $ boardCoordState xy board)-  then error "computeGroup called on an empty point."-  else let groupCoords = bucketFill board xy-       in ApplyMoveGroup { applyMoveGroupOrigin = xy-                         , applyMoveGroupCoords = groupCoords-                         , applyMoveGroupLiberties = getLibertiesOfGroup board groupCoords-                         }--applyMoveCapture :: (BoardState, Int) -> ApplyMoveGroup -> (BoardState, Int)-applyMoveCapture (board, points) group =-  (updateCoordStates (\state -> state { coordStone = Nothing })-                     (applyMoveGroupCoords group)-                     board,-   points + length (applyMoveGroupCoords group))---- | Returns a list of the four coordinates that are adjacent to the--- given coordinate on the board, excluding coordinates that are out--- of bounds.-adjacentPoints :: BoardState -> Coord -> [Coord]-adjacentPoints board (x, y) = execWriter $ do-  when (x > 0) $ tell [(x - 1, y)]-  when (y > 0) $ tell [(x, y - 1)]-  when (x < boardWidth board - 1) $ tell [(x + 1, y)]-  when (y < boardHeight board - 1) $ tell [(x, y + 1)]---- | Takes a list of coordinates that comprise a group (e.g. a list--- returned from 'bucketFill') and returns the number of liberties the--- group has.  Does no error checking to ensure that the list refers--- to a single or maximal group.-getLibertiesOfGroup :: BoardState -> [Coord] -> Int-getLibertiesOfGroup board groupCoords =-  length $ nub $ concatMap findLiberties groupCoords-  where findLiberties xy = filter (\xy' -> isNothing $ coordStone $ boardCoordState xy' board)-                                  (adjacentPoints board xy)---- | Expands a single coordinate on a board into a list of all the--- coordinates connected to it by some continuous path of stones of--- the same color (or empty spaces).-bucketFill :: BoardState -> Coord -> [Coord]-bucketFill board xy0 = bucketFill' Set.empty [xy0]-  where bucketFill' known [] = Set.toList known-        bucketFill' known (xy:xys) =-          if Set.member xy known-          then bucketFill' known xys-          else let new = filter ((stone0 ==) . coordStone . flip boardCoordState board)-                                (adjacentPoints board xy)-               in bucketFill' (Set.insert xy known) (new ++ xys)-        stone0 = coordStone $ boardCoordState xy0 board---- | Returns whether it is legal to place a stone of the given color at a point--- on a board.  Accepts out-of-bound coordinates and returns false.-isValidMove :: BoardState -> Color -> Coord -> Bool--- TODO Should out-of-bound coordinates be accepted?-isValidMove board color coord@(x, y) =-  let w = boardWidth board-      h = boardHeight board-  in x >= 0 && y >= 0 && x < w && y < h &&-     isJust (getApplyMoveResult' $ applyMove standardGoMoveParams color coord board)---- | Returns whether it is legal for the current player to place a stone at a--- point on a board.  Accepts out-of-bound coordinates and returns false.-isCurrentValidMove :: BoardState -> Coord -> Bool-isCurrentValidMove board = isValidMove board (boardPlayerTurn board)---- | A pointer to a node in a game tree that also holds information--- about the current state of the game at that node.-data Cursor = Cursor { cursorParent :: Maybe Cursor-                       -- ^ The cursor for the node above this cursor's node in-                       -- the game tree.  The node of the parent cursor is the-                       -- parent of the cursor's node.-                       ---                       -- This is @Nothing@ iff the cursor's node has no parent.-                     , cursorChildIndex :: Int-                       -- ^ The index of this cursor's node in its parent's-                       -- child list.  When the cursor's node has no parent,-                       -- the value in this field is not specified.-                     , cursorNode :: Node-                       -- ^ The game tree node about which the cursor stores-                       -- information.-                     , cursorBoard :: BoardState-                       -- ^ The complete board state for the current node.-                     } deriving (Show) -- TODO Better Show Cursor instance.---- | Returns a cursor for a root node.-rootCursor :: Node -> Cursor-rootCursor node =-  Cursor { cursorParent = Nothing-         , cursorChildIndex = -1-         , cursorNode = node-         , cursorBoard = rootBoardState node-         }--cursorRoot :: Cursor -> Cursor-cursorRoot cursor = case cursorParent cursor of-  Nothing -> cursor-  Just parent -> cursorRoot parent--cursorChild :: Cursor -> Int -> Cursor-cursorChild cursor index =-  Cursor { cursorParent = Just cursor-         , cursorChildIndex = index-         , cursorNode = child-         , cursorBoard = applyProperties child $ boardChild $ cursorBoard cursor-         }-  -- TODO Better handling or messaging for out-of-bounds:-  where child = (!! index) $ nodeChildren $ cursorNode cursor--cursorChildren :: Cursor -> [Cursor]-cursorChildren cursor =-  let board = boardChild $ cursorBoard cursor-  in map (\(index, child) -> Cursor { cursorParent = Just cursor-                                    , cursorChildIndex = index-                                    , cursorNode = child-                                    , cursorBoard = applyProperties child board-                                    })-     $ zip [0..]-     $ nodeChildren-     $ cursorNode cursor--cursorChildCount :: Cursor -> Int-cursorChildCount = length . nodeChildren . cursorNode--cursorChildPlayingAt :: Coord -> Cursor -> Maybe Cursor-cursorChildPlayingAt coord cursor =-  let children = cursorChildren cursor-      color = boardPlayerTurn $ cursorBoard cursor-      hasMove = elem $ colorToMove color coord-  in find (hasMove . nodeProperties . cursorNode) children---- | This is simply @'nodeProperties' . 'cursorNode'@.-cursorProperties :: Cursor -> [Property]-cursorProperties = nodeProperties . cursorNode--cursorModifyNode :: (Node -> Node) -> Cursor -> Cursor-cursorModifyNode fn cursor =-  let node' = fn $ cursorNode cursor-  in case cursorParent cursor of-    Nothing -> rootCursor node'-    Just parentCursor ->-      let index = cursorChildIndex cursor-          parentCursor' = cursorModifyNode-                          (\parentNode ->-                            parentNode { nodeChildren = listUpdate (const node')-                                                        index-                                                        (nodeChildren parentNode)-                                       })-                          parentCursor-      in cursorChild parentCursor' index---- | Returns the variations to display for a cursor.  The returned list contains--- the location and color of 'B' and 'W' properties in variation nodes.--- Variation nodes are either children of the current node, or siblings of the--- current node, depending on the variation mode source.-cursorVariations :: VariationModeSource -> Cursor -> [(Coord, Color)]-cursorVariations source cursor =-  case source of-    ShowChildVariations -> collectPlays $ nodeChildren $ cursorNode cursor-    ShowCurrentVariations ->-      case cursorParent cursor of-        Nothing -> []-        Just parent -> collectPlays $ listDeleteIndex (cursorChildIndex cursor) $-                       nodeChildren $ cursorNode parent-  where collectPlays :: [Node] -> [(Coord, Color)]-        collectPlays = concatMap collectPlays'-        collectPlays' = concatMap collectPlays'' . nodeProperties-        collectPlays'' prop = case prop of-          B (Just xy) -> [(xy, Black)]-          W (Just xy) -> [(xy, White)]-          _ -> []--colorToMove :: Color -> Coord -> Property-colorToMove color coord =-  case color of-    Black -> B $ Just coord-    White -> W $ Just coord

@@ -1,690 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.---- | A monad for working with game trees.-module Game.Goatee.Sgf.Monad (-  -- * The Go monad-  GoT, GoM,-  runGoT, runGo,-  evalGoT, evalGo,-  execGoT, execGo,-  getCursor, getCoordState,-  -- * Navigation-  Step(..), goUp, goDown, goToRoot, goToGameInfoNode,-  -- * Remembering positions-  pushPosition, popPosition, dropPosition,-  -- * Properties-  getProperties,-  modifyProperties,-  getProperty,-  getPropertyValue,-  putProperty,-  deleteProperty,-  modifyProperty,-  modifyPropertyValue,-  modifyPropertyString,-  modifyPropertyCoords,-  modifyGameInfo,-  modifyVariationMode,-  getMark,-  modifyMark,-  -- * Children-  addChild,-  -- * Event handling-  Event, on, fire,-  -- * Events-  childAddedEvent, ChildAddedHandler,-  gameInfoChangedEvent, GameInfoChangedHandler,-  navigationEvent, NavigationHandler,-  propertiesModifiedEvent, PropertiesModifiedHandler,-  variationModeChangedEvent, VariationModeChangedHandler,-  ) where--import Control.Applicative ((<$>), Applicative ((<*>), pure))-import Control.Monad (ap, liftM, when)-import Control.Monad.Identity (Identity, runIdentity)-import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)-import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer)-import qualified Control.Monad.State as State-import Control.Monad.State (StateT)-import Data.List (delete, find, mapAccumL, nub)-import Data.Maybe (fromMaybe, isJust, isNothing)-import Game.Goatee.Common-import Game.Goatee.Sgf.Board-import Game.Goatee.Sgf.Property-import Game.Goatee.Sgf.Tree hiding (addChild)-import Game.Goatee.Sgf.Types---- | The internal state of a Go monad transformer.  @go@ is the type of--- Go monad or transformer (instance of 'GoMonad').-data GoState go = GoState { stateCursor :: Cursor-                            -- ^ The current position in the game tree.-                          , statePathStack :: PathStack-                            -- ^ The current path stack.--                          -- Event handlers.-                          , stateChildAddedHandlers :: [ChildAddedHandler go]-                            -- ^ Handlers for 'childAddedEvent'.-                          , stateGameInfoChangedHandlers :: [GameInfoChangedHandler go]-                            -- ^ Handlers for 'gameInfoChangedEvent'.-                          , stateNavigationHandlers :: [NavigationHandler go]-                            -- ^ Handlers for 'navigationEvent'.-                          , statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go]-                            -- ^ Handlers for 'propertiesModifiedEvent'.-                          , stateVariationModeChangedHandlers :: [VariationModeChangedHandler go]-                            -- ^ Handlers for 'variationModeChangedEvent'.-                          }---- | A path stack is a record of previous places visited in a game tree.  It is--- encoded a list of paths (steps) to each previous memorized position.------ The positions saved in calls to 'pushPosition' correspond to entries in the--- outer list here, with the first sublist representing the last call.  The--- sublist contains the steps in order that will trace the path back to the--- saved position.-type PathStack = [[Step]]---- | A simplified constructor function for 'GoState'.-initialState :: Cursor -> GoState m-initialState cursor = GoState { stateCursor = cursor-                              , statePathStack = []-                              , stateChildAddedHandlers = []-                              , stateGameInfoChangedHandlers = []-                              , stateNavigationHandlers = []-                              , statePropertiesModifiedHandlers = []-                              , stateVariationModeChangedHandlers = []-                              }---- | A single step along a game tree.  Either up or down.-data Step = GoUp Int-            -- ^ Represents a step up from a child with the given index.-          | GoDown Int-            -- ^ Represents a step down to the child with the given index.-          deriving (Eq, Show)---- | Reverses a step, such that taking a step then it's reverse will leave you--- where you started.-reverseStep :: Step -> Step-reverseStep step = case step of-  GoUp index -> GoDown index-  GoDown index -> GoUp index---- | Takes a 'Step' from a 'Cursor', returning a new 'Cursor'.-takeStep :: Step -> Cursor -> Cursor-takeStep (GoUp _) cursor = fromMaybe (error $ "takeStep: Can't go up from " ++ show cursor ++ ".") $-                           cursorParent cursor-takeStep (GoDown index) cursor = cursorChild cursor index---- | Internal function.  Takes a 'Step' in the Go monad.  Updates the path stack--- accordingly.-takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m ()-takeStepM step = case step of-  GoUp _ -> goUp'-  GoDown index -> goDown' index---- | A monad (transformer) for navigating and mutating 'Cursor's, and--- remembering previous locations.  See 'GoT' and 'GoM'.------ The monad supports handlers for events raised during actions it takes, such--- as navigating through the tree and modifying nodes.-class Monad go => MonadGo go where-  -- | Returns the current cursor.-  getCursor :: go Cursor--  -- | Returns the 'CoordState' at the given point.-  getCoordState :: Coord -> go CoordState-  getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor--  -- | Navigates up the tree.  It must be valid to do so, otherwise 'fail' is-  -- called.  Fires a 'navigationEvent' after moving.-  goUp :: go ()--  -- | Navigates down the tree to the child with the given index.  The child-  -- must exist.  Fires a 'navigationEvent' after moving.-  goDown :: Int -> go ()--  -- | Navigates up to the root of the tree.  Fires 'navigationEvent's for each-  -- step.-  goToRoot :: go ()--  -- | Navigates up the tree to the node containing game info properties, if-  -- any.  Returns true if a game info node was found.-  goToGameInfoNode :: Bool-                      -- ^ When no node with game info is found, then if false,-                      -- return to the original node, otherwise finish at the-                      -- root node.-                   -> go Bool--  -- | Pushes the current location in the game tree onto an internal position-  -- stack, such that 'popPosition' is capable of navigating back to the same-  -- position, even if the game tree has been modified (though the old position-  -- must still exist in the tree to return to it).-  pushPosition :: go ()--  -- | Returns to the last position pushed onto the internal position stack via-  -- 'pushPosition'.  This action must be balanced by a 'pushPosition'.-  popPosition :: go ()--  -- | Drops the last position pushed onto the internal stack by 'pushPosition'-  -- off of the stack.  This action must be balanced by a 'pushPosition'.-  dropPosition :: go ()--  -- | Returns the set of properties on the current node.-  getProperties :: go [Property]-  getProperties = liftM cursorProperties getCursor--  -- | Modifies the set of properties on the current node.-  ---  -- The given function must end on the same node on which it started.-  modifyProperties :: ([Property] -> go [Property]) -> go ()--  -- | Searches for a property on the current node, returning it if found.-  getProperty :: Descriptor d => d -> go (Maybe Property)--  -- | Searches for a valued property on the current node, returning its value-  -- if found.-  getPropertyValue :: ValuedDescriptor d v => d -> go (Maybe v)-  getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor--  -- | Sets a property on the current node, replacing an existing property with-  -- the same name, if one exists.-  putProperty :: Property -> go ()-  putProperty property = modifyProperty (propertyInfo property) $ const $ Just property--  -- | Deletes a property from the current node, if it's set.-  ---  -- Note that although a 'Property' is a 'Descriptor', giving a valued-  -- @Property@ here will not cause deletion to match on the value of the-  -- property.  That is, the following code will result in 'Nothing', because-  -- the deletion only cares about the name of the property.-  ---  -- > do putProperty $ PL Black-  -- >    deleteProperty $ PL White-  -- >    getPropertyValue propertyPL-  deleteProperty :: Descriptor d => d -> go ()-  deleteProperty descriptor = modifyProperty descriptor $ const Nothing--  -- | Calls the given function to modify the state of the given property-  -- (descriptor) on the current node.  'Nothing' represents the property not-  -- existing on the node, and a 'Just' marks the property's presence.  This-  -- function does not do any validation to check that the resulting tree state-  -- is valid.-  modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go ()--  -- | Calls the given function to modify the state of the given valued property-  -- (descriptor) on the current node.  'Nothing' represents the property not-  -- existing on the node, and a 'Just' with the property's value marks the-  -- property's presence.  This function does not do any validation to check-  -- that the resulting tree state is valid.-  modifyPropertyValue :: ValuedDescriptor d v => d -> (Maybe v -> Maybe v) -> go ()-  modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old ->-    propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old)--  -- | Mutates the string-valued property attached to the current node according-  -- to the given function.  The input string will be empty if the current node-  -- either has the property with an empty value, or doesn't have the property.-  -- Returning an empty string removes the property from the node, if it was-  -- set.-  modifyPropertyString :: (Stringlike s, ValuedDescriptor d s) => d -> (String -> String) -> go ()-  modifyPropertyString descriptor fn =-    modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of-      "" -> Nothing-      str -> let sgf = stringToSgf str-                 -- Because stringToSgf might do processing, we have to check-                 -- the conversion back to a string for emptiness.-             in if null $ sgfToString sgf then Nothing else Just sgf--  -- | Mutates the 'CoordList'-valued property attached to the current node-  -- according to the given function.  Conversion between @CoordList@ and-  -- @[Coord]@ is performed automatically.  The input list will be empty if the-  -- current node either has the property with an empty value, or doesn't have-  -- the property.  Returning an empty list removes the property from the node,-  -- if it was set.-  ---  -- Importantly, this might not be specific enough for properties such as 'DD'-  -- and 'VW' where a present, empty list has different semantics from the-  -- property not being present.  In that case, 'modifyPropertyValue' is better.-  modifyPropertyCoords :: ValuedDescriptor d CoordList => d -> ([Coord] -> [Coord]) -> go ()-  modifyPropertyCoords descriptor fn =-    modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of-      [] -> Nothing-      coords -> Just $ buildCoordList coords--  -- | Mutates the game info for the current path, returning the new info.  If-  -- the current node or one of its ancestors has game info properties, then-  -- that node is modified.  Otherwise, properties are inserted on the root-  -- node.-  modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo--  -- | Sets the game's 'VariationMode' via the 'ST' property on the root node,-  -- then fires a 'variationModeChangedEvent' if the variation mode has changed.-  modifyVariationMode :: (VariationMode -> VariationMode) -> go ()--  -- | Returns the 'Mark' at a point on the current node.-  getMark :: Coord -> go (Maybe Mark)-  getMark = liftM coordMark . getCoordState--  -- | Calls the given function to modify the presence of a 'Mark' on the-  -- current node.-  modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go ()-  modifyMark fn coord = do-    maybeOldMark <- getMark coord-    case (maybeOldMark, fn maybeOldMark) of-      (Just oldMark, Nothing) -> remove oldMark-      (Nothing, Just newMark) -> add newMark-      (Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark-      (Just _, Just _) -> return ()-      (Nothing, Nothing) -> return ()-    where remove mark = modifyPropertyCoords (markProperty mark) (delete coord)-          add mark = modifyPropertyCoords (markProperty mark) (coord:)--  -- | Adds a child node to the current node at the given index, shifting all-  -- existing children at and after the index to the right.  The index must in-  -- the range @[0, numberOfChildren]@.  Fires a 'childAddedEvent' after the-  -- child is added.-  addChild :: Int -> Node -> go ()--  -- | Registers a new event handler for a given event type.-  on :: Event go h -> h -> go ()---- | The regular monad transformer for 'MonadGo'.-newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a }---- | The regular monad for 'MonadGo'.-type GoM = GoT Identity--instance Monad m => Functor (GoT m) where-  fmap = liftM--instance Monad m => Applicative (GoT m) where-  pure = return-  (<*>) = ap--instance Monad m => Monad (GoT m) where-  return x = GoT $ return x-  m >>= f = GoT $ goState . f =<< goState m-  fail = lift . fail--instance MonadTrans GoT where-  lift = GoT . lift--instance MonadIO m => MonadIO (GoT m) where-  liftIO = lift . liftIO--instance MonadWriter w m => MonadWriter w (GoT m) where-  writer = lift . writer-  tell = lift . tell-  listen = GoT . listen . goState-  pass = GoT . pass . goState---- | Executes a Go monad transformer on a cursor, returning in the underlying--- monad a tuple that contains the resulting value and the final cursor.-runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor)-runGoT go cursor = do-  (value, state) <- State.runStateT (goState go) (initialState cursor)-  return (value, stateCursor state)---- | Executes a Go monad transformer on a cursor, returning in the underlying--- monad the value in the transformer.-evalGoT :: Monad m => GoT m a -> Cursor -> m a-evalGoT go cursor = liftM fst $ runGoT go cursor---- | Executes a Go monad transformer on a cursor, returning in the underlying--- monad the final cursor.-execGoT :: Monad m => GoT m a -> Cursor -> m Cursor-execGoT go cursor = liftM snd $ runGoT go cursor---- | Runs a Go monad on a cursor.  See 'runGoT'.-runGo :: GoM a -> Cursor -> (a, Cursor)-runGo go = runIdentity . runGoT go---- | Runs a Go monad on a cursor and returns the value in the monad.-evalGo :: GoM a -> Cursor -> a-evalGo m cursor = fst $ runGo m cursor---- | Runs a Go monad on a cursor and returns the final cursor.-execGo :: GoM a -> Cursor -> Cursor-execGo m cursor = snd $ runGo m cursor--getState :: Monad m => GoT m (GoState (GoT m))-getState = GoT State.get--putState :: Monad m => GoState (GoT m) -> GoT m ()-putState = GoT . State.put--modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()-modifyState = GoT . State.modify--instance Monad m => MonadGo (GoT m) where-  getCursor = liftM stateCursor getState--  goUp = do-    index <- liftM cursorChildIndex getCursor-    goUp' $ \pathStack -> case pathStack of-      [] -> pathStack-      path:paths -> (GoDown index:path):paths--  goDown index = goDown' index $ \pathStack -> case pathStack of-    [] -> pathStack-    path:paths -> (GoUp index:path):paths--  goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp--  goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode-    where findGameInfoNode = do-            cursor <- getCursor-            if hasGameInfo cursor-              then dropPosition >> return True-              else if isNothing $ cursorParent cursor-                   then do if goToRootIfNotFound then dropPosition else popPosition-                           return False-                   else goUp >> findGameInfoNode-          hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor--  pushPosition = modifyState $ \state ->-    state { statePathStack = []:statePathStack state }--  popPosition = do-    getPathStack >>= \stack -> when (null stack) $-      fail "popPosition: No position to pop from the stack."--    -- Drop each step in the top list of the path stack one at a time, until the-    -- top list is empty.-    whileM' (do path:_ <- getPathStack-                return $ if null path then Nothing else Just $ head path) $-      flip takeStepM $ \((_:steps):paths) -> steps:paths--    -- Finally, drop the empty top of the path stack.-    modifyState $ \state -> case statePathStack state of-      []:rest -> state { statePathStack = rest }-      _ -> error "popPosition: Internal failure, top of path stack is not empty."--  dropPosition = do-    state <- getState-    -- If there are >=2 positions on the path stack, then we can't simply drop-    -- the moves that will return us to the top-of-stack position, because they-    -- may still be needed to return to the second-on-stack position by a-    -- following popPosition.-    case statePathStack state of-      x:y:xs -> putState $ state { statePathStack = (x ++ y):xs }-      _:[] -> putState $ state { statePathStack = [] }-      [] -> fail "dropPosition: No position to drop from the stack."--  modifyProperties fn = do-    oldCursor <- getCursor-    let oldProperties = cursorProperties oldCursor-    newProperties <- fn oldProperties-    modifyState $ \state ->-      state { stateCursor = cursorModifyNode-                            (\node -> node { nodeProperties = newProperties })-                            oldCursor-            }-    fire propertiesModifiedEvent (\f -> f oldProperties newProperties)--    -- The current game info changes when modifying game info properties on the-    -- current node.  I think comparing game info properties should be faster-    -- than comparing 'GameInfo's.-    let filterToGameInfo = nub . filter ((GameInfoProperty ==) . propertyType)-        oldGameInfo = filterToGameInfo oldProperties-        newGameInfo = filterToGameInfo newProperties-    when (newGameInfo /= oldGameInfo) $ do-      newCursor <- getCursor-      fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard oldCursor)-                                         (boardGameInfo $ cursorBoard newCursor))--  getProperty descriptor = find (propertyPredicate descriptor) <$> getProperties--  modifyProperty descriptor fn = do-    cursor <- getCursor-    let node = cursorNode cursor-        old = findProperty descriptor node-        new = fn old-    when (maybe False (not . propertyPredicate descriptor) new) $-      fail $ "modifyProperty: May not change property type: " ++-      show old ++ " -> " ++ show new ++ "."-    case (old, new) of-      (Just _, Nothing) -> modifyProperties $ return . remove descriptor-      (Nothing, Just value') -> modifyProperties $ return . add value'-      (Just value, Just value') | value /= value' ->-        modifyProperties $ return . add value' . remove descriptor-      _ -> return ()-    where remove descriptor = filter (not . propertyPredicate descriptor)-          add value = (value:)--  modifyGameInfo fn = do-    cursor <- getCursor-    let info = boardGameInfo $ cursorBoard cursor-        info' = fn info-    when (gameInfoRootInfo info /= gameInfoRootInfo info') $-      fail "Illegal modification of root info in modifyGameInfo."-    pushPosition-    goToGameInfoNode True-    modifyProperties $ \props ->-      return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props-    popPosition-    return info'--  modifyVariationMode fn = do-    pushPosition-    goToRoot-    modifyPropertyValue propertyST $ \maybeOld ->-      -- If the new variation mode is equal to the old effective variation mode-      -- (effective applying the default if the property isn't present), then-      -- leave the property unchanged.  Otherwise, apply the new variation mode,-      -- deleting the property if the default variation mode is selected.  We-      -- don't delete the property if @maybeOld == Just new == Just-      -- defaultVariationMode@, because we don't want to trigger dirtyness-      -- unnecessarily.-      let old = fromMaybe defaultVariationMode maybeOld-          new = fn old-      in if new == old-         then maybeOld-         else if new == defaultVariationMode-              then Nothing-              else Just new-    popPosition--  addChild index node = do-    cursor <- getCursor-    let childCount = cursorChildCount cursor-    when (index < 0 || index > childCount) $ fail $-      "Monad.addChild: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]."-    let cursor' = cursorModifyNode (addChildAt index node) cursor-    modifyState $ \state ->-      state { stateCursor = cursor'-            , statePathStack = updatePathStackCurrentNode-                               (\step -> case step of-                                   GoUp n -> GoUp $ if n < index then n else n + 1-                                   down@(GoDown _) -> down)-                               (\step -> case step of-                                   up@(GoUp _) -> up-                                   GoDown n -> GoDown $ if n < index then n else n + 1)-                               cursor'-                               (statePathStack state)-            }-    fire childAddedEvent (\f -> f index (cursorChild cursor' index))--  on event handler = modifyState $ addHandler event handler---- | Takes a step up the game tree, updates the path stack according to the--- given function, then fires navigation and game info changed events as--- appropriate.-goUp' :: Monad m => (PathStack -> PathStack) -> GoT m ()-goUp' pathStackFn = do-  state@(GoState { stateCursor = cursor-                 , statePathStack = pathStack-                 }) <- getState-  case cursorParent cursor of-    Nothing -> fail $ "goUp': Can't go up from a root cursor: " ++ show cursor-    Just parent -> do-      let index = cursorChildIndex cursor-      putState state { stateCursor = parent-                     , statePathStack = pathStackFn pathStack-                     }-      fire navigationEvent ($ GoUp index)--      -- The current game info changes when navigating up from a node that has-      -- game info properties.-      when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $-        fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)-                                           (boardGameInfo $ cursorBoard parent))---- | Takes a step down the game tree, updates the path stack according to the--- given function, then fires navigation and game info changed events as--- appropriate.-goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m ()-goDown' index pathStackFn = do-  state@(GoState { stateCursor = cursor-                 , statePathStack = pathStack-                 }) <- getState-  case drop index $ cursorChildren cursor of-    [] -> fail $ "goDown': Cursor does not have a child #" ++ show index ++ ": " ++ show cursor-    child:_ -> do-      putState state { stateCursor = child-                     , statePathStack = pathStackFn pathStack-                     }-      fire navigationEvent ($ GoDown index)--      -- The current game info changes when navigating down to a node that has-      -- game info properties.-      when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $-        fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)-                                           (boardGameInfo $ cursorBoard child))---- | Returns the current path stack.-getPathStack :: Monad m => GoT m PathStack-getPathStack = liftM statePathStack getState---- | Maps over a path stack, updating with the given functions all steps that--- enter and leave the cursor's current node.-updatePathStackCurrentNode :: (Step -> Step)-                           -> (Step -> Step)-                           -> Cursor-                           -> PathStack-                           -> PathStack-updatePathStackCurrentNode _ _ _ [] = []-updatePathStackCurrentNode onEnter onExit cursor0 paths =-  snd $ mapAccumL updatePath (cursor0, []) paths-  where updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [Step])-        updatePath = mapAccumL updateStep-        updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), Step)-        updateStep (cursor, []) step = ((takeStep step cursor, [reverseStep step]), onExit step)-        updateStep (cursor, pathToInitial@(stepToInitial:restToInitial)) step =-          let pathToInitial' = if stepToInitial == step-                               then restToInitial-                               else reverseStep step:pathToInitial-          in ((takeStep step cursor, pathToInitial'),-              if null pathToInitial' then onEnter step else step)---- | Fires all of the handlers for the given event, using the given function to--- create a Go action from each of the handlers (normally themselves functions--- that create Go actions, if they're not just Go actions directly, depending on--- the event).-fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()-fire event handlerGenerator = do-  state <- getState-  mapM_ handlerGenerator $ eventStateGetter event state---- | A type of event in the Go monad transformer that can be handled by--- executing an action.  @go@ is the type of the type of the Go--- monad/transformer.  @h@ is the type of monad or monadic function which will--- be used by Go actions that can trigger the event.  For example, a navigation--- event is characterized by a 'Step' that cannot easily be recovered from the--- regular monad state, and comparing before-and-after states would be a pain.--- So @h@ for navigation events is @'Step' -> go ()@; a handler takes a 'Step'--- and returns a Go action to run as a result.-data Event go h = Event { eventName :: String-                        , eventStateGetter :: GoState go -> [h]-                        , eventStateSetter :: [h] -> GoState go -> GoState go-                        }--instance Show (Event go h) where-  show = eventName--addHandler :: Event go h -> h -> GoState go -> GoState go-addHandler event handler state =-  eventStateSetter event (eventStateGetter event state ++ [handler]) state---- | An event corresponding to a child node being added to the current node.-childAddedEvent :: Event go (ChildAddedHandler go)-childAddedEvent = Event {-  eventName = "childAddedEvent"-  , eventStateGetter = stateChildAddedHandlers-  , eventStateSetter = \handlers state -> state { stateChildAddedHandlers = handlers }-  }---- | A handler for 'childAddedEvent's.-type ChildAddedHandler go = Int -> Cursor -> go ()---- | An event that is fired when the current game info changes, either by--- navigating past a node with game info properties, or by modifying the current--- game info properties.-gameInfoChangedEvent :: Event go (GameInfoChangedHandler go)-gameInfoChangedEvent = Event {-  eventName = "gameInfoChangedEvent"-  , eventStateGetter = stateGameInfoChangedHandlers-  , eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers }-  }---- | A handler for 'gameInfoChangedEvent's.  It is called with the old game info--- then the new game info.-type GameInfoChangedHandler go = GameInfo -> GameInfo -> go ()---- | An event that is fired when a single step up or down in a game tree is--- made.-navigationEvent :: Event go (NavigationHandler go)-navigationEvent = Event {-  eventName = "navigationEvent"-  , eventStateGetter = stateNavigationHandlers-  , eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers }-  }---- | A handler for 'navigationEvent's.------ A navigation handler may navigate further, but beware infinite recursion.  A--- navigation handler must end on the same node on which it started.-type NavigationHandler go = Step -> go ()---- | An event corresponding to a modification to the properties list of the--- current node.-propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go)-propertiesModifiedEvent = Event {-  eventName = "propertiesModifiedEvent"-  , eventStateGetter = statePropertiesModifiedHandlers-  , eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers }-  }---- | A handler for 'propertiesModifiedEvent's.  It is called with the old--- property list then the new property list.-type PropertiesModifiedHandler go = [Property] -> [Property] -> go ()---- | An event corresponding to a change in the active 'VariationMode'.  This can--- happen when modifying the 'ST' property, and also when navigating between--- collections (as they have different root nodes).-variationModeChangedEvent :: Event go (VariationModeChangedHandler go)-variationModeChangedEvent = Event {-  eventName = "variationModeChangedEvent"-  , eventStateGetter = stateVariationModeChangedHandlers-  , eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers }-  }--- TODO Test that this is fired when moving between root nodes in a collection.--- For now, since we don't support multiple trees in a collection, we don't need--- to worry about checking for active variation mode change on navigation.---- | A handler for 'variationModeChangedEvent's.  It is called with the old--- variation mode then the new variation mode.-type VariationModeChangedHandler go = VariationMode -> VariationMode -> go ()

@@ -1,113 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.---- | A parser for reading SGF files.-module Game.Goatee.Sgf.Parser (-  parseString,-  parseFile,-  ) where--import Control.Applicative ((<*), (*>))-import Data.Maybe (fromMaybe)-import Game.Goatee.Common-import Game.Goatee.Sgf.Property-import Game.Goatee.Sgf.Tree-import Game.Goatee.Sgf.Types-import Text.ParserCombinators.Parsec (-  (<?>), Parser, char, eof, many, many1, parse, spaces, upper,-  )---- | Parses a string in SGF format.  Returns an error string if parsing fails.-parseString :: String -> Either String Collection-parseString str = case parse collection "<collection>" str of-  Left err -> Left $ show err-  Right (Collection roots) -> onLeft concatErrors $-                              onRight Collection $-                              andEithers $-                              map processRoot roots-  where processRoot :: Node -> Either String Node-        processRoot = checkFormatVersion . ttToPass--        -- Ensures that we are parsing an SGF version that we understand.-        -- TODO Try to proceed, if it makes sense.-        checkFormatVersion :: Node -> Either String Node-        checkFormatVersion root =-          let version = case findProperty propertyFF root of-                Nothing -> defaultFormatVersion-                Just (FF x) -> x-                x -> error $ "Expected FF or nothing, received " ++ show x ++ "."-          in if version `elem` supportedFormatVersions-             then Right root-             else Left $-                  "Unsupported SGF version " ++ show version ++ ".  Only versions " ++-                  show supportedFormatVersions ++ " are supported."--        -- SGF allows B[tt] and W[tt] to represent passes on boards <=19x19.-        -- Convert any passes from this format to B[] and W[] in a root node and-        -- its descendents.-        ttToPass :: Node -> Node-        ttToPass root =-          let SZ width height = fromMaybe (SZ boardSizeDefault boardSizeDefault) $-                                findProperty propertySZ root-          in if width <= 19 && height <= 19-             then ttToPass' width height root-             else root--        -- Convert a node and its descendents.-        ttToPass' width height node =-          node { nodeProperties = map ttToPass'' $ nodeProperties node-               , nodeChildren = map (ttToPass' width height) $ nodeChildren node-               }--        -- Convert a property.-        ttToPass'' prop = case prop of-          B (Just (19, 19)) -> B Nothing-          W (Just (19, 19)) -> W Nothing-          _ -> prop--        concatErrors errs = "The following errors occurred while parsing:" ++-                            concatMap ("\n-> " ++) errs---- | Parses a file in SGF format.  Returns an error string if parsing fails.-parseFile :: String -> IO (Either String Collection)-parseFile = fmap parseString . readFile--collection :: Parser Collection-collection = fmap Collection (spaces *> many (gameTree <* spaces) <* eof)-             <?> "collection"--gameTree :: Parser Node-gameTree = do-  char '('-  nodes <- spaces *> many1 (node <* spaces) <?> "sequence"-  subtrees <- many (gameTree <* spaces) <?> "subtrees"-  char ')'-  let (sequence, [final]) = splitAt (length nodes - 1) nodes-  return $ foldr (\seqNode childNode -> seqNode { nodeChildren = [childNode] })-                 (final { nodeChildren = subtrees })-                 sequence--node :: Parser Node-node = fmap (\props -> emptyNode { nodeProperties = props })-       (char ';' *> spaces *> many (property <* spaces)-        <?> "node")--property :: Parser Property-property = do-  name <- many1 upper-  spaces-  propertyValueParser $ descriptorForName name

@@ -1,27 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.---- | Structures and functions for working with SGF node properties.-module Game.Goatee.Sgf.Property (-  module Game.Goatee.Sgf.Property.Base,-  module Game.Goatee.Sgf.Property.Info,-  PropertyValueType, pvtParser, pvtRenderer, pvtRendererPretty,-  ) where--import Game.Goatee.Sgf.Property.Base-import Game.Goatee.Sgf.Property.Info-import Game.Goatee.Sgf.Property.Value

@@ -1,314 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_HADDOCK hide #-}---- | Core property-related data types, and some Template Haskell declarations--- for defining property metadata.------ Import "Game.Goatee.Sgf.Property" rather than importing this module.-module Game.Goatee.Sgf.Property.Base (-  -- * Properties-  Property (..),-  -- * Property metadata-  PropertyType (..),-  Descriptor (..),-  SomeDescriptor (..),-  ValuedDescriptor (..),-  PropertyInfo,-  ValuedPropertyInfo (ValuedPropertyInfo),-  -- * Property declaration-  defProperty, defValuedProperty,-  ) where--import Control.Applicative ((<$))-import Game.Goatee.Sgf.Property.Value (PropertyValueType(..), nonePvt)-import Game.Goatee.Sgf.Renderer-import Game.Goatee.Sgf.Types-import Language.Haskell.TH (-  Info (DataConI), DecsQ, Name, Type (AppT),-  appE, appT, caseE, conE, conP, conT, lam1E, match, mkName, newName,-  normalB, recP, reify, sigD, stringE, valD, varE, varP, wildP,-  )-import Text.ParserCombinators.Parsec (Parser)---- | An SGF property that gives a node meaning.-data Property =-  -- Move properties.-    B (Maybe Coord)      -- ^ Black move (nothing iff pass).-  | KO                   -- ^ Execute move unconditionally (even if illegal).-  | MN Integer           -- ^ Assign move number.-  | W (Maybe Coord)      -- ^ White move (nothing iff pass).--  -- Setup properties.-  | AB CoordList         -- ^ Assign black stones.-  | AE CoordList         -- ^ Assign empty stones.-  | AW CoordList         -- ^ Assign white stones.-  | PL Color             -- ^ Player to play.--  -- Node annotation properties.-  | C Text               -- ^ Comment.-  | DM DoubleValue       -- ^ Even position.-  | GB DoubleValue       -- ^ Good for black.-  | GW DoubleValue       -- ^ Good for white.-  | HO DoubleValue       -- ^ Hotspot.-  | N SimpleText         -- ^ Node name.-  | UC DoubleValue       -- ^ Unclear position.-  | V RealValue          -- ^ Node value.--  -- Move annotation properties.-  | BM DoubleValue       -- ^ Bad move.-  | DO                   -- ^ Doubtful move.-  | IT                   -- ^ Interesting move.-  | TE DoubleValue       -- ^ Tesuji.--  -- Markup properties.-  | AR ArrowList         -- ^ Arrows.-  | CR CoordList         -- ^ Mark points with circles.-  | DD CoordList         -- ^ Dim points.-  | LB LabelList         -- ^ Label points with text.-  | LN LineList          -- ^ Lines.-  | MA CoordList         -- ^ Mark points with 'X's.-  | SL CoordList         -- ^ Mark points as selected.-  | SQ CoordList         -- ^ Mark points with squares.-  | TR CoordList         -- ^ Mark points with trianges.--  -- Root properties.-  | AP SimpleText SimpleText -- ^ Application info.-  | CA SimpleText        -- ^ Charset for SimpleText and Text.-  | FF Int               -- ^ File format version.-  | GM Int               -- ^ Game (must be 1 = Go).-  | ST VariationMode     -- ^ Variation display format.-  | SZ Int Int           -- ^ Board size, columns then rows.--  -- Game info properties.-  | AN SimpleText        -- ^ Name of annotator.-  | BR SimpleText        -- ^ Rank of black player.-  | BT SimpleText        -- ^ Name of black team.-  | CP SimpleText        -- ^ Copyright info.-  | DT SimpleText        -- ^ Dates played.-  | EV SimpleText        -- ^ Event name.-  | GC SimpleText        -- ^ Game comment, or background, or summary.-  | GN SimpleText        -- ^ Game name.-  | ON SimpleText        -- ^ Information about the opening.-  | OT SimpleText        -- ^ The method used for overtime.-  | PB SimpleText        -- ^ Name of black player.-  | PC SimpleText        -- ^ Where the game was played.-  | PW SimpleText        -- ^ Name of white player.-  | RE GameResult        -- ^ Result of the game.-  | RO SimpleText        -- ^ Round info.-  | RU Ruleset           -- ^ Ruleset used.-  | SO SimpleText        -- ^ Source of the game.-  | TM RealValue         -- ^ Time limit, in seconds.-  | US SimpleText        -- ^ Name of user or program who entered the game.-  | WR SimpleText        -- ^ Rank of white player.-  | WT SimpleText        -- ^ Name of white team.--  -- Miscellaneous properties.-  | VW CoordList         -- ^ Set viewing region.--  | UnknownProperty String UnknownPropertyValue--  -- TODO Game info, timing, and miscellaneous properties.-  -- Also in functions below.-  deriving (Eq, Show)---- | The property types that SGF uses to group properties.-data PropertyType = MoveProperty     -- ^ Cannot mix with setup nodes.-                  | SetupProperty    -- ^ Cannot mix with move nodes.-                  | RootProperty     -- ^ May only appear in root nodes.-                  | GameInfoProperty -- ^ At most one on any path.-                  | GeneralProperty  -- ^ May appear anywhere in the game tree.-                  deriving (Eq, Show)---- | A class for types that contain metadata about a 'Property'.-class Descriptor a where-  -- | Returns the name of the property, as used in SGF files.-  propertyName :: a -> String--  -- | Returns the type of the property, as specified by the SGF spec.-  propertyType :: a -> PropertyType--  -- | Returns whether the value of the given property is inherited from the-  -- lowest ancestor specifying the property, when the property is not set on a-  -- node itself.-  propertyInherited :: a -> Bool--  -- | Returns whether the given property has the type of a descriptor.-  propertyPredicate :: a -> Property -> Bool--  -- | A parser of property values in SGF format (e.g. @"[ab]"@ for a property-  -- that takes a point).-  propertyValueParser :: a -> Parser Property--  -- | A renderer property values to SGF format (e.g. @B (Just (1,2))@ renders-  -- to @"[ab]"@).-  propertyValueRenderer :: a -> Property -> Render ()--  -- | A renderer for displaying property values in a UI.  Displays the value in-  -- a human-readable format.-  propertyValueRendererPretty :: a -> Property -> Render ()--data SomeDescriptor = forall a. Descriptor a => SomeDescriptor a--instance Descriptor SomeDescriptor where-  propertyName (SomeDescriptor d) = propertyName d-  propertyType (SomeDescriptor d) = propertyType d-  propertyInherited (SomeDescriptor d) = propertyInherited d-  propertyPredicate (SomeDescriptor d) = propertyPredicate d-  propertyValueParser (SomeDescriptor d) = propertyValueParser d-  propertyValueRenderer (SomeDescriptor d) = propertyValueRenderer d-  propertyValueRendererPretty (SomeDescriptor d) = propertyValueRendererPretty d---- | A class for 'Descriptor's of 'Property's that also contain values.-class (Descriptor a, Eq v) => ValuedDescriptor a v | a -> v where-  -- | Extracts the value from a property of the given type.  Behaviour is-  -- undefined if the property is not of the given type.-  propertyValue :: a -> Property -> v--  -- | Builds a property from a given value.-  propertyBuilder :: a -> v -> Property---- | Metadata for a property that does not contain a value.  Corresponds to a--- single nullary data constructor of 'Property'.-data PropertyInfo = PropertyInfo {-  propertyInfoName :: String-  -- ^ The SGF textual name for the property.-  , propertyInfoInstance :: Property-    -- ^ The single instance of the property.-  , propertyInfoType :: PropertyType-    -- ^ The SGF property type.-  , propertyInfoInherited :: Bool-    -- ^ Whether the property is inherited.-  }--instance Descriptor PropertyInfo where-  propertyName = propertyInfoName-  propertyType = propertyInfoType-  propertyInherited = propertyInfoInherited-  propertyPredicate = (==) . propertyInfoInstance-  propertyValueParser descriptor = propertyInfoInstance descriptor <$ pvtParser nonePvt-  propertyValueRenderer _ _ = pvtRenderer nonePvt ()-  propertyValueRendererPretty _ _ = pvtRendererPretty nonePvt ()---- | Metadata for a property that contains a value.  Corresponds to a single--- unary data constructor of 'Property'.-data ValuedPropertyInfo v = ValuedPropertyInfo {-  valuedPropertyInfoName :: String-  -- ^ The SGF textual name for the property (also the name of the data-  -- constructor).-  , valuedPropertyInfoType :: PropertyType-    -- ^ The SGF property type.-  , valuedPropertyInfoInherited :: Bool-    -- ^ Whether the property is inherited.-  , valuedPropertyInfoPredicate :: Property -> Bool-    -- ^ A predicate that matches predicates to which this 'ValuedPropertyInfo'-    -- applies.-  , valuedPropertyInfoValueType :: PropertyValueType v-    -- ^ Metadata about the type of the property's value.-  , valuedPropertyInfoValue :: Property -> v-    -- ^ A function that extracts values from properties to which this-    -- 'ValuedPropertyInfo' applies.  It is invalid to call this function with a-    -- different type of property.-  , valuedPropertyInfoBuilder :: v -> Property-    -- ^ A function that builds a property containing a value.-  }--instance Descriptor (ValuedPropertyInfo v) where-  propertyName = valuedPropertyInfoName-  propertyType = valuedPropertyInfoType-  propertyInherited = valuedPropertyInfoInherited-  propertyPredicate = valuedPropertyInfoPredicate-  propertyValueParser descriptor =-    fmap (valuedPropertyInfoBuilder descriptor) $-    pvtParser $-    valuedPropertyInfoValueType descriptor-  propertyValueRenderer descriptor property =-    pvtRenderer (valuedPropertyInfoValueType descriptor) $-    valuedPropertyInfoValue descriptor property-  propertyValueRendererPretty descriptor property =-    pvtRendererPretty (valuedPropertyInfoValueType descriptor) $-    valuedPropertyInfoValue descriptor property--instance Eq v => ValuedDescriptor (ValuedPropertyInfo v) v where-  propertyValue = valuedPropertyInfoValue-  propertyBuilder = valuedPropertyInfoBuilder---- | Template Haskell function to declare a property that does not contain a--- value.------ > $(defProperty "KO" 'MoveProperty False)------ This example declares a @propertyKO :: 'PropertyInfo'@ that is a--- 'MoveProperty' and is not inherited.-defProperty :: String-               -- ^ The SGF textual name of the property.-            -> Name-               -- ^ The name of the 'PropertyType'.-            -> Bool-               -- ^ Whether the property is inherited.-            -> DecsQ-defProperty name propType inherited = do-  let propName = mkName name-      varName = mkName $ "property" ++ name-  foo <- newName "foo"-  sequence [-    sigD varName $ conT $ mkName "PropertyInfo",-    valD (varP varName)-         (normalB [| PropertyInfo name $(conE propName) $(conE propType) inherited |])-         []-    ]---- | Template Haskell function to declare a property that contains a value.------ > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter)------ This example declares a @propertyB :: 'ValuedPropertyInfo' (Maybe 'Coord')@--- that is a 'MoveProperty' and is not inherited.  The value type is--- automatically inferred.-defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ-defValuedProperty name propType inherited valueType = do-  let propName = mkName name-      varName = mkName $ "property" ++ name-  foo <- newName "foo"-  bar <- newName "bar"-  DataConI _ (AppT (AppT _ haskellValueType) _) _ _ <- reify propName-  sequence [-    sigD varName $ appT (conT ''ValuedPropertyInfo) $ return haskellValueType,-    valD (varP varName)-         (normalB [| ValuedPropertyInfo-                     name-                     $(conE propType)-                     inherited-                     $(lam1E (varP foo) $ caseE (varE foo)-                       [match (recP propName [])-                              (normalB $ conE $ mkName "True")-                              [],-                        match wildP (normalB $ conE $ mkName "False") []])-                     $(varE valueType)-                     $(lam1E (varP foo) $ caseE (varE foo)-                       [match (conP propName [varP bar]) (normalB $ varE bar) [],-                        match wildP-                              (normalB-                               [| error $ "Property value getter for " ++ $(stringE name) ++-                                  " applied to " ++ show $(varE foo) ++ "." |])-                              []])-                     $(lam1E (varP foo) $ appE (conE propName) (varE foo))-                   |])-         []-    ]

@@ -1,288 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_HADDOCK hide #-}---- | Property metadata declarations.------ Import "Game.Goatee.Sgf.Property" rather than importing this module.-module Game.Goatee.Sgf.Property.Info where--import Control.Arrow ((&&&))-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe (fromMaybe)-import Game.Goatee.Sgf.Property.Base-import Game.Goatee.Sgf.Property.Value-import Game.Goatee.Sgf.Types---- Move properties.-$(defValuedProperty "B" 'MoveProperty False 'movePvt)-$(defProperty "KO" 'MoveProperty False)-$(defValuedProperty "MN" 'MoveProperty False 'integralPvt)-$(defValuedProperty "W" 'MoveProperty False 'movePvt)---- Setup properties.-$(defValuedProperty "AB" 'SetupProperty False 'coordListPvt)-$(defValuedProperty "AE" 'SetupProperty False 'coordListPvt)-$(defValuedProperty "AW" 'SetupProperty False 'coordListPvt)-$(defValuedProperty "PL" 'SetupProperty False 'colorPvt)---- Node annotation properties.-$(defValuedProperty "C" 'GeneralProperty False 'textPvt)-$(defValuedProperty "DM" 'GeneralProperty False 'doublePvt)-$(defValuedProperty "GB" 'GeneralProperty False 'doublePvt)-$(defValuedProperty "GW" 'GeneralProperty False 'doublePvt)-$(defValuedProperty "HO" 'GeneralProperty False 'doublePvt)-$(defValuedProperty "N" 'GeneralProperty False 'simpleTextPvt)-$(defValuedProperty "UC" 'GeneralProperty False 'doublePvt)-$(defValuedProperty "V" 'GeneralProperty False 'realPvt)---- Move annotation properties.-$(defValuedProperty "BM" 'MoveProperty False 'doublePvt)-$(defProperty "DO" 'MoveProperty False)-$(defProperty "IT" 'MoveProperty False)-$(defValuedProperty "TE" 'MoveProperty False 'doublePvt)---- Markup properties.-$(defValuedProperty "AR" 'GeneralProperty False 'coordPairListPvt)-$(defValuedProperty "CR" 'GeneralProperty False 'coordListPvt)-$(defValuedProperty "DD" 'GeneralProperty True 'coordListPvt)-$(defValuedProperty "LB" 'GeneralProperty False 'labelListPvt)-$(defValuedProperty "LN" 'GeneralProperty False 'coordPairListPvt)-$(defValuedProperty "MA" 'GeneralProperty False 'coordListPvt)-$(defValuedProperty "SL" 'GeneralProperty False 'coordListPvt)-$(defValuedProperty "SQ" 'GeneralProperty False 'coordListPvt)-$(defValuedProperty "TR" 'GeneralProperty False 'coordListPvt)---- Root properties.-propertyAP :: ValuedPropertyInfo (SimpleText, SimpleText)-propertyAP = ValuedPropertyInfo "AP" RootProperty False-             (\x -> case x of { AP {} -> True; _ -> False })-             simpleTextPairPvt-             (\(AP x y) -> (x, y))-             (uncurry AP)-$(defValuedProperty "CA" 'RootProperty False 'simpleTextPvt)-$(defValuedProperty "FF" 'RootProperty False 'integralPvt)  -- TODO Add parser validation.-$(defValuedProperty "GM" 'RootProperty False 'integralPvt)  -- TODO Add parser validation.-$(defValuedProperty "ST" 'RootProperty False 'variationModePvt)-propertySZ :: ValuedPropertyInfo (Int, Int)-propertySZ = ValuedPropertyInfo "SZ" RootProperty False-             (\x -> case x of { SZ {} -> True; _ -> False })-             sizePvt-             (\(SZ x y) -> (x, y))-             (uncurry SZ)---- Game info properties.-$(defValuedProperty "AN" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "BR" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "BT" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "CP" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "DT" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "EV" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "GC" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "GN" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "ON" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "OT" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "PB" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "PC" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "PW" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "RE" 'GameInfoProperty False 'gameResultPvt)-$(defValuedProperty "RO" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "RU" 'GameInfoProperty False 'rulesetPvt)-$(defValuedProperty "SO" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "TM" 'GameInfoProperty False 'realPvt)-$(defValuedProperty "US" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "WR" 'GameInfoProperty False 'simpleTextPvt)-$(defValuedProperty "WT" 'GameInfoProperty False 'simpleTextPvt)---- Miscellaneous properties.-$(defValuedProperty "VW" 'GeneralProperty True 'coordElistPvt)--propertyUnknown :: String -> ValuedPropertyInfo UnknownPropertyValue-propertyUnknown name =-  ValuedPropertyInfo name GeneralProperty False-  (\x -> case x of-      UnknownProperty name' _ | name' == name -> True-      _ -> False)-  unknownPropertyPvt-  (\(UnknownProperty _ value) -> value)-  (UnknownProperty name)--allDescriptors :: [SomeDescriptor]-allDescriptors = [-  SomeDescriptor propertyB-  , SomeDescriptor propertyKO-  , SomeDescriptor propertyMN-  , SomeDescriptor propertyW--  , SomeDescriptor propertyAB-  , SomeDescriptor propertyAE-  , SomeDescriptor propertyAW-  , SomeDescriptor propertyPL--  , SomeDescriptor propertyC-  , SomeDescriptor propertyDM-  , SomeDescriptor propertyGB-  , SomeDescriptor propertyGW-  , SomeDescriptor propertyHO-  , SomeDescriptor propertyN-  , SomeDescriptor propertyUC-  , SomeDescriptor propertyV--  , SomeDescriptor propertyBM-  , SomeDescriptor propertyDO-  , SomeDescriptor propertyIT-  , SomeDescriptor propertyTE--  , SomeDescriptor propertyAR-  , SomeDescriptor propertyCR-  , SomeDescriptor propertyDD-  , SomeDescriptor propertyLB-  , SomeDescriptor propertyLN-  , SomeDescriptor propertyMA-  , SomeDescriptor propertySL-  , SomeDescriptor propertySQ-  , SomeDescriptor propertyTR--  , SomeDescriptor propertyAP-  , SomeDescriptor propertyCA-  , SomeDescriptor propertyFF-  , SomeDescriptor propertyGM-  , SomeDescriptor propertyST-  , SomeDescriptor propertySZ--  , SomeDescriptor propertyAN-  , SomeDescriptor propertyBR-  , SomeDescriptor propertyBT-  , SomeDescriptor propertyCP-  , SomeDescriptor propertyDT-  , SomeDescriptor propertyEV-  , SomeDescriptor propertyGC-  , SomeDescriptor propertyGN-  , SomeDescriptor propertyON-  , SomeDescriptor propertyOT-  , SomeDescriptor propertyPB-  , SomeDescriptor propertyPC-  , SomeDescriptor propertyPW-  , SomeDescriptor propertyRE-  , SomeDescriptor propertyRO-  , SomeDescriptor propertyRU-  , SomeDescriptor propertySO-  , SomeDescriptor propertyTM-  , SomeDescriptor propertyUS-  , SomeDescriptor propertyWR-  , SomeDescriptor propertyWT--  , SomeDescriptor propertyVW-  ]--propertyInfo :: Property -> SomeDescriptor-propertyInfo property = case property of-  B {} -> SomeDescriptor propertyB-  KO {} -> SomeDescriptor propertyKO-  MN {} -> SomeDescriptor propertyMN-  W {} -> SomeDescriptor propertyW--  AB {} -> SomeDescriptor propertyAB-  AE {} -> SomeDescriptor propertyAE-  AW {} -> SomeDescriptor propertyAW-  PL {} -> SomeDescriptor propertyPL--  C {} -> SomeDescriptor propertyC-  DM {} -> SomeDescriptor propertyDM-  GB {} -> SomeDescriptor propertyGB-  GW {} -> SomeDescriptor propertyGW-  HO {} -> SomeDescriptor propertyHO-  N {} -> SomeDescriptor propertyN-  UC {} -> SomeDescriptor propertyUC-  V {} -> SomeDescriptor propertyV--  BM {} -> SomeDescriptor propertyBM-  DO {} -> SomeDescriptor propertyDO-  IT {} -> SomeDescriptor propertyIT-  TE {} -> SomeDescriptor propertyTE--  AR {} -> SomeDescriptor propertyAR-  CR {} -> SomeDescriptor propertyCR-  DD {} -> SomeDescriptor propertyDD-  LB {} -> SomeDescriptor propertyLB-  LN {} -> SomeDescriptor propertyLN-  MA {} -> SomeDescriptor propertyMA-  SL {} -> SomeDescriptor propertySL-  SQ {} -> SomeDescriptor propertySQ-  TR {} -> SomeDescriptor propertyTR--  AP {} -> SomeDescriptor propertyAP-  CA {} -> SomeDescriptor propertyCA-  FF {} -> SomeDescriptor propertyFF-  GM {} -> SomeDescriptor propertyGM-  ST {} -> SomeDescriptor propertyST-  SZ {} -> SomeDescriptor propertySZ--  AN {} -> SomeDescriptor propertyAN-  BR {} -> SomeDescriptor propertyBR-  BT {} -> SomeDescriptor propertyBT-  CP {} -> SomeDescriptor propertyCP-  DT {} -> SomeDescriptor propertyDT-  EV {} -> SomeDescriptor propertyEV-  GC {} -> SomeDescriptor propertyGC-  GN {} -> SomeDescriptor propertyGN-  ON {} -> SomeDescriptor propertyON-  OT {} -> SomeDescriptor propertyOT-  PB {} -> SomeDescriptor propertyPB-  PC {} -> SomeDescriptor propertyPC-  PW {} -> SomeDescriptor propertyPW-  RE {} -> SomeDescriptor propertyRE-  RO {} -> SomeDescriptor propertyRO-  RU {} -> SomeDescriptor propertyRU-  SO {} -> SomeDescriptor propertySO-  TM {} -> SomeDescriptor propertyTM-  US {} -> SomeDescriptor propertyUS-  WR {} -> SomeDescriptor propertyWR-  WT {} -> SomeDescriptor propertyWT--  VW {} -> SomeDescriptor propertyVW--  UnknownProperty name _ -> SomeDescriptor $ propertyUnknown name--instance Descriptor Property where-  propertyName = propertyName . propertyInfo-  propertyType = propertyType . propertyInfo-  propertyInherited = propertyInherited . propertyInfo-  propertyPredicate = propertyPredicate . propertyInfo-  propertyValueParser = propertyValueParser . propertyInfo-  propertyValueRenderer = propertyValueRenderer . propertyInfo-  propertyValueRendererPretty = propertyValueRendererPretty . propertyInfo--descriptorsByName :: Map String SomeDescriptor-descriptorsByName = Map.fromList $ map (propertyName &&& id) allDescriptors--descriptorForName :: String -> SomeDescriptor-descriptorForName name = fromMaybe (SomeDescriptor $ propertyUnknown name) $ descriptorForName' name--descriptorForName' :: String -> Maybe SomeDescriptor-descriptorForName' = flip Map.lookup descriptorsByName---- | Returns the descriptor for a mark.-markProperty :: Mark -> ValuedPropertyInfo CoordList-markProperty MarkCircle = propertyCR-markProperty MarkSelected = propertySL-markProperty MarkSquare = propertySQ-markProperty MarkTriangle = propertyTR-markProperty MarkX = propertyMA

@@ -1,275 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.---- | Parsers of property values.------ Import "Game.Goatee.Sgf.Property" rather than importing this module.-module Game.Goatee.Sgf.Property.Parser (-  colorParser,-  coordElistParser,-  coordListParser,-  coordPairListParser,-  doubleParser,-  gameResultParser,-  labelListParser,-  moveParser,-  noneParser,-  integralParser,-  realParser,-  rulesetParser,-  simpleTextPairParser,-  simpleTextParser,-  sizeParser,-  textParser,-  unknownPropertyParser,-  variationModeParser,-  -- * Exposed for testing-  compose,-  line,-  simpleText,-  text,-  ) where--import Control.Applicative ((<$), (<$>), (<*), (<*>), (*>))-import Control.Monad (when)-import Data.Char (isUpper, ord)-import Data.Maybe (catMaybes)-import Data.Monoid (Monoid, mappend, mconcat, mempty)-import Game.Goatee.Sgf.Types-import Text.ParserCombinators.Parsec (-  (<?>), (<|>), Parser,-  anyChar, char, choice, digit, eof, many, many1,-  noneOf, oneOf, option, parse, space, spaces, string,-  try, unexpected,-  )--{-# ANN module "HLint: ignore Reduce duplication" #-}---- Internal parser builders not corresponding to any particular value type.---- | A wrapper around 'CoordList' with a 'Monoid' instance used for parsing.--- The monoid does simple concatenation of the single and rectangle lists, so it--- is not appropriate for @CoordList@ proper, as it doesn't do duplicate removal--- between two @CoordList@s.-newtype CoordListMonoid = CoordListMonoid { runCoordListMonoid :: CoordList }--instance Monoid CoordListMonoid where-  mempty = CoordListMonoid emptyCoordList--  mappend (CoordListMonoid x) (CoordListMonoid y) =-    CoordListMonoid $ coords' (coordListSingles x ++ coordListSingles y)-                              (coordListRects x ++ coordListRects y)--single :: Parser a -> Parser a-single valueParser = char '[' *> valueParser <* char ']'--compose :: Parser a -> Parser b -> Parser (a, b)-compose first second = do-  x <- first-  char ':'-  y <- second-  return (x, y)--line :: Parser Int-line = toLine <$> line' <?> "line"-  where line' = oneOf $ ['a'..'z'] ++ ['A'..'Z']-        toLine c = if isUpper c-                   then ord c - ord 'A' + 26-                   else ord c - ord 'a'--listOf :: Parser a -> Parser [a]-listOf valueParser = many1 (single valueParser <* spaces)--number :: Parser (String, Bool)-number = do-  sign <- "-" <$ char '-' <|>-          "" <$ char '+' <|>-          return ""-  digits <- many1 digit-  return (sign ++ digits, not $ null sign)---- Public parsers.--colorParser :: Parser Color-colorParser = single color <?> "color"--color :: Parser Color-color = choice [Black <$ char 'B',-                White <$ char 'W']--coord :: Parser Coord-coord = (,) <$> line <*> line--coordElistParser :: Parser CoordList-coordElistParser =-  try (emptyCoordList <$ string "[]") <|>-  coordListParser <?>-  "list of points or empty"--coordListParser :: Parser CoordList-coordListParser =-  runCoordListMonoid . mconcat . map CoordListMonoid <$> listOf coordListEntry <?>-  "list of points"-  where coordListEntry = do x0 <- line-                            y0 <- line-                            choice [do char ':'-                                       x1 <- line-                                       y1 <- line-                                       return $ coordR ((x0, y0), (x1, y1)),-                                    return $ coord1 (x0, y0)]-        coordR rect = coords' [] [rect]--coordPairListParser :: Parser [(Coord, Coord)]-coordPairListParser = listOf coordPair <?> "list of point pairs"-  where coordPair = do-          x0 <- line-          y0 <- line-          char ':'-          x1 <- line-          y1 <- line-          return ((x0, y0), (x1, y1))--doubleParser :: Parser DoubleValue-doubleParser =-  single (Double1 <$ char '1' <|>-          Double2 <$ char '2') <?>-  "double"--gameResultParser :: Parser GameResult-gameResultParser = single (parseGameResult <$> simpleText False) <?> "game result"-  where parseGameResult text = case fromSimpleText text of-          "0" -> GameResultDraw-          "Draw" -> GameResultDraw-          "Void" -> GameResultVoid-          "?" -> GameResultUnknown-          rawText -> case parse gameResultWin "<game result win>" rawText of-            Left _ -> GameResultOther text-            Right win -> win--gameResultWin :: Parser GameResult-gameResultWin = GameResultWin <$> color <* char '+' <*> winReason <* eof--winReason :: Parser WinReason-winReason =-  WinByScore <$> try real <|>-  WinByResignation <$ try (string "Resign") <|>-  WinByResignation <$ try (string "R") <|>-  WinByTime <$ try (string "Time") <|>-  WinByTime <$ try (string "T") <|>-  WinByForfeit <$ try (string "Forfeit") <|>-  WinByForfeit <$ try (string "F")--labelListParser :: Parser [(Coord, SimpleText)]-labelListParser =-  listOf (compose coord $ simpleText True) <?> "list of points and labels"--moveParser :: Parser (Maybe Coord)-moveParser =-  char '[' *> (Nothing <$ char ']' <|> Just <$> coord <* char ']') <?>-  "move (point or pass)"--noneParser :: Parser ()-noneParser = () <$ string "[]" <?> "none"---- This is what the SGF spec calls the Number type, i.e. a signed integer.-integralParser :: (Integral a, Read a) => Parser a-integralParser = single integral <?> "integer"--integral :: (Integral a, Read a) => Parser a-integral = read . fst <$> number--realParser :: Parser RealValue-realParser = single real <?> "real"--real :: Parser RealValue-real = do-  (whole, isNegative) <- number-  let wholePart = toRational (read whole :: Integer)-  -- Try to read a fractional part of the number.-  -- If we fail, just return the whole part.-  option wholePart $ try $ do-    fractionalStr <- char '.' *> many1 digit-    let fractionalPart = toRational (read fractionalStr) / 10 ^ length fractionalStr-    return $ (if isNegative then (-) else (+)) wholePart fractionalPart--rulesetParser :: Parser Ruleset-rulesetParser =-  single (toRuleset . fromSimpleText <$> simpleText False) <?> "ruleset"--simpleTextPairParser :: Parser (SimpleText, SimpleText)-simpleTextPairParser = single (compose composedText composedText) <?> "pair of simple texts"-  where composedText = simpleText True---- | A parser for SGF SimpleText property values.-simpleTextParser :: Parser SimpleText-simpleTextParser = single (simpleText False) <?> "simple text"--simpleText :: Bool -> Parser SimpleText-simpleText isComposed = toSimpleText <$> text isComposed--sizeParser :: Parser (Int, Int)-sizeParser =-  (do char '['-      width <- integral-      height <- choice [width <$ char ']',-                        do char ':'-                           height <- integral-                           char ']'-                           -- TODO We should warn here rather than aborting.-                           when (width == height) $-                             fail $ show width ++ "x" ++ show height ++ " square board " ++-                             " dimensions should be specified with a single number."-                           return height]-      when (width < 1 || width > boardSizeMax ||-            height < 1 || height > boardSizeMax) $-        fail $ show width ++ "x" ++ show height ++ " board dimensions are invalid.  " ++-        "Each dimension must be between 1 and 52 inclusive."-      return (width, height)) <?>-  "board size (width or width:height)"--textParser :: Parser Text-textParser = single (toText <$> text False) <?> "text"---- | A parser for SGF text property values.  Its argument should be true if the--- text is inside of a composed property value, so @\':\'@ should terminate the--- value in addition to @']'@.-text :: Bool -> Parser String-text isComposed = catMaybes <$> many textChar'-  where textChar' = textChar (if isComposed then ":]\\" else "]\\")--textChar :: String -> Parser (Maybe Char)-textChar specialChars =-  choice [Just <$> char '\n',-          Just ' ' <$ space,-          try (char '\\' *> (Nothing <$ char '\n' <|>-                             Just <$> anyChar)),-          Just <$> noneOf specialChars]--unknownPropertyParser :: Parser UnknownPropertyValue-unknownPropertyParser =-  single (toUnknownPropertyValue <$> text False) <?>-  "unknown property value"--variationModeParser :: Parser VariationMode-variationModeParser = single variationMode <?> "variation mode"--variationMode :: Parser VariationMode-variationMode = do-  value <- integral-  case toVariationMode value of-    Just mode -> return mode-    Nothing -> unexpected $ "variation mode " ++ show value

@@ -1,326 +0,0 @@--- This file is part of Goatee.------ Copyright 2014 Bryan Gardiner------ Goatee is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero General Public License as published by--- the Free Software Foundation, either version 3 of the License, or--- (at your option) any later version.------ Goatee is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE CPP #-}---- | Renderers of property values.------ Import "Game.Goatee.Sgf.Property" rather than importing this module.-module Game.Goatee.Sgf.Property.Renderer (-  renderColorBracketed,-  renderColorPretty,-  renderCoordElistBracketed,-  renderCoordElistPretty,-  renderCoordListBracketed,-  renderCoordListPretty,-  renderCoordPairListBracketed,-  renderCoordPairListPretty,-  renderDoubleBracketed,-  renderDoublePretty,-  renderGameResultBracketed,-  renderGameResultPretty,-  renderIntegralBracketed,-  renderIntegralPretty,-  renderLabelListBracketed,-  renderLabelListPretty,-  renderMoveBracketed,-  renderMovePretty,-  renderNoneBracketed,-  renderNonePretty,-  renderRealBracketed,-  renderRealPretty,-  renderRulesetBracketed,-  renderRulesetPretty,-  renderSimpleTextBracketed,-  renderSimpleTextPairBracketed,-  renderSimpleTextPairPretty,-  renderSimpleTextPretty,-  renderSizeBracketed,-  renderSizePretty,-  renderTextBracketed,-  renderTextPretty,-  renderUnknownPropertyBracketed,-  renderUnknownPropertyPretty,-  renderVariationModeBracketed,-  renderVariationModePretty,-  ) where--import Control.Monad (forM_, when)-#if MIN_VERSION_mtl(2,2,1)-import Control.Monad.Except (throwError)-#else-import Control.Monad.Error (throwError)-#endif-import Control.Monad.Writer (tell)-import Data.Char (chr, ord)-import Data.List (intersperse)-import Game.Goatee.Sgf.Renderer-import Game.Goatee.Sgf.Types--{-# ANN module "HLint: ignore Use <$>" #-}---- Internal renderers not corresponding to any particular value type.--bracketed :: Render () -> Render ()-bracketed x = tell "[" >> x >> tell "]"--renderLine :: Int -> Render ()-renderLine = rendererOf "line" $ \x ->-  if x >= 0 && x < 52-  then tell [chr $ x + (if x < 26 then ord 'a' else ord 'A' - 26)]-  else throwError $ "renderLine: Index not in [0, 52): " ++ show x--renderCoord :: Coord -> Render ()-renderCoord = rendererOf "coord" $ \(x, y) -> renderLine x >> renderLine y--renderCoordBracketed :: Coord -> Render ()-renderCoordBracketed = fmap bracketed renderCoord--renderCoordPretty :: Coord -> Render ()-renderCoordPretty = rendererOf "coord pretty" $ \(x, y) ->-  mapM_ tell ["(", show x, ", ", show y, ")"]--renderCoordPairPretty :: (Coord, Coord) -> Render ()-renderCoordPairPretty = rendererOf "coord pair pretty" $ \(a, b) -> do-  renderCoordPretty a-  tell "-"-  renderCoordPretty b--renderCoordPair :: (Coord, Coord) -> Render ()-renderCoordPair = rendererOf "coord pair" $ \(a, b) ->-  renderCoord a >> tell ":" >> renderCoord b--renderCoordPairBracketed :: (Coord, Coord) -> Render ()-renderCoordPairBracketed = fmap bracketed renderCoordPair--renderShowable :: Show a => a -> Render ()-renderShowable = tell . show--renderStringlike :: (Show a, Stringlike a) => Bool -> a -> Render ()-renderStringlike isComposed =-  rendererOf (if isComposed then "composed stringlike" else "stringlike") $ \str ->-  tell $ escape $ sgfToString str-  where escape [] = []-        escape (first:rest) | first `elem` specialChars = '\\':first:escape rest-                            | otherwise = first:escape rest-        -- TODO Deduplicate these characters with the parser:-        specialChars = if isComposed then ":]\\" else "]\\"---- Note that unlike the serialized SGF version, we don't care about escaping--- characters in composed strings.-renderStringlikePretty :: (Show a, Stringlike a) => a -> Render ()-renderStringlikePretty = rendererOf "stringlike pretty" $ tell . sgfToString---- Public renderers.--renderColorBracketed :: Color -> Render ()-renderColorBracketed color = bracketed $ tell $ case color of-  Black -> "[B]"-  White -> "[W]"--renderColorPretty :: Color -> Render ()-renderColorPretty Black = tell "Black"-renderColorPretty White = tell "White"--renderCoordElistBracketed :: CoordList -> Render ()-renderCoordElistBracketed = rendererOf "coord elist bracketed" $ \list ->-  if null $ expandCoordList list-  then tell "[]"-  else renderCoordListNonempty list--renderCoordElistPretty :: CoordList -> Render ()-renderCoordElistPretty = rendererOf "coord elist pretty" $ \list ->-  if null $ expandCoordList list-  then tell "empty"-  else renderCoordListNonemptyPretty list--renderCoordListBracketed :: CoordList -> Render ()-renderCoordListBracketed = rendererOf "coord list bracketed" $ \list ->-  if null $ expandCoordList list-  then throwError "renderCoordListBracketed: Unexpected empty CoordList."-  else renderCoordListNonempty list--renderCoordListPretty :: CoordList -> Render ()-renderCoordListPretty = rendererOf "coord list pretty" $ \list ->-  if null $ expandCoordList list-  then throwError "renderCoordListPretty: Unexpected empty CoordList."-  else renderCoordListNonemptyPretty list--renderCoordListNonempty :: CoordList -> Render ()-renderCoordListNonempty = rendererOf "coord list nonempty" $ \list -> do-  mapM_ renderCoordPairBracketed $ coordListRects list-  mapM_ renderCoordBracketed $ coordListSingles list--renderCoordListNonemptyPretty :: CoordList -> Render ()-renderCoordListNonemptyPretty = rendererOf "coord list nonempty pretty" $ \list ->-  sequence_ $ intersperse (tell ", ") $-  map renderCoordPairPretty (coordListRects list) ++-  map renderCoordPretty (coordListSingles list)--renderCoordPairListBracketed :: [(Coord, Coord)] -> Render ()-renderCoordPairListBracketed = rendererOf "coord pair list bracketed" $ \list ->-  if null list-  then throwError "renderCoordPairListBracketed: Unexpected empty list."-  else mapM_ renderCoordPairBracketed list--renderCoordPairListPretty :: [(Coord, Coord)] -> Render ()-renderCoordPairListPretty list =-  if null list-  then throwError "renderCoordPairListPretty: Unexpected empty list."-  else sequence_ $ intersperse (tell ", ") $ map renderCoordPairPretty list--renderDoubleBracketed :: DoubleValue -> Render ()-renderDoubleBracketed = fmap bracketed $ rendererOf "double" $ \double -> tell $ case double of-  Double1 -> "1"-  Double2 -> "2"--renderDoublePretty :: DoubleValue -> Render ()-renderDoublePretty = rendererOf "double pretty" $ tell . \double -> case double of-  Double1 -> "1"-  Double2 -> "2"--renderGameResultBracketed :: GameResult -> Render ()-renderGameResultBracketed = fmap bracketed $ rendererOf "game result" $ \result -> case result of-  GameResultWin color reason ->-    tell $-    (case color of { Black -> 'B'; White -> 'W' }) : '+' :-    (case reason of-        WinByScore diff -> show diff-        WinByResignation -> "R"-        WinByTime -> "T"-        WinByForfeit -> "F")-  GameResultDraw -> tell "0"-  GameResultVoid -> tell "Void"-  GameResultUnknown -> tell "?"-  GameResultOther text -> renderStringlike False text--renderGameResultPretty :: GameResult -> Render ()-renderGameResultPretty = rendererOf "game result pretty" $ \result -> case result of-  GameResultWin color reason ->-    tell $-    (case color of { Black -> 'B'; White -> 'W' }) : '+' :-    (case reason of-        WinByScore diff -> show diff-        WinByResignation -> "Resign"-        WinByTime -> "Time"-        WinByForfeit -> "Forfeit")-  GameResultDraw -> tell "Draw"-  GameResultVoid -> tell "Void"-  GameResultUnknown -> tell "Unknown"-  GameResultOther text -> renderStringlikePretty text--renderIntegralBracketed :: (Integral a, Show a) => a -> Render ()-renderIntegralBracketed = bracketed . rendererOf "integral" renderShowable--renderIntegralPretty :: (Integral a, Show a) => a -> Render ()-renderIntegralPretty = rendererOf "integral pretty" renderShowable--renderLabelListBracketed :: [(Coord, SimpleText)] -> Render ()-renderLabelListBracketed = rendererOf "label list" $ \list ->-  if null list-  then throwError "renderLabelListBracketed: Unexpected empty list."-  else forM_ list $ bracketed . \(coord, text) -> do-    renderCoord coord-    tell ":"-    renderStringlike True text--renderLabelListPretty :: [(Coord, SimpleText)] -> Render ()-renderLabelListPretty = rendererOf "label list pretty" $ \list ->-  if null list-  then throwError "renderLabelListPretty: Unexpected empty list."-  else sequence_ $ intersperse (tell ", ") $-       map (\(coord, text) -> do-               renderCoordPretty coord-               tell ":"-               renderStringlikePretty text)-       list--renderMoveBracketed :: Maybe Coord -> Render ()-renderMoveBracketed = rendererOf "move bracketed" $ maybe (tell "[]") renderCoordBracketed--renderMovePretty :: Maybe Coord -> Render ()-renderMovePretty = rendererOf "move pretty" $ maybe (tell "Pass") renderCoordPretty--renderNoneBracketed :: () -> Render ()-renderNoneBracketed = rendererOf "none bracketed" $ tell . const "[]"--renderNonePretty :: () -> Render ()-renderNonePretty = rendererOf "none pretty" $ tell . const ""--renderRealBracketed :: RealValue -> Render ()-renderRealBracketed = fmap bracketed $ rendererOf "real" $ renderShowable . fromRational--renderRealPretty :: RealValue -> Render ()-renderRealPretty = rendererOf "real pretty" renderShowable--renderRulesetBracketed :: Ruleset -> Render ()-renderRulesetBracketed = fmap bracketed $ rendererOf "ruleset" $ tell . fromRuleset--renderRulesetPretty :: Ruleset -> Render ()-renderRulesetPretty = rendererOf "ruleset pretty" $ tell . fromRuleset--renderSimpleTextPairBracketed :: (SimpleText, SimpleText) -> Render ()-renderSimpleTextPairBracketed = fmap bracketed $ rendererOf "simple text pair" $ \(a, b) -> do-  renderStringlike True a-  tell ":"-  renderStringlike True b--renderSimpleTextPairPretty :: (SimpleText, SimpleText) -> Render ()-renderSimpleTextPairPretty = fmap bracketed $ rendererOf "simple text pair pretty" $ \(a, b) -> do-  renderStringlike True a-  tell " "-  renderStringlike True b--renderSimpleTextBracketed :: SimpleText -> Render ()-renderSimpleTextBracketed = fmap bracketed $ rendererOf "simple text" $ renderStringlike False--renderSimpleTextPretty :: SimpleText -> Render ()-renderSimpleTextPretty = fmap bracketed $ rendererOf "simple text pretty" $ tell . fromSimpleText--renderSizeBracketed :: (Int, Int) -> Render ()-renderSizeBracketed = fmap bracketed $ rendererOf "size" $ \(x, y) -> do-  tell $ show x-  when (x /= y) $ tell $ ':' : show y--renderSizePretty :: (Int, Int) -> Render ()-renderSizePretty = rendererOf "size pretty" renderCoordPretty--renderTextBracketed :: Text -> Render ()-renderTextBracketed = fmap bracketed $ rendererOf "text" $ renderStringlike False--renderTextPretty :: Text -> Render ()-renderTextPretty = fmap bracketed $ rendererOf "text pretty" $ tell . fromText--renderUnknownPropertyBracketed :: UnknownPropertyValue -> Render ()-renderUnknownPropertyBracketed =-  fmap bracketed $ rendererOf "unknown property" $ renderStringlike False--renderUnknownPropertyPretty :: UnknownPropertyValue -> Render ()-renderUnknownPropertyPretty =-  rendererOf "unknown property pretty" $ tell . fromUnknownPropertyValue--renderVariationModeBracketed :: VariationMode -> Render ()-renderVariationModeBracketed =-  fmap bracketed $ rendererOf "variation mode" $ tell . show . fromVariationMode--renderVariationModePretty :: VariationMode -> Render ()-renderVariationModePretty = rendererOf "variation mode pretty" $ \(VariationMode source markup) ->-  tell $-  (case source of-      ShowChildVariations -> "Children"-      ShowCurrentVariations -> "Current") ++ " " ++-  (if markup then "Shown" else "Hidden")