hipe 0.1.1.0 → 0.2.0.0

raw patch · 11 files changed

+543/−367 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hipe.cabal +8/−5
• src/Data/Geometry/Ipe/IGC.hs +16/−1
• src/Data/Geometry/Ipe/InternalTypes.hs +129/−0
• src/Data/Geometry/Ipe/Ipe.hs +12/−0
• src/Data/Geometry/Ipe/IpeGeometry.hs +0/−96
• src/Data/Geometry/Ipe/IpeGeometryTypes.hs +2/−1
• src/Data/Geometry/Ipe/IpeTypes.hs +168/−89
• src/Data/Geometry/Ipe/IpeView.hs +0/−44
• src/Data/Geometry/Ipe/Pickle.hs +110/−50
• src/Data/Geometry/Ipe/ReadIpeGeometry.hs +47/−49
• src/Data/Geometry/Ipe/WriteIpeGeometry.hs +51/−32

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.1.1.0+version:             0.2.0.0  -- A short (one-line) description of the package. synopsis:            Support for reading and writing ipe7 files (http://ipe7.sourceforge.net)@@ -31,6 +31,9 @@ -- patches. maintainer:          f.staals@uu.nl ++homepage:            http://fstaals.net/software/hipe+ -- A copyright notice. -- copyright: @@ -51,14 +54,14 @@   -- GHC-Options:    -Wall    -- Modules exported by the library.-  exposed-modules: Data.Geometry.Ipe.IpeGeometry-                 , Data.Geometry.Ipe.ReadIpeGeometry-                 , Data.Geometry.Ipe.WriteIpeGeometry+  exposed-modules: Data.Geometry.Ipe.Ipe                  , Data.Geometry.Ipe.IpeTypes                  , Data.Geometry.Ipe.IpeGeometryTypes                  , Data.Geometry.Ipe.IGC-                 , Data.Geometry.Ipe.IpeView+                 , Data.Geometry.Ipe.ReadIpeGeometry+                 , Data.Geometry.Ipe.WriteIpeGeometry                  , Data.Geometry.Ipe.Pickle+                 , Data.Geometry.Ipe.InternalTypes    -- Modules included in this library but not exported.   -- other-modules:

@@ -1,12 +1,17 @@+{-# Language RankNTypes+  #-} module Data.Geometry.Ipe.IGC( IGC(..)                             , IsIpeGeometry(..)                             , empty                             , singleton                             , fromList+                            , mergeAll+                            , updateAll                             ) where -import Data.Geometry.Ipe.IpeGeometryTypes import Data.Monoid+import Data.Geometry.Ipe.InternalTypes(HasAttributes(..))+import Data.Geometry.Ipe.IpeGeometryTypes  -- | an ipe geometry collection data IGC a = IGC { name           :: String@@ -30,6 +35,16 @@ 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')++mergeAll :: [IGC a] -> IGC a+mergeAll = foldr merge empty+++updateAll  :: (forall t. HasAttributes t => t -> t) -> IGC a -> IGC a+updateAll f (IGC n pts pll spsm mps) = IGC n (map f pts)+                                             (map f pll)+                                             (map f spsm)+                                             (map f mps)   -- | Stuff that we can store in a IpGeometryCollection

@@ -0,0 +1,129 @@+module Data.Geometry.Ipe.InternalTypes 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+++-- | A complete ipe file+data IpeFile a = IpeFile { preamble :: Maybe IpePreamble+                         , styles   :: [IpeStyle]+                         , ipePages :: [IpePage a]+                         }+                 deriving (Eq,Show)++-- for now we pretty much ignore these+-- | the maybe string is the styles name+data IpeStyle = IpeStyle (Maybe String) [XmlTree]+              deriving (Eq,Show)++-- | The maybe string is the encoding+data IpePreamble  = IpePreamble (Maybe String) XmlTree+                  deriving (Eq,Show)++type IpeBitmap = XmlTree+++-- | Represents the <page> tag+data IpePage a = IpePage [LayerDefinition] [ViewDefinition] [IpeObject a]+              deriving (Eq, Show)+++type LayerDefinition = String++-- | 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++-- | Attribute Map+type AMap = Map String String++-- | 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++    setAttr     :: String -> String -> c -> c+    setAttr k v = updateWith (M.insert k v)++    setAttrs :: [(String,String)] -> c -> c+    setAttrs ats = updateWith (insertAll ats)+                   where+                     insertAll       :: [(String,String)] -> AMap -> AMap+                     insertAll ats m = foldr (uncurry M.insert) m ats++    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)

@@ -0,0 +1,12 @@+module Data.Geometry.Ipe.Ipe( module X ) where++import Control.Arrow+++import Data.Geometry.Ipe.IpeTypes          as X+import Data.Geometry.Ipe.Pickle            as X++import Data.Geometry.Ipe.IpeGeometryTypes  as X+++import Data.Geometry.Ipe.IGC               as X (IGC(..))

@@ -1,96 +0,0 @@-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

@@ -4,7 +4,8 @@ import Data.Geometry.Line import Data.Geometry.Polygon import Data.Geometry.Geometry-import Data.Geometry.Ipe.IpeTypes++import Data.Geometry.Ipe.InternalTypes(HasAttributes(..),AMap)  import qualified Data.Map as M 

@@ -1,129 +1,208 @@-module Data.Geometry.Ipe.IpeTypes where+{-# Language TypeFamilies+  #-}+module Data.Geometry.Ipe.IpeTypes( IpeDrawing(..)+                                 , Page(..)+                                 , Layer(..)+                                 , emptyDrawing+                                 , emptyPage+                                 , emptyLayer+                                 , HasContent(..)+                                 , extend+                                 -- * Working with views+                                 , view+                                 -- * Running computations on ipe files+                                 , runOnFile+                                 , runOnPath+                                 -- * Querying+                                 , findLayer+                                 , findLayer'+                                 -- * Other types+                                 , IpeFile+                                 , LayerDefinition+                                 , ViewDefinition(..)+                                 , AMap+                                 , HasAttributes(..)+                                 ) where +import Control.Arrow++import Data.Monoid+import Data.Function(on)++import Data.Maybe+import Data.List+ import Data.Geometry.Point import Data.Geometry.Geometry-import Text.XML.HXT.DOM.TypeDefs -import Data.Map(Map)-import Data.Maybe+import Data.Geometry.Ipe.IGC(IGC,empty,mergeAll,updateAll) -import qualified Data.Map as M+import Data.Geometry.Ipe.ReadIpeGeometry hiding (PM)+import Data.Geometry.Ipe.WriteIpeGeometry hiding (PM) --- | Attribute Map-type AMap = Map String String+import Data.Geometry.Ipe.InternalTypes +import Data.Geometry.Ipe.Pickle++ ----------------------------------------------------------------------------------------- | Representing an ipe file+-- | Representing ipe drawings  --- | A complete ipe file-data IpeDrawing a = Ipe { preamble :: Maybe Preamble-                        , styles   :: [IpeStyle]-                        , pages    :: [Page a]-                        }-                    deriving (Eq,Show)+data IpeDrawing a = IpeDrawing { pages :: [Page a] }+                  deriving (Show,Eq) --- 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)+data Page a = Page { layers :: [Layer a]+                   , views  :: [ViewDefinition]+                   }+              deriving (Show,Eq) +data Layer a = Layer { layerDef     :: LayerDefinition+                     , layerContent :: IGC a+                     }+               deriving (Show,Eq)  -- | 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)+emptyDrawing = IpeDrawing [emptyPage]  -- | A new empty page emptyPage :: Page a-emptyPage = Page [] [] []+emptyPage = Page [emptyLayer] [] -type LayerDefinition = String+emptyLayer :: Layer a+emptyLayer = Layer "alpha" empty -instance IsPoint2Functor Page where-    p2fmap f (Page l v obs) = Page l v (map (p2fmap f) obs) +instance Monoid (IpeDrawing a) where+    mempty = emptyDrawing+    (IpeDrawing pgs) `mappend` (IpeDrawing pgs') = IpeDrawing $ pgs++pgs' --- | The definition of a view--- make active layer into an index ?-data ViewDefinition = ViewDefinition { layerNames      :: [String]-                                     , activeLayer     :: String-                                     }-                      deriving (Eq, Show)+-- | Merges the two drawings. i.e. page by page we merge the pages in the sense+-- that objects on layers with the same names are *BOTH* included+extend :: IpeDrawing a -> IpeDrawing a -> IpeDrawing a+extend (IpeDrawing pgs) (IpeDrawing pgs') = IpeDrawing $ zipWith mappend pgs pgs' ------------------------------------------------------------------------------------ | An ipe-object. The main ``thing'' that defines the drawings+-- | When mappending two pages, they are are merged, i.e. if both contain a+-- layer named A, say layers l and r, then the output page contains only one+-- layer named A, containing all items from both l and r+instance Monoid (Page a) where+    mempty = emptyPage+    p@(Page lrs vds) `mappend` q@(Page lrs' vds') =+        Page (combineLayers lrs lrs') (vds ++ vds') -data IpeObject a = Path [Operation a] AMap-                 | Group [IpeObject a] AMap-                 | IpeText String AMap-                 | Use (Point2' a) AMap-                   deriving (Eq,Show)+-- | Combines a set of layers by merging layers with a common name+combineLayers :: [Layer a] -> [Layer a] -> [Layer a]+combineLayers lrs lrs' = map mergeCommon commonNames +++                         filter (not . inSet commonNames) (lrs++lrs')+    where+      names         = map layerDef+      commonNames   = names lrs `intersect` names lrs'+      inSet ns lr   = let n = layerDef lr in n `elem` ns+      mergeCommon n = findL n lrs `mergeLayers` findL n lrs' -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+mergeLayers                      :: Maybe (Layer a) -> Maybe (Layer a) -> Layer a+mergeLayers (Just lr) (Just lr') = lr `mappend` lr'+mergeLayers mlr       mlr'       = fromMaybe mempty (mlr `mappend` mlr') --- | 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+instance Monoid (Layer a) where+    mempty = emptyLayer+    (Layer n xs) `mappend` (Layer _ ys) = Layer n (xs `mappend` ys)   ----------------------------------------------------------------------------------------- | Stuff with attributes+-- | Working with views -class HasAttributes c where-    attrs      :: c -> AMap-    updateWith :: (AMap -> AMap) -> c -> c+-- data View a = View [Layer a]+--                  deriving (Show,Eq) -    getAttr :: String -> c -> Maybe String-    getAttr s o = M.lookup s . attrs $ o+view      :: [LayerDefinition] -> ViewDefinition+view lrns = ViewDefinition lrns (head lrns) -    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)+++--------------------------------------------------------------------------------------+-- | Getting the content of pages/layers etc++class HasContent t where+    type PM t+    content :: t -> IGC (PM t)++instance HasContent (IpeDrawing a) where+    type PM (IpeDrawing a) = a+    content = mergeAll . map content . pages+++instance HasContent (Page a) where+    type PM (Page a) = a+    content = mergeAll . map content . layers++instance HasContent (Layer a) where+    type PM (Layer a) = a+    content = layerContent+++-----------------------------------------------------------------------------------+-- | Converting between IpeFile and IpeDrawings, and IpePages and Pages++fromIpeFile :: IpeFile a -> IpeDrawing a+fromIpeFile (IpeFile _ _ pgs) = IpeDrawing $ map gatherPage pgs++gatherPage                   :: IpePage a -> Page a+gatherPage (IpePage _ vds obs) = Page lrs vds+    where+      lrs        = map mkLayer .  groupBy' layerName $ obs+      groupBy' f = groupBy ((==) `on` f) . sortBy (compare `on` f)++      mkLayer           :: [IpeObject a] -> Layer a+      mkLayer []        = emptyLayer -- This should not really occur+      mkLayer obs@(o:_) = Layer (layerName o) (listToIGC obs)++      layerName :: IpeObject a -> String+      layerName = fromMaybe "alpha" . getAttr "layer"++updateIpeFile                          :: IpeFile t -> IpeDrawing a -> IpeFile a+updateIpeFile ipeFile (IpeDrawing pgs) =+    ipeFile { ipePages = map constructIpePage pgs}++constructIpePage                :: Page a -> IpePage a+constructIpePage (Page lrs vds) = IpePage lds vds obs+    where+      lds             = map layerDef lrs+      obs             = toIpeObjects' . mergeAll . map f $ lrs+      f (Layer n col) = updateAll (setAttr "layer" n) col++--------------------------------------------------------------------------------------+-- | Manipulating Ipe documents+++++runOnPath f = loadFileA >>> runOnFile f+++runOnFile   :: Arrow arr => arr (IpeDrawing a) (IpeDrawing b) -> arr (IpeFile a) (IpeFile b)+runOnFile f = arr id &&& (fromIpeFile ^>> f)+              >>>+              arr (uncurry updateIpeFile)+++-----------------------------------------------------------------------------------+-- | Querying a drawing for layers/views/pages etc++findLayer                       :: Int -> LayerDefinition -> IpeDrawing a -> Maybe (Layer a)+findLayer i lr (IpeDrawing pgs) = let mpg = listToMaybe . drop i $ pgs in+                                  mpg >>= findLayer' lr++findLayer'      :: LayerDefinition -> Page a -> Maybe (Layer a)+findLayer' name = findL name . layers++findL name = listToMaybe . filter ((== name) . layerDef)

@@ -1,44 +0,0 @@-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)

@@ -1,13 +1,24 @@ {-# Language FlexibleInstances,              OverloadedStrings  #-}-module Data.Geometry.Ipe.Pickle ( loadDrawing-                                , storeDrawing-                                , Coordinate(..)-                                ) where+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@@ -15,8 +26,7 @@  import Data.Geometry.Point import Data.Geometry.Geometry-import Data.Geometry.Ipe.IpeTypes-+import Data.Geometry.Ipe.InternalTypes   import Text.Parsec@@ -25,6 +35,8 @@ 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)@@ -37,51 +49,57 @@  -- | 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+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-    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+instance Coordinate a => XmlPickler (IpePage a) where     xpickle = xpPage -instance Coordinate a => XmlPickler (IpeDrawing a) where-    xpickle = xpIpeDrawing+instance Coordinate a => XmlPickler (IpeFile a) where+    xpickle = xpIpeFile   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+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-storeDrawing              :: Coordinate a => IpeDrawing a -> FilePath -> IO ()-storeDrawing drawing path =+storeFile              :: Coordinate a => IpeFile a -> FilePath -> IO ()+storeFile ipeFile path =     do-      runX $ constA drawing >>> xpickleDocument xpIpeDrawing xpStoreSettings path+      runX $ constA ipeFile >>> xpickleDocument xpIpeFile xpStoreSettings path       return ()  xpLoadSettings :: [SysConfig]@@ -95,34 +113,59 @@                   ]  +--------+-- 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)+ ----------------------------------------------------------------------- -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)+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 [XmlTree]-xpIpeStyle = xpElem "ipestyle" xpTrees+xpIpeStyle :: PU IpeStyle+xpIpeStyle = xpElem "ipestyle" $+             xpWrap ( uncurry IpeStyle+                    , \(IpeStyle name content) -> (name,content)) $+             xpPair (xpTextAttrImplied "name") xpTrees -xpPage :: Coordinate a => PU (Page a)++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) -> Page lrs vws (markWithlayers "alpha" obs)-                , \(Page lrs vws obs) -> (lrs,vws,obs)+         xpWrap ( \(lrs,vws,obs) -> IpePage lrs vws (markWithlayers "alpha" obs)+                , \(IpePage lrs vws obs) -> (lrs,vws,obs)                 ) $          xpTriple (xpList xpLayerDefinition)                   (xpList xpViewDefinition)@@ -140,10 +183,6 @@       markOb lrName = updateWith (M.insert "layer" lrName)  ---- xpLayerDefinition :: PU String xpLayerDefinition = xpElem "layer" $                     xpTextAttr "name"@@ -155,7 +194,7 @@                           ) $                    xpPair (xpTextAttr "layers") (xpTextAttr "active") -+-----------------------------------------------------------------------  -- | Pickler for ipe objects @@ -221,7 +260,7 @@ xpVarTextAttrs :: PU AMap xpVarTextAttrs = PU { appPickle   = \m st -> M.foldrWithKey addAtt' st m                     , appUnPickle = UP $ \st ->-                                    (Right . M.fromList . mapMaybe toPair . attributes $ st, 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)@@ -235,6 +274,27 @@                                        (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 @@ -318,7 +378,7 @@                                                          , [0, 0, 1]]                  Right xs            -> error (                                           "matrix with wrong number of elems: "-                                          ++ (show $ length xs))+                                          ++ show (length xs))   matrixAttr :: Coordinate a => Parser [a]

@@ -1,18 +1,24 @@-module Data.Geometry.Ipe.ReadIpeGeometry( ipeViews-                                        , IsConvertableToIGC(..)-                                        , perPage-                                        , perView-                                        , perView'+{-# Language TypeFamilies+  #-}+module Data.Geometry.Ipe.ReadIpeGeometry(+                                         IsConvertableToIGC(..)+                                        -- , perPage+                                        -- , perView+                                        -- , perView'+                                        -- , layer'+                                        -- , findLayer                                         ) where  import Data.Geometry.Point-import Data.Geometry.Line hiding (length)+import Data.Geometry.Line hiding (length, PM) import Data.Geometry.Polygon import Data.Geometry.Geometry++ import Data.Geometry.Ipe.IGC(IGC)-import Data.Geometry.Ipe.IpeTypes++import Data.Geometry.Ipe.InternalTypes import Data.Geometry.Ipe.IpeGeometryTypes-import Data.Geometry.Ipe.IpeView  import Data.List.Split import Data.Maybe@@ -21,66 +27,59 @@ import qualified Data.Geometry.Ipe.IGC as IGC  --------------------------------------------------------------------------------------- | Typeclass expressing which ipetypes we can convert into a IGC --- | minimal implementation: toIGC-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 +-----------------------------------------------------------------------------------+-- | Typeclass expressing which ipetypes we can convert into a IGC -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)+-- | minimal implementation: toIGC+class IsConvertableToIGC t where+    type PM t+    toIGC :: t -> IGC (PM t) +    listToIGC :: [t] -> IGC (PM t)+    listToIGC = foldr (mappend . toIGC) IGC.empty -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+    perEntry :: [t] -> [(t, IGC (PM t))]+    perEntry = map (\e -> (e, toIGC e))  -instance IsConvertableToIGC IpeObject where+instance IsConvertableToIGC (IpeFile a) where+    type PM (IpeFile a) = a+    toIGC = listToIGC . ipePages++instance IsConvertableToIGC (IpePage a) where+    type PM (IpePage a) = a+    toIGC (IpePage _ _ obs) = listToIGC obs++-- instance IsConvertableToIGC (ViewInstance a) where+--     type PM (ViewInstance a) = a+--     toIGC = listToIGC . layers++-- instance IsConvertableToIGC (Layer a) where+--     type PM (Layer a) = a+--     toIGC = layerContent++-----------------------------------------------------------------------------------+-- the most interesting one is an ipe object. Since this is where all the work+-- really happens.+++instance IsConvertableToIGC (IpeObject a) where+    type PM (IpeObject a) = a     -- 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@@ -93,7 +92,6 @@     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

@@ -1,23 +1,24 @@ {-# Language TypeFamilies   #-}-module Data.Geometry.Ipe.WriteIpeGeometry( addToPage-                                         , addViewToDrawing-                                         , IsConvertableToIpeObject(..)+module Data.Geometry.Ipe.WriteIpeGeometry( IsConvertableToIpeObject(..)                                          , toIpeObjects'                                         ) where  import Data.Geometry.Point import Data.Geometry.Geometry-import Data.Geometry.Ipe.IpeTypes++import Data.Geometry.Ipe.InternalTypes import Data.Geometry.Ipe.IpeGeometryTypes-import Data.Geometry.Ipe.IpeView+ import Data.Geometry.Ipe.IGC(IGC(IGC))++import Data.Maybe import Data.List  import qualified Data.Map as M  -------------------------------------------------------------------------------------- | Converting to IpeTypes+-- | Primitives for converting to IpeTypes  -- | convert a sequence of points into a list of operations representing a linear Path toLinearPath         :: [Point2' a] -> [Operation a]@@ -28,32 +29,46 @@ mkPolygonOps     :: [Point2' a] -> [Operation a] mkPolygonOps pts = toLinearPath pts ++ [ClosePath] ++-- | Helper function to create an ipe object, more specifically a path, from a+-- list of operations.+mkPath           :: AMap -> [Operation a] -> Maybe (IpeObject a)+mkPath _     []  = Nothing+mkPath attrs ops = Just $ Path ops attrs++ class IsConvertableToIpeObject g where-    toIpeObject  :: g a -> IpeObject a-    toIpeObjects :: [g a] -> [IpeObject a]-    toIpeObjects = map toIpeObject+    type PM g+    toIpeObject  :: g -> Maybe (IpeObject (PM g))+    toIpeObjects :: [g] -> [IpeObject (PM g)]+    toIpeObjects = mapMaybe toIpeObject  -instance IsConvertableToIpeObject IpePoint' where-    toIpeObject (IpePoint p attrs) = Use p attrs+instance IsConvertableToIpeObject (IpePoint' a) where+    type PM (IpePoint' a) = a+    toIpeObject (IpePoint p attrs) = Just $ Use p attrs -instance IsConvertableToIpeObject IpePolyline' where+instance IsConvertableToIpeObject (IpePolyline' a) where+    type PM (IpePolyline' a) = a     toIpeObject (IpePolyline lines attrs) =-        Path (toLinearPath . concatMap points $ lines) attrs+        mkPath attrs . toLinearPath . concatMap points $ lines -instance IsConvertableToIpeObject IpeSimplePolygon' where+instance IsConvertableToIpeObject (IpeSimplePolygon' a) where+    type PM (IpeSimplePolygon' a) = a     toIpeObject (IpeSimplePolygon pts attrs) =-        Path (mkPolygonOps pts) attrs+        mkPath attrs . mkPolygonOps $ pts -instance IsConvertableToIpeObject IpeMultiPolygon' where+instance IsConvertableToIpeObject (IpeMultiPolygon' a) where+    type PM (IpeMultiPolygon' a) = a     toIpeObject (IpeMultiPolygon pls attrs) =-        Path ops attrs-             where-               ops = concatMap (mkPolygonOps . points) pls+        mkPath attrs . concatMap (mkPolygonOps . points) $ pls  -instance IsConvertableToIpeObject IGC where-    toIpeObject gc = Group obs ats+instance IsConvertableToIpeObject (IGC a) where+    type PM (IGC a) = a+    toIpeObject gc = case obs of+                       [] -> Nothing+                       _  -> Just $ Group obs ats                      where                        obs = toIpeObjects' gc                        ats = case obs of@@ -66,16 +81,20 @@                                                , 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++-- addViewToDrawing :: Eq a => ViewInstance a -> IpeDocument a -> IpeDocument a+-- addViewToDrawing v (IpeDoc pre sty [])      = IpeDoc pre sty [addToPage v emptyPage]+-- addViewToDrawing v (IpeDoc pre sty (p:pgs)) = IpeDoc 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