{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Ipe.Draw
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Class and setup for rendering/drawing
--
--------------------------------------------------------------------------------
module Ipe.Draw
  ( Rendered
  , Attr
  , IsDrawable(..)

  -- * The Ipe backend
  , Ipe
  ) where

import HGeometry.Ext
import HGeometry.Point
import Control.Lens
import Data.Kind (Type)
import Ipe.Types
import Ipe.FromIpe
import Ipe.IpeOut
import Ipe.Attributes
import HGeometry.Polygon
import HGeometry.Vector
import HGeometry.PolyLine
import HGeometry.BezierSpline
import HGeometry.LineSegment
import HGeometry.Triangle
import Data.List.NonEmpty (NonEmpty)

--------------------------------------------------------------------------------

-- | The type of objects a backend renders
type family Rendered backend :: Type


-- | An Attribute Assignment
type Attr backend geom = AttrOf backend geom -> AttrOf backend geom

-- | A class that expresses that something is drawable using a particular backend
class ( Monoid (Rendered backend)
      ) => IsDrawable backend geom where

  -- | A GADT that expresses possible attributes for a particular object
  type AttrOf backend geom :: Type

  -- | Draw some objects
  draw :: [Attr backend geom] -> geom -> Rendered backend

instance ( IsDrawable backend a
         ) => IsDrawable backend (NonEmpty a) where
  type AttrOf backend (NonEmpty a) = AttrOf backend a
  draw :: [Attr backend (NonEmpty a)] -> NonEmpty a -> Rendered backend
draw [Attr backend (NonEmpty a)]
ats = (a -> Rendered backend) -> NonEmpty a -> Rendered backend
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @backend [Attr backend a]
[Attr backend (NonEmpty a)]
ats)

instance ( IsDrawable backend a
         ) => IsDrawable backend [a] where
  type AttrOf backend [a] = AttrOf backend a
  draw :: [Attr backend [a]] -> [a] -> Rendered backend
draw [Attr backend [a]]
ats = (a -> Rendered backend) -> [a] -> Rendered backend
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @backend [Attr backend a]
[Attr backend [a]]
ats)

instance ( Point_ vertex 2 r, Num r
         , IsDrawable backend (SimplePolygonF f vertex)
         , VertexContainer f vertex
         , Monoid (Rendered backend)
         ) => IsDrawable backend (ConvexPolygonF f vertex) where
  type AttrOf backend (ConvexPolygonF f vertex) = AttrOf backend (SimplePolygonF f vertex)
  draw :: [Attr backend (ConvexPolygonF f vertex)]
-> ConvexPolygonF f vertex -> Rendered backend
draw [Attr backend (ConvexPolygonF f vertex)]
ats ConvexPolygonF f vertex
poly = forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @backend [Attr backend (SimplePolygonF f vertex)]
[Attr backend (ConvexPolygonF f vertex)]
ats (ConvexPolygonF f vertex -> SimplePolygonF f vertex
forall {k} (f :: k -> *) (point :: k).
ConvexPolygonF f point -> SimplePolygonF f point
toSimplePolygon ConvexPolygonF f vertex
poly)

instance ( Point_ corner 2 r, Num r
         , IsDrawable backend (SimplePolygon corner)
         , Monoid (Rendered backend)
         ) => IsDrawable backend (Triangle corner) where
  type AttrOf backend (Triangle corner) = AttrOf backend (SimplePolygon corner)
  draw :: [Attr backend (Triangle corner)]
-> Triangle corner -> Rendered backend
draw [Attr backend (Triangle corner)]
ats Triangle corner
tri = forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @backend [Attr backend (Triangle corner)]
[Attr backend (SimplePolygon corner)]
ats (Triangle corner -> SimplePolygon corner
forall simplePolygon point r (f :: * -> *).
(SimplePolygon_ simplePolygon point r, Foldable1 f) =>
f point -> simplePolygon
forall (f :: * -> *).
Foldable1 f =>
f corner -> SimplePolygon corner
uncheckedFromCCWPoints Triangle corner
tri :: SimplePolygon corner)
  -- if we can draw a simple polygon we can draw a 2d triangle

--------------------------------------------------------------------------------
-- * Ipe Backend utils

-- | The Ipe backend
type data Ipe (r :: Type)

type instance Rendered (Ipe r) = [IpeObject r]

instance IsDrawable (Ipe r) (IpeObject r) where
  type AttrOf (Ipe r) (IpeObject r) = CommonAttributes r Maybe
  draw :: [Attr (Ipe r) (IpeObject r)] -> IpeObject r -> Rendered (Ipe r)
draw [Attr (Ipe r) (IpeObject r)]
ats IpeObject r
o = [ (IpeObject r
 -> (CommonAttributes r Maybe -> CommonAttributes r Maybe)
 -> IpeObject r)
-> IpeObject r
-> [CommonAttributes r Maybe -> CommonAttributes r Maybe]
-> IpeObject r
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IpeObject r
o' CommonAttributes r Maybe -> CommonAttributes r Maybe
f -> IpeObject r
o'IpeObject r -> (IpeObject r -> IpeObject r) -> IpeObject r
forall a b. a -> (a -> b) -> b
&(CommonAttributes r Maybe -> Identity (CommonAttributes r Maybe))
-> IpeObject r -> Identity (IpeObject r)
forall c r (f :: * -> *).
HasCommonAttributes c r f =>
Lens' c (CommonAttributes r f)
Lens' (IpeObject r) (CommonAttributes r Maybe)
commonAttributes ((CommonAttributes r Maybe -> Identity (CommonAttributes r Maybe))
 -> IpeObject r -> Identity (IpeObject r))
-> (CommonAttributes r Maybe -> CommonAttributes r Maybe)
-> IpeObject r
-> IpeObject r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ CommonAttributes r Maybe -> CommonAttributes r Maybe
f) IpeObject r
o [CommonAttributes r Maybe -> CommonAttributes r Maybe]
[Attr (Ipe r) (IpeObject r)]
ats ]

instance IsDrawable (Ipe r) (Path r) where
  type AttrOf (Ipe r) (Path r) = PathAttributes r
  draw :: [Attr (Ipe r) (Path r)] -> Path r -> Rendered (Ipe r)
draw [Attr (Ipe r) (Path r)]
ats Path r
p = [ IpeObject' Path r -> IpeObject r
forall r. IpeObject' Path r -> IpeObject r
IpePath (Path r
p Path r -> PathAttributes r -> Path r :+ PathAttributes r
forall core extra. core -> extra -> core :+ extra
:+ [PathAttributes r -> PathAttributes r] -> PathAttributes r
forall at. Default at => [at -> at] -> at
mkAttrs [PathAttributes r -> PathAttributes r]
[Attr (Ipe r) (Path r)]
ats) ]

instance IsDrawable (Ipe r) (IpeSymbol r) where
  type AttrOf (Ipe r) (IpeSymbol r) = SymbolAttributes r
  draw :: [Attr (Ipe r) (IpeSymbol r)] -> IpeSymbol r -> Rendered (Ipe r)
draw [Attr (Ipe r) (IpeSymbol r)]
ats IpeSymbol r
p = [ IpeObject' IpeSymbol r -> IpeObject r
forall r. IpeObject' IpeSymbol r -> IpeObject r
IpeUse (IpeSymbol r
p IpeSymbol r
-> SymbolAttributes r -> IpeSymbol r :+ SymbolAttributes r
forall core extra. core -> extra -> core :+ extra
:+ [SymbolAttributes r -> SymbolAttributes r] -> SymbolAttributes r
forall at. Default at => [at -> at] -> at
mkAttrs [SymbolAttributes r -> SymbolAttributes r]
[Attr (Ipe r) (IpeSymbol r)]
ats) ]

instance ( Point_ vertex 2 r, VertexContainer f vertex, Num r
         ) => IsDrawable (Ipe r) (SimplePolygonF f vertex) where
  type AttrOf (Ipe r) (SimplePolygonF f vertex) = PathAttributes r
  draw :: [Attr (Ipe r) (SimplePolygonF f vertex)]
-> SimplePolygonF f vertex -> Rendered (Ipe r)
draw [Attr (Ipe r) (SimplePolygonF f vertex)]
ats SimplePolygonF f vertex
pg = forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @(Ipe r) [Attr (Ipe r) (SimplePolygonF f vertex)]
[Attr (Ipe r) (Path r)]
ats (AReview
  (Path r) (SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r))
-> SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r) -> Path r
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview
  (Path r) (SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r))
forall (f :: * -> *) r.
Foldable1 f =>
Prism
  (Path r)
  (Path r)
  (SimplePolygon (Point 2 r))
  (SimplePolygonF f (Point 2 r))
Prism
  (Path r)
  (Path r)
  (SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r))
  (SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r))
_asSimplePolygon SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r)
pg')
    where
      pg' :: SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r)
pg' = NonEmpty (Point 2 r)
-> SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r)
forall simplePolygon point r (f :: * -> *).
(SimplePolygon_ simplePolygon point r, Foldable1 f) =>
f point -> simplePolygon
forall (f :: * -> *).
Foldable1 f =>
f (Point 2 r) -> SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r)
uncheckedFromCCWPoints (NonEmpty (Point 2 r)
 -> SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r))
-> NonEmpty (Point 2 r)
-> SimplePolygonF (Cyclic NonEmptyVector) (Point 2 r)
forall a b. (a -> b) -> a -> b
$ Getting
  (NonEmptyDList (Point 2 r)) (SimplePolygonF f vertex) (Point 2 r)
-> SimplePolygonF f vertex -> NonEmpty (Point 2 r)
forall a s. Getting (NonEmptyDList a) s a -> s -> NonEmpty a
toNonEmptyOf ((vertex -> Const (NonEmptyDList (Point 2 r)) vertex)
-> SimplePolygonF f vertex
-> Const (NonEmptyDList (Point 2 r)) (SimplePolygonF f vertex)
(Vertex (SimplePolygonF f vertex)
 -> Const
      (NonEmptyDList (Point 2 r)) (Vertex (SimplePolygonF f vertex)))
-> SimplePolygonF f vertex
-> Const (NonEmptyDList (Point 2 r)) (SimplePolygonF f vertex)
forall graph graph'.
HasVertices graph graph' =>
IndexedTraversal1
  (VertexIx graph) graph graph' (Vertex graph) (Vertex graph')
IndexedTraversal1
  (VertexIx (SimplePolygonF f vertex))
  (SimplePolygonF f vertex)
  (SimplePolygonF f vertex)
  (Vertex (SimplePolygonF f vertex))
  (Vertex (SimplePolygonF f vertex))
vertices((vertex -> Const (NonEmptyDList (Point 2 r)) vertex)
 -> SimplePolygonF f vertex
 -> Const (NonEmptyDList (Point 2 r)) (SimplePolygonF f vertex))
-> ((Point 2 r -> Const (NonEmptyDList (Point 2 r)) (Point 2 r))
    -> vertex -> Const (NonEmptyDList (Point 2 r)) vertex)
-> Getting
     (NonEmptyDList (Point 2 r)) (SimplePolygonF f vertex) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (NonEmptyDList (Point 2 r)) (Point 2 r))
-> vertex -> Const (NonEmptyDList (Point 2 r)) vertex
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' vertex (Point 2 r)
asPoint) SimplePolygonF f vertex
pg


instance (Point_ point 2 r, Fractional r
         ) => IsDrawable (Ipe r) (ClosedLineSegment point) where
  type AttrOf (Ipe r) (ClosedLineSegment point) = PathAttributes r
  draw :: [Attr (Ipe r) (ClosedLineSegment point)]
-> ClosedLineSegment point -> Rendered (Ipe r)
draw [Attr (Ipe r) (ClosedLineSegment point)]
ats (ClosedLineSegment point
s point
t) = forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @(Ipe r) @(PolyLine point) [Attr (Ipe r) (ClosedLineSegment point)]
[Attr (Ipe r) (PolyLine point)]
ats
                                   (PolyLine point -> Rendered (Ipe r))
-> PolyLine point -> Rendered (Ipe r)
forall a b. (a -> b) -> a -> b
$ Vector 2 point -> PolyLine point
forall polyLine point (f :: * -> *).
(ConstructablePolyLine_ polyLine point, Foldable1 f) =>
f point -> polyLine
forall (f :: * -> *). Foldable1 f => f point -> PolyLine point
polyLineFromPoints (point -> point -> Vector 2 point
forall r. r -> r -> Vector 2 r
Vector2 point
s point
t)

instance ( Point_ point 2 r, Fractional r
         -- , HasPoints (PolyLineF f point) (PolyLineF (Point 2 r)) point (Point 2 r)
         ) => IsDrawable (Ipe r) (PolyLine point) where
  type AttrOf (Ipe r) (PolyLine point) = PathAttributes r
  draw :: [Attr (Ipe r) (PolyLine point)]
-> PolyLine point -> Rendered (Ipe r)
draw [Attr (Ipe r) (PolyLine point)]
ats PolyLine point
poly = forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @(Ipe r) [Attr (Ipe r) (PolyLine point)]
[Attr (Ipe r) (Path r)]
ats Path r
thePath
    where
      thePath :: Path r
thePath = PathSegment r -> Path r
forall r. PathSegment r -> Path r
singletonPath (PathSegment r -> Path r)
-> (PolyLine (Point 2 r) -> PathSegment r)
-> PolyLine (Point 2 r)
-> Path r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyLine (Point 2 r) -> PathSegment r
forall r. PolyLine (Point 2 r) -> PathSegment r
PolyLineSegment (PolyLine (Point 2 r) -> Path r) -> PolyLine (Point 2 r) -> Path r
forall a b. (a -> b) -> a -> b
$ PolyLine point
polyPolyLine point
-> (PolyLine point -> PolyLine (Point 2 r)) -> PolyLine (Point 2 r)
forall a b. a -> (a -> b) -> b
&(point -> Identity (Point 2 r))
-> PolyLine point -> Identity (PolyLine (Point 2 r))
forall (d :: Nat) r r'.
(Point_ point d r, Point_ (Point 2 r) d r',
 NumType (PolyLine point) ~ r, NumType (PolyLine (Point 2 r)) ~ r',
 Dimension (PolyLine point) ~ d,
 Dimension (PolyLine (Point 2 r)) ~ d) =>
Traversal1
  (PolyLine point) (PolyLine (Point 2 r)) point (Point 2 r)
forall s t point point' (d :: Nat) r r'.
(HasPoints s t point point', Point_ point d r, Point_ point' d r',
 NumType s ~ r, NumType t ~ r', Dimension s ~ d, Dimension t ~ d) =>
Traversal1 s t point point'
Traversal1
  (PolyLine point) (PolyLine (Point 2 r)) point (Point 2 r)
allPoints ((point -> Identity (Point 2 r))
 -> PolyLine point -> Identity (PolyLine (Point 2 r)))
-> (point -> Point 2 r) -> PolyLine point -> PolyLine (Point 2 r)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (point -> Getting (Point 2 r) point (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) point (Point 2 r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint)

instance (Point_ point 2 r, Fractional r
         ) => IsDrawable (Ipe r) (CubicBezier point) where
  type AttrOf (Ipe r) (CubicBezier point) = PathAttributes r
  draw :: [Attr (Ipe r) (CubicBezier point)]
-> CubicBezier point -> Rendered (Ipe r)
draw [Attr (Ipe r) (CubicBezier point)]
ats CubicBezier point
bez = forall backend geom.
IsDrawable backend geom =>
[Attr backend geom] -> geom -> Rendered backend
draw @(Ipe r) [Attr (Ipe r) (CubicBezier point)]
[Attr (Ipe r) (Path r)]
ats Path r
thePath
    where
      thePath :: Path r
thePath = PathSegment r -> Path r
forall r. PathSegment r -> Path r
singletonPath (PathSegment r -> Path r)
-> (CubicBezier (Point 2 r) -> PathSegment r)
-> CubicBezier (Point 2 r)
-> Path r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CubicBezier (Point 2 r) -> PathSegment r
forall r. CubicBezier (Point 2 r) -> PathSegment r
CubicBezierSegment (CubicBezier (Point 2 r) -> Path r)
-> CubicBezier (Point 2 r) -> Path r
forall a b. (a -> b) -> a -> b
$ CubicBezier point
bezCubicBezier point
-> (CubicBezier point -> CubicBezier (Point 2 r))
-> CubicBezier (Point 2 r)
forall a b. a -> (a -> b) -> b
&(point -> Identity (Point 2 r))
-> CubicBezier point -> Identity (CubicBezier (Point 2 r))
forall (d :: Nat) r r'.
(Point_ point d r, Point_ (Point 2 r) d r',
 NumType (CubicBezier point) ~ r,
 NumType (CubicBezier (Point 2 r)) ~ r',
 Dimension (CubicBezier point) ~ d,
 Dimension (CubicBezier (Point 2 r)) ~ d) =>
Traversal1
  (CubicBezier point) (CubicBezier (Point 2 r)) point (Point 2 r)
forall s t point point' (d :: Nat) r r'.
(HasPoints s t point point', Point_ point d r, Point_ point' d r',
 NumType s ~ r, NumType t ~ r', Dimension s ~ d, Dimension t ~ d) =>
Traversal1 s t point point'
Traversal1
  (CubicBezier point) (CubicBezier (Point 2 r)) point (Point 2 r)
allPoints ((point -> Identity (Point 2 r))
 -> CubicBezier point -> Identity (CubicBezier (Point 2 r)))
-> (point -> Point 2 r)
-> CubicBezier point
-> CubicBezier (Point 2 r)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (point -> Getting (Point 2 r) point (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) point (Point 2 r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint)

--------------------------------------------------------------------------------

instance IsDrawable (Ipe r) (Point 2 r) where
  type AttrOf (Ipe r) (Point 2 r) = SymbolAttributes r
  draw :: [Attr (Ipe r) (Point 2 r)] -> Point 2 r -> Rendered (Ipe r)
draw [Attr (Ipe r) (Point 2 r)]
ats Point 2 r
p = [ IpeObject' IpeSymbol r -> IpeObject r
forall r. IpeObject' IpeSymbol r -> IpeObject r
IpeUse (IpeObject' IpeSymbol r -> IpeObject r)
-> IpeObject' IpeSymbol r -> IpeObject r
forall a b. (a -> b) -> a -> b
$ IpeOut (Point 2 r) IpeSymbol r
forall r. IpeOut (Point 2 r) IpeSymbol r
ipeDiskMark Point 2 r
p (IpeSymbol r :+ SymbolAttributes r)
-> ((IpeSymbol r :+ SymbolAttributes r) -> IpeObject' IpeSymbol r)
-> IpeObject' IpeSymbol r
forall a b. a -> (a -> b) -> b
& (IpeAttributes IpeSymbol r -> Identity (IpeAttributes IpeSymbol r))
-> (IpeSymbol r :+ SymbolAttributes r)
-> Identity (IpeSymbol r :+ SymbolAttributes r)
(IpeAttributes IpeSymbol r -> Identity (IpeAttributes IpeSymbol r))
-> IpeObject' IpeSymbol r -> Identity (IpeObject' IpeSymbol r)
forall (i :: * -> *) r (f :: * -> *).
Functor f =>
(IpeAttributes i r -> f (IpeAttributes i r))
-> IpeObject' i r -> f (IpeObject' i r)
attributes ((IpeAttributes IpeSymbol r
  -> Identity (IpeAttributes IpeSymbol r))
 -> (IpeSymbol r :+ SymbolAttributes r)
 -> Identity (IpeSymbol r :+ SymbolAttributes r))
-> (IpeAttributes IpeSymbol r -> IpeAttributes IpeSymbol r)
-> (IpeSymbol r :+ SymbolAttributes r)
-> IpeSymbol r :+ SymbolAttributes r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ [IpeAttributes IpeSymbol r -> IpeAttributes IpeSymbol r]
-> IpeAttributes IpeSymbol r -> IpeAttributes IpeSymbol r
forall at. [at -> at] -> at -> at
applyAttrs [IpeAttributes IpeSymbol r -> IpeAttributes IpeSymbol r]
[Attr (Ipe r) (Point 2 r)]
ats ]

-- -- | Create an ipe mark
-- ipeMark     :: Text -> Point 2 r -> IpeSymbol r :+ SymbolAttributes r
-- ipeMark n p = Symbol p n :+ def

-- -- | Creates a disk ipe mark
-- ipeDiskMark :: Point 2 r -> IpeSymbol r :+ SymbolAttributes r
-- ipeDiskMark = ipeMark "mark/disk(sx)"