hgeometry-ipe-0.9.0.0: src/Data/Geometry/Ipe/Types.hs
{-# 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