hstzaar-0.9: src/Serialize.hs

-- Serialization of Tzaar games to/from XML 
-- Pedro Vasconcelos, 2012
module Serialize where
import Data.Version
import Paths_hstzaar(version)
import Data.Maybe
import Text.XML.Light
import qualified Data.Map as Map
import Board

-- | convertion to/from XML elements
class ToXML a where
  toXML :: a -> Element
  
class FromXML a where  
  fromXML :: Element -> Maybe a


-- | wrapper for a piece together with a board position   
newtype PosPiece = PosPiece (Position, Piece) 
                 deriving (Eq,Show)

-- | wrapper for a list of moves from game start
newtype MoveList = MoveList [Move] deriving (Eq,Show)

-- | wrapper for numbered & labelled moves
newtype NumMove = NumMove (Int,Color,Move) deriving (Eq,Show)

instance Node PosPiece where
  node qn (PosPiece (pos,(c,k,h))) = add_attrs alist $ node qn ()
    where alist = [attr "color" (show c), 
                   attr "kind" (show k),
                   attr "height" (show h),
                   attr "position" (show pos)]

instance Node Move where
  node qn m = node qn $ Text (cdata $ showMove m)

instance Node NumMove where
  node qn (NumMove (n,c,m)) = add_attrs alist $ node qn $ Text (cdata $ showMove m)
    where alist = [attr "num" (show n), attr "color" (show c)]

instance Node MoveList where
  node qn (MoveList ms) = node qn $ map (Elem . node (unqual "move")) nms
    where nms = map NumMove (zip3 [1..] cs ms)
          cs = White : cycle [Black,Black,White,White]


instance Node Board where
  node qn b = node qn $ 
              map (Elem . node (unqual "piece") . PosPiece) $ 
              Map.assocs (pieces b)

instance Node Game where
  node qn g = add_attrs alist  $ 
              node qn [Elem (node (unqual "board") (initial g)),
                       Elem (node (unqual "moves") (MoveList ms))]
    where ms = reverse (trail g) ++ remain g -- all moves
          alist =[attr "version" (showVersion version),
                  attr "human" (show (human g))]


instance ToXML Game where
  toXML = node (unqual "hstzaar") 

instance FromXML Board where  
  fromXML el = return (initBoard assocs)
    where assocs = catMaybes
            [do { c<-readAttr (unqual "color") el' 
                ; k<-readAttr (unqual "kind") el'
                ; h<-readAttr (unqual "height") el'
                ; pos<-readAttr (unqual "position") el'
                ; return (pos,(c,k,h))
                } | el'<-findChildren (unqual "piece") el]
          

instance FromXML MoveList where
  fromXML el = Just (MoveList moves)
    where moves = catMaybes 
                  [ readMove (strContent el') 
                  | el'<-findChildren (unqual "move") el]


instance FromXML Game where
  fromXML el = do el1 <- findChild (unqual "board") el
                  el2 <- findChild (unqual "moves") el
                  c <- readAttr (unqual "human") el  -- human player color
                  b <- fromXML el1
                  MoveList ms <- fromXML el2
                  let g = initGame b c
                  let b' = foldr applyMoveSkip b (reverse ms)
                  return g { board=b', trail=reverse ms }


showXML :: ToXML a => a -> String
showXML a = ppTopElement (toXML a)

readXML :: FromXML a => String -> Maybe a
readXML txt = parseXMLDoc txt >>= fromXML 



-- | parse an attribute from an element
readAttr :: Read a => QName -> Element -> Maybe a          
readAttr name el = do txt<-findAttr name el 
                      case reads txt of
                        [] -> Nothing
                        (a,_):_ -> Just a


readMove :: String -> Maybe Move
readMove [a,b,'x',c,d] = do (from,_) <- listToMaybe (reads [a,b])
                            (to,_) <- listToMaybe (reads [c,d])
                            return (Capture from to)
  
readMove [a,b,'-',c,d] = do (from,_) <- listToMaybe (reads [a,b])
                            (to,_) <- listToMaybe (reads [c,d])
                            return (Stack from to)
readMove "pass"          = Just Pass  
readMove "skip"          = Just Skip
readMove _               = Nothing



-- | make an attribute with an unqualified name
attr :: String -> String -> Attr
attr n = Attr (unqual n) 

-- | make a cdata from a string
cdata :: String -> CData
cdata txt = CData CDataText txt Nothing