diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2014, Frank Staals
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Frank Staals nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,28 @@
+HGeometry-ipe
+=============
+
+This package provides an API for reading and writing Ipe
+(http://ipe.otfried.org) files. This is all very work in
+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
+
+```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
+```
+
+See the [hgeometry-examples](https://github.com/noinia/hgeometry/tree/master/hgeometry-examples) package for more examples.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/changelog.org b/changelog.org
new file mode 100644
--- /dev/null
+++ b/changelog.org
diff --git a/hgeometry-ipe.cabal b/hgeometry-ipe.cabal
new file mode 100644
--- /dev/null
+++ b/hgeometry-ipe.cabal
@@ -0,0 +1,210 @@
+name: hgeometry-ipe
+version: 0.9.0.0
+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-file: LICENSE
+author: Frank Staals
+maintainer: frank@fstaals.net
+-- copyright:
+
+tested-with: GHC >= 8.2
+
+category: Geometry
+build-type: Simple
+
+data-files: resources/basic.isy
+ -- in the future (cabal >=2.4) we can use
+ -- examples/**/*.in
+ -- examples/**/*.out
+
+extra-source-files: README.md
+ changelog.org
+
+Extra-doc-files:
+ -- docs/**/*.png
+
+cabal-version: 2.0
+source-repository head
+ type: git
+ location: https://github.com/noinia/hgeometry
+
+
+library
+ ghc-options: -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults
+
+ exposed-modules:
+ -- * Drawing Graps and Planar Subdivisions
+ Data.Geometry.PlanarSubdivision.Draw
+ Data.Geometry.Arrangement.Draw
+ Data.Geometry.Triangulation.Draw
+ Data.Tree.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
+
+ -- * Embedded Planar Graphs
+ Data.PlaneGraph.Draw
+
+ other-modules:
+ Data.Geometry.Ipe.ParserPrimitives
+
+
+ -- other-extensions:
+ build-depends:
+ base >= 4.11 && < 5
+ , bifunctors >= 4.1
+ , bytestring >= 0.10
+ , containers >= 0.5.5
+ , dlist >= 0.7
+ , lens >= 4.2
+ , linear >= 1.10
+ , semigroupoids >= 5
+ , semigroups >= 0.18
+ , singletons >= 2.0
+ , text >= 1.1.1.0
+ , vinyl >= 0.10
+ , deepseq >= 1.1
+ , fingertree >= 0.1
+ , colour >= 2.3.3
+ , reflection >= 2.1
+ , MonadRandom >= 0.5
+ , QuickCheck >= 2.5
+ , quickcheck-instances >= 0.3
+
+ , hgeometry-combinatorial >= 0.9.0.0
+ , hgeometry >= 0.9.0.0
+
+ -- , validation >= 0.4
+
+ , parsec >= 3
+ -- , tranformers > 0.3
+
+ , vector >= 0.11
+ , fixed-vector >= 1.0
+ , data-clist >= 0.0.7.2
+
+ , hexpat >= 0.20.9
+ , aeson >= 1.0
+ , yaml >= 0.8
+
+
+ , mtl
+ , random
+ , template-haskell
+
+
+ hs-source-dirs: src
+ -- examples/demo
+
+ default-language: Haskell2010
+
+ default-extensions: TypeFamilies
+ , GADTs
+ , KindSignatures
+ , DataKinds
+ , TypeOperators
+ , ConstraintKinds
+ , PolyKinds
+ , RankNTypes
+ , TypeApplications
+ , ScopedTypeVariables
+
+ , PatternSynonyms
+ , TupleSections
+ , LambdaCase
+ , ViewPatterns
+
+ , StandaloneDeriving
+ , GeneralizedNewtypeDeriving
+ , DeriveFunctor
+ , DeriveFoldable
+ , DeriveTraversable
+ , DeriveGeneric
+ , AutoDeriveTypeable
+
+
+ , FlexibleInstances
+ , FlexibleContexts
+ , MultiParamTypeClasses
+
+test-suite hspec
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ hs-source-dirs: test
+ main-is: Spec.hs
+ ghc-options: -fno-warn-unticked-promoted-constructors
+ -fno-warn-partial-type-signatures
+ -fno-warn-missing-signatures
+
+ build-tool-depends: hspec-discover:hspec-discover
+
+
+ other-modules: Data.Geometry.Ipe.ReaderSpec
+
+ build-depends: base
+ , hspec >= 2.1
+ , QuickCheck >= 2.5
+ , quickcheck-instances >= 0.3
+ , approximate-equality >= 1.1.0.2
+ , hgeometry
+ , hgeometry-combinatorial
+ , hgeometry-ipe
+ , lens
+ , data-clist
+ , linear
+ , bytestring
+ , vinyl
+ , semigroups
+ , vector
+ , containers
+ , random
+ , singletons
+ , colour
+ , filepath
+ , directory
+ , yaml
+ , MonadRandom
+
+ default-extensions: TypeFamilies
+ , GADTs
+ , KindSignatures
+ , DataKinds
+ , TypeOperators
+ , ConstraintKinds
+ , PolyKinds
+ , RankNTypes
+ , TypeApplications
+ , ScopedTypeVariables
+
+
+ , PatternSynonyms
+ , ViewPatterns
+ , LambdaCase
+ , TupleSections
+
+
+ , StandaloneDeriving
+ , GeneralizedNewtypeDeriving
+ , DeriveFunctor
+ , DeriveFoldable
+ , DeriveTraversable
+
+ , AutoDeriveTypeable
+
+ , FlexibleInstances
+ , FlexibleContexts
+ , MultiParamTypeClasses
+ , OverloadedStrings
diff --git a/resources/basic.isy b/resources/basic.isy
new file mode 100644
--- /dev/null
+++ b/resources/basic.isy
@@ -0,0 +1,141 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e
+
+
+
+0.6 0 0 0.6 0 0 e
+
+
+
+0.5 0 0 0.5 0 0 e
+
+0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e
+
+
+
+-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h
+-0.4 -0.4 m 0.4 -0.4 l 0.4 0.4 l -0.4 0.4 l h
+
+
+-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h
+
+
+-0.5 -0.5 m 0.5 -0.5 l 0.5 0.5 l -0.5 0.5 l h
+
+-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h
+-0.4 -0.4 m 0.4 -0.4 l 0.4 0.4 l -0.4 0.4 l h
+
+
+-0.43 -0.57 m 0.57 0.43 l 0.43 0.57 l -0.57 -0.43 l h
+
+-0.43 0.57 m 0.57 -0.43 l 0.43 -0.57 l -0.57 0.43 l h
+
+
+
+0 0 m -1.0 0.333 l -1.0 -0.333 l h
+
+
+0 0 m -1.0 0.333 l -1.0 -0.333 l h
+
+
+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h
+
+
+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h
+
+
+0 0 m -1.0 0.333 l -1.0 -0.333 l h
+
+
+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h
+
+
+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h
+
+
+-1.0 0.333 m 0 0 l -1.0 -0.333 l
+
+
+0 0 m -1.0 0.333 l -1.0 -0.333 l h
+-1 0 m -2.0 0.333 l -2.0 -0.333 l h
+
+
+
+0 0 m -1.0 0.333 l -1.0 -0.333 l h
+-1 0 m -2.0 0.333 l -2.0 -0.333 l h
+
+
+
+
+
+
+
+
diff --git a/src/Data/Geometry/Arrangement/Draw.hs b/src/Data/Geometry/Arrangement/Draw.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Arrangement/Draw.hs
@@ -0,0 +1,24 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module : Data.Geometry.Arrangement.Draw
+-- Copyright : (C) Frank Staals
+-- License : see the LICENSE file
+-- Maintainer : Frank Staals
+--
+-- Functions for Drawing arrangements
+
+--------------------------------------------------------------------------------
+module Data.Geometry.Arrangement.Draw where
+
+import Control.Lens
+import Data.Geometry.Arrangement
+import Data.Geometry.Ipe
+import Data.Geometry.PlanarSubdivision.Draw
+
+-- | Draws an arrangement
+drawArrangement :: 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe.hs
@@ -0,0 +1,28 @@
+--------------------------------------------------------------------------------
+-- |
+-- 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/Attributes.hs
@@ -0,0 +1,368 @@
+{-# 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 GHC.Exts
+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 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 #-}
+
+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 = (<>)
+
+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
+
+
+
+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
+
+attrLens :: forall at ats proxy f. (at ∈ ats)
+ => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at))
+attrLens _ = unAttrs.(rlens @at).getAttr
+
+lookupAttr :: (at ∈ ats) => proxy at -> Attributes f ats -> Maybe (Apply f at)
+lookupAttr p = view (attrLens p)
+
+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&attrLens 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
+
+
+attr :: (at ∈ ats, RecApplicative ats)
+ => proxy at -> Apply f at -> Attributes f ats
+attr p x = setAttr p x mempty
+
+
+
+
+--------------------------------------------------------------------------------
+-- | 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)
+newtype IpePen r = IpePen (IpeValue r) deriving (Show,Eq,Ord)
+
+
+
+-- -- | 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)
+
+-- | 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)
+makeLenses ''IpeArrow
+
+normalArrow :: IpeArrow r
+normalArrow = IpeArrow "normal" (IpeSize $ Named "normal/normal")
+
+-- -- | and their types
+-- type family PathAttrElf (r :: *) (s :: PathAttributeUniverse) :: * where
+-- PathAttrElf r Stroke = IpeColor
+-- PathAttrElf r Fill = IpeColor
+-- PathAttrElf r Dash = IpeDash r
+-- PathAttrElf r Pen = IpePen r
+-- PathAttrElf r LineCap = Int
+-- PathAttrElf r LineJoin = Int
+-- PathAttrElf r FillRule = FillType
+-- PathAttrElf r Arrow = IpeArrow r
+-- PathAttrElf r RArrow = IpeArrow r
+-- PathAttrElf r Opacity = IpeOpacity
+-- PathAttrElf r Tiling = IpeTiling
+-- PathAttrElf r Gradient = IpeGradient
+
+-- genDefunSymbols [''PathAttrElf]
+
+-- type PathAttributes r = [ Stroke, Fill, Dash, Pen, LineCap, LineJoin
+-- , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient
+-- ]
+
+-- type PathAttributes r =
+-- Attributes (PathAttrElfSym1 r) [ Stroke, Fill, Dash, Pen, LineCap, LineJoin
+-- , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient
+-- ]
+
+--------------------------------------------------------------------------------
+-- | 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 :: AllSatisfy 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/Color.hs
@@ -0,0 +1,110 @@
+{-# 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
+--------------------------------------------------------------------------------
+
+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)
+
+-- | 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/FromIpe.hs b/src/Data/Geometry/Ipe/FromIpe.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/FromIpe.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE OverloadedStrings #-}
+--------------------------------------------------------------------------------
+-- |
+-- 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 where
+
+import Control.Lens hiding (Simple)
+import Data.Ext
+import Data.Geometry.Ipe.Reader
+import Data.Geometry.Ipe.Types
+import Data.Geometry.LineSegment
+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)
+-- :}
+
+
+-- | 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
+
+-- | Convert to a triangle
+_asTriangle :: Prism' (Path r) (Triangle 2 () r)
+_asTriangle = prism' triToPath path2tri
+ where
+ triToPath (Triangle p q r) = polygonToPath . fromPoints . 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
+
+-- | 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
+ $ (SimplePolygon vs) :| hs
+
+
+pathToPolygon :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r))
+pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of
+ [] -> Nothing
+ [pg] -> Just . Left $ pg
+ SimplePolygon 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 symbolPoint
+
+
+instance HasDefaultFromIpe (LineSegment 2 () r) where
+ type DefaultFromIpe (LineSegment 2 () r) = Path
+ defaultFromIpe = _withAttrs _IpePath _asLineSegment
+
+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 :: (HasDefaultFromIpe g, r ~ NumType g, Foldable f)
+ => f (IpePage r) -> [g :+ IpeAttributes (DefaultFromIpe g) r]
+readAll = foldMap (^..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 = 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/IpeOut.hs
@@ -0,0 +1,213 @@
+{-# 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.Geometry.Ball
+import Data.Geometry.Boundary
+import Data.Geometry.Box
+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 Data.Geometry.Transformation
+import qualified Data.LSeq as LSeq
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
+import Data.Maybe (fromMaybe)
+import Linear.Affine ((.+^))
+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
+
+
+-- | 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 = ipeLineSegment . toSeg
+ where
+ b :: Rectangle () r
+ b = box (ext $ Point2 (-200) (-200)) (ext $ Point2 1200 1200)
+ naive (Line p v) = ClosedLineSegment (ext p) (ext $ p .+^ v)
+ toSeg l = fromMaybe (naive l) . asA @(LineSegment 2 () r)
+ $ l `intersect` b
+
+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 Floating r => HasDefaultIpeOut (Disk p r) where
+ type DefaultIpeOut (Disk p r) = Path
+ defIO = ipeDisk
+
+--------------------------------------------------------------------------------
+-- * 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
+
+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
+
+ipeDisk :: Floating r => IpeOut (Disk p r) Path r
+ipeDisk d = ipeCircle (Boundary d) ! attr SFill (IpeColor "0.722 0.145 0.137")
+
+ipeCircle :: Floating r => IpeOut (Circle p r) Path r
+ipeCircle (Circle (c :+ _) r) = (path $ EllipseSegment m) :+ mempty
+ where
+ m = translation (toVec c) |.| uniformScaling (sqrt r) ^. transformationMatrix
+ -- m is the matrix s.t. if we apply m to the unit circle centered at the origin, we
+ -- get the input circle.
+
+-- | 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
+
+
+--------------------------------------------------------------------------------
+-- * Group Converters
+
+ipeGroup :: IpeOut [IpeObject r] Group r
+ipeGroup xs = Group xs :+ mempty
+
+
+
+
+--------------------------------------------------------------------------------
diff --git a/src/Data/Geometry/Ipe/Literal.hs b/src/Data/Geometry/Ipe/Literal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/Literal.hs
@@ -0,0 +1,27 @@
+{-# 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/ParserPrimitives.hs b/src/Data/Geometry/Ipe/ParserPrimitives.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/ParserPrimitives.hs
@@ -0,0 +1,148 @@
+{-# 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 = space
+
+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/PathParser.hs b/src/Data/Geometry/Ipe/PathParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/PathParser.hs
@@ -0,0 +1,163 @@
+{-# 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.Types (Operation(..))
+import Data.Geometry.Point
+import Data.Geometry.Transformation
+import Data.Geometry.Vector
+import Data.Ratio
+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 (Ratio Integer)
+
+-----------------------------------------------------------------------
+-- | 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 :: 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Geometry/Ipe/Reader.hs
@@ -0,0 +1,417 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Data.Geometry.Ipe.Reader( -- * Reading ipe Files
+ readRawIpeFile
+ , readIpeFile
+ , readSinglePageFile
+ , 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 qualified Data.ByteString as B
+import Data.Colour.SRGB (RGB(..))
+import Data.Either (rights)
+import Data.Ext
+import Data.Geometry.Box
+import Data.Geometry.Ipe.Attributes
+import Data.Geometry.Ipe.ParserPrimitives (pInteger, pWhiteSpace)
+import Data.Geometry.Ipe.PathParser
+import Data.Geometry.Ipe.Types
+import Data.Geometry.Ipe.Value
+import Data.Geometry.Ipe.Color(IpeColor(..))
+import Data.Geometry.Point
+import Data.Geometry.PolyLine
+import qualified Data.Geometry.Polygon as Polygon
+import qualified Data.Geometry.Transformation as Trans
+import qualified Data.List as L
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Proxy
+import qualified Data.LSeq as LSeq
+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 (bimap id applyMatrices) . readRawIpeFile
+
+
+-- | Since most Ipe file contain only one page, we provide a shortcut for that
+-- as well. This function applies all matrices.
+readSinglePageFile :: (Coordinate r, Eq r)
+ => FilePath -> IO (Either ConversionError (IpePage r))
+readSinglePageFile = fmap f . readIpeFile
+ where
+ f (Left e) = Left e
+ f (Right i) = maybe (Left "No Ipe pages found") Right . firstOf (pages.traverse) $ i
+
+-- | 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 = bimap (T.pack . show) id . 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 (Trans.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 (NE.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 NE.:| ps
+
+ fromOps [] = Right []
+ 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.fromPoints . dropRepeats $ pts
+ pl = fromPoints pts
+ in case xs of
+ (ClosePath : xs') -> PolygonPath poly <<| xs'
+ _ -> PolyLineSegment pl <<| xs
+ 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 :: [u]). Applicative h
+ => (forall (x :: u). 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
+ , AllSatisfy 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
+ , AllSatisfy 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 = "