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
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 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
loadDrawing :: Coordinate a => FilePath -> IO (IpeDrawing a)
loadDrawing path = do
[d] <- runX $ xunpickleDocument xpIpeDrawing xpLoadSettings path
return d
storeDrawing :: Coordinate a => IpeDrawing a -> FilePath -> IO ()
storeDrawing drawing path =
do
runX $ constA drawing >>> xpickleDocument xpIpeDrawing xpStoreSettings path
return ()
xpLoadSettings :: [SysConfig]
xpLoadSettings = [ withRemoveWS yes
, withValidate no
]
xpStoreSettings :: [SysConfig]
xpStoreSettings = [ withIndent yes
, withAddDefaultDTD yes
]
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"
, Nothing
, []
, p
, s
, ps
)
) $
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")
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
xpIpeUse :: Coordinate a => PU (IpeObject a)
xpIpeUse = xpElem "use" $
xpWrap ( fromMap
, \(Use p a) -> M.insert "pos" (toString p) a
)
xpVarTextAttrs
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
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
xpVarTextAttrs :: PU AMap
xpVarTextAttrs = PU { appPickle = \m st -> M.foldrWithKey addAtt' st m
, appUnPickle = UP $ \st ->
(Right . M.fromList . mapMaybe toPair . attributes $ st, st)
, theSchema = theSchema xpText
} where
addAtt' k v = putAtt (mkName k) (txt v)
txt v = contents $ appPickle xpText v emptySt
toPair :: XmlTree -> Maybe (String,String)
toPair t@(XN.NTree (XAttr qn) chs) = let st = emptySt { contents = chs} in
case fst . runUP (appUnPickle xpText) $ st of
(Left _) -> Nothing
(Right s) -> Just (localPart qn, s)
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
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
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
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
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"