{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE AllowAmbiguousTypes          #-}
{-# LANGUAGE QuantifiedConstraints          #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Miso.Svg.Draw
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Draw geometric objects to Svg files through miso.
--
-- This uses the newer API common with ipe
--
--------------------------------------------------------------------------------
module HGeometry.Miso.Svg.Draw
  ( Svg
  , SVG
  , module Ipe.Draw
  ) where

import           Control.Lens
import           Data.Kind (Type)
import           HGeometry.PolyLine
import           HGeometry.Point
import           HGeometry.LineSegment
import           Data.Default
import           Ipe.Attributes
import           Ipe.Draw
import           Miso (View)
import           Data.Void
import           HGeometry.Polygon
import           HGeometry.Properties
import qualified HGeometry.Miso.Svg as Svg
import           Miso.String (ToMisoString(..), ms)
import           Miso.Svg
import           Miso.Svg.Property

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

-- | The Svg backend; which renders to Svg using Miso
type data Svg (model :: Type) (action :: Type)

-- | Static Svg
type SVG = Svg () Void

type instance Rendered (Svg model action) = [View model action]

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

instance ( Point_ vertex 2 (NumType vertex)
         , ToMisoString (NumType vertex)
         , SimplePolygon_ (SimplePolygonF f vertex) vertex (NumType vertex)
         ) => IsDrawable (Svg model action) (SimplePolygonF f vertex) where
  type AttrOf (Svg model action) (SimplePolygonF f vertex) = PathAttributes (NumType vertex)
  draw :: [Attr (Svg model action) (SimplePolygonF f vertex)]
-> SimplePolygonF f vertex -> Rendered (Svg model action)
draw [Attr (Svg model action) (SimplePolygonF f vertex)]
ats SimplePolygonF f vertex
poly = [ SimplePolygonF f vertex -> [Attribute action] -> View model action
forall simplePolygon point r action model.
(SimplePolygon_ simplePolygon point r, ToMisoString r) =>
simplePolygon -> [Attribute action] -> View model action
Svg.dSimplePolygon SimplePolygonF f vertex
poly (PathAttributesF (NumType vertex) Maybe -> [Attribute action]
forall (ats :: (* -> *) -> *) action.
SvgWriteAttributes ats action =>
ats Maybe -> [Attribute action]
Svg.svgWriteAttrs (PathAttributesF (NumType vertex) Maybe -> [Attribute action])
-> PathAttributesF (NumType vertex) Maybe -> [Attribute action]
forall a b. (a -> b) -> a -> b
$ [PathAttributesF (NumType vertex) Maybe
 -> PathAttributesF (NumType vertex) Maybe]
-> PathAttributesF (NumType vertex) Maybe
forall at. Default at => [at -> at] -> at
apply [PathAttributesF (NumType vertex) Maybe
 -> PathAttributesF (NumType vertex) Maybe]
[Attr (Svg model action) (SimplePolygonF f vertex)]
ats)
                  ]

instance ( Point_ vertex 2 (NumType vertex)
         , ToMisoString (NumType vertex)
         , PolyLine_ (PolyLineF f vertex) vertex
         ) => IsDrawable (Svg model action) (PolyLineF f vertex) where
  type AttrOf (Svg model action) (PolyLineF f vertex) = PathAttributes (NumType vertex)
  draw :: [Attr (Svg model action) (PolyLineF f vertex)]
-> PolyLineF f vertex -> Rendered (Svg model action)
draw [Attr (Svg model action) (PolyLineF f vertex)]
ats PolyLineF f vertex
poly = [ PolyLineF f vertex -> [Attribute action] -> View model action
forall polyLine point r action model.
(PolyLine_ polyLine point, Point_ point 2 r, ToMisoString r) =>
polyLine -> [Attribute action] -> View model action
Svg.dPolyLine PolyLineF f vertex
poly (PathAttributesF (NumType vertex) Maybe -> [Attribute action]
forall (ats :: (* -> *) -> *) action.
SvgWriteAttributes ats action =>
ats Maybe -> [Attribute action]
Svg.svgWriteAttrs (PathAttributesF (NumType vertex) Maybe -> [Attribute action])
-> PathAttributesF (NumType vertex) Maybe -> [Attribute action]
forall a b. (a -> b) -> a -> b
$ [PathAttributesF (NumType vertex) Maybe
 -> PathAttributesF (NumType vertex) Maybe]
-> PathAttributesF (NumType vertex) Maybe
forall at. Default at => [at -> at] -> at
apply [PathAttributesF (NumType vertex) Maybe
 -> PathAttributesF (NumType vertex) Maybe]
[Attr (Svg model action) (PolyLineF f vertex)]
ats) ]


instance ( Point_ vertex 2 (NumType vertex)
         , ToMisoString (NumType vertex)
         , EndPoint_ (endPoint vertex), IxValue (endPoint vertex) ~ vertex
         ) => IsDrawable (Svg model action) (LineSegment endPoint vertex) where
  type AttrOf (Svg model action) (LineSegment endPoint vertex) = PathAttributes (NumType vertex)
  draw :: [Attr (Svg model action) (LineSegment endPoint vertex)]
-> LineSegment endPoint vertex -> Rendered (Svg model action)
draw [Attr (Svg model action) (LineSegment endPoint vertex)]
ats LineSegment endPoint vertex
seg = [ LineSegment endPoint vertex
-> [Attribute action] -> View model action
forall lineSegment point r action model.
(LineSegment_ lineSegment point, Point_ point 2 r,
 ToMisoString r) =>
lineSegment -> [Attribute action] -> View model action
Svg.dLineSegment LineSegment endPoint vertex
seg (PathAttributesF (NumType vertex) Maybe -> [Attribute action]
forall (ats :: (* -> *) -> *) action.
SvgWriteAttributes ats action =>
ats Maybe -> [Attribute action]
Svg.svgWriteAttrs (PathAttributesF (NumType vertex) Maybe -> [Attribute action])
-> PathAttributesF (NumType vertex) Maybe -> [Attribute action]
forall a b. (a -> b) -> a -> b
$ [PathAttributesF (NumType vertex) Maybe
 -> PathAttributesF (NumType vertex) Maybe]
-> PathAttributesF (NumType vertex) Maybe
forall at. Default at => [at -> at] -> at
apply [PathAttributesF (NumType vertex) Maybe
 -> PathAttributesF (NumType vertex) Maybe]
[Attr (Svg model action) (LineSegment endPoint vertex)]
ats) ]


instance ( ToMisoString r
         ) => IsDrawable (Svg model action) (Point 2 r) where
  type AttrOf (Svg model action) (Point 2 r) = SymbolAttributes r
  draw :: [Attr (Svg model action) (Point 2 r)]
-> Point 2 r -> Rendered (Svg model action)
draw [Attr (Svg model action) (Point 2 r)]
ats Point 2 r
p = [ [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
ellipse_ ([ MisoString -> Attribute action
forall action. MisoString -> Attribute action
cx_ (r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> MisoString) -> r -> MisoString
forall a b. (a -> b) -> a -> b
$ Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int (Point 2 r) r
xCoord), MisoString -> Attribute action
forall action. MisoString -> Attribute action
cy_ (r -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (r -> MisoString) -> r -> MisoString
forall a b. (a -> b) -> a -> b
$ Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int (Point 2 r) r
yCoord)
                           , MisoString -> Attribute action
forall action. MisoString -> Attribute action
rx_ MisoString
"2", MisoString -> Attribute action
forall action. MisoString -> Attribute action
ry_ MisoString
"2"
                           ] [Attribute action] -> [Attribute action] -> [Attribute action]
forall a. Semigroup a => a -> a -> a
<> SymbolAttributesF r Maybe -> [Attribute action]
forall (ats :: (* -> *) -> *) action.
SvgWriteAttributes ats action =>
ats Maybe -> [Attribute action]
Svg.svgWriteAttrs ([SymbolAttributesF r Maybe -> SymbolAttributesF r Maybe]
-> SymbolAttributesF r Maybe
forall at. Default at => [at -> at] -> at
apply [SymbolAttributesF r Maybe -> SymbolAttributesF r Maybe]
[Attr (Svg model action) (Point 2 r)]
ats))
               ]

-- | Helper function to apply attributes
apply :: Default at => [at -> at] -> at
apply :: forall at. Default at => [at -> at] -> at
apply = (at -> (at -> at) -> at) -> at -> [at -> at] -> at
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((at -> at) -> at -> at) -> at -> (at -> at) -> at
forall a b c. (a -> b -> c) -> b -> a -> c
flip (at -> at) -> at -> at
forall a b. (a -> b) -> a -> b
($)) at
forall a. Default a => a
def