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
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 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
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
storeFile :: Coordinate a => IpeFile a -> FilePath -> IO ()
storeFile ipeFile path =
do
runX $ constA ipeFile >>> xpickleDocument xpIpeFile xpStoreSettings path
return ()
xpLoadSettings :: [SysConfig]
xpLoadSettings = [ withRemoveWS yes
, withValidate no
]
xpStoreSettings :: [SysConfig]
xpStoreSettings = [ withIndent yes
, withAddDefaultDTD yes
]
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"
, Just "hipe"
, Nothing
, []
, p
, s
, ps
)
) $
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")
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 {attributes = []})
, 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)
xpTextAttrImplied :: String -> PU (Maybe String)
xpTextAttrImplied s = xpAttrImplied s xpText
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"