{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Render a laid-out string diagram as 'ChartOptions' (SVG via chart-svg).
module Strings.Svg.Render
  ( renderLayout,
    renderSDiagram,
    renderDiagram,
    equalityRow,
    withBackground,
    padLayout,
  )
where

import Chart
import Circuit.Poly.StringDiagram (Diagram, SDiagram, skeleton)
import Data.ByteString (ByteString)
import Optics.Core
import Strings.Svg.Layout
import Strings.Svg.Palette
import Prelude

-- | Pad a layout's bounds (for background / viewBox breathing room).
padLayout :: Double -> Layout -> Layout
padLayout :: Double -> Layout -> Layout
padLayout Double
p Layout
lay =
  Layout
lay {bounds = expandBounds p (bounds lay)}
  where
    expandBounds :: a -> Rect a -> Rect a
expandBounds a
d (Rect a
x a
z a
y a
w) = a -> a -> a -> a -> Rect a
forall a. a -> a -> a -> a -> Rect a
Rect (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
d) (a
z a -> a -> a
forall a. Num a => a -> a -> a
+ a
d) (a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
d) (a
w a -> a -> a
forall a. Num a => a -> a -> a
+ a
d)

-- | Dark background rect behind a chart tree, spanning the given bounds.
withBackground :: Rect Double -> ChartTree -> ChartTree
withBackground :: Rect Double -> ChartTree -> ChartTree
withBackground Rect Double
r ChartTree
tree =
  Maybe Text -> [ChartTree] -> ChartTree
group
    Maybe Text
forall a. Maybe a
Nothing
    [ [Chart] -> ChartTree
unnamed [Style -> [Rect Double] -> Chart
RectChart (Colour -> Style
blob Colour
bgDark Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style ScaleP ScaleP
-> ScaleP -> Style -> Style
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx Style Style ScaleP ScaleP
#scaleP ScaleP
NoScaleP) [Rect Double
r]],
      ChartTree
tree
    ]

-- | Render a 'Layout' to chart options (no hud).
renderLayout :: Layout -> ChartOptions
renderLayout :: Layout -> ChartOptions
renderLayout Layout
lay =
  ChartOptions
forall a. Monoid a => a
mempty
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx ChartOptions ChartOptions HudOptions HudOptions
-> HudOptions -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx ChartOptions ChartOptions HudOptions HudOptions
#hudOptions HudOptions
forall a. Monoid a => a
mempty
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx ChartOptions ChartOptions ChartTree ChartTree
-> ChartTree -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx ChartOptions ChartOptions ChartTree ChartTree
#chartTree (Rect Double -> ChartTree -> ChartTree
withBackground Rect Double
b (Layout -> ChartTree
picture Layout
lay))
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx ChartOptions ChartOptions ChartAspect ChartAspect
-> ChartAspect -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set
      (Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
#markupOptions Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
-> Optic
     A_Lens NoIx MarkupOptions MarkupOptions ChartAspect ChartAspect
-> Optic
     A_Lens NoIx ChartOptions ChartOptions ChartAspect ChartAspect
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens NoIx MarkupOptions MarkupOptions ChartAspect ChartAspect
#chartAspect)
      ChartAspect
UnscaledAspect
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx ChartOptions ChartOptions ByteString ByteString
-> ByteString -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set
      (Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
#markupOptions Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
-> Optic
     A_Lens NoIx MarkupOptions MarkupOptions CssOptions CssOptions
-> Optic
     A_Lens NoIx ChartOptions ChartOptions CssOptions CssOptions
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx MarkupOptions MarkupOptions CssOptions CssOptions
#cssOptions Optic A_Lens NoIx ChartOptions ChartOptions CssOptions CssOptions
-> Optic A_Lens NoIx CssOptions CssOptions ByteString ByteString
-> Optic
     A_Lens NoIx ChartOptions ChartOptions ByteString ByteString
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx CssOptions CssOptions ByteString ByteString
#fontFamilies)
      ByteString
monoFont
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  ChartOptions
  ChartOptions
  PreferColorScheme
  PreferColorScheme
-> PreferColorScheme -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set
      (Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
#markupOptions Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
-> Optic
     A_Lens NoIx MarkupOptions MarkupOptions CssOptions CssOptions
-> Optic
     A_Lens NoIx ChartOptions ChartOptions CssOptions CssOptions
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx MarkupOptions MarkupOptions CssOptions CssOptions
#cssOptions Optic A_Lens NoIx ChartOptions ChartOptions CssOptions CssOptions
-> Optic
     A_Lens
     NoIx
     CssOptions
     CssOptions
     PreferColorScheme
     PreferColorScheme
-> Optic
     A_Lens
     NoIx
     ChartOptions
     ChartOptions
     PreferColorScheme
     PreferColorScheme
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  CssOptions
  CssOptions
  PreferColorScheme
  PreferColorScheme
#preferColorScheme)
      PreferColorScheme
PreferNormal
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx ChartOptions ChartOptions ByteString ByteString
-> ByteString -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set
      (Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
#markupOptions Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
-> Optic
     A_Lens NoIx MarkupOptions MarkupOptions CssOptions CssOptions
-> Optic
     A_Lens NoIx ChartOptions ChartOptions CssOptions CssOptions
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx MarkupOptions MarkupOptions CssOptions CssOptions
#cssOptions Optic A_Lens NoIx ChartOptions ChartOptions CssOptions CssOptions
-> Optic A_Lens NoIx CssOptions CssOptions ByteString ByteString
-> Optic
     A_Lens NoIx ChartOptions ChartOptions ByteString ByteString
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx CssOptions CssOptions ByteString ByteString
#cssExtra)
      (ByteString
"svg { background-color: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Colour -> ByteString
showRGB Colour
bgDark ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"; }\n")
    ChartOptions -> (ChartOptions -> ChartOptions) -> ChartOptions
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx ChartOptions ChartOptions (Maybe Double) (Maybe Double)
-> Maybe Double -> ChartOptions -> ChartOptions
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
#markupOptions Optic
  A_Lens NoIx ChartOptions ChartOptions MarkupOptions MarkupOptions
-> Optic
     A_Lens
     NoIx
     MarkupOptions
     MarkupOptions
     (Maybe Double)
     (Maybe Double)
-> Optic
     A_Lens NoIx ChartOptions ChartOptions (Maybe Double) (Maybe Double)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  NoIx
  MarkupOptions
  MarkupOptions
  (Maybe Double)
  (Maybe Double)
#markupHeight) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
h)
  where
    lay' :: Layout
lay' = Double -> Layout -> Layout
padLayout Double
0.15 Layout
lay
    b :: Rect Double
b = Layout -> Rect Double
bounds Layout
lay'
    Rect Double
_ Double
_ Double
y Double
w = Rect Double
b
    -- keep height readable; width follows UnscaledAspect from data
    h :: Double
h = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
120 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
360 (Double
180 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.01)))
    monoFont :: ByteString
    monoFont :: ByteString
monoFont = ByteString
"svg { font-family: ui-monospace, SFMono-Regular, Menlo, Monaco, Consolas, monospace; }\n"

-- | Layout then render an untyped skeleton.
renderSDiagram :: SDiagram -> ChartOptions
renderSDiagram :: SDiagram -> ChartOptions
renderSDiagram = Layout -> ChartOptions
renderLayout (Layout -> ChartOptions)
-> (SDiagram -> Layout) -> SDiagram -> ChartOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDiagram -> Layout
layoutSDiagram

-- | Forget types via 'skeleton', then render.
renderDiagram :: Diagram a da b db -> ChartOptions
renderDiagram :: forall a da b db. Diagram a da b db -> ChartOptions
renderDiagram = SDiagram -> ChartOptions
renderSDiagram (SDiagram -> ChartOptions)
-> (Diagram a da b db -> SDiagram)
-> Diagram a da b db
-> ChartOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diagram a da b db -> SDiagram
forall a da b db. Diagram a da b db -> SDiagram
skeleton

-- | Place two layouts side by side with an equals sign between them.
equalityRow :: Layout -> Layout -> Layout
equalityRow :: Layout -> Layout -> Layout
equalityRow Layout
left Layout
right =
  Layout
    { picture :: ChartTree
picture = Maybe Text -> [ChartTree] -> ChartTree
group Maybe Text
forall a. Maybe a
Nothing [Layout -> ChartTree
picture Layout
l', ChartTree
eqTree, Layout -> ChartTree
picture Layout
r'],
      leftPorts :: [Point Double]
leftPorts = Layout -> [Point Double]
leftPorts Layout
l',
      rightPorts :: [Point Double]
rightPorts = Layout -> [Point Double]
rightPorts Layout
r',
      bounds :: Rect Double
bounds = Layout -> Rect Double
bounds Layout
l' Rect Double -> Rect Double -> Rect Double
forall a. Semigroup a => a -> a -> a
<> Layout -> Rect Double
bounds Layout
r' Rect Double -> Rect Double -> Rect Double
forall a. Semigroup a => a -> a -> a
<> Rect Double
eqBounds
    }
  where
    gap :: Double
gap = Double
0.45
    l' :: Layout
l' = Point Double -> Layout -> Layout
moveLayout (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (-Layout -> Double
lx Layout
left) (-Layout -> Double
midY Layout
left)) Layout
left
    eqX :: Double
eqX = Layout -> Double
rx Layout
l' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
gap
    r' :: Layout
r' = Point Double -> Layout -> Layout
moveLayout (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
eqX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
gap Double -> Double -> Double
forall a. Num a => a -> a -> a
- Layout -> Double
lx Layout
right) (-Layout -> Double
midY Layout
right)) Layout
right
    eqTree :: ChartTree
eqTree = [Chart] -> ChartTree
unnamed [Style -> [(Text, Point Double)] -> Chart
TextChart Style
eqStyle [(Text
"=", Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
eqX Double
0)]]
    eqBounds :: Rect Double
eqBounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect (Double
eqX Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.2) (Double
eqX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.2) (-Double
0.2) Double
0.2
    lx :: Layout -> Double
lx (Layout ChartTree
_ [Point Double]
_ [Point Double]
_ (Rect Double
x Double
_ Double
_ Double
_)) = Double
x
    rx :: Layout -> Double
rx (Layout ChartTree
_ [Point Double]
_ [Point Double]
_ (Rect Double
_ Double
z Double
_ Double
_)) = Double
z
    midY :: Layout -> Double
midY (Layout ChartTree
_ [Point Double]
_ [Point Double]
_ (Rect Double
_ Double
_ Double
y Double
w)) = (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2