hgeometry-ipe (empty) → 0.9.0.0
raw patch · 25 files changed
+3205/−0 lines, 25 filesdep +MonadRandomdep +QuickCheckdep +aesonsetup-changed
Dependencies added: MonadRandom, QuickCheck, aeson, approximate-equality, base, bifunctors, bytestring, colour, containers, data-clist, deepseq, directory, dlist, filepath, fingertree, fixed-vector, hexpat, hgeometry, hgeometry-combinatorial, hgeometry-ipe, hspec, lens, linear, mtl, parsec, quickcheck-instances, random, reflection, semigroupoids, semigroups, singletons, template-haskell, text, vector, vinyl, yaml
Files
- LICENSE +30/−0
- README.md +28/−0
- Setup.hs +2/−0
- changelog.org +0/−0
- hgeometry-ipe.cabal +210/−0
- resources/basic.isy +141/−0
- src/Data/Geometry/Arrangement/Draw.hs +24/−0
- src/Data/Geometry/Ipe.hs +28/−0
- src/Data/Geometry/Ipe/Attributes.hs +368/−0
- src/Data/Geometry/Ipe/Color.hs +110/−0
- src/Data/Geometry/Ipe/FromIpe.hs +177/−0
- src/Data/Geometry/Ipe/IpeOut.hs +213/−0
- src/Data/Geometry/Ipe/Literal.hs +27/−0
- src/Data/Geometry/Ipe/ParserPrimitives.hs +148/−0
- src/Data/Geometry/Ipe/PathParser.hs +163/−0
- src/Data/Geometry/Ipe/Reader.hs +417/−0
- src/Data/Geometry/Ipe/Types.hs +436/−0
- src/Data/Geometry/Ipe/Value.hs +24/−0
- src/Data/Geometry/Ipe/Writer.hs +468/−0
- src/Data/Geometry/PlanarSubdivision/Draw.hs +54/−0
- src/Data/Geometry/Triangulation/Draw.hs +14/−0
- src/Data/PlaneGraph/Draw.hs +50/−0
- src/Data/Tree/Draw.hs +17/−0
- test/Data/Geometry/Ipe/ReaderSpec.hs +55/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.org view
+ hgeometry-ipe.cabal view
@@ -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
+ resources/basic.isy view
@@ -0,0 +1,141 @@+<?xml version="1.0"?>+<!DOCTYPE ipestyle SYSTEM "ipe.dtd">+<ipestyle name="basic">+<color name="red" value="1 0 0"/>+<color name="green" value="0 1 0"/>+<color name="blue" value="0 0 1"/>+<color name="yellow" value="1 1 0"/>+<color name="orange" value="1 0.647 0"/>+<color name="gold" value="1 0.843 0"/>+<color name="purple" value="0.627 0.125 0.941"/>+<color name="gray" value="0.745 0.745 0.745"/>+<color name="brown" value="0.647 0.165 0.165"/>+<color name="navy" value="0 0 0.502"/>+<color name="pink" value="1 0.753 0.796"/>+<color name="seagreen" value="0.18 0.545 0.341"/>+<color name="turquoise" value="0.251 0.878 0.816"/>+<color name="violet" value="0.933 0.51 0.933"/>+<color name="darkblue" value="0 0 0.545"/>+<color name="darkcyan" value="0 0.545 0.545"/>+<color name="darkgray" value="0.663 0.663 0.663"/>+<color name="darkgreen" value="0 0.392 0"/>+<color name="darkmagenta" value="0.545 0 0.545"/>+<color name="darkorange" value="1 0.549 0"/>+<color name="darkred" value="0.545 0 0"/>+<color name="lightblue" value="0.678 0.847 0.902"/>+<color name="lightcyan" value="0.878 1 1"/>+<color name="lightgray" value="0.827 0.827 0.827"/>+<color name="lightgreen" value="0.565 0.933 0.565"/>+<color name="lightyellow" value="1 1 0.878"/>+<dashstyle name="dashed" value="[4] 0"/>+<dashstyle name="dotted" value="[1 3] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<pen name="heavier" value="0.8"/>+<pen name="fat" value="1.2"/>+<pen name="ultrafat" value="2"/>+<textsize name="large" value="\large"/>+<textsize name="Large" value="\Large"/>+<textsize name="LARGE" value="\LARGE"/>+<textsize name="huge" value="\huge"/>+<textsize name="Huge" value="\Huge"/>+<textsize name="small" value="\small"/>+<textsize name="footnote" value="\footnotesize"/>+<textsize name="tiny" value="\tiny"/>+<symbolsize name="small" value="2"/>+<symbolsize name="tiny" value="1.1"/>+<symbolsize name="large" value="5"/>+<arrowsize name="small" value="5"/>+<arrowsize name="tiny" value="3"/>+<arrowsize name="large" value="10"/>+<gridsize name="4 pts" value="4"/>+<gridsize name="8 pts (~3 mm)" value="8"/>+<gridsize name="16 pts (~6 mm)" value="16"/>+<gridsize name="32 pts (~12 mm)" value="32"/>+<gridsize name="10 pts (~3.5 mm)" value="10"/>+<gridsize name="20 pts (~7 mm)" value="20"/>+<gridsize name="14 pts (~5 mm)" value="14"/>+<gridsize name="28 pts (~10 mm)" value="28"/>+<gridsize name="56 pts (~20 mm)" value="56"/>+<anglesize name="90 deg" value="90"/>+<anglesize name="60 deg" value="60"/>+<anglesize name="45 deg" value="45"/>+<anglesize name="30 deg" value="30"/>+<anglesize name="22.5 deg" value="22.5"/>+<symbol name="mark/circle(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e+</path></symbol>+<symbol name="mark/disk(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+</path></symbol>+<symbol name="mark/fdisk(sfx)" transformations="translations">+<group><path fill="sym-fill">+0.5 0 0 0.5 0 0 e+</path><path fill="sym-stroke" fillrule="eofill">+0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e+</path></group></symbol>+<symbol name="mark/box(sx)" transformations="translations">+<path fill="sym-stroke" fillrule="eofill">+-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</path></symbol>+<symbol name="mark/square(sx)" transformations="translations">+<path fill="sym-stroke">+-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h</path></symbol>+<symbol name="mark/fsquare(sfx)" transformations="translations">+<group><path fill="sym-fill">+-0.5 -0.5 m 0.5 -0.5 l 0.5 0.5 l -0.5 0.5 l h</path>+<path fill="sym-stroke" fillrule="eofill">+-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</path></group></symbol>+<symbol name="mark/cross(sx)" transformations="translations">+<group><path fill="sym-stroke">+-0.43 -0.57 m 0.57 0.43 l 0.43 0.57 l -0.57 -0.43 l h</path>+<path fill="sym-stroke">+-0.43 0.57 m 0.57 -0.43 l 0.43 -0.57 l -0.57 0.43 l h</path>+</group></symbol>+<symbol name="arrow/arc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/farc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/ptarc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/fptarc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/fnormal(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/pointed(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/fpointed(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/linear(spx)">+<path pen="sym-pen" stroke="sym-stroke">+-1.0 0.333 m 0 0 l -1.0 -0.333 l</path></symbol>+<symbol name="arrow/fdouble(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+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+</path></symbol>+<symbol name="arrow/double(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+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+</path></symbol>+<tiling name="falling" angle="-60" width="1" step="4"/>+<tiling name="rising" angle="30" width="1" step="4"/>+<textstyle name="center" begin="\begin{center}"+end="\end{center}"/>+<textstyle name="itemize" begin="\begin{itemize}"+end="\end{itemize}"/>+<textstyle name="item" begin="\begin{itemize}\item{}"+end="\end{itemize}"/>+</ipestyle>+
+ src/Data/Geometry/Arrangement/Draw.hs view
@@ -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
+ src/Data/Geometry/Ipe.hs view
@@ -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(..))
+ src/Data/Geometry/Ipe/Attributes.hs view
@@ -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)++--
+ src/Data/Geometry/Ipe/Color.hs view
@@ -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"
+ src/Data/Geometry/Ipe/FromIpe.hs view
@@ -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 . (:| [])
+ src/Data/Geometry/Ipe/IpeOut.hs view
@@ -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+++++--------------------------------------------------------------------------------
+ src/Data/Geometry/Ipe/Literal.hs view
@@ -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
+ src/Data/Geometry/Ipe/ParserPrimitives.hs view
@@ -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
+ src/Data/Geometry/Ipe/PathParser.hs view
@@ -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"
+ src/Data/Geometry/Ipe/Reader.hs view
@@ -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 = "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+++++-- readAttrsFromXML :: B.ByteString -> Either++-- readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double)+-- readSymAttrs = readXML testSym+-- >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)++++++-- | If we can ipeRead an ipe element, and we can ipeReadAttrs its attributes+-- we can properly read an ipe object using ipeReadObject+ipeReadObject :: ( IpeRead (i r)+ , f ~ AttrMapSym1 r, ats ~ AttributesOf i+ , RecApplicative ats+ , ReifyConstraint IpeReadAttr (Attr f) ats+ , RecAll (Attr f) ats IpeReadAttr+ , AllSatisfy IpeAttrName ats+ )+ => Proxy i -> proxy r -> Node Text Text+ -> Either ConversionError (i r :+ IpeAttributes i r)+ipeReadObject prI prR xml = (:+) <$> ipeRead xml <*> ipeReadAttrs prI prR xml+++--------------------------------------------------------------------------------+-- | Ipe read instances++instance Coordinate r => IpeRead (IpeSymbol r) where+ ipeRead (Element "use" ats _) = case lookup "pos" ats of+ Nothing -> Left "symbol without position"+ Just ps -> flip Symbol name <$> ipeReadText ps+ where+ name = fromMaybe "mark/disk(sx)" $ lookup "name" ats+ ipeRead _ = Left "symbol element expected, text found"++-- | Given a list of Nodes, try to parse all of them as a big text. If we+-- encounter anything else then text, the parsing fails.+allText :: [Node Text Text] -> Either ConversionError Text+allText = fmap T.unlines . mapM unT+ where+ unT (Text t) = Right t+ unT _ = Left "allText: Expected Text, found an Element"++instance (Coordinate r, Eq r) => IpeRead (Path r) where+ ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText+ ipeRead _ = Left "path: expected element, found text"+++lookup' :: Text -> [(Text,a)] -> Either ConversionError a+lookup' k = maybe (Left $ "lookup' " <> k <> " not found") Right . lookup k++instance Coordinate r => IpeRead (TextLabel r) where+ ipeRead (Element "text" ats chs)+ | lookup "type" ats == Just "label" = Label+ <$> allText chs+ <*> (lookup' "pos" ats >>= ipeReadText)+ | otherwise = Left "Not a Text label"+ ipeRead _ = Left "textlabel: Expected element, found text"++++instance Coordinate r => IpeRead (MiniPage r) where+ ipeRead (Element "text" ats chs)+ | lookup "type" ats == Just "minipage" = MiniPage+ <$> allText chs+ <*> (lookup' "pos" ats >>= ipeReadText)+ <*> (lookup' "width" ats >>= readCoordinate)+ | otherwise = Left "Not a MiniPage"+ ipeRead _ = Left "MiniPage: Expected element, found text"+++instance Coordinate r => IpeRead (Image r) where+ ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText)+ ipeRead _ = Left "Image: Element expected, text found"++instance (Coordinate r, Eq r) => IpeRead (IpeObject r) where+ ipeRead x = firstRight [ IpeUse <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x+ , IpePath <$> ipeReadObject (Proxy :: Proxy Path) r x+ , IpeGroup <$> ipeReadObject (Proxy :: Proxy Group) r x+ , IpeTextLabel <$> ipeReadObject (Proxy :: Proxy TextLabel) r x+ , IpeMiniPage <$> ipeReadObject (Proxy :: Proxy MiniPage) r x+ , IpeImage <$> ipeReadObject (Proxy :: Proxy Image) r x+ ]+ where+ r = Proxy :: Proxy r++firstRight :: [Either ConversionError a] -> Either ConversionError a+firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right)+++instance (Coordinate r, Eq r) => IpeRead (Group r) where+ ipeRead (Element "group" _ chs) = Right . Group . rights . map ipeRead $ chs+ ipeRead _ = Left "ipeRead Group: expected Element, found Text"+++instance IpeRead LayerName where+ ipeRead (Element "layer" ats _) = LayerName <$> lookup' "name" ats+ ipeRead _ = Left "layer: Expected element, found text"++instance IpeRead View where+ ipeRead (Element "view" ats _) = (\lrs a -> View (map LayerName $ T.words lrs) a)+ <$> lookup' "layers" ats+ <*> (lookup' "active" ats >>= ipeReadText)+ ipeRead _ = Left "View Expected element, found text"+++-- TODO: this instance throws away all of our error collecting (and is pretty+-- slow/stupid since it tries parsing all children with all parsers)+instance (Coordinate r, Eq r) => IpeRead (IpePage r) where+ ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs)+ ipeRead _ = Left "page: Element expected, text found"+ -- withDef :: b -> Either a b -> Either c b+ -- withDef d = either (const $ Right d) Right++ -- readLayers = withDef ["alpha"] . readAll+ -- readViews = withDef [] . readAll+ -- readObjects = withDef [] . readAll++-- | try reading everything as an a. Throw away whatever fails.+readAll :: IpeRead a => [Node Text Text] -> [a]+readAll = rights . map ipeRead+++instance (Coordinate r, Eq r) => IpeRead (IpeFile r) where+ ipeRead (Element "ipe" _ chs) = case readAll chs of+ [] -> Left "Ipe: no pages found"+ pgs -> Right $ IpeFile Nothing [] (NE.fromList pgs)+ ipeRead _ = Left "Ipe: Element expected, text found"++++++--------------------------------------------------------------------------------
+ src/Data/Geometry/Ipe/Types.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Geometry.Ipe.Types+-- Copyright : (C) Frank Staals+-- License : see the LICENSE file+-- Maintainer : Frank Staals+--+-- Data type modeling the various elements in Ipe files.+--+--------------------------------------------------------------------------------+module Data.Geometry.Ipe.Types 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++ 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]+++--------------------------------------------------------------------------------+-- | 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)++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++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)+++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]++--------------------------------------------------------------------------------+++-- | The definition of a view+-- make active layer into an index ?+data View = View { _layerNames :: [LayerName]+ , _activeLayer :: LayerName+ }+ deriving (Eq, Ord, Show)+makeLenses ''View++-- instance Default+++-- | for now we pretty much ignore these+data IpeStyle = IpeStyle { _styleName :: Maybe Text+ , _styleData :: Node Text Text+ }+ deriving (Eq,Show)+makeLenses ''IpeStyle+++basicIpeStyle :: IpeStyle+basicIpeStyle = IpeStyle (Just "basic") (xmlLiteral [litFile|resources/basic.isy|])+++-- | The maybe string is the encoding+data IpePreamble = IpePreamble { _encoding :: Maybe Text+ , _preambleData :: Text+ }+ deriving (Eq,Read,Show,Ord)+makeLenses ''IpePreamble++type IpeBitmap = Text++++--------------------------------------------------------------------------------+-- Ipe Pages++-- | An IpePage is essentially a Group, together with a list of layers and a+-- list of views.+data IpePage r = IpePage { _layers :: [LayerName]+ , _views :: [View]+ , _content :: [IpeObject r]+ }+ deriving (Eq,Show)+makeLenses ''IpePage++-- | Creates a simple page with no views.+fromContent :: [IpeObject r] -> IpePage r+fromContent obs = IpePage layers' [] obs+ where+ layers' = mapMaybe (^.commonAttributes.attrLens SLayer) obs++-- | A complete ipe file+data IpeFile r = IpeFile { _preamble :: Maybe IpePreamble+ , _styles :: [IpeStyle]+ , _pages :: NE.NonEmpty (IpePage r)+ }+ deriving (Eq,Show)+makeLenses ''IpeFile++-- | Convenience function to construct an ipe file consisting of a single page.+singlePageFile :: IpePage r -> IpeFile r+singlePageFile p = IpeFile Nothing [basicIpeStyle] (p 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
+ src/Data/Geometry/Ipe/Value.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Geometry.Ipe.Value+-- Copyright : (C) Frank Staals+-- License : see the LICENSE file+-- Maintainer : Frank Staals+--+-- Data type for representing values in ipe.+--+--------------------------------------------------------------------------------+module Data.Geometry.Ipe.Value where++import GHC.Exts+import Data.Text++--------------------------------------------------------------------------------++-- | Many types either consist of a symbolc value, or a value of type v+data IpeValue v = Named Text | Valued v+ deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable)++instance IsString (IpeValue v) where+ fromString = Named . fromString
+ src/Data/Geometry/Ipe/Writer.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Geometry.Ipe.Writer+-- Copyright : (C) Frank Staals+-- License : see the LICENSE file+-- Maintainer : Frank Staals+-- Description : Converting data types into IpeTypes+--+--------------------------------------------------------------------------------+module Data.Geometry.Ipe.Writer where++import Control.Lens ((^.), (^..), (.~), (&))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C+import Data.Colour.SRGB (RGB(..))+import Data.Ext+import Data.Fixed+import qualified Data.Foldable as F+import Data.Geometry.Box+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.Value+import Data.Geometry.LineSegment+import Data.Geometry.Point+import Data.Geometry.PolyLine+import Data.Geometry.Polygon (Polygon, outerBoundary, holeList, asSimplePolygon)+import qualified Data.Geometry.Transformation as GT+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.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+import Data.Vinyl.TypeLevel+import System.IO (hPutStrLn,stderr)+import Text.XML.Expat.Format (format')+import Text.XML.Expat.Tree++--------------------------------------------------------------------------------++-- | Given a prism to convert something of type g into an ipe file, a file path,+-- and a g. Convert the geometry and write it to file.++-- writeIpe :: ( RecAll (Page r) gs IpeWrite+-- , IpeWriteText r+-- ) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO ()+-- writeIpe p fp g = writeIpeFile (p # g) fp++-- | Write an IpeFiele to file.+writeIpeFile :: IpeWriteText r => FilePath -> IpeFile r -> IO ()+writeIpeFile = flip writeIpeFile'++-- | Creates a single page ipe file with the given page+writeIpePage :: IpeWriteText r => FilePath -> IpePage r -> IO ()+writeIpePage fp = writeIpeFile fp . singlePageFile+++-- | Convert the input to ipeXml, and prints it to standard out in such a way+-- that the copied text can be pasted into ipe as a geometry object.+printAsIpeSelection :: IpeWrite t => t -> IO ()+printAsIpeSelection = C.putStrLn . fromMaybe "" . toIpeSelectionXML++-- | Convert input into an ipe selection.+toIpeSelectionXML :: IpeWrite t => t -> Maybe B.ByteString+toIpeSelectionXML = fmap (format' . ipeSelection) . ipeWrite+ where+ ipeSelection x = Element "ipeselection" [] [x]+++-- | Convert to Ipe xml+toIpeXML :: IpeWrite t => t -> Maybe B.ByteString+toIpeXML = fmap format' . ipeWrite+++-- | Convert to ipe XML and write the output to a file.+writeIpeFile' :: IpeWrite t => t -> FilePath -> IO ()+writeIpeFile' i fp = maybe err (B.writeFile fp) . toIpeXML $ i+ where+ err = hPutStrLn stderr $+ "writeIpeFile: error converting to xml. File '" <> fp <> "'not written"++--------------------------------------------------------------------------------++-- | For types that can produce a text value+class IpeWriteText t where+ ipeWriteText :: t -> Maybe Text++-- | Types that correspond to an XML Element. All instances should produce an+-- Element. If the type should produce a Node with the Text constructor, use+-- the `IpeWriteText` typeclass instead.+class IpeWrite t where+ ipeWrite :: t -> Maybe (Node Text Text)++instance IpeWrite t => IpeWrite [t] where+ ipeWrite gs = case mapMaybe ipeWrite gs of+ [] -> Nothing+ ns -> (Just $ Element "group" [] ns)++instance (IpeWrite l, IpeWrite r) => IpeWrite (Either l r) where+ ipeWrite = either ipeWrite ipeWrite++instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where+ ipeWriteText att = _getAttr att >>= ipeWriteText++instance (IpeWriteText l, IpeWriteText r) => IpeWriteText (Either l r) where+ ipeWriteText = either ipeWriteText ipeWriteText+++-- | Functon to write all attributes in a Rec+ipeWriteAttrs :: ( RecordToList rs, RMap rs+ , ReifyConstraint IpeWriteText (Attr f) rs+ , AllSatisfy IpeAttrName rs+ , RecAll (Attr f) rs IpeWriteText+ ) => IA.Attributes f rs -> [(Text,Text)]+ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames r)+ (writeAttrValues r)+ where+ f (Const n) (Const mv) = Const $ (n,) <$> mv++-- | Writing the attribute values+writeAttrValues :: ( RMap rs, ReifyConstraint IpeWriteText f rs+ , RecAll f rs IpeWriteText)+ => Rec f rs -> Rec (Const (Maybe Text)) rs+writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x)+ . reifyConstraint @IpeWriteText+++instance IpeWriteText Text where+ ipeWriteText = Just++-- | Add attributes to a node+addAtts :: Node Text Text -> [(Text,Text)] -> Node Text Text+n `addAtts` ats = n { eAttributes = ats ++ eAttributes n }++-- | Same as `addAtts` but then for a Maybe node+mAddAtts :: Maybe (Node Text Text) -> [(Text, Text)] -> Maybe (Node Text Text)+mn `mAddAtts` ats = fmap (`addAtts` ats) mn+++--------------------------------------------------------------------------------++instance IpeWriteText Double where+ ipeWriteText = writeByShow++instance IpeWriteText Int where+ ipeWriteText = writeByShow++instance IpeWriteText Integer where+ ipeWriteText = writeByShow++instance HasResolution p => IpeWriteText (Fixed p) where+ ipeWriteText = writeByShow++-- | This instance converts the ratio to a Pico, and then displays that.+instance Integral a => IpeWriteText (Ratio a) where+ ipeWriteText = ipeWriteText . f . fromRational . toRational+ where+ f :: Pico -> Pico+ f = id++writeByShow :: Show t => t -> Maybe Text+writeByShow = ipeWriteText . T.pack . show++unwords' :: [Maybe Text] -> Maybe Text+unwords' = fmap T.unwords . sequence++unlines' :: [Maybe Text] -> Maybe Text+unlines' = fmap T.unlines . sequence+++instance IpeWriteText r => IpeWriteText (Point 2 r) where+ ipeWriteText (Point2 x y) = unwords' [ipeWriteText x, ipeWriteText y]+++--------------------------------------------------------------------------------++instance IpeWriteText v => IpeWriteText (IpeValue v) where+ ipeWriteText (Named t) = ipeWriteText t+ ipeWriteText (Valued v) = ipeWriteText v++instance IpeWriteText TransformationTypes where+ ipeWriteText Affine = Just "affine"+ ipeWriteText Rigid = Just "rigid"+ ipeWriteText Translations = Just "translations"++instance IpeWriteText PinType where+ ipeWriteText No = Nothing+ ipeWriteText Yes = Just "yes"+ ipeWriteText Horizontal = Just "h"+ ipeWriteText Vertical = Just "v"++instance IpeWriteText r => IpeWriteText (RGB r) where+ ipeWriteText (RGB r g b) = unwords' . map ipeWriteText $ [r,g,b]++deriving instance IpeWriteText r => IpeWriteText (IpeSize r)+deriving instance IpeWriteText r => IpeWriteText (IpePen r)+deriving instance IpeWriteText r => IpeWriteText (IpeColor r)++instance IpeWriteText r => IpeWriteText (IpeDash r) where+ ipeWriteText (DashNamed t) = Just t+ ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "["+ , Text.intercalate " " ts+ , "] ", t ])+ <$> mapM ipeWriteText xs+ <*> ipeWriteText x++instance IpeWriteText FillType where+ ipeWriteText Wind = Just "wind"+ ipeWriteText EOFill = Just "eofill"++instance IpeWriteText r => IpeWriteText (IpeArrow r) where+ ipeWriteText (IpeArrow n s) = (\n' s' -> n' <> "/" <> s') <$> ipeWriteText n+ <*> ipeWriteText s++instance IpeWriteText r => IpeWriteText (Path r) where+ ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . _pathSegments+ where+ concat' = F.foldr1 (\t t' -> t <> "\n" <> t')+++--------------------------------------------------------------------------------+instance IpeWriteText r => IpeWrite (IpeSymbol r) where+ ipeWrite (Symbol p n) = f <$> ipeWriteText p+ where+ f ps = Element "use" [ ("pos", ps)+ , ("name", n)+ ] []++-- instance IpeWriteText (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]+ where+ (Vector3 r1 r2 _) = m++ (Vector3 a c e) = ipeWriteText <$> r1+ (Vector3 b d f) = ipeWriteText <$> r2+ -- TODO: The third row should be (0,0,1) I guess.+++instance IpeWriteText r => IpeWriteText (Operation r) where+ ipeWriteText (MoveTo p) = unwords' [ ipeWriteText p, Just "m"]+ ipeWriteText (LineTo p) = unwords' [ ipeWriteText p, Just "l"]+ ipeWriteText (CurveTo p q r) = unwords' [ ipeWriteText p+ , ipeWriteText q+ , ipeWriteText r, Just "c"]+ ipeWriteText (QCurveTo p q) = unwords' [ ipeWriteText p+ , ipeWriteText q, Just "q"]+ ipeWriteText (Ellipse m) = unwords' [ ipeWriteText m, Just "e"]+ ipeWriteText (ArcTo m p) = unwords' [ ipeWriteText m+ , ipeWriteText p, Just "a"]+ ipeWriteText (Spline pts) = unlines' $ map ipeWriteText pts <> [Just "s"]+ ipeWriteText (ClosedSpline pts) = unlines' $ map ipeWriteText pts <> [Just "u"]+ ipeWriteText ClosePath = Just "h"+++instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where+ ipeWriteText pl = case pl^..points.traverse.core of+ (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest+ _ -> error "ipeWriteText. absurd. no vertices polyline"+ -- the polyline type guarantees that there is at least one point++instance IpeWriteText r => IpeWriteText (Polygon t () r) where+ ipeWriteText pg = fmap mconcat . traverse f $ asSimplePolygon pg : holeList pg+ where+ f pg' = case pg'^..outerBoundary.traverse.core of+ (p : rest) -> unlines' . map ipeWriteText+ $ MoveTo p : map LineTo rest ++ [ClosePath]+ _ -> Nothing+ -- TODO: We are not really guaranteed that there is at least one point, it would+ -- be nice if the type could guarantee that.+++instance IpeWriteText r => IpeWriteText (PathSegment r) where+ ipeWriteText (PolyLineSegment p) = ipeWriteText p+ ipeWriteText (PolygonPath p) = ipeWriteText p+ ipeWriteText (EllipseSegment m) = ipeWriteText $ Ellipse m+ ipeWriteText _ = error "ipeWriteText: PathSegment, not implemented yet."++instance IpeWriteText r => IpeWrite (Path r) where+ ipeWrite p = (\t -> Element "path" [] [Text t]) <$> ipeWriteText p++--------------------------------------------------------------------------------+++instance (IpeWriteText r) => IpeWrite (Group r) where+ ipeWrite (Group gs) = ipeWrite gs+++instance ( AllSatisfy IpeAttrName rs+ , RecordToList rs, RMap rs+ , ReifyConstraint IpeWriteText (Attr f) rs+ , RecAll (Attr f) rs IpeWriteText+ , IpeWrite g+ ) => IpeWrite (g :+ IA.Attributes f rs) where+ ipeWrite (g :+ ats) = ipeWrite g `mAddAtts` ipeWriteAttrs ats+++instance IpeWriteText r => IpeWrite (MiniPage r) where+ ipeWrite (MiniPage t p w) = (\pt wt ->+ Element "text" [ ("pos", pt)+ , ("type", "minipage")+ , ("width", wt)+ ] [Text t]+ ) <$> ipeWriteText p+ <*> ipeWriteText w++instance IpeWriteText r => IpeWrite (Image r) where+ ipeWrite (Image d (Box a b)) = (\dt p q ->+ Element "image" [("rect", p <> " " <> q)] [Text dt]+ )+ <$> ipeWriteText d+ <*> ipeWriteText (a^.core.cwMin)+ <*> ipeWriteText (b^.core.cwMax)++-- TODO: Replace this one with s.t. that writes the actual image payload+instance IpeWriteText () where+ ipeWriteText () = Nothing++instance IpeWriteText r => IpeWrite (TextLabel r) where+ ipeWrite (Label t p) = (\pt ->+ Element "text" [("pos", pt)+ ,("type", "label")+ ] [Text t]+ ) <$> ipeWriteText p+++instance (IpeWriteText r) => IpeWrite (IpeObject r) where+ ipeWrite (IpeGroup g) = ipeWrite g+ ipeWrite (IpeImage i) = ipeWrite i+ ipeWrite (IpeTextLabel l) = ipeWrite l+ ipeWrite (IpeMiniPage m) = ipeWrite m+ ipeWrite (IpeUse s) = ipeWrite s+ ipeWrite (IpePath p) = ipeWrite p+++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++instance IpeWrite LayerName where+ ipeWrite (LayerName n) = Just $ Element "layer" [("name",n)] []++instance IpeWrite View where+ ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls)+ , ("active", _layerName act)+ ] []+ where+ ls = T.unwords . map _layerName $ lrs++instance (IpeWriteText r) => IpeWrite (IpePage r) where+ ipeWrite (IpePage lrs vs objs) = Just .+ Element "page" [] . catMaybes . concat $+ [ map ipeWrite lrs+ , map ipeWrite vs+ , map ipeWrite objs+ ]+++instance IpeWrite IpeStyle where+ ipeWrite (IpeStyle _ xml) = Just xml+++instance IpeWrite IpePreamble where+ ipeWrite (IpePreamble _ latex) = Just $ Element "preamble" [] [Text latex]+ -- TODO: I probably want to do something with the encoding ....++instance (IpeWriteText r) => IpeWrite (IpeFile r) where+ ipeWrite (IpeFile mp ss pgs) = Just $ Element "ipe" ipeAtts chs+ where+ ipeAtts = [("version","70005"),("creator", "HGeometry")]+ chs = mconcat [ catMaybes [mp >>= ipeWrite]+ , mapMaybe ipeWrite ss+ , mapMaybe ipeWrite . F.toList $ pgs+ ]+++++--------------------------------------------------------------------------------++instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where+ ipeWrite p = ipeWrite path+ where+ path = fromPolyLine $ p & points.traverse.extra .~ ()+ -- TODO: Do something with the p's++fromPolyLine :: PolyLine 2 () r -> Path r+fromPolyLine = Path . LSeq.fromNonEmpty . (:| []) . PolyLineSegment+++instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where+ ipeWrite (LineSegment' p q) = ipeWrite . fromPolyLine . fromPoints . 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+-- )
+ src/Data/Geometry/PlanarSubdivision/Draw.hs view
@@ -0,0 +1,54 @@+module Data.Geometry.PlanarSubdivision.Draw where++import Control.Lens+import Data.Ext+import Data.Geometry.Ipe+import Data.Geometry.LineSegment+import Data.Geometry.PlanarSubdivision+import Data.Geometry.Polygon+import Data.Maybe (mapMaybe)+import qualified Data.Vector as V+++drawColoredPlanarSubdivision :: IpeOut (PlanarSubdivision s v e (Maybe (IpeColor r)) r)+ Group r+drawColoredPlanarSubdivision ps = drawPlanarSubdivision+ (ps&vertexData.traverse .~ Just mempty+ &dartData.traverse._2 .~ Just mempty+ &faceData.traverse %~ fmap (attr SFill)+ )++-- | Draws only the values for which we have a Just attribute+drawPlanarSubdivision :: forall s r.+ IpeOut (PlanarSubdivision s (Maybe (IpeAttributes IpeSymbol r))+ (Maybe (IpeAttributes Path r))+ (Maybe (IpeAttributes Path r))+ r) Group r+drawPlanarSubdivision = drawPlanarSubdivisionWith fv fe ff+ where+ fv :: (VertexId' s, VertexData r (Maybe (IpeAttributes IpeSymbol r)))+ -> Maybe (IpeObject' IpeSymbol r)+ fv (_,VertexData p ma) = (\a -> defIO p ! a) <$> ma -- draws a point+ fe (_,s :+ ma) = (\a -> defIO s ! a) <$> ma -- draw segment+ ff (_,f :+ ma) = (\a -> defIO f ! a) <$> ma -- draw a face+++-- | Draw everything using the defaults+drawPlanarSubdivision' :: forall s v e f r. IpeOut (PlanarSubdivision s v e f r) Group r+drawPlanarSubdivision' ps = drawPlanarSubdivision+ (ps&vertexData.traverse .~ Just (mempty :: IpeAttributes IpeSymbol r)+ &dartData.traverse._2 .~ Just (mempty :: IpeAttributes Path r)+ &faceData.traverse .~ Just (mempty :: IpeAttributes Path r))++type MIO g i r = g -> Maybe (IpeObject' i r)++drawPlanarSubdivisionWith :: (ToObject vi, ToObject ei, ToObject fi)+ => MIO (VertexId' s, VertexData r v) vi r+ -> MIO (Dart s, LineSegment 2 v r :+ e) ei r+ -> MIO (FaceId' s, SomePolygon v r :+ f) fi r+ -> IpeOut (PlanarSubdivision s v e f r) Group r+drawPlanarSubdivisionWith fv fe ff g = ipeGroup . concat $ [vs, es, fs]+ where+ vs = mapMaybe (fmap iO . fv) . V.toList . vertices $ g+ es = mapMaybe (fmap iO . fe) . V.toList . edgeSegments $ g+ fs = mapMaybe (fmap iO . ff) . V.toList . rawFacePolygons $ g
+ src/Data/Geometry/Triangulation/Draw.hs view
@@ -0,0 +1,14 @@+module Data.Geometry.Triangulation.Draw where++import Algorithms.Geometry.DelaunayTriangulation.Types+import Data.Geometry.LineSegment+import Data.Geometry.Ipe++--------------------------------------------------------------------------------++-- | Draws a triangulation+drawTriangulation :: IpeOut (Triangulation p r) Group r+drawTriangulation tr =+ ipeGroup [ iO $ ipeLineSegment e+ | e <- map (uncurry ClosedLineSegment) . triangulationEdges $ tr+ ]
+ src/Data/PlaneGraph/Draw.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.PlaneGraph.Draw where++import Data.Ext+import Data.Geometry.Ipe+import Data.Geometry.Properties+import Data.Geometry.LineSegment+import Data.Geometry.Point+import Data.Geometry.Polygon+import Data.Maybe (catMaybes)+import Data.PlaneGraph+import qualified Data.Vector as V++--------------------------------------------------------------------------------++-- | Draws a planegraph using Marks, LineSegments, and simple polygons for+-- vertices, edges, and faces, respectively. Uses the default IpeOuts to draw+-- these elements.+drawPlaneGraph :: forall s v e f r. IpeOut (PlaneGraph s v e f r) Group r+drawPlaneGraph = drawPlaneGraphWith defIO' defIO' defIO'+ where+ defIO' :: (HasDefaultIpeOut g, NumType g ~ r) => g -> _x -> Maybe (IpeObject r)+ defIO' p _ = Just . iO $ defIO p++-- | Draws a planegraph using Marks, LineSegments, and simple polygons for+-- vertices, edges, and faces, respectively.+drawPlaneGraphWith :: (Point 2 r -> v -> Maybe (IpeObject r))+ -> (LineSegment 2 v r -> e -> Maybe (IpeObject r))+ -> (SimplePolygon v r -> f -> Maybe (IpeObject r))+ -> IpeOut (PlaneGraph s v e f r) Group r+drawPlaneGraphWith vF eF fF g = ipeGroup $ concatMap (catMaybes . V.toList) [vs, es, fs]+ where+ vs = (\(_,VertexData p v) -> vF p v) <$> vertices g+ es = (\(_,s :+ e) -> eF s e) <$> edgeSegments g+ fs = (\(_,p :+ f) -> fF p f) <$> rawFacePolygons g+++-- | Draw a planegraph using the given functions. Fully generic in how we draw+-- the objects.+genericDrawPlaneGraphWith :: (VertexId' s :+ v -> IpeObject r)+ -> (Dart s :+ e -> IpeObject r)+ -> (FaceId' s :+ f -> IpeObject r)+ -> IpeOut (PlaneGraph s v e f r) Group r+genericDrawPlaneGraphWith vF eF fF g = ipeGroup $ concatMap V.toList [vs, es, fs]+ where+ vs = (\(v,VertexData _ x) -> vF $ v :+ x) <$> vertices g+ es = wrap eF <$> edges g+ fs = wrap fF <$> faces g++ wrap f (a,b) = f $ a :+ b
+ src/Data/Tree/Draw.hs view
@@ -0,0 +1,17 @@+module Data.Tree.Draw where++import Data.Ext+import Data.Geometry.LineSegment+import Data.Geometry.Point+import Data.Geometry.Ipe+import Data.Tree++--------------------------------------------------------------------------------++-- | Draws a tree+drawTree' :: IpeOut (Tree (Point 2 r :+ p)) Group r+drawTree' = ipeGroup . map (iO . defIO . uncurry ClosedLineSegment) . treeEdges+++treeEdges :: Tree a -> [(a,a)]+treeEdges (Node v chs) = map ((v,) . rootLabel) chs ++ concatMap treeEdges chs
+ test/Data/Geometry/Ipe/ReaderSpec.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Geometry.Ipe.ReaderSpec where++import Test.Hspec+import Data.Ext+import Data.Geometry+import Data.Geometry.Ipe+import Data.ByteString(ByteString)+import Data.Proxy+++-- | specializes to use Double as Numtype+fromIpeXML' :: IpeRead (t Double) => ByteString -> Either ConversionError (t Double)+fromIpeXML' = fromIpeXML+++spec :: Spec+spec = do+ describe "IpeReadText" $ do+ it "parses a polyline into a Path" $+ ipeReadText "\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n"+ `shouldBe` Right ops+ describe "IpeReadAttrs" $ do+ it "parses a symbols attributes" $+ (show $ readXML useTxt+ >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double))+ `shouldBe`+ "Right (Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named \"black\"), NoAttr, NoAttr, Attr IpeSize (Named \"normal\")})"+ describe "IpeRead" $ do+ it "parses a Symbol" $+ fromIpeXML' useTxt+ `shouldBe` Right useSym+ -- it "parses a path" $+ -- (show $ fromIpeXML'+ -- "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+-- )+ -- `shouldBe`+-- "Right (Path {_pathSegments = PolyLineSegment (PolyLine {_points = Seq2 (Point2 [128.0,656.0] :+ ()) (fromList [Point2 [224.0,768.0] :+ (),Point2 [304.0,624.0] :+ ()]) (Point2 [432.0,752.0] :+ ())}) :< fromList []})"+++ where+ useTxt = "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+ useSym = Symbol (point2 320 736) "mark/disk(sx)"+-- symAttrs =++ translatedUse = "<use matrix=\"1 0 0 1 4.44908 -4.21815\" name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+++++ ops = [ MoveTo $ point2 128 (656 :: Double)+ , LineTo $ point2 224 768+ , LineTo $ point2 304 624+ , LineTo $ point2 432 752+ ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}