diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,23 +6,49 @@ progress. Hence, the API is experimental and may change at any time! Here is an example showing reading a set of points from an Ipe file, -computing the DelaunayTriangulation, and writing the result again to -an output file +computing the DelaunayTriangulation and the Euclidean Minimimum +Spanning tree, and writing the result again to an output file. Refer +to +[hgeometry-examples](https://github.com/noinia/hgeometry/tree/master/hgeometry-examples/src/Demo/Delaunay.hs) +for the full code. + ```haskell mainWith :: Options -> IO () mainWith (Options inFile outFile) = do - ePage <- readSinglePageFile inFile - case ePage of - Left err -> print err - Right (page :: IpePage Rational) -> case page^..content.traverse._IpeUse of - [] -> putStrLn "No points found" - syms@(_:_) -> do - let pts = syms&traverse.core %~ (^.symbolPoint) - pts' = NonEmpty.fromList pts - dt = delaunayTriangulation $ pts' - out = [iO $ drawTriangulation dt] - writeIpeFile outFile . singlePageFromContent $ out + pts <- readAllFrom @(Point 2 R) inFile + let pts' = NonEmpty.fromList pts + dt = toPlanarSubdivision (Proxy @DTWorld) . delaunayTriangulation $ pts' + emst = euclideanMST pts' + out = [ iO $ drawPlanarSubdivisionWith drawVtx drawEdge (drawInternalFace dt) drawOuterFace dt + ! attr SLayer "delaunayTriangulation" + , iO $ drawTree' emst ! attr SLayer "emst" + ] + outputFile = singlePageFromContent out + outputFile' <- addStyleSheetFrom "../hgeometry-ipe/resources/opacities.isy" outputFile + writeIpeFile outFile outputFile' + +-- | The world in which the delaunay triangulation "lives" +data DTWorld + +-- | Draw vertices using their default representation; disk marks. For +-- the rest we keep their original attributes. +drawVtx :: IpeOut' Maybe (VertexId' s, VertexData r (IpeAttributes IpeSymbol r)) IpeSymbol r +drawVtx (_vi, VertexData p ats) = Just $ defIO p ! ats + +-- | Draw edges using normal line segments +drawEdge :: IpeOut' Maybe (Dart s, LineSegment 2 v r :+ e) Path r +drawEdge (_d, s :+ _) = Just $ defIO s + +-- | Internal faces are filled polygons. +drawInternalFace :: PlanarSubdivision s v e f r + -> IpeOut' Maybe (FaceId' s, SomePolygon v r :+ f) Path r +drawInternalFace s (fi, pg :+ _) = Just $ defIO pg ! attr SFill lightcyan + +-- +drawOuterFace :: (Ord r, Num r) => IpeOut' Maybe (FaceId' s, MultiPolygon (Maybe v) r :+ f) Path r +drawOuterFace (_, pg :+ _) = Just $ defIO pg ! attr SOpacity "10%" + ! attr SFill lightgray ``` See the [hgeometry-examples](https://github.com/noinia/hgeometry/tree/master/hgeometry-examples) package for more examples. diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,54 @@ +#+STARTUP: showeverything + +* Changelog + +** 0.13 + +- Newer BezierSpline parsing. +- Renamed the modules from Data.Geometry.Ipe to simply Ipe. The + following find and sed command should be able to help you migrate + (but use it at your own risk) + + #+begin_src sh + find src -name "*.hs" -exec sed -i -e 's/Data.Geometry.Ipe/Ipe/g' {} \; + #+end_src +- Better Documentation; i.e. specific reexports from the Ipe module. +- Added functionality to load and add a stylesheet to a file. +- Added support for the stroke-opacity attribute. +- IpeRender and IpeToIpe modules that allows to us to easily call + 'iperender' and 'ipetoipe'. The IpeToIpe module now also defines a + 'wirteIpeFileAsPdf' function that allows us to write to an ipe pdf + file (by calling ipetoipe to create this pdf.) + +** 0.12 + +- Compatibility with HGeometry 0.12 + +** 0.11 +- Split the Types module into smaller sub modules, and restricting + what is exported. +- Traversable, Foldable, and Functor instances for the ipe types. +- Reading and Writing of Ellipses :) +- Added Coordinate Float and IpeWriteText Float instances. +- readAll now accepts only one IpePage rather than a Foldable f => f + (IpePage r) +- Renamed attrLens to ixAttr, and added a prism _Attr to access an + attribute._ +- added convenience functions (well, Getter's) for getting all Ipe + objects on a particular layer, or in a particular view. +- readSinglePageFile now makes sure there is at least one layer / view + in the file, and if not creates it. This matches the behaviour of + ipe itself. See the new 'withDefaults' function in the Types module + for the details. +- fromContent now creates these layers and views as well. + +** 0.10 + +- Added a 'labeled' IpeOut that supports labeling geometric objects + with some textual label +- IpeWrite instance for NonEmpty Lists, and IpeWriteText and + Coordinate instances for Data.RealNumber.Rational + +** 0.9 + +- First release in which hgeometry-ipe was split off from hgeometry. diff --git a/changelog.org b/changelog.org --- a/changelog.org +++ b/changelog.org @@ -2,6 +2,28 @@ * Changelog +** 0.13 + +- Newer BezierSpline parsing. +- Renamed the modules from Data.Geometry.Ipe to simply Ipe. The + following find and sed command should be able to help you migrate + (but use it at your own risk) + + #+begin_src sh + find src -name "*.hs" -exec sed -i -e 's/Data.Geometry.Ipe/Ipe/g' {} \; + #+end_src +- Better Documentation; i.e. specific reexports from the Ipe module. +- Added functionality to load and add a stylesheet to a file. +- Added support for the stroke-opacity attribute. +- IpeRender and IpeToIpe modules that allows to us to easily call + 'iperender' and 'ipetoipe'. The IpeToIpe module now also defines a + 'wirteIpeFileAsPdf' function that allows us to write to an ipe pdf + file (by calling ipetoipe to create this pdf.) + +** 0.12 + +- Compatibility with HGeometry 0.12 + ** 0.11 - Split the Types module into smaller sub modules, and restricting what is exported. diff --git a/hgeometry-ipe.cabal b/hgeometry-ipe.cabal --- a/hgeometry-ipe.cabal +++ b/hgeometry-ipe.cabal @@ -1,10 +1,11 @@ +cabal-version: 2.4 name: hgeometry-ipe -version: 0.12.0.0 +version: 0.13 synopsis: Reading and Writing ipe7 files. description: Reading and Writing ipe7 files and converting them to and from HGeometry types. homepage: https://fstaals.net/software/hgeometry -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Frank Staals maintainer: frank@fstaals.net @@ -21,12 +22,12 @@ -- examples/**/*.out extra-source-files: README.md + changelog changelog.org Extra-doc-files: -- docs/**/*.png -cabal-version: 2.0 source-repository head type: git location: https://github.com/noinia/hgeometry @@ -47,21 +48,24 @@ Data.Geometry.QuadTree.Draw -- * Ipe Types - Data.Geometry.Ipe - Data.Geometry.Ipe.Literal - Data.Geometry.Ipe.Value - Data.Geometry.Ipe.Color - Data.Geometry.Ipe.Attributes - Data.Geometry.Ipe.Types - Data.Geometry.Ipe.Writer - Data.Geometry.Ipe.Reader - Data.Geometry.Ipe.PathParser - Data.Geometry.Ipe.IpeOut - Data.Geometry.Ipe.FromIpe - Data.Geometry.Ipe.Path - Data.Geometry.Ipe.Matrix - Data.Geometry.Ipe.Layer - Data.Geometry.Ipe.Content + Ipe + Ipe.Literal + Ipe.Value + Ipe.Color + Ipe.Attributes + Ipe.Types + Ipe.Writer + Ipe.Reader + Ipe.PathParser + Ipe.IpeOut + Ipe.FromIpe + Ipe.Path + Ipe.Matrix + Ipe.Layer + Ipe.Content + -- * IpeRender + Ipe.IpeRender + Ipe.IpeToIpe -- * Embedded Planar Graphs Data.PlaneGraph.Draw @@ -69,7 +73,7 @@ -- Data.Geometry.BezierSpline other-modules: - Data.Geometry.Ipe.ParserPrimitives + Ipe.ParserPrimitives -- other-extensions: @@ -93,8 +97,8 @@ , QuickCheck >= 2.5 , quickcheck-instances >= 0.3 - , hgeometry-combinatorial >= 0.12.0.0 - , hgeometry >= 0.12.0.0 + , hgeometry-combinatorial >= 0.13 + , hgeometry >= 0.13 -- , validation >= 0.4 @@ -108,8 +112,9 @@ , hexpat >= 0.20.9 , aeson >= 1.0 , yaml >= 0.8 - -- , zippers >= 0.2 - + , typed-process >= 0.2.6 + , directory >= 1.3 + , filepath >= 1.4 , mtl , random , template-haskell @@ -169,7 +174,7 @@ build-tool-depends: hspec-discover:hspec-discover - other-modules: Data.Geometry.Ipe.ReaderSpec + other-modules: Ipe.ReaderSpec build-depends: base , hspec >= 2.1 diff --git a/src/Data/Geometry/Arrangement/Draw.hs b/src/Data/Geometry/Arrangement/Draw.hs --- a/src/Data/Geometry/Arrangement/Draw.hs +++ b/src/Data/Geometry/Arrangement/Draw.hs @@ -12,13 +12,9 @@ import Control.Lens import Data.Geometry.Arrangement -import Data.Geometry.Ipe +import Ipe import Data.Geometry.PlanarSubdivision.Draw -- | Draws an arrangement -drawArrangement :: IpeOut (Arrangement s l v e f r) Group r +drawArrangement :: (Ord r, Num r) => IpeOut (Arrangement s l v e f r) Group r drawArrangement = drawPlanarSubdivision' . view subdivision - --- | Draws an arrangement -drawColoredArrangement :: IpeOut (Arrangement s l v e (Maybe (IpeColor r)) r) Group r -drawColoredArrangement = drawColoredPlanarSubdivision . view subdivision diff --git a/src/Data/Geometry/Ipe.hs b/src/Data/Geometry/Ipe.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe.hs +++ /dev/null @@ -1,28 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- --- Reexports the functionality for reading and writing Ipe files. --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe( module Data.Geometry.Ipe.Types - , module Data.Geometry.Ipe.Writer - , module Data.Geometry.Ipe.Reader - , module Data.Geometry.Ipe.IpeOut - , module Data.Geometry.Ipe.FromIpe - , module Data.Geometry.Ipe.Attributes - , module Data.Geometry.Ipe.Value - , module Data.Geometry.Ipe.Color - ) where - -import Data.Geometry.Ipe.Types -import Data.Geometry.Ipe.Writer -import Data.Geometry.Ipe.Reader -import Data.Geometry.Ipe.IpeOut -import Data.Geometry.Ipe.FromIpe -import Data.Geometry.Ipe.Attributes -import Data.Geometry.Ipe.Value -import Data.Geometry.Ipe.Color(IpeColor(..)) diff --git a/src/Data/Geometry/Ipe/Attributes.hs b/src/Data/Geometry/Ipe/Attributes.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Attributes.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE UndecidableInstances #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe.Attributes --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- --- Possible Attributes we can assign to items in an Ipe file --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe.Attributes where - -import Control.Lens hiding (rmap, Const) -import Data.Geometry.Ipe.Value -import Data.Singletons -import Data.Singletons.TH -import Data.Text (Text) -import Data.Vinyl -import Data.Vinyl.TypeLevel -import Data.Vinyl.Functor -import Text.Read (lexP, step, parens, prec, (+++) - , Lexeme(Ident), readPrec, readListPrec, readListPrecDefault) - --------------------------------------------------------------------------------- - - -data AttributeUniverse = -- common - Layer | Matrix | Pin | Transformations - -- symbol - | Stroke | Fill | Pen | Size - -- Path - | Dash | LineCap | LineJoin - | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient - -- Group - | Clip - -- Extra --- | X Text - deriving (Show,Read,Eq) - - -genSingletons [ ''AttributeUniverse ] - - -type CommonAttributes = [ Layer, Matrix, Pin, Transformations ] - - -type TextLabelAttributes = CommonAttributes -type MiniPageAttributes = CommonAttributes - -type ImageAttributes = CommonAttributes - - -type SymbolAttributes = CommonAttributes ++ - [Stroke, Fill, Pen, Size] - -type PathAttributes = CommonAttributes ++ - [ Stroke, Fill, Dash, Pen, LineCap, LineJoin - , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient - ] - -type GroupAttributes = CommonAttributes ++ '[ 'Clip] - - - --------------------------------------------------------------------------------- --- * Attr - --- | Attr implements the mapping from labels to types as specified by the --- (symbol representing) the type family 'f' -newtype Attr (f :: TyFun u * -> *) -- Symbol repr. the Type family mapping - -- Labels in universe u to concrete types - (label :: u) = GAttr { _getAttr :: Maybe (Apply f label) } - - -deriving instance Eq (Apply f label) => Eq (Attr f label) -deriving instance Ord (Apply f label) => Ord (Attr f label) - -makeLenses ''Attr - --- | Constructor for constructing an Attr given an actual value. -pattern Attr :: Apply f label -> Attr f label -pattern Attr x = GAttr (Just x) - --- | An Attribute that is not set -pattern NoAttr :: Attr f label -pattern NoAttr = GAttr Nothing -{-# COMPLETE NoAttr, Attr #-} - - -traverseAttr :: Applicative h => (Apply f label -> h (Apply g label)) - -> Attr f label -> h (Attr g label) -traverseAttr f = \case - Attr x -> Attr <$> f x - NoAttr -> pure NoAttr - --- | Traverse for the situation where the type is not actually parameterized. -pureAttr :: (Applicative h, Apply f a ~ Apply g a) => Attr f a -> h (Attr g a) -pureAttr = pure . \case - Attr a -> Attr a - NoAttr -> NoAttr - - -instance Show (Apply f label) => Show (Attr f label) where - showsPrec d NoAttr = showParen (d > app_prec) $ showString "NoAttr" - where app_prec = 10 - showsPrec d (Attr a) = showParen (d > up_prec) $ - showString "Attr " . showsPrec (up_prec+1) a - where up_prec = 5 - -instance Read (Apply f label) => Read (Attr f label) where - readPrec = parens $ (prec app_prec $ do - Ident "NoAttr" <- lexP - pure NoAttr) - +++ (prec up_prec $ do - Ident "Attr" <- lexP - a <- step readPrec - pure $ Attr a) - where - app_prec = 10 - up_prec = 5 - readListPrec = readListPrecDefault - - - --- | Give pref. to the *RIGHT* -instance Semigroup (Attr f l) where - _ <> b@(Attr _) = b - a <> _ = a - -instance Monoid (Attr f l) where - mempty = NoAttr - mappend = (<>) - --------------------------------------------------------------------------------- --- * Attributes - --- | A collection of Attributes. -newtype Attributes (f :: TyFun u * -> *) (ats :: [u]) = Attrs (Rec (Attr f) ats) - -unAttrs :: Lens (Attributes f ats) (Attributes f' ats') (Rec (Attr f) ats) (Rec (Attr f') ats') -unAttrs = lens (\(Attrs r) -> r) (const Attrs) - -deriving instance ( RMap ats, ReifyConstraint Show (Attr f) ats, RecordToList ats - , RecAll (Attr f) ats Show) => Show (Attributes f ats) --- deriving instance (RecAll (Attr f) ats Read) => Read (Attributes f ats) - -instance ( ReifyConstraint Eq (Attr f) ats, RecordToList ats - , RecAll (Attr f) ats Eq) => Eq (Attributes f ats) where - (Attrs a) == (Attrs b) = and . recordToList - . zipRecsWith (\x (Compose (Dict y)) -> Const $ x == y) a - . (reifyConstraint @Eq) $ b - -instance RecApplicative ats => Monoid (Attributes f ats) where - mempty = Attrs $ rpure mempty - a `mappend` b = a <> b - -instance Semigroup (Attributes f ats) where - (Attrs as) <> (Attrs bs) = Attrs $ zipRecsWith mappend as bs - -traverseAttrs :: Applicative h - => (forall label. Attr f label -> h (Attr g label)) - -> Attributes f ats -> h (Attributes g ats) -traverseAttrs f (Attrs ats) = Attrs <$> rtraverse f ats - - - -zipRecsWith :: (forall a. f a -> g a -> h a) - -> Rec f as -> Rec g as -> Rec h as -zipRecsWith _ RNil _ = RNil -zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss - - ----------------------------------------- - --- | Lens into a specific attribute, if it is set. -ixAttr :: forall at ats proxy f. (at ∈ ats) - => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at)) -ixAttr _ = unAttrs.(rlens @at).getAttr - --- | Prism into a particular attribute. -_Attr :: forall at ats proxy f. (at ∈ ats, RecApplicative ats) - => proxy at -> Prism' (Attributes f ats) (Apply f at) -_Attr a = prism' setA getA - where - setA x = setAttr a x mempty - getA = lookupAttr a - --- | Looks up a particular attribute. -lookupAttr :: (at ∈ ats) => proxy at -> Attributes f ats -> Maybe (Apply f at) -lookupAttr p = view (ixAttr p) - --- | Sets a particular attribute -setAttr :: forall proxy at ats f. (at ∈ ats) - => proxy at -> Apply f at -> Attributes f ats -> Attributes f ats -setAttr _ a (Attrs r) = Attrs $ rput (Attr a :: Attr f at) r - - --- | gets and removes the attribute from Attributes -takeAttr :: forall proxy at ats f. (at ∈ ats) - => proxy at -> Attributes f ats -> ( Maybe (Apply f at) - , Attributes f ats ) -takeAttr p ats = (lookupAttr p ats, ats&ixAttr p .~ Nothing) - --- | unsets/Removes an attribute -unSetAttr :: forall proxy at ats f. (at ∈ ats) - => proxy at -> Attributes f ats -> Attributes f ats -unSetAttr p = snd . takeAttr p - --- | Creates a singleton attribute -attr :: (at ∈ ats, RecApplicative ats) - => proxy at -> Apply f at -> Attributes f ats -attr p x = x^.re (_Attr p) - --------------------------------------------------------------------------------- --- | Common Attributes - --- IpeObjects may have attributes. Essentially attributes are (key,value) --- pairs. The key is some name. Which attributes an object can have depends on --- the type of the object. However, all ipe objects support the following --- 'common attributes': - --- data CommonAttributeUniverse = Layer | Matrix | Pin | Transformations --- deriving (Show,Read,Eq) - --- | Possible values for Pin -data PinType = No | Yes | Horizontal | Vertical - deriving (Eq,Show,Read) - --- | Possible values for Transformation -data TransformationTypes = Affine | Rigid | Translations deriving (Show,Read,Eq) - --- type family CommonAttrElf (r :: *) (f :: CommonAttributeUniverse)where --- CommonAttrElf r 'Layer = Text --- CommonAttrElf r 'Matrix = Matrix 3 3 r --- CommonAttrElf r Pin = PinType --- CommonAttrElf r Transformations = TransformationTypes - --- genDefunSymbols [''CommonAttrElf] - - --- type CommonAttributes r = --- Attributes (CommonAttrElfSym1 r) [ 'Layer, 'Matrix, Pin, Transformations ] - --------------------------------------------------------------------------------- --- Text Attributes - --- these Attributes are speicifc to IpeObjects representing TextLabels and --- MiniPages. The same structure as for the `CommonAttributes' applies here. - --- | TODO - --------------------------------------------------------------------------------- --- | Symbol Attributes - --- | The optional Attributes for a symbol --- data SymbolAttributeUniverse = SymbolStroke | SymbolFill | SymbolPen | Size --- deriving (Show,Eq) - -newtype IpeSize r = IpeSize (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable) -newtype IpePen r = IpePen (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable) - - --- -- | And the corresponding types --- type family SymbolAttrElf (r :: *) (s :: SymbolAttributeUniverse) :: * where --- SymbolAttrElf r SymbolStroke = IpeColor --- SymbolAttrElf r SymbolPen = IpePen r --- SymbolAttrElf r SymbolFill = IpeColor --- SymbolAttrElf r Size = IpeSize r - --- genDefunSymbols [''SymbolAttrElf] - - --- type SymbolAttributes r = [SymbolStroke, SymbolFill, SymbolPen, Size] - --- type SymbolAttributes r = --- Attributes (SymbolAttrElfSym1 r) [SymbolStroke, SymbolFill, SymbolPen, Size] - -------------------------------------------------------------------------------- --- | Path Attributes - --- | Possible attributes for a path --- data PathAttributeUniverse = Stroke | Fill | Dash | Pen | LineCap | LineJoin --- | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient --- deriving (Show,Eq) - - --- | Possible values for Dash -data IpeDash r = DashNamed Text - | DashPattern [r] r - deriving (Show,Eq,Functor,Foldable,Traversable) - --- | Allowed Fill types -data FillType = Wind | EOFill deriving (Show,Read,Eq) - --- | IpeOpacity, IpeTyling, and IpeGradient are all symbolic values -type IpeOpacity = Text -type IpeTiling = Text -type IpeGradient = Text - --- | Possible values for an ipe arrow -data IpeArrow r = IpeArrow { _arrowName :: Text - , _arrowSize :: IpeSize r - } deriving (Show,Eq,Functor,Foldable,Traversable) -makeLenses ''IpeArrow - -normalArrow :: IpeArrow r -normalArrow = IpeArrow "normal" (IpeSize $ Named "normal/normal") - --------------------------------------------------------------------------------- --- | Group Attributes - --- | The only group attribute is a Clip --- data GroupAttributeUniverse = Clip deriving (Show,Read,Eq,Ord) - --- A clipping path is a Path. Which is defined in Data.Geometry.Ipe.Types. To --- avoid circular imports, we define GroupAttrElf and GroupAttribute there. - --------------------------------------------------------------------------------- --- * Attribute names in Ipe - - --- | For the types representing attribute values we can get the name/key to use --- when serializing to ipe. -class IpeAttrName (a :: AttributeUniverse) where - attrName :: proxy a -> Text - --- CommonAttributeUnivers -instance IpeAttrName Layer where attrName _ = "layer" -instance IpeAttrName Matrix where attrName _ = "matrix" -instance IpeAttrName Pin where attrName _ = "pin" -instance IpeAttrName Transformations where attrName _ = "transformations" - --- IpeSymbolAttributeUniversre -instance IpeAttrName Stroke where attrName _ = "stroke" -instance IpeAttrName Fill where attrName _ = "fill" -instance IpeAttrName Pen where attrName _ = "pen" -instance IpeAttrName Size where attrName _ = "size" - --- PathAttributeUniverse -instance IpeAttrName Dash where attrName _ = "dash" -instance IpeAttrName LineCap where attrName _ = "cap" -instance IpeAttrName LineJoin where attrName _ = "join" -instance IpeAttrName FillRule where attrName _ = "fillrule" -instance IpeAttrName Arrow where attrName _ = "arrow" -instance IpeAttrName RArrow where attrName _ = "rarrow" -instance IpeAttrName Opacity where attrName _ = "opacity" -instance IpeAttrName Tiling where attrName _ = "tiling" -instance IpeAttrName Gradient where attrName _ = "gradient" - --- GroupAttributeUniverse -instance IpeAttrName Clip where attrName _ = "clip" - - --- -- | Function that states that all elements in xs satisfy a given constraint c --- type family AllSatisfy (c :: k -> Constraint) (xs :: [k]) :: Constraint where --- AllSatisfy c '[] = () --- AllSatisfy c (x ': xs) = (c x, AllSatisfy c xs) - - --- | Writing Attribute names -writeAttrNames :: AllConstrained IpeAttrName rs => Rec f rs -> Rec (Const Text) rs -writeAttrNames RNil = RNil -writeAttrNames (x :& xs) = Const (write'' x) :& writeAttrNames xs - where - write'' :: forall f s. IpeAttrName s => f s -> Text - write'' _ = attrName (Proxy :: Proxy s) - --- - --------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/Ipe/Color.hs b/src/Data/Geometry/Ipe/Color.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Color.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe.Color --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- --- Data type for representing colors in ipe as well as the colors available in --- the standard ipe stylesheet. --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe.Color where - -import Data.Colour.SRGB (RGB(..)) -import Data.Geometry.Ipe.Value -import Data.Text -import Data.Traversable --------------------------------------------------------------------------------- - -newtype IpeColor r = IpeColor (IpeValue (RGB r)) deriving (Show,Read,Eq) - -instance Ord r => Ord (IpeColor r) where - (IpeColor c) `compare` (IpeColor c') = fmap f c `compare` fmap f c' - where - f (RGB r g b) = (r,g,b) - -instance Functor IpeColor where - fmap = fmapDefault -instance Foldable IpeColor where - foldMap = foldMapDefault -instance Traversable IpeColor where - traverse f (IpeColor v) = IpeColor <$> traverse traverseRGB v - where - traverseRGB (RGB r g b) = RGB <$> f r <*> f g <*> f b - --- | Creates a named color -named :: Text -> IpeColor r -named = IpeColor . Named - --------------------------------------------------------------------------------- --- * Basic Named colors - -red :: IpeColor r -red = named "red" - -green :: IpeColor r -green = named "green" - -blue :: IpeColor r -blue = named "blue" - -yellow :: IpeColor r -yellow = named "yellow" - -orange :: IpeColor r -orange = named "orange" - -gold :: IpeColor r -gold = named "gold" - -purple :: IpeColor r -purple = named "purple" - -gray :: IpeColor r -gray = named "gray" - -brown :: IpeColor r -brown = named "brown" - -navy :: IpeColor r -navy = named "navy" - -pink :: IpeColor r -pink = named "pink" - -seagreen :: IpeColor r -seagreen = named "seagreen" - -turquoise :: IpeColor r -turquoise = named "turquoise" - -violet :: IpeColor r -violet = named "violet" - -darkblue :: IpeColor r -darkblue = named "darkblue" - -darkcyan :: IpeColor r -darkcyan = named "darkcyan" - -darkgray :: IpeColor r -darkgray = named "darkgray" - -darkgreen :: IpeColor r -darkgreen = named "darkgreen" - -darkmagenta :: IpeColor r -darkmagenta = named "darkmagenta" - -darkorange :: IpeColor r -darkorange = named "darkorange" - -darkred :: IpeColor r -darkred = named "darkred" - -lightblue :: IpeColor r -lightblue = named "lightblue" - -lightcyan :: IpeColor r -lightcyan = named "lightcyan" - -lightgray :: IpeColor r -lightgray = named "lightgray" - -lightgreen :: IpeColor r -lightgreen = named "lightgreen" - -lightyellow :: IpeColor r -lightyellow = named "lightyellow" diff --git a/src/Data/Geometry/Ipe/Content.hs b/src/Data/Geometry/Ipe/Content.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Content.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Geometry.Ipe.Content( - Image(Image), imageData, rect - , TextLabel(..) - , MiniPage(..), width - - , IpeSymbol(Symbol), symbolPoint, symbolName - - , Path(Path), pathSegments - , PathSegment(..) - - , Group(Group), groupItems - - - , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath - , IpeObject' - , ipeObject', ToObject(..) - - , IpeAttributes - , Attributes', AttributesOf, AttrMap, AttrMapSym1 - , attributes, traverseIpeAttrs - , commonAttributes - - , flattenGroups - ) where - -import Control.Lens hiding (views) -import Data.Bitraversable -import Data.Ext -import Data.Geometry.Box (Rectangle) -import qualified Data.Geometry.Ipe.Attributes as AT -import Data.Geometry.Ipe.Attributes hiding (Matrix) -import Data.Geometry.Ipe.Color -import Data.Geometry.Ipe.Layer -import Data.Geometry.Ipe.Path -import Data.Geometry.Matrix -import Data.Geometry.Point -import Data.Geometry.Properties -import Data.Geometry.Transformation -import Data.Proxy -import Data.Singletons.TH (genDefunSymbols) -import Data.Text (Text) -import Data.Traversable -import Data.Vinyl hiding (Label) -import Data.Vinyl.TypeLevel (AllConstrained) - --------------------------------------------------------------------------------- --- | Image Objects - -data Image r = Image { _imageData :: () - , _rect :: Rectangle () r - } deriving (Show,Eq,Ord) -makeLenses ''Image - -type instance NumType (Image r) = r -type instance Dimension (Image r) = 2 - -instance Fractional r => IsTransformable (Image r) where - transformBy t = over rect (transformBy t) - -instance Functor Image where - fmap = fmapDefault -instance Foldable Image where - foldMap = foldMapDefault -instance Traversable Image where - traverse f (Image d r) = Image d <$> bitraverse pure f r - --------------------------------------------------------------------------------- --- | Text Objects - -data TextLabel r = Label Text (Point 2 r) - deriving (Show,Eq,Ord,Functor,Foldable,Traversable) - -data MiniPage r = MiniPage Text (Point 2 r) r - deriving (Show,Eq,Ord,Functor,Foldable,Traversable) - -type instance NumType (TextLabel r) = r -type instance Dimension (TextLabel r) = 2 - -type instance NumType (MiniPage r) = r -type instance Dimension (MiniPage r) = 2 - -instance Fractional r => IsTransformable (TextLabel r) where - transformBy t (Label txt p) = Label txt (transformBy t p) - -instance Fractional r => IsTransformable (MiniPage r) where - transformBy t (MiniPage txt p w) = MiniPage txt (transformBy t p) w - -width :: MiniPage t -> t -width (MiniPage _ _ w) = w - --------------------------------------------------------------------------------- --- | Ipe Symbols, i.e. Points - --- | A symbol (point) in ipe -data IpeSymbol r = Symbol { _symbolPoint :: Point 2 r - , _symbolName :: Text - } - deriving (Show,Eq,Ord,Functor,Foldable,Traversable) -makeLenses ''IpeSymbol - -type instance NumType (IpeSymbol r) = r -type instance Dimension (IpeSymbol r) = 2 - -instance Fractional r => IsTransformable (IpeSymbol r) where - transformBy t = over symbolPoint (transformBy t) - - - --- | Example of an IpeSymbol. I.e. A symbol that expresses that the size is 'large' --- sizeSymbol :: Attributes (AttrMapSym1 r) (SymbolAttributes r) --- sizeSymbol = attr SSize (IpeSize $ Named "large") - - --------------------------------------------------------------------------------- --- * Paths are in a separate module - --------------------------------------------------------------------------------- --- * Attribute Mapping - - --- | The mapping between the labels of the the attributes and the types of the --- attributes with these labels. For example, the 'Matrix' label/attribute should --- have a value of type 'Matrix 3 3 r'. -type family AttrMap (r :: *) (l :: AttributeUniverse) :: * where - AttrMap r 'Layer = LayerName - AttrMap r AT.Matrix = Matrix 3 3 r - AttrMap r Pin = PinType - AttrMap r Transformations = TransformationTypes - - AttrMap r Stroke = IpeColor r - AttrMap r Pen = IpePen r - AttrMap r Fill = IpeColor r - AttrMap r Size = IpeSize r - - AttrMap r Dash = IpeDash r - AttrMap r LineCap = Int - AttrMap r LineJoin = Int - AttrMap r FillRule = FillType - AttrMap r Arrow = IpeArrow r - AttrMap r RArrow = IpeArrow r - AttrMap r Opacity = IpeOpacity - AttrMap r Tiling = IpeTiling - AttrMap r Gradient = IpeGradient - - AttrMap r Clip = Path r -- strictly we event want this to be a closed path I guess - -genDefunSymbols [''AttrMap] - --------------------------------------------------------------------------------- - - --- | For the types representing attribute values we can get the name/key to use --- when serializing to ipe. -class TraverseIpeAttr (a :: AttributeUniverse) where - traverseIpeAttr :: Applicative h - => (r -> h s) -> Attr (AttrMapSym1 r) a -> h (Attr (AttrMapSym1 s) a) - - -- attrName :: proxy a -> Text - --- CommonAttributeUnivers -instance TraverseIpeAttr Layer where traverseIpeAttr _ = pureAttr -instance TraverseIpeAttr AT.Matrix where traverseIpeAttr f = traverseAttr (traverse f) -instance TraverseIpeAttr Pin where traverseIpeAttr _ = pureAttr -instance TraverseIpeAttr Transformations where traverseIpeAttr _ = pureAttr - --- -- IpeSymbolAttributeUniversre -instance TraverseIpeAttr Stroke where traverseIpeAttr f = traverseAttr (traverse f) -instance TraverseIpeAttr Fill where traverseIpeAttr f = traverseAttr (traverse f) -instance TraverseIpeAttr Pen where traverseIpeAttr f = traverseAttr (traverse f) -instance TraverseIpeAttr Size where traverseIpeAttr f = traverseAttr (traverse f) - --- -- PathAttributeUniverse -instance TraverseIpeAttr Dash where traverseIpeAttr f = traverseAttr (traverse f) -instance TraverseIpeAttr LineCap where traverseIpeAttr _ = pureAttr -instance TraverseIpeAttr LineJoin where traverseIpeAttr _ = pureAttr -instance TraverseIpeAttr FillRule where traverseIpeAttr _ = pureAttr -instance TraverseIpeAttr Arrow where traverseIpeAttr f = traverseAttr (traverse f) -instance TraverseIpeAttr RArrow where traverseIpeAttr f = traverseAttr (traverse f) -instance TraverseIpeAttr Opacity where traverseIpeAttr _ = pureAttr -instance TraverseIpeAttr Tiling where traverseIpeAttr _ = pureAttr -instance TraverseIpeAttr Gradient where traverseIpeAttr _ = pureAttr - - --- GroupAttributeUniverse -instance TraverseIpeAttr Clip where traverseIpeAttr f = traverseAttr (traverse f) - --------------------------------------------------------------------------------- --- | Groups and Objects - --------------------------------------------------------------------------------- --- | Group Attributes - --- -- | Now that we know what a Path is we can define the Attributes of a Group. --- type family GroupAttrElf (r :: *) (s :: GroupAttributeUniverse) :: * where --- GroupAttrElf r Clip = Path r -- strictly we event want this to be a closed path I guess - --- genDefunSymbols [''GroupAttrElf] - --- type GroupAttributes r = Attributes (GroupAttrElfSym1 r) '[ 'Clip] - - --- | A group is essentially a list of IpeObjects. -newtype Group r = Group [IpeObject r] deriving (Show,Eq,Functor,Foldable,Traversable) - -type instance NumType (Group r) = r -type instance Dimension (Group r) = 2 - -instance Fractional r => IsTransformable (Group r) where - transformBy t (Group s) = Group $ fmap (transformBy t) s - - -type family AttributesOf (t :: * -> *) :: [AttributeUniverse] where - AttributesOf Group = GroupAttributes - AttributesOf Image = CommonAttributes - AttributesOf TextLabel = CommonAttributes - AttributesOf MiniPage = CommonAttributes - AttributesOf IpeSymbol = SymbolAttributes - AttributesOf Path = PathAttributes - - --- | Attributes' :: * -> [AttributeUniverse] -> * -type Attributes' r = Attributes (AttrMapSym1 r) - -type IpeAttributes g r = Attributes' r (AttributesOf g) - - --- | An IpeObject' is essentially the oject ogether with its attributes -type IpeObject' g r = g r :+ IpeAttributes g r - -attributes :: Lens' (IpeObject' g r) (IpeAttributes g r) -attributes = extra - --- | traverse for ipe attributes -traverseIpeAttrs :: ( Applicative f - , AllConstrained TraverseIpeAttr (AttributesOf g) - ) => proxy g -> (r -> f s) -> IpeAttributes g r -> f (IpeAttributes g s) -traverseIpeAttrs _ f (Attrs ats) = fmap Attrs . traverseIpeAttrs' f $ ats - -traverseIpeAttrs' :: ( Applicative f - , AllConstrained TraverseIpeAttr ats - ) - => (r -> f s) - -> Rec (Attr (AttrMapSym1 r)) ats - -> f (Rec (Attr (AttrMapSym1 s)) ats) -traverseIpeAttrs' f = \case - RNil -> pure RNil - (a :& ats') -> (:&) <$> traverseIpeAttr f a <*> traverseIpeAttrs' f ats' - - -data IpeObject r = - IpeGroup (IpeObject' Group r) - | IpeImage (IpeObject' Image r) - | IpeTextLabel (IpeObject' TextLabel r) - | IpeMiniPage (IpeObject' MiniPage r) - | IpeUse (IpeObject' IpeSymbol r) - | IpePath (IpeObject' Path r) - - -traverseIpeObject' :: forall g r f s. ( Applicative f - , Traversable g - , AllConstrained TraverseIpeAttr (AttributesOf g) - ) - => (r -> f s) -> IpeObject' g r -> f (IpeObject' g s) -traverseIpeObject' f (i :+ ats) = (:+) <$> traverse f i <*> traverseIpeAttrs (Proxy @g) f ats - -instance Functor IpeObject where - fmap = fmapDefault -instance Foldable IpeObject where - foldMap = foldMapDefault -instance Traversable IpeObject where - traverse f = \case - IpeGroup g -> IpeGroup <$> traverseIpeObject' f g - IpeImage i -> IpeImage <$> traverseIpeObject' f i - IpeTextLabel l -> IpeTextLabel <$> traverseIpeObject' f l - IpeMiniPage p -> IpeMiniPage <$> traverseIpeObject' f p - IpeUse u -> IpeUse <$> traverseIpeObject' f u - IpePath p -> IpePath <$> traverseIpeObject' f p - - -deriving instance (Show r) => Show (IpeObject r) --- deriving instance (Read r) => Read (IpeObject r) -deriving instance (Eq r) => Eq (IpeObject r) - -type instance NumType (IpeObject r) = r -type instance Dimension (IpeObject r) = 2 - -makePrisms ''IpeObject - -groupItems :: Lens (Group r) (Group s) [IpeObject r] [IpeObject s] -groupItems = lens (\(Group xs) -> xs) (const Group) - -class ToObject i where - mkIpeObject :: IpeObject' i r -> IpeObject r - -instance ToObject Group where mkIpeObject = IpeGroup -instance ToObject Image where mkIpeObject = IpeImage -instance ToObject TextLabel where mkIpeObject = IpeTextLabel -instance ToObject MiniPage where mkIpeObject = IpeMiniPage -instance ToObject IpeSymbol where mkIpeObject = IpeUse -instance ToObject Path where mkIpeObject = IpePath - -instance Fractional r => IsTransformable (IpeObject r) where - transformBy t (IpeGroup i) = IpeGroup $ i&core %~ transformBy t - transformBy t (IpeImage i) = IpeImage $ i&core %~ transformBy t - transformBy t (IpeTextLabel i) = IpeTextLabel $ i&core %~ transformBy t - transformBy t (IpeMiniPage i) = IpeMiniPage $ i&core %~ transformBy t - transformBy t (IpeUse i) = IpeUse $ i&core %~ transformBy t - transformBy t (IpePath i) = IpePath $ i&core %~ transformBy t - --- | Shorthand for constructing ipeObjects -ipeObject' :: ToObject i => i r -> IpeAttributes i r -> IpeObject r -ipeObject' i a = mkIpeObject $ i :+ a - -commonAttributes :: Lens' (IpeObject r) (Attributes (AttrMapSym1 r) CommonAttributes) -commonAttributes = lens (Attrs . g) (\x (Attrs a) -> s x a) - where - select :: (CommonAttributes ⊆ AttributesOf g) => - Lens' (IpeObject' g r) (Rec (Attr (AttrMapSym1 r)) CommonAttributes) - select = attributes.unAttrs.rsubset - - g (IpeGroup i) = i^.select - g (IpeImage i) = i^.select - g (IpeTextLabel i) = i^.select - g (IpeMiniPage i) = i^.select - g (IpeUse i) = i^.select - g (IpePath i) = i^.select - - s (IpeGroup i) a = IpeGroup $ i&select .~ a - s (IpeImage i) a = IpeImage $ i&select .~ a - s (IpeTextLabel i) a = IpeTextLabel $ i&select .~ a - s (IpeMiniPage i) a = IpeMiniPage $ i&select .~ a - s (IpeUse i) a = IpeUse $ i&select .~ a - s (IpePath i) a = IpePath $ i&select .~ a - --- | collect all non-group objects -flattenGroups :: [IpeObject r] -> [IpeObject r] -flattenGroups = concatMap flattenGroups' - where - flattenGroups' :: IpeObject r -> [IpeObject r] - flattenGroups' (IpeGroup (Group gs :+ ats)) = - map (applyAts ats) . concatMap flattenGroups' $ gs - where - applyAts _ = id - flattenGroups' o = [o] diff --git a/src/Data/Geometry/Ipe/FromIpe.hs b/src/Data/Geometry/Ipe/FromIpe.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/FromIpe.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe.FromIpe --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- --- Functions that help reading geometric values from ipe images. --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe.FromIpe( - -- * Individual readers - _asPoint - , _asLineSegment - , _asRectangle - , _asTriangle - - , _asPolyLine - , _asSomePolygon, _asSimplePolygon, _asMultiPolygon - - -- * Dealing with Attributes - , _withAttrs - - -- * Default readers - , HasDefaultFromIpe(..) - - -- * Reading all elements of a particular type - , readAll, readAllFrom - ) where - -import Control.Lens hiding (Simple) -import Data.Ext -import Data.Geometry.Ball -import Data.Geometry.Box -import Data.Geometry.Ellipse (Ellipse, _EllipseCircle) -import Data.Geometry.Ipe.Path -import Data.Geometry.Ipe.Reader -import Data.Geometry.Ipe.Types -import Data.Geometry.LineSegment -import Data.Geometry.Point -import qualified Data.Geometry.PolyLine as PolyLine -import Data.Geometry.Polygon -import Data.Geometry.Properties -import Data.Geometry.Triangle -import qualified Data.LSeq as LSeq -import Data.List.NonEmpty (NonEmpty(..)) - --------------------------------------------------------------------------------- --- $setup --- >>> :set -XOverloadedStrings --- >>> import Data.Geometry.Ipe.Attributes --- >>> import Data.Geometry.Ipe.Color(IpeColor(..)) --- >>> import Data.Geometry.Point --- >>> :{ --- let testPath :: Path Int --- testPath = Path . fromSingleton . PolyLineSegment --- . PolyLine.fromPoints . map ext --- $ [ origin, Point2 10 10, Point2 200 100 ] --- testPathAttrs :: IpeAttributes Path Int --- testPathAttrs = attr SStroke (IpeColor "red") --- testObject :: IpeObject Int --- testObject = IpePath (testPath :+ testPathAttrs) --- :} - - - --- | Extracts the point from a Symbol. When creating a symbol this --- creates a disk that supports a stroke color. -_asPoint :: Prism' (IpeSymbol r) (Point 2 r) -_asPoint = prism' (flip Symbol "mark/disk(sx)") (Just . view symbolPoint) - --- | Try to convert a path into a line segment, fails if the path is not a line --- segment or a polyline with more than two points. --- --- -_asLineSegment :: Prism' (Path r) (LineSegment 2 () r) -_asLineSegment = prism' seg2path path2seg - where - seg2path = review _asPolyLine . PolyLine.fromLineSegment - path2seg p = PolyLine.asLineSegment' =<< preview _asPolyLine p - --- | Convert to a polyline. Ignores all non-polyline parts --- --- >>> testPath ^? _asPolyLine --- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])}) -_asPolyLine :: Prism' (Path r) (PolyLine.PolyLine 2 () r) -_asPolyLine = prism' poly2path path2poly - where - poly2path = Path . fromSingleton . PolyLineSegment - path2poly = preview (pathSegments.traverse._PolyLineSegment) - -- TODO: Check that the path actually is a polyline, rather - -- than ignoring everything that does not fit - --- | Convert to a simple polygon -_asSimplePolygon :: Prism' (Path r) (Polygon Simple () r) -_asSimplePolygon = _asSomePolygon._Left - - --- | Tries to convert a path into a rectangle. -_asRectangle :: forall r. (Num r, Ord r) => Prism' (Path r) (Rectangle () r) -_asRectangle = prism' rectToPath pathToRect - where - rectToPath (corners -> Corners a b c d) = review _asSimplePolygon . fromPoints $ [a,b,c,d] - pathToRect p = p^?_asSimplePolygon >>= asRect - - asRect :: SimplePolygon () r -> Maybe (Rectangle () r) - asRect pg = case pg^..outerBoundaryVector.traverse of - [a,b,c,d] | isH a b && isV b c && isH c d && isV d a -> Just (boundingBoxList' [a,c]) - [a,b,c,d] | isV a b && isH b c && isV c d && isH d a -> Just (boundingBoxList' [a,c]) - _ -> Nothing - - isH (p :+ _) (q :+ _) = p^.xCoord == q^.xCoord - isV (p :+ _) (q :+ _) = p^.yCoord == q^.yCoord - - --- | Convert to a triangle -_asTriangle :: Prism' (Path r) (Triangle 2 () r) -_asTriangle = prism' triToPath path2tri - where - triToPath (Triangle p q r) = polygonToPath . unsafeFromPoints . map (&extra .~ ()) $ [p,q,r] - path2tri p = case p^..pathSegments.traverse._PolygonPath of - [] -> Nothing - [pg] -> case polygonVertices pg of - (a :| [b,c]) -> Just $ Triangle a b c - _ -> Nothing - _ -> Nothing - - - -- an ellipse is an affine transformation of the unit disk - - --- (Disk origin 1) (Vector2 1 1) - -_asEllipse :: Prism' (Path r) (Ellipse r) -_asEllipse = prism' toPath toEllipse - where - toPath = Path . fromSingleton . EllipseSegment - toEllipse p = case p^..pathSegments.traverse._EllipseSegment of - [e] -> Just e - _ -> Nothing - -_asCircle :: (Floating r, Eq r) => Prism' (Path r) (Circle () r) -_asCircle = _asEllipse._EllipseCircle --- FIXME: For reading we should not need the floating constraint! - -_asDisk :: (Floating r, Eq r) => Prism' (Path r) (Disk () r) -_asDisk = _asCircle.from _DiskCircle - - --- | Convert to a multipolygon -_asMultiPolygon :: Prism' (Path r) (MultiPolygon () r) -_asMultiPolygon = _asSomePolygon._Right - --- _asPolygon :: Prism' (Path r) (forall t. Polygon t () r) --- _asPolygon = prism' polygonToPath (fmap (either id id) . pathToPolygon) - -_asSomePolygon :: Prism' (Path r) (SomePolygon () r) -_asSomePolygon = prism' embed pathToPolygon - where - embed = either polygonToPath polygonToPath - - -polygonToPath :: Polygon t () r -> Path r -polygonToPath pg@SimplePolygon{} = Path . fromSingleton . PolygonPath $ pg -polygonToPath (MultiPolygon vs hs) = Path . LSeq.fromNonEmpty . fmap PolygonPath - $ vs :| hs - - -pathToPolygon :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r)) -pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of - [] -> Nothing - [pg] -> Just . Left $ pg - vs:hs -> Just . Right $ MultiPolygon vs hs - - - - - --------------------------------------------------------------------------------- - - --- | Use the first prism to select the ipe object to depicle with, and the second --- how to select the geometry object from there on. Then we can select the geometry --- object, directly with its attributes here. --- --- >>> testObject ^? _withAttrs _IpePath _asPolyLine --- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}) -_withAttrs :: Prism' (IpeObject r) (i r :+ IpeAttributes i r) -> Prism' (i r) g - -> Prism' (IpeObject r) (g :+ IpeAttributes i r) -_withAttrs po pg = prism' g2o o2g - where - g2o = review po . over core (review pg) - o2g o = preview po o >>= \(i :+ ats) -> (:+ ats) <$> preview pg i - - - - - --- instance HasDefaultIpeObject Path where --- defaultIpeObject' = _IpePath - - --- class HasDefaultFromIpe g where --- type DefaultFromIpe g :: * -> * --- defaultIpeObject :: proxy g -> Prism' (IpeObject r) (DefaultFromIpe g r :+ IpeAttributes (DefaultFromIpe g) r) --- defaultFromIpe :: proxy g -> Prism' (DefaultFromIpe g (NumType g)) g - - -class HasDefaultFromIpe g where - type DefaultFromIpe g :: * -> * - defaultFromIpe :: (r ~ NumType g) - => Prism' (IpeObject r) (g :+ IpeAttributes (DefaultFromIpe g) r) - -instance HasDefaultFromIpe (Point 2 r) where - type DefaultFromIpe (Point 2 r) = IpeSymbol - defaultFromIpe = _withAttrs _IpeUse _asPoint - where - - -instance HasDefaultFromIpe (LineSegment 2 () r) where - type DefaultFromIpe (LineSegment 2 () r) = Path - defaultFromIpe = _withAttrs _IpePath _asLineSegment - -instance HasDefaultFromIpe (Ellipse r) where - type DefaultFromIpe (Ellipse r) = Path - defaultFromIpe = _withAttrs _IpePath _asEllipse - -instance (Floating r, Eq r) => HasDefaultFromIpe (Circle () r) where - type DefaultFromIpe (Circle () r) = Path - defaultFromIpe = _withAttrs _IpePath _asCircle - -instance (Floating r, Eq r) => HasDefaultFromIpe (Disk () r) where - type DefaultFromIpe (Disk () r) = Path - defaultFromIpe = _withAttrs _IpePath _asDisk - -instance HasDefaultFromIpe (PolyLine.PolyLine 2 () r) where - type DefaultFromIpe (PolyLine.PolyLine 2 () r) = Path - defaultFromIpe = _withAttrs _IpePath _asPolyLine - - -instance HasDefaultFromIpe (SimplePolygon () r) where - type DefaultFromIpe (SimplePolygon () r) = Path - defaultFromIpe = _withAttrs _IpePath _asSimplePolygon - -instance HasDefaultFromIpe (MultiPolygon () r) where - type DefaultFromIpe (MultiPolygon () r) = Path - defaultFromIpe = _withAttrs _IpePath _asMultiPolygon - - --- | Read all g's from some ipe page(s). -readAll :: forall g r. (HasDefaultFromIpe g, r ~ NumType g) - => IpePage r -> [g :+ IpeAttributes (DefaultFromIpe g) r] -readAll p = p^..content.traverse.defaultFromIpe - --- | Convenience function from reading all g's from an ipe file. If there --- is an error reading or parsing the file the error is "thrown away". -readAllFrom :: (HasDefaultFromIpe g, r ~ NumType g, Coordinate r, Eq r) - => FilePath -> IO [g :+ IpeAttributes (DefaultFromIpe g) r] -readAllFrom fp = foldMap readAll <$> readSinglePageFile fp - -fromSingleton :: a -> LSeq.LSeq 1 a -fromSingleton = LSeq.fromNonEmpty . (:| []) diff --git a/src/Data/Geometry/Ipe/IpeOut.hs b/src/Data/Geometry/Ipe/IpeOut.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/IpeOut.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe.IpeOut --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- --- Functions that help drawing geometric values in ipe. An "IpeOut" is --- essenitally a function that converts a geometric type g into an IpeObject. --- --- We also proivde a "HasDefaultIpeOut" typeclass that defines a default --- conversion function from a geometry type g to an ipe type. --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe.IpeOut where - - -import Control.Lens hiding (Simple) -import Data.Bifunctor -import Data.Ext -import Data.Foldable (toList) -import Data.Geometry.Ball -import Data.Geometry.Boundary -import Data.Geometry.Box -import Data.Geometry.Ellipse (Ellipse, circleToEllipse) -import Data.Geometry.HalfLine -import Data.Geometry.Ipe.Attributes -import Data.Geometry.Ipe.Color (IpeColor(..)) -import Data.Geometry.Ipe.FromIpe -import Data.Geometry.Ipe.Types -import Data.Geometry.Line -import Data.Geometry.LineSegment -import Data.Geometry.Point -import Data.Geometry.PolyLine (PolyLine,fromLineSegment) -import Data.Geometry.Polygon -import Data.Geometry.Polygon.Convex -import Data.Geometry.Properties -import qualified Data.LSeq as LSeq -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Vinyl (Rec(..)) -import Data.Vinyl.CoRec -import Linear.Affine ((.+^)) - --------------------------------------------------------------------------------- - --- $setup --- >>> :set -XOverloadedStrings --- >>> :{ --- let myPolygon = fromPoints . map ext $ [origin, Point2 10 10, Point2 100 200] --- :} - --------------------------------------------------------------------------------- --- * The IpeOut type and the default combinator to use it - -type IpeOut g i r = g -> IpeObject' i r - - --- | Add attributes to an IpeObject' -(!) :: IpeObject' i r -> IpeAttributes i r -> IpeObject' i r -(!) i ats = i&extra %~ (<> ats) - --- | Render an ipe object --- --- --- >>> :{ --- iO $ defIO myPolygon ! attr SFill (IpeColor "blue") --- ! attr SLayer "alpha" --- ! attr SLayer "beta" --- :} --- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "blue"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}) --- --- >>> :{ --- iO $ ipeGroup [ iO $ ipePolygon myPolygon ! attr SFill (IpeColor "red") --- ] ! attr SLayer "alpha" --- :} --- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr}) --- -iO :: ToObject i => IpeObject' i r -> IpeObject r -iO = mkIpeObject - --- | Render to an ipe object using the defIO IpeOut --- --- --- >>> :{ --- iO'' myPolygon $ attr SFill (IpeColor "red") --- <> attr SLayer "alpha" --- <> attr SLayer "beta" --- :} --- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}) --- --- >>> iO'' [ myPolygon , myPolygon ] $ attr SLayer "alpha" --- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}),IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr}) -iO'' :: ( HasDefaultIpeOut g, NumType g ~ r - , DefaultIpeOut g ~ i, ToObject i - ) => g -> IpeAttributes i r - -> IpeObject r -iO'' g ats = iO $ defIO g ! ats - --- | generate an ipe object without any specific attributes -iO' :: HasDefaultIpeOut g => g -> IpeObject (NumType g) -iO' = iO . defIO - --------------------------------------------------------------------------------- --- * Default Conversions - --- | Class that specifies a default conversion from a geometry type g into an --- ipe object. -class ToObject (DefaultIpeOut g) => HasDefaultIpeOut g where - type DefaultIpeOut g :: * -> * - - defIO :: IpeOut g (DefaultIpeOut g) (NumType g) - -instance (HasDefaultIpeOut g, a ~ IpeAttributes (DefaultIpeOut g) (NumType g)) - => HasDefaultIpeOut (g :+ a) where - type DefaultIpeOut (g :+ a) = DefaultIpeOut g - defIO (g :+ ats) = defIO g ! ats - -instance HasDefaultIpeOut a => HasDefaultIpeOut [a] where - type DefaultIpeOut [a] = Group - defIO = ipeGroup . map (iO . defIO) - -instance HasDefaultIpeOut (Point 2 r) where - type DefaultIpeOut (Point 2 r) = IpeSymbol - defIO = ipeDiskMark - -instance HasDefaultIpeOut (LineSegment 2 p r) where - type DefaultIpeOut (LineSegment 2 p r) = Path - defIO = ipeLineSegment - -instance HasDefaultIpeOut (PolyLine 2 p r) where - type DefaultIpeOut (PolyLine 2 p r) = Path - defIO = ipePolyLine - -instance (Fractional r, Ord r) => HasDefaultIpeOut (Line 2 r) where - type DefaultIpeOut (Line 2 r) = Path - defIO = ipeLine - -instance (Fractional r, Ord r) => HasDefaultIpeOut (HalfLine 2 r) where - type DefaultIpeOut (HalfLine 2 r) = Path - defIO = ipeHalfLine - -instance HasDefaultIpeOut (Polygon t p r) where - type DefaultIpeOut (Polygon t p r) = Path - defIO = ipePolygon - -instance HasDefaultIpeOut (SomePolygon p r) where - type DefaultIpeOut (SomePolygon p r) = Path - defIO = either defIO defIO - -instance HasDefaultIpeOut (ConvexPolygon p r) where - type DefaultIpeOut (ConvexPolygon p r) = Path - defIO = defIO . view simplePolygon - -instance HasDefaultIpeOut (Ellipse r) where - type DefaultIpeOut (Ellipse r) = Path - defIO = ipeEllipse - -instance Floating r => HasDefaultIpeOut (Disk p r) where - type DefaultIpeOut (Disk p r) = Path - defIO = ipeDisk - -instance Floating r => HasDefaultIpeOut (Circle p r) where - type DefaultIpeOut (Circle p r) = Path - defIO = ipeCircle - -instance Num r => HasDefaultIpeOut (Rectangle p r) where - type DefaultIpeOut (Rectangle p r) = Path - defIO = ipeRectangle - --------------------------------------------------------------------------------- --- * Point Converters - -ipeMark :: Text -> IpeOut (Point 2 r) IpeSymbol r -ipeMark n p = Symbol p n :+ mempty - -ipeDiskMark :: IpeOut (Point 2 r) IpeSymbol r -ipeDiskMark = ipeMark "mark/disk(sx)" - --------------------------------------------------------------------------------- --- * Path Converters - --- | Size of the default bounding box used to clip lines and --- half-lines in the default IpeOuts. -defaultBox :: Num r => Rectangle () r -defaultBox = let z = 1000 - z' = negate z - in box (ext $ Point2 z' z') (ext $ Point2 z z) - --- | Renders a line as a Path. The line is clipped to the 'defaultBox' -ipeLine :: (Ord r, Fractional r) => IpeOut (Line 2 r) Path r -ipeLine = ipeLineIn defaultBox - --- | Renders the line in the given box. --- --- pre: the intersection of the box with the line is non-empty -ipeLineIn :: forall p r. (Ord r, Fractional r) - => Rectangle p r -> IpeOut (Line 2 r) Path r -ipeLineIn bBox l = match (l `intersect` bBox) $ - H (\NoIntersection -> error "ipeLineIn: precondition failed, no intersection") - :& H (\(_p :: Point 2 r) -> error "ipeLineIn: precondition failed, single point") - :& H ipeLineSegment - :& RNil - --- | Renders an Halfine. --- --- --- pre: the intersection of the box with the line is non-empty -ipeHalfLine :: (Ord r, Fractional r) => IpeOut (HalfLine 2 r) Path r -ipeHalfLine = ipeHalfLineIn defaultBox - --- | Renders the HalfLine in the given box. --- --- pre: the intersection of the box with the line is non-empty -ipeHalfLineIn :: forall p r. (Ord r, Fractional r) - => Rectangle p r -> IpeOut (HalfLine 2 r) Path r -ipeHalfLineIn bBox l = match (l `intersect` bBox) $ - H (\NoIntersection -> error "ipeHalfLineIn: precondition failed, no intersection") - :& H (\(_p :: Point 2 r) -> error "ipeHalfLineIn: precondition failed, single point") - :& H ipeLineSegment - :& RNil - -ipeLineSegment :: IpeOut (LineSegment 2 p r) Path r -ipeLineSegment s = (path . pathSegment $ s) :+ mempty - -ipePolyLine :: IpeOut (PolyLine 2 p r) Path r -ipePolyLine p = (path . PolyLineSegment . first (const ()) $ p) :+ mempty - -ipeEllipse :: IpeOut (Ellipse r) Path r -ipeEllipse = \e -> path (EllipseSegment e) :+ mempty - -ipeCircle :: Floating r => IpeOut (Circle p r) Path r -ipeCircle = ipeEllipse . circleToEllipse - -ipeDisk :: Floating r => IpeOut (Disk p r) Path r -ipeDisk d = ipeCircle (Boundary d) ! attr SFill (IpeColor "0.722 0.145 0.137") - --- | Helper to construct a path from a singleton item -path :: PathSegment r -> Path r -path = Path . LSeq.fromNonEmpty . (:| []) - -pathSegment :: LineSegment 2 p r -> PathSegment r -pathSegment = PolyLineSegment . fromLineSegment . first (const ()) - --- | Draw a polygon -ipePolygon :: IpeOut (Polygon t p r) Path r -ipePolygon (first (const ()) -> pg) = case pg of - SimplePolygon{} -> pg^.re _asSimplePolygon :+ mempty - MultiPolygon{} -> pg^.re _asMultiPolygon :+ mempty - - --- | Draw a Rectangle -ipeRectangle :: Num r => IpeOut (Rectangle p r) Path r -ipeRectangle r = ipePolygon $ unsafeFromPoints [tl,tr,br,bl] - where - Corners tl tr br bl = corners r - --------------------------------------------------------------------------------- --- * Group Converters - -ipeGroup :: Foldable f => IpeOut (f (IpeObject r)) Group r -ipeGroup xs = Group (toList xs) :+ mempty - - --------------------------------------------------------------------------------- --- * Text Converters - --- | Creates an text label -ipeLabel :: IpeOut (Text :+ Point 2 r) TextLabel r -ipeLabel (txt :+ p) = Label txt p :+ mempty - - --- | Annotate an IpeOut with a label -labelled :: (Show lbl, NumType g ~ r, ToObject i) - => (g -> Point 2 r) -- ^ where to place the label - -> IpeOut g i r -- ^ how to draw the geometric object - -> IpeOut (g :+ lbl) Group r -labelled pos f (g :+ lbl) = ipeGroup [iO $ f g, iO $ ipeLabel ((Text.pack $ show lbl) :+ pos g)] diff --git a/src/Data/Geometry/Ipe/Layer.hs b/src/Data/Geometry/Ipe/Layer.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Layer.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Data.Geometry.Ipe.Layer( - LayerName(LayerName), layerName - ) where - -import Control.Lens -import Data.Text (Text) -import GHC.Exts - --------------------------------------------------------------------------------- - -newtype LayerName = LayerName {_layerName :: Text } deriving (Show,Read,Eq,Ord,IsString) -makeLenses ''LayerName diff --git a/src/Data/Geometry/Ipe/Literal.hs b/src/Data/Geometry/Ipe/Literal.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Literal.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Data.Geometry.Ipe.Literal where - - -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as C -import Text.XML.Expat.Tree - -literally :: String -> Q Exp -literally = return . LitE . StringL - -lit :: QuasiQuoter -lit = QuasiQuoter { quoteExp = literally - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined - } - -litFile :: QuasiQuoter -litFile = quoteFile lit - - -xmlLiteral :: String -> Node T.Text T.Text -xmlLiteral = either (error "xmlLiteral. error parsing xml: " . show) id - . parse' defaultParseOptions . C.pack diff --git a/src/Data/Geometry/Ipe/Matrix.hs b/src/Data/Geometry/Ipe/Matrix.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Matrix.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Data.Geometry.Ipe.Matrix where - -import Control.Lens hiding (rmap) -import Data.Ext -import qualified Data.Geometry.Ipe.Attributes as AT -import Data.Geometry.Ipe.Attributes hiding (Matrix) -import Data.Geometry.Ipe.Types -import Data.Geometry.Properties -import Data.Geometry.Transformation -import Data.Proxy -import Data.Vinyl hiding (Label) - --------------------------------------------------------------------------------- - --- | Takes and applies the ipe Matrix attribute of this item. -applyMatrix' :: ( IsTransformable (i r) - , AT.Matrix ∈ AttributesOf i - , Dimension (i r) ~ 2, r ~ NumType (i r)) - => IpeObject' i r -> IpeObject' i r -applyMatrix' o@(i :+ ats) = maybe o (\m -> transformBy (Transformation m) i :+ ats') mm - where - (mm,ats') = takeAttr (Proxy :: Proxy AT.Matrix) ats - --- | Applies the matrix to an ipe object if it has one. -applyMatrix :: Fractional r => IpeObject r -> IpeObject r -applyMatrix (IpeGroup i) = IpeGroup . applyMatrix' - $ i&core.groupItems.traverse %~ applyMatrix - -- note that for a group we first (recursively) - -- apply the matrices, and then apply - -- the matrix of the group to its members. -applyMatrix (IpeImage i) = IpeImage $ applyMatrix' i -applyMatrix (IpeTextLabel i) = IpeTextLabel $ applyMatrix' i -applyMatrix (IpeMiniPage i) = IpeMiniPage $ applyMatrix' i -applyMatrix (IpeUse i) = IpeUse $ applyMatrix' i -applyMatrix (IpePath i) = IpePath $ applyMatrix' i - -applyMatrices :: Fractional r => IpeFile r -> IpeFile r -applyMatrices f = f&pages.traverse %~ applyMatricesPage - -applyMatricesPage :: Fractional r => IpePage r -> IpePage r -applyMatricesPage p = p&content.traverse %~ applyMatrix diff --git a/src/Data/Geometry/Ipe/ParserPrimitives.hs b/src/Data/Geometry/Ipe/ParserPrimitives.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/ParserPrimitives.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# Language FlexibleContexts #-} -{-# Language OverloadedStrings #-} -module Data.Geometry.Ipe.ParserPrimitives( runP, runP' - , pMany, pMany1, pChoice - , pChar, pSpace, pWhiteSpace, pInteger - , pNatural, pPaddedNatural - , (<*><>) , (<*><) - , (<***>) , (<***) , (***>) - , pMaybe , pCount , pSepBy - , Parser, ParseError - , pNotFollowedBy - ) where - - -import Text.Parsec(try) -import Text.Parsec(ParsecT, Stream) -import Text.Parsec.Text -import Text.ParserCombinators.Parsec hiding (Parser,try) -import qualified Data.Text as T - - -runP' :: Parser a -> T.Text -> (a, T.Text) -runP' p s = case runP p s of - Left e -> error $ show e - Right x -> x - -runP :: Parser a -> T.Text -> Either ParseError (a,T.Text) -runP p = parse ((,) <$> p <*> getInput) "" - - ----------------------------------------------------------------------------- --- | reexporting some standard combinators - -pMany :: Parser a -> Parser [a] -pMany = many - -pMany1 :: Parser a -> Parser [a] -pMany1 = many1 - - -pChoice :: [Parser a] -> Parser a -pChoice = choice . map try - - -pNatural :: Parser Integer -pNatural = read <$> pMany1 digit - --- | parses an integer with a prefix of zeros. Returns the total length of the --- string parced (i.e. number of digits) and the resulting antural number. -pPaddedNatural :: Parser (Int, Integer) -pPaddedNatural = (\s -> (length s, read s)) <$> pMany1 digit - -pInteger :: Parser Integer -pInteger = pNatural - <|> - negate <$> (pChar '-' *> pNatural) - -pChar :: Char -> Parser Char -pChar = char - -pSpace :: Parser Char -pSpace = pChar ' ' - -pWhiteSpace :: Parser [Char] -pWhiteSpace = pMany1 (space <|> newline) - -pMaybe :: Parser a -> Parser (Maybe a) -pMaybe = optionMaybe - -pCount :: Int -> Parser a -> Parser [a] -pCount = count - -pSepBy :: Parser a -> Parser b -> Parser [a] -pSepBy = sepBy - - --- | infix variant of notfollowed by -pNotFollowedBy :: Parser a -> Parser b -> Parser a -p `pNotFollowedBy` q = do { x <- p ; notFollowedBy' q ; return x } - where - -- | copy of the original notFollowedBy but replaced the error message - -- to get rid of the Show dependency - notFollowedBy' z = try (do{ _ <- try z; unexpected "not followed by" } - <|> return () - ) - ----------------------------------------------------------------------------- --- | Running parsers in reverse - -infix 1 <*><>, <*>< - --- | Runs parser q ``in reverse'' on the end of the input stream -(<*><>) :: (Reversable s, Stream s m t) - => ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b -p <*><> q = do - rev - x <- q - rev - f <- p - return $ f x - - -(<*><) :: (Stream s m t, Reversable s) - => ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b -p <*>< q = const <$> p <*><> q - - -rev :: (Reversable s, Stream s m t) => ParsecT s u m () -rev = getInput >>= (setInput . reverseS) - --- as :: Parser String --- as = many (char 'a') - --- foo :: Parser String --- foo = reverse <$> (string . reverse $ "foo") - --- prs :: Parser (String,String) --- prs = (,) <$> as <*>< foo' - --- foo' :: Parser String --- foo' = spaces ***> foo - --- (<***>) :: Parser (a -> b) - -infixr 2 <***>, ***>, <*** - --- | run the parsers in reverse order, first q, then p -(<***>) :: Monad m => m (t -> b) -> m t -> m b -p <***> q = do - x <- q - f <- p - return $ f x - --- | the variants with missing brackets -(***>) :: Monad m => m a -> m b -> m b -p ***> q = (\_ s -> s) <$> p <***> q - -(<***) :: Monad m => m b -> m t -> m b -p <*** q = (\s _ -> s) <$> p <***> q - -class Reversable s where - reverseS :: s -> s - -instance Reversable [c] where - reverseS = reverse - -instance Reversable T.Text where - reverseS = T.reverse diff --git a/src/Data/Geometry/Ipe/Path.hs b/src/Data/Geometry/Ipe/Path.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Path.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Data.Geometry.Ipe.Path( - Path(Path), pathSegments - , PathSegment(..) - - , _PolyLineSegment - , _PolygonPath - , _CubicBezierSegment - , _QuadraticBezierSegment - , _EllipseSegment - , _ArcSegment - , _SplineSegment - , _ClosedSplineSegment - - , Operation(..) - , _MoveTo - , _LineTo - , _CurveTo - , _QCurveTo - , _Ellipse - , _ArcTo - , _Spline - , _ClosedSpline - , _ClosePath - ) where - -import Control.Lens hiding (rmap) -import Data.Bitraversable -import Data.Geometry.BezierSpline -import Data.Geometry.Point -import Data.Geometry.Ellipse(Ellipse) -import Data.Geometry.PolyLine -import Data.Geometry.Polygon (SimplePolygon) -import Data.Geometry.Properties -import Data.Geometry.Transformation -import Data.Geometry.Matrix -import qualified Data.LSeq as LSeq -import Data.Traversable - --------------------------------------------------------------------------------- --- | Paths - --- | Paths consist of Path Segments. PathSegments come in the following forms: -data PathSegment r = PolyLineSegment (PolyLine 2 () r) - | PolygonPath (SimplePolygon () r) - | CubicBezierSegment (BezierSpline 3 2 r) - | QuadraticBezierSegment (BezierSpline 2 2 r) - | EllipseSegment (Ellipse r) - -- TODO - | ArcSegment - | SplineSegment -- (Spline 2 r) - | ClosedSplineSegment -- (ClosedSpline 2 r) - deriving (Show,Eq) -makePrisms ''PathSegment - -type instance NumType (PathSegment r) = r -type instance Dimension (PathSegment r) = 2 - -instance Functor PathSegment where - fmap = fmapDefault -instance Foldable PathSegment where - foldMap = foldMapDefault -instance Traversable PathSegment where - traverse f = \case - PolyLineSegment p -> PolyLineSegment <$> bitraverse pure f p - PolygonPath p -> PolygonPath <$> bitraverse pure f p - CubicBezierSegment b -> CubicBezierSegment <$> traverse f b - QuadraticBezierSegment b -> QuadraticBezierSegment <$> traverse f b - EllipseSegment e -> EllipseSegment <$> traverse f e - ArcSegment -> pure ArcSegment - SplineSegment -> pure SplineSegment - ClosedSplineSegment -> pure ClosedSplineSegment - -instance Fractional r => IsTransformable (PathSegment r) where - transformBy t = \case - PolyLineSegment p -> PolyLineSegment $ transformBy t p - PolygonPath p -> PolygonPath $ transformBy t p - CubicBezierSegment b -> CubicBezierSegment $ transformBy t b - QuadraticBezierSegment b -> QuadraticBezierSegment $ transformBy t b - EllipseSegment e -> EllipseSegment $ transformBy t e - -- TODO: - ArcSegment -> ArcSegment - SplineSegment -> SplineSegment - ClosedSplineSegment -> ClosedSplineSegment - - --- | A path is a non-empty sequence of PathSegments. -newtype Path r = Path { _pathSegments :: LSeq.LSeq 1 (PathSegment r) } - deriving (Show,Eq,Functor,Foldable,Traversable) -makeLenses ''Path - -type instance NumType (Path r) = r -type instance Dimension (Path r) = 2 - -instance Fractional r => IsTransformable (Path r) where - transformBy t (Path s) = Path $ fmap (transformBy t) s - - --------------------------------------------------------------------------------- - --- | type that represents a path in ipe. -data Operation r = MoveTo (Point 2 r) - | LineTo (Point 2 r) - | CurveTo (Point 2 r) (Point 2 r) (Point 2 r) - | QCurveTo (Point 2 r) (Point 2 r) - | Ellipse (Matrix 3 3 r) - | ArcTo (Matrix 3 3 r) (Point 2 r) - | Spline [Point 2 r] - | ClosedSpline [Point 2 r] - | ClosePath - deriving (Eq, Show,Functor,Foldable,Traversable) -makePrisms ''Operation diff --git a/src/Data/Geometry/Ipe/PathParser.hs b/src/Data/Geometry/Ipe/PathParser.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/PathParser.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# Language OverloadedStrings #-} -{-# Language DefaultSignatures #-} -module Data.Geometry.Ipe.PathParser where - -import Data.Bifunctor -import Data.Char (isSpace) -import Data.Ext (ext) -import Data.Geometry.Box -import Data.Geometry.Ipe.ParserPrimitives -import Data.Geometry.Ipe.Path (Operation(..)) -import Data.Geometry.Matrix -import Data.Geometry.Point -import Data.Geometry.Vector -import Data.Ratio -import Data.RealNumber.Rational -import Data.Text (Text) -import qualified Data.Text as T -import Text.Parsec.Error (messageString, errorMessages) - - ------------------------------------------------------------------------ --- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read) - -class Fractional r => Coordinate r where - -- reads a coordinate. The input is an integer representing the - -- part before the decimal point, and a length and an integer - -- representing the part after the decimal point - fromSeq :: Integer -> Maybe (Int, Integer) -> r - default fromSeq :: (Ord r, Fractional r) => Integer -> Maybe (Int, Integer) -> r - fromSeq = defaultFromSeq - -defaultFromSeq :: (Ord r, Fractional r) - => Integer -> Maybe (Int, Integer) -> r -defaultFromSeq x Nothing = fromInteger x -defaultFromSeq x (Just (l,y)) = let x' = fromInteger x - y' = fromInteger y - asDecimal a = a * (0.1 ^ l) - z = if x' < 0 then (-1) else 1 - in z * (abs x' + asDecimal y') - -instance Coordinate Double -instance Coordinate Float -instance Coordinate (Ratio Integer) -instance Coordinate (RealNumber p) - ------------------------------------------------------------------------ --- | Running the parsers - -readCoordinate :: Coordinate r => Text -> Either Text r -readCoordinate = runParser pCoordinate - -readPoint :: Coordinate r => Text -> Either Text (Point 2 r) -readPoint = runParser pPoint - -runParser :: Parser a -> Text -> Either Text a -runParser p = bimap errorText fst . runP p - --- Collect errors -data Either' l r = Left' l | Right' r deriving (Show,Eq) - -instance (Semigroup l, Semigroup r) => Semigroup (Either' l r) where - (Left' l) <> (Left' l') = Left' $ l <> l' - (Left' l) <> _ = Left' l - _ <> (Left' l') = Left' l' - (Right' r) <> (Right' r') = Right' $ r <> r' - -instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where - mempty = Right' mempty - mappend = (<>) -either' :: (l -> a) -> (r -> a) -> Either' l r -> a -either' lf _ (Left' l) = lf l -either' _ rf (Right' r) = rf r --- TODO: Use Validation instead of this home-brew one - -readPathOperations :: Coordinate r => Text -> Either Text [Operation r] -readPathOperations = unWrap . mconcat . map (wrap . runP pOperation) - . clean . splitKeepDelims "mlcqeasuh" - where - -- Unwrap the Either'. If it is a Left containing all our errors, - -- combine them into one error. Otherwise just ReWrap it in an proper Either - unWrap = either' (Left . combineErrors) Right - -- for the lefts: wrap the error in a list, for the rights: we only care - -- about the result, so wrap that in a list as well. Collecting the - -- results is done using the Semigroup instance of Either' - wrap = either (Left' . (:[])) (Right' . (:[]) . fst) - -- Split the input string in pieces, each piece represents one operation - trim = T.dropWhile isSpace - clean = filter (not . T.null) . map trim - -- TODO: Do the splitting on the Text rather than unpacking and packing - -- the thing - -errorText :: ParseError -> Text -errorText = T.pack . unlines . map messageString . errorMessages - -combineErrors :: [ParseError] -> Text -combineErrors = T.unlines . map errorText - - -splitKeepDelims :: [Char] -> Text -> [Text] -splitKeepDelims delims t = maybe mPref continue $ T.uncons rest - where - mPref = if T.null pref then [] else [pref] - (pref,rest) = T.break (`elem` delims) t - continue (c,t') = pref `T.snoc` c : splitKeepDelims delims t' - - -readMatrix :: Coordinate r => Text -> Either Text (Matrix 3 3 r) -readMatrix = runParser pMatrix - - -readRectangle :: Coordinate r => Text -> Either Text (Rectangle () r) -readRectangle = runParser pRectangle - ------------------------------------------------------------------------ --- | The parsers themselves - - -pOperation :: forall r. Coordinate r => Parser (Operation r) -pOperation = pChoice [ MoveTo <$> pPoint *>> 'm' - , LineTo <$> pPoint *>> 'l' - , CurveTo <$> pPoint <*> pPoint' <*> pPoint' *>> 'c' - , QCurveTo <$> pPoint <*> pPoint' *>> 'q' - , Ellipse <$> pMatrix *>> 'e' - , ArcTo <$> pMatrix <*> pPoint' *>> 'a' - , Spline <$> pPoint `pSepBy` pWhiteSpace *>> 's' - , ClosedSpline <$> pPoint `pSepBy` pWhiteSpace *>> 'u' - , pChar 'h' *> pure ClosePath - ] - where - pPoint' = pWhiteSpace *> pPoint - p *>> c = p <*>< pWhiteSpace ***> pChar c - - - -pPoint :: Coordinate r => Parser (Point 2 r) -pPoint = Point2 <$> pCoordinate <* pWhiteSpace <*> pCoordinate - - -pCoordinate :: Coordinate r => Parser r -pCoordinate = fromSeq <$> pInteger <*> pDecimal - where - pDecimal = pMaybe (pChar '.' *> pPaddedNatural) - - -pRectangle :: Coordinate r => Parser (Rectangle () r) -pRectangle = (\p q -> box (ext p) (ext q)) <$> pPoint - <* pWhiteSpace - <*> pPoint - -pMatrix :: Coordinate r => Parser (Matrix 3 3 r) -pMatrix = (\a b -> mkMatrix (a:b)) <$> pCoordinate - <*> pCount 5 (pWhiteSpace *> pCoordinate) - - --- | Generate a matrix from a list of 6 coordinates. -mkMatrix :: Coordinate r => [r] -> Matrix 3 3 r -mkMatrix [a,b,c,d,e,f] = Matrix $ Vector3 (Vector3 a c e) - (Vector3 b d f) - (Vector3 0 0 1) - -- We need the matrix in the following order: - -- 012 - -- 345 - -- - -- But ipe uses the following order: - -- 024 - -- 135 -mkMatrix _ = error "mkMatrix: need exactly 6 arguments" diff --git a/src/Data/Geometry/Ipe/Reader.hs b/src/Data/Geometry/Ipe/Reader.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Reader.hs +++ /dev/null @@ -1,438 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Data.Geometry.Ipe.Reader( -- * Reading ipe Files - readRawIpeFile - , readIpeFile - , readSinglePageFile - , readSinglePageFileThrow - , ConversionError - - -- * Reading XML directly - , fromIpeXML - , readXML - - -- * Read classes - , IpeReadText(..) - , IpeRead(..) - , IpeReadAttr(..) - - - -- * Some low level implementation functions - , ipeReadTextWith - , ipeReadObject - , ipeReadAttrs - , ipeReadRec - - , Coordinate(..) - ) where - -import Control.Applicative ((<|>)) -import Control.Lens hiding (Const, rmap) -import Data.Bifunctor -import qualified Data.ByteString as B -import Data.Colour.SRGB (RGB(..)) -import Data.Either (rights) -import Data.Ext -import Data.Geometry.BezierSpline -import Data.Geometry.Box -import Data.Geometry.Ellipse (ellipseMatrix) -import Data.Geometry.Ipe.Attributes -import Data.Geometry.Ipe.Color (IpeColor(..)) -import Data.Geometry.Ipe.Matrix -import Data.Geometry.Ipe.ParserPrimitives (pInteger, pWhiteSpace) -import Data.Geometry.Ipe.Path -import Data.Geometry.Ipe.PathParser -import Data.Geometry.Ipe.Types -import Data.Geometry.Ipe.Value -import qualified Data.Geometry.Matrix as Matrix -import Data.Geometry.Point -import Data.Geometry.PolyLine -import qualified Data.Geometry.Polygon as Polygon -import qualified Data.LSeq as LSeq -import qualified Data.List as L -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Proxy -import Data.Singletons -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Traversable as Tr -import Data.Vinyl hiding (Label) -import Data.Vinyl.Functor -import Data.Vinyl.TypeLevel -import Text.XML.Expat.Tree - - --------------------------------------------------------------------------------- - -type ConversionError = Text - - --- | Given a file path, tries to read an ipe file -readRawIpeFile :: (Coordinate r, Eq r) - => FilePath -> IO (Either ConversionError (IpeFile r)) -readRawIpeFile = fmap fromIpeXML . B.readFile - - --- | Given a file path, tries to read an ipe file. --- --- This function applies all matrices to objects. -readIpeFile :: (Coordinate r, Eq r) - => FilePath -> IO (Either ConversionError (IpeFile r)) -readIpeFile = fmap (second applyMatrices) . readRawIpeFile - - --- | Since most Ipe file contain only one page, we provide a shortcut for that --- as well. --- --- This function applies all matrices, and it makes sure there is at --- least one layer and view in the page. --- -readSinglePageFile :: (Coordinate r, Eq r) - => FilePath -> IO (Either ConversionError (IpePage r)) -readSinglePageFile = fmap (fmap f) . readIpeFile - where - f :: IpeFile r -> IpePage r - f i = withDefaults . NonEmpty.head $ i^.pages - --- | Tries to read a single page file, throws an error when this --- fails. See 'readSinglePageFile' for further details. -readSinglePageFileThrow :: (Coordinate r, Eq r) => FilePath -> IO (IpePage r) -readSinglePageFileThrow fp = readSinglePageFile fp >>= \case - Left err -> fail (show err) - Right p -> pure p - --- | Given a Bytestring, try to parse the bytestring into anything that is --- IpeReadable, i.e. any of the Ipe elements. -fromIpeXML :: IpeRead (t r) => B.ByteString -> Either ConversionError (t r) -fromIpeXML b = readXML b >>= ipeRead - --- | Reads the data from a Bytestring into a proper Node -readXML :: B.ByteString -> Either ConversionError (Node Text Text) -readXML = first (T.pack . show) . parse' defaultParseOptions - --------------------------------------------------------------------------------- - --- | Reading an ipe elemtn from a Text value -class IpeReadText t where - ipeReadText :: Text -> Either ConversionError t - --- | Reading an ipe lement from Xml -class IpeRead t where - ipeRead :: Node Text Text -> Either ConversionError t - --------------------------------------------------------------------------------- --- ReadText instances - -instance IpeReadText Text where - ipeReadText = Right - -instance IpeReadText Int where - ipeReadText = fmap fromInteger . runParser pInteger - -instance Coordinate r => IpeReadText (Point 2 r) where - ipeReadText = readPoint - -instance Coordinate r => IpeReadText (Matrix.Matrix 3 3 r) where - ipeReadText = readMatrix - -instance IpeReadText LayerName where - ipeReadText = Right . LayerName - -instance IpeReadText PinType where - ipeReadText "yes" = Right Yes - ipeReadText "h" = Right Horizontal - ipeReadText "v" = Right Vertical - ipeReadText "" = Right No - ipeReadText _ = Left "invalid PinType" - -instance IpeReadText TransformationTypes where - ipeReadText "affine" = Right Affine - ipeReadText "rigid" = Right Rigid - ipeReadText "translations" = Right Translations - ipeReadText _ = Left "invalid TransformationType" - -instance IpeReadText FillType where - ipeReadText "wind" = Right Wind - ipeReadText "eofill" = Right EOFill - ipeReadText _ = Left "invalid FillType" - -instance Coordinate r => IpeReadText (IpeArrow r) where - ipeReadText t = case T.split (== '/') t of - [n,s] -> IpeArrow <$> pure n <*> ipeReadText s - _ -> Left "ipeArrow: name contains not exactly 1 / " - -instance Coordinate r => IpeReadText (IpeDash r) where - ipeReadText t = Right . DashNamed $ t - -- TODO: Implement proper parsing here - - -ipeReadTextWith :: (Text -> Either t v) -> Text -> Either ConversionError (IpeValue v) -ipeReadTextWith f t = case f t of - Right v -> Right (Valued v) - Left _ -> Right (Named t) - - -instance Coordinate r => IpeReadText (Rectangle () r) where - ipeReadText = readRectangle - -instance Coordinate r => IpeReadText (RGB r) where - ipeReadText = runParser (pRGB <|> pGrey) - where - pGrey = (\c -> RGB c c c) <$> pCoordinate - pRGB = RGB <$> pCoordinate <* pWhiteSpace - <*> pCoordinate <* pWhiteSpace - <*> pCoordinate - -instance Coordinate r => IpeReadText (IpeColor r) where - ipeReadText = fmap IpeColor . ipeReadTextWith ipeReadText - -instance Coordinate r => IpeReadText (IpePen r) where - ipeReadText = fmap IpePen . ipeReadTextWith readCoordinate - -instance Coordinate r => IpeReadText (IpeSize r) where - ipeReadText = fmap IpeSize . ipeReadTextWith readCoordinate - - -instance Coordinate r => IpeReadText [Operation r] where - ipeReadText = readPathOperations - -instance (Coordinate r, Eq r) => IpeReadText (NonEmpty.NonEmpty (PathSegment r)) where - ipeReadText t = ipeReadText t >>= fromOpsN - where - fromOpsN xs = case fromOps xs of - Left l -> Left l - Right [] -> Left "No path segments produced" - Right (p:ps) -> Right $ p NonEmpty.:| ps - - fromOps [] = Right [] - fromOps [Ellipse m] = Right [EllipseSegment . view (from ellipseMatrix) $ m] - fromOps (MoveTo p:xs) = fromOps' p xs - fromOps _ = Left "Path should start with a move to" - - fromOps' _ [] = Left "Found only a MoveTo operation" - fromOps' s (LineTo q:ops) = let (ls,xs) = span' _LineTo ops - pts = map ext $ s:q:mapMaybe (^?_LineTo) ls - poly = Polygon.unsafeFromPoints . dropRepeats $ pts - pl = fromPointsUnsafe pts - in case xs of - (ClosePath : xs') -> PolygonPath poly <<| xs' - _ -> PolyLineSegment pl <<| xs - - fromOps' s [CurveTo a b c] = Right [CubicBezierSegment $ Bezier3 s a b c] - fromOps' _ _ = Left "fromOpts': rest not implemented yet." - - span' pr = L.span (not . isn't pr) - - x <<| xs = (x:) <$> fromOps xs - - -dropRepeats :: Eq a => [a] -> [a] -dropRepeats = map head . L.group - -instance (Coordinate r, Eq r) => IpeReadText (Path r) where - ipeReadText = fmap (Path . LSeq.fromNonEmpty) . ipeReadText - --------------------------------------------------------------------------------- --- Reading attributes - --- | Basically IpeReadText for attributes. This class is not really meant to be --- implemented directly. Just define an IpeReadText instance for the type --- (Apply f at), then the generic instance below takes care of looking up the --- name of the attribute, and calling the right ipeReadText value. This class --- is just so that reifyConstraint in `ipeReadRec` can select the right --- typeclass when building the rec. -class IpeReadAttr t where - ipeReadAttr :: Text -> Node Text Text -> Either ConversionError t - -instance IpeReadText (Apply f at) => IpeReadAttr (Attr f at) where - ipeReadAttr n (Element _ ats _) = GAttr <$> Tr.mapM ipeReadText (lookup n ats) - ipeReadAttr _ _ = Left "IpeReadAttr: Element expected, Text found" - --- | Combination of zipRecWith and traverse -zipTraverseWith :: forall f g h i (rs :: [AttributeUniverse]). Applicative h - => (forall (x :: AttributeUniverse). f x -> g x -> h (i x)) - -> Rec f rs -> Rec g rs -> h (Rec i rs) -zipTraverseWith _ RNil RNil = pure RNil -zipTraverseWith f (x :& xs) (y :& ys) = (:&) <$> f x y <*> zipTraverseWith f xs ys - --- | Reading the Attributes into a Rec (Attr f), all based on the types of f --- (the type family mapping labels to types), and a list of labels (ats). -ipeReadRec :: forall f ats. - ( RecApplicative ats - , ReifyConstraint IpeReadAttr (Attr f) ats - , RecAll (Attr f) ats IpeReadAttr - , AllConstrained IpeAttrName ats - ) - => Proxy f -> Proxy ats - -> Node Text Text - -> Either ConversionError (Rec (Attr f) ats) -ipeReadRec _ _ x = zipTraverseWith f (writeAttrNames r) r' - where - r = rpure (GAttr Nothing) - r' = reifyConstraint @IpeReadAttr r - - - f :: forall at. - Const Text at - -> (Dict IpeReadAttr :. Attr f) at - -> Either ConversionError (Attr f at) - f (Const n) (Compose (Dict _)) = ipeReadAttr n x - - --- | Reader for records. Given a proxy of some ipe type i, and a proxy of an --- coordinate type r, read the IpeAttributes for i from the xml node. -ipeReadAttrs :: forall proxy proxy' i r f ats. - ( f ~ AttrMapSym1 r, ats ~ AttributesOf i - , ReifyConstraint IpeReadAttr (Attr f) ats - , RecApplicative ats - , RecAll (Attr f) ats IpeReadAttr - , AllConstrained IpeAttrName ats - ) - => proxy i -> proxy' r - -> Node Text Text - -> Either ConversionError (IpeAttributes i r) -ipeReadAttrs _ _ = fmap Attrs . ipeReadRec (Proxy :: Proxy f) (Proxy :: Proxy ats) - - --- testSym :: B.ByteString --- testSym = "" - - - - --- readAttrsFromXML :: B.ByteString -> Either - --- readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double) --- readSymAttrs = readXML testSym --- >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double) - - - - - --- | If we can ipeRead an ipe element, and we can ipeReadAttrs its attributes --- we can properly read an ipe object using ipeReadObject -ipeReadObject :: ( IpeRead (i r) - , f ~ AttrMapSym1 r, ats ~ AttributesOf i - , RecApplicative ats - , ReifyConstraint IpeReadAttr (Attr f) ats - , RecAll (Attr f) ats IpeReadAttr - , AllConstrained IpeAttrName ats - ) - => Proxy i -> proxy r -> Node Text Text - -> Either ConversionError (i r :+ IpeAttributes i r) -ipeReadObject prI prR xml = (:+) <$> ipeRead xml <*> ipeReadAttrs prI prR xml - - --------------------------------------------------------------------------------- --- | Ipe read instances - -instance Coordinate r => IpeRead (IpeSymbol r) where - ipeRead (Element "use" ats _) = case lookup "pos" ats of - Nothing -> Left "symbol without position" - Just ps -> flip Symbol name <$> ipeReadText ps - where - name = fromMaybe "mark/disk(sx)" $ lookup "name" ats - ipeRead _ = Left "symbol element expected, text found" - --- | Given a list of Nodes, try to parse all of them as a big text. If we --- encounter anything else then text, the parsing fails. -allText :: [Node Text Text] -> Either ConversionError Text -allText = fmap T.unlines . mapM unT - where - unT (Text t) = Right t - unT _ = Left "allText: Expected Text, found an Element" - -instance (Coordinate r, Eq r) => IpeRead (Path r) where - ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText - ipeRead _ = Left "path: expected element, found text" - - -lookup' :: Text -> [(Text,a)] -> Either ConversionError a -lookup' k = maybe (Left $ "lookup' " <> k <> " not found") Right . lookup k - -instance Coordinate r => IpeRead (TextLabel r) where - ipeRead (Element "text" ats chs) - | lookup "type" ats == Just "label" = Label - <$> allText chs - <*> (lookup' "pos" ats >>= ipeReadText) - | otherwise = Left "Not a Text label" - ipeRead _ = Left "textlabel: Expected element, found text" - - - -instance Coordinate r => IpeRead (MiniPage r) where - ipeRead (Element "text" ats chs) - | lookup "type" ats == Just "minipage" = MiniPage - <$> allText chs - <*> (lookup' "pos" ats >>= ipeReadText) - <*> (lookup' "width" ats >>= readCoordinate) - | otherwise = Left "Not a MiniPage" - ipeRead _ = Left "MiniPage: Expected element, found text" - - -instance Coordinate r => IpeRead (Image r) where - ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText) - ipeRead _ = Left "Image: Element expected, text found" - -instance (Coordinate r, Eq r) => IpeRead (IpeObject r) where - ipeRead x = firstRight [ IpeUse <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x - , IpePath <$> ipeReadObject (Proxy :: Proxy Path) r x - , IpeGroup <$> ipeReadObject (Proxy :: Proxy Group) r x - , IpeTextLabel <$> ipeReadObject (Proxy :: Proxy TextLabel) r x - , IpeMiniPage <$> ipeReadObject (Proxy :: Proxy MiniPage) r x - , IpeImage <$> ipeReadObject (Proxy :: Proxy Image) r x - ] - where - r = Proxy :: Proxy r - -firstRight :: [Either ConversionError a] -> Either ConversionError a -firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right) - - -instance (Coordinate r, Eq r) => IpeRead (Group r) where - ipeRead (Element "group" _ chs) = Right . Group . rights . map ipeRead $ chs - ipeRead _ = Left "ipeRead Group: expected Element, found Text" - - -instance IpeRead LayerName where - ipeRead (Element "layer" ats _) = LayerName <$> lookup' "name" ats - ipeRead _ = Left "layer: Expected element, found text" - -instance IpeRead View where - ipeRead (Element "view" ats _) = (\lrs a -> View (map LayerName $ T.words lrs) a) - <$> lookup' "layers" ats - <*> (lookup' "active" ats >>= ipeReadText) - ipeRead _ = Left "View Expected element, found text" - - --- TODO: this instance throws away all of our error collecting (and is pretty --- slow/stupid since it tries parsing all children with all parsers) -instance (Coordinate r, Eq r) => IpeRead (IpePage r) where - ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs) - ipeRead _ = Left "page: Element expected, text found" - -- withDef :: b -> Either a b -> Either c b - -- withDef d = either (const $ Right d) Right - - -- readLayers = withDef ["alpha"] . readAll - -- readViews = withDef [] . readAll - -- readObjects = withDef [] . readAll - --- | try reading everything as an a. Throw away whatever fails. -readAll :: IpeRead a => [Node Text Text] -> [a] -readAll = rights . map ipeRead - - -instance (Coordinate r, Eq r) => IpeRead (IpeFile r) where - ipeRead (Element "ipe" _ chs) = case readAll chs of - [] -> Left "Ipe: no pages found" - pgs -> Right $ IpeFile Nothing [] (NonEmpty.fromList pgs) - ipeRead _ = Left "Ipe: Element expected, text found" - - - - - --------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/Ipe/Types.hs b/src/Data/Geometry/Ipe/Types.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Types.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe.Types --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- --- Data type modeling the various elements in Ipe files. --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe.Types( - LayerName(LayerName), layerName - , Image(Image), imageData, rect - , TextLabel(..) - , MiniPage(..), width - - , IpeSymbol(Symbol), symbolPoint, symbolName - - , Path(Path), pathSegments - , PathSegment(..) - - , Group(Group), groupItems - - - , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath - , IpeObject' - , ipeObject' - , ToObject(..) - - , IpeAttributes - , Attributes', AttributesOf, AttrMap, AttrMapSym1 - , attributes, traverseIpeAttrs - , commonAttributes - - , flattenGroups - - - , View(View), layerNames, activeLayer - - , IpeStyle(IpeStyle), styleName, styleData - , basicIpeStyle - - - , IpePreamble(IpePreamble), encoding, preambleData - - , IpeBitmap - - - , IpePage(IpePage), layers, views, content - , emptyPage, fromContent - , onLayer, contentInView - , withDefaults - - , IpeFile(IpeFile), preamble, styles, pages - , ipeFile, singlePageFile, singlePageFromContent - ) where - - -import Control.Lens hiding (views) -import Data.Geometry.Ipe.Attributes hiding (Matrix) -import Data.Geometry.Ipe.Content -import Data.Geometry.Ipe.Layer -import Data.Geometry.Ipe.Literal -import qualified Data.List.NonEmpty as NE -import Data.Maybe (mapMaybe) -import Data.Semigroup (Endo) -import qualified Data.Set as Set -import Data.Text (Text) -import Text.XML.Expat.Tree (Node) - --------------------------------------------------------------------------------- - - --- | The definition of a view --- make active layer into an index ? -data View = View { _layerNames :: [LayerName] - , _activeLayer :: LayerName - } - deriving (Eq, Ord, Show) -makeLenses ''View - --- instance Default - - --- | for now we pretty much ignore these -data IpeStyle = IpeStyle { _styleName :: Maybe Text - , _styleData :: Node Text Text - } - deriving (Eq,Show) -makeLenses ''IpeStyle - - -basicIpeStyle :: IpeStyle -basicIpeStyle = IpeStyle (Just "basic") (xmlLiteral [litFile|resources/basic.isy|]) - - --- | The maybe string is the encoding -data IpePreamble = IpePreamble { _encoding :: Maybe Text - , _preambleData :: Text - } - deriving (Eq,Read,Show,Ord) -makeLenses ''IpePreamble - -type IpeBitmap = Text - - - --------------------------------------------------------------------------------- --- Ipe Pages - --- | An IpePage is essentially a Group, together with a list of layers and a --- list of views. -data IpePage r = IpePage { _layers :: [LayerName] - , _views :: [View] - , _content :: [IpeObject r] - } - deriving (Eq,Show) -makeLenses ''IpePage - --- | Creates an empty page with one layer and view. -emptyPage :: IpePage r -emptyPage = fromContent [] - --- | Creates a simple page with a single view. -fromContent :: [IpeObject r] -> IpePage r -fromContent obs = IpePage layers' [View layers' a] obs - where - layers' = Set.toList . Set.fromList $ a : mapMaybe (^.commonAttributes.ixAttr SLayer) obs - a = "alpha" - --- | Makes sure that the page has at least one layer and at least one --- view, essentially matching the behaviour of ipe. In particular, --- --- - if the page does not have any layers, it creates a layer named "alpha", and --- - if the page does not have any views, it creates a view in which all layers are visible. --- -withDefaults :: IpePage r -> IpePage r -withDefaults = addView . addLayer - where - whenNull ys = \case - [] -> ys - xs -> xs - addLayer p = p&layers %~ whenNull ["alpha"] - addView p = p&views %~ whenNull [View (p^.layers) (head $ p^.layers)] - -- note that the head is save, since we just made sure - -- with 'addLayer' that there is at least one layer - --- | This allows you to filter the objects on some layer. --- --- >>> let page = IpePage [] [] [] --- >>> page^..content.onLayer "myLayer" --- [] -onLayer :: LayerName -> Getting (Endo [IpeObject r]) [IpeObject r] (IpeObject r) -onLayer n = folded.filtered (\o -> o^?commonAttributes._Attr SLayer == Just n) - --- | Gets all objects that are visible in the given view. --- --- Note that views are indexed starting from 0. If the page does not --- have any explicit view definitions, this function returns an empty --- list. --- --- >>> let page = IpePage [] [] [] --- >>> page^.contentInView 0 --- [] -contentInView :: Word -> Getter (IpePage r) [IpeObject r] -contentInView (fromIntegral -> i) = to inView' - where - inView' p = let lrs = Set.fromList . concatMap (^.layerNames) $ p^..views.ix i - in p^..content.folded.filtered (inVisibleLayer lrs) - - inVisibleLayer lrs o = maybe False (`Set.member` lrs) $ o^?commonAttributes._Attr SLayer - --------------------------------------------------------------------------------- - --- | A complete ipe file -data IpeFile r = IpeFile { _preamble :: Maybe IpePreamble - , _styles :: [IpeStyle] - , _pages :: NE.NonEmpty (IpePage r) - } - deriving (Eq,Show) -makeLenses ''IpeFile - - --- | Convenience constructor for creating an ipe file without preamble --- and with the default stylesheet. -ipeFile :: NE.NonEmpty (IpePage r) -> IpeFile r -ipeFile = IpeFile Nothing [basicIpeStyle] - --- | Convenience function to construct an ipe file consisting of a single page. -singlePageFile :: IpePage r -> IpeFile r -singlePageFile = ipeFile . (NE.:| []) - --- | Create a single page ipe file from a list of IpeObjects -singlePageFromContent :: [IpeObject r] -> IpeFile r -singlePageFromContent = singlePageFile . fromContent diff --git a/src/Data/Geometry/Ipe/Value.hs b/src/Data/Geometry/Ipe/Value.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Value.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe.Value --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- --- Data type for representing values in ipe. --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe.Value where - -import GHC.Exts -import Data.Text - --------------------------------------------------------------------------------- - --- | Many types either consist of a symbolc value, or a value of type v -data IpeValue v = Named Text | Valued v - deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable) - -instance IsString (IpeValue v) where - fromString = Named . fromString diff --git a/src/Data/Geometry/Ipe/Writer.hs b/src/Data/Geometry/Ipe/Writer.hs deleted file mode 100644 --- a/src/Data/Geometry/Ipe/Writer.hs +++ /dev/null @@ -1,436 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Geometry.Ipe.Writer --- Copyright : (C) Frank Staals --- License : see the LICENSE file --- Maintainer : Frank Staals --- Description : Converting data types into IpeTypes --- --------------------------------------------------------------------------------- -module Data.Geometry.Ipe.Writer( writeIpeFile, writeIpeFile', writeIpePage - , toIpeXML - - , printAsIpeSelection, toIpeSelectionXML - - - , IpeWrite(..) - , IpeWriteText(..) - - , ipeWriteAttrs, writeAttrValues - ) where - -import Control.Lens (view, (&), (.~), (^.), (^..)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Colour.SRGB (RGB (..)) -import Data.Ext -import Data.Fixed -import qualified Data.Foldable as F -import Data.Geometry.BezierSpline -import Data.Geometry.Box -import Data.Geometry.Ellipse (ellipseMatrix) -import Data.Geometry.Ipe.Attributes -import qualified Data.Geometry.Ipe.Attributes as IA -import Data.Geometry.Ipe.Color (IpeColor (..)) -import Data.Geometry.Ipe.Path -import Data.Geometry.Ipe.Types -import Data.Geometry.Ipe.Value -import Data.Geometry.LineSegment -import qualified Data.Geometry.Matrix as Matrix -import Data.Geometry.Point -import Data.Geometry.PolyLine -import Data.Geometry.Polygon (Polygon, holeList, outerBoundary, - outerBoundaryVector) -import Data.Geometry.Vector -import qualified Data.LSeq as LSeq -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) -import Data.Ratio -import Data.RealNumber.Rational -import Data.Singletons -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Vinyl hiding (Label) -import Data.Vinyl.Functor -import Data.Vinyl.TypeLevel -import System.IO (hPutStrLn, stderr) -import Text.XML.Expat.Format (format') -import Text.XML.Expat.Tree - --------------------------------------------------------------------------------- - --- | Given a prism to convert something of type g into an ipe file, a file path, --- and a g. Convert the geometry and write it to file. - --- writeIpe :: ( RecAll (Page r) gs IpeWrite --- , IpeWriteText r --- ) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO () --- writeIpe p fp g = writeIpeFile (p # g) fp - --- | Write an IpeFiele to file. -writeIpeFile :: IpeWriteText r => FilePath -> IpeFile r -> IO () -writeIpeFile = flip writeIpeFile' - --- | Creates a single page ipe file with the given page -writeIpePage :: IpeWriteText r => FilePath -> IpePage r -> IO () -writeIpePage fp = writeIpeFile fp . singlePageFile - - --- | Convert the input to ipeXml, and prints it to standard out in such a way --- that the copied text can be pasted into ipe as a geometry object. -printAsIpeSelection :: IpeWrite t => t -> IO () -printAsIpeSelection = C.putStrLn . fromMaybe "" . toIpeSelectionXML - --- | Convert input into an ipe selection. -toIpeSelectionXML :: IpeWrite t => t -> Maybe B.ByteString -toIpeSelectionXML = fmap (format' . ipeSelection) . ipeWrite - where - ipeSelection x = Element "ipeselection" [] [x] - - --- | Convert to Ipe xml -toIpeXML :: IpeWrite t => t -> Maybe B.ByteString -toIpeXML = fmap format' . ipeWrite - - --- | Convert to ipe XML and write the output to a file. -writeIpeFile' :: IpeWrite t => t -> FilePath -> IO () -writeIpeFile' i fp = maybe err (B.writeFile fp) . toIpeXML $ i - where - err = hPutStrLn stderr $ - "writeIpeFile: error converting to xml. File '" <> fp <> "'not written" - --------------------------------------------------------------------------------- - --- | For types that can produce a text value -class IpeWriteText t where - ipeWriteText :: t -> Maybe Text - --- | Types that correspond to an XML Element. All instances should produce an --- Element. If the type should produce a Node with the Text constructor, use --- the `IpeWriteText` typeclass instead. -class IpeWrite t where - ipeWrite :: t -> Maybe (Node Text Text) - -instance IpeWrite t => IpeWrite [t] where - ipeWrite gs = case mapMaybe ipeWrite gs of - [] -> Nothing - ns -> (Just $ Element "group" [] ns) - -instance IpeWrite t => IpeWrite (NonEmpty t) where - ipeWrite = ipeWrite . F.toList - -instance (IpeWrite l, IpeWrite r) => IpeWrite (Either l r) where - ipeWrite = either ipeWrite ipeWrite - -instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where - ipeWriteText att = _getAttr att >>= ipeWriteText - -instance (IpeWriteText l, IpeWriteText r) => IpeWriteText (Either l r) where - ipeWriteText = either ipeWriteText ipeWriteText - - --- | Functon to write all attributes in a Rec -ipeWriteAttrs :: ( RecordToList rs, RMap rs - , ReifyConstraint IpeWriteText (Attr f) rs - , AllConstrained IpeAttrName rs - , RecAll (Attr f) rs IpeWriteText - ) => IA.Attributes f rs -> [(Text,Text)] -ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames r) - (writeAttrValues r) - where - f (Const n) (Const mv) = Const $ (n,) <$> mv - --- | Writing the attribute values -writeAttrValues :: ( RMap rs, ReifyConstraint IpeWriteText f rs - , RecAll f rs IpeWriteText) - => Rec f rs -> Rec (Const (Maybe Text)) rs -writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x) - . reifyConstraint @IpeWriteText - - -instance IpeWriteText Text where - ipeWriteText = Just - -instance IpeWriteText String where - ipeWriteText = ipeWriteText . Text.pack - - --- | Add attributes to a node -addAtts :: Node Text Text -> [(Text,Text)] -> Node Text Text -n `addAtts` ats = n { eAttributes = ats ++ eAttributes n } - --- | Same as `addAtts` but then for a Maybe node -mAddAtts :: Maybe (Node Text Text) -> [(Text, Text)] -> Maybe (Node Text Text) -mn `mAddAtts` ats = fmap (`addAtts` ats) mn - - --------------------------------------------------------------------------------- - -instance IpeWriteText Double where - ipeWriteText = writeByShow - -instance IpeWriteText Float where - ipeWriteText = writeByShow - -instance IpeWriteText Int where - ipeWriteText = writeByShow - -instance IpeWriteText Integer where - ipeWriteText = writeByShow - -instance IpeWriteText (RealNumber p) where - ipeWriteText = ipeWriteText . realToFrac @(RealNumber p) @Rational - -instance HasResolution p => IpeWriteText (Fixed p) where - ipeWriteText = writeByShow - --- | This instance converts the ratio to a Pico, and then displays that. -instance Integral a => IpeWriteText (Ratio a) where - ipeWriteText = ipeWriteText . f . fromRational . toRational - where - f :: Pico -> Pico - f = id - -writeByShow :: Show t => t -> Maybe Text -writeByShow = ipeWriteText . Text.pack . show - -unwords' :: [Maybe Text] -> Maybe Text -unwords' = fmap Text.unwords . sequence - -unlines' :: [Maybe Text] -> Maybe Text -unlines' = fmap Text.unlines . sequence - - -instance IpeWriteText r => IpeWriteText (Point 2 r) where - ipeWriteText (Point2 x y) = unwords' [ipeWriteText x, ipeWriteText y] - - --------------------------------------------------------------------------------- - -instance IpeWriteText v => IpeWriteText (IpeValue v) where - ipeWriteText (Named t) = ipeWriteText t - ipeWriteText (Valued v) = ipeWriteText v - -instance IpeWriteText TransformationTypes where - ipeWriteText Affine = Just "affine" - ipeWriteText Rigid = Just "rigid" - ipeWriteText Translations = Just "translations" - -instance IpeWriteText PinType where - ipeWriteText No = Nothing - ipeWriteText Yes = Just "yes" - ipeWriteText Horizontal = Just "h" - ipeWriteText Vertical = Just "v" - -instance IpeWriteText r => IpeWriteText (RGB r) where - ipeWriteText (RGB r g b) = unwords' . map ipeWriteText $ [r,g,b] - -deriving instance IpeWriteText r => IpeWriteText (IpeSize r) -deriving instance IpeWriteText r => IpeWriteText (IpePen r) -deriving instance IpeWriteText r => IpeWriteText (IpeColor r) - -instance IpeWriteText r => IpeWriteText (IpeDash r) where - ipeWriteText (DashNamed t) = Just t - ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "[" - , Text.intercalate " " ts - , "] ", t ]) - <$> mapM ipeWriteText xs - <*> ipeWriteText x - -instance IpeWriteText FillType where - ipeWriteText Wind = Just "wind" - ipeWriteText EOFill = Just "eofill" - -instance IpeWriteText r => IpeWriteText (IpeArrow r) where - ipeWriteText (IpeArrow n s) = (\n' s' -> n' <> "/" <> s') <$> ipeWriteText n - <*> ipeWriteText s - -instance IpeWriteText r => IpeWriteText (Path r) where - ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . view pathSegments - where - concat' = F.foldr1 (\t t' -> t <> "\n" <> t') - - --------------------------------------------------------------------------------- -instance IpeWriteText r => IpeWrite (IpeSymbol r) where - ipeWrite (Symbol p n) = f <$> ipeWriteText p - where - f ps = Element "use" [ ("pos", ps) - , ("name", n) - ] [] - --------------------------------------------------------------------------------- - -instance IpeWriteText r => IpeWriteText (Matrix.Matrix 3 3 r) where - ipeWriteText (Matrix.Matrix m) = unwords' [a,b,c,d,e,f] - where - (Vector3 r1 r2 _) = m - - (Vector3 a c e) = ipeWriteText <$> r1 - (Vector3 b d f) = ipeWriteText <$> r2 - -- TODO: The third row should be (0,0,1) I guess. - - -instance IpeWriteText r => IpeWriteText (Operation r) where - ipeWriteText (MoveTo p) = unwords' [ ipeWriteText p, Just "m"] - ipeWriteText (LineTo p) = unwords' [ ipeWriteText p, Just "l"] - ipeWriteText (CurveTo p q r) = unwords' [ ipeWriteText p - , ipeWriteText q - , ipeWriteText r, Just "c"] - ipeWriteText (QCurveTo p q) = unwords' [ ipeWriteText p - , ipeWriteText q, Just "q"] - ipeWriteText (Ellipse m) = unwords' [ ipeWriteText m, Just "e"] - ipeWriteText (ArcTo m p) = unwords' [ ipeWriteText m - , ipeWriteText p, Just "a"] - ipeWriteText (Spline pts) = unlines' $ map ipeWriteText pts <> [Just "s"] - ipeWriteText (ClosedSpline pts) = unlines' $ map ipeWriteText pts <> [Just "u"] - ipeWriteText ClosePath = Just "h" - - -instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where - ipeWriteText pl = case pl^..points.traverse.core of - (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest - _ -> error "ipeWriteText. absurd. no vertices polyline" - -- the polyline type guarantees that there is at least one point - -instance IpeWriteText r => IpeWriteText (Polygon t () r) where - ipeWriteText pg = fmap mconcat . traverse f $ pg^.outerBoundary : holeList pg - where - f pg' = case pg'^..outerBoundaryVector.traverse.core of - (p : rest) -> unlines' . map ipeWriteText - $ MoveTo p : map LineTo rest ++ [ClosePath] - _ -> Nothing - -- TODO: We are not really guaranteed that there is at least one point, it would - -- be nice if the type could guarantee that. - -instance IpeWriteText r => IpeWriteText (BezierSpline 3 2 r) where - ipeWriteText (Bezier3 p q r s) = unlines' . map ipeWriteText $ [MoveTo p, CurveTo q r s] - -instance IpeWriteText r => IpeWriteText (PathSegment r) where - ipeWriteText (PolyLineSegment p) = ipeWriteText p - ipeWriteText (PolygonPath p) = ipeWriteText p - ipeWriteText (EllipseSegment e) = ipeWriteText $ Ellipse (e^.ellipseMatrix) - ipeWriteText _ = error "ipeWriteText: PathSegment, not implemented yet." - -instance IpeWriteText r => IpeWrite (Path r) where - ipeWrite p = (\t -> Element "path" [] [Text t]) <$> ipeWriteText p - --------------------------------------------------------------------------------- - - -instance (IpeWriteText r) => IpeWrite (Group r) where - ipeWrite (Group gs) = ipeWrite gs - - -instance ( AllConstrained IpeAttrName rs - , RecordToList rs, RMap rs - , ReifyConstraint IpeWriteText (Attr f) rs - , RecAll (Attr f) rs IpeWriteText - , IpeWrite g - ) => IpeWrite (g :+ IA.Attributes f rs) where - ipeWrite (g :+ ats) = ipeWrite g `mAddAtts` ipeWriteAttrs ats - - -instance IpeWriteText r => IpeWrite (MiniPage r) where - ipeWrite (MiniPage t p w) = (\pt wt -> - Element "text" [ ("pos", pt) - , ("type", "minipage") - , ("width", wt) - ] [Text t] - ) <$> ipeWriteText p - <*> ipeWriteText w - -instance IpeWriteText r => IpeWrite (Image r) where - ipeWrite (Image d (Box a b)) = (\dt p q -> - Element "image" [("rect", p <> " " <> q)] [Text dt] - ) - <$> ipeWriteText d - <*> ipeWriteText (a^.core.cwMin) - <*> ipeWriteText (b^.core.cwMax) - --- TODO: Replace this one with s.t. that writes the actual image payload -instance IpeWriteText () where - ipeWriteText () = Nothing - -instance IpeWriteText r => IpeWrite (TextLabel r) where - ipeWrite (Label t p) = (\pt -> - Element "text" [("pos", pt) - ,("type", "label") - ] [Text t] - ) <$> ipeWriteText p - - -instance (IpeWriteText r) => IpeWrite (IpeObject r) where - ipeWrite (IpeGroup g) = ipeWrite g - ipeWrite (IpeImage i) = ipeWrite i - ipeWrite (IpeTextLabel l) = ipeWrite l - ipeWrite (IpeMiniPage m) = ipeWrite m - ipeWrite (IpeUse s) = ipeWrite s - ipeWrite (IpePath p) = ipeWrite p - --------------------------------------------------------------------------------- - -deriving instance IpeWriteText LayerName - -instance IpeWrite LayerName where - ipeWrite (LayerName n) = Just $ Element "layer" [("name",n)] [] - -instance IpeWrite View where - ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls) - , ("active", act^.layerName) - ] [] - where - ls = Text.unwords . map (^.layerName) $ lrs - -instance (IpeWriteText r) => IpeWrite (IpePage r) where - ipeWrite (IpePage lrs vs objs) = Just . - Element "page" [] . catMaybes . concat $ - [ map ipeWrite lrs - , map ipeWrite vs - , map ipeWrite objs - ] - - -instance IpeWrite IpeStyle where - ipeWrite (IpeStyle _ xml) = Just xml - - -instance IpeWrite IpePreamble where - ipeWrite (IpePreamble _ latex) = Just $ Element "preamble" [] [Text latex] - -- TODO: I probably want to do something with the encoding .... - -instance (IpeWriteText r) => IpeWrite (IpeFile r) where - ipeWrite (IpeFile mp ss pgs) = Just $ Element "ipe" ipeAtts chs - where - ipeAtts = [("version","70005"),("creator", "HGeometry")] - chs = mconcat [ catMaybes [mp >>= ipeWrite] - , mapMaybe ipeWrite ss - , mapMaybe ipeWrite . F.toList $ pgs - ] - - - - --------------------------------------------------------------------------------- - -instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where - ipeWrite p = ipeWrite path - where - path = fromPolyLine $ p & points.traverse.extra .~ () - -- TODO: Do something with the p's - -fromPolyLine :: PolyLine 2 () r -> Path r -fromPolyLine = Path . LSeq.fromNonEmpty . (:| []) . PolyLineSegment - - -instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where - ipeWrite (LineSegment' p q) = - ipeWrite . fromPolyLine . fromPointsUnsafe . map (extra .~ ()) $ [p,q] - - -instance IpeWrite () where - ipeWrite = const Nothing diff --git a/src/Data/Geometry/PlanarSubdivision/Draw.hs b/src/Data/Geometry/PlanarSubdivision/Draw.hs --- a/src/Data/Geometry/PlanarSubdivision/Draw.hs +++ b/src/Data/Geometry/PlanarSubdivision/Draw.hs @@ -1,30 +1,33 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.PlanarSubdivision.Draw +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Helper functions to draw a PlanarSubdivision in ipe +-- +-------------------------------------------------------------------------------- module Data.Geometry.PlanarSubdivision.Draw where import Control.Lens import Data.Ext -import Data.Geometry.Ipe +import Ipe import Data.Geometry.LineSegment import Data.Geometry.PlanarSubdivision import Data.Geometry.Polygon import Data.Maybe (mapMaybe) import qualified Data.Vector as V - -drawColoredPlanarSubdivision :: IpeOut (PlanarSubdivision s v e (Maybe (IpeColor r)) r) - Group r -drawColoredPlanarSubdivision ps = drawPlanarSubdivision - (ps&vertexData.traverse .~ Just mempty - &dartData.traverse._2 .~ Just mempty - &faceData.traverse %~ fmap (attr SFill) - ) +-------------------------------------------------------------------------------- -- | Draws only the values for which we have a Just attribute -drawPlanarSubdivision :: forall s r. +drawPlanarSubdivision :: forall s r. (Num r, Ord r) => IpeOut (PlanarSubdivision s (Maybe (IpeAttributes IpeSymbol r)) (Maybe (IpeAttributes Path r)) (Maybe (IpeAttributes Path r)) r) Group r -drawPlanarSubdivision = drawPlanarSubdivisionWith fv fe ff +drawPlanarSubdivision = drawPlanarSubdivisionWith fv fe ff ff where fv :: (VertexId' s, VertexData r (Maybe (IpeAttributes IpeSymbol r))) -> Maybe (IpeObject' IpeSymbol r) @@ -34,21 +37,25 @@ -- | Draw everything using the defaults -drawPlanarSubdivision' :: forall s v e f r. IpeOut (PlanarSubdivision s v e f r) Group r +drawPlanarSubdivision' :: forall s v e f r. (Num r, Ord r) + => IpeOut (PlanarSubdivision s v e f r) Group r drawPlanarSubdivision' ps = drawPlanarSubdivision - (ps&vertexData.traverse .~ Just (mempty :: IpeAttributes IpeSymbol r) - &dartData.traverse._2 .~ Just (mempty :: IpeAttributes Path r) - &faceData.traverse .~ Just (mempty :: IpeAttributes Path r)) + (ps&vertexData.traverse ?~ (mempty :: IpeAttributes IpeSymbol r) + &dartData.traverse._2 ?~ (mempty :: IpeAttributes Path r) + &faceData.traverse ?~ (mempty :: IpeAttributes Path r)) -type MIO g i r = g -> Maybe (IpeObject' i r) -drawPlanarSubdivisionWith :: (ToObject vi, ToObject ei, ToObject fi) - => MIO (VertexId' s, VertexData r v) vi r - -> MIO (Dart s, LineSegment 2 v r :+ e) ei r - -> MIO (FaceId' s, SomePolygon v r :+ f) fi r - -> IpeOut (PlanarSubdivision s v e f r) Group r -drawPlanarSubdivisionWith fv fe ff g = ipeGroup . concat $ [vs, es, fs] +-- | Function to draw a planar subdivision by giving functions that +-- specify how to render vertices, edges, the internal faces, and the outer face. +drawPlanarSubdivisionWith :: (ToObject vi, ToObject ei, ToObject fi, Num r, Ord r) + => IpeOut' Maybe (VertexId' s, VertexData r v) vi r + -> IpeOut' Maybe (Dart s, LineSegment 2 v r :+ e) ei r + -> IpeOut' Maybe (FaceId' s, SomePolygon v r :+ f) fi r + -> IpeOut' Maybe (FaceId' s, MultiPolygon (Maybe v) r :+ f) fi r + -> IpeOut (PlanarSubdivision s v e f r) Group r +drawPlanarSubdivisionWith fv fe fi fo g = ipeGroup . concat $ [o <> fs, es, vs] where - vs = mapMaybe (fmap iO . fv) . V.toList . vertices $ g - es = mapMaybe (fmap iO . fe) . V.toList . edgeSegments $ g - fs = mapMaybe (fmap iO . ff) . V.toList . rawFacePolygons $ g + vs = mapMaybe (fmap iO . fv) . V.toList . vertices $ g + es = mapMaybe (fmap iO . fe) . V.toList . edgeSegments $ g + fs = mapMaybe (fmap iO . fi) . V.toList . internalFacePolygons $ g + o = mapMaybe (fmap iO . fo) [(outerFaceId g, outerFacePolygon g)] diff --git a/src/Data/Geometry/QuadTree/Draw.hs b/src/Data/Geometry/QuadTree/Draw.hs --- a/src/Data/Geometry/QuadTree/Draw.hs +++ b/src/Data/Geometry/QuadTree/Draw.hs @@ -1,28 +1,42 @@ {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.QuadTree.Draw +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Machinery for drawing cells. +-- +-------------------------------------------------------------------------------- module Data.Geometry.QuadTree.Draw where import Data.Ext import qualified Data.Foldable as F -import Data.Geometry.Ipe.Attributes -import Data.Geometry.Ipe.IpeOut -import Data.Geometry.Ipe.Types +import Ipe.Attributes +import Ipe.IpeOut +import Ipe.Types import Data.Geometry.QuadTree import Data.Geometry.QuadTree.Cell import qualified Data.Text as T import Data.Tree.Util (TreeNode(..)) -------------------------------------------------------------------------------- +-- | Draw a quadTree cell as a Path drawCell :: Fractional r => IpeOut (Cell r) Path r -drawCell = \c -> ipeRectangle (toBox c) +drawCell = ipeRectangle . toBox +-- | Draws an entire quadtree. drawQuadTree :: (Fractional r, Ord r) => IpeOut (QuadTree v p r) Group r drawQuadTree = drawQuadTreeWith (\(_ :+ c) -> drawCell c) +-- | Draw a quadtree with a given method for drawing the cells. drawQuadTreeWith :: (ToObject i, Fractional r, Ord r) => IpeOut (p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r drawQuadTreeWith drawCell' = ipeGroup . fmap (iO . drawCell') . leaves . withCells +-- | Draw every cell of a level of the quadtree. quadTreeLevels :: forall i r v p. (ToObject i, Fractional r, Ord r ) => IpeOut (TreeNode v p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r @@ -37,4 +51,4 @@ drawLevel i = ipeGroup . fmap (\n -> iO $ ipeGroup [iO $ drawCell' n] ! attr SLayer (layer i)) layer :: Int -> LayerName - layer i = LayerName $ "level_" <> (T.pack $ show i) + layer i = LayerName $ "level_" <> T.pack (show i) diff --git a/src/Data/Geometry/Triangulation/Draw.hs b/src/Data/Geometry/Triangulation/Draw.hs --- a/src/Data/Geometry/Triangulation/Draw.hs +++ b/src/Data/Geometry/Triangulation/Draw.hs @@ -2,7 +2,7 @@ import Algorithms.Geometry.DelaunayTriangulation.Types import Data.Geometry.LineSegment -import Data.Geometry.Ipe +import Ipe -------------------------------------------------------------------------------- diff --git a/src/Data/PlaneGraph/Draw.hs b/src/Data/PlaneGraph/Draw.hs --- a/src/Data/PlaneGraph/Draw.hs +++ b/src/Data/PlaneGraph/Draw.hs @@ -1,50 +1,73 @@ {-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlaneGraph.Draw +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Helper functions to draw a PlaneGraph in ipe +-- +-------------------------------------------------------------------------------- module Data.PlaneGraph.Draw where +import Control.Lens import Data.Ext -import Data.Geometry.Ipe -import Data.Geometry.Properties +import qualified Data.Foldable as F import Data.Geometry.LineSegment -import Data.Geometry.Point import Data.Geometry.Polygon -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.PlaneGraph -import qualified Data.Vector as V +import Ipe -------------------------------------------------------------------------------- --- | Draws a planegraph using Marks, LineSegments, and simple polygons for --- vertices, edges, and faces, respectively. Uses the default IpeOuts to draw --- these elements. -drawPlaneGraph :: forall s v e f r. IpeOut (PlaneGraph s v e f r) Group r -drawPlaneGraph = drawPlaneGraphWith defIO' defIO' defIO' +-- | Draws only the values for which we have a Just attribute +drawPlaneGraph :: forall s r. (Fractional r, Ord r) + => IpeOut (PlaneGraph s (Maybe (IpeAttributes IpeSymbol r)) + (Maybe (IpeAttributes Path r)) + (Maybe (IpeAttributes Path r)) + r) Group r +drawPlaneGraph = drawPlaneGraphWith fv fe ff ff where - defIO' :: (HasDefaultIpeOut g, NumType g ~ r) => g -> _x -> Maybe (IpeObject r) - defIO' p _ = Just . iO $ defIO p + fv :: (VertexId' s, VertexData r (Maybe (IpeAttributes IpeSymbol r))) + -> Maybe (IpeObject' IpeSymbol r) + fv (_,VertexData p ma) = (\a -> defIO p ! a) <$> ma -- draws a point + fe (_,s :+ ma) = (\a -> defIO s ! a) <$> ma -- draw segment + ff (_,f :+ ma) = (\a -> defIO f ! a) <$> ma -- draw a face --- | Draws a planegraph using Marks, LineSegments, and simple polygons for --- vertices, edges, and faces, respectively. -drawPlaneGraphWith :: (Point 2 r -> v -> Maybe (IpeObject r)) - -> (LineSegment 2 v r -> e -> Maybe (IpeObject r)) - -> (SimplePolygon v r -> f -> Maybe (IpeObject r)) - -> IpeOut (PlaneGraph s v e f r) Group r -drawPlaneGraphWith vF eF fF g = ipeGroup $ concatMap (catMaybes . V.toList) [vs, es, fs] - where - vs = (\(_,VertexData p v) -> vF p v) <$> vertices g - es = (\(_,s :+ e) -> eF s e) <$> edgeSegments g - fs = (\(_,p :+ f) -> fF p f) <$> rawFacePolygons g +-- | Draw everything using the defaults +drawPlaneGraph' :: forall s v e f r. (Ord r, Fractional r) + => IpeOut (PlaneGraph s v e f r) Group r +drawPlaneGraph' pg = drawPlaneGraph + (pg&vertexData.traverse ?~ (mempty :: IpeAttributes IpeSymbol r) + &dartData.traverse._2 ?~ (mempty :: IpeAttributes Path r) + &faceData.traverse ?~ (mempty :: IpeAttributes Path r)) --- | Draw a planegraph using the given functions. Fully generic in how we draw --- the objects. -genericDrawPlaneGraphWith :: (VertexId' s :+ v -> IpeObject r) - -> (Dart s :+ e -> IpeObject r) - -> (FaceId' s :+ f -> IpeObject r) - -> IpeOut (PlaneGraph s v e f r) Group r -genericDrawPlaneGraphWith vF eF fF g = ipeGroup $ concatMap V.toList [vs, es, fs] - where - vs = (\(v,VertexData _ x) -> vF $ v :+ x) <$> vertices g - es = wrap eF <$> edges g - fs = wrap fF <$> faces g +-- | Function to draw a graph by giving functions that specify how to +-- render vertices, edges, and faces. +drawPlaneGraphWith :: (ToObject vi, ToObject ei, ToObject fi, Fractional r, Ord r) + => IpeOut' Maybe (VertexId' s, VertexData r v) vi r + -> IpeOut' Maybe (Dart s, LineSegment 2 v r :+ e) ei r + -> IpeOut' Maybe (FaceId' s, SimplePolygon v r :+ f) fi r + -> IpeOut' Maybe (FaceId' s, MultiPolygon (Maybe v) r :+ f) fi r + -> IpeOut (PlaneGraph s v e f r) Group r +drawPlaneGraphWith fs fe fif fof g = drawPlaneGraphWith' (outerFaceId g) fs fe fif fof g - wrap f (a,b) = f $ a :+ b +-- | Function to draw a graph by giving the outer faceId and the +-- functions that specify how to render vertices, edges, and faces. +drawPlaneGraphWith' :: (ToObject vi, ToObject ei, ToObject fi, Num r, Ord r) + => FaceId' s -- ^ outerface Id + -> IpeOut' Maybe (VertexId' s, VertexData r v) vi r + -> IpeOut' Maybe (Dart s, LineSegment 2 v r :+ e) ei r + -> IpeOut' Maybe (FaceId' s, SimplePolygon v r :+ f) fi r + -> IpeOut' Maybe (FaceId' s, MultiPolygon (Maybe v) r :+ f) fi r + -> IpeOut (PlaneGraph s v e f r) Group r +drawPlaneGraphWith' i fv fe fif fof g = ipeGroup . concat $ [vs, es, ifs, of'] + where + (outerF,innerFs) = facePolygons i g + vs = mapMaybe (fmap iO . fv) . F.toList . vertices $ g + es = mapMaybe (fmap iO . fe) . F.toList . edgeSegments $ g + ifs = mapMaybe (fmap iO . fif) . F.toList $ innerFs + of' = mapMaybe (fmap iO . fof) [outerF] diff --git a/src/Data/Tree/Draw.hs b/src/Data/Tree/Draw.hs --- a/src/Data/Tree/Draw.hs +++ b/src/Data/Tree/Draw.hs @@ -3,7 +3,7 @@ import Data.Ext import Data.Geometry.LineSegment import Data.Geometry.Point -import Data.Geometry.Ipe +import Ipe import Data.Tree -------------------------------------------------------------------------------- diff --git a/src/Ipe.hs b/src/Ipe.hs new file mode 100644 --- /dev/null +++ b/src/Ipe.hs @@ -0,0 +1,99 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Reexports the functionality for reading and writing Ipe files. +-- +-------------------------------------------------------------------------------- +module Ipe( + -- * Ipe Files + IpeFile(IpeFile), preamble, styles, pages + , ipeFile, singlePageFile, singlePageFromContent + -- ** Reading Ipe files + , readIpeFile + , readSinglePageFile + , readSinglePageFileThrow + , readRawIpeFile + , ConversionError + -- *** Reading all Geometries from a single page ipe file + , readAll, readAllFrom + -- ** Writing ipe files + , writeIpeFile, writeIpeFile', writeIpePage + , toIpeXML + , printAsIpeSelection, toIpeSelectionXML + + + -- * Ipe Pages + , IpePage(IpePage), layers, views, content + , emptyPage, fromContent + , onLayer, contentInView + , withDefaults + + -- * Content: Ipe Objects + , IpeObject(..), _IpePath, _IpeUse, _IpeGroup, _IpeTextLabel, _IpeMiniPage, _IpeImage + , IpeObject' + , ipeObject' + , ToObject(..) + -- ** Specific Ipe-Objects + , Path(Path), pathSegments + , PathSegment(..) + , IpeSymbol(Symbol), symbolPoint, symbolName + , Group(Group), groupItems + , TextLabel(..) + , MiniPage(..), width + , Image(Image), imageData, rect + , IpeBitmap + -- ** Attributes + , IpeAttributes + , Attributes', AttributesOf, AttrMap, AttrMapSym1 + , attributes, traverseIpeAttrs + , commonAttributes + -- * Layers and Views + , LayerName(LayerName), layerName + , View(View), layerNames, activeLayer + -- * Ipe Syles and Preamble + , IpeStyle(IpeStyle), styleName, styleData + , basicIpeStyle + , readIpeStylesheet + , addStyleSheetFrom + , IpePreamble(IpePreamble), encoding, preambleData + -- * Reading Geometries *From* Ipe + , IpeRead(..) + -- ** Converting *from* IpeObjects + , _asPoint + , _asLineSegment + , _asRectangle + , _asTriangle + , _asPolyLine + , _asSomePolygon, _asSimplePolygon, _asMultiPolygon + -- *** Dealing with Attributes + , _withAttrs + -- ** Default readers + , HasDefaultFromIpe(..) + + -- * Converting *to* IpeObjects + -- ** IpeWrite + , IpeWrite(..) + , IpeWriteText(..) + -- ** IpeOut + , module Ipe.IpeOut + -- ** Batch reexports + + , module Ipe.Types + , module Ipe.FromIpe + , module Ipe.Attributes + , module Ipe.Value + , IpeColor(..), named + ) where + +import Ipe.Types +import Ipe.Writer +import Ipe.Reader +import Ipe.IpeOut +import Ipe.FromIpe +import Ipe.Attributes +import Ipe.Value +import Ipe.Color diff --git a/src/Ipe/Attributes.hs b/src/Ipe/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Attributes.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Attributes +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Possible Attributes we can assign to items in an Ipe file +-- +-------------------------------------------------------------------------------- +module Ipe.Attributes + -- ( AttributeUniverse(..) + -- , + + -- ) + where + +import Control.Lens hiding (rmap, Const) +import Ipe.Value +import Data.Singletons +import Data.Singletons.TH +import Data.Text (Text) +import Data.Vinyl +import Data.Vinyl.TypeLevel +import Data.Vinyl.Functor +import Text.Read (lexP, step, parens, prec, (+++) + , Lexeme(Ident), readPrec, readListPrec, readListPrecDefault) + +-------------------------------------------------------------------------------- + +-- | The possible Attributes supported in Ipe. To use these +-- attributes, you'll likely need their Singletons's version which is +-- Prefixed by an 'S'. E.g. the 'Fill' attribute is represented by a +-- singleton 'SFill :: Sing Fill'. +data AttributeUniverse = -- common + Layer | Matrix | Pin | Transformations + -- symbol + | Stroke | Fill | Pen | Size + -- Path + | Dash | LineCap | LineJoin + | FillRule | Arrow | RArrow | StrokeOpacity | Opacity | Tiling | Gradient + -- Group + | Clip + -- Extra +-- | X Text + deriving (Show,Read,Eq) + + +genSingletons [ ''AttributeUniverse ] + +-- | IpeObjects may have attributes. Essentially attributes are +-- (key,value) pairs. The key is some name. Which attributes an object +-- can have depends on the type of the object. However, all ipe +-- objects support the Common Attributes +type CommonAttributes = [ Layer, Matrix, Pin, Transformations ] + +-- | All attributes applicable to TextLabels +type TextLabelAttributes = CommonAttributes +-- | All attributes applicable to Minipages +type MiniPageAttributes = CommonAttributes +-- | All attributes applicable to Images +type ImageAttributes = CommonAttributes + +-- | All attributes applicable to Symbols/Marks +type SymbolAttributes = CommonAttributes ++ [Stroke, Fill, Pen, Size] + +-- | All attributes applicable to Paths +type PathAttributes = CommonAttributes ++ + [ Stroke, Fill, Dash, Pen, LineCap, LineJoin + , FillRule, Arrow, RArrow, StrokeOpacity, Opacity, Tiling, Gradient + ] + +-- | All attributes applicable to Groups +type GroupAttributes = CommonAttributes ++ '[ 'Clip] + +-------------------------------------------------------------------------------- +-- * A single attribute Attr + +-- | Attr implements the mapping from labels to types as specified by the +-- (symbol representing) the type family 'f' +newtype Attr (f :: TyFun u * -> *) -- Symbol repr. the Type family mapping + -- Labels in universe u to concrete types + (label :: u) = GAttr { _getAttr :: Maybe (Apply f label) } + + +deriving instance Eq (Apply f label) => Eq (Attr f label) +deriving instance Ord (Apply f label) => Ord (Attr f label) + +makeLenses ''Attr + +-- | Constructor for constructing an Attr given an actual value. +pattern Attr :: Apply f label -> Attr f label +pattern Attr x = GAttr (Just x) + +-- | An Attribute that is not set +pattern NoAttr :: Attr f label +pattern NoAttr = GAttr Nothing +{-# COMPLETE NoAttr, Attr #-} + +-- | Traverse an attribute. +traverseAttr :: Applicative h => (Apply f label -> h (Apply g label)) + -> Attr f label -> h (Attr g label) +traverseAttr f = \case + Attr x -> Attr <$> f x + NoAttr -> pure NoAttr + +-- | Traverse for the situation where the type is not actually parameterized. +pureAttr :: (Applicative h, Apply f a ~ Apply g a) => Attr f a -> h (Attr g a) +pureAttr = pure . \case + Attr a -> Attr a + NoAttr -> NoAttr + + +instance Show (Apply f label) => Show (Attr f label) where + showsPrec d NoAttr = showParen (d > app_prec) $ showString "NoAttr" + where app_prec = 10 + showsPrec d (Attr a) = showParen (d > up_prec) $ + showString "Attr " . showsPrec (up_prec+1) a + where up_prec = 5 + +instance Read (Apply f label) => Read (Attr f label) where + readPrec = parens $ (prec app_prec $ do + Ident "NoAttr" <- lexP + pure NoAttr) + +++ (prec up_prec $ do + Ident "Attr" <- lexP + a <- step readPrec + pure $ Attr a) + where + app_prec = 10 + up_prec = 5 + readListPrec = readListPrecDefault + + + +-- | Give pref. to the *RIGHT* +instance Semigroup (Attr f l) where + _ <> b@(Attr _) = b + a <> _ = a + +instance Monoid (Attr f l) where + mempty = NoAttr + mappend = (<>) + +-------------------------------------------------------------------------------- +-- * Attributes + +-- | A collection of Attributes. +newtype Attributes (f :: TyFun u * -> *) (ats :: [u]) = Attrs (Rec (Attr f) ats) + +-- | Get a vinyl Record with Attrs +unAttrs :: Lens (Attributes f ats) (Attributes f' ats') (Rec (Attr f) ats) (Rec (Attr f') ats') +unAttrs = lens (\(Attrs r) -> r) (const Attrs) + +deriving instance ( RMap ats, ReifyConstraint Show (Attr f) ats, RecordToList ats + , RecAll (Attr f) ats Show) => Show (Attributes f ats) +-- deriving instance (RecAll (Attr f) ats Read) => Read (Attributes f ats) + +instance ( ReifyConstraint Eq (Attr f) ats, RecordToList ats + , RecAll (Attr f) ats Eq) => Eq (Attributes f ats) where + (Attrs a) == (Attrs b) = and . recordToList + . zipRecsWith (\x (Compose (Dict y)) -> Const $ x == y) a + . (reifyConstraint @Eq) $ b + +instance RecApplicative ats => Monoid (Attributes f ats) where + mempty = Attrs $ rpure mempty + a `mappend` b = a <> b + +instance Semigroup (Attributes f ats) where + (Attrs as) <> (Attrs bs) = Attrs $ zipRecsWith mappend as bs + +-- | Traverse implementation for Attrs +traverseAttrs :: Applicative h + => (forall label. Attr f label -> h (Attr g label)) + -> Attributes f ats -> h (Attributes g ats) +traverseAttrs f (Attrs ats) = Attrs <$> rtraverse f ats + +-- | Zip two Recs with the given function. +zipRecsWith :: (forall a. f a -> g a -> h a) + -> Rec f as -> Rec g as -> Rec h as +zipRecsWith _ RNil _ = RNil +zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss + + +---------------------------------------- + +-- | Lens into a specific attribute, if it is set. +ixAttr :: forall at ats proxy f. (at ∈ ats) + => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at)) +ixAttr _ = unAttrs.(rlens @at).getAttr + +-- | Prism into a particular attribute. +_Attr :: forall at ats proxy f. (at ∈ ats, RecApplicative ats) + => proxy at -> Prism' (Attributes f ats) (Apply f at) +_Attr a = prism' setA getA + where + setA x = setAttr a x mempty + getA = lookupAttr a + +-- | Looks up a particular attribute. +lookupAttr :: (at ∈ ats) => proxy at -> Attributes f ats -> Maybe (Apply f at) +lookupAttr p = view (ixAttr p) + +-- | Sets a particular attribute +setAttr :: forall proxy at ats f. (at ∈ ats) + => proxy at -> Apply f at -> Attributes f ats -> Attributes f ats +setAttr _ a (Attrs r) = Attrs $ rput (Attr a :: Attr f at) r + + +-- | gets and removes the attribute from Attributes +takeAttr :: forall proxy at ats f. (at ∈ ats) + => proxy at -> Attributes f ats -> ( Maybe (Apply f at) + , Attributes f ats ) +takeAttr p ats = (lookupAttr p ats, ats&ixAttr p .~ Nothing) + +-- | unsets/Removes an attribute +unSetAttr :: forall proxy at ats f. (at ∈ ats) + => proxy at -> Attributes f ats -> Attributes f ats +unSetAttr p = snd . takeAttr p + +-- | Creates a singleton attribute +attr :: (at ∈ ats, RecApplicative ats) + => proxy at -> Apply f at -> Attributes f ats +attr p x = x^.re (_Attr p) + +-------------------------------------------------------------------------------- +-- * Implementations for Common Attributes + +-- | Possible values for Pin +data PinType = No | Yes | Horizontal | Vertical + deriving (Eq,Show,Read) + +-- | Possible values for Transformation +data TransformationTypes = Affine | Rigid | Translations deriving (Show,Read,Eq) + +-------------------------------------------------------------------------------- +-- * Text Attributes + +-- these Attributes are speicifc to IpeObjects representing TextLabels +-- and MiniPages. The same structure as for the `CommonAttributes' +-- applies here. + +-- | TODO + +-------------------------------------------------------------------------------- +-- * Symbol Attributes + +-- | The optional Attributes for a symbol +-- data SymbolAttributeUniverse = SymbolStroke | SymbolFill | SymbolPen | Size +-- deriving (Show,Eq) + +-- | Size +newtype IpeSize r = IpeSize (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable) +-- | Pen/Thickness +newtype IpePen r = IpePen (IpeValue r) deriving (Show,Eq,Ord,Functor,Foldable,Traversable) + +------------------------------------------------------------------------------- +-- * Path Attributes + +-- | Possible values for Dash +data IpeDash r = DashNamed Text + | DashPattern [r] r + deriving (Show,Eq,Functor,Foldable,Traversable) + +-- | Allowed Fill types +data FillType = Wind | EOFill deriving (Show,Read,Eq) + +-- | IpeOpacity, IpeTyling, and IpeGradient are all symbolic values +type IpeOpacity = Text +type IpeTiling = Text +type IpeGradient = Text + +-- | Possible values for an ipe arrow +data IpeArrow r = IpeArrow { _arrowName :: Text + , _arrowSize :: IpeSize r + } deriving (Show,Eq,Functor,Foldable,Traversable) +makeLenses ''IpeArrow + +-- | A normal arrow +normalArrow :: IpeArrow r +normalArrow = IpeArrow "normal" (IpeSize $ Named "normal/normal") + +-------------------------------------------------------------------------------- +-- * Group Attributes + +-- | The only group attribute is a Clip + +-- A clipping path is a Path. Which is defined in Ipe.Types. To +-- avoid circular imports, we define GroupAttrElf and GroupAttribute there. + +-------------------------------------------------------------------------------- +-- * Attribute names in Ipe + + +-- | For the types representing attribute values we can get the name/key to use +-- when serializing to ipe. +class IpeAttrName (a :: AttributeUniverse) where + attrName :: proxy a -> Text + +-- CommonAttributeUnivers +instance IpeAttrName Layer where attrName _ = "layer" +instance IpeAttrName Matrix where attrName _ = "matrix" +instance IpeAttrName Pin where attrName _ = "pin" +instance IpeAttrName Transformations where attrName _ = "transformations" + +-- IpeSymbolAttributeUniversre +instance IpeAttrName Stroke where attrName _ = "stroke" +instance IpeAttrName Fill where attrName _ = "fill" +instance IpeAttrName Pen where attrName _ = "pen" +instance IpeAttrName Size where attrName _ = "size" + +-- PathAttributeUniverse +instance IpeAttrName Dash where attrName _ = "dash" +instance IpeAttrName LineCap where attrName _ = "cap" +instance IpeAttrName LineJoin where attrName _ = "join" +instance IpeAttrName FillRule where attrName _ = "fillrule" +instance IpeAttrName Arrow where attrName _ = "arrow" +instance IpeAttrName RArrow where attrName _ = "rarrow" +instance IpeAttrName StrokeOpacity where attrName _ = "stroke-opacity" +instance IpeAttrName Opacity where attrName _ = "opacity" +instance IpeAttrName Tiling where attrName _ = "tiling" +instance IpeAttrName Gradient where attrName _ = "gradient" + +-- GroupAttributeUniverse +instance IpeAttrName Clip where attrName _ = "clip" + +-- | Writing Attribute names +writeAttrNames :: AllConstrained IpeAttrName rs => Rec f rs -> Rec (Const Text) rs +writeAttrNames RNil = RNil +writeAttrNames (x :& xs) = Const (write'' x) :& writeAttrNames xs + where + write'' :: forall f s. IpeAttrName s => f s -> Text + write'' _ = attrName (Proxy :: Proxy s) + +-- + +-------------------------------------------------------------------------------- diff --git a/src/Ipe/Color.hs b/src/Ipe/Color.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Color.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Color +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing colors in ipe as well as the colors available in +-- the standard ipe stylesheet. +-- +-------------------------------------------------------------------------------- +module Ipe.Color where + +import Data.Colour.SRGB (RGB(..)) +import Ipe.Value +import Data.Text +import Data.Traversable +-------------------------------------------------------------------------------- + +-- | Defines a color in Ipe. Colors are either RGB Values or Named +-- values. +newtype IpeColor r = IpeColor (IpeValue (RGB r)) deriving (Show,Read,Eq) + +instance Ord r => Ord (IpeColor r) where + (IpeColor c) `compare` (IpeColor c') = fmap f c `compare` fmap f c' + where + f (RGB r g b) = (r,g,b) + +instance Functor IpeColor where + fmap = fmapDefault +instance Foldable IpeColor where + foldMap = foldMapDefault +instance Traversable IpeColor where + traverse f (IpeColor v) = IpeColor <$> traverse traverseRGB v + where + traverseRGB (RGB r g b) = RGB <$> f r <*> f g <*> f b + +-- | Creates a named color +named :: Text -> IpeColor r +named = IpeColor . Named + +-------------------------------------------------------------------------------- +-- * Basic Named colors + +black :: IpeColor r +black = named "black" + +white :: IpeColor r +white = named "white" + +red :: IpeColor r +red = named "red" + +green :: IpeColor r +green = named "green" + +blue :: IpeColor r +blue = named "blue" + +yellow :: IpeColor r +yellow = named "yellow" + +orange :: IpeColor r +orange = named "orange" + +gold :: IpeColor r +gold = named "gold" + +purple :: IpeColor r +purple = named "purple" + +gray :: IpeColor r +gray = named "gray" + +brown :: IpeColor r +brown = named "brown" + +navy :: IpeColor r +navy = named "navy" + +pink :: IpeColor r +pink = named "pink" + +seagreen :: IpeColor r +seagreen = named "seagreen" + +turquoise :: IpeColor r +turquoise = named "turquoise" + +violet :: IpeColor r +violet = named "violet" + +darkblue :: IpeColor r +darkblue = named "darkblue" + +darkcyan :: IpeColor r +darkcyan = named "darkcyan" + +darkgray :: IpeColor r +darkgray = named "darkgray" + +darkgreen :: IpeColor r +darkgreen = named "darkgreen" + +darkmagenta :: IpeColor r +darkmagenta = named "darkmagenta" + +darkorange :: IpeColor r +darkorange = named "darkorange" + +darkred :: IpeColor r +darkred = named "darkred" + +lightblue :: IpeColor r +lightblue = named "lightblue" + +lightcyan :: IpeColor r +lightcyan = named "lightcyan" + +lightgray :: IpeColor r +lightgray = named "lightgray" + +lightgreen :: IpeColor r +lightgreen = named "lightgreen" + +lightyellow :: IpeColor r +lightyellow = named "lightyellow" diff --git a/src/Ipe/Content.hs b/src/Ipe/Content.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Content.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +module Ipe.Content( + Image(Image), imageData, rect + , TextLabel(..) + , MiniPage(..), width + + , IpeSymbol(Symbol), symbolPoint, symbolName + + , Path(Path), pathSegments + , PathSegment(..) + + , Group(Group), groupItems + + + , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath + , IpeObject' + , ipeObject', ToObject(..) + + , IpeAttributes + , Attributes', AttributesOf, AttrMap, AttrMapSym1 + , attributes, traverseIpeAttrs + , commonAttributes + + , flattenGroups + ) where + +import Control.Lens hiding (views) +import Data.Bitraversable +import Data.Ext +import Data.Geometry.Box (Rectangle) +import qualified Ipe.Attributes as AT +import Ipe.Attributes hiding (Matrix) +import Ipe.Color +import Ipe.Layer +import Ipe.Path +import Data.Geometry.Matrix +import Data.Geometry.Point +import Data.Geometry.Properties +import Data.Geometry.Transformation +import Data.Proxy +import Data.Singletons.TH (genDefunSymbols) +import Data.Text (Text) +import Data.Traversable +import Data.Vinyl hiding (Label) +import Data.Vinyl.TypeLevel (AllConstrained) + +-------------------------------------------------------------------------------- +-- | Image Objects + +data Image r = Image { _imageData :: () + , _rect :: Rectangle () r + } deriving (Show,Eq,Ord) +makeLenses ''Image + +type instance NumType (Image r) = r +type instance Dimension (Image r) = 2 + +instance Fractional r => IsTransformable (Image r) where + transformBy t = over rect (transformBy t) + +instance Functor Image where + fmap = fmapDefault +instance Foldable Image where + foldMap = foldMapDefault +instance Traversable Image where + traverse f (Image d r) = Image d <$> bitraverse pure f r + +-------------------------------------------------------------------------------- +-- | Text Objects + +data TextLabel r = Label Text (Point 2 r) + deriving (Show,Eq,Ord,Functor,Foldable,Traversable) + +data MiniPage r = MiniPage Text (Point 2 r) r + deriving (Show,Eq,Ord,Functor,Foldable,Traversable) + +type instance NumType (TextLabel r) = r +type instance Dimension (TextLabel r) = 2 + +type instance NumType (MiniPage r) = r +type instance Dimension (MiniPage r) = 2 + +instance Fractional r => IsTransformable (TextLabel r) where + transformBy t (Label txt p) = Label txt (transformBy t p) + +instance Fractional r => IsTransformable (MiniPage r) where + transformBy t (MiniPage txt p w) = MiniPage txt (transformBy t p) w + +width :: MiniPage t -> t +width (MiniPage _ _ w) = w + +-------------------------------------------------------------------------------- +-- | Ipe Symbols, i.e. Points + +-- | A symbol (point) in ipe +data IpeSymbol r = Symbol { _symbolPoint :: Point 2 r + , _symbolName :: Text + } + deriving (Show,Eq,Ord,Functor,Foldable,Traversable) +makeLenses ''IpeSymbol + +type instance NumType (IpeSymbol r) = r +type instance Dimension (IpeSymbol r) = 2 + +instance Fractional r => IsTransformable (IpeSymbol r) where + transformBy t = over symbolPoint (transformBy t) + + + +-- | Example of an IpeSymbol. I.e. A symbol that expresses that the size is 'large' +-- sizeSymbol :: Attributes (AttrMapSym1 r) (SymbolAttributes r) +-- sizeSymbol = attr SSize (IpeSize $ Named "large") + + +-------------------------------------------------------------------------------- +-- * Paths are in a separate module + +-------------------------------------------------------------------------------- +-- * Attribute Mapping + + +-- | The mapping between the labels of the the attributes and the types of the +-- attributes with these labels. For example, the 'Matrix' label/attribute should +-- have a value of type 'Matrix 3 3 r'. +type family AttrMap (r :: *) (l :: AttributeUniverse) :: * where + AttrMap r 'Layer = LayerName + AttrMap r AT.Matrix = Matrix 3 3 r + AttrMap r Pin = PinType + AttrMap r Transformations = TransformationTypes + + AttrMap r Stroke = IpeColor r + AttrMap r Pen = IpePen r + AttrMap r Fill = IpeColor r + AttrMap r Size = IpeSize r + + AttrMap r Dash = IpeDash r + AttrMap r LineCap = Int + AttrMap r LineJoin = Int + AttrMap r FillRule = FillType + AttrMap r Arrow = IpeArrow r + AttrMap r RArrow = IpeArrow r + AttrMap r StrokeOpacity = IpeOpacity + AttrMap r Opacity = IpeOpacity + AttrMap r Tiling = IpeTiling + AttrMap r Gradient = IpeGradient + + AttrMap r Clip = Path r -- strictly we event want this to be a closed path I guess + +genDefunSymbols [''AttrMap] + +-------------------------------------------------------------------------------- + + +-- | For the types representing attribute values we can get the name/key to use +-- when serializing to ipe. +class TraverseIpeAttr (a :: AttributeUniverse) where + traverseIpeAttr :: Applicative h + => (r -> h s) -> Attr (AttrMapSym1 r) a -> h (Attr (AttrMapSym1 s) a) + + -- attrName :: proxy a -> Text + +-- CommonAttributeUnivers +instance TraverseIpeAttr Layer where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr AT.Matrix where traverseIpeAttr f = traverseAttr (traverse f) +instance TraverseIpeAttr Pin where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr Transformations where traverseIpeAttr _ = pureAttr + +-- -- IpeSymbolAttributeUniversre +instance TraverseIpeAttr Stroke where traverseIpeAttr f = traverseAttr (traverse f) +instance TraverseIpeAttr Fill where traverseIpeAttr f = traverseAttr (traverse f) +instance TraverseIpeAttr Pen where traverseIpeAttr f = traverseAttr (traverse f) +instance TraverseIpeAttr Size where traverseIpeAttr f = traverseAttr (traverse f) + +-- -- PathAttributeUniverse +instance TraverseIpeAttr Dash where traverseIpeAttr f = traverseAttr (traverse f) +instance TraverseIpeAttr LineCap where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr LineJoin where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr FillRule where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr Arrow where traverseIpeAttr f = traverseAttr (traverse f) +instance TraverseIpeAttr RArrow where traverseIpeAttr f = traverseAttr (traverse f) +instance TraverseIpeAttr StrokeOpacity where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr Opacity where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr Tiling where traverseIpeAttr _ = pureAttr +instance TraverseIpeAttr Gradient where traverseIpeAttr _ = pureAttr + + +-- GroupAttributeUniverse +instance TraverseIpeAttr Clip where traverseIpeAttr f = traverseAttr (traverse f) + +-------------------------------------------------------------------------------- +-- | Groups and Objects + +-------------------------------------------------------------------------------- +-- | Group Attributes + +-- -- | Now that we know what a Path is we can define the Attributes of a Group. +-- type family GroupAttrElf (r :: *) (s :: GroupAttributeUniverse) :: * where +-- GroupAttrElf r Clip = Path r -- strictly we event want this to be a closed path I guess + +-- genDefunSymbols [''GroupAttrElf] + +-- type GroupAttributes r = Attributes (GroupAttrElfSym1 r) '[ 'Clip] + + +-- | A group is essentially a list of IpeObjects. +newtype Group r = Group [IpeObject r] deriving (Show,Eq,Functor,Foldable,Traversable) + +type instance NumType (Group r) = r +type instance Dimension (Group r) = 2 + +instance Fractional r => IsTransformable (Group r) where + transformBy t (Group s) = Group $ fmap (transformBy t) s + + +type family AttributesOf (t :: * -> *) :: [AttributeUniverse] where + AttributesOf Group = GroupAttributes + AttributesOf Image = CommonAttributes + AttributesOf TextLabel = CommonAttributes + AttributesOf MiniPage = CommonAttributes + AttributesOf IpeSymbol = SymbolAttributes + AttributesOf Path = PathAttributes + + +-- | Attributes' :: * -> [AttributeUniverse] -> * +type Attributes' r = Attributes (AttrMapSym1 r) + +type IpeAttributes g r = Attributes' r (AttributesOf g) + + +-- | An IpeObject' is essentially the oject ogether with its attributes +type IpeObject' g r = g r :+ IpeAttributes g r + +attributes :: Lens' (IpeObject' g r) (IpeAttributes g r) +attributes = extra + +-- | traverse for ipe attributes +traverseIpeAttrs :: ( Applicative f + , AllConstrained TraverseIpeAttr (AttributesOf g) + ) => proxy g -> (r -> f s) -> IpeAttributes g r -> f (IpeAttributes g s) +traverseIpeAttrs _ f (Attrs ats) = fmap Attrs . traverseIpeAttrs' f $ ats + +traverseIpeAttrs' :: ( Applicative f + , AllConstrained TraverseIpeAttr ats + ) + => (r -> f s) + -> Rec (Attr (AttrMapSym1 r)) ats + -> f (Rec (Attr (AttrMapSym1 s)) ats) +traverseIpeAttrs' f = \case + RNil -> pure RNil + (a :& ats') -> (:&) <$> traverseIpeAttr f a <*> traverseIpeAttrs' f ats' + + +data IpeObject r = + IpeGroup (IpeObject' Group r) + | IpeImage (IpeObject' Image r) + | IpeTextLabel (IpeObject' TextLabel r) + | IpeMiniPage (IpeObject' MiniPage r) + | IpeUse (IpeObject' IpeSymbol r) + | IpePath (IpeObject' Path r) + + +traverseIpeObject' :: forall g r f s. ( Applicative f + , Traversable g + , AllConstrained TraverseIpeAttr (AttributesOf g) + ) + => (r -> f s) -> IpeObject' g r -> f (IpeObject' g s) +traverseIpeObject' f (i :+ ats) = (:+) <$> traverse f i <*> traverseIpeAttrs (Proxy @g) f ats + +instance Functor IpeObject where + fmap = fmapDefault +instance Foldable IpeObject where + foldMap = foldMapDefault +instance Traversable IpeObject where + traverse f = \case + IpeGroup g -> IpeGroup <$> traverseIpeObject' f g + IpeImage i -> IpeImage <$> traverseIpeObject' f i + IpeTextLabel l -> IpeTextLabel <$> traverseIpeObject' f l + IpeMiniPage p -> IpeMiniPage <$> traverseIpeObject' f p + IpeUse u -> IpeUse <$> traverseIpeObject' f u + IpePath p -> IpePath <$> traverseIpeObject' f p + + +deriving instance (Show r) => Show (IpeObject r) +-- deriving instance (Read r) => Read (IpeObject r) +deriving instance (Eq r) => Eq (IpeObject r) + +type instance NumType (IpeObject r) = r +type instance Dimension (IpeObject r) = 2 + +makePrisms ''IpeObject + +groupItems :: Lens (Group r) (Group s) [IpeObject r] [IpeObject s] +groupItems = lens (\(Group xs) -> xs) (const Group) + +class ToObject i where + mkIpeObject :: IpeObject' i r -> IpeObject r + +instance ToObject Group where mkIpeObject = IpeGroup +instance ToObject Image where mkIpeObject = IpeImage +instance ToObject TextLabel where mkIpeObject = IpeTextLabel +instance ToObject MiniPage where mkIpeObject = IpeMiniPage +instance ToObject IpeSymbol where mkIpeObject = IpeUse +instance ToObject Path where mkIpeObject = IpePath + +instance Fractional r => IsTransformable (IpeObject r) where + transformBy t (IpeGroup i) = IpeGroup $ i&core %~ transformBy t + transformBy t (IpeImage i) = IpeImage $ i&core %~ transformBy t + transformBy t (IpeTextLabel i) = IpeTextLabel $ i&core %~ transformBy t + transformBy t (IpeMiniPage i) = IpeMiniPage $ i&core %~ transformBy t + transformBy t (IpeUse i) = IpeUse $ i&core %~ transformBy t + transformBy t (IpePath i) = IpePath $ i&core %~ transformBy t + +-- | Shorthand for constructing ipeObjects +ipeObject' :: ToObject i => i r -> IpeAttributes i r -> IpeObject r +ipeObject' i a = mkIpeObject $ i :+ a + +commonAttributes :: Lens' (IpeObject r) (Attributes (AttrMapSym1 r) CommonAttributes) +commonAttributes = lens (Attrs . g) (\x (Attrs a) -> s x a) + where + select :: (CommonAttributes ⊆ AttributesOf g) => + Lens' (IpeObject' g r) (Rec (Attr (AttrMapSym1 r)) CommonAttributes) + select = attributes.unAttrs.rsubset + + g (IpeGroup i) = i^.select + g (IpeImage i) = i^.select + g (IpeTextLabel i) = i^.select + g (IpeMiniPage i) = i^.select + g (IpeUse i) = i^.select + g (IpePath i) = i^.select + + s (IpeGroup i) a = IpeGroup $ i&select .~ a + s (IpeImage i) a = IpeImage $ i&select .~ a + s (IpeTextLabel i) a = IpeTextLabel $ i&select .~ a + s (IpeMiniPage i) a = IpeMiniPage $ i&select .~ a + s (IpeUse i) a = IpeUse $ i&select .~ a + s (IpePath i) a = IpePath $ i&select .~ a + +-- | collect all non-group objects +flattenGroups :: [IpeObject r] -> [IpeObject r] +flattenGroups = concatMap flattenGroups' + where + flattenGroups' :: IpeObject r -> [IpeObject r] + flattenGroups' (IpeGroup (Group gs :+ ats)) = + map (applyAts ats) . concatMap flattenGroups' $ gs + where + applyAts _ = id + flattenGroups' o = [o] diff --git a/src/Ipe/FromIpe.hs b/src/Ipe/FromIpe.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/FromIpe.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.FromIpe +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Functions that help reading geometric values from ipe images. +-- +-------------------------------------------------------------------------------- +module Ipe.FromIpe( + -- * Individual readers + _asPoint + , _asLineSegment + , _asRectangle + , _asTriangle + + , _asPolyLine + , _asSomePolygon, _asSimplePolygon, _asMultiPolygon + + -- * Dealing with Attributes + , _withAttrs + + -- * Default readers + , HasDefaultFromIpe(..) + + -- * Reading all elements of a particular type + , readAll, readAllFrom + ) where + +import Control.Lens hiding (Simple) +import Data.Ext +import Data.Geometry.Ball +import Data.Geometry.Box +import Data.Geometry.Ellipse (Ellipse, _EllipseCircle) +import Ipe.Path +import Ipe.Reader +import Ipe.Types +import Data.Geometry.LineSegment +import Data.Geometry.Point +import qualified Data.Geometry.PolyLine as PolyLine +import Data.Geometry.Polygon +import Data.Geometry.Properties +import Data.Geometry.Triangle +import qualified Data.LSeq as LSeq +import Data.List.NonEmpty (NonEmpty(..)) + +-------------------------------------------------------------------------------- +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Ipe.Attributes +-- >>> import Ipe.Color(IpeColor(..)) +-- >>> import Data.Geometry.Point +-- >>> :{ +-- let testPath :: Path Int +-- testPath = Path . fromSingleton . PolyLineSegment +-- . PolyLine.fromPoints . map ext +-- $ [ origin, Point2 10 10, Point2 200 100 ] +-- testPathAttrs :: IpeAttributes Path Int +-- testPathAttrs = attr SStroke (IpeColor "red") +-- testObject :: IpeObject Int +-- testObject = IpePath (testPath :+ testPathAttrs) +-- :} + + + +-- | Extracts the point from a Symbol. When creating a symbol this +-- creates a disk that supports a stroke color. +_asPoint :: Prism' (IpeSymbol r) (Point 2 r) +_asPoint = prism' (flip Symbol "mark/disk(sx)") (Just . view symbolPoint) + +-- | Try to convert a path into a line segment, fails if the path is not a line +-- segment or a polyline with more than two points. +-- +-- +_asLineSegment :: Prism' (Path r) (LineSegment 2 () r) +_asLineSegment = prism' seg2path path2seg + where + seg2path = review _asPolyLine . PolyLine.fromLineSegment + path2seg p = PolyLine.asLineSegment' =<< preview _asPolyLine p + +-- | Convert to a polyline. Ignores all non-polyline parts +-- +-- >>> testPath ^? _asPolyLine +-- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])}) +_asPolyLine :: Prism' (Path r) (PolyLine.PolyLine 2 () r) +_asPolyLine = prism' poly2path path2poly + where + poly2path = Path . fromSingleton . PolyLineSegment + path2poly = preview (pathSegments.traverse._PolyLineSegment) + -- TODO: Check that the path actually is a polyline, rather + -- than ignoring everything that does not fit + +-- | Convert to a simple polygon +_asSimplePolygon :: Prism' (Path r) (Polygon Simple () r) +_asSimplePolygon = _asSomePolygon._Left + + +-- | Tries to convert a path into a rectangle. +_asRectangle :: forall r. (Num r, Ord r) => Prism' (Path r) (Rectangle () r) +_asRectangle = prism' rectToPath pathToRect + where + rectToPath (corners -> Corners a b c d) = review _asSimplePolygon . fromPoints $ [a,b,c,d] + pathToRect p = p^?_asSimplePolygon >>= asRect + + asRect :: SimplePolygon () r -> Maybe (Rectangle () r) + asRect pg = case pg^..outerBoundaryVector.traverse of + [a,b,c,d] | isH a b && isV b c && isH c d && isV d a -> Just (boundingBoxList' [a,c]) + [a,b,c,d] | isV a b && isH b c && isV c d && isH d a -> Just (boundingBoxList' [a,c]) + _ -> Nothing + + isH (p :+ _) (q :+ _) = p^.xCoord == q^.xCoord + isV (p :+ _) (q :+ _) = p^.yCoord == q^.yCoord + + +-- | Convert to a triangle +_asTriangle :: Prism' (Path r) (Triangle 2 () r) +_asTriangle = prism' triToPath path2tri + where + triToPath (Triangle p q r) = polygonToPath . unsafeFromPoints . map (&extra .~ ()) $ [p,q,r] + path2tri p = case p^..pathSegments.traverse._PolygonPath of + [] -> Nothing + [pg] -> case polygonVertices pg of + (a :| [b,c]) -> Just $ Triangle a b c + _ -> Nothing + _ -> Nothing + + + -- an ellipse is an affine transformation of the unit disk + + +-- (Disk origin 1) (Vector2 1 1) + +_asEllipse :: Prism' (Path r) (Ellipse r) +_asEllipse = prism' toPath toEllipse + where + toPath = Path . fromSingleton . EllipseSegment + toEllipse p = case p^..pathSegments.traverse._EllipseSegment of + [e] -> Just e + _ -> Nothing + +_asCircle :: (Floating r, Eq r) => Prism' (Path r) (Circle () r) +_asCircle = _asEllipse._EllipseCircle +-- FIXME: For reading we should not need the floating constraint! + +_asDisk :: (Floating r, Eq r) => Prism' (Path r) (Disk () r) +_asDisk = _asCircle.from _DiskCircle + + +-- | Convert to a multipolygon +_asMultiPolygon :: Prism' (Path r) (MultiPolygon () r) +_asMultiPolygon = _asSomePolygon._Right + +-- _asPolygon :: Prism' (Path r) (forall t. Polygon t () r) +-- _asPolygon = prism' polygonToPath (fmap (either id id) . pathToPolygon) + +_asSomePolygon :: Prism' (Path r) (SomePolygon () r) +_asSomePolygon = prism' embed pathToPolygon + where + embed = either polygonToPath polygonToPath + + +polygonToPath :: Polygon t () r -> Path r +polygonToPath pg@SimplePolygon{} = Path . fromSingleton . PolygonPath $ pg +polygonToPath (MultiPolygon vs hs) = Path . LSeq.fromNonEmpty . fmap PolygonPath + $ vs :| hs + + +pathToPolygon :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r)) +pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of + [] -> Nothing + [pg] -> Just . Left $ pg + vs:hs -> Just . Right $ MultiPolygon vs hs + + + + + +-------------------------------------------------------------------------------- + + +-- | Use the first prism to select the ipe object to depicle with, and the second +-- how to select the geometry object from there on. Then we can select the geometry +-- object, directly with its attributes here. +-- +-- >>> testObject ^? _withAttrs _IpePath _asPolyLine +-- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}) +_withAttrs :: Prism' (IpeObject r) (i r :+ IpeAttributes i r) -> Prism' (i r) g + -> Prism' (IpeObject r) (g :+ IpeAttributes i r) +_withAttrs po pg = prism' g2o o2g + where + g2o = review po . over core (review pg) + o2g o = preview po o >>= \(i :+ ats) -> (:+ ats) <$> preview pg i + + + + + +-- instance HasDefaultIpeObject Path where +-- defaultIpeObject' = _IpePath + + +-- class HasDefaultFromIpe g where +-- type DefaultFromIpe g :: * -> * +-- defaultIpeObject :: proxy g -> Prism' (IpeObject r) (DefaultFromIpe g r :+ IpeAttributes (DefaultFromIpe g) r) +-- defaultFromIpe :: proxy g -> Prism' (DefaultFromIpe g (NumType g)) g + + +class HasDefaultFromIpe g where + type DefaultFromIpe g :: * -> * + defaultFromIpe :: (r ~ NumType g) + => Prism' (IpeObject r) (g :+ IpeAttributes (DefaultFromIpe g) r) + +instance HasDefaultFromIpe (Point 2 r) where + type DefaultFromIpe (Point 2 r) = IpeSymbol + defaultFromIpe = _withAttrs _IpeUse _asPoint + where + + +instance HasDefaultFromIpe (LineSegment 2 () r) where + type DefaultFromIpe (LineSegment 2 () r) = Path + defaultFromIpe = _withAttrs _IpePath _asLineSegment + +instance HasDefaultFromIpe (Ellipse r) where + type DefaultFromIpe (Ellipse r) = Path + defaultFromIpe = _withAttrs _IpePath _asEllipse + +instance (Floating r, Eq r) => HasDefaultFromIpe (Circle () r) where + type DefaultFromIpe (Circle () r) = Path + defaultFromIpe = _withAttrs _IpePath _asCircle + +instance (Floating r, Eq r) => HasDefaultFromIpe (Disk () r) where + type DefaultFromIpe (Disk () r) = Path + defaultFromIpe = _withAttrs _IpePath _asDisk + +instance HasDefaultFromIpe (PolyLine.PolyLine 2 () r) where + type DefaultFromIpe (PolyLine.PolyLine 2 () r) = Path + defaultFromIpe = _withAttrs _IpePath _asPolyLine + + +instance HasDefaultFromIpe (SimplePolygon () r) where + type DefaultFromIpe (SimplePolygon () r) = Path + defaultFromIpe = _withAttrs _IpePath _asSimplePolygon + +instance HasDefaultFromIpe (MultiPolygon () r) where + type DefaultFromIpe (MultiPolygon () r) = Path + defaultFromIpe = _withAttrs _IpePath _asMultiPolygon + + +-- | Read all g's from some ipe page(s). +readAll :: forall g r. (HasDefaultFromIpe g, r ~ NumType g) + => IpePage r -> [g :+ IpeAttributes (DefaultFromIpe g) r] +readAll p = p^..content.traverse.defaultFromIpe + +-- | Convenience function from reading all g's from an ipe file. If there +-- is an error reading or parsing the file the error is "thrown away". +readAllFrom :: forall g r. (HasDefaultFromIpe g, r ~ NumType g, Coordinate r, Eq r) + => FilePath -> IO [g :+ IpeAttributes (DefaultFromIpe g) r] +readAllFrom fp = foldMap readAll <$> readSinglePageFile fp + +fromSingleton :: a -> LSeq.LSeq 1 a +fromSingleton = LSeq.fromNonEmpty . (:| []) diff --git a/src/Ipe/IpeOut.hs b/src/Ipe/IpeOut.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/IpeOut.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.IpeOut +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Functions that help drawing geometric values in ipe. An "IpeOut" is +-- essenitally a function that converts a geometric type g into an IpeObject. +-- +-- We also proivde a "HasDefaultIpeOut" typeclass that defines a default +-- conversion function from a geometry type g to an ipe type. +-- +-------------------------------------------------------------------------------- +module Ipe.IpeOut where + + +import Control.Lens hiding (Simple) +import Data.Bifunctor +import Data.Ext +import Data.Foldable (toList) +import Data.Geometry.Ball +import Data.Geometry.BezierSpline +import Data.Geometry.Boundary +import Data.Geometry.Box +import Data.Geometry.Ellipse (Ellipse, circleToEllipse) +import Data.Geometry.HalfLine +import Ipe.Attributes +import Ipe.Color (IpeColor(..)) +import Ipe.FromIpe +import Ipe.Types +import Data.Geometry.Line +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.PolyLine (PolyLine,fromLineSegment) +import Data.Geometry.Polygon +import Data.Geometry.Polygon.Convex +import Data.Geometry.Properties +import qualified Data.LSeq as LSeq +import Data.List.NonEmpty (NonEmpty(..)) + +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vinyl (Rec(..)) +import Data.Vinyl.CoRec + + +-------------------------------------------------------------------------------- + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :{ +-- let myPolygon = fromPoints . map ext $ [origin, Point2 10 10, Point2 100 200] +-- :} + +-------------------------------------------------------------------------------- +-- * The IpeOut type and the default combinator to use it + +type IpeOut g i r = g -> IpeObject' i r + +-- | Give the option to draw zero, one or more things, i.e. by +-- choosing f ~ Maybe or f ~ [] +type IpeOut' f g i r = g -> f (IpeObject' i r) + + +-- | Add attributes to an IpeObject' +(!) :: IpeObject' i r -> IpeAttributes i r -> IpeObject' i r +(!) i ats = i&extra %~ (<> ats) + +-- | Render an ipe object +-- +-- +-- >>> :{ +-- iO $ defIO myPolygon ! attr SFill (IpeColor "blue") +-- ! attr SLayer "alpha" +-- ! attr SLayer "beta" +-- :} +-- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "blue"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}) +-- +-- >>> :{ +-- iO $ ipeGroup [ iO $ ipePolygon myPolygon ! attr SFill (IpeColor "red") +-- ] ! attr SLayer "alpha" +-- :} +-- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr}) +-- +iO :: ToObject i => IpeObject' i r -> IpeObject r +iO = mkIpeObject + +-- | Render to an ipe object using the defIO IpeOut +-- +-- +-- >>> :{ +-- iO'' myPolygon $ attr SFill (IpeColor "red") +-- <> attr SLayer "alpha" +-- <> attr SLayer "beta" +-- :} +-- IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {Attr LayerName {_layerName = "beta"}, NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}) +-- +-- >>> iO'' [ myPolygon , myPolygon ] $ attr SLayer "alpha" +-- IpeGroup (Group [IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr}),IpePath (Path {_pathSegments = LSeq (fromList [PolygonPath SimplePolygon CSeq [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [100,200] :+ ()]])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})] :+ Attrs {Attr LayerName {_layerName = "alpha"}, NoAttr, NoAttr, NoAttr, NoAttr}) +iO'' :: ( HasDefaultIpeOut g, NumType g ~ r + , DefaultIpeOut g ~ i, ToObject i + ) => g -> IpeAttributes i r + -> IpeObject r +iO'' g ats = iO $ defIO g ! ats + +-- | generate an ipe object without any specific attributes +iO' :: HasDefaultIpeOut g => g -> IpeObject (NumType g) +iO' = iO . defIO + +-------------------------------------------------------------------------------- +-- * Default Conversions + +-- | Class that specifies a default conversion from a geometry type g into an +-- ipe object. +class ToObject (DefaultIpeOut g) => HasDefaultIpeOut g where + type DefaultIpeOut g :: * -> * + + defIO :: IpeOut g (DefaultIpeOut g) (NumType g) + +instance (HasDefaultIpeOut g, a ~ IpeAttributes (DefaultIpeOut g) (NumType g)) + => HasDefaultIpeOut (g :+ a) where + type DefaultIpeOut (g :+ a) = DefaultIpeOut g + defIO (g :+ ats) = defIO g ! ats + +instance HasDefaultIpeOut a => HasDefaultIpeOut [a] where + type DefaultIpeOut [a] = Group + defIO = ipeGroup . map (iO . defIO) + +instance HasDefaultIpeOut (Point 2 r) where + type DefaultIpeOut (Point 2 r) = IpeSymbol + defIO = ipeDiskMark + +instance HasDefaultIpeOut (LineSegment 2 p r) where + type DefaultIpeOut (LineSegment 2 p r) = Path + defIO = ipeLineSegment + +instance HasDefaultIpeOut (PolyLine 2 p r) where + type DefaultIpeOut (PolyLine 2 p r) = Path + defIO = ipePolyLine + +instance (Fractional r, Ord r) => HasDefaultIpeOut (Line 2 r) where + type DefaultIpeOut (Line 2 r) = Path + defIO = ipeLine + +instance (Fractional r, Ord r) => HasDefaultIpeOut (HalfLine 2 r) where + type DefaultIpeOut (HalfLine 2 r) = Path + defIO = ipeHalfLine + +instance HasDefaultIpeOut (Polygon t p r) where + type DefaultIpeOut (Polygon t p r) = Path + defIO = ipePolygon + +instance HasDefaultIpeOut (SomePolygon p r) where + type DefaultIpeOut (SomePolygon p r) = Path + defIO = either defIO defIO + +instance HasDefaultIpeOut (ConvexPolygon p r) where + type DefaultIpeOut (ConvexPolygon p r) = Path + defIO = defIO . view simplePolygon + +instance HasDefaultIpeOut (Ellipse r) where + type DefaultIpeOut (Ellipse r) = Path + defIO = ipeEllipse + +instance Floating r => HasDefaultIpeOut (Disk p r) where + type DefaultIpeOut (Disk p r) = Path + defIO = ipeDisk + +instance Floating r => HasDefaultIpeOut (Circle p r) where + type DefaultIpeOut (Circle p r) = Path + defIO = ipeCircle + +instance Num r => HasDefaultIpeOut (Rectangle p r) where + type DefaultIpeOut (Rectangle p r) = Path + defIO = ipeRectangle + +-------------------------------------------------------------------------------- +-- * Point Converters + +ipeMark :: Text -> IpeOut (Point 2 r) IpeSymbol r +ipeMark n p = Symbol p n :+ mempty + +ipeDiskMark :: IpeOut (Point 2 r) IpeSymbol r +ipeDiskMark = ipeMark "mark/disk(sx)" + +-------------------------------------------------------------------------------- +-- * Path Converters + +-- | Size of the default bounding box used to clip lines and +-- half-lines in the default IpeOuts. +defaultBox :: Num r => Rectangle () r +defaultBox = let z = 1000 + z' = negate z + in box (ext $ Point2 z' z') (ext $ Point2 z z) + +-- | Renders a line as a Path. The line is clipped to the 'defaultBox' +ipeLine :: (Ord r, Fractional r) => IpeOut (Line 2 r) Path r +ipeLine = ipeLineIn defaultBox + +-- | Renders the line in the given box. +-- +-- pre: the intersection of the box with the line is non-empty +ipeLineIn :: forall p r. (Ord r, Fractional r) + => Rectangle p r -> IpeOut (Line 2 r) Path r +ipeLineIn bBox l = match (l `intersect` bBox) $ + H (\NoIntersection -> error "ipeLineIn: precondition failed, no intersection") + :& H (\(_p :: Point 2 r) -> error "ipeLineIn: precondition failed, single point") + :& H ipeLineSegment + :& RNil + +-- | Renders an Halfine. +-- +-- +-- pre: the intersection of the box with the line is non-empty +ipeHalfLine :: (Ord r, Fractional r) => IpeOut (HalfLine 2 r) Path r +ipeHalfLine = ipeHalfLineIn defaultBox + +-- | Renders the HalfLine in the given box. +-- +-- pre: the intersection of the box with the line is non-empty +ipeHalfLineIn :: forall p r. (Ord r, Fractional r) + => Rectangle p r -> IpeOut (HalfLine 2 r) Path r +ipeHalfLineIn bBox l = match (l `intersect` bBox) $ + H (\NoIntersection -> error "ipeHalfLineIn: precondition failed, no intersection") + :& H (\(_p :: Point 2 r) -> error "ipeHalfLineIn: precondition failed, single point") + :& H ipeLineSegment + :& RNil + +ipeLineSegment :: IpeOut (LineSegment 2 p r) Path r +ipeLineSegment s = (path . pathSegment $ s) :+ mempty + +ipePolyLine :: IpeOut (PolyLine 2 p r) Path r +ipePolyLine p = (path . PolyLineSegment . first (const ()) $ p) :+ mempty + +ipeEllipse :: IpeOut (Ellipse r) Path r +ipeEllipse = \e -> path (EllipseSegment e) :+ mempty + +ipeCircle :: Floating r => IpeOut (Circle p r) Path r +ipeCircle = ipeEllipse . circleToEllipse + +ipeDisk :: Floating r => IpeOut (Disk p r) Path r +ipeDisk d = ipeCircle (Boundary d) ! attr SFill (IpeColor "0.722 0.145 0.137") + +ipeBezier :: IpeOut (BezierSpline 3 2 r) Path r +ipeBezier b = (path $ CubicBezierSegment b) :+ mempty + +-- | Helper to construct a path from a singleton item +path :: PathSegment r -> Path r +path = Path . LSeq.fromNonEmpty . (:| []) + +pathSegment :: LineSegment 2 p r -> PathSegment r +pathSegment = PolyLineSegment . fromLineSegment . first (const ()) + +-- | Draw a polygon +ipePolygon :: IpeOut (Polygon t p r) Path r +ipePolygon (first (const ()) -> pg) = case pg of + SimplePolygon{} -> pg^.re _asSimplePolygon :+ mempty + MultiPolygon{} -> pg^.re _asMultiPolygon :+ mempty + + +-- | Draw a Rectangle +ipeRectangle :: Num r => IpeOut (Rectangle p r) Path r +ipeRectangle r = ipePolygon $ unsafeFromPoints [tl,tr,br,bl] + where + Corners tl tr br bl = corners r + +-------------------------------------------------------------------------------- +-- * Group Converters + +ipeGroup :: Foldable f => IpeOut (f (IpeObject r)) Group r +ipeGroup xs = Group (toList xs) :+ mempty + + +-------------------------------------------------------------------------------- +-- * Text Converters + +-- | Creates an text label +ipeLabel :: IpeOut (Text :+ Point 2 r) TextLabel r +ipeLabel (txt :+ p) = Label txt p :+ mempty + + +-- | Annotate an IpeOut with a label +labelled :: (Show lbl, NumType g ~ r, ToObject i) + => (g -> Point 2 r) -- ^ where to place the label + -> IpeOut g i r -- ^ how to draw the geometric object + -> IpeOut (g :+ lbl) Group r +labelled pos f (g :+ lbl) = ipeGroup [iO $ f g, iO $ ipeLabel ((Text.pack $ show lbl) :+ pos g)] diff --git a/src/Ipe/IpeRender.hs b/src/Ipe/IpeRender.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/IpeRender.hs @@ -0,0 +1,81 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.IpeRender +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Use 'iperender' to generate png, pdf, or svg files. +-- +-- Note that all functions in this module require that 'iperender' is +-- installed (it is bundled with ipe) and available on the path. + +-------------------------------------------------------------------------------- +module Ipe.IpeRender where + +import qualified System.Process.Typed as Process + +-------------------------------------------------------------------------------- + +-- | Call 'iperender' to produce an image of the specified type. +-- +-- note that pdf files produces with iperender cannot be opened with ipe. +ipeRenderWith :: Options -- ^ the options to use + -> FileType -- ^ output file type + -> FilePath -- ^ input file path + -> FilePath -- ^ output file path + -> IO () +ipeRenderWith options fType inFp outFp = + Process.withProcessWait processCfg $ \_iperenderProc -> pure () + where + processCfg = Process.proc "iperender" args + args = [ "-" <> show fType + , "-page", show (pageNumber options) + , "-view", show (viewNumber options) + , "-resolution", show (resolution options) + ] <> + [ "-transparent" | TransparentBackground == transparent options ] <> + [ "-nocrop" | NoCrop == crop options ] <> + [ inFp + , outFp + ] + +-- | Call 'iperender' with the default options. +-- +-- note that pdf files produces with iperender cannot be opened with ipe. +ipeRender :: FileType -> FilePath -> FilePath -> IO () +ipeRender = ipeRenderWith defaultOptions + +-------------------------------------------------------------------------------- + +-- | Output filetypes supported by iperender +data FileType = PNG | EPS | PDF | SVG + deriving (Eq,Ord,Enum) + +instance Show FileType where + show = \case + PNG -> "png" + EPS -> "eps" + PDF -> "pdf" + SVG -> "svg" + +-- | Options for iperender +data Options = Options { pageNumber :: Int + , viewNumber :: Int + , resolution :: Int + , transparent :: Background + , crop :: Crop + } deriving (Show,Eq,Ord) + +-- | The default options in Ipe +defaultOptions :: Options +defaultOptions = Options 1 1 72 TransparentBackground Crop + +-- | Whether or not to render a transparent background in output png +-- images. +data Background = OpaqueBackground | TransparentBackground + deriving (Show,Read,Eq,Ord,Enum) + +-- | Whether or not to crop the output image. +data Crop = NoCrop | Crop + deriving (Show,Read,Eq,Ord,Enum) diff --git a/src/Ipe/IpeToIpe.hs b/src/Ipe/IpeToIpe.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/IpeToIpe.hs @@ -0,0 +1,107 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.IpeToIpe +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Use 'ipetoipe' to generate pdf files. +-- +-- Note that all functions in this module require that 'ipetoipe' is +-- installed (it is bundled with ipe) and available on the path. + +-------------------------------------------------------------------------------- +module Ipe.IpeToIpe where + +import Data.Range +import Ipe.Types (IpeFile) +import Ipe.Writer (writeIpeFile, IpeWriteText) +import System.Directory (getTemporaryDirectory, removeFile) +import System.FilePath +import qualified System.Process.Typed as Process +import System.Random + +-------------------------------------------------------------------------------- + +-- | Call 'ipetoipe' to produce an image of the specified type. +ipeToIpeWith :: Options -- ^ the options to use + -> FileType -- ^ output file type + -> FilePath -- ^ input file path + -> FilePath -- ^ output file path + -> IO () +ipeToIpeWith options fType inFp outFp = + Process.withProcessWait processCfg $ \_iperenderProc -> pure () + where + processCfg = Process.proc "ipetoipe" args + args = [ "-" <> show fType ] <> + concat [ [ "-pages", pageRange r ] | PageRange r <- [pages options] ] <> + concat [ [ "-view", pageView p v ] | Just (p,v) <- [singleView options] ] <> + [ "-export" | Export == export options ] <> + [ "-runlatex" | runLatex options] <> + [ "-nozip" | NoZip == nozip options ] <> + [ inFp + , outFp + ] + pageRange (Range' l u) = show l <> "-" <> show u + pageView p v = show p <> "-" <> show v + + +-- | Call 'ipetoipe' with the default options. +ipeToIpe :: FileType -> FilePath -> FilePath -> IO () +ipeToIpe = ipeToIpeWith defaultOptions + +-- | Write an ipe file to disk as an ipe readable pdf file. +-- +-- Note that like all other functions in this module, this requires +-- 'ipetoipe' to be installed (it is bundled with ipe) and available +-- on the path. +-- +-- Note this will write soem intermediate file to your system temp dir. +writeIpeFileAsPdf :: IpeWriteText r => FilePath -> IpeFile r -> IO () +writeIpeFileAsPdf fp f = do num <- randomIO @Int + tempDir <- getTemporaryDirectory + let xmlFp = tempDir "writeipepdf" <> show num <.> "ipe" + writeIpeFile xmlFp f + ipeToIpe PDF xmlFp fp + removeFile xmlFp + + +data FileType = PDF | XML + deriving (Eq,Enum) + +instance Show FileType where + show = \case + PDF -> "pdf" + XML -> "xml" + +data Export = RetainIpeInfo | Export + deriving (Show,Eq,Enum) + +type PageNumber = Int +type ViewNumber = Int + +data MarkedView = All | OnlyMarkedViews + deriving (Show,Eq,Enum) + +data NoZip = NoZip | Zip + deriving (Show,Eq,Enum) + +data PageRange = EntireFile + | PageRange (Range PageNumber) -- ^ only closed ranges are supported. + deriving (Show,Eq) + +data Options = Options { export :: Export + , pages :: PageRange + , singleView :: Maybe (PageNumber,ViewNumber) + , markedView :: MarkedView + , runLatex :: Bool + , nozip :: NoZip + } deriving (Show,Eq) + +defaultOptions :: Options +defaultOptions = Options RetainIpeInfo + EntireFile + Nothing -- default : entire file + All + False + Zip diff --git a/src/Ipe/Layer.hs b/src/Ipe/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Layer.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Layer +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Layers in Ipe documents. +-- +-------------------------------------------------------------------------------- +module Ipe.Layer( + LayerName(LayerName), layerName + ) where + +import Control.Lens +import Data.Text (Text) +import GHC.Exts + +-------------------------------------------------------------------------------- + +-- | Defines an Layer in Ipe. +newtype LayerName = LayerName {_layerName :: Text } deriving (Show,Read,Eq,Ord,IsString) +makeLenses ''LayerName diff --git a/src/Ipe/Literal.hs b/src/Ipe/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Literal.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Literal +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Including xml literals +-- +-------------------------------------------------------------------------------- +module Ipe.Literal where + + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as C +import Text.XML.Expat.Tree + +-- | Include a literal expression +literally :: String -> Q Exp +literally = return . LitE . StringL + +-- | Literal quoter. +lit :: QuasiQuoter +lit = QuasiQuoter { quoteExp = literally + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +-- | Include a file as a literal. +litFile :: QuasiQuoter +litFile = quoteFile lit + +-- | Parse a string into a Node. +xmlLiteral :: String -> Node T.Text T.Text +xmlLiteral = either (error "xmlLiteral. error parsing xml: " . show) id + . parse' defaultParseOptions . C.pack diff --git a/src/Ipe/Matrix.hs b/src/Ipe/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Matrix.hs @@ -0,0 +1,53 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Matrix +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Matrix Attributes as defined in Ipe +-- +-------------------------------------------------------------------------------- +module Ipe.Matrix where + +import Control.Lens hiding (rmap) +import Data.Ext +import qualified Ipe.Attributes as AT +import Ipe.Attributes hiding (Matrix) +import Ipe.Types +import Data.Geometry.Properties +import Data.Geometry.Transformation +import Data.Proxy +import Data.Vinyl hiding (Label) + +-------------------------------------------------------------------------------- + +-- | Takes and applies the ipe Matrix attribute of this item. +applyMatrix' :: ( IsTransformable (i r) + , AT.Matrix ∈ AttributesOf i + , Dimension (i r) ~ 2, r ~ NumType (i r)) + => IpeObject' i r -> IpeObject' i r +applyMatrix' o@(i :+ ats) = maybe o (\m -> transformBy (Transformation m) i :+ ats') mm + where + (mm,ats') = takeAttr (Proxy :: Proxy AT.Matrix) ats + +-- | Applies the matrix to an ipe object if it has one. +applyMatrix :: Fractional r => IpeObject r -> IpeObject r +applyMatrix (IpeGroup i) = IpeGroup . applyMatrix' + $ i&core.groupItems.traverse %~ applyMatrix + -- note that for a group we first (recursively) + -- apply the matrices, and then apply + -- the matrix of the group to its members. +applyMatrix (IpeImage i) = IpeImage $ applyMatrix' i +applyMatrix (IpeTextLabel i) = IpeTextLabel $ applyMatrix' i +applyMatrix (IpeMiniPage i) = IpeMiniPage $ applyMatrix' i +applyMatrix (IpeUse i) = IpeUse $ applyMatrix' i +applyMatrix (IpePath i) = IpePath $ applyMatrix' i + +-- | Applies all matrices in the file. +applyMatrices :: Fractional r => IpeFile r -> IpeFile r +applyMatrices f = f&pages.traverse %~ applyMatricesPage + +-- | Applies all Matrices on a given page. +applyMatricesPage :: Fractional r => IpePage r -> IpePage r +applyMatricesPage p = p&content.traverse %~ applyMatrix diff --git a/src/Ipe/ParserPrimitives.hs b/src/Ipe/ParserPrimitives.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/ParserPrimitives.hs @@ -0,0 +1,148 @@ +{-# Language FlexibleContexts #-} +{-# Language OverloadedStrings #-} +module Ipe.ParserPrimitives( runP, runP' + , pMany, pMany1, pChoice + , pChar, pSpace, pWhiteSpace, pInteger + , pNatural, pPaddedNatural + , (<*><>) , (<*><) + , (<***>) , (<***) , (***>) + , pMaybe , pCount , pSepBy + , Parser, ParseError + , pNotFollowedBy + ) where + + +import Text.Parsec(try) +import Text.Parsec(ParsecT, Stream) +import Text.Parsec.Text +import Text.ParserCombinators.Parsec hiding (Parser,try) +import qualified Data.Text as T + + +runP' :: Parser a -> T.Text -> (a, T.Text) +runP' p s = case runP p s of + Left e -> error $ show e + Right x -> x + +runP :: Parser a -> T.Text -> Either ParseError (a,T.Text) +runP p = parse ((,) <$> p <*> getInput) "" + + +---------------------------------------------------------------------------- +-- | reexporting some standard combinators + +pMany :: Parser a -> Parser [a] +pMany = many + +pMany1 :: Parser a -> Parser [a] +pMany1 = many1 + + +pChoice :: [Parser a] -> Parser a +pChoice = choice . map try + + +pNatural :: Parser Integer +pNatural = read <$> pMany1 digit + +-- | parses an integer with a prefix of zeros. Returns the total length of the +-- string parced (i.e. number of digits) and the resulting antural number. +pPaddedNatural :: Parser (Int, Integer) +pPaddedNatural = (\s -> (length s, read s)) <$> pMany1 digit + +pInteger :: Parser Integer +pInteger = pNatural + <|> + negate <$> (pChar '-' *> pNatural) + +pChar :: Char -> Parser Char +pChar = char + +pSpace :: Parser Char +pSpace = pChar ' ' + +pWhiteSpace :: Parser [Char] +pWhiteSpace = pMany1 (space <|> newline) + +pMaybe :: Parser a -> Parser (Maybe a) +pMaybe = optionMaybe + +pCount :: Int -> Parser a -> Parser [a] +pCount = count + +pSepBy :: Parser a -> Parser b -> Parser [a] +pSepBy = sepBy + + +-- | infix variant of notfollowed by +pNotFollowedBy :: Parser a -> Parser b -> Parser a +p `pNotFollowedBy` q = do { x <- p ; notFollowedBy' q ; return x } + where + -- | copy of the original notFollowedBy but replaced the error message + -- to get rid of the Show dependency + notFollowedBy' z = try (do{ _ <- try z; unexpected "not followed by" } + <|> return () + ) + +---------------------------------------------------------------------------- +-- | Running parsers in reverse + +infix 1 <*><>, <*>< + +-- | Runs parser q ``in reverse'' on the end of the input stream +(<*><>) :: (Reversable s, Stream s m t) + => ParsecT s u m (a -> b) -> ParsecT s u m a -> ParsecT s u m b +p <*><> q = do + rev + x <- q + rev + f <- p + return $ f x + + +(<*><) :: (Stream s m t, Reversable s) + => ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b +p <*>< q = const <$> p <*><> q + + +rev :: (Reversable s, Stream s m t) => ParsecT s u m () +rev = getInput >>= (setInput . reverseS) + +-- as :: Parser String +-- as = many (char 'a') + +-- foo :: Parser String +-- foo = reverse <$> (string . reverse $ "foo") + +-- prs :: Parser (String,String) +-- prs = (,) <$> as <*>< foo' + +-- foo' :: Parser String +-- foo' = spaces ***> foo + +-- (<***>) :: Parser (a -> b) + +infixr 2 <***>, ***>, <*** + +-- | run the parsers in reverse order, first q, then p +(<***>) :: Monad m => m (t -> b) -> m t -> m b +p <***> q = do + x <- q + f <- p + return $ f x + +-- | the variants with missing brackets +(***>) :: Monad m => m a -> m b -> m b +p ***> q = (\_ s -> s) <$> p <***> q + +(<***) :: Monad m => m b -> m t -> m b +p <*** q = (\s _ -> s) <$> p <***> q + +class Reversable s where + reverseS :: s -> s + +instance Reversable [c] where + reverseS = reverse + +instance Reversable T.Text where + reverseS = T.reverse diff --git a/src/Ipe/Path.hs b/src/Ipe/Path.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Path.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Path +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Defines an Ipe Path. +-- +-------------------------------------------------------------------------------- +module Ipe.Path( + Path(Path), pathSegments + , PathSegment(..) + + , _PolyLineSegment + , _PolygonPath + , _CubicBezierSegment + , _QuadraticBezierSegment + , _EllipseSegment + , _ArcSegment + , _SplineSegment + , _ClosedSplineSegment + + , Operation(..) + , _MoveTo + , _LineTo + , _CurveTo + , _QCurveTo + , _Ellipse + , _ArcTo + , _Spline + , _ClosedSpline + , _ClosePath + ) where + +import Control.Lens hiding (rmap) +import Data.Bitraversable +import Data.Geometry.BezierSpline +import Data.Geometry.Point +import Data.Geometry.Ellipse(Ellipse) +import Data.Geometry.PolyLine +import Data.Geometry.Polygon (SimplePolygon) +import Data.Geometry.Properties +import Data.Geometry.Transformation +import Data.Geometry.Matrix +import qualified Data.LSeq as LSeq +import Data.Traversable + +-------------------------------------------------------------------------------- +-- | Paths + +-- | Paths consist of Path Segments. PathSegments come in the following forms: +data PathSegment r = PolyLineSegment (PolyLine 2 () r) + | PolygonPath (SimplePolygon () r) + | CubicBezierSegment (BezierSpline 3 2 r) + | QuadraticBezierSegment (BezierSpline 2 2 r) + | EllipseSegment (Ellipse r) + -- TODO + | ArcSegment + | SplineSegment -- (Spline 2 r) + | ClosedSplineSegment -- (ClosedSpline 2 r) + deriving (Show,Eq) +makePrisms ''PathSegment + +type instance NumType (PathSegment r) = r +type instance Dimension (PathSegment r) = 2 + +instance Functor PathSegment where + fmap = fmapDefault +instance Foldable PathSegment where + foldMap = foldMapDefault +instance Traversable PathSegment where + traverse f = \case + PolyLineSegment p -> PolyLineSegment <$> bitraverse pure f p + PolygonPath p -> PolygonPath <$> bitraverse pure f p + CubicBezierSegment b -> CubicBezierSegment <$> traverse f b + QuadraticBezierSegment b -> QuadraticBezierSegment <$> traverse f b + EllipseSegment e -> EllipseSegment <$> traverse f e + ArcSegment -> pure ArcSegment + SplineSegment -> pure SplineSegment + ClosedSplineSegment -> pure ClosedSplineSegment + +instance Fractional r => IsTransformable (PathSegment r) where + transformBy t = \case + PolyLineSegment p -> PolyLineSegment $ transformBy t p + PolygonPath p -> PolygonPath $ transformBy t p + CubicBezierSegment b -> CubicBezierSegment $ transformBy t b + QuadraticBezierSegment b -> QuadraticBezierSegment $ transformBy t b + EllipseSegment e -> EllipseSegment $ transformBy t e + -- TODO: + ArcSegment -> ArcSegment + SplineSegment -> SplineSegment + ClosedSplineSegment -> ClosedSplineSegment + + +-- | A path is a non-empty sequence of PathSegments. +newtype Path r = Path { _pathSegments :: LSeq.LSeq 1 (PathSegment r) } + deriving (Show,Eq,Functor,Foldable,Traversable) +makeLenses ''Path + +type instance NumType (Path r) = r +type instance Dimension (Path r) = 2 + +instance Fractional r => IsTransformable (Path r) where + transformBy t (Path s) = Path $ fmap (transformBy t) s + + +-------------------------------------------------------------------------------- + +-- | type that represents a path in ipe. +data Operation r = MoveTo (Point 2 r) + | LineTo (Point 2 r) + | Ellipse (Matrix 3 3 r) + | ArcTo (Matrix 3 3 r) (Point 2 r) + | Spline [Point 2 r] + | ClosedSpline [Point 2 r] + | ClosePath + -- these should be deprecated + | CurveTo (Point 2 r) (Point 2 r) (Point 2 r) + | QCurveTo (Point 2 r) (Point 2 r) + deriving (Eq, Show,Functor,Foldable,Traversable) +makePrisms ''Operation + diff --git a/src/Ipe/PathParser.hs b/src/Ipe/PathParser.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/PathParser.hs @@ -0,0 +1,194 @@ +{-# Language OverloadedStrings #-} +{-# Language DefaultSignatures #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.PathParser +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Parser for a 'Path' in Ipe. +-- +-------------------------------------------------------------------------------- +module Ipe.PathParser + ( Coordinate(..) + , readCoordinate, readPoint + , readMatrix, readRectangle + , runParser + , readPathOperations + + , pOperation, pPoint, pCoordinate + ) where + +import Data.Bifunctor +import Data.Char (isSpace) +import Data.Ext (ext) +import Data.Functor (($>)) +import Data.Geometry.Box +import Data.Geometry.Matrix +import Data.Geometry.Point +import Data.Geometry.Vector +import Data.Ratio +import Data.RealNumber.Rational +import Data.Text (Text) +import qualified Data.Text as T +import Ipe.ParserPrimitives +import Ipe.Path (Operation(..)) +import Text.Parsec.Error (messageString, errorMessages) + + +----------------------------------------------------------------------- +-- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read) + +class Fractional r => Coordinate r where + -- reads a coordinate. The input is an integer representing the + -- part before the decimal point, and a length and an integer + -- representing the part after the decimal point + fromSeq :: Integer -> Maybe (Int, Integer) -> r + default fromSeq :: (Ord r, Fractional r) => Integer -> Maybe (Int, Integer) -> r + fromSeq = defaultFromSeq + +defaultFromSeq :: (Ord r, Fractional r) + => Integer -> Maybe (Int, Integer) -> r +defaultFromSeq x Nothing = fromInteger x +defaultFromSeq x (Just (l,y)) = let x' = fromInteger x + y' = fromInteger y + asDecimal a = a * (0.1 ^ l) + z = if x' < 0 then (-1) else 1 + in z * (abs x' + asDecimal y') + +instance Coordinate Double +instance Coordinate Float +instance Coordinate (Ratio Integer) +instance Coordinate (RealNumber p) + +----------------------------------------------------------------------- +-- | Running the parsers + +-- | Read/parse a single coordinate value. +readCoordinate :: Coordinate r => Text -> Either Text r +readCoordinate = runParser pCoordinate + +-- | Read/parse a single point +readPoint :: Coordinate r => Text -> Either Text (Point 2 r) +readPoint = runParser pPoint + +-- | Run a parser +runParser :: Parser a -> Text -> Either Text a +runParser p = bimap errorText fst . runP p + +-- Collect errors +data Either' l r = Left' l | Right' r deriving (Show,Eq) + +instance (Semigroup l, Semigroup r) => Semigroup (Either' l r) where + (Left' l) <> (Left' l') = Left' $ l <> l' + (Left' l) <> _ = Left' l + _ <> (Left' l') = Left' l' + (Right' r) <> (Right' r') = Right' $ r <> r' + +instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where + mempty = Right' mempty + mappend = (<>) + +either' :: (l -> a) -> (r -> a) -> Either' l r -> a +either' lf _ (Left' l) = lf l +either' _ rf (Right' r) = rf r +-- TODO: Use Validation instead of this home-brew one + +-- | Parse a sequence of path operations. +readPathOperations :: Coordinate r => Text -> Either Text [Operation r] +readPathOperations = unWrap . mconcat . map (wrap . runP pOperation) + . clean . splitKeepDelims "mlcqeasuh" + where + -- Unwrap the Either'. If it is a Left containing all our errors, + -- combine them into one error. Otherwise just ReWrap it in an proper Either + unWrap = either' (Left . combineErrors) Right + -- for the lefts: wrap the error in a list, for the rights: we only care + -- about the result, so wrap that in a list as well. Collecting the + -- results is done using the Semigroup instance of Either' + wrap = either (Left' . (:[])) (Right' . (:[]) . fst) + -- Split the input string in pieces, each piece represents one operation + trim = T.dropWhile isSpace + clean = filter (not . T.null) . map trim + -- TODO: Do the splitting on the Text rather than unpacking and packing + -- the thing + +errorText :: ParseError -> Text +errorText = T.pack . unlines . map messageString . errorMessages + +combineErrors :: [ParseError] -> Text +combineErrors = T.unlines . map errorText + + +splitKeepDelims :: [Char] -> Text -> [Text] +splitKeepDelims delims t = maybe mPref continue $ T.uncons rest + where + mPref = if T.null pref then [] else [pref] + (pref,rest) = T.break (`elem` delims) t + continue (c,t') = pref `T.snoc` c : splitKeepDelims delims t' + + +-- | Try to read/parse a matrix. +readMatrix :: Coordinate r => Text -> Either Text (Matrix 3 3 r) +readMatrix = runParser pMatrix + +-- | Try to read/parse a Rectangle +readRectangle :: Coordinate r => Text -> Either Text (Rectangle () r) +readRectangle = runParser pRectangle + +----------------------------------------------------------------------- +-- * The parsers themselves + +-- | Parse an operation +pOperation :: forall r. Coordinate r => Parser (Operation r) +pOperation = pChoice [ MoveTo <$> pPoint *>> 'm' + , LineTo <$> pPoint *>> 'l' + , Ellipse <$> pMatrix *>> 'e' + , ArcTo <$> pMatrix <*> pPoint' *>> 'a' + , Spline <$> pPoint `pSepBy` pWhiteSpace *>> 'c' + , ClosedSpline <$> pPoint `pSepBy` pWhiteSpace *>> 'u' + , pChar 'h' $> ClosePath + , QCurveTo <$> pPoint <*> pPoint' *>> 'q' + , CurveTo <$> pPoint <*> pPoint' <*> pPoint' *>> 'c' + , Spline <$> pPoint `pSepBy` pWhiteSpace *>> 's' + ] + where + pPoint' = pWhiteSpace *> pPoint + p *>> c = p <*>< pWhiteSpace ***> pChar c + +-- * Parse a Point +pPoint :: Coordinate r => Parser (Point 2 r) +pPoint = Point2 <$> pCoordinate <* pWhiteSpace <*> pCoordinate + +-- * Parse a single coordinate. +pCoordinate :: Coordinate r => Parser r +pCoordinate = fromSeq <$> pInteger <*> pDecimal + where + pDecimal = pMaybe (pChar '.' *> pPaddedNatural) + + +-- | Parser for a rectangle +pRectangle :: Coordinate r => Parser (Rectangle () r) +pRectangle = (\p q -> box (ext p) (ext q)) <$> pPoint + <* pWhiteSpace + <*> pPoint + +-- | Parser for a matrix. +pMatrix :: Coordinate r => Parser (Matrix 3 3 r) +pMatrix = (\a b -> mkMatrix (a:b)) <$> pCoordinate + <*> pCount 5 (pWhiteSpace *> pCoordinate) + + +-- | Generate a matrix from a list of 6 coordinates. +mkMatrix :: Coordinate r => [r] -> Matrix 3 3 r +mkMatrix [a,b,c,d,e,f] = Matrix $ Vector3 (Vector3 a c e) + (Vector3 b d f) + (Vector3 0 0 1) + -- We need the matrix in the following order: + -- 012 + -- 345 + -- + -- But ipe uses the following order: + -- 024 + -- 135 +mkMatrix _ = error "mkMatrix: need exactly 6 arguments" diff --git a/src/Ipe/Reader.hs b/src/Ipe/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Reader.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ipe.Reader + ( -- * Reading ipe Files + readRawIpeFile + , readIpeFile + , readSinglePageFile + , readSinglePageFileThrow + , ConversionError + -- * Readiing ipe style files + , readIpeStylesheet + , addStyleSheetFrom + + -- * Reading XML directly + , fromIpeXML + , readXML + + -- * Read classes + , IpeReadText(..) + , IpeRead(..) + , IpeReadAttr(..) + + + -- * Some low level implementation functions + , ipeReadTextWith + , ipeReadObject + , ipeReadAttrs + , ipeReadRec + + , Coordinate(..) + ) where + +import Control.Applicative ((<|>)) +import Control.Lens hiding (Const, rmap) +import Control.Monad ((<=<)) +import Data.Bifunctor +import qualified Data.ByteString as B +import Data.Colour.SRGB (RGB(..)) +import Data.Either (rights) +import Data.Ext +import Data.Geometry hiding (head) +import Data.Geometry.BezierSpline +import Data.Geometry.Box +import Data.Geometry.Ellipse (ellipseMatrix) +import qualified Data.Geometry.Matrix as Matrix +import Ipe.Attributes +import Ipe.Color (IpeColor(..)) +import Ipe.Matrix +import Ipe.ParserPrimitives (pInteger, pWhiteSpace) +import Ipe.Path +import Ipe.PathParser +import Ipe.Types +import Ipe.Value + + +import qualified Data.Geometry.Polygon as Polygon +import qualified Data.LSeq as LSeq +import qualified Data.List as L +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Proxy +import Data.Singletons +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Traversable as Tr +import Data.Vinyl hiding (Label) +import Data.Vinyl.Functor +import Data.Vinyl.TypeLevel +import Text.XML.Expat.Tree + + +-------------------------------------------------------------------------------- + +type ConversionError = Text + + +-- | Given a file path, tries to read an ipe file +readRawIpeFile :: (Coordinate r, Eq r) + => FilePath -> IO (Either ConversionError (IpeFile r)) +readRawIpeFile = fmap fromIpeXML . B.readFile + + +-- | Given a file path, tries to read an ipe file. +-- +-- This function applies all matrices to objects. +readIpeFile :: (Coordinate r, Eq r) + => FilePath -> IO (Either ConversionError (IpeFile r)) +readIpeFile = fmap (second applyMatrices) . readRawIpeFile + + +-- | Since most Ipe file contain only one page, we provide a shortcut for that +-- as well. +-- +-- This function applies all matrices, and it makes sure there is at +-- least one layer and view in the page. +-- +readSinglePageFile :: (Coordinate r, Eq r) + => FilePath -> IO (Either ConversionError (IpePage r)) +readSinglePageFile = fmap (fmap f) . readIpeFile + where + f :: IpeFile r -> IpePage r + f i = withDefaults . NonEmpty.head $ i^.pages + +-- | Tries to read a single page file, throws an error when this +-- fails. See 'readSinglePageFile' for further details. +readSinglePageFileThrow :: (Coordinate r, Eq r) => FilePath -> IO (IpePage r) +readSinglePageFileThrow fp = readSinglePageFile fp >>= \case + Left err -> fail (show err) + Right p -> pure p + +-- | Given a Bytestring, try to parse the bytestring into anything that is +-- IpeReadable, i.e. any of the Ipe elements. +fromIpeXML :: IpeRead (t r) => B.ByteString -> Either ConversionError (t r) +fromIpeXML b = readXML b >>= ipeRead + +-- | Reads the data from a Bytestring into a proper Node +readXML :: B.ByteString -> Either ConversionError (Node Text Text) +readXML = first (T.pack . show) . parse' defaultParseOptions + +-------------------------------------------------------------------------------- + +-- | Reading an ipe elemtn from a Text value +class IpeReadText t where + ipeReadText :: Text -> Either ConversionError t + +-- | Reading an ipe lement from Xml +class IpeRead t where + ipeRead :: Node Text Text -> Either ConversionError t + +-------------------------------------------------------------------------------- +-- ReadText instances + +instance IpeReadText Text where + ipeReadText = Right + +instance IpeReadText Int where + ipeReadText = fmap fromInteger . runParser pInteger + +instance Coordinate r => IpeReadText (Point 2 r) where + ipeReadText = readPoint + +instance Coordinate r => IpeReadText (Matrix.Matrix 3 3 r) where + ipeReadText = readMatrix + +instance IpeReadText LayerName where + ipeReadText = Right . LayerName + +instance IpeReadText PinType where + ipeReadText "yes" = Right Yes + ipeReadText "h" = Right Horizontal + ipeReadText "v" = Right Vertical + ipeReadText "" = Right No + ipeReadText _ = Left "invalid PinType" + +instance IpeReadText TransformationTypes where + ipeReadText "affine" = Right Affine + ipeReadText "rigid" = Right Rigid + ipeReadText "translations" = Right Translations + ipeReadText _ = Left "invalid TransformationType" + +instance IpeReadText FillType where + ipeReadText "wind" = Right Wind + ipeReadText "eofill" = Right EOFill + ipeReadText _ = Left "invalid FillType" + +instance Coordinate r => IpeReadText (IpeArrow r) where + ipeReadText t = case T.split (== '/') t of + [n,s] -> IpeArrow <$> pure n <*> ipeReadText s + _ -> Left "ipeArrow: name contains not exactly 1 / " + +instance Coordinate r => IpeReadText (IpeDash r) where + ipeReadText t = Right . DashNamed $ t + -- TODO: Implement proper parsing here + + +ipeReadTextWith :: (Text -> Either t v) -> Text -> Either ConversionError (IpeValue v) +ipeReadTextWith f t = case f t of + Right v -> Right (Valued v) + Left _ -> Right (Named t) + + +instance Coordinate r => IpeReadText (Rectangle () r) where + ipeReadText = readRectangle + +instance Coordinate r => IpeReadText (RGB r) where + ipeReadText = runParser (pRGB <|> pGrey) + where + pGrey = (\c -> RGB c c c) <$> pCoordinate + pRGB = RGB <$> pCoordinate <* pWhiteSpace + <*> pCoordinate <* pWhiteSpace + <*> pCoordinate + +instance Coordinate r => IpeReadText (IpeColor r) where + ipeReadText = fmap IpeColor . ipeReadTextWith ipeReadText + +instance Coordinate r => IpeReadText (IpePen r) where + ipeReadText = fmap IpePen . ipeReadTextWith readCoordinate + +instance Coordinate r => IpeReadText (IpeSize r) where + ipeReadText = fmap IpeSize . ipeReadTextWith readCoordinate + + +instance Coordinate r => IpeReadText [Operation r] where + ipeReadText = readPathOperations + +instance (Coordinate r, Fractional r, Eq r) => IpeReadText (NonEmpty.NonEmpty (PathSegment r)) where + ipeReadText t = ipeReadText t >>= fromOpsN + where + fromOpsN xs = case fromOps xs of + Left l -> Left l + Right [] -> Left "No path segments produced" + Right (p:ps) -> Right $ p NonEmpty.:| ps + + fromOps [] = Right [] + fromOps [Ellipse m] = Right [EllipseSegment . view (from ellipseMatrix) $ m] + fromOps (MoveTo p:xs) = fromOps' p xs + fromOps _ = Left "Path should start with a move to" + + fromOps' _ [] = Left "Found only a MoveTo operation" + fromOps' s (LineTo q:ops) = let (ls,xs) = span' _LineTo ops + pts = map ext $ s:q:mapMaybe (^?_LineTo) ls + poly = Polygon.unsafeFromPoints . dropRepeats $ pts + pl = fromPointsUnsafe pts + in case xs of + (ClosePath : xs') -> PolygonPath poly <<| xs' + _ -> PolyLineSegment pl <<| xs + + fromOps' s [Spline [a, b]] = Right [QuadraticBezierSegment $ Bezier2 s a b] + fromOps' s [Spline [a, b, c]] = Right [CubicBezierSegment $ Bezier3 s a b c] + fromOps' s [Spline ps] = Right $ map CubicBezierSegment $ splineToCubicBeziers $ s : ps + -- these will not occur anymore with recent ipe files + fromOps' s [QCurveTo a b] = Right [QuadraticBezierSegment $ Bezier2 s a b] + fromOps' s [CurveTo a b c] = Right [CubicBezierSegment $ Bezier3 s a b c] + fromOps' _ _ = Left "fromOpts': rest not implemented yet." + + span' pr = L.span (not . isn't pr) + + x <<| xs = (x:) <$> fromOps xs + + +-- | Read a list of control points of a uniform cubic B-spline and conver it +-- to cubic Bezier pieces +splineToCubicBeziers :: Fractional r => [Point 2 r] -> [BezierSpline 3 2 r] +splineToCubicBeziers [a, b, c, d] = [Bezier3 a b c d] +splineToCubicBeziers (a : b : c : d : rest) = + let p = b .+^ (c .-. b) ^/ 2 + q = c .+^ (d .-. c) ^/ 3 + r = p .+^ (q .-. p) ^/ 2 + in (Bezier3 a b p r) : splineToCubicBeziers (r : q : d : rest) +splineToCubicBeziers _ = error "splineToCubicBeziers needs at least four points" + + +dropRepeats :: Eq a => [a] -> [a] +dropRepeats = map head . L.group + +instance (Coordinate r, Fractional r, Eq r) => IpeReadText (Path r) where + ipeReadText = fmap (Path . LSeq.fromNonEmpty) . ipeReadText + +-------------------------------------------------------------------------------- +-- Reading attributes + +-- | Basically IpeReadText for attributes. This class is not really meant to be +-- implemented directly. Just define an IpeReadText instance for the type +-- (Apply f at), then the generic instance below takes care of looking up the +-- name of the attribute, and calling the right ipeReadText value. This class +-- is just so that reifyConstraint in `ipeReadRec` can select the right +-- typeclass when building the rec. +class IpeReadAttr t where + ipeReadAttr :: Text -> Node Text Text -> Either ConversionError t + +instance IpeReadText (Apply f at) => IpeReadAttr (Attr f at) where + ipeReadAttr n (Element _ ats _) = GAttr <$> Tr.mapM ipeReadText (lookup n ats) + ipeReadAttr _ _ = Left "IpeReadAttr: Element expected, Text found" + +-- | Combination of zipRecWith and traverse +zipTraverseWith :: forall f g h i (rs :: [AttributeUniverse]). Applicative h + => (forall (x :: AttributeUniverse). f x -> g x -> h (i x)) + -> Rec f rs -> Rec g rs -> h (Rec i rs) +zipTraverseWith _ RNil RNil = pure RNil +zipTraverseWith f (x :& xs) (y :& ys) = (:&) <$> f x y <*> zipTraverseWith f xs ys + +-- | Reading the Attributes into a Rec (Attr f), all based on the types of f +-- (the type family mapping labels to types), and a list of labels (ats). +ipeReadRec :: forall f ats. + ( RecApplicative ats + , ReifyConstraint IpeReadAttr (Attr f) ats + , RecAll (Attr f) ats IpeReadAttr + , AllConstrained IpeAttrName ats + ) + => Proxy f -> Proxy ats + -> Node Text Text + -> Either ConversionError (Rec (Attr f) ats) +ipeReadRec _ _ x = zipTraverseWith f (writeAttrNames r) r' + where + r = rpure (GAttr Nothing) + r' = reifyConstraint @IpeReadAttr r + + + f :: forall at. + Const Text at + -> (Dict IpeReadAttr :. Attr f) at + -> Either ConversionError (Attr f at) + f (Const n) (Compose (Dict _)) = ipeReadAttr n x + + +-- | Reader for records. Given a proxy of some ipe type i, and a proxy of an +-- coordinate type r, read the IpeAttributes for i from the xml node. +ipeReadAttrs :: forall proxy proxy' i r f ats. + ( f ~ AttrMapSym1 r, ats ~ AttributesOf i + , ReifyConstraint IpeReadAttr (Attr f) ats + , RecApplicative ats + , RecAll (Attr f) ats IpeReadAttr + , AllConstrained IpeAttrName ats + ) + => proxy i -> proxy' r + -> Node Text Text + -> Either ConversionError (IpeAttributes i r) +ipeReadAttrs _ _ = fmap Attrs . ipeReadRec (Proxy :: Proxy f) (Proxy :: Proxy ats) + + +-- testSym :: B.ByteString +-- testSym = "" + + + + +-- readAttrsFromXML :: B.ByteString -> Either + +-- readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double) +-- readSymAttrs = readXML testSym +-- >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double) + + + + + +-- | If we can ipeRead an ipe element, and we can ipeReadAttrs its attributes +-- we can properly read an ipe object using ipeReadObject +ipeReadObject :: ( IpeRead (i r) + , f ~ AttrMapSym1 r, ats ~ AttributesOf i + , RecApplicative ats + , ReifyConstraint IpeReadAttr (Attr f) ats + , RecAll (Attr f) ats IpeReadAttr + , AllConstrained IpeAttrName ats + ) + => Proxy i -> proxy r -> Node Text Text + -> Either ConversionError (i r :+ IpeAttributes i r) +ipeReadObject prI prR xml = (:+) <$> ipeRead xml <*> ipeReadAttrs prI prR xml + + +-------------------------------------------------------------------------------- +-- | Ipe read instances + +instance Coordinate r => IpeRead (IpeSymbol r) where + ipeRead (Element "use" ats _) = case lookup "pos" ats of + Nothing -> Left "symbol without position" + Just ps -> flip Symbol name <$> ipeReadText ps + where + name = fromMaybe "mark/disk(sx)" $ lookup "name" ats + ipeRead _ = Left "symbol element expected, text found" + +-- | Given a list of Nodes, try to parse all of them as a big text. If we +-- encounter anything else then text, the parsing fails. +allText :: [Node Text Text] -> Either ConversionError Text +allText = fmap T.unlines . mapM unT + where + unT (Text t) = Right t + unT _ = Left "allText: Expected Text, found an Element" + +instance (Coordinate r, Fractional r, Eq r) => IpeRead (Path r) where + ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText + ipeRead _ = Left "path: expected element, found text" + + +lookup' :: Text -> [(Text,a)] -> Either ConversionError a +lookup' k = maybe (Left $ "lookup' " <> k <> " not found") Right . lookup k + +instance Coordinate r => IpeRead (TextLabel r) where + ipeRead (Element "text" ats chs) + | lookup "type" ats == Just "label" = Label + <$> allText chs + <*> (lookup' "pos" ats >>= ipeReadText) + | otherwise = Left "Not a Text label" + ipeRead _ = Left "textlabel: Expected element, found text" + + + +instance Coordinate r => IpeRead (MiniPage r) where + ipeRead (Element "text" ats chs) + | lookup "type" ats == Just "minipage" = MiniPage + <$> allText chs + <*> (lookup' "pos" ats >>= ipeReadText) + <*> (lookup' "width" ats >>= readCoordinate) + | otherwise = Left "Not a MiniPage" + ipeRead _ = Left "MiniPage: Expected element, found text" + + +instance Coordinate r => IpeRead (Image r) where + ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText) + ipeRead _ = Left "Image: Element expected, text found" + +instance (Coordinate r, Fractional r, Eq r) => IpeRead (IpeObject r) where + ipeRead x = firstRight [ IpeUse <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x + , IpePath <$> ipeReadObject (Proxy :: Proxy Path) r x + , IpeGroup <$> ipeReadObject (Proxy :: Proxy Group) r x + , IpeTextLabel <$> ipeReadObject (Proxy :: Proxy TextLabel) r x + , IpeMiniPage <$> ipeReadObject (Proxy :: Proxy MiniPage) r x + , IpeImage <$> ipeReadObject (Proxy :: Proxy Image) r x + ] + where + r = Proxy :: Proxy r + +firstRight :: [Either ConversionError a] -> Either ConversionError a +firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right) + + +instance (Coordinate r, Eq r) => IpeRead (Group r) where + ipeRead (Element "group" _ chs) = Right . Group . rights . map ipeRead $ chs + ipeRead _ = Left "ipeRead Group: expected Element, found Text" + + +instance IpeRead LayerName where + ipeRead (Element "layer" ats _) = LayerName <$> lookup' "name" ats + ipeRead _ = Left "layer: Expected element, found text" + +instance IpeRead View where + ipeRead (Element "view" ats _) = (\lrs a -> View (map LayerName $ T.words lrs) a) + <$> lookup' "layers" ats + <*> (lookup' "active" ats >>= ipeReadText) + ipeRead _ = Left "View Expected element, found text" + + +-- TODO: this instance throws away all of our error collecting (and is pretty +-- slow/stupid since it tries parsing all children with all parsers) +instance (Coordinate r, Eq r) => IpeRead (IpePage r) where + ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs) + ipeRead _ = Left "page: Element expected, text found" + -- withDef :: b -> Either a b -> Either c b + -- withDef d = either (const $ Right d) Right + + -- readLayers = withDef ["alpha"] . readAll + -- readViews = withDef [] . readAll + -- readObjects = withDef [] . readAll + +-- | try reading everything as an a. Throw away whatever fails. +readAll :: IpeRead a => [Node Text Text] -> [a] +readAll = rights . map ipeRead + + +instance (Coordinate r, Eq r) => IpeRead (IpeFile r) where + ipeRead (Element "ipe" _ chs) = case readAll chs of + [] -> Left "Ipe: no pages found" + pgs -> Right $ IpeFile Nothing [] (NonEmpty.fromList pgs) + ipeRead _ = Left "Ipe: Element expected, text found" + + +instance IpeRead IpeStyle where + ipeRead = \case + xml@(Element "ipestyle" ats _) -> Right $ IpeStyle (lookup "name" ats) xml + _ -> Left "ipeStyle exptected. Something else found" + + +-- | Reads an Ipe stylesheet from Disk. +readIpeStylesheet :: FilePath -> IO (Either ConversionError IpeStyle) +readIpeStylesheet = fmap (ipeRead <=< readXML) . B.readFile + +-- | Given a path to a stylesheet, add it to the ipe file with the +-- highest priority. Throws an error when this fails. +addStyleSheetFrom :: FilePath -> IpeFile r -> IO (IpeFile r) +addStyleSheetFrom fp f = readIpeStylesheet fp >>= \case + Left err -> fail (show err) + Right s -> pure $ addStyleSheet s f + +-------------------------------------------------------------------------------- diff --git a/src/Ipe/Types.hs b/src/Ipe/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Types.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Types +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type modeling the various elements in Ipe files. +-- +-------------------------------------------------------------------------------- +module Ipe.Types( + -- * Ipe Files + IpeFile(IpeFile), preamble, styles, pages + , ipeFile, singlePageFile, singlePageFromContent + -- * Ipe Pages + , IpePage(IpePage), layers, views, content + , emptyPage, fromContent + , onLayer, contentInView + , withDefaults + -- * Content: Ipe Objects + , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath + , IpeObject' + , ipeObject' + , ToObject(..) + -- ** Specific Ipe-Objects + , Path(Path), pathSegments + , PathSegment(..) + , IpeSymbol(Symbol), symbolPoint, symbolName + , Group(Group), groupItems + , TextLabel(..) + , MiniPage(..), width + , Image(Image), imageData, rect + , IpeBitmap + -- * Attributes + , IpeAttributes + , Attributes', AttributesOf, AttrMap, AttrMapSym1 + , attributes, traverseIpeAttrs + , commonAttributes + -- * Layers and Views + , LayerName(LayerName), layerName + , View(View), layerNames, activeLayer + -- * Styles and Preamble + , addStyleSheet + , IpeStyle(IpeStyle), styleName, styleData + , basicIpeStyle + , IpePreamble(IpePreamble), encoding, preambleData + -- + -- , flattenGroups + ) where + + +import Control.Lens hiding (views) +import Ipe.Attributes hiding (Matrix) +import Ipe.Content +import Ipe.Layer +import Ipe.Literal +import qualified Data.List.NonEmpty as NE +import Data.Maybe (mapMaybe) +import Data.Semigroup (Endo) +import qualified Data.Set as Set +import Data.Text (Text) +import Text.XML.Expat.Tree (Node) + + +-------------------------------------------------------------------------------- + + +-- | The definition of a view +-- make active layer into an index ? +data View = View { _layerNames :: [LayerName] + , _activeLayer :: LayerName + } + deriving (Eq, Ord, Show) +makeLenses ''View + +-- instance Default + + +-- | for now we pretty much ignore these +data IpeStyle = IpeStyle { _styleName :: Maybe Text + , _styleData :: Node Text Text + } + deriving (Eq,Show) +makeLenses ''IpeStyle + + +basicIpeStyle :: IpeStyle +basicIpeStyle = IpeStyle (Just "basic") (xmlLiteral [litFile|resources/basic.isy|]) + + + +-- | The maybe string is the encoding +data IpePreamble = IpePreamble { _encoding :: Maybe Text + , _preambleData :: Text + } + deriving (Eq,Read,Show,Ord) +makeLenses ''IpePreamble + +type IpeBitmap = Text + + + +-------------------------------------------------------------------------------- +-- Ipe Pages + +-- | An IpePage is essentially a Group, together with a list of layers and a +-- list of views. +data IpePage r = IpePage { _layers :: [LayerName] + , _views :: [View] + , _content :: [IpeObject r] + } + deriving (Eq,Show) +makeLenses ''IpePage + +-- | Creates an empty page with one layer and view. +emptyPage :: IpePage r +emptyPage = fromContent [] + +-- | Creates a simple page with a single view. +fromContent :: [IpeObject r] -> IpePage r +fromContent obs = IpePage layers' [View layers' a] obs + where + layers' = Set.toList . Set.fromList $ a : mapMaybe (^.commonAttributes.ixAttr SLayer) obs + a = "alpha" + +-- | Makes sure that the page has at least one layer and at least one +-- view, essentially matching the behaviour of ipe. In particular, +-- +-- - if the page does not have any layers, it creates a layer named "alpha", and +-- - if the page does not have any views, it creates a view in which all layers are visible. +-- +withDefaults :: IpePage r -> IpePage r +withDefaults = addView . addLayer + where + whenNull ys = \case + [] -> ys + xs -> xs + addLayer p = p&layers %~ whenNull ["alpha"] + addView p = p&views %~ whenNull [View (p^.layers) (head $ p^.layers)] + -- note that the head is save, since we just made sure + -- with 'addLayer' that there is at least one layer + +-- | This allows you to filter the objects on some layer. +-- +-- >>> let page = IpePage [] [] [] +-- >>> page^..content.onLayer "myLayer" +-- [] +onLayer :: LayerName -> Getting (Endo [IpeObject r]) [IpeObject r] (IpeObject r) +onLayer n = folded.filtered (\o -> o^?commonAttributes._Attr SLayer == Just n) + +-- | Gets all objects that are visible in the given view. +-- +-- Note that views are indexed starting from 0. If the page does not +-- have any explicit view definitions, this function returns an empty +-- list. +-- +-- >>> let page = IpePage [] [] [] +-- >>> page^.contentInView 0 +-- [] +contentInView :: Word -> Getter (IpePage r) [IpeObject r] +contentInView (fromIntegral -> i) = to inView' + where + inView' p = let lrs = Set.fromList . concatMap (^.layerNames) $ p^..views.ix i + in p^..content.folded.filtered (inVisibleLayer lrs) + + inVisibleLayer lrs o = maybe False (`Set.member` lrs) $ o^?commonAttributes._Attr SLayer + +-------------------------------------------------------------------------------- + +-- | A complete ipe file +data IpeFile r = IpeFile { _preamble :: Maybe IpePreamble + , _styles :: [IpeStyle] + , _pages :: NE.NonEmpty (IpePage r) + } + deriving (Eq,Show) +makeLenses ''IpeFile + + +-- | Convenience constructor for creating an ipe file without preamble +-- and with the default stylesheet. +ipeFile :: NE.NonEmpty (IpePage r) -> IpeFile r +ipeFile = IpeFile Nothing [basicIpeStyle] + +-- | Convenience function to construct an ipe file consisting of a single page. +singlePageFile :: IpePage r -> IpeFile r +singlePageFile = ipeFile . (NE.:| []) + +-- | Create a single page ipe file from a list of IpeObjects +singlePageFromContent :: [IpeObject r] -> IpeFile r +singlePageFromContent = singlePageFile . fromContent + + +-- | Adds a stylesheet to the ipe file. This will be the first +-- stylesheet, i.e. it has priority over all previously imported stylesheets. +addStyleSheet :: IpeStyle -> IpeFile r -> IpeFile r +addStyleSheet s f = f&styles %~ (s:) diff --git a/src/Ipe/Value.hs b/src/Ipe/Value.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Value.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Value +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing values in ipe. +-- +-------------------------------------------------------------------------------- +module Ipe.Value where + +import GHC.Exts +import Data.Text + +-------------------------------------------------------------------------------- + +-- | Many types either consist of a symbolc value, or a value of type v +data IpeValue v = Named Text | Valued v + deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable) + +instance IsString (IpeValue v) where + fromString = Named . fromString diff --git a/src/Ipe/Writer.hs b/src/Ipe/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Ipe/Writer.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Ipe.Writer +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- Description : Converting data types into IpeTypes +-- +-------------------------------------------------------------------------------- +module Ipe.Writer( + writeIpeFile, writeIpeFile', writeIpePage + , toIpeXML + , printAsIpeSelection, toIpeSelectionXML + + , IpeWrite(..) + , IpeWriteText(..) + + , ipeWriteAttrs, writeAttrValues + ) where + +import Control.Lens (view, (&), (.~), (^.), (^..)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.Colour.SRGB (RGB (..)) +import Data.Ext +import Data.Fixed +import qualified Data.Foldable as F +import Data.Geometry.BezierSpline +import Data.Geometry.Box +import Data.Geometry.Ellipse (ellipseMatrix) +import Ipe.Attributes +import qualified Ipe.Attributes as IA +import Ipe.Color (IpeColor (..)) +import Ipe.Path +import Ipe.Types +import Ipe.Value +import Data.Geometry.LineSegment +import qualified Data.Geometry.Matrix as Matrix +import Data.Geometry.Point +import Data.Geometry.PolyLine +import Data.Geometry.Polygon (Polygon, holeList, outerBoundary, + outerBoundaryVector) +import Data.Geometry.Vector +import qualified Data.LSeq as LSeq +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Ratio +import Data.RealNumber.Rational +import Data.Singletons +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vinyl hiding (Label) +import Data.Vinyl.Functor +import Data.Vinyl.TypeLevel +import System.IO (hPutStrLn, stderr) +import Text.XML.Expat.Format (format') +import Text.XML.Expat.Tree + +-------------------------------------------------------------------------------- + +-- | Given a prism to convert something of type g into an ipe file, a file path, +-- and a g. Convert the geometry and write it to file. + +-- writeIpe :: ( RecAll (Page r) gs IpeWrite +-- , IpeWriteText r +-- ) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO () +-- writeIpe p fp g = writeIpeFile (p # g) fp + +-- | Write an IpeFiele to file. +writeIpeFile :: IpeWriteText r => FilePath -> IpeFile r -> IO () +writeIpeFile = flip writeIpeFile' + +-- | Creates a single page ipe file with the given page +writeIpePage :: IpeWriteText r => FilePath -> IpePage r -> IO () +writeIpePage fp = writeIpeFile fp . singlePageFile + + +-- | Convert the input to ipeXml, and prints it to standard out in such a way +-- that the copied text can be pasted into ipe as a geometry object. +printAsIpeSelection :: IpeWrite t => t -> IO () +printAsIpeSelection = C.putStrLn . fromMaybe "" . toIpeSelectionXML + +-- | Convert input into an ipe selection. +toIpeSelectionXML :: IpeWrite t => t -> Maybe B.ByteString +toIpeSelectionXML = fmap (format' . ipeSelection) . ipeWrite + where + ipeSelection x = Element "ipeselection" [] [x] + + +-- | Convert to Ipe xml +toIpeXML :: IpeWrite t => t -> Maybe B.ByteString +toIpeXML = fmap format' . ipeWrite + + +-- | Convert to ipe XML and write the output to a file. +writeIpeFile' :: IpeWrite t => t -> FilePath -> IO () +writeIpeFile' i fp = maybe err (B.writeFile fp) . toIpeXML $ i + where + err = hPutStrLn stderr $ + "writeIpeFile: error converting to xml. File '" <> fp <> "'not written" + +-------------------------------------------------------------------------------- + +-- | For types that can produce a text value +class IpeWriteText t where + ipeWriteText :: t -> Maybe Text + +-- | Types that correspond to an XML Element. All instances should produce an +-- Element. If the type should produce a Node with the Text constructor, use +-- the `IpeWriteText` typeclass instead. +class IpeWrite t where + ipeWrite :: t -> Maybe (Node Text Text) + +instance IpeWrite t => IpeWrite [t] where + ipeWrite gs = case mapMaybe ipeWrite gs of + [] -> Nothing + ns -> (Just $ Element "group" [] ns) + +instance IpeWrite t => IpeWrite (NonEmpty t) where + ipeWrite = ipeWrite . F.toList + +instance (IpeWrite l, IpeWrite r) => IpeWrite (Either l r) where + ipeWrite = either ipeWrite ipeWrite + +instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where + ipeWriteText att = _getAttr att >>= ipeWriteText + +instance (IpeWriteText l, IpeWriteText r) => IpeWriteText (Either l r) where + ipeWriteText = either ipeWriteText ipeWriteText + + +-- | Functon to write all attributes in a Rec +ipeWriteAttrs :: ( RecordToList rs, RMap rs + , ReifyConstraint IpeWriteText (Attr f) rs + , AllConstrained IpeAttrName rs + , RecAll (Attr f) rs IpeWriteText + ) => IA.Attributes f rs -> [(Text,Text)] +ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames r) + (writeAttrValues r) + where + f (Const n) (Const mv) = Const $ (n,) <$> mv + +-- | Writing the attribute values +writeAttrValues :: ( RMap rs, ReifyConstraint IpeWriteText f rs + , RecAll f rs IpeWriteText) + => Rec f rs -> Rec (Const (Maybe Text)) rs +writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x) + . reifyConstraint @IpeWriteText + + +instance IpeWriteText Text where + ipeWriteText = Just + +instance IpeWriteText String where + ipeWriteText = ipeWriteText . Text.pack + + +-- | Add attributes to a node +addAtts :: Node Text Text -> [(Text,Text)] -> Node Text Text +n `addAtts` ats = n { eAttributes = ats ++ eAttributes n } + +-- | Same as `addAtts` but then for a Maybe node +mAddAtts :: Maybe (Node Text Text) -> [(Text, Text)] -> Maybe (Node Text Text) +mn `mAddAtts` ats = fmap (`addAtts` ats) mn + + +-------------------------------------------------------------------------------- + +instance IpeWriteText Double where + ipeWriteText = writeByShow + +instance IpeWriteText Float where + ipeWriteText = writeByShow + +instance IpeWriteText Int where + ipeWriteText = writeByShow + +instance IpeWriteText Integer where + ipeWriteText = writeByShow + +instance IpeWriteText (RealNumber p) where + ipeWriteText = ipeWriteText . realToFrac @(RealNumber p) @Rational + +instance HasResolution p => IpeWriteText (Fixed p) where + ipeWriteText = writeByShow + +-- | This instance converts the ratio to a Pico, and then displays that. +instance Integral a => IpeWriteText (Ratio a) where + ipeWriteText = ipeWriteText . f . fromRational . toRational + where + f :: Pico -> Pico + f = id + +writeByShow :: Show t => t -> Maybe Text +writeByShow = ipeWriteText . Text.pack . show + +unwords' :: [Maybe Text] -> Maybe Text +unwords' = fmap Text.unwords . sequence + +unlines' :: [Maybe Text] -> Maybe Text +unlines' = fmap Text.unlines . sequence + + +instance IpeWriteText r => IpeWriteText (Point 2 r) where + ipeWriteText (Point2 x y) = unwords' [ipeWriteText x, ipeWriteText y] + + +-------------------------------------------------------------------------------- + +instance IpeWriteText v => IpeWriteText (IpeValue v) where + ipeWriteText (Named t) = ipeWriteText t + ipeWriteText (Valued v) = ipeWriteText v + +instance IpeWriteText TransformationTypes where + ipeWriteText Affine = Just "affine" + ipeWriteText Rigid = Just "rigid" + ipeWriteText Translations = Just "translations" + +instance IpeWriteText PinType where + ipeWriteText No = Nothing + ipeWriteText Yes = Just "yes" + ipeWriteText Horizontal = Just "h" + ipeWriteText Vertical = Just "v" + +instance IpeWriteText r => IpeWriteText (RGB r) where + ipeWriteText (RGB r g b) = unwords' . map ipeWriteText $ [r,g,b] + +deriving instance IpeWriteText r => IpeWriteText (IpeSize r) +deriving instance IpeWriteText r => IpeWriteText (IpePen r) +deriving instance IpeWriteText r => IpeWriteText (IpeColor r) + +instance IpeWriteText r => IpeWriteText (IpeDash r) where + ipeWriteText (DashNamed t) = Just t + ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "[" + , Text.intercalate " " ts + , "] ", t ]) + <$> mapM ipeWriteText xs + <*> ipeWriteText x + +instance IpeWriteText FillType where + ipeWriteText Wind = Just "wind" + ipeWriteText EOFill = Just "eofill" + +instance IpeWriteText r => IpeWriteText (IpeArrow r) where + ipeWriteText (IpeArrow n s) = (\n' s' -> n' <> "/" <> s') <$> ipeWriteText n + <*> ipeWriteText s + +instance IpeWriteText r => IpeWriteText (Path r) where + ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . view pathSegments + where + concat' = F.foldr1 (\t t' -> t <> "\n" <> t') + + +-------------------------------------------------------------------------------- +instance IpeWriteText r => IpeWrite (IpeSymbol r) where + ipeWrite (Symbol p n) = f <$> ipeWriteText p + where + f ps = Element "use" [ ("pos", ps) + , ("name", n) + ] [] + +-------------------------------------------------------------------------------- + +instance IpeWriteText r => IpeWriteText (Matrix.Matrix 3 3 r) where + ipeWriteText (Matrix.Matrix m) = unwords' [a,b,c,d,e,f] + where + (Vector3 r1 r2 _) = m + + (Vector3 a c e) = ipeWriteText <$> r1 + (Vector3 b d f) = ipeWriteText <$> r2 + -- TODO: The third row should be (0,0,1) I guess. + + +instance IpeWriteText r => IpeWriteText (Operation r) where + ipeWriteText (MoveTo p) = unwords' [ ipeWriteText p, Just "m"] + ipeWriteText (LineTo p) = unwords' [ ipeWriteText p, Just "l"] + ipeWriteText (CurveTo p q r) = unwords' [ ipeWriteText p + , ipeWriteText q + , ipeWriteText r, Just "c"] + ipeWriteText (QCurveTo p q) = unwords' [ ipeWriteText p + , ipeWriteText q, Just "q"] + ipeWriteText (Ellipse m) = unwords' [ ipeWriteText m, Just "e"] + ipeWriteText (ArcTo m p) = unwords' [ ipeWriteText m + , ipeWriteText p, Just "a"] + ipeWriteText (Spline pts) = unlines' $ map ipeWriteText pts <> [Just "s"] + ipeWriteText (ClosedSpline pts) = unlines' $ map ipeWriteText pts <> [Just "u"] + ipeWriteText ClosePath = Just "h" + + +instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where + ipeWriteText pl = case pl^..points.traverse.core of + (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest + _ -> error "ipeWriteText. absurd. no vertices polyline" + -- the polyline type guarantees that there is at least one point + +instance IpeWriteText r => IpeWriteText (Polygon t () r) where + ipeWriteText pg = fmap mconcat . traverse f $ pg^.outerBoundary : holeList pg + where + f pg' = case pg'^..outerBoundaryVector.traverse.core of + (p : rest) -> unlines' . map ipeWriteText + $ MoveTo p : map LineTo rest ++ [ClosePath] + _ -> Nothing + -- TODO: We are not really guaranteed that there is at least one point, it would + -- be nice if the type could guarantee that. + +instance IpeWriteText r => IpeWriteText (BezierSpline 3 2 r) where + ipeWriteText (Bezier3 p q r s) = unlines' . map ipeWriteText $ [MoveTo p, CurveTo q r s] + +instance IpeWriteText r => IpeWriteText (PathSegment r) where + ipeWriteText (PolyLineSegment p) = ipeWriteText p + ipeWriteText (PolygonPath p) = ipeWriteText p + ipeWriteText (EllipseSegment e) = ipeWriteText $ Ellipse (e^.ellipseMatrix) + ipeWriteText (CubicBezierSegment b) = ipeWriteText b + ipeWriteText _ = error "ipeWriteText: PathSegment, not implemented yet." + +instance IpeWriteText r => IpeWrite (Path r) where + ipeWrite p = (\t -> Element "path" [] [Text t]) <$> ipeWriteText p + +-------------------------------------------------------------------------------- + + +instance (IpeWriteText r) => IpeWrite (Group r) where + ipeWrite (Group gs) = ipeWrite gs + + +instance ( AllConstrained IpeAttrName rs + , RecordToList rs, RMap rs + , ReifyConstraint IpeWriteText (Attr f) rs + , RecAll (Attr f) rs IpeWriteText + , IpeWrite g + ) => IpeWrite (g :+ IA.Attributes f rs) where + ipeWrite (g :+ ats) = ipeWrite g `mAddAtts` ipeWriteAttrs ats + + +instance IpeWriteText r => IpeWrite (MiniPage r) where + ipeWrite (MiniPage t p w) = (\pt wt -> + Element "text" [ ("pos", pt) + , ("type", "minipage") + , ("width", wt) + ] [Text t] + ) <$> ipeWriteText p + <*> ipeWriteText w + +instance IpeWriteText r => IpeWrite (Image r) where + ipeWrite (Image d (Box a b)) = (\dt p q -> + Element "image" [("rect", p <> " " <> q)] [Text dt] + ) + <$> ipeWriteText d + <*> ipeWriteText (a^.core.cwMin) + <*> ipeWriteText (b^.core.cwMax) + +-- TODO: Replace this one with s.t. that writes the actual image payload +instance IpeWriteText () where + ipeWriteText () = Nothing + +instance IpeWriteText r => IpeWrite (TextLabel r) where + ipeWrite (Label t p) = (\pt -> + Element "text" [("pos", pt) + ,("type", "label") + ] [Text t] + ) <$> ipeWriteText p + + +instance (IpeWriteText r) => IpeWrite (IpeObject r) where + ipeWrite (IpeGroup g) = ipeWrite g + ipeWrite (IpeImage i) = ipeWrite i + ipeWrite (IpeTextLabel l) = ipeWrite l + ipeWrite (IpeMiniPage m) = ipeWrite m + ipeWrite (IpeUse s) = ipeWrite s + ipeWrite (IpePath p) = ipeWrite p + +-------------------------------------------------------------------------------- + +deriving instance IpeWriteText LayerName + +instance IpeWrite LayerName where + ipeWrite (LayerName n) = Just $ Element "layer" [("name",n)] [] + +instance IpeWrite View where + ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls) + , ("active", act^.layerName) + ] [] + where + ls = Text.unwords . map (^.layerName) $ lrs + +instance (IpeWriteText r) => IpeWrite (IpePage r) where + ipeWrite (IpePage lrs vs objs) = Just . + Element "page" [] . catMaybes . concat $ + [ map ipeWrite lrs + , map ipeWrite vs + , map ipeWrite objs + ] + + +instance IpeWrite IpeStyle where + ipeWrite (IpeStyle _ xml) = Just xml + + +instance IpeWrite IpePreamble where + ipeWrite (IpePreamble _ latex) = Just $ Element "preamble" [] [Text latex] + -- TODO: I probably want to do something with the encoding .... + +instance (IpeWriteText r) => IpeWrite (IpeFile r) where + ipeWrite (IpeFile mp ss pgs) = Just $ Element "ipe" ipeAtts chs + where + ipeAtts = [("version","70005"),("creator", "HGeometry")] + chs = mconcat [ catMaybes [mp >>= ipeWrite] + , mapMaybe ipeWrite ss + , mapMaybe ipeWrite . F.toList $ pgs + ] + + + + +-------------------------------------------------------------------------------- + +instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where + ipeWrite p = ipeWrite path + where + path = fromPolyLine $ p & points.traverse.extra .~ () + -- TODO: Do something with the p's + +fromPolyLine :: PolyLine 2 () r -> Path r +fromPolyLine = Path . LSeq.fromNonEmpty . (:| []) . PolyLineSegment + + +instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where + ipeWrite (LineSegment' p q) = + ipeWrite . fromPolyLine . fromPointsUnsafe . map (extra .~ ()) $ [p,q] + + +instance IpeWrite () where + ipeWrite = const Nothing diff --git a/test/Data/Geometry/Ipe/ReaderSpec.hs b/test/Data/Geometry/Ipe/ReaderSpec.hs deleted file mode 100644 --- a/test/Data/Geometry/Ipe/ReaderSpec.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Data.Geometry.Ipe.ReaderSpec where - -import Test.Hspec -import Data.Ext -import Data.Geometry -import Data.Geometry.Ipe -import Data.Geometry.Ipe.Path -import Data.ByteString(ByteString) -import Data.Proxy - - --- | specializes to use Double as Numtype -fromIpeXML' :: IpeRead (t Double) => ByteString -> Either ConversionError (t Double) -fromIpeXML' = fromIpeXML - - -spec :: Spec -spec = do - describe "IpeReadText" $ do - it "parses a polyline into a Path" $ - ipeReadText "\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n" - `shouldBe` Right ops - describe "IpeReadAttrs" $ do - it "parses a symbols attributes" $ - (show $ readXML useTxt - >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)) - `shouldBe` - "Right (Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named \"black\"), NoAttr, NoAttr, Attr IpeSize (Named \"normal\")})" - describe "IpeRead" $ do - it "parses a Symbol" $ - fromIpeXML' useTxt - `shouldBe` Right useSym - -- it "parses a path" $ - -- (show $ fromIpeXML' - -- "" --- ) - -- `shouldBe` --- "Right (Path {_pathSegments = PolyLineSegment (PolyLine {_points = Seq2 (Point2 [128.0,656.0] :+ ()) (fromList [Point2 [224.0,768.0] :+ (),Point2 [304.0,624.0] :+ ()]) (Point2 [432.0,752.0] :+ ())}) :< fromList []})" - - - where - useTxt = "" - useSym = Symbol (Point2 320 736) "mark/disk(sx)" --- symAttrs = - - translatedUse = "" - - - - - ops = [ MoveTo $ Point2 128 (656 :: Double) - , LineTo $ Point2 224 768 - , LineTo $ Point2 304 624 - , LineTo $ Point2 432 752 - ] diff --git a/test/Ipe/ReaderSpec.hs b/test/Ipe/ReaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Ipe/ReaderSpec.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +module Ipe.ReaderSpec where + +import Test.Hspec +import Data.Ext +import Data.Geometry +import Ipe +import Ipe.Reader +import Ipe.Path +import Data.ByteString(ByteString) +import Data.Proxy + + +-- | specializes to use Double as Numtype +fromIpeXML' :: IpeRead (t Double) => ByteString -> Either ConversionError (t Double) +fromIpeXML' = fromIpeXML + + +spec :: Spec +spec = do + describe "IpeReadText" $ do + it "parses a polyline into a Path" $ + ipeReadText "\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n" + `shouldBe` Right ops + describe "IpeReadAttrs" $ do + it "parses a symbols attributes" $ + (show $ readXML useTxt + >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)) + `shouldBe` + "Right (Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named \"black\"), NoAttr, NoAttr, Attr IpeSize (Named \"normal\")})" + describe "IpeRead" $ do + it "parses a Symbol" $ + fromIpeXML' useTxt + `shouldBe` Right useSym + -- it "parses a path" $ + -- (show $ fromIpeXML' + -- "" +-- ) + -- `shouldBe` +-- "Right (Path {_pathSegments = PolyLineSegment (PolyLine {_points = Seq2 (Point2 [128.0,656.0] :+ ()) (fromList [Point2 [224.0,768.0] :+ (),Point2 [304.0,624.0] :+ ()]) (Point2 [432.0,752.0] :+ ())}) :< fromList []})" + + + where + useTxt = "" + useSym = Symbol (Point2 320 736) "mark/disk(sx)" +-- symAttrs = + + translatedUse = "" + + + + + ops = [ MoveTo $ Point2 128 (656 :: Double) + , LineTo $ Point2 224 768 + , LineTo $ Point2 304 624 + , LineTo $ Point2 432 752 + ]