diff --git a/Data/SGF.hs b/Data/SGF.hs new file mode 100644 --- /dev/null +++ b/Data/SGF.hs @@ -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! +-} +-- }}} diff --git a/Data/SGF/Parse.hs b/Data/SGF/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/SGF/Parse.hs @@ -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 () "" . 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-\ 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 +-- }}} diff --git a/Data/SGF/Parse/Encodings.hs b/Data/SGF/Parse/Encodings.hs new file mode 100644 --- /dev/null +++ b/Data/SGF/Parse/Encodings.hs @@ -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 diff --git a/Data/SGF/Parse/Raw.hs b/Data/SGF/Parse/Raw.hs new file mode 100644 --- /dev/null +++ b/Data/SGF/Parse/Raw.hs @@ -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 diff --git a/Data/SGF/Parse/Util.hs b/Data/SGF/Parse/Util.hs new file mode 100644 --- /dev/null +++ b/Data/SGF/Parse/Util.hs @@ -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 +-- }}} +-- }}} diff --git a/Data/SGF/Types.hs b/Data/SGF/Types.hs new file mode 100644 --- /dev/null +++ b/Data/SGF/Types.hs @@ -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 +-- ). 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 + -- + = TeamName Color + -- | See also the PB and PW properties at + -- + | PlayerName Color + -- | The name of the person who annotated the game. See also + -- + | Annotator + -- | The name of the source, e.g. the title of the book this game came from. + -- See also + | Source + -- | The name of the person or program who entered the game. See also + -- + | User + -- | See also + | Copyright + -- | Background information or a summary of the game. See also + -- + | Context + -- | Where the game was played. See also + -- + | 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 + -- + | Event + -- | An easily-remembered moniker for the game. See also + -- + | GameName + -- | A description of the opening moves using the game's vernacular. See + -- also + | Opening + -- | The overtime rules. See also + -- + | Overtime + deriving (Eq, Ord, Show, Read) + +-- | See also 'GameTree' and +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 +-- +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 +-- +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 +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 +-- +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 + -- + 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 + illegal :: FuzzyBool, + -- | When @Just@, set the current move number. See also + -- + 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 + -- + quality :: Maybe Quality, + -- | Time remaining, in seconds, for the black player after this move + -- was made. See also + timeBlack :: Maybe Rational, + -- | Time remaining, in seconds, for the white player after this move + -- was made. See also + timeWhite :: Maybe Rational, + -- | Number of overtime moves left for the black player after this move + -- was made. See also + overtimeMovesBlack :: Maybe Integer, + -- | Number of overtime moves left for the white player after this move + -- was made. See also + 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 + -- + 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 + -- + addWhite :: Set stone, + -- | This node specifies locations of the board to clear. See also + -- + remove :: Set Point, + -- | Specify which player should move next. See also + -- + 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 + -- + rankBlack :: Maybe Rank, + -- | The strength of the white player. See also + -- + rankWhite :: Maybe Rank, + -- | When the game was played. An empty set indicates that no date + -- information is available. See also + -- + date :: Set PartialDate, + -- | The round number (for games played in a tournament). See also + -- + round :: Maybe Round, + -- | The ruleset used for this game. See also + -- + ruleSet :: Maybe (RuleSet ruleSet), + -- | The time limit of the game in seconds. See also + -- + timeLimit :: Maybe Rational, + -- | How the game ended. See also + -- + 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 + handicap :: Maybe Integer, + -- | See also + 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 +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 + -- + 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 + -- + invertYAxis :: Bool, + -- | The initial placement of pieces and rule variation. See also + -- + 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 +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 + -- + 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 + -- + squaresBlack :: Set Point, + -- | How many prongs each player starts with. See also + -- + prongs :: Integer, + -- | How many pods each player has in reserve to start with. See also + -- + reserve :: Integer, + -- | How many superprongs each player starts with. See also + -- + 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 + -- + comment :: Maybe String, + -- | A very short description of the node. Must not contain newlines. + -- See also + name :: Maybe String, + -- | When @Just@, this node contains something interesting. Viewers + -- should show a message. See also + -- + hotspot :: Maybe Emphasis, + -- | A quantitative full-board positional judgment. Positive values are + -- good for black, negative for white. See also + -- + value :: Maybe Rational, + -- | A qualitative full-board positional judgment. See also the GB, GW, + -- DM, and UC properties at + -- + 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 +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 + -- + marks :: Map Point Mark, + -- | Typically, the @String@s will be single letters, but that is not + -- guaranteed. Labels must not contain newlines. See also + -- + labels :: Map Point String, + -- | Arrows must not start and end at the same point. See also + -- + 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 + -- + lines :: Set (Point, Point), + -- | Shade out (exactly) the given points. This property is inherited, + -- defaulting to @Set.empty@. See also + -- + 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 + -- + visible :: Maybe (Set Point), + -- | How move numbers should be printed on the board. This property is + -- inherited, defaulting to @Numbered@. See also + -- + numbering :: Maybe Numbering, + -- | When @Just@, a new diagram should begin at this move. See also + -- + 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 + 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 + -- + 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 + -- + 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 + -- + | 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 + 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 () () +-- }}} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/sgf.cabal b/sgf.cabal new file mode 100644 --- /dev/null +++ b/sgf.cabal @@ -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