Pickle.hs

{-# Language FlexibleInstances,
             OverloadedStrings
 #-}
module Data.Geometry.Ipe.Pickle ( loadDrawing
                                , storeDrawing
                                , Coordinate(..)
                                ) where

import Numeric

import Control.Applicative((<$>))

import Data.Ratio
import Data.Maybe

import Data.Geometry.Point
import Data.Geometry.Geometry
import Data.Geometry.Ipe.IpeTypes



import Text.Parsec
import Text.Parsec.String

import Data.Text.Lazy(Text)
import Data.Text.Format

import Text.XML.HXT.Arrow.Pickle
import Text.XML.HXT.Arrow.Pickle.Xml
import Text.XML.HXT.Core hiding (trace)

import qualified Data.Map as M
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Data.Text.Lazy as T

-----------------------------------------------------------------------

-- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read)

class Num a => Coordinate a where
    toIpeOut   :: a -> String
    fromSeq    :: Integer -> Maybe Integer -> a

instance Coordinate Double where
    toIpeOut = show
    fromSeq x Nothing  = fromInteger x
    fromSeq x (Just y) = read $ show x ++ "." ++ show y

instance Coordinate (Ratio Integer) where
    toIpeOut r = show (fromRat r :: Double)
    fromSeq x  Nothing = fromInteger x
    fromSeq x (Just y) = fst . head $ readSigned readFloat (show x ++ "." ++ show y)

-----------------------------------------------------------------------
-- instance declarations for parsing ipe stuff

instance Coordinate a => XmlPickler (IpeObject a) where
    xpickle = xpIpeObject

instance Coordinate a => XmlPickler (Page a) where
    xpickle = xpPage

instance Coordinate a => XmlPickler (IpeDrawing a) where
    xpickle = xpIpeDrawing


instance XmlPickler ViewDefinition where
    xpickle = xpViewDefinition


-----------------------------------------------------------------------

-- | Load an ipe drawing from a file
loadDrawing      :: Coordinate a => FilePath -> IO (IpeDrawing a)
loadDrawing path = do
  [d] <- runX $ xunpickleDocument xpIpeDrawing xpLoadSettings path
  return d


-- | Store an ipe drawing in a file
storeDrawing              :: Coordinate a => IpeDrawing a -> FilePath -> IO ()
storeDrawing drawing path =
    do
      runX $ constA drawing >>> xpickleDocument xpIpeDrawing xpStoreSettings path
      return ()

xpLoadSettings :: [SysConfig]
xpLoadSettings = [ withRemoveWS yes   -- remove redundant whitespace
                 , withValidate no    -- don't validate source
                 ]

xpStoreSettings :: [SysConfig]
xpStoreSettings = [ withIndent yes        -- indent XML
                  , withAddDefaultDTD yes   -- add a default DTD
                  ]


-----------------------------------------------------------------------

xpIpeDrawing :: Coordinate a => PU (IpeDrawing a)
xpIpeDrawing = xpElem "ipe" $
               xpWrap ( \(version,date,bitmaps,p,s,ps) -> Ipe p s ps
                      , \(Ipe p s ps) -> ( "70005" -- ipe version
                                         , Nothing -- don't generate an info field
                                         , []      -- don't generate bitmaps
                                         , p       -- latex preamble
                                         , s       -- ipestyles
                                         , ps      -- pages
                                         )
                      ) $
               xp6Tuple (xpTextAttr "version")
                        (xpOption $ xpElem "info" $ xpTextAttr "created")
                        (xpList   $ xpElem "bitmap" xpTrees)
                        (xpOption $ xpElem "preamble" xpTree)
                        (xpList xpIpeStyle)
                        (xpList xpPage)


xpIpeStyle :: PU [XmlTree]
xpIpeStyle = xpElem "ipestyle" xpTrees

xpPage :: Coordinate a => PU (Page a)
xpPage = xpElem "page" $
         xpWrap ( \(lrs,vws,obs) -> Page lrs vws (markWithlayers "alpha" obs)
                , \(Page lrs vws obs) -> (lrs,vws,obs)
                ) $
         xpTriple (xpList xpLayerDefinition)
                  (xpList xpViewDefinition)
                  (xpList xpIpeObject)


markWithlayers              :: HasAttributes a => String -> [a] -> [a]
markWithlayers lrName []    = []
markWithlayers lrName (o:obs)
               | hasLayer o = o : markWithlayers (getLayer o) obs
               | otherwise  = markOb lrName o : markWithlayers lrName obs
    where
      hasLayer      = M.member "layer" . attrs
      getLayer      = fromJust . M.lookup "layer" . attrs
      markOb lrName = updateWith (M.insert "layer" lrName)






xpLayerDefinition :: PU String
xpLayerDefinition = xpElem "layer" $
                    xpTextAttr "name"

xpViewDefinition :: PU ViewDefinition
xpViewDefinition = xpElem "view" $
                   xpWrap ( \(lrs,a) -> ViewDefinition (words lrs) a
                          , \vd -> (unwords $ layerNames vd, activeLayer vd)
                          ) $
                   xpPair (xpTextAttr "layers") (xpTextAttr "active")



-- | Pickler for ipe objects

xpIpeObject :: Coordinate a => PU (IpeObject a)
xpIpeObject = xpWrap (applyMatrix,id) $ xpAlt tag ps
    where
      tag (Path _ _)    = 0
      tag (Group _ _)   = 1
      tag (IpeText _ _) = 2
      tag (Use _ _)     = 3
      ps = [ xpPath, xpGroup, xpIpeText , xpIpeUse ]

xpGroup :: Coordinate a => PU (IpeObject a)
xpGroup = xpElem "group" $
          xpWrap ( uncurry Group
                 , \(Group o a) -> (o,a)) $
          xpPair (xpList xpIpeObject) xpVarTextAttrs


xpIpeText :: PU (IpeObject a)
xpIpeText = xpElem "text" $
            xpWrap ( uncurry IpeText
                   , \(IpeText s a) -> (s,a)) $
            xpPair xpText xpVarTextAttrs


applyMatrix :: Coordinate a => IpeObject a -> IpeObject a
applyMatrix o = transformWith m . extractAttr "matrix" $ o
    where
      m          = fromMaybe identityMatrix3 . fmap readMatrix . getAttr "matrix" $ o

-----------------------------------------------------------------------
-- | pickler for symbols (use)

xpIpeUse :: Coordinate a => PU (IpeObject a)
xpIpeUse = xpElem "use" $
           xpWrap ( fromMap
                  , \(Use p a) -> M.insert "pos" (toString p) a
                  )
           xpVarTextAttrs

-- use the information in an AMap to construct a symbol
fromMap       :: Coordinate a => AMap -> IpeObject a
fromMap attrs = Use p attrs'
    where
      at     = M.lookup "pos" attrs
      p      = fromMaybe (Point2 (0,0)) $ readPoint =<< at
      attrs' = M.update (const at) "pos" attrs

-----------------------------------------------------------------------
-- | Pickler for paths

xpPath :: Coordinate a => PU (IpeObject a)
xpPath = xpElem "path" $
         xpWrap ( \(opStr, attrs)   -> Path (readPathOperations opStr) attrs
                , \(Path ops attrs) -> (opsString ops, attrs)
                ) $
         xpPair xpText xpVarTextAttrs

-----------------------------------------------------------------------
-- | Pickler that pickles an AMap into attributes

xpVarTextAttrs :: PU AMap
xpVarTextAttrs = PU { appPickle   = \(m,st) -> M.foldrWithKey addAtt' st m
                    , appUnPickle = \st ->
                                    (Just . M.fromList . mapMaybe toPair . attributes $ st, st)
                    , theSchema   = theSchema xpText -- schema is not used here I guess
                    } where
    addAtt' k v      = addAtt $ XN.mkAttr (mkName k) (txt v)
    txt v            = contents $ appPickle xpText (v, emptySt)


-- | Get the name and the value from this attribute
toPair   :: XmlTree -> Maybe (String,String)
toPair t@(XN.NTree (XAttr qn) chs) = do
  v <- fst . appUnPickle xpText $ St { attributes = []
                                     , contents   = chs}
  return (localPart qn, v)

-----------------------------------------------------------------------
-- Parsing stuff starts here

-- for parsing the position in a symbol
readPoint   :: Coordinate a => String -> Maybe (Point2' a)
readPoint s = case parse point "" s of
                Left  _ -> Nothing
                Right p -> Just p

readPathOperations :: Coordinate a => String -> [Operation a]
readPathOperations s = case parse path "" s of
                         Left  err -> error $ show err
                         Right ops -> ops


path :: Coordinate a => Parser [Operation a]
path = do many (newline <|> space)
          line `sepEndBy` newline

line :: Coordinate a => Parser (Operation a)
line = close <|> do pts <- many1 (do { p <- point ; space ; return p })
                    operation pts

operation :: Coordinate a => [Point2' a] -> Parser (Operation a)
operation pts
          | length pts == 1 = let [p]     = pts in moveTo p <|> lineTo p
          | length pts == 2 = let [p,q]   = pts in qCurveTo p q
          | length pts == 3 = let [p,q,r] = pts in curveTo p q r
-- TODO: Otherwise

moveTo :: Coordinate a => Point2' a -> Parser (Operation a)
moveTo p = char 'm' >> return (MoveTo p)


lineTo :: Coordinate a => Point2' a -> Parser (Operation a)
lineTo p = char 'l' >> return (LineTo p)


qCurveTo :: Coordinate a => Point2' a -> Point2' a -> Parser (Operation a)
qCurveTo p q = char 'q' >> return (QCurveTo p q)


curveTo :: Coordinate a => Point2' a -> Point2' a -> Point2' a -> Parser (Operation a)
curveTo p q r = char 'c' >> return (CurveTo p q r)


close :: Parser (Operation a)
close = char 'h' >> return ClosePath

point ::  Coordinate a => Parser (Point2' a)
point = do { x <- coord
           ; space
           ; y <- coord
           ; return $ Point2 (x,y)
           }


coord :: Coordinate a => Parser a
coord = uncurry fromSeq <$> do s <- option 1 (char '-' >> return (-1))
                               x <- int
                               y <- optionMaybe (char '.' >> int)
                               return (s*x,y)

int :: Parser Integer
int = read <$> many1 digit


-- | Read the matrix:
-- Our matrix has the following order of doubles:
-- 012
-- 345
--
-- But ipe uses the following order:
-- 024
-- 135
readMatrix   :: Coordinate a => String -> Matrix3 a
readMatrix s = case parse matrixAttr "" s of
                 Left  err           -> error $ show err
                 Right [a,b,c,d,e,f] -> matrix3FromLists [ [a, c, e]
                                                         , [b, d, f]
                                                         , [0, 0, 1]]
                 Right xs            -> error (
                                          "matrix with wrong number of elems: "
                                          ++ (show $ length xs))


matrixAttr :: Coordinate a => Parser [a]
matrixAttr = coord `sepBy` space

-----------------------------------------------------------------------
-- | Write ipe stuff


class IsIpeWriteable c where
    toOnly :: Coordinate a => c a -> Only Text
    toOnly = Only . toText
    toText :: Coordinate a => c a -> Text

    toString  :: Coordinate a => c a -> String
    toString = T.unpack . toText

    textSepBy        :: Coordinate a => [c a] -> Text -> Text
    xs `textSepBy` s =  T.intercalate s . map toText $ xs


instance IsIpeWriteable Matrix3 where
    -- | Note, we only use the first 6 values (the first two rows)
    --   furthermore, the order of the ipe matrices is switched again.
    toText m = let [[a,b,c],[d,e,f],_] = matrix3ToLists m
                   ipeM                = [a, c, e, b, d, f] in
               T.intercalate " " . map (T.pack . toIpeOut) $ ipeM


instance IsIpeWriteable Point2' where
    toText (Point2 (x,y)) = format "{} {}" $ map toIpeOut [x,y]


instance IsIpeWriteable Operation where
    toText (MoveTo p)         = format "{} m"       $ toOnly p
    toText (LineTo p)         = format "{} l"       $ toOnly p
    toText (CurveTo p q r)    = format "{} {} {} c" $ map toText [p,q,r]
    toText (QCurveTo p q)     = format "{} {} q"    $ map toText [p,q]
    toText (Ellipse m)        = format "{} e"       $ toOnly m
    toText (ArcTo m p)        = format "{} {} a"      [toText m , toText p]
    toText (Spline pts)       = format "{} u"       $ Only $ pts `textSepBy` " "
    toText (ClosedSpline pts) = format "{} u"       $ Only $ pts `textSepBy` " "
    toText ClosePath          = "h"

opsString     :: Coordinate a => [Operation a] -> String
opsString ops = T.unpack $ "\n" `T.append` (ops `textSepBy` "\n") `T.append` "\n"