Parsing SGF format ( http://www.red-bean.com/sgf/ )

SGFParser.hs

import Control.Applicative ((<$>), (*>), (<*))
import Text.Parsec (many1, option, oneOf, spaces, upper, char, digit,
                    noneOf, parseTest, (<|>))
import Text.Parsec.String (Parser, parseFromFile)
import Data.Char (ord)

import Prelude hiding (sequence, seq)

-- data Collection = Collection [GameTree] deriving Show
data GameTree = GameTree { seq::Sequence, subtrees::[GameTree] } deriving Show
data Sequence = Sequence { nodes::[Node] } deriving Show
data Node = Node { props::[Property] } deriving Show
data Property = FF Number
              | GM Number
--              | AP SimpleText SimpleText
              | AP SimpleText
              | SZ Number
--              | SZ_C Number Number
              | PB SimpleText
              | BR SimpleText
              | PW SimpleText
              | WR SimpleText
              | DT SimpleText
              | RE SimpleText
--              | KM Real
              | KM Number
              | B { m::Move }
              | W { m::Move }
              | C Text
                deriving Show
data Move = Move { x::Int, y::Int } deriving Show
data Number = Number Int deriving Show
-- data Real = Real Double deriving Show
data SimpleText = SimpleText String deriving Show
data Text = Text String deriving Show

gameTree :: Parser GameTree
gameTree = do
  char '(' >> spaces
  root <- sequence
  branches <- option [] $ many1 gameTree
  spaces >> char ')' >> spaces
  return $ GameTree root branches

sequence :: Parser Sequence
sequence = Sequence <$> many1 node <* spaces

node :: Parser Node
node = char ';' *> spaces *> (Node <$> option [] (many1 property)) <* spaces

property :: Parser Property
property = do
  id <- many1 upper <* spaces
  case id of
    "FF" -> FF <$> number
    "GM" -> GM <$> number
    -- "AP" -> AP <$> (compose simpleText simpleText)
    "AP" -> AP <$> simpleText
    -- "SZ" -> SZ <$> number <|> propCValue (compose number number)
    "SZ" -> SZ <$> number
    "PB" -> PB <$> simpleText
    "BR" -> BR <$> simpleText
    "PW" -> PW <$> simpleText
    "WR" -> WR <$> simpleText
    "DT" -> DT <$> simpleText
    "RE" -> RE <$> simpleText
    -- "KM" -> KM <$> real
    "KM" -> KM <$> number
    "B" -> B <$> move
    "W" -> W <$> move
    "C" -> C <$> text

-- propCValue :: Parser Compose -> Parser PropValue
-- propCValue p = char '[' *> (PropCValue <$> p) <* char ']' <* spaces

propValue :: Parser a -> Parser a
propValue p = char '[' *> p <* char ']' <* spaces

move :: Parser Move
move = propValue move'
    where
      move' = do
        x <- oneOf ['a'..'s']
        y <- oneOf ['a'..'s']
        return $ Move (charToInt x) (charToInt y)
      charToInt c = ord c - ord 'a'

number :: Parser Number
number = propValue $ Number . read <$> many1 digit

-- real :: Parser Real
-- real = undefined

simpleText :: Parser SimpleText
simpleText = propValue $ SimpleText <$> (many1 $ noneOf "]")

text :: Parser Text
text = propValue $ Text <$> (many1 $ noneOf "]")

-- compose :: Parser ValueType -> Parser ValueType -> Parser Compose
-- compose p1 p2 = do
--   v1 <- p1
--   Compose v1 <$> (char ':' *> p2)

getGameTreeFromFile :: IO GameTree
getGameTreeFromFile = do
  egt <- parseFromFile gameTree "hikago002b.sgf"
  case egt of
    (Right gt) -> return gt
    _ -> error "fail"

getMoves :: GameTree -> [Property]
getMoves gt = filter isMove $ props =<< nodes (seq gt)
    where isMove (W _) = True
          isMove (B _) = True
          isMove _ = False

cppexpr :: Property -> String
cppexpr p = "Turn(Point(" ++
            (show $ x $ m p) ++ ", " ++
            (show $ y $ m p) ++ "), " ++ c p ++ ")"
    where c (W _) = "color_t::white"
          c (B _) = "color_t::black"

main = do
  gt <- getGameTreeFromFile
  let (e:es) = map cppexpr $ getMoves gt
  putStrLn (' ':e)
  mapM_ (putStrLn . (',':)) es