hipe (empty) → 0.1.0.0
raw patch · 11 files changed
+1130/−0 lines, 11 filesdep +basedep +containersdep +hgeometrysetup-changed
Dependencies added: base, containers, hgeometry, hxt, parsec, split, text, text-format
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hipe.cabal +71/−0
- src/Data/Geometry/Ipe/IGC.hs +66/−0
- src/Data/Geometry/Ipe/IpeGeometry.hs +96/−0
- src/Data/Geometry/Ipe/IpeGeometryTypes.hs +93/−0
- src/Data/Geometry/Ipe/IpeTypes.hs +129/−0
- src/Data/Geometry/Ipe/IpeView.hs +44/−0
- src/Data/Geometry/Ipe/Pickle.hs +367/−0
- src/Data/Geometry/Ipe/ReadIpeGeometry.hs +151/−0
- src/Data/Geometry/Ipe/WriteIpeGeometry.hs +81/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Frank Staals++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Frank Staals nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hipe.cabal view
@@ -0,0 +1,71 @@+-- Initial hipe.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: hipe++-- The package version. See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Support for reading and writing ipe7 files (http://ipe7.sourceforge.net)++-- A longer description of the package.+description: A package to support reading and writing ipe7 files. It has support for converting from and to several geometry types like Points, (Poly)Lines, Polygons etc.++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Frank Staals++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer: f.staals@uu.nl++-- A copyright notice.+-- copyright:++category: Geometry++build-type: Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.8++library+ -- Specify where we can find the source code+ Hs-source-dirs: src++ GHC-Options: -Wall++ -- Modules exported by the library.+ exposed-modules: Data.Geometry.Ipe.IpeGeometry+ , Data.Geometry.Ipe.ReadIpeGeometry+ , Data.Geometry.Ipe.WriteIpeGeometry+ , Data.Geometry.Ipe.IpeTypes+ , Data.Geometry.Ipe.IpeGeometryTypes+ , Data.Geometry.Ipe.IGC+ , Data.Geometry.Ipe.IpeView+ , Data.Geometry.Ipe.Pickle++ -- Modules included in this library but not exported.+ -- other-modules:++ -- Other library packages from which modules are imported.+ build-depends: base >= 4.3 && < 5+ , containers >= 0.4.2.1+ , hxt == 9.1.5+ , hgeometry >= 0.1+ , parsec >= 3+ , split >= 0.1.4.2+ , text-format >= 0.3.0.7+ , text >= 0.11.2.0
+ src/Data/Geometry/Ipe/IGC.hs view
@@ -0,0 +1,66 @@+module Data.Geometry.Ipe.IGC( IGC(..)+ , IsIpeGeometry(..)+ , empty+ , singleton+ , fromList+ ) where++import Data.Geometry.Ipe.IpeGeometryTypes+import Data.Monoid++-- | an ipe geometry collection+data IGC a = IGC { name :: String+ , points :: [IpePoint' a]+ , polyLines :: [IpePolyline' a]+ , simplePolygons :: [IpeSimplePolygon' a]+ , multiPolygons :: [IpeMultiPolygon' a]+ }+ deriving (Show,Eq)+++instance Monoid (IGC a) where+ mempty = empty+ mappend = merge+++empty :: IGC a+empty = IGC "" [] [] [] []++-- merge/concatenate the two collections. Take the name of the first one+merge :: IGC a -> IGC a -> IGC a+merge (IGC n pts pll sps mps) (IGC _ pts' pll' sps' mps') =+ IGC n (pts ++ pts') (pll ++ pll') (sps ++ sps') (mps ++ mps')+++-- | Stuff that we can store in a IpGeometryCollection+class IsIpeGeometry g where+ insert :: g a -> IGC a -> IGC a+ -- | shorhand for insert+ (<|) :: g a -> IGC a -> IGC a+ g <| c = insert g c++ insertAll :: [g a] -> IGC a -> IGC a+ insertAll gs col = foldr insert col gs++instance IsIpeGeometry IpePoint' where+ insert p (IGC n pts pll sps mps) =+ IGC n (p:pts) pll sps mps++instance IsIpeGeometry IpePolyline' where+ insert p (IGC n pts pll sps mps) =+ IGC n pts (p:pll) sps mps+++instance IsIpeGeometry IpeSimplePolygon' where+ insert p (IGC n pts pll sps mps) =+ IGC n pts pll (p:sps) mps++instance IsIpeGeometry IpeMultiPolygon' where+ insert p (IGC n pts pll sps mps) =+ IGC n pts pll sps (p:mps)++singleton :: IsIpeGeometry g => g a -> IGC a+singleton g = g <| empty++fromList :: IsIpeGeometry g => [g a] -> IGC a+fromList = flip insertAll empty
+ src/Data/Geometry/Ipe/IpeGeometry.hs view
@@ -0,0 +1,96 @@+module Data.Geometry.Ipe.IpeGeometry( RunWith(..)+ , runSimple+ , runSimple'+ , runSimpleIO+ , runSimpleIO'+ ) where+++import Data.Monoid++import Data.Geometry.Ipe.IpeTypes+import Data.Geometry.Ipe.IpeView+import Data.Geometry.Ipe.IGC(IGC)+import Data.Geometry.Ipe.ReadIpeGeometry+import Data.Geometry.Ipe.WriteIpeGeometry+import Data.Geometry.Ipe.Pickle++-- | A class expressing that we can run a computation on the data stored in+-- this part of the ipe drawing. A minimum implementation implements+-- replaceIGC and extend.+class IsConvertableToIGC c => RunWith c where+ -- | given a IGC, replace whatever I'm storing with the contents of the IGC+ replaceIGC :: Eq a => IGC a -> c a -> c a+ -- | add everything from the given IGC to whatever I'm storing allready.+ extend :: Eq a => IGC a -> c a -> c a++ -- | Given a function, run the function on my contents, and replace my contents+ -- with the results.+ runAndReplace :: Eq a => (IGC a -> IGC a) -> c a -> c a+ runAndReplace f o = let gc' = f . toIGC $ o in+ replaceIGC gc' o++ -- | Given a function, run the computation on my contents, and replace my contents+ -- with te results.+ runWith :: Eq a => (IGC a -> IGC a) -> c a -> c a+ runWith = runAndReplace++ -- | Given a function, run the computation on my contents, and store the result+ -- together with the stuff I'm allready storing.+ runAndExtend :: Eq a => (IGC a -> IGC a) -> c a -> c a+ runAndExtend f o = let gc = toIGC o+ gc' = f gc in+ extend (gc `mappend` gc') o+++instance RunWith Layer where+ replaceIGC gc (Layer n _) = Layer n gc+ -- | we do not really add stuff to this layer, but create a copy containing+ -- our stuff together with the new stuff.+ extend gc (Layer n _) = Layer (n++"'") gc+++instance RunWith ViewInstance where+ -- | replace the contents from the first layer, and drop the rest of the layers+ replaceIGC gc v = let l@(Layer n _) = head . layers $ v in+ ViewInstance (ViewDefinition [n] n) [replaceIGC gc l]+ extend gc v = let l = head . layers $ v in+ addLayer (extend gc l) v++instance RunWith Page where+ replaceIGC gc _ = Page [] [] (toIpeObjects' gc)+ extend gc p = let v = head . ipeViews $ p in+ addToPage (extend gc v) p++instance RunWith IpeDrawing where+ replaceIGC gc (Ipe pre sty []) = Ipe pre sty [extend gc emptyPage]+ replaceIGC gc (Ipe pre sty (p:_)) = Ipe pre sty [replaceIGC gc p]++ extend gc (Ipe pre sty []) = Ipe pre sty [extend gc emptyPage]+ extend gc (Ipe pre sty (p:pgs)) = Ipe pre sty $ extend gc p : pgs+++-- | shorthand to run a computation on a given drawing, and extend the input+-- drawing with the results+runSimple :: Eq a => (IGC a -> IGC a) -> IpeDrawing a -> IpeDrawing a+runSimple = runAndExtend++-- | Run a computation on an Ipe drawing+runSimple' :: (IGC a -> b) -> IpeDrawing a -> b+runSimple' f = f . toIGC+++-- | Load an drawing from a file path, and run the given computation on it.+runSimpleIO :: (Eq a, Coordinate a) =>+ (IGC a -> IGC a) -> FilePath -> IO (IpeDrawing a)+runSimpleIO f = fmap (runSimple f) . loadDrawing+++-- | runSimpleIO' f inPath outPath runs loads a drawing from inPath, runs+-- function f on it, extending the drawing with the result. The resulting+-- drawing is stored in as outPath.+runSimpleIO' :: (Eq a, Coordinate a) =>+ (IGC a -> IGC a) -> FilePath -> FilePath -> IO ()+runSimpleIO' f inPath outPath = do+ d <- loadDrawing inPath+ storeDrawing (runSimple f d) outPath
+ src/Data/Geometry/Ipe/IpeGeometryTypes.hs view
@@ -0,0 +1,93 @@+module Data.Geometry.Ipe.IpeGeometryTypes where++import Data.Geometry.Point+import Data.Geometry.Line+import Data.Geometry.Polygon+import Data.Geometry.Geometry+import Data.Geometry.Ipe.IpeTypes++import qualified Data.Map as M+++--------------------------------------------------------------------------------------+-- | An ipe point.++data IpePoint' a = IpePoint (Point2' a) AMap+ deriving (Eq, Ord, Read, Show)++instance IsPoint2Functor IpePoint' where+ p2fmap f (IpePoint p a) = IpePoint (f p) a+++instance HasPoints IpePoint' where+ points (IpePoint p _) = [p]++instance HasAttributes (IpePoint' a) where+ attrs (IpePoint _ a) = a+ updateWith f (IpePoint p a) = IpePoint p (f a)++-- | create a default ipe point from a given point+fromPoint :: Point2' a -> IpePoint' a+fromPoint = flip IpePoint $ M.fromList [("name","mark/disk(sx)")]++++--------------------------------------------------------------------------------------+-- | A polyline++data IpePolyline' a = IpePolyline [LineSegment2' a] AMap+ deriving (Show, Eq)++toPolyLine :: IpePolyline' a -> Polyline2' a+toPolyLine (IpePolyline ls _) = Polyline2 ls++instance IsPoint2Functor IpePolyline' where+ p2fmap f (IpePolyline lines a) = IpePolyline (map (p2fmap f) lines) a++instance HasPoints IpePolyline' where+ points = points . toPolyLine++instance HasAttributes (IpePolyline' a) where+ attrs (IpePolyline _ a) = a+ updateWith f (IpePolyline p a) = IpePolyline p (f a)+++--------------------------------------------------------------------------------------+-- | Polygons++data IpeSimplePolygon' a = IpeSimplePolygon [Point2' a] AMap+ deriving (Show, Eq)++instance IsPoint2Functor IpeSimplePolygon' where+ p2fmap f (IpeSimplePolygon pts a) = IpeSimplePolygon (map f pts) a++instance HasPoints IpeSimplePolygon' where+ points (IpeSimplePolygon pts _) = pts++instance HasAttributes (IpeSimplePolygon' a) where+ attrs (IpeSimplePolygon _ a) = a+ updateWith f (IpeSimplePolygon p a) = IpeSimplePolygon p (f a)++instance IsPolygon IpeSimplePolygon' where+ isSimple = const True+ containsHoles = const False++-- note a ipeMultiPolygon consists of ``SimplePolygon''s, not ``IpeSimplePolygon''s+data IpeMultiPolygon' a = IpeMultiPolygon [SimplePolygon' a] AMap+ deriving (Show, Eq)++instance IsPoint2Functor IpeMultiPolygon' where+ p2fmap f (IpeMultiPolygon polys a) = IpeMultiPolygon (map (p2fmap f) polys) a++instance HasPoints IpeMultiPolygon' where+ points (IpeMultiPolygon polys _) = concatMap points polys++instance HasAttributes (IpeMultiPolygon' a) where+ attrs (IpeMultiPolygon _ a) = a+ updateWith f (IpeMultiPolygon p a) = IpeMultiPolygon p (f a)++-- TODO whether or not there are holes or the thing is simple actually depends+-- on the thing, so we need code here rather than a simple const False+instance IsPolygon IpeMultiPolygon' where+ isSimple = const False+ containsHoles = const False
+ src/Data/Geometry/Ipe/IpeTypes.hs view
@@ -0,0 +1,129 @@+module Data.Geometry.Ipe.IpeTypes where++import Data.Geometry.Point+import Data.Geometry.Geometry+import Text.XML.HXT.DOM.TypeDefs++import Data.Map(Map)+import Data.Maybe++import qualified Data.Map as M++-- | Attribute Map+type AMap = Map String String++--------------------------------------------------------------------------------------+-- | Representing an ipe file+++-- | A complete ipe file+data IpeDrawing a = Ipe { preamble :: Maybe Preamble+ , styles :: [IpeStyle]+ , pages :: [Page a]+ }+ deriving (Eq,Show)++-- for now we simply ignore these+type IpeStyle = [XmlTree]+type Preamble = XmlTree++instance IsPoint2Functor IpeDrawing where+ p2fmap f (Ipe p s pages) = Ipe p s (map (p2fmap f) pages)+++-- | A new blank ipe drawing+emptyDrawing :: IpeDrawing a+emptyDrawing = Ipe Nothing [] [emptyPage]++-- | A single page in an ipe drawing+data Page a = Page [LayerDefinition] [ViewDefinition] [IpeObject a]+ deriving (Eq, Show)++-- | A new empty page+emptyPage :: Page a+emptyPage = Page [] [] []++type LayerDefinition = String++instance IsPoint2Functor Page where+ p2fmap f (Page l v obs) = Page l v (map (p2fmap f) obs)+++-- | The definition of a view+-- make active layer into an index ?+data ViewDefinition = ViewDefinition { layerNames :: [String]+ , activeLayer :: String+ }+ deriving (Eq, Show)++--------------------------------------------------------------------------------+-- | An ipe-object. The main ``thing'' that defines the drawings++data IpeObject a = Path [Operation a] AMap+ | Group [IpeObject a] AMap+ | IpeText String AMap+ | Use (Point2' a) AMap+ deriving (Eq,Show)++instance IsPoint2Functor IpeObject where+ p2fmap f (Path ops attrs) = Path (map (p2fmap f) ops) attrs+ p2fmap f (Group obs attrs) = Group (map (p2fmap f) obs) attrs+ p2fmap f (IpeText s attrs) = IpeText s attrs+ p2fmap f (Use p attrs) = Use (f p) attrs++-- | type that represents a path in ipe.+data Operation a = MoveTo (Point2' a)+ | LineTo (Point2' a)+ | CurveTo (Point2' a) (Point2' a) (Point2' a)+ | QCurveTo (Point2' a) (Point2' a)+ | Ellipse (Matrix3 a)+ | ArcTo (Matrix3 a) (Point2' a)+ | Spline [Point2' a]+ | ClosedSpline [Point2' a]+ | ClosePath+ deriving (Eq, Show)++instance IsPoint2Functor Operation where+ p2fmap f (MoveTo p) = MoveTo (f p)+ p2fmap f (LineTo p) = LineTo (f p)+ p2fmap f (CurveTo p q r) = CurveTo (f p) (f q) (f r)+ p2fmap f (QCurveTo p q) = QCurveTo (f p) (f q)+ -- TODO: Should we transform the matrix too?+ -- p2fmap f (Ellipse m) = Ellipse m+ -- p2fmap f (ArcTo m p) = ArcTo m (f p)+ p2fmap f (Spline pts) = Spline (map f pts)+ p2fmap f (ClosedSpline pts) = ClosedSpline (map f pts)+ p2fmap f ClosePath = ClosePath+++--------------------------------------------------------------------------------------+-- | Stuff with attributes++class HasAttributes c where+ attrs :: c -> AMap+ updateWith :: (AMap -> AMap) -> c -> c++ getAttr :: String -> c -> Maybe String+ getAttr s o = M.lookup s . attrs $ o++ hasAttrWithValue :: String -> String -> c -> Bool+ hasAttrWithValue at val o = Just val == getAttr at o++ hasAttr :: String -> c -> Bool+ hasAttr s = isJust . getAttr s++ extractAttr :: String -> c -> c+ extractAttr s = updateWith (M.delete s)++++instance HasAttributes (IpeObject a) where+ attrs (Path _ a) = a+ attrs (Group _ a) = a+ attrs (IpeText _ a) = a+ attrs (Use _ a) = a++ updateWith f (Path ops a) = Path ops (f a)+ updateWith f (Group obs a) = Group obs (f a)+ updateWith f (IpeText s a) = IpeText s (f a)+ updateWith f (Use p a) = Use p (f a)
+ src/Data/Geometry/Ipe/IpeView.hs view
@@ -0,0 +1,44 @@+module Data.Geometry.Ipe.IpeView where++import Data.Geometry.Ipe.IpeTypes+import Data.Geometry.Ipe.IGC+import Data.List++import qualified Data.Map as M++data Layer a = Layer { layerDef :: LayerDefinition+ , layerContent :: IGC a+ }+ deriving (Show,Eq)++data ViewInstance a = ViewInstance { viewDef :: ViewDefinition+ , layers :: [Layer a]+ }+ deriving (Show,Eq)+++++-- | Given a set of layers construct a view instance. The first layer is used as+-- active layer.+viewInstance :: [Layer a] -> ViewInstance a+viewInstance lrs = ViewInstance vd lrs+ where+ a = layerDef . head $ lrs+ lns = nub $ map layerDef lrs+ vd = ViewDefinition lns a+++addLayer :: Layer a -> ViewInstance a -> ViewInstance a+addLayer l@(Layer name _) (ViewInstance (ViewDefinition lns a) ls) =+ ViewInstance (ViewDefinition lns' a) (l:ls)+ where+ lns' = nub (name:lns)++-- | Make a new layer, and add the elements in the given collection to this layer+layer :: String -> IGC a -> Layer a+layer name (IGC n pts pll sps mps) = Layer name gc+ where+ f ::HasAttributes g => g -> g+ f = updateWith (M.alter (const $ Just name) "layer")+ gc = IGC n (map f pts) (map f pll) (map f sps) (map f mps)
+ src/Data/Geometry/Ipe/Pickle.hs view
@@ -0,0 +1,367 @@+{-# 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"
+ src/Data/Geometry/Ipe/ReadIpeGeometry.hs view
@@ -0,0 +1,151 @@+module Data.Geometry.Ipe.ReadIpeGeometry( ipeViews+ , IsConvertableToIGC(..)+ , perPage+ , perView+ , perView'+ ) where++import Data.Geometry.Point+import Data.Geometry.Line hiding (length)+import Data.Geometry.Polygon+import Data.Geometry.Geometry+import Data.Geometry.Ipe.IGC(IGC)+import Data.Geometry.Ipe.IpeTypes+import Data.Geometry.Ipe.IpeGeometryTypes+import Data.Geometry.Ipe.IpeView++import Data.List.Split+import Data.Maybe+import Data.Monoid++import qualified Data.Geometry.Ipe.IGC as IGC+++-----------------------------------------------------------------------------------+-- | Typeclass expressing which ipetypes we can convert into a IGC++class IsConvertableToIGC t where+ toIGC :: t a -> IGC a++ listToIGC :: [t a] -> IGC a+ listToIGC = foldr (mappend . toIGC) IGC.empty++ perEntry :: [t a] -> [(t a, IGC a)]+ perEntry = map (\e -> (e, toIGC e))+++-----------------------------------------------------------------------------------+-- | Converting from IpeTypes++instance IsConvertableToIGC IpeDrawing where+ toIGC = listToIGC . pages+++-- | Get the IGC's with objects stored per page+perPage :: IpeDrawing a -> [(Page a, IGC a)]+perPage = perEntry . pages++-- | Get the IGC's with objects stored per view (for all views in the drawing)+perView :: IpeDrawing a -> [(ViewInstance a, IGC a)]+perView = concatMap perView' . pages++-- | Get the IGC's with objects stored per view (for all views in the page)+perView' :: Page a -> [(ViewInstance a, IGC a)]+perView' = perEntry . ipeViews+++instance IsConvertableToIGC Page where+ toIGC (Page _ _ obs) = listToIGC obs++instance IsConvertableToIGC ViewInstance where+ toIGC = listToIGC . layers++instance IsConvertableToIGC Layer where+ toIGC = layerContent+++ipeViews :: Page a -> [ViewInstance a]+ipeViews (Page _ vds obs) =+ map (\vd -> extend (ViewInstance vd [])) vds+ where+ addLayer' = addLayer . layer' obs+ extend vi = foldr addLayer' vi (layerNames . viewDef $ vi)+++layer' :: (HasAttributes (t a), IsConvertableToIGC t) =>+ [t a] -> String -> Layer a+layer' allObs lrName = Layer lrName (listToIGC obs)+ where+ obs = filter (hasAttrWithValue "layer" lrName) allObs+++instance IsConvertableToIGC IpeObject where+ -- todo: we still may need to apply a transformation matrix (in case of the group)+ toIGC o@(Path ops _) = case determineType ops of+ TPolyline -> singleton' . toPolyLine' $ o+ TSimplePolygon -> singleton' . toSimplePolygon $ o+ TMultiPolygon -> singleton' . toMultiPolygon $ o+ TOther -> IGC.empty+ where+ singleton' (Just g) = IGC.singleton g+ singleton' Nothing = IGC.empty+ toIGC (Group obs attrs) = listToIGC obs+ toIGC (Use p attrs) = IGC.singleton $ IpePoint p attrs+ toIGC (IpeText _ _) = IGC.empty+++-----------------------------------------------------------------------------------+-- | Stuff to determine the type of an IpeObject++data GeometryType = TPolyline | TSimplePolygon |TMultiPolygon | TOther+ deriving (Eq,Show)++determineType :: [Operation a] -> GeometryType+determineType ops+ | numClose == 0 && allLinear = TPolyline+ | numClose == 1 && allLinear = TSimplePolygon+ | allLinear = TMultiPolygon+ | otherwise = TOther -- for the time being we only know these ones+ where+ numClose = length $ filter isClose ops+ allLinear = all isLinear ops+ isLinear (LineTo _) = True+ isLinear (MoveTo _) = True+ isLinear ClosePath = True+ isLinear _ = False++isClose :: Operation a -> Bool+isClose ClosePath = True+isClose _ = False+++-----------------------------------------------------------------------------------+-- | Convert an ipe object into a X++-- | to a polyline+toPolyLine' :: IpeObject a -> Maybe (IpePolyline' a)+toPolyLine' (Path ops attrs) =+ if null pts then Nothing else Just $ IpePolyline lines attrs+ where+ pts = mapMaybe getPoint ops+ (Polyline2 lines) = polyLine pts+toPolyLine' _ = Nothing+++-- | to a polygon+toSimplePolygon :: IpeObject a -> Maybe (IpeSimplePolygon' a)+toSimplePolygon (Path ops attrs) = Just $ IpeSimplePolygon (mapMaybe getPoint ops) attrs+toSimplePolygon _ = Nothing++toMultiPolygon :: IpeObject a -> Maybe (IpeMultiPolygon' a)+toMultiPolygon (Path ops attrs) = Just $ IpeMultiPolygon polygons attrs+ where+ parts = splitWhen isClose ops+ polygons = map (SimplePolygon . mapMaybe getPoint) parts+toMultiPolygon _ = Nothing++-- | helper to extract a point from an operation+getPoint :: Operation a -> Maybe (Point2' a)+getPoint (MoveTo p) = Just p+getPoint (LineTo p) = Just p+getPoint _ = Nothing
+ src/Data/Geometry/Ipe/WriteIpeGeometry.hs view
@@ -0,0 +1,81 @@+{-# Language TypeFamilies+ #-}+module Data.Geometry.Ipe.WriteIpeGeometry( addToPage+ , addViewToDrawing+ , IsConvertableToIpeObject(..)+ , toIpeObjects'+ ) where++import Data.Geometry.Point+import Data.Geometry.Geometry+import Data.Geometry.Ipe.IpeTypes+import Data.Geometry.Ipe.IpeGeometryTypes+import Data.Geometry.Ipe.IpeView+import Data.Geometry.Ipe.IGC(IGC(IGC))+import Data.List++import qualified Data.Map as M++-----------------------------------------------------------------------------------+-- | Converting to IpeTypes++-- | convert a sequence of points into a list of operations representing a linear Path+toLinearPath :: [Point2' a] -> [Operation a]+toLinearPath [] = []+toLinearPath (p:pts) = MoveTo p : map LineTo pts++-- | Express that this sequence of points represents a polygon+mkPolygonOps :: [Point2' a] -> [Operation a]+mkPolygonOps pts = toLinearPath pts ++ [ClosePath]++class IsConvertableToIpeObject g where+ toIpeObject :: g a -> IpeObject a+ toIpeObjects :: [g a] -> [IpeObject a]+ toIpeObjects = map toIpeObject+++instance IsConvertableToIpeObject IpePoint' where+ toIpeObject (IpePoint p attrs) = Use p attrs++instance IsConvertableToIpeObject IpePolyline' where+ toIpeObject (IpePolyline lines attrs) =+ Path (toLinearPath . concatMap points $ lines) attrs++instance IsConvertableToIpeObject IpeSimplePolygon' where+ toIpeObject (IpeSimplePolygon pts attrs) =+ Path (mkPolygonOps pts) attrs++instance IsConvertableToIpeObject IpeMultiPolygon' where+ toIpeObject (IpeMultiPolygon pls attrs) =+ Path ops attrs+ where+ ops = concatMap (mkPolygonOps . points) pls+++instance IsConvertableToIpeObject IGC where+ toIpeObject gc = Group obs ats+ where+ obs = toIpeObjects' gc+ ats = case obs of+ [] -> M.empty+ (o:_) -> attrs o++toIpeObjects' :: IGC a -> [IpeObject a]+toIpeObjects' (IGC _ pts pll sps mps) = concat [ toIpeObjects pts+ , toIpeObjects pll+ , toIpeObjects sps+ , toIpeObjects mps ]++addViewToDrawing :: Eq a => ViewInstance a -> IpeDrawing a -> IpeDrawing a+addViewToDrawing v (Ipe pre sty []) = Ipe pre sty [addToPage v emptyPage]+addViewToDrawing v (Ipe pre sty (p:pgs)) = Ipe pre sty (addToPage v p : pgs)+++-- | Add (the objects in this View) to the given page+addToPage :: Eq a => ViewInstance a -> Page a -> Page a+addToPage (ViewInstance vd lrs) (Page lds vds obs) =+ Page lds' vds' obs'+ where+ lds' = nub $ layerNames vd ++ lds+ vds' = nub $ vd:vds+ obs' = nub $ map (toIpeObject . layerContent) lrs ++ obs