hgeometry-ipe 0.10.0.0 → 0.11.0.0

raw patch · 17 files changed

+991/−524 lines, 17 filesdep ~hgeometrydep ~hgeometry-combinatorialPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hgeometry, hgeometry-combinatorial

API changes (from Hackage documentation)

Files

• changelog.org +32/−0
• hgeometry-ipe.cabal +17/−5
• src/Data/Geometry/Ipe/Attributes.hs +59/−53
• src/Data/Geometry/Ipe/Color.hs +14/−4
• src/Data/Geometry/Ipe/Content.hs +346/−0
• src/Data/Geometry/Ipe/FromIpe.hs +95/−9
• src/Data/Geometry/Ipe/IpeOut.hs +35/−15
• src/Data/Geometry/Ipe/Layer.hs +13/−0
• src/Data/Geometry/Ipe/Matrix.hs +41/−0
• src/Data/Geometry/Ipe/ParserPrimitives.hs +2/−2
• src/Data/Geometry/Ipe/Path.hs +112/−0
• src/Data/Geometry/Ipe/PathParser.hs +7/−3
• src/Data/Geometry/Ipe/Reader.hs +28/−16
• src/Data/Geometry/Ipe/Types.hs +101/−339
• src/Data/Geometry/Ipe/Writer.hs +45/−78
• src/Data/Geometry/QuadTree/Draw.hs +43/−0
• test/Data/Geometry/Ipe/ReaderSpec.hs +1/−0

@@ -0,0 +1,32 @@+#+STARTUP: showeverything++* Changelog++** 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.

@@ -1,5 +1,5 @@ name:                hgeometry-ipe-version:             0.10.0.0+version:             0.11.0.0 synopsis:            Reading and Writing ipe7 files. description:    Reading and Writing ipe7 files and converting them to and from HGeometry types.@@ -36,12 +36,16 @@   ghc-options: -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults    exposed-modules:-                    -- * Drawing Graps and Planar Subdivisions+                    -- * Drawing Graphs and Planar Subdivisions                     Data.Geometry.PlanarSubdivision.Draw                     Data.Geometry.Arrangement.Draw                     Data.Geometry.Triangulation.Draw                     Data.Tree.Draw ++                    -- Data.Geometry.CatmulRomSpline+                    Data.Geometry.QuadTree.Draw+                     -- * Ipe Types                     Data.Geometry.Ipe                     Data.Geometry.Ipe.Literal@@ -54,10 +58,16 @@                     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                      -- * Embedded Planar Graphs                     Data.PlaneGraph.Draw +                    -- Data.Geometry.BezierSpline+   other-modules:                     Data.Geometry.Ipe.ParserPrimitives @@ -84,8 +94,8 @@               , QuickCheck              >= 2.5               , quickcheck-instances    >= 0.3 -              , hgeometry-combinatorial >= 0.9.0.0-              , hgeometry               >= 0.9.0.0+              , hgeometry-combinatorial >= 0.11.0.0+              , hgeometry               >= 0.11.0.0                -- , validation       >= 0.4 @@ -99,11 +109,13 @@               , hexpat           >= 0.20.9               , aeson            >= 1.0               , yaml             >= 0.8-+              -- , zippers          >= 0.2                , mtl               , random               , template-haskell++              -- , hslua     hs-source-dirs: src

@@ -22,7 +22,6 @@ 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) @@ -66,6 +65,10 @@ 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@@ -73,7 +76,6 @@              (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) @@ -88,6 +90,20 @@ 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@@ -119,6 +135,10 @@   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')@@ -141,20 +161,39 @@ 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 -attrLens   :: forall at ats proxy f. (at ∈ ats)-           => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at))-attrLens _ = unAttrs.(rlens @at).getAttr +----------------------------------------++-- | 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 (attrLens p)+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@@ -164,21 +203,17 @@ 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)-+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 = setAttr p x mempty---+attr p x = x^.re (_Attr p)  -------------------------------------------------------------------------------- -- | Common Attributes@@ -225,11 +260,8 @@ -- 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)-+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@@ -259,7 +291,7 @@ -- | Possible values for Dash data IpeDash r = DashNamed Text                | DashPattern [r] r-               deriving (Show,Eq)+               deriving (Show,Eq,Functor,Foldable,Traversable)  -- | Allowed Fill types data FillType = Wind | EOFill deriving (Show,Read,Eq)@@ -272,49 +304,21 @@ -- | Possible values for an ipe arrow data IpeArrow r = IpeArrow { _arrowName :: Text                            , _arrowSize :: IpeSize r-                           } deriving (Show,Eq)+                           } deriving (Show,Eq,Functor,Foldable,Traversable) 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 @@ -351,14 +355,14 @@ 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)+-- -- | 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           :: AllConstrained IpeAttrName rs => Rec f rs -> Rec (Const Text) rs writeAttrNames RNil      = RNil writeAttrNames (x :& xs) = Const (write'' x) :& writeAttrNames xs   where@@ -366,3 +370,5 @@     write'' _ = attrName (Proxy :: Proxy s)  --++--------------------------------------------------------------------------------

@@ -12,17 +12,27 @@ -------------------------------------------------------------------------------- module Data.Geometry.Ipe.Color where -import           Data.Colour.SRGB (RGB(..))-import           Data.Geometry.Ipe.Value-import           Data.Text+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)+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

@@ -0,0 +1,346 @@+{-# 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 :: * -> *) :: [u] 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]

@@ -9,13 +9,36 @@ -- Functions that help reading geometric values from ipe images. -- ---------------------------------------------------------------------------------module Data.Geometry.Ipe.FromIpe where+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@@ -41,6 +64,12 @@ -- :}  ++-- | 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. --@@ -67,6 +96,24 @@ _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^..outerBoundary.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@@ -79,6 +126,28 @@                               _            -> 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@@ -106,6 +175,11 @@   +++--------------------------------------------------------------------------------++ -- | 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.@@ -138,15 +212,28 @@   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 (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@@ -162,16 +249,15 @@   -- | 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)-+readAll   :: (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 = readAll <$> readSinglePageFile fp+readAllFrom fp = foldMap readAll <$> readSinglePageFile fp  fromSingleton :: a -> LSeq.LSeq 1 a fromSingleton = LSeq.fromNonEmpty . (:| [])

@@ -20,7 +20,10 @@ import           Control.Lens hiding (Simple) import           Data.Bifunctor import           Data.Ext+import           Data.Foldable (toList) import           Data.Geometry.Ball+import           Data.Geometry.Ellipse(Ellipse, circleToEllipse)+import           Data.Geometry.BezierSpline import           Data.Geometry.Boundary import           Data.Geometry.Box import           Data.Geometry.Ipe.Attributes@@ -30,17 +33,17 @@ import           Data.Geometry.Line import           Data.Geometry.LineSegment import           Data.Geometry.Point-import           Data.Geometry.PolyLine(PolyLine,fromLineSegment)+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.Text (Text)+import qualified Data.Text as Text import           Data.Vinyl.CoRec+import           Linear.Affine ((.+^))  -------------------------------------------------------------------------------- @@ -154,11 +157,18 @@   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@@ -181,16 +191,15 @@ 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") -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 . (:| [])@@ -209,15 +218,26 @@ ipeRectangle   :: Num r => IpeOut (Rectangle p r) Path r ipeRectangle r = ipePolygon $ fromPoints [tl,tr,br,bl]   where-    (tl, tr, br, bl) = corners r+    Corners tl tr br bl = corners r  -------------------------------------------------------------------------------- -- * Group Converters -ipeGroup    :: IpeOut [IpeObject r] Group r-ipeGroup xs = Group xs :+ mempty+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)]

@@ -0,0 +1,13 @@+{-# 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

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

@@ -61,8 +61,8 @@ pSpace :: Parser Char pSpace = pChar ' ' -pWhiteSpace :: Parser Char-pWhiteSpace = space+pWhiteSpace :: Parser [Char]+pWhiteSpace = pMany1 (space <|> newline)  pMaybe :: Parser a -> Parser (Maybe a) pMaybe = optionMaybe

@@ -0,0 +1,112 @@+{-# 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

@@ -7,11 +7,12 @@ import           Data.Ext (ext) import           Data.Geometry.Box import           Data.Geometry.Ipe.ParserPrimitives-import           Data.Geometry.Ipe.Types (Operation(..))+import           Data.Geometry.Ipe.Path (Operation(..))+import           Data.Geometry.Matrix import           Data.Geometry.Point-import           Data.Geometry.Transformation 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)@@ -38,7 +39,9 @@                                 in z * (abs x' + asDecimal y')  instance Coordinate Double+instance Coordinate Float instance Coordinate (Ratio Integer)+instance Coordinate (RealNumber p)  ----------------------------------------------------------------------- -- | Running the parsers@@ -112,7 +115,7 @@ -- | The parsers themselves  -pOperation :: Coordinate r => Parser (Operation r)+pOperation :: forall r. Coordinate r => Parser (Operation r) pOperation = pChoice [ MoveTo       <$> pPoint                         *>> 'm'                      , LineTo       <$> pPoint                         *>> 'l'                      , CurveTo      <$> pPoint <*> pPoint' <*> pPoint' *>> 'c'@@ -126,6 +129,7 @@              where                pPoint' = pWhiteSpace *> pPoint                p *>> c = p <*>< pWhiteSpace ***> pChar c+   pPoint :: Coordinate r => Parser (Point 2 r)

@@ -33,18 +33,22 @@ import           Data.Either (rights) import           Data.Ext import           Data.Geometry.Box+import           Data.Geometry.BezierSpline+import           Data.Geometry.Ellipse(ellipseMatrix) import           Data.Geometry.Ipe.Attributes import           Data.Geometry.Ipe.ParserPrimitives (pInteger, pWhiteSpace) import           Data.Geometry.Ipe.PathParser+import           Data.Geometry.Ipe.Path+import           Data.Geometry.Ipe.Matrix 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.Geometry.Matrix as Matrix import qualified Data.List as L-import qualified Data.List.NonEmpty as NE+import qualified Data.List.NonEmpty as NonEmpty import           Data.Maybe (fromMaybe, mapMaybe) import           Data.Proxy import qualified Data.LSeq as LSeq@@ -69,21 +73,26 @@ readRawIpeFile = fmap fromIpeXML . B.readFile  --- | Given a file path, tries to read an ipe file. This function applies all--- matrices to objects.+-- | 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.+-- 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 f . readIpeFile+readSinglePageFile = fmap (fmap f) . readIpeFile   where-    f (Left e)  = Left e-    f (Right i) = maybe (Left "No Ipe pages found") Right . firstOf (pages.traverse) $ i+    f   :: IpeFile r -> IpePage r+    f i = withDefaults . NonEmpty.head $ i^.pages  -- | Given a Bytestring, try to parse the bytestring into anything that is -- IpeReadable, i.e. any of the Ipe elements.@@ -116,7 +125,7 @@ instance Coordinate r => IpeReadText (Point 2 r) where   ipeReadText = readPoint -instance Coordinate r => IpeReadText (Trans.Matrix 3 3 r) where+instance Coordinate r => IpeReadText (Matrix.Matrix 3 3 r) where   ipeReadText = readMatrix  instance IpeReadText LayerName where@@ -180,15 +189,16 @@ instance Coordinate r => IpeReadText [Operation r] where   ipeReadText = readPathOperations -instance (Coordinate r, Eq r) => IpeReadText (NE.NonEmpty (PathSegment r)) where+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 NE.:| ps+                      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" @@ -196,10 +206,12 @@       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+                                      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)@@ -242,7 +254,7 @@                  ( RecApplicative ats                  , ReifyConstraint IpeReadAttr (Attr f) ats                  , RecAll (Attr f) ats IpeReadAttr-                 , AllSatisfy IpeAttrName ats+                 , AllConstrained IpeAttrName ats                  )                  => Proxy f -> Proxy ats                  -> Node Text Text@@ -267,7 +279,7 @@                  , ReifyConstraint IpeReadAttr (Attr f) ats                  , RecApplicative ats                  , RecAll (Attr f) ats IpeReadAttr-                 , AllSatisfy IpeAttrName ats+                 , AllConstrained IpeAttrName ats                  )                  => proxy i -> proxy' r                  -> Node Text Text@@ -298,7 +310,7 @@                            , RecApplicative ats                            , ReifyConstraint IpeReadAttr (Attr f) ats                            , RecAll (Attr f) ats IpeReadAttr-                           , AllSatisfy IpeAttrName ats+                           , AllConstrained IpeAttrName ats                            )                         => Proxy i -> proxy r -> Node Text Text                         -> Either ConversionError (i r :+ IpeAttributes i r)@@ -407,7 +419,7 @@ 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 [] (NE.fromList pgs)+                                    pgs -> Right $ IpeFile Nothing [] (NonEmpty.fromList pgs)   ipeRead _                     = Left "Ipe: Element expected, text found"  

@@ -1,5 +1,3 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}@@ -13,305 +11,65 @@ -- Data type modeling the various elements in Ipe files. -- ---------------------------------------------------------------------------------module Data.Geometry.Ipe.Types where---import           Control.Lens-import           Data.Proxy-import           Data.Vinyl hiding (Label)--import           Data.Ext-import           Data.Geometry.Box(Rectangle)-import           Data.Geometry.Point-import           Data.Geometry.PolyLine-import           Data.Geometry.Polygon(SimplePolygon)-import           Data.Geometry.Properties-import           Data.Geometry.Transformation--import           Data.Maybe(mapMaybe)-import           Data.Singletons.TH(genDefunSymbols)--import           Data.Geometry.Ipe.Literal-import           Data.Geometry.Ipe.Color-import qualified Data.Geometry.Ipe.Attributes as AT-import           Data.Geometry.Ipe.Attributes hiding (Matrix)-import           Data.Text(Text)-import           Text.XML.Expat.Tree(Node)--import           GHC.Exts---import qualified Data.List.NonEmpty as NE-import qualified Data.LSeq          as LSeq-------------------------------------------------------------------------------------newtype LayerName = LayerName {_layerName :: Text } deriving (Show,Read,Eq,Ord,IsString)------------------------------------------------------------------------------------- | 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)------------------------------------------------------------------------------------- | Text Objects--data TextLabel r = Label Text (Point 2 r)-                 deriving (Show,Eq,Ord)--data MiniPage r = MiniPage Text (Point 2 r) r-                 deriving (Show,Eq,Ord)--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)-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---- | Paths consist of Path Segments. PathSegments come in the following forms:-data PathSegment r = PolyLineSegment        (PolyLine 2 () r)-                   | PolygonPath            (SimplePolygon () r)-                     -- TODO-                   | CubicBezierSegment     -- (CubicBezier 2 r)-                   | QuadraticBezierSegment -- (QuadraticBezier 2 r)-                   | EllipseSegment (Matrix 3 3 r)-                   | 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 Fractional r => IsTransformable (PathSegment r) where-  transformBy t (PolyLineSegment p) = PolyLineSegment $ transformBy t p-  transformBy t (PolygonPath p)     = PolygonPath $ transformBy t p-  transformBy _ _                   = error "transformBy: not implemented yet"----- | A path is a non-empty sequence of PathSegments.-newtype Path r = Path { _pathSegments :: LSeq.LSeq 1 (PathSegment r) }-                 deriving (Show,Eq)-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)-makePrisms ''Operation------------------------------------------------------------------------------------- * 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+module Data.Geometry.Ipe.Types(+    LayerName(LayerName), layerName+  , Image(Image), imageData, rect+  , TextLabel(..)+  , MiniPage(..), width -  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+  , IpeSymbol(Symbol), symbolPoint, symbolName -  AttrMap r Clip = Path r -- strictly we event want this to be a closed path I guess+  , Path(Path), pathSegments+  , PathSegment(..) -genDefunSymbols [''AttrMap]+  , Group(Group), groupItems  ------------------------------------------------------------------------------------ | 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+  , IpeObject(..), _IpeGroup, _IpeImage, _IpeTextLabel, _IpeMiniPage, _IpeUse, _IpePath+  , IpeObject'+  , ipeObject'+  , ToObject(..) --- genDefunSymbols [''GroupAttrElf]+  , IpeAttributes+  , Attributes', AttributesOf, AttrMap, AttrMapSym1+  , attributes, traverseIpeAttrs+  , commonAttributes --- type GroupAttributes r = Attributes (GroupAttrElfSym1 r) '[ 'Clip]+  , flattenGroups  --- | A group is essentially a list of IpeObjects.-newtype Group r = Group [IpeObject r] deriving (Show,Eq)--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-+  , View(View), layerNames, activeLayer -type family AttributesOf (t :: * -> *) :: [u] where-  AttributesOf Group     = GroupAttributes-  AttributesOf Image     = CommonAttributes-  AttributesOf TextLabel = CommonAttributes-  AttributesOf MiniPage  = CommonAttributes-  AttributesOf IpeSymbol = SymbolAttributes-  AttributesOf Path      = PathAttributes+  , IpeStyle(IpeStyle), styleName, styleData+  , basicIpeStyle  --- | Attributes' :: * -> [AttributeUniverse] -> *-type Attributes' r = Attributes (AttrMapSym1 r)+  , IpePreamble(IpePreamble), encoding, preambleData -type IpeAttributes g r = Attributes' r (AttributesOf g)+  , IpeBitmap  --- | 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+  , IpePage(IpePage), layers, views, content+  , emptyPage, fromContent+  , onLayer, contentInView+  , withDefaults -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)+  , IpeFile(IpeFile), preamble, styles, pages+  , ipeFile, singlePageFile, singlePageFromContent+  ) where  -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]+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)  -------------------------------------------------------------------------------- @@ -362,12 +120,61 @@               deriving (Eq,Show) makeLenses ''IpePage --- | Creates a simple page with no views.+-- | 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' [] obs+fromContent obs = IpePage layers' [View layers' a] obs   where-    layers' = mapMaybe (^.commonAttributes.attrLens SLayer) obs+    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]@@ -376,61 +183,16 @@                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 p = IpeFile Nothing [basicIpeStyle] (p NE.:| [])+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--------------------------------------------------------------------------------------- | 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---------------------------------------------------------------------------------------- -- | Access a path as if it was a PolyLine--- _PolyLine :: Prism' (IpeObject' Path r)---                     (PolyLine 2 () r :+ IpeAttributes Path r)--- _PolyLine = prism' build' access---   where---     build'  p         = p&core %~ Path . S2.l1Singleton . PolyLineSegment---     access ~(p :+ a) = (:+ a) <$> p^?pathSegments.S2.headL1._PolyLineSegment---- -- | Access a path as if it was a SimplePolygon--- _SimplePolygon :: Prism' (IpeObject' Path r)---                          (SimplePolygon () r :+ IpeAttributes Path r)--- _SimplePolygon = prism' build' access---   where---     build'  p         = p&core %~ Path . S2.l1Singleton . PolygonPath---     access ~(p :+ a) = (:+ a) <$> p^?pathSegments.S2.headL1._PolygonPath

@@ -10,9 +10,19 @@ -- Description :  Converting data types into IpeTypes -- ---------------------------------------------------------------------------------module Data.Geometry.Ipe.Writer where+module Data.Geometry.Ipe.Writer( writeIpeFile, writeIpeFile', writeIpePage+                               , toIpeXML -import           Control.Lens ((^.), (^..), (.~), (&))+                               , 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(..))@@ -20,24 +30,27 @@ import           Data.Fixed import qualified Data.Foldable as F 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.Types+import           Data.Geometry.Ipe.Path import           Data.Geometry.Ipe.Value import           Data.Geometry.LineSegment import           Data.Geometry.Point+import           Data.Geometry.BezierSpline import           Data.Geometry.PolyLine import           Data.Geometry.Polygon (Polygon, outerBoundary, holeList, asSimplePolygon)-import qualified Data.Geometry.Transformation as GT+import qualified Data.Geometry.Matrix as Matrix import           Data.Geometry.Vector import qualified Data.LSeq as LSeq import           Data.List.NonEmpty (NonEmpty(..)) import           Data.Maybe (catMaybes, mapMaybe, fromMaybe) import           Data.Ratio+import           Data.RealNumber.Rational import           Data.Singletons import           Data.Text (Text)-import qualified Data.Text as T import qualified Data.Text as Text import           Data.Vinyl hiding (Label) import           Data.Vinyl.Functor@@ -106,6 +119,9 @@                   [] -> 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 @@ -119,7 +135,7 @@ -- | Functon to write all attributes in a Rec ipeWriteAttrs           :: ( RecordToList rs, RMap rs                            , ReifyConstraint IpeWriteText (Attr f) rs-                           , AllSatisfy IpeAttrName rs+                           , AllConstrained IpeAttrName rs                            , RecAll (Attr f) rs IpeWriteText                            ) => IA.Attributes f rs -> [(Text,Text)] ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames  r)@@ -138,6 +154,10 @@ 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 }@@ -152,12 +172,18 @@ 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 @@ -169,13 +195,13 @@       f = id  writeByShow :: Show t => t -> Maybe Text-writeByShow = ipeWriteText . T.pack . show+writeByShow = ipeWriteText . Text.pack . show  unwords' :: [Maybe Text] -> Maybe Text-unwords' = fmap T.unwords . sequence+unwords' = fmap Text.unwords . sequence  unlines' :: [Maybe Text] -> Maybe Text-unlines' = fmap T.unlines . sequence+unlines' = fmap Text.unlines . sequence   instance IpeWriteText r => IpeWriteText (Point 2 r) where@@ -223,7 +249,7 @@                                                             <*> ipeWriteText s  instance IpeWriteText r => IpeWriteText (Path r) where-  ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . _pathSegments+  ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . view pathSegments     where       concat' = F.foldr1 (\t t' -> t <> "\n" <> t') @@ -236,15 +262,10 @@                            , ("name", n)                            ] [] --- instance IpeWriteText (SymbolAttrElf rs r) => IpeWriteText (SymbolAttribute r rs) where---   ipeWriteText (SymbolAttribute x) = ipeWriteText x--- -------------------------------------------------------------------------------- -instance IpeWriteText r => IpeWriteText (GT.Matrix 3 3 r) where-  ipeWriteText (GT.Matrix m) = unwords' [a,b,c,d,e,f]+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 @@ -285,11 +306,13 @@     -- 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  m) = ipeWriteText $ Ellipse m+  ipeWriteText (EllipseSegment  e) = ipeWriteText $ Ellipse (e^.ellipseMatrix)   ipeWriteText _                   = error "ipeWriteText: PathSegment, not implemented yet."  instance IpeWriteText r => IpeWrite (Path r) where@@ -302,7 +325,7 @@   ipeWrite (Group gs) = ipeWrite gs  -instance ( AllSatisfy IpeAttrName rs+instance ( AllConstrained IpeAttrName rs          , RecordToList rs, RMap rs          , ReifyConstraint IpeWriteText (Attr f) rs          , RecAll (Attr f) rs IpeWriteText@@ -348,18 +371,6 @@     ipeWrite (IpeUse       s) = ipeWrite s     ipeWrite (IpePath      p) = ipeWrite p --ipeWriteRec :: (RecAll f rs IpeWrite, RMap rs, ReifyConstraint IpeWrite f rs, RecordToList rs)-            => Rec f rs -> [Node Text Text]-ipeWriteRec = catMaybes . recordToList-            . rmap (\(Compose (Dict x)) -> Const $ ipeWrite x)-            . reifyConstraint @IpeWrite----- instance IpeWriteText (GroupAttrElf rs r) => IpeWriteText (GroupAttribute r rs) where---   ipeWriteText (GroupAttribute x) = ipeWriteText x-- --------------------------------------------------------------------------------  deriving instance IpeWriteText LayerName@@ -369,10 +380,10 @@  instance IpeWrite View where   ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls)-                                                  , ("active", _layerName act)+                                                  , ("active", act^.layerName)                                                   ] []     where-      ls = T.unwords .  map _layerName $ lrs+      ls = Text.unwords .  map (^.layerName) $ lrs  instance (IpeWriteText r)  => IpeWrite (IpePage r) where   ipeWrite (IpePage lrs vs objs) = Just .@@ -416,53 +427,9 @@   instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where-  ipeWrite (LineSegment' p q) = ipeWrite . fromPolyLine . fromPoints . map (extra .~ ()) $ [p,q]+  ipeWrite (LineSegment' p q) =+    ipeWrite . fromPolyLine . fromPointsUnsafe . map (extra .~ ()) $ [p,q]   instance IpeWrite () where   ipeWrite = const Nothing---- -- | slightly clever instance that produces a group if there is more than one--- -- element and just an element if there is only one value produced--- instance IpeWrite a => IpeWrite [a] where---   ipeWrite = combine . mapMaybe ipeWrite---combine     :: [Node Text Text] -> Maybe (Node Text Text)-combine []  = Nothing-combine [n] = Just n-combine ns  = Just $ Element "group" [] ns---- instance (IpeWrite a, IpeWrite b) => IpeWrite (a,b) where---   ipeWrite (a,b) = combine . catMaybes $ [ipeWrite a, ipeWrite b]------ -- | The default symbol for a point--- ipeWritePoint :: IpeWriteText r => Point 2 r -> Maybe (Node Text Text)--- ipeWritePoint = ipeWrite . flip Symbol "mark/disk(sx)"----- instance (IpeWriteText r, Floating r) => IpeWrite (Circle r) where---   ipeWrite = ipeWrite . Path . S2.l1Singleton . fromCircle------------------------------------------------------------------------------------------ testPoly :: PolyLine 2 () Double--- testPoly = fromPoints' [origin, Point2 0 10, Point2 10 10, Point2 100 100]------- testWriteUse :: Maybe (Node Text Text)--- testWriteUse = ipeWriteExt sym---   where---     sym :: IpeSymbol Double :+ (Rec (SymbolAttribute Double) [Size, SymbolStroke])---     sym = Symbol origin "mark" :+ (  SymbolAttribute (IpeSize  $ Named "normal")---                                   :& SymbolAttribute (IpeColor $ Named "green")---                                   :& RNil---                                   )

@@ -0,0 +1,43 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+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           Data.Geometry.QuadTree+import           Data.Geometry.QuadTree.Cell+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Text as T+import           Data.Tree.Util (TreeNode(..))+import           Data.Vinyl.Notation+import           Data.Vinyl.Core+--------------------------------------------------------------------------------++drawCell :: Fractional r => IpeOut (Cell r) Path r+drawCell = \c -> ipeRectangle (toBox c)++drawQuadTree :: (Fractional r, Ord r) => IpeOut (QuadTree v p r) Group r+drawQuadTree = drawQuadTreeWith (\(_ :+ c) -> drawCell c)++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++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+quadTreeLevels drawCell' = \qt -> let lvls = fmap (fmap flip') . perLevel . withCells $ qt+                                  in ipeGroup . fmap iO . zipWith drawLevel [1..] . F.toList $ lvls+  where+    flip' = \case+      InternalNode (v :+ c) -> InternalNode v :+ c+      LeafNode (l :+ c)     -> LeafNode l     :+ c++    -- drawLevel   :: Int -> IpeOut (NonEmpty (TreeNode v p :+ Cell r)) Group r+    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)

@@ -5,6 +5,7 @@ import Data.Ext import Data.Geometry import Data.Geometry.Ipe+import Data.Geometry.Ipe.Path import Data.ByteString(ByteString) import Data.Proxy