{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
-- |
-- 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 Data.Default
import Data.Text (Text)
import HGeometry.Ext
import HGeometry.Point
import Control.Lens
import Data.Kind (Type)
import Ipe.Types
import Ipe.FromIpe
import Ipe.Attributes
import HGeometry.Polygon
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)

--------------------------------------------------------------------------------
-- * 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 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
$ Point 2 r -> IpeSymbol r :+ SymbolAttributes r
forall r. Point 2 r -> IpeSymbol r :+ SymbolAttributes 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
& (SymbolAttributes r -> Identity (SymbolAttributes 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 ((SymbolAttributes r -> Identity (SymbolAttributes r))
 -> (IpeSymbol r :+ SymbolAttributes r)
 -> Identity (IpeSymbol r :+ SymbolAttributes r))
-> (SymbolAttributes r -> SymbolAttributes r)
-> (IpeSymbol r :+ SymbolAttributes r)
-> IpeSymbol r :+ SymbolAttributes r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ [SymbolAttributes r -> SymbolAttributes r]
-> SymbolAttributes r -> SymbolAttributes r
forall at. [at -> at] -> at -> at
applyAttrs [SymbolAttributes r -> SymbolAttributes r]
[Attr (Ipe r) (Point 2 r)]
ats ]

-- | Create an ipe mark
ipeMark     :: Text -> Point 2 r -> IpeSymbol r :+ SymbolAttributes r
ipeMark :: forall r. Text -> Point 2 r -> IpeSymbol r :+ SymbolAttributes r
ipeMark Text
n Point 2 r
p = Point 2 r -> Text -> IpeSymbol r
forall r. Point 2 r -> Text -> IpeSymbol r
Symbol Point 2 r
p Text
n IpeSymbol r
-> SymbolAttributes r -> IpeSymbol r :+ SymbolAttributes r
forall core extra. core -> extra -> core :+ extra
:+ SymbolAttributes r
forall a. Default a => a
def

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