sgf (empty) → 0.1
raw patch · 9 files changed
+1860/−0 lines, 9 filesdep +basedep +containersdep +encodingsetup-changed
Dependencies added: base, containers, encoding, extensible-exceptions, mtl, parsec, split, time
Files
- Data/SGF.hs +169/−0
- Data/SGF/Parse.hs +503/−0
- Data/SGF/Parse/Encodings.hs +49/−0
- Data/SGF/Parse/Raw.hs +87/−0
- Data/SGF/Parse/Util.hs +266/−0
- Data/SGF/Types.hs +707/−0
- LICENSE +30/−0
- Setup.lhs +4/−0
- sgf.cabal +45/−0
+ Data/SGF.hs view
@@ -0,0 +1,169 @@+-- boilerplate {{{+{-|+This is a parser for the go\/igo\/weiqi\/baduk fragment of the SGF format.+Encodings latin-1, utf-8, and ascii are supported, and the parser strives to be+robust to minor errors, especially those made by the most common SGF editors.+There are plans to support other games and pretty-printing in future releases.+-}+module Data.SGF (+ module Data.SGF.Types,+ module Data.SGF.Parse,+ module Data.Word,+ module Text.ParserCombinators.Parsec+ -- * Overview of SGF+ -- $sgf++ -- * Overview of the library+ -- $library++ -- * Example usage+ -- $example+) where++import Data.SGF.Types+import Data.SGF.Parse (collection)+import Data.Word+import Text.ParserCombinators.Parsec (runParser)++-- TODO:+-- * support parsing from ByteString, then take the "unpack" out of "parse" below+-- * support the rest of the SGF format ;-)+-- * clean up exports and imports as much as possible+-- }}}+-- sgf {{{+{- $sgf+The Smart Games Format (SGF) is a rich way of storing records of games, along+with metadata about the games. The format is arranged in a tree structure; to+a first approximation, each node in the tree corresponds to a move in one of+the games being recorded.++There are a few ways this first approximation needs to be corrected:++1. It is actually a non-empty forest: there may be several trees, each of which+is totally independent. In particular, different trees may be recording not+only different games, but even different game /types/: the file may contain+records of both go and chess games, for example. Each root has games of only a+single type, but there may be many actual games of that type. There is no+restriction that different roots use different game types. (Luckily, most+real-world files have have a single root and record a single game.)++2. A tree may encode variations within a single game. When there are many+branches in a tree, there may or may not be an indication of which are separate+games and which are variations.++3. Each node may additionally record metadata. This metadata may be about the+game (for example, the names of the players), about the position (for example,+that the whole board favors the black player), or about the move (for example,+that the move is good for the black player).++4. Some nodes may record a modification of the game board rather than a move in+the game. This is used especially for collections of problems, to record only+parts of a game (i.e. to set up the initial position), and to handle other+strange situations.++This module provides a way to parse files in the SGF format and traverse game+forests. In addition to specifying a file format, the SGF specification talks+about the behavior of applications that read and write SGF files. Wherever+possible, these behaviors are enforced or encouraged via types. It is+considered a bug if a required behavior is impossible, if an unrecommended+behavior is easy, or if a prohibited behavior is allowed and the documentation+does not have warnings in appropriate places.+-}+-- }}}+-- library {{{+{- $library+The two basic starting points are 'collection' and 'Collection'.++The former is a Parsec-3 parser for consuming entire files in the SGF format.+It additionally reports some warnings for the most common and easily-corrected+errors in files, but these can generally be safely ignored.++The latter is a largish type which is intended to be inhabitable by all and+only the valid SGF trees. There are a few places where we sacrifice this+property in the name of convenience; wherever possible, the documentation+states any restrictions on values that are not reflected by the type system.+-}+-- }}}+-- example {{{+{- $example+In this section, we develop a short program to print, in human-readable form,+the moves of the main line of a game of go. We will assume that we are given+the contents of an SGF file on @stdin@, that the file only records one game on+a standard size board, that the file doesn't do anything fancy (like change the+move number in the middle of the game), and that any node without a valid move+is the end of the game. (This saves us a lot of error-checking that would just+obscure the idea.)++First, some boring stuff.++> import Data.SGF+> import Data.ByteString (ByteString, getContents, unpack)+> import Data.Tree+> import Data.List hiding ((!!))+> import Prelude hiding ((!!), getContents)+>+> (!!) = genericIndex++Now we'll extract the 'TreeGo' representing the game. As suggested in the+overview section, we'll use the 'collection' parser.++> grabTree :: [Word8] -> TreeGo+> grabTree s = case runParser collection () "stdin" s of+> Right ([Game { tree = TreeGo t }], _) -> t++We're already assuming huge swathes of things about the input; this is a+horribly partial function. But let's continue. The next step is to extract+the moves from the main line. The main line is specified to be the first child+at each possible junction, so this is not too tricky: the 'levels' function of+'Data.Tree' (together with a 'transpose') will flatten the game tree in just+the right way that the first element will be the main line.++The one thing we will watch out for is that games of go often begin with one+setup node to give the handicap stones, which we want to skip. Actually, for+simplicity, we'll just skip every single setup node. Setup nodes are signaled+by via the 'action' field of 'GameNode's: if this field is a 'Left', then it is+a setup node, and otherwise it is a move node.++> grabMoves :: TreeGo -> [MoveGo]+> grabMoves n = [move | Right Move { move = Just (color, move) } <- mainLine]+> where mainLine = map action . head . transpose . levels $ n++Let's wrap these functions up:++> parse :: ByteString -> [MoveGo]+> parse = grabMoves . grabTree . unpack++Now that we have the moves, we need a way to show them. In go, it's standard+practice to give coordinates as a single upper-case letter followed by a+number. To avoid confusion, the letter \'I\' is skipped as a coordinate, since+it looks much like a one in some fonts.++> coordinates :: [Char]+> coordinates = delete 'I' ['A'..'Z']+>+> showPoint :: Point -> String+> showPoint (x, y) = coordinates !! x : show (19 - y)++We'll pad moves out to four spaces, and show them in pairs.++> pad :: String -> String+> pad s = s ++ replicate (4 - length s) ' '+>+> showMove :: MoveGo -> String+> showMove Pass = "pass"+> showMove (Play p) = pad (showPoint p)+>+> showMoves :: [MoveGo] -> String+> showMoves = unlines . showMoves' 1 where+> showMoves' n [ ] = []+> showMoves' n [m] = unwords [show n ++ ".", showMove m] : []+> showMoves' n (m:m':ms) = unwords [show n ++ ".", showMove m, showMove m'] : showMoves' (n+2) ms++Finally, we just need some plumbing:++> main :: IO ()+> main = putStr . showMoves . parse =<< getContents++And there we have it: a complete program to parse an SGF file, extract the moves, and print them!+-}+-- }}}
+ Data/SGF/Parse.hs view
@@ -0,0 +1,503 @@+-- TODO: check that every occurrence of "die" should really be a death, and not just a "fix-it-up-and-warn"+-- boilerplate {{{+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}+module Data.SGF.Parse (+ collection,+ clipDate,+ PropertyType(..),+ properties,+ extraProperties,+ Property(..),+ Warning(..),+ ErrorType(..),+ Error(..)+) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Data.Bits+import Data.Char+import Data.Encoding+import Data.Function+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Ord+import Data.Time.Calendar+import Data.Tree+import Data.Word+import Prelude hiding (round)+import Text.Parsec hiding (newline)+import Text.Parsec.Pos (newPos)++import qualified Data.Map as Map+import qualified Data.Set as Set++import Data.SGF.Parse.Encodings+import Data.SGF.Parse.Raw hiding (collection)+import Data.SGF.Types hiding (Game(..), GameInfo(..), GameNode(..), Setup(..), Move(..))+import Data.SGF.Types (Game(Game), GameNode(GameNode))+import Data.SGF.Parse.Util+import qualified Data.SGF.Parse.Raw as Raw+import qualified Data.SGF.Types as T+-- }}}+-- top level/testing {{{+translate trans state = case runStateT (runWriterT trans) state of+ Left (UnknownError Nothing ) -> fail ""+ Left (UnknownError (Just e)) -> fail e+ Left e -> setPosition (errorPosition e) >> fail (show e)+ Right ((a, warnings), _) -> return (a, warnings)++-- TODO: delete "test"+test = runParser collection () "<interactive>" . map enum++-- |+-- Parse a 'Word8' stream into an SGF collection. A collection is a list of+-- games; the documentation for 'Game' has more details. There are generally+-- two kinds of errors in SGF files: recoverable ones (which will be+-- accumulated in the ['Warning'] return) and unrecoverable ones (which will+-- result in parse errors).+collection :: Stream s m Word8 => ParsecT s u m (Collection, [Warning])+collection = second concat . unzip <$> (mapM (translate gameTree) =<< Raw.collection)+gameTree = do+ hea <- parseHeader+ app <- application hea+ gam <- gameType+ var <- variationType+ siz <- size gam+ fmap (Game app var siz) (parse hea gam siz False)+ where+ parse h g s = case g of+ Go -> fmap TreeGo . nodeGo h s+ Backgammon -> fmap TreeBackgammon . nodeBackgammon h+ LinesOfAction -> fmap TreeLinesOfAction . nodeLinesOfAction h+ Hex -> gameHex h+ Octi -> fmap TreeOcti . nodeOcti h+ other -> fmap (TreeOther other) . nodeOther h+-- }}}+warnAll w ps = mapM_ (\p -> maybe (return ()) (tell . (:[]) . w) =<< consume p) ps+dieEarliest e ps = dieWith e . head . sortBy (comparing position) . catMaybes =<< mapM consume ps+-- game header information {{{+getFormat = do+ prop <- consumeSingle "FF"+ ff <- maybe (return 1) number prop+ when (ff /= 4) (dieWithPos FormatUnsupported (maybe (newPos "FF_missing" 1 1) position prop))+ return ff++getEncoding = do+ ws <- consumeSingle "CA"+ case maybe [encodingFromString "latin1"] (guessEncoding . head . values) ws of+ [encoding] -> return encoding+ [] -> dieWithJust UnknownEncoding ws+ _ -> dieWithJust AmbiguousEncoding ws -- pretty much guaranteed not to happen++parseHeader = liftM2 Header getFormat getEncoding++application = flip transMap "AP" . join compose . simple+gameType = do+ property <- consumeSingle "GM"+ gameType <- maybe (return 1) number property+ if enum (minBound :: GameType) <= gameType && gameType <= enum (maxBound :: GameType)+ then return (enum gameType)+ else dieWithJust OutOfBounds property+variationType = transMap (\p -> number p >>= variationType' p) "ST" where+ variationType' property 0 = return (T.Children, True )+ variationType' property 1 = return (T.Siblings, True )+ variationType' property 2 = return (T.Children, False)+ variationType' property 3 = return (T.Siblings, False)+ variationType' property _ = dieWith OutOfBounds property+size gameType = do+ property <- consumeSingle "SZ"+ case property of+ Nothing -> return $ lookup gameType defaultSize+ Just p -> if enum ':' `elem` head (values p)+ then do+ (m, n) <- join compose number p+ when (m == n) . tell . return . SquareSizeSpecifiedAsRectangle . position $ p+ checkValidity gameType m n property+ else do+ m <- number p+ checkValidity gameType m m property+ where+ invalid t m n = or [t == Go && (m > 52 || n > 52), m < 1, n < 1]+ checkValidity t m n p = when (invalid t m n) (dieWithJust OutOfBounds p) >> return (Just (m, n))+-- }}}+-- game-info properties {{{+gameInfo header =+ consumeFreeformGameInfo header+ >>= consumeUpdateGameInfo rank (\g v -> g { T.rankBlack = v }) "BR" header+ >>= consumeUpdateGameInfo rank (\g v -> g { T.rankWhite = v }) "WR" header+ >>= consumeUpdateGameInfo round (\g v -> g { T.round = v }) "RO" header+ >>= consumeUpdateGameInfoMaybe result (\g v -> g { T.result = v }) "RE" header+ >>= consumeUpdateGameInfoMaybe date dateUpdate "DT" header+ >>= warnClipDate+ >>= timeLimit++freeformGameInfo = [+ ("AN", T.Annotator ),+ ("BT", T.TeamName Black ),+ ("CP", T.Copyright ),+ ("EV", T.Event ),+ ("GN", T.GameName ),+ ("GC", T.Context ),+ ("ON", T.Opening ),+ ("OT", T.Overtime ),+ ("PB", T.PlayerName Black),+ ("PC", T.Location ),+ ("PW", T.PlayerName White),+ ("SO", T.Source ),+ ("US", T.User ),+ ("WT", T.TeamName White )+ ]+consumeFreeformGameInfo header = fmap gameInfo tagValues where+ (tags, types) = unzip freeformGameInfo+ tagValues = mapM (transMap (simple header)) tags+ gameInfo vals = (\m -> emptyGameInfo { T.freeform = m })+ . Map.fromList . catMaybes+ $ zipWith (fmap . (,)) types vals++consumeUpdateGameInfo = consumeUpdateGameInfoMaybe . (return .)+consumeUpdateGameInfoMaybe fromString update property header gameInfo = do+ maybeProp <- consumeSingle property+ maybeString <- transMap' (simple header) maybeProp+ case (maybeProp, maybeString >>= fromString) of+ (Nothing, _) -> return gameInfo+ (_, Nothing) -> dieWithJust BadlyFormattedValue maybeProp+ (_, v) -> return (update gameInfo v)++abbreviateList xs = xs >>= \(n, v) -> [(n, v), (take 1 n, v)]+-- TODO: can we unify this with the other implementation of reading a rational?+readRational s = liftM3 (\s n d -> s * (fromInteger n + d)) maybeSign maybeNum maybeDen where+ (sign, rest) = span (`elem` "+-") s+ (numerator, rest') = span isDigit rest+ denominator' = drop 1 rest' ++ "0"+ denominator = fromInteger (read denominator') / 10 ^ length denominator'++ maybeSign = lookup sign [("", 1), ("+", 1), ("-", -1)]+ maybeNum = listToMaybe numerator >> return (read numerator)+ maybeDen = guard (take 1 rest' `isPrefixOf` "." && all isDigit denominator') >> return denominator++rank s = fromMaybe (OtherRank s) maybeRanked where+ (rank, rest) = span isDigit s+ (scale, certainty) = span isAlpha rest+ maybeRank = listToMaybe rank >> return (read rank)+ maybeScale = lookup (map toLower scale) scales+ maybeCertainty = lookup certainty certainties+ maybeRanked = liftM3 Ranked maybeRank maybeScale maybeCertainty+ certainties = [("", Nothing), ("?", Just Uncertain), ("*", Just Certain)]+ scales = abbreviateList [("kyu", Kyu), ("dan", Dan), ("pro", Pro)]++result (c:'+':score) = liftM2 Win maybeColor maybeWinType where+ maybeColor = lookup (toLower c) [('b', Black), ('w', White)]+ maybeWinType = lookup (map toLower score) winTypes `mplus` fmap Score (readRational score)+ winTypes = abbreviateList [("", OtherWinType), ("forfeit", Forfeit), ("time", Time), ("resign", Resign)]++result s = lookup (map toLower s) [("0", Draw), ("draw", Draw), ("void", Void), ("?", Unknown)]++timeLimit gameInfo = fmap (\v -> gameInfo { T.timeLimit = v }) (transMap real "TM")++date = expect [] . splitWhen (== ',') where+ expect parsers [] = return []+ expect parsers (pd:pds) = do+ parsed <- msum . sequence ([parseYMD, parseYM, parseY] ++ parsers) . splitWhen (== '-') $ pd+ liftM (parsed:) . ($ pds) $ case parsed of+ Year {} -> expect []+ Month { year = y } -> expect [parseMD y, parseM y]+ Day { year = y, month = m } -> expect [parseMD y, parseD y m]++ ensure p x = guard (p x) >> return x+ hasLength n xs = n >= 0 && hasLength' n xs where+ hasLength' n [] = n == 0+ hasLength' 0 (x:xs) = False+ hasLength' n (x:xs) = hasLength' (n-1) xs+ ensureLength = ensure . hasLength++ parseYMD ss = ensureLength 3 ss >>= \[y, m, d] -> liftM3 Day (checkY y) (checkMD m) (checkMD d)+ parseYM ss = ensureLength 2 ss >>= \[y, m ] -> liftM2 Month (checkY y) (checkMD m)+ parseY ss = ensureLength 1 ss >>= \[y ] -> liftM Year (checkY y)+ parseMD y ss = ensureLength 2 ss >>= \[ m, d] -> liftM2 (Day y) (checkMD m) (checkMD d)+ parseM y ss = ensureLength 1 ss >>= \[ m ] -> liftM (Month y) (checkMD m)+ parseD y m ss = ensureLength 1 ss >>= \[ d] -> liftM (Day y m) (checkMD d)++ checkY y = ensureLength 4 y >>= readM+ checkMD md = ensureLength 2 md >>= readM+ readM = listToMaybe . map fst . filter (null . snd) . reads++-- |+-- Clip to a valid, representable date. Years are clipped to the 0000-9999+-- range; months are clipped to the 1-12 range, and days are clipped to the+-- 1-\<number of days in the given month\> range (accounting for leap years in+-- the case of February).+--+-- If a parsed date is changed by this function, a warning is emitted.+clipDate :: PartialDate -> PartialDate+clipDate (y@Year {}) = Year . min 9999 . max 0 . year $ y+clipDate (Month { year = y, month = m }) = Month {+ year = year . clipDate . Year $ y,+ month = min 12 . max 1 $ m+ }+clipDate (Day { year = y, month = m, day = d }) = let m' = clipDate (Month y m) in Day {+ year = year m', month = month m',+ day = max 1 . min (fromIntegral (gregorianMonthLength (year m') (fromIntegral (month m')))) $ d+ }++warnClipDate gameInfo@(T.GameInfo { T.date = d }) = let d' = Set.map clipDate d in do+ when (d /= d') (tell [InvalidDatesClipped d])+ return gameInfo { T.date = d' }++dateUpdate g v = g { T.date = maybe Set.empty Set.fromList v }++round s = case words s of+ [roundNumber@(_:_)] | all isDigit roundNumber+ -> SimpleRound (read roundNumber)+ [roundNumber@(_:_), '(':roundType] | all isDigit roundNumber && last roundType == ')'+ -> FormattedRound (read roundNumber) (init roundType)+ _ -> OtherRound s+-- }}}+-- move properties {{{+move move = do+ color_ <- mapM has ["B", "W"]+ [number_, overtimeMovesBlack_, overtimeMovesWhite_] <- mapM (transMap number) ["MN", "OB", "OW"]+ [timeBlack_, timeWhite_] <- mapM (transMap real ) ["BL", "WL"]+ let partialMove = emptyMove {+ T.number = number_,+ T.timeBlack = timeBlack_,+ T.timeWhite = timeWhite_,+ T.overtimeMovesBlack = overtimeMovesBlack_,+ T.overtimeMovesWhite = overtimeMovesWhite_+ }+ case color_ of+ [False, False] -> warnAll MovelessAnnotationOmitted ["KO", "BM", "DO", "IT", "TE"] >> return partialMove+ [True , True ] -> dieEarliest ConcurrentBlackAndWhiteMove ["B", "W"]+ [black, white] -> let color = if black then Black else White in do+ Just move <- fmap msum . mapM (transMap move) $ ["B", "W"]+ illegal <- fmap (maybe Possibly (const Definitely)) (transMap none "KO")+ annotations <- mapM has ["BM", "DO", "IT", "TE"]+ quality <- case annotations of+ [False, False, False, False] -> return Nothing+ [True , False, False, False] -> fmap (fmap Bad ) (transMap double "BM")+ [False, False, False, True ] -> fmap (fmap Good) (transMap double "TE")+ [False, True , False, False] -> transMap none "DO" >> return (Just Doubtful )+ [False, False, True , False] -> transMap none "IT" >> return (Just Interesting)+ _ -> dieEarliest ConcurrentAnnotations ["BM", "DO", "IT", "TE"]+ return partialMove { T.move = Just (color, move), T.illegal = illegal, T.quality = quality }+-- }}}+-- setup properties {{{+setupPoint point = do+ points <- mapM (transMapList (listOfPoint point)) ["AB", "AW", "AE"]+ let [addBlack, addWhite, remove] = map Set.fromList points+ allPoints = addBlack `Set.union` addWhite `Set.union` remove+ duplicates = concat points \\ Set.elems allPoints+ addWhite' = addWhite Set.\\ addBlack+ remove' = remove Set.\\ (addBlack `Set.union` addWhite')+ unless (null duplicates) (tell [DuplicateSetupOperationsOmitted duplicates])+ setupFinish addBlack addWhite' remove'++-- note: does not (cannot, in general) check the constraint that addBlack,+-- addWhite, and remove specify disjoint sets of points+-- TODO: what, really, cannot? even if we allow ourselves a class constraint or something?+setupPointStone point stone = do+ addBlack <- transMapList (listOf stone) "AB"+ addWhite <- transMapList (listOf stone) "AW"+ remove <- transMapList (listOfPoint point) "AE"+ setupFinish (Set.fromList addBlack) (Set.fromList addWhite) (Set.fromList remove)++setupFinish addBlack addWhite remove =+ liftM (T.Setup addBlack addWhite remove) (transMap color "PL")+-- }}}+-- none properties {{{+annotation header = do+ comment <- transMap (text header) "C"+ name <- transMap (simple header) "N"+ hotspot <- transMap double "HO"+ value <- transMap real "V"+ judgments' <- mapM (transMap double) ["GW", "GB", "DM", "UC"]+ let judgments = [(j, e) | (j, Just e) <- zip [GoodForWhite ..] judgments']+ tell . map ExtraPositionalJudgmentOmitted . drop 1 $ judgments+ return emptyAnnotation {+ T.comment = comment,+ T.name = name,+ T.hotspot = hotspot,+ T.value = value,+ T.judgment = listToMaybe judgments+ }++addMarks marks (mark, points) = tell warning >> return result where+ (ignored, inserted) = partition (`Map.member` marks) points+ warning = map (DuplicateMarkupOmitted . (,) mark) ignored+ result = marks `Map.union` Map.fromList [(i, mark) | i <- inserted]++markup header point = do+ markedPoints <- mapM (transMapList (listOfPoint point)) ["CR", "MA", "SL", "SQ", "TR"]+ marks <- foldM addMarks Map.empty . zip [Circle ..] $ markedPoints+ labels <- transMapList (listOf (compose point (simple header))) "LB"+ arrows <- consumePointPairs "AR"+ lines <- consumePointPairs "LN"+ dim <- transMapMulti ( listOfPoint point) "DD"+ visible <- transMapMulti (elistOfPoint point) "VW"+ numbering <- transMap number "PM"+ figure <- transMap (figurePTranslator header) "FG"++ tell . map DuplicateLabelOmitted $ labels \\ nubBy (on (==) fst) labels+ tell [UnknownNumberingIgnored n | Just n <- [numbering], n < 0 || n > 2]+ -- TODO: some kind of warning when omitting arrows and lines++ return Markup {+ T.marks = marks,+ T.labels = Map.fromList labels,+ T.arrows = prune arrows,+ T.lines = prune . map canonicalize $ lines,+ T.dim = fmap Set.fromList dim,+ T.visible = fmap Set.fromList visible,+ T.numbering = numbering >>= flip lookup (zip [0..] [Unnumbered ..]),+ T.figure = figure+ }+ where+ consumePointPairs = transMapList (listOf (join compose point))+ prune = Set.fromList . filter (uncurry (/=))+ canonicalize (x, y) = (min x y, max x y)++figurePTranslator header (Property { values = [[]] }) = return DefaultFigure+figurePTranslator header p = do+ (flags, name) <- compose number (simple header) p+ return $ if testBit flags 16+ then NamedDefaultFigure name+ else NamedFigure name (not . testBit flags . fromEnum)+-- }}}+-- known properties list {{{+-- |+-- Types of properties, as given in the SGF specification.+data PropertyType+ = Move+ | Setup+ | Root+ | GameInfo+ | Inherit -- ^+ -- Technically, these properties have type \"none\" and+ -- /attribute/ \"inherit\", but the property index lists them as+ -- properties of type \"inherit\" with no attributes, so we+ -- follow that lead.+ | None+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- |+-- All properties of each type listed in the SGF specification.+properties :: GameType -> PropertyType -> [String]+properties = liftM2 (++) properties' . extraProperties where+ properties' Move = ["B", "KO", "MN", "W", "BM", "DO", "IT", "TE", "BL", "OB", "OW", "WL"]+ properties' Setup = ["AB", "AE", "AW", "PL"]+ properties' Root = ["AP", "CA", "FF", "GM", "ST", "SZ"]+ properties' GameInfo = ["AN", "BR", "BT", "CP", "DT", "EV", "GN", "GC", "ON", "OT", "PB", "PC", "PW", "RE", "RO", "RU", "SO", "TM", "US", "WR", "WT"]+ properties' Inherit = ["DD", "PM", "VW"]+ properties' None = ["C", "DM", "GB", "GW", "HO", "N", "UC", "V", "AR", "CR", "LB", "LN", "MA", "SL", "SQ", "TR", "FG"]+-- }}}+-- game-specific stuff {{{+defaultSize = [+ (Go , (19, 19)),+ (Chess , ( 8, 8)),+ (LinesOfAction , ( 8, 8)),+ (Hex , (11, 11)),+ (Amazons , (10, 10)),+ (Gess , (20, 20))+ ]++ruleSetLookup rs = flip lookup rs . map toLower+ruleSetGo = ruleSetLookup [+ ("aga" , AGA),+ ("goe" , GOE),+ ("chinese" , Chinese),+ ("japanese" , Japanese),+ ("nz" , NewZealand)+ ]+ruleSetBackgammon = ruleSetLookup [+ ("crawford" , Crawford),+ ("crawford:crawfordgame" , CrawfordGame),+ ("jacoby" , Jacoby)+ ]+ruleSetOcti s = case break (== ':') s of+ (major, ':':minors) -> liftM (flip OctiRuleSet (minorVariations minors )) (majorVariation major )+ (majorOrMinors, "") -> liftM (flip OctiRuleSet (Set.empty )) (majorVariation majorOrMinors)+ `mplus` return (OctiRuleSet Full (minorVariations majorOrMinors))+ where+ majorVariation = ruleSetLookup [("full", Full), ("fast", Fast), ("kids", Kids)]+ minorVariation s = fromMaybe (OtherMinorVariation s) . ruleSetLookup [("edgeless", Edgeless), ("superprong", Superprong)] $ s+ minorVariations = Set.fromList . map minorVariation . splitWhen (== ',')++ruleSet read maybeDefault header = do+ maybeRulesetString <- transMap (simple header) "RU"+ return $ case (maybeRulesetString, maybeRulesetString >>= read) of+ (Nothing, _ ) -> fmap Known maybeDefault+ (Just s , Nothing) -> Just (OtherRuleSet s)+ (_ , Just rs) -> Just (Known rs)++ruleSetDefault = ruleSet (const Nothing) Nothing++-- |+-- Just the properties associated with specific games.+extraProperties :: GameType -> PropertyType -> [String]+extraProperties Go GameInfo = ["HA", "KM"]+extraProperties Go None = ["TB", "TW"]+extraProperties Backgammon Setup = ["CO", "CV", "DI"]+extraProperties Backgammon GameInfo = ["MI", "RE", "RU"]+extraProperties LinesOfAction GameInfo = ["IP", "IY", "SU"]+extraProperties LinesOfAction None = ["AS", "SE"]+extraProperties Hex Root = ["IS"]+extraProperties Hex GameInfo = ["IP"]+extraProperties Amazons Setup = ["AA"]+extraProperties Octi Setup = ["RP"]+extraProperties Octi GameInfo = ["BO", "WO", "NP", "NR", "NS"]+extraProperties Octi None = ["AS", "CS", "MS", "SS", "TS"]+extraProperties _ _ = []++gameInfoGo = liftM2 GameInfoGo (transMap number "HA") (transMap real "KM")++pointGo (Property { values = [[x, y]] }) | valid x && valid y = return (translate x, translate y)+ where+ valid x = (enum 'a' <= x && x <= enum 'z') || (enum 'A' <= x && x <= enum 'Z')+ translate x = enum x - enum (if x < enum 'a' then 'A' else 'a')+pointGo p = dieWith BadlyFormattedValue p++moveGo _ (Property { values = [[]] }) = return Pass+moveGo (Just (w, h)) p = pointGo p >>= \v@(x, y) -> return $ if x >= w || y >= h then Pass else Play v+moveGo _ p = fmap Play (pointGo p)++annotationGo = do+ territories <- mapM (transMap (elistOfPoint pointGo)) ["TB", "TW"]+ return . Map.fromList $ [(c, Set.fromList t) | (c, Just t) <- zip [Black, White] territories]++gameHex header seenGameInfo = fmap (TreeHex []) (nodeHex header seenGameInfo)++nodeGo header size seenGameInfo = do+ [hasGameInfo, hasRoot, hasSetup, hasMove] <- mapM (hasAny . properties Go) [GameInfo, Root, Setup, Move]+ let setGameInfo = hasGameInfo && not seenGameInfo+ duplicateGameInfo = hasGameInfo && seenGameInfo+ when (hasSetup && hasMove) dieSetupAndMove+ when duplicateGameInfo warnGameInfo+ when hasRoot warnRoot++ mGameInfo <- liftM (\x -> guard setGameInfo >> Just x) (gameInfo header)+ otherGameInfo <- gameInfoGo+ ruleSet_ <- ruleSet ruleSetGo Nothing header+ action_ <- if hasMove then liftM Right $ move (moveGo size) else liftM Left $ setupPoint pointGo+ annotation_ <- annotation header+ otherAnnotation <- annotationGo+ markup_ <- markup header pointGo+ unknown_ <- unknownProperties+ children <- gets subForest >>= mapM (\s -> put s >> nodeGo header size (seenGameInfo || hasGameInfo))++ return (Node (GameNode (fmap (\gi -> gi { T.ruleSet = ruleSet_, T.otherGameInfo = otherGameInfo }) mGameInfo) action_ annotation_ { T.otherAnnotation = otherAnnotation } markup_ unknown_) children)+ where+ dieSetupAndMove = dieEarliest ConcurrentMoveAndSetup (properties Go =<< [Setup, Move])+ warnGameInfo = warnAll ExtraGameInfoOmitted (properties Go GameInfo)+ warnRoot = warnAll NestedRootPropertyOmitted (properties Go Root)++nodeBackgammon = nodeOther -- TODO+nodeLinesOfAction = nodeOther -- TODO+nodeHex = nodeOther -- TODO+nodeOcti = nodeOther -- TODO+nodeOther header seenGameInfo = return (Node emptyGameNode []) -- TODO+-- }}}
+ Data/SGF/Parse/Encodings.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}+module Data.SGF.Parse.Encodings (guessEncoding, decodeWordStringExplicit) where++import Control.Exception.Extensible+import Control.Monad.State+import Control.Throws+import Data.Encoding+import Data.Word++type MyIHateGHC = MyEither DecodingException (String, [Word8])+newtype MyEither a b = MyEither (Either a b) deriving (Throws a)++instance Monad (MyEither a) where+ return = MyEither . Right+ (MyEither (Right x)) >>= f = f x+ (MyEither (Left x)) >>= f = MyEither (Left x)++instance ByteSource (StateT [Word8] (MyEither DecodingException)) where+ sourceEmpty = gets null+ fetchWord8 = do+ s <- get+ case s of+ [] -> throwException UnexpectedEnd+ c:cs -> put cs >> return c+ fetchAhead m = do+ s <- get+ v <- m+ put s+ return v++-- some ones that we know satisfy our invariant (see SGF.Parse.Raw)+encodings = map encodingFromString ["latin1", "utf-8", "ascii"]+guess ws encoding = case runStateT (decode encoding) ws :: MyIHateGHC of+ (MyEither (Right (s, []))) -> encodingFromStringExplicit s == Just encoding+ _ -> False++-- |+-- Try decoding the given word string with each of the known-good encodings to+-- see if the decoded name names the encoding used to decode. It should be+-- impossible for this to return a list with more than one guess.+guessEncoding :: [Word8] -> [DynEncoding]+guessEncoding ws = filter (guess ws) encodings++-- |+-- A simple wrapper around the encoding package's 'decode' function.+decodeWordStringExplicit :: Encoding e => e -> [Word8] -> Either DecodingException String+decodeWordStringExplicit e ws = case runStateT (decode e) ws :: MyIHateGHC of+ (MyEither (Right (s,_))) -> Right s+ (MyEither (Left ex )) -> Left ex
+ Data/SGF/Parse/Raw.hs view
@@ -0,0 +1,87 @@+-- boilerplate {{{+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+module Data.SGF.Parse.Raw (+ collection,+ Property(..),+ enum+) where++import Control.Applicative hiding (many, (<|>))+import Control.Monad+import Data.Char+import Data.Tree+import Data.Word+import Prelude hiding (lex)+import Text.Parsec (SourcePos(..), incSourceColumn)+import Text.Parsec.Prim+import Text.Parsec.Combinator+-- }}}+data Property = Property {+ position :: SourcePos, -- ^+ -- Currently, this is pretty lame: it doesn't track+ -- line number and character number, only byte+ -- offset from the beginning of the file. This is+ -- because I don't really understand how to+ -- correctly track line number and character number+ -- properly in the face of dynamically changing+ -- encodings, whereas byte number is a totally+ -- braindead statistic to track.+ name :: String, -- ^+ -- The literal name of the property. This is+ -- guaranteed to be a non-empty string of+ -- upper-case ASCII characters.+ values :: [[Word8]] -- ^ The arguments to the property.+} deriving (Eq, Ord, Show)++-- |+-- Handy way to convert known-ASCII characters from 'Word8' to 'Char', among other+-- things.+enum :: (Enum a, Enum b) => a -> b+enum = toEnum . fromEnum+ensure p x = guard (p x) >> return x++satisfy p = tokenPrim+ ((\x -> ['\'', x, '\'']) . enum)+ (\pos _ _ -> incSourceColumn pos 1)+ (ensure p)+satisfyChar = satisfy . (. enum)++anyWord = satisfy (const True)+exactWord = satisfy . (==) . enum+someWord = satisfy . flip elem . map enum+noWord = satisfy . flip notElem . map enum++whitespace = many (satisfyChar isSpace)++-- assumed: the current byte is literally ASCII '\\' iff the current byte is+-- the last byte of the encoding of the actual character '\\' and neither of+-- the bytes that are literally ASCII ']' and ASCII ':' occur after the first+-- byte of any multi-byte encoded character+-- (in particular, UTF-8, ASCII, and ISO 8859-1 satisfy this property)+escapedChar = liftM2 (\x y -> [x, y]) (exactWord '\\') anyWord+unescapedExcept ws = fmap return (noWord ws)+literalTextExcept ws = fmap concat $ many (escapedChar <|> unescapedExcept ws)++property = liftM3 ((. map enum) . Property)+ (getPosition)+ (many1 (satisfyChar (liftM2 (&&) isUpper (< '\128'))))+ (sepEndBy1 (exactWord '[' >> literalTextExcept "]" <* exactWord ']') whitespace)++node = do+ exactWord ';'+ whitespace+ sepEndBy property whitespace++gameTree = do+ exactWord '('+ whitespace+ (node:nodes) <- sepEndBy1 node whitespace+ trees <- sepEndBy gameTree whitespace+ exactWord ')'+ return (Node node (foldr ((return .) . Node) trees nodes))++-- |+-- Parse the tree-structure of an SGF file, but without any knowledge of the+-- semantics of the properties, etc.+collection :: Stream s m Word8 => ParsecT s u m [Tree [Property]]+collection = whitespace >> sepEndBy1 gameTree whitespace <* whitespace <* eof
+ Data/SGF/Parse/Util.hs view
@@ -0,0 +1,266 @@+-- boilerplate {{{+module Data.SGF.Parse.Util where++import Control.Arrow+import Control.Monad.Error hiding (Error(..))+import qualified Control.Monad.Error as Either+import Control.Monad.State hiding (State(..))+import Control.Monad.Writer+import Data.Char+import Data.Encoding+import Data.Function+import Data.Ix+import Data.List+import Data.Maybe+import Data.Map (Map(..), fromList, keys)+import Data.Ord+import Data.Set (Set)+import Data.Tree+import Data.Word+import Text.Parsec hiding (State(..), choice, newline)++import Data.SGF.Parse.Encodings+import Data.SGF.Parse.Raw+import Data.SGF.Types hiding (name)+-- }}}+-- new types {{{+-- Header {{{+data Header = Header {+ format :: Integer,+ encoding :: DynEncoding+}+-- }}}+-- Error {{{+-- |+data ErrorType+ = UnknownEncoding+ | AmbiguousEncoding+ | FormatUnsupported+ | GameUnsupported+ | OutOfBounds+ | BadlyFormattedValue+ | BadlyEncodedValue+ | ConcurrentMoveAndSetup+ | ConcurrentBlackAndWhiteMove+ | ConcurrentAnnotations+ | ExtraMoveAnnotations+ deriving (Eq, Ord, Show, Read, Bounded, Enum)++-- Errors signify unrecoverable errors.+data Error+ = KnownError { errorType :: ErrorType, errorPosition :: SourcePos }+ | UnknownError { errorDescription :: Maybe String }+ deriving (Eq, Ord, Show)++instance Either.Error Error where+ noMsg = UnknownError Nothing+ strMsg = UnknownError . Just++die :: Error -> Translator a+dieWithPos :: ErrorType -> SourcePos -> Translator a+dieWith :: ErrorType -> Property -> Translator a+dieWithJust :: ErrorType -> Maybe Property -> Translator a++die = lift . StateT . const . Left+dieWithPos e = die . KnownError e+dieWith e = dieWithPos e . position+dieWithJust e = dieWith e . fromJust+-- }}}+-- Warning {{{+-- by convention, a warning that does not end in a verb just "did the right thing" to correct the problem+-- |+-- Warnings signify recoverable errors.+data Warning+ = DuplicatePropertyOmitted Property+ | SquareSizeSpecifiedAsRectangle SourcePos+ | DanglingEscapeCharacterOmitted SourcePos+ | PropValueForNonePropertyOmitted Property+ | UnknownPropertyPreserved String+ | PointSpecifiedAsPointRange Property+ | DuplicatePointsOmitted Property [Point]+ | InvalidDatesClipped (Set PartialDate)+ | AnnotationWithNoMoveOmitted Property+ | ExtraGameInfoOmitted Property+ | NestedRootPropertyOmitted Property+ | MovelessAnnotationOmitted Property+ | DuplicateSetupOperationsOmitted [Point]+ | ExtraPositionalJudgmentOmitted (Judgment, Emphasis)+ | DuplicateMarkupOmitted (Mark, Point)+ | ExtraPropertyValuesOmitted Property+ | DuplicateLabelOmitted (Point, String)+ | UnknownNumberingIgnored Integer+ deriving (Eq, Ord, Show)+-- }}}+-- State, Translator a, PTranslator a {{{+type State = Tree [Property]+type Translator a = WriterT [Warning] (StateT State (Either Error)) a+type PTranslator a = Property -> Translator a++transMap, transMapMulti :: PTranslator a -> String -> Translator (Maybe a)+transMap f = consumeSingle >=> transMap' f+transMapMulti f = consume >=> transMap' f++transMap' :: (a -> Translator b) -> (Maybe a -> Translator (Maybe b))+transMap' f = maybe (return Nothing) (liftM Just . f)++transMapList :: PTranslator [a] -> String -> Translator [a]+transMapList f = consume >=> maybe (return []) f+-- }}}+-- }}}+-- handy Translators {{{+-- helper functions {{{+duplicatesOn :: Ord b => (a -> b) -> [a] -> [a]+duplicatesOn f = map fst+ . concatMap (drop 1)+ . groupBy ((==) `on` snd)+ . sortBy (comparing snd)+ . map (id &&& f)++duplicateProperties :: State -> [Warning]+duplicateProperties = map DuplicatePropertyOmitted . duplicatesOn name . rootLabel++duplicates :: Translator ()+duplicates = get >>= tell . duplicateProperties++readNumber :: String -> SourcePos -> Translator Integer+readNumber "" _ = return 0+readNumber s pos | all isDigit s = return (read s)+ | otherwise = dieWithPos BadlyFormattedValue pos++newline :: a -> (String -> a) -> (Char -> String -> a) -> String -> a+newline empty with without xs = case xs of+ '\r':'\n':xs -> with xs+ '\n':'\r':xs -> with xs+ '\r': xs -> with xs+ '\n': xs -> with xs+ x : xs -> without x xs+ [] -> empty++trim :: Char -> Char+trim x = if isSpace x then ' ' else x++descape :: Char -> SourcePos -> String -> Translator String+descape hard pos s = case s of+ ('\\':xs) -> newline' (tell [DanglingEscapeCharacterOmitted pos]) id xs+ xs -> newline' (return ()) (hard:) xs+ where+ newline' warn prefix = newline (warn >> return "") (fmap prefix . descape hard pos) (\c -> fmap (trim c:) . descape hard pos)++decodeAndDescape :: Char -> Header -> PTranslator String+decodeAndDescape hard (Header { encoding = e }) (Property { values = v:_, position = pos }) =+ case decodeWordStringExplicit e v of+ Left exception -> dieWithPos BadlyEncodedValue pos+ Right decoded -> descape hard pos decoded++splitColon :: [Word8] -> Maybe ( [Word8] , [Word8] )+splitColons :: [[Word8]] -> Maybe ([[Word8]], [[Word8]])++splitColons = fmap unzip . mapM splitColon+splitColon xs+ | null xs = Nothing+ | [enum ':' ] `isPrefixOf` xs = Just ([], drop 1 xs)+ | [enum '\\'] `isPrefixOf` xs = continue 2+ | otherwise = continue 1+ where+ continue n = fmap (first (take n xs ++)) (splitColon (drop n xs))++warnAboutDuplicatePoints :: Property -> [Point] -> Translator [Point]+warnAboutDuplicatePoints p ps = let ds = duplicatesOn id ps in do+ when (not $ null ds) (tell [DuplicatePointsOmitted p ds])+ return (nub ps)++checkPointList :: (PTranslator [Point] -> PTranslator [[Point]]) -> (PTranslator Point -> PTranslator [Point])+checkPointList listType a p = listType (mayBeCompoundPoint a) p >>= warnAboutDuplicatePoints p . concat+-- }}}+-- low-level {{{+has :: String -> Translator Bool+has s = gets (any ((s ==) . name) . rootLabel)++hasAny :: [String] -> Translator Bool+hasAny = fmap or . mapM has++consume :: String -> Translator (Maybe Property)+consume s = do+ (v, rest) <- gets (partition ((== s) . name) . rootLabel)+ modify (\s -> s { rootLabel = rest })+ return (listToMaybe v)++consumeSingle :: String -> Translator (Maybe Property)+consumeSingle s = do+ maybeProperty <- consume s+ case maybeProperty of+ Just p@(Property { values = (v:_:_) }) -> do+ tell [ExtraPropertyValuesOmitted p]+ return (Just p { values = [v] })+ _ -> return maybeProperty++unknownProperties :: Translator (Map String [[Word8]])+unknownProperties = do+ m <- gets (fromList . map (name &&& values) . rootLabel)+ tell [UnknownPropertyPreserved name | name <- keys m]+ return m+-- }}}+-- PTranslators and combinators {{{+number :: PTranslator Integer+number p@(Property { values = v:_ })+ | enum '.' `elem` v = dieWith BadlyFormattedValue p+ | otherwise = fmap floor (real p)++real :: PTranslator Rational+real (Property { values = v:_, position = pos })+ | [enum '+'] `isPrefixOf` v = result 1+ | [enum '-'] `isPrefixOf` v = fmap negate (result 1)+ | otherwise = result 0+ where+ split i = second (drop 1) . break (== '.') . map enum . drop i $ v+ result i = let (n, d) = split i in do+ whole <- readNumber n pos+ fract <- readNumber d pos+ return (fromInteger whole + fromInteger fract / 10 ^ length d)++simple :: Header -> PTranslator String+text :: Header -> PTranslator String++simple = decodeAndDescape ' '+text = decodeAndDescape '\n'++none :: PTranslator ()+none (Property { values = [[]] }) = return ()+none p = tell [PropValueForNonePropertyOmitted p]++choice :: [([Word8], a)] -> PTranslator a+choice vs p@(Property { values = [] }) = dieWith BadlyFormattedValue p -- can't happen+choice vs p@(Property { values = v:_ }) = maybe (dieWith BadlyFormattedValue p) return (lookup v vs)++choice' :: [(String, a)] -> PTranslator a+choice' vs = choice [(map enum k, v) | (k', v) <- vs, k <- [k', map toLower k']]++double :: PTranslator Emphasis+color :: PTranslator Color+double = choice' [("1", Normal), ("2", Strong)]+color = choice' [("B", Black), ("W", White)]++compose :: PTranslator a -> PTranslator b -> PTranslator (a, b)+compose a b p@(Property { values = vs }) = case splitColons vs of+ Nothing -> dieWith BadlyFormattedValue p+ Just (as, bs) -> liftM2 (,) (a p { values = as }) (b p { values = bs })++listOf :: PTranslator a -> PTranslator [a]+listOf a p@(Property { values = vs }) = mapM a [p { values = [v] } | v <- vs]++elistOf :: PTranslator a -> PTranslator [a]+elistOf _ (Property { values = [[]] }) = return []+elistOf a p = listOf a p++mayBeCompoundPoint, listOfPoint, elistOfPoint :: PTranslator Point -> PTranslator [Point]+mayBeCompoundPoint a p@(Property { values = v:_ }) = case splitColon v of+ Nothing -> fmap return $ a p+ Just {} -> do+ pointRange <- compose a a p { values = [v] }+ when (uncurry (==) pointRange) (tell [PointSpecifiedAsPointRange p])+ return (range pointRange)++listOfPoint = checkPointList listOf+elistOfPoint = checkPointList elistOf+-- }}}+-- }}}
+ Data/SGF/Types.hs view
@@ -0,0 +1,707 @@+-- boilerplate {{{+{-# LANGUAGE EmptyDataDecls #-}+-- | Types used to represent an SGF tree. Whenever a data type is used by+-- exactly one other data type, there will be a \"see also\" link to its+-- containing type.+module Data.SGF.Types (+ -- * Game type+ Game(..), GameTree(..), GameNode(..),+ Move(..), Setup(..),+ Annotation(..), Markup(..), GameInfo(..), GameInfoType(..),+ emptyGameNode, emptyMove, emptySetup, emptyGameInfo, emptyAnnotation, emptyMarkup,++ -- * Game-specific types+ -- ** Go+ NodeGo, MoveGo(..), RuleSetGo(..), GameInfoGo(..), AnnotationGo,++ -- ** Backgammon+ NodeBackgammon, RuleSetBackgammon(..), GameInfoBackgammon,+ MatchInfo(..),++ -- ** Lines of Action+ NodeLinesOfAction, GameInfoLinesOfAction(..),+ InitialPosition(..), InitialPlacement(..),++ -- ** Hex+ NodeHex, GameInfoHex,+ ViewerSetting(..),++ -- ** Octi+ -- $octi+ NodeOcti, RuleSetOcti(..), GameInfoOcti(..),+ MajorVariation(..), MinorVariation(..),++ -- ** Other+ NodeOther,++ -- * Type aliases+ Collection, Point,+ Application, Version, AutoMarkup,+ TreeGo, TreeBackgammon, TreeLinesOfAction, TreeHex, TreeOcti, TreeOther,++ -- * Enumerations+ Color(..), RankScale(..),+ Emphasis(..), Certainty(..), FuzzyBool(..),+ GameType(..),+ Judgment(..), Quality(..),+ Mark(..), Numbering(..), VariationType(..), FigureFlag(..),++ -- * Miscellaneous+ WinType(..), GameResult(..), Rank(..), RuleSet(..),+ Round(..), PartialDate(..), Figure(..),+ Void+) where++import Data.List+import Data.Map hiding (empty, filter, findIndex)+import Data.Maybe+import Data.Ord+import Data.Set hiding (empty, filter)+import Data.Tree+import Data.Word+import Prelude hiding (round)++import qualified Data.Map as Map+import qualified Data.Set as Set++-- | A type with no constructors used merely to indicate a lack of data.+data Void+instance Eq Void where _ == _ = True+instance Ord Void where compare _ _ = EQ+instance Read Void where readsPrec _ _ = []+instance Show Void where show _ = ""+-- }}}+-- GameType {{{+-- | See also 'GameTree'. This enumeration is used for the GM property (see+-- <http://www.red-bean.com/sgf/properties.html#GM>). The Enum instance+-- converts to and from the numeric game codes listed there.+data GameType =+ Go | Othello | Chess | Gomoku | NineMen'sMorris |+ Backgammon | ChineseChess | Shogi | LinesOfAction | Ataxx |+ Hex | Jungle | Neutron | Philosopher'sFootball |+ Quadrature | Trax | Tantrix | Amazons | Octi | Gess |+ Twixt | Zertz | Plateau | Yinsh | Punct | Gobblet | Hive |+ Exxit | Hnefatal | Kuba | Tripples | Chase | TumblingDown |+ Sahara | Byte | Focus | Dvonn | Tamsk | Gipf | Kropki+ deriving (Eq, Ord, Bounded, Show, Read)++allGameTypesInSGFOrder =+ [Go, Othello, Chess, Gomoku, NineMen'sMorris, Backgammon,+ ChineseChess, Shogi, LinesOfAction, Ataxx, Hex, Jungle,+ Neutron, Philosopher'sFootball, Quadrature, Trax, Tantrix,+ Amazons, Octi, Gess, Twixt, Zertz, Plateau, Yinsh, Punct,+ Gobblet, Hive, Exxit, Hnefatal, Kuba, Tripples, Chase,+ TumblingDown, Sahara, Byte, Focus, Dvonn, Tamsk, Gipf,+ Kropki+ ]++instance Enum GameType where+ toEnum n = allGameTypesInSGFOrder !! (n - 1)+ fromEnum t = (+1) . fromJust . findIndex (t==) $ allGameTypesInSGFOrder+-- }}}+-- type aliases {{{+type Collection = [Game]+-- | See also 'Game'.+type Application = String+-- | See also 'Game'.+type Version = String+-- | 0-indexed x/y coordinates that start at the top left+type Point = (Integer, Integer)+-- | See also 'Game'.+type AutoMarkup = Bool+-- }}}+-- enums {{{+-- | See also 'Move'.+data FuzzyBool = Possibly | Definitely deriving (Eq, Ord, Show, Read, Enum, Bounded)+data Emphasis = Normal | Strong deriving (Eq, Ord, Show, Read, Enum, Bounded)+data Color = Black | White deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'Rank'.+data Certainty = Uncertain | Certain deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'GameInfoLinesOfAction'.+data InitialPosition = Beginning | End deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'Rank'. In addition to the standard \"kyu\" and \"dan\" ranks,+-- this also supports the non-standard (but common) \"pro\" ranks.+data RankScale = Kyu | Dan | Pro deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'Annotation'.+data Judgment = GoodForWhite | GoodForBlack | Even | Unclear deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'GameInfoLinesOfAction'.+data InitialPlacement = Standard | ScrambledEggs | Parachute | Gemma | Custom deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- | See also 'Game'.+data VariationType+ = Children -- ^ Variations are stored in child nodes.+ | Siblings -- ^ Variations are stored in sibling nodes.+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- | See also 'Markup'. With the exception of 'Selected', the constructor+-- names describe a shape whose outline should be shown over the given point.+data Mark+ = Circle+ | X+ -- | The exact appearance of this kind of markup is not specified, though+ -- suggestions include darkening the colors on these points or inverting+ -- the colors on these points.+ | Selected+ | Square+ | Triangle+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- | See also 'GameInfo', especially the 'freeform' field.+data GameInfoType+ -- | See also the BT and WT properties at+ -- <http://www.red-bean.com/sgf/properties.html#BT>+ = TeamName Color+ -- | See also the PB and PW properties at+ -- <http://www.red-bean.com/sgf/properties.html#PB>+ | PlayerName Color+ -- | The name of the person who annotated the game. See also+ -- <http://www.red-bean.com/sgf/properties.html#AN>+ | Annotator+ -- | The name of the source, e.g. the title of the book this game came from.+ -- See also <http://www.red-bean.com/sgf/properties.html#SO>+ | Source+ -- | The name of the person or program who entered the game. See also+ -- <http://www.red-bean.com/sgf/properties.html#US>+ | User+ -- | See also <http://www.red-bean.com/sgf/properties.html#CP>+ | Copyright+ -- | Background information or a summary of the game. See also+ -- <http://www.red-bean.com/sgf/properties.html#GC>+ | Context+ -- | Where the game was played. See also+ -- <http://www.red-bean.com/sgf/properties.html#PC>+ | Location+ -- | The name of the event or tournament at which the game occurred.+ -- Additional information about the game (e.g. that it was in the finals)+ -- should appear in the 'round' field, not here. See also+ -- <http://www.red-bean.com/sgf/properties.html#EV>+ | Event+ -- | An easily-remembered moniker for the game. See also+ -- <http://www.red-bean.com/sgf/properties.html#GN>+ | GameName+ -- | A description of the opening moves using the game's vernacular. See+ -- also <http://www.red-bean.com/sgf/properties.html#ON>+ | Opening+ -- | The overtime rules. See also+ -- <http://www.red-bean.com/sgf/properties.html#OT>+ | Overtime+ deriving (Eq, Ord, Show, Read)++-- | See also 'GameTree' and <http://www.red-bean.com/sgf/hex.html#IS>+data ViewerSetting+ = Tried -- ^ Identify future moves that have been tried?+ | Marked -- ^ Show good/bad move markings?+ | LastMove -- ^ Identify the last cell played?+ | Headings -- ^ Display column/row headings?+ | Lock -- ^ Lock the game against new moves?+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++-- | See also 'Markup'.+data Numbering+ = Unnumbered -- ^ Don't print move numbers.+ | Numbered -- ^ Print move numbers as they are.+ | Modulo100 -- ^ Subtract enough multiples of 100 from each move+ -- number that the first labeled move is below 100.+ deriving (Eq, Ord, Show, Read, Enum, Bounded)++allGameInfoTypes = [TeamName Black, TeamName White, PlayerName Black, PlayerName White, Annotator, Source, User, Copyright, Context, Location, Event, GameName, Opening, Overtime]+instance Enum GameInfoType where+ toEnum = (allGameInfoTypes !!)+ fromEnum t = fromJust $ findIndex (t==) allGameInfoTypes++instance Bounded GameInfoType where+ minBound = head allGameInfoTypes+ maxBound = last allGameInfoTypes+-- }}}+-- rulesets {{{+-- | See also 'RuleSet', 'GameInfo', and+-- <http://red-bean.com/sgf/properties.html#RU>+data RuleSetGo+ -- | American Go Association rules+ = AGA+ -- | Ing rules+ | GOE+ | Chinese | Japanese | NewZealand+ deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'RuleSet', 'GameInfo', and+-- <http://red-bean.com/sgf/backgammon.html#RU>+data RuleSetBackgammon+ -- | The Crawford rule is being used.+ = Crawford+ -- | This game /is/ the Crawford game.+ | CrawfordGame+ -- | The Jacoby rule is being used.+ | Jacoby+ deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'RuleSet', 'GameInfo', and <http://red-bean.com/sgf/octi.html#RU>+data RuleSetOcti = OctiRuleSet MajorVariation (Set MinorVariation) deriving (Eq, Ord, Show, Read)+-- | See also 'RuleSetOcti'.+data MajorVariation = Full | Fast | Kids deriving (Eq, Ord, Show, Read, Enum, Bounded)+-- | See also 'RuleSetOcti'.+data MinorVariation = Edgeless | Superprong | OtherMinorVariation String deriving (Eq, Ord, Show, Read)+-- | See also 'GameInfo'. Typical values for the @a@ type variable are+-- 'RuleSetGo', 'RuleSetBackgammon', and 'RuleSetOcti'. For games where the+-- valid values of the ruleset field is not specified, the @a@ type variable+-- will be 'Void' to ensure that all rulesets are specified as a 'String'.+data RuleSet a = Known !a | OtherRuleSet String deriving (Eq, Ord, Show, Read)+-- }}}+-- misc types {{{+-- | See also 'GameResult'. Games that end normally use @Score@ if there is a+-- natural concept of score differential for that game and @OtherWinType@ if+-- not.+data WinType = Score Rational | Resign | Time | Forfeit | OtherWinType deriving (Eq, Ord, Show, Read)+-- | See also 'Move'.+data Quality = Bad Emphasis | Doubtful | Interesting | Good Emphasis deriving (Eq, Ord, Show, Read)++-- | See also 'GameInfo'.+data GameResult+ = Draw | Void | Unknown+ | Win Color WinType -- ^ The first argument is the color of the winner.+ deriving (Eq, Ord, Show, Read)++-- | See also 'GameInfo', especially the 'rankBlack' and 'rankWhite' fields.+-- The @Eq@ and @Ord@ instances are the derived ones, and should not be mistaken+-- for semantic equality or ordering.+data Rank+ -- | Ranked in one of the standard ways. Most SGF generators specify+ -- the certainty only when it is @Uncertain@. Therefore, it may be+ -- reasonable to treat @Nothing@ and @Just Certain@ identically.+ = Ranked Integer RankScale (Maybe Certainty)+ -- | Any rank that does not fall in the standard categories. This field+ -- must not contain newlines.+ | OtherRank String+ deriving (Eq, Ord, Show, Read)++-- | See also 'GameInfo'.+data Round+ -- | Only a round number is given.+ = SimpleRound Integer+ -- | Both a round number and a type, like \"final\", \"playoff\", or+ -- \"league\".+ | FormattedRound Integer String+ -- | Round information in an unknown format.+ | OtherRound String+ deriving (Eq, Ord, Show, Read)++-- | See also 'GameInfoBackgammon' and+-- <http://red-bean.com/sgf/backgammon.html#MI>+data MatchInfo+ -- | The number of points in this match.+ = Length Integer+ -- | The (1-indexed) number of the game within this match.+ | GameNumber Integer+ -- | The score at the beginning of the game.+ | StartScore Color Integer+ -- | An unknown piece of match information.+ | OtherMatchInfo String String+ deriving (Eq, Ord, Show, Read)++-- | See also 'GameInfo'.+data PartialDate+ = Year { year :: Integer }+ | Month { year :: Integer, month :: Integer }+ | Day { year :: Integer, month :: Integer, day :: Integer }+ deriving (Eq, Ord, Show, Read)+-- }}}+-- Figure {{{+-- FigureFlag {{{+-- | See also 'Figure'.+data FigureFlag+ -- | Show coordinates around the edges of the board.+ = Coordinates+ -- | Show the diagram's name.+ | Name+ -- | List moves that can't be shown in the diagram as text.+ | HiddenMoves+ -- | Remove captured stones from the diagram.+ | RemoveCaptures+ -- | Show hoshi dots.+ | Hoshi+ deriving (Eq, Ord, Show, Read, Bounded)++allFigureFlags :: [FigureFlag]+allFigureFlags = [Coordinates, Name, HiddenMoves, RemoveCaptures, Hoshi]++instance Enum FigureFlag where+ toEnum 0 = Coordinates+ toEnum 1 = Name+ toEnum 2 = HiddenMoves+ toEnum 8 = RemoveCaptures+ toEnum 9 = Hoshi+ toEnum n = error $ "unknown FigureFlag bit " ++ show n+ fromEnum Coordinates = 0+ fromEnum Name = 1+ fromEnum HiddenMoves = 2+ fromEnum RemoveCaptures = 8+ fromEnum Hoshi = 9+ enumFrom lo = dropWhile (/= lo) allFigureFlags+ enumFromTo lo hi = filter (\x -> lo <= x && x <= hi) allFigureFlags+ succ lo = enumFrom lo !! 1+ pred hi = reverse (enumFromTo minBound hi) !! 1+ -- TODO: enumFromThen, enumFromThenTo+-- }}}+-- | See also 'Markup'.+data Figure+ -- | Unnamed figure using the application default settings.+ = DefaultFigure+ -- | Named figure using the application default settings.+ | NamedDefaultFigure String+ -- | Named figure that overrides the application's figure settings.+ | NamedFigure String (FigureFlag -> Bool)+ deriving (Eq, Ord, Show, Read)+-- function instances of Eq, Ord, Show, Read {{{+mapFromFunction f = Map.fromList [(k, f k) | k <- [minBound..maxBound]]++-- TODO: remove Ord k constraints+instance (Bounded k, Enum k, Ord k, Show k, Show v) => Show (k -> v) where+ showsPrec n = showsPrec n . mapFromFunction++instance (Bounded k, Enum k, Ord k, Read k, Read v) => Read (k -> v) where+ readsPrec n s = [((m Map.!), rest) | (m, rest) <- readsPrec n s, all (`Map.member` m) [minBound..]]++instance (Bounded k, Enum k, Ord k, Eq v) => Eq (k -> v) where+ f == g = mapFromFunction f == mapFromFunction g++instance (Bounded k, Enum k, Ord k, Ord v) => Ord (k -> v) where+ compare = comparing mapFromFunction+-- }}}+-- }}}+-- Move {{{+-- | See also 'GameNode'.+data Move move = Move {+ -- | The given move should be executed, whether it is illegal or not.+ -- See also the B and W properties at+ -- <http://www.red-bean.com/sgf/properties.html#B>+ move :: Maybe (Color, move),+ -- | When set to 'Definitely', the current move is acknowledged to be+ -- illegal. When set to 'Possibly', the move may be legal or illegal.+ -- See also <http://www.red-bean.com/sgf/properties.html#KO>+ illegal :: FuzzyBool,+ -- | When @Just@, set the current move number. See also+ -- <http://www.red-bean.com/sgf/properties.html#MN>+ number :: Maybe Integer,+ -- | An annotation telling the quality of the current move. This+ -- annotation makes no bigger-picture positional judgments; for those,+ -- see 'Annotation'. See also the BM, DO, IT, and TE properties at+ -- <http://www.red-bean.com/sgf/properties.html#BM>+ quality :: Maybe Quality,+ -- | Time remaining, in seconds, for the black player after this move+ -- was made. See also <http://www.red-bean.com/sgf/properties.html#BL>+ timeBlack :: Maybe Rational,+ -- | Time remaining, in seconds, for the white player after this move+ -- was made. See also <http://www.red-bean.com/sgf/properties.html#WL>+ timeWhite :: Maybe Rational,+ -- | Number of overtime moves left for the black player after this move+ -- was made. See also <http://www.red-bean.com/sgf/properties.html#OB>+ overtimeMovesBlack :: Maybe Integer,+ -- | Number of overtime moves left for the white player after this move+ -- was made. See also <http://www.red-bean.com/sgf/properties.html#OW>+ overtimeMovesWhite :: Maybe Integer+ } deriving (Eq, Ord, Show, Read)++emptyMove :: Move move+emptyMove = Move Nothing Possibly Nothing Nothing Nothing Nothing Nothing Nothing++-- | See also 'NodeGo' and 'Game'.+data MoveGo = Pass | Play Point deriving (Eq, Ord, Show, Read)+-- }}}+-- Setup {{{+-- | See also 'GameNode'. 'Setup' nodes are distinct from 'Move' nodes in that+-- they need not correspond to any natural part of the game, and game rules+-- (e.g. for capture) are not applied after executing 'Setup' nodes. They can+-- be used for any non-standard changes to the game board or to create illegal+-- board positions. The locations specified in the @addBlack@, @addWhite@, and+-- @remove@ fields must be pairwise disjoint.+data Setup stone = Setup {+ -- | This node adds the given black pieces to the board; if the board+ -- before this setup node had any pieces at the locations given by this+ -- field, they are overridden. See also+ -- <http://www.red-bean.com/sgf/properties.html#AB>+ addBlack :: Set stone,+ -- | This node adds the given white pieces to the board; if the board+ -- before this setup node had any pieces at the locations given by this+ -- field, they are overridden. See also+ -- <http://www.red-bean.com/sgf/properties.html#AW>+ addWhite :: Set stone,+ -- | This node specifies locations of the board to clear. See also+ -- <http://www.red-bean.com/sgf/properties.html#AE>+ remove :: Set Point,+ -- | Specify which player should move next. See also+ -- <http://www.red-bean.com/sgf/properties.html#PL>+ toPlay :: Maybe Color+ } deriving (Eq, Ord, Show, Read)++emptySetup :: Setup stone+emptySetup = Setup Set.empty Set.empty Set.empty Nothing+-- }}}+-- GameInfo {{{+-- | See also 'GameNode'. Each individual game may have at most one node with+-- associated game info. If it has such a node, it must occur at the first node+-- where that game is distinguishable from all of the other games in the tree.+data GameInfo ruleSet extra = GameInfo {+ -- | The strength of the black player. See also+ -- <http://www.red-bean.com/sgf/properties.html#BR>+ rankBlack :: Maybe Rank,+ -- | The strength of the white player. See also+ -- <http://www.red-bean.com/sgf/properties.html#WR>+ rankWhite :: Maybe Rank,+ -- | When the game was played. An empty set indicates that no date+ -- information is available. See also+ -- <http://www.red-bean.com/sgf/properties.html#DT>+ date :: Set PartialDate,+ -- | The round number (for games played in a tournament). See also+ -- <http://www.red-bean.com/sgf/properties.html#RO>+ round :: Maybe Round,+ -- | The ruleset used for this game. See also+ -- <http://www.red-bean.com/sgf/properties.html#RU>+ ruleSet :: Maybe (RuleSet ruleSet),+ -- | The time limit of the game in seconds. See also+ -- <http://www.red-bean.com/sgf/properties.html#TM>+ timeLimit :: Maybe Rational,+ -- | How the game ended. See also+ -- <http://www.red-bean.com/sgf/properties.html#RE>+ result :: Maybe GameResult,+ -- | Miscellaneous properties with no prescribed format.+ freeform :: Map GameInfoType String,+ -- | Certain game types specify additional informational properties, which+ -- are stored here.+ otherGameInfo :: extra+ } deriving (Eq, Ord, Show, Read)++emptyGameInfo :: GameInfo ruleSet ()+emptyGameInfo = GameInfo Nothing Nothing Set.empty Nothing Nothing Nothing Nothing Map.empty ()++-- | See also 'NodeGo' and the 'otherGameInfo' field of 'GameInfo'.+data GameInfoGo = GameInfoGo {+ -- | Specifying this does not automatically add stones to the board; a+ -- 'Setup' node with a non-empty 'addBlack' field should be specified before+ -- any 'Move' nodes. See also <http://red-bean.com/sgf/go.html#HA>+ handicap :: Maybe Integer,+ -- | See also <http://red-bean.com/sgf/go.html#KM>+ komi :: Maybe Rational+ } deriving (Eq, Ord, Show, Read)++-- | See also 'NodeBackgammon' and the 'otherGameInfo' field of 'GameInfo'. An+-- empty list indicates that no match information was specified. The order of+-- the list is not significant, and there should be only one value of any given+-- kind of 'MatchInfo'. See also <http://red-bean.com/sgf/backgammon.html#MI>+type GameInfoBackgammon = [MatchInfo]++-- | See also 'NodeLinesOfAction' and the 'otherGameInfo' field of 'GameInfo'.+data GameInfoLinesOfAction = GameInfoLinesOfAction {+ -- | When this field is 'Beginning', the viewer should initially show the+ -- board position after setup but before any moves. (When 'End', the+ -- viewer should display the final position.) See also+ -- <http://www.red-bean.com/sgf/loa.html#IP>+ initialPositionLOA :: InitialPosition,+ -- | When this field is 'True', the board should be displayed with numbers+ -- increasing from the bottom to the top of the screen. (When 'False', the+ -- numbers should be decreasing.) See also+ -- <http://www.red-bean.com/sgf/loa.html#IY>+ invertYAxis :: Bool,+ -- | The initial placement of pieces and rule variation. See also+ -- <http://www.red-bean.com/sgf/loa.html#SU>+ initialPlacement :: InitialPlacement+ } deriving (Eq, Ord, Show, Read)++-- | See also 'NodeHex' and the 'otherGameInfo' field of 'GameInfo'. The+-- specification says that trees representing Hex games will mark which+-- position the viewer should initially show by setting this field to 'True'.+-- I think this is probably an error in the specification; there is an obvious+-- conflict between the requirement to put all game information at the first+-- node where a game is uniquely identifiable and the requirement to have a+-- game-information property at the location you want to view first (whenever+-- these two nodes are not the same node, of course). For this reason, Hex+-- game trees may have paths containing two nodes whose game information is not+-- 'Nothing'. See also <http://www.red-bean.com/sgf/hex.html#IP>+type GameInfoHex = Bool++-- $octi+-- For Octi, 'Black' always refers to the first player and 'White' always+-- refers to the second player, regardless of the colors of the actual pieces+-- used by the first and second players.++-- | See also 'NodeOcti' and the 'otherGameInfo' field of 'GameInfo'.+data GameInfoOcti = GameInfoOcti {+ -- | Black should be set up with one empty pod on each of these points. An+ -- empty set indicates that this property was not specified. See also+ -- <http://www.red-bean.com/sgf/octi.html#BO>+ squaresWhite :: Set Point,+ -- | White should be set up with one empty pod on each of these points. An+ -- empty set indicates that this property was not specified. See also+ -- <http://www.red-bean.com/sgf/octi.html#WO>+ squaresBlack :: Set Point,+ -- | How many prongs each player starts with. See also+ -- <http://www.red-bean.com/sgf/octi.html#NP>+ prongs :: Integer,+ -- | How many pods each player has in reserve to start with. See also+ -- <http://www.red-bean.com/sgf/octi.html#NR>+ reserve :: Integer,+ -- | How many superprongs each player starts with. See also+ -- <http://www.red-bean.com/sgf/octi.html#NS>+ superProngs :: Integer+ } deriving (Eq, Ord, Show, Read)+-- }}}+-- Annotation/Markup {{{+-- | See also 'GameNode'.+data Annotation extra = Annotation {+ -- | Free-form text describing the current node. See also+ -- <http://www.red-bean.com/sgf/properties.html#C>+ comment :: Maybe String,+ -- | A very short description of the node. Must not contain newlines.+ -- See also <http://www.red-bean.com/sgf/properties.html#N>+ name :: Maybe String,+ -- | When @Just@, this node contains something interesting. Viewers+ -- should show a message. See also+ -- <http://www.red-bean.com/sgf/properties.html#HO>+ hotspot :: Maybe Emphasis,+ -- | A quantitative full-board positional judgment. Positive values are+ -- good for black, negative for white. See also+ -- <http://www.red-bean.com/sgf/properties.html#V>+ value :: Maybe Rational,+ -- | A qualitative full-board positional judgment. See also the GB, GW,+ -- DM, and UC properties at+ -- <http://www.red-bean.com/sgf/properties.html#DM>+ judgment :: Maybe (Judgment, Emphasis),+ -- | Game-specific annotations.+ otherAnnotation :: extra+ } deriving (Eq, Ord, Show, Read)++emptyAnnotation :: Annotation ()+emptyAnnotation = Annotation Nothing Nothing Nothing Nothing Nothing ()++-- | See also 'NodeGo' and the 'otherAnnotation' field of 'Annotation'. This+-- specifies which points are considered territory for each player. See also+-- the TB and TW properties at <http://red-bean.com/sgf/go.html#TB>+type AnnotationGo = Map Color (Set Point)++-- | See also 'GameNode'. Presumably, no arrow in the @arrows@ field should+-- exactly overlap a line specified in the @lines@ field; however, this is not+-- explicitly made illegal by the SGF spec. Note that some fields are marked+-- \"inherit\". These inheritances are not explicitly tracked; @Nothing@ values+-- indicate that the correct interpretation depends on the node's ancestors, or+-- on the default if no ancestor has a @Just@ value in this field.+data Markup = Markup {+ -- | See also the CR, MA, SL, SQ, and TR properties at+ -- <http://www.red-bean.com/sgf/properties.html#CR>+ marks :: Map Point Mark,+ -- | Typically, the @String@s will be single letters, but that is not+ -- guaranteed. Labels must not contain newlines. See also+ -- <http://www.red-bean.com/sgf/properties.html#LB>+ labels :: Map Point String,+ -- | Arrows must not start and end at the same point. See also+ -- <http://www.red-bean.com/sgf/properties.html#AR>+ arrows :: Set (Point, Point),+ -- | Lines must not start and end at the same point. Lines must not be+ -- repeated; the parser guarantees this by only including pairs @(p, q)@+ -- in which @p \< q@. See also+ -- <http://www.red-bean.com/sgf/properties.html#LN>+ lines :: Set (Point, Point),+ -- | Shade out (exactly) the given points. This property is inherited,+ -- defaulting to @Set.empty@. See also+ -- <http://www.red-bean.com/sgf/properties.html#DD>+ dim :: Maybe (Set Point),+ -- | Make (exactly) the given points visible; do not draw any of the+ -- other points. This property is inherited, defaulting to the entire+ -- board, and @Set.empty@ resets to the default. See also+ -- <http://www.red-bean.com/sgf/properties.html#VW>+ visible :: Maybe (Set Point),+ -- | How move numbers should be printed on the board. This property is+ -- inherited, defaulting to @Numbered@. See also+ -- <http://www.red-bean.com/sgf/properties.html#PM>+ numbering :: Maybe Numbering,+ -- | When @Just@, a new diagram should begin at this move. See also+ -- <http://www.red-bean.com/sgf/properties.html#FG>+ figure :: Maybe Figure+ } deriving (Eq, Ord, Show, Read)++emptyMarkup :: Markup+emptyMarkup = Markup Map.empty Map.empty Set.empty Set.empty Nothing Nothing Nothing Nothing+-- }}}+-- Game/GameNode/GameTree {{{+-- | See also 'Collection'.+data Game = Game {+ -- | The name and version number of the application used to create this+ -- game. The version number must be in a format that allows ordinary+ -- string comparison to tell which version is higher or lower. Neither+ -- the application name nor the version number may have newlines. See+ -- also <http://www.red-bean.com/sgf/properties.html#AP>+ application :: Maybe (Application, Version),+ -- | The first argument tells whether children (False) or siblings+ -- (True) are variations; the second argument tells whether or not to+ -- show board markup when variations are available. See also+ -- <http://www.red-bean.com/sgf/properties.html#ST>+ variationType :: Maybe (VariationType, AutoMarkup),+ -- | The size of the board. For games with a default board size, this+ -- is guaranteed to be a @Just@. See also+ -- <http://www.red-bean.com/sgf/properties.html#SZ>+ size :: Maybe (Integer, Integer),+ -- | The actual game tree.+ tree :: GameTree+ } deriving (Eq, Show, Read)++-- | See also 'Game'.+data GameTree+ = TreeGo TreeGo+ | TreeBackgammon TreeBackgammon+ | TreeLinesOfAction TreeLinesOfAction+ -- | Applications can store and read settings in the first argument+ -- here. This got totally shoehorned into the spec by some particular+ -- viewer, I'm sure, but it's in the spec now, so there we go. See also+ -- <http://www.red-bean.com/sgf/hex.html#IS>+ | TreeHex [(ViewerSetting, Bool)] TreeHex+ | TreeOcti TreeOcti+ | TreeOther GameType TreeOther+ deriving (Eq, Show, Read)++-- | See also 'GameTree'.+type TreeGo = Tree NodeGo+-- | See also 'GameTree'.+type TreeBackgammon = Tree NodeBackgammon+-- | See also 'GameTree'.+type TreeLinesOfAction = Tree NodeLinesOfAction+-- | See also 'GameTree'.+type TreeHex = Tree NodeHex+-- | See also 'GameTree'.+type TreeOcti = Tree NodeOcti+-- | See also 'GameTree'.+type TreeOther = Tree NodeOther++-- | See also 'GameTree'.+data GameNode move stone ruleSet extraGameInfo extraAnnotation = GameNode {+ -- | All properties with propertytype game-info. There must be only one+ -- @Just@ on any path within a 'GameTree'.+ gameInfo :: Maybe (GameInfo ruleSet extraGameInfo),+ -- | All properties with propertytype setup or move.+ action :: Either (Setup stone) (Move move),+ -- | Positional judgments and comments (as opposed to judgments of+ -- particular moves). All properties covered in the \"Node annotation\"+ -- section.+ annotation :: Annotation extraAnnotation,+ -- | How a node should be displayed. All properties covered in the+ -- \"Markup\" and \"Miscellaneous\" sections.+ markup :: Markup,+ -- | Unspecified properties. The keys in the map must contain only+ -- the characters A-Z (and must be upper-case). The values in the map+ -- may be more or less arbitrary, but any occurrence of the ASCII byte+ -- \']\' must be preceded by an odd number of copies of the ASCII byte+ -- \'\\\'. See also <http://www.red-bean.com/sgf/sgf4.html#2.2>+ unknown :: Map String [[Word8]]+ } deriving (Eq, Ord, Show, Read)++emptyGameNode :: GameNode move stone ruleSet extraGameInfo ()+emptyGameNode = GameNode Nothing (Left emptySetup) emptyAnnotation emptyMarkup Map.empty++-- | See also 'TreeGo' and 'Game'.+type NodeGo = GameNode MoveGo Point RuleSetGo GameInfoGo AnnotationGo+-- | See also 'TreeBackgammon' and 'Game'.+type NodeBackgammon = GameNode () () RuleSetBackgammon GameInfoBackgammon ()+-- | See also 'TreeLinesOfAction' and 'Game'.+type NodeLinesOfAction = GameNode () () Void GameInfoLinesOfAction ()+-- | See also 'TreeHex' and 'Game'.+type NodeHex = GameNode () () Void GameInfoHex ()+-- | See also 'TreeOcti' and 'Game'.+type NodeOcti = GameNode () () RuleSetOcti GameInfoOcti ()+-- | See also 'TreeOther' and 'Game'.+type NodeOther = GameNode [Word8] [Word8] Void () ()+-- }}}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2009 Daniel Wagner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ sgf.cabal view
@@ -0,0 +1,45 @@+name: sgf+version: 0.1+author: Daniel Wagner+maintainer: daniel@wagner-home.com+homepage: http://www.dmwit.com/sgf+bug-reports: http://dmwit.fogbugz.com/default.asp?command=new&pg=pgEditBug+synopsis: SGF (Smart Game Format) parser+description:+ This is a parser for the go\/igo\/weiqi\/baduk fragment of the SGF format.+ Encodings latin-1, utf-8, and ascii are supported, and the parser strives+ to be robust to minor errors, especially those made by the most common SGF+ editors. There are plans to support other games and pretty-printing in+ future releases.+category: Data+license: BSD3+license-file: LICENSE+cabal-version: >= 1.6+build-type: Simple++library+ exposed-modules: Data.SGF+ Data.SGF.Parse+ Data.SGF.Types++ other-modules: Data.SGF.Parse.Encodings+ Data.SGF.Parse.Raw+ Data.SGF.Parse.Util++ build-depends: base >=3 && < 4,+ containers,+ extensible-exceptions,+ mtl>=1,+ time>=1,+ parsec>=3,+ split,+ encoding>=0.6++source-repository head+ type: git+ location: http://www.dmwit.com/sgf++source-repository this+ type: git+ location: http://www.dmwit.com/sgf+ tag: 0.1