diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hipe.cabal b/hipe.cabal new file mode 100644 --- /dev/null +++ b/hipe.cabal @@ -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 diff --git a/src/Data/Geometry/Ipe/IGC.hs b/src/Data/Geometry/Ipe/IGC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/IGC.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/IpeGeometry.hs b/src/Data/Geometry/Ipe/IpeGeometry.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/IpeGeometry.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/IpeGeometryTypes.hs b/src/Data/Geometry/Ipe/IpeGeometryTypes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/IpeGeometryTypes.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/IpeTypes.hs b/src/Data/Geometry/Ipe/IpeTypes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/IpeTypes.hs @@ -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) diff --git a/src/Data/Geometry/Ipe/IpeView.hs b/src/Data/Geometry/Ipe/IpeView.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/IpeView.hs @@ -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) diff --git a/src/Data/Geometry/Ipe/Pickle.hs b/src/Data/Geometry/Ipe/Pickle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/Pickle.hs @@ -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" diff --git a/src/Data/Geometry/Ipe/ReadIpeGeometry.hs b/src/Data/Geometry/Ipe/ReadIpeGeometry.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/ReadIpeGeometry.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/WriteIpeGeometry.hs b/src/Data/Geometry/Ipe/WriteIpeGeometry.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/WriteIpeGeometry.hs @@ -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