hipe-0.2.0.0: src/Data/Geometry/Ipe/Pickle.hs
{-# Language FlexibleInstances,
OverloadedStrings
#-}
module Data.Geometry.Ipe.Pickle( Coordinate(..)
, loadFile
, storeFile
, loadFileA
, storeFileA
, unpickle
, xpLoadSettings
, xpStoreSettings
)
where
import Numeric
import Control.Arrow
import Control.Applicative((<$>))
import Data.Ratio
import Data.Maybe
import Data.Geometry.Point
import Data.Geometry.Geometry
import Data.Geometry.Ipe.InternalTypes
import Text.Parsec
import Text.Parsec.String
import Data.Text.Lazy(Text)
import Data.Text.Format
import Data.Tree.NTree.TypeDefs
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 (Fractional a, Ord a) => Coordinate a where
toIpeOut :: a -> String
fromSeq :: Integer -> Maybe Integer -> a
fromSeq x Nothing = fromInteger x
fromSeq x (Just y) = let x' = fromInteger x
y' = fromInteger y
asDecimal = head . dropWhile (>= 1) . iterate (* 0.1) in
signum x' * (abs x' + asDecimal y')
instance Coordinate Double where
toIpeOut = show
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 (IpePage a) where
xpickle = xpPage
instance Coordinate a => XmlPickler (IpeFile a) where
xpickle = xpIpeFile
instance XmlPickler ViewDefinition where
xpickle = xpViewDefinition
-----------------------------------------------------------------------
-- | Load an ipe drawing from a file
loadFile :: Coordinate a => FilePath -> IO (IpeFile a)
loadFile path = do
[d] <- unpickle xpIpeFile path
return d
unpickle :: PU a -> FilePath -> IO [a]
unpickle p path = runX $ xunpickleDocument p xpLoadSettings path
-- | Store an ipe drawing in a file
storeFile :: Coordinate a => IpeFile a -> FilePath -> IO ()
storeFile ipeFile path =
do
runX $ constA ipeFile >>> xpickleDocument xpIpeFile 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
]
--------
-- Arrow versions of the stuff above
loadFileA :: Coordinate a => Kleisli IO FilePath (IpeFile a)
loadFileA = Kleisli loadFile
storeFileA :: Coordinate a => FilePath -> Kleisli IO (IpeFile a) ()
storeFileA path = Kleisli (flip storeFile path)
-----------------------------------------------------------------------
xpIpeFile :: Coordinate a => PU (IpeFile a)
xpIpeFile = xpElem "ipe" $
xpWrap ( \(version,creator,date,bitmaps,p,s,ps) -> IpeFile p s ps
, \(IpeFile p s ps) -> ( "70005" -- ipe version
, Just "hipe" -- Creator
, Nothing -- don't generate an info field
, [] -- don't generate bitmaps
, p -- latex preamble
, s -- ipestyles
, ps -- pages
)
) $
xp7Tuple (xpTextAttr "version")
(xpTextAttrImplied "creator")
(xpOption $ xpElem "info" xpVarTextAttrs)
(xpList xpBitmap)
(xpOption xpPreamble)
(xpList xpIpeStyle)
(xpList xpPage)
xpIpeStyle :: PU IpeStyle
xpIpeStyle = xpElem "ipestyle" $
xpWrap ( uncurry IpeStyle
, \(IpeStyle name content) -> (name,content)) $
xpPair (xpTextAttrImplied "name") xpTrees
xpPreamble :: PU IpePreamble
xpPreamble = xpElem "preamble" $
xpWrap ( uncurry IpePreamble
, \(IpePreamble enc cont) -> (enc,cont)
) $
xpPair (xpTextAttrImplied "encoding") xpTree
xpBitmap :: PU IpeBitmap
xpBitmap = xpElem "bitmap" xpTree
xpPage :: Coordinate a => PU (IpePage a)
xpPage = xpElem "page" $
xpWrap ( \(lrs,vws,obs) -> IpePage lrs vws (markWithlayers "alpha" obs)
, \(IpePage 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 = UP $ \st ->
(Right . M.fromList . mapMaybe toPair . attributes $ st, st {attributes = []})
, theSchema = theSchema xpText -- schema is not used here I guess
} where
addAtt' k v = putAtt (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) = let st = emptySt { contents = chs} in
case fst . runUP (appUnPickle xpText) $ st of
(Left _) -> Nothing
(Right s) -> Just (localPart qn, s)
xpTextAttrImplied :: String -> PU (Maybe String)
xpTextAttrImplied s = xpAttrImplied s xpText
-- -- | Tree picklers that consume the attributes as well
-- xpTree' :: PU XmlTree
-- xpTree' = PU { appPickle = putCont
-- , appUnPickle = UP $ \st ->
-- let (e,st') = runUP getCont st
-- (as,st'') = getAtts st' in
-- (e, st'')
-- , theSchema = theSchema xpTree
-- }
-- where
-- getAtts st = (attributes st, st { attributes = []})
-- appendChs (NTree x chs') ys = NTree x (ys ++ chs')
-- xpTrees' = (xpList xpTree' ) { theSchema = theSchema xpTrees }
-----------------------------------------------------------------------
-- 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"