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

-- | Port-aware layout of untyped string diagrams ('SDiagram').
--
-- Coordinates use chart-svg data space (y increases upward).  Morphisms
-- compose left-to-right ('SThenD'); tensor stacks top-to-bottom
-- ('SBeside').  That matches the left/right port model and the wall-chart
-- schematics — not the wording slip in the requirements bullet that had
-- composition stacking vertically.
--
-- Every primitive emits its boundary ports on a uniform vertical grid
-- with 'portPitch' spacing, so 'thenL' aligns whole port lists pairwise
-- and 'besideL' concatenates port lists slot by slot.  A port-count
-- mismatch in 'thenL' is a wiring error: the connection is truncated to
-- the common prefix and each unmatched port is marked with a dangling
-- stub and dot, so the error is visible rather than silent.
module Strings.Svg.Layout
  ( Layout (..),
    layoutSDiagram,
    layoutWidth,
    layoutHeight,
    moveLayout,
    countCharts,
    countLines,
    countRects,
    countPaths,
    countGlyphs,
    unitW,
    boxH,
    composeGap,
    tensorGap,
    portPitch,
  )
where

import Chart
import Circuit.Poly.StringDiagram (SDiagram (..))
import Data.Text (pack)
import Optics.Core
import Strings.Svg.Palette
import Prelude

-- | Laid-out diagram with boundary ports and bounding box.
data Layout = Layout
  { Layout -> ChartTree
picture :: ChartTree,
    Layout -> [Point Double]
leftPorts :: [Point Double],
    Layout -> [Point Double]
rightPorts :: [Point Double],
    Layout -> Rect Double
bounds :: Rect Double
  }
  deriving (Layout -> Layout -> Bool
(Layout -> Layout -> Bool)
-> (Layout -> Layout -> Bool) -> Eq Layout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Layout -> Layout -> Bool
== :: Layout -> Layout -> Bool
$c/= :: Layout -> Layout -> Bool
/= :: Layout -> Layout -> Bool
Eq, Int -> Layout -> ShowS
[Layout] -> ShowS
Layout -> String
(Int -> Layout -> ShowS)
-> (Layout -> String) -> ([Layout] -> ShowS) -> Show Layout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Layout -> ShowS
showsPrec :: Int -> Layout -> ShowS
$cshow :: Layout -> String
show :: Layout -> String
$cshowList :: [Layout] -> ShowS
showList :: [Layout] -> ShowS
Show)

-- | Horizontal span of one wire / box cell.
unitW :: Double
unitW :: Double
unitW = Double
1.0

-- | Box height (centred on the wire).
boxH :: Double
boxH :: Double
boxH = Double
0.6

-- | Gap between sequential (then) cells.
composeGap :: Double
composeGap :: Double
composeGap = Double
0.12

-- | Gap between tensor (beside) cells.
tensorGap :: Double
tensorGap :: Double
tensorGap = Double
0.35

-- | Vertical pitch between parallel wires.
portPitch :: Double
portPitch :: Double
portPitch = Double
0.5

layoutWidth :: Layout -> Double
layoutWidth :: Layout -> Double
layoutWidth (Layout ChartTree
_ [Point Double]
_ [Point Double]
_ (Rect Double
x Double
z Double
_ Double
_)) = Double
z Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x

layoutHeight :: Layout -> Double
layoutHeight :: Layout -> Double
layoutHeight (Layout ChartTree
_ [Point Double]
_ [Point Double]
_ (Rect Double
_ Double
_ Double
y Double
w)) = Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y

-- | Translate a layout by a vector.
moveLayout :: Point Double -> Layout -> Layout
moveLayout :: Point Double -> Layout -> Layout
moveLayout Point Double
d (Layout ChartTree
pic [Point Double]
ls [Point Double]
rs Rect Double
b) =
  Layout
    { picture :: ChartTree
picture = Point Double -> ChartTree -> ChartTree
moveChartTree Point Double
d ChartTree
pic,
      leftPorts :: [Point Double]
leftPorts = (Point Double
d Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+) (Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
ls,
      rightPorts :: [Point Double]
rightPorts = (Point Double
d Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+) (Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
rs,
      bounds :: Rect Double
bounds = Point Double -> Rect Double -> Rect Double
forall a. Additive a => Point a -> Rect a -> Rect a
addPoint Point Double
d Rect Double
b
    }

-- | chart-svg has no public moveChartTree reexport path that keeps names;
-- fold charts with moveChart.
moveChartTree :: Point Double -> ChartTree -> ChartTree
moveChartTree :: Point Double -> ChartTree -> ChartTree
moveChartTree Point Double
d = Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
-> ([Chart] -> [Chart]) -> ChartTree -> ChartTree
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
charts' ((Chart -> Chart) -> [Chart] -> [Chart]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Point Double -> Chart -> Chart
moveChart Point Double
d))

-- | Layout an untyped skeleton at the origin (first left port near @x=0@).
layoutSDiagram :: SDiagram -> Layout
layoutSDiagram :: SDiagram -> Layout
layoutSDiagram = Int -> SDiagram -> Layout
go Int
0
  where
    -- box colour index cycles blue / magenta for multi-box composites
    go :: Int -> SDiagram -> Layout
    go :: Int -> SDiagram -> Layout
go Int
n = \case
      SDiagram
SWire -> Layout
wireL
      SBox String
lbl Int
m Int
o -> Int -> String -> Int -> Int -> Layout
boxL Int
n String
lbl Int
m Int
o
      SSpider Int
m Int
o -> Int -> Int -> Layout
spiderL Int
m Int
o
      SDiagram
SPrismBox -> Int -> String -> Int -> Int -> Layout
boxL Int
n String
"prism" Int
1 Int
1
      SBeside SDiagram
a SDiagram
b -> Layout -> Layout -> Layout
besideL (Int -> SDiagram -> Layout
go Int
n SDiagram
a) (Int -> SDiagram -> Layout
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SDiagram -> Int
boxCount SDiagram
a) SDiagram
b)
      SThenD SDiagram
a SDiagram
b -> Layout -> Layout -> Layout
thenL (Int -> SDiagram -> Layout
go Int
n SDiagram
a) (Int -> SDiagram -> Layout
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SDiagram -> Int
boxCount SDiagram
a) SDiagram
b)
      SDiagram
SBend -> Layout
cupL
      SDiagram
SBend' -> Layout
capL
      STurn SDiagram
d -> Layout -> Layout
turnL (Int -> SDiagram -> Layout
go Int
n SDiagram
d)
      SDiagram
SUnitL -> Layout
wireL
      SDiagram
SUnitL' -> Layout
wireL
      SDiagram
SUnitR -> Layout
wireL
      SDiagram
SUnitR' -> Layout
wireL
      SDiagram
SAssoc -> Int -> Layout
multiWireL Int
3
      SDiagram
SAssoc' -> Int -> Layout
multiWireL Int
3
      SDiagram
SSwap -> Layout
swapL
      STrace SDiagram
d -> Int -> SDiagram -> Layout
go Int
n SDiagram
d

boxCount :: SDiagram -> Int
boxCount :: SDiagram -> Int
boxCount = \case
  SBox {} -> Int
1
  SDiagram
SPrismBox -> Int
1
  SBeside SDiagram
a SDiagram
b -> SDiagram -> Int
boxCount SDiagram
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SDiagram -> Int
boxCount SDiagram
b
  SThenD SDiagram
a SDiagram
b -> SDiagram -> Int
boxCount SDiagram
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SDiagram -> Int
boxCount SDiagram
b
  STurn SDiagram
d -> SDiagram -> Int
boxCount SDiagram
d
  STrace SDiagram
d -> SDiagram -> Int
boxCount SDiagram
d
  SDiagram
_ -> Int
0

boxStroke :: Int -> Colour
boxStroke :: Int -> Colour
boxStroke Int
n = case Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 of
  Int
0 -> Colour
accentBlue
  Int
1 -> Colour
accentMagenta
  Int
_ -> Colour
accentGreen

--------------------------------------------------------------------------------
-- primitives
--------------------------------------------------------------------------------

wireL :: Layout
wireL :: Layout
wireL =
  Layout
    { picture :: ChartTree
picture = [Chart] -> ChartTree
unnamed [Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
wireGrey) [[Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
0, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
0]]],
      leftPorts :: [Point Double]
leftPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
0],
      rightPorts :: [Point Double]
rightPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
0],
      bounds :: Rect Double
bounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0 Double
unitW (-Double
0.05) Double
0.05
    }

-- | @k@ parallel identity wires spanning one unit of width.
multiWireL :: Int -> Layout
multiWireL :: Int -> Layout
multiWireL Int
k =
  Layout
    { picture :: ChartTree
picture = [Chart] -> ChartTree
unnamed [Chart]
lines',
      leftPorts :: [Point Double]
leftPorts = [Point Double]
ports,
      rightPorts :: [Point Double]
rightPorts = (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
0 Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+) (Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
ports0,
      bounds :: Rect Double
bounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0 Double
unitW (Double
ymin Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.05) (Double
ymax Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.05)
    }
  where
    ports0 :: [Point Double]
ports0 = Int -> [Point Double]
portYs Int
k
    ports :: [Point Double]
ports = [Point Double]
ports0
    lines' :: [Chart]
lines' =
      [ Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
wireGrey) [[Point Double
p, Point Double
p Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
0]]
      | Point Double
p <- [Point Double]
ports0
      ]
    ys :: [Double]
ys = (\(Point Double
_ Double
y) -> Double
y) (Point Double -> Double) -> [Point Double] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
ports0
    ymin :: Double
ymin = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
ys)
    ymax :: Double
ymax = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
ys)

portYs :: Int -> [Point Double]
portYs :: Int -> [Point Double]
portYs Int
k
  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = []
  | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
0]
  | Bool
otherwise =
      let half :: Double
half = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
       in [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 (Double
half Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
portPitch) | Int
i <- [Int
0 .. Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

-- | Box with @m@ input ports on the left edge and @n@ output ports on
-- the right edge.  Ports sit on the uniform 'portPitch' grid; short
-- stubs connect each boundary port to a pad dot on the box edge, and the
-- box height grows to fit @max m n@ ports.  A one-port box keeps the
-- classic look: a single centred stub per side, no pad dots.
boxL :: Int -> String -> Int -> Int -> Layout
boxL :: Int -> String -> Int -> Int -> Layout
boxL Int
c String
lbl Int
m Int
n =
  Layout
    { picture :: ChartTree
picture =
        [Chart] -> ChartTree
unnamed
          ( [ Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
wireGrey) [[Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
y, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x0 Double
y]]
            | Double
y <- [Double]
inYs
            ]
              [Chart] -> [Chart] -> [Chart]
forall a. [a] -> [a] -> [a]
++ [ Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
wireGrey) [[Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x1 Double
y, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
y]]
                 | Double
y <- [Double]
outYs
                 ]
              [Chart] -> [Chart] -> [Chart]
forall a. [a] -> [a] -> [a]
++ [ Style -> [Rect Double] -> Chart
RectChart (Colour -> Style
boxStyle (Int -> Colour
boxStroke Int
c)) [Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
x0 Double
x1 (-Double
h2) Double
h2],
                   Style -> [(Text, Point Double)] -> Chart
TextChart Style
labelStyle [(String -> Text
pack String
lbl, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
midX Double
0)]
                 ]
              [Chart] -> [Chart] -> [Chart]
forall a. [a] -> [a] -> [a]
++ [Chart]
pads
          ),
      leftPorts :: [Point Double]
leftPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
y | Double
y <- [Double]
inYs],
      rightPorts :: [Point Double]
rightPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
y | Double
y <- [Double]
outYs],
      bounds :: Rect Double
bounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0 Double
unitW (-Double
h2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.05) (Double
h2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.05)
    }
  where
    inYs :: [Double]
inYs = [Double
y | Point Double
_ Double
y <- Int -> [Point Double]
portYs (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
m)]
    outYs :: [Double]
outYs = [Double
y | Point Double
_ Double
y <- Int -> [Point Double]
portYs (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
n)]
    padHalf :: Double
padHalf = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
y (-Double
y) | Double
y <- [Double]
inYs [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [Double]
outYs])
    h2 :: Double
h2 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Double
boxH Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) (Double
padHalf Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
padMargin)
    padMargin :: Double
padMargin = Double
0.18
    x0 :: Double
x0 = Double
0.18
    x1 :: Double
x1 = Double
unitW Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.18
    midX :: Double
midX = (Double
x0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x1) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    pads :: [Chart]
pads
      | Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
m Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 =
          [ Style -> [Point Double] -> Chart
GlyphChart
              (Double -> Colour -> Style
dotStyle Double
0.06 (Int -> Colour
boxStroke Int
c))
              ([Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x0 Double
y | Double
y <- [Double]
inYs] [Point Double] -> [Point Double] -> [Point Double]
forall a. [a] -> [a] -> [a]
++ [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x1 Double
y | Double
y <- [Double]
outYs])
          ]
      | Bool
otherwise = []

-- | Spider: a junction dot with @m@ input legs converging from the left
-- and @n@ output legs diverging to the right, drawn as smooth cubics
-- with horizontal tangents.  'SSpider' 1 2 and 'SSpider' 2 1 are the
-- classic copy\/merge forks; the degenerate arities are terminators —
-- 'SSpider' 1 0 a stub ending in a dot, 'SSpider' 0 1 a dot opening
-- into a stub, 'SSpider' 0 0 a bare dot.
spiderL :: Int -> Int -> Layout
spiderL :: Int -> Int -> Layout
spiderL Int
m Int
n =
  Layout
    { picture :: ChartTree
picture =
        [Chart] -> ChartTree
unnamed
          ( [ Style -> [PathData Double] -> Chart
PathChart
                (Colour -> Double -> Style
pathStroke Colour
wireGrey Double
0.035)
                [Point Double -> PathData Double
forall a. Point a -> PathData a
StartP Point Double
p, Point Double -> Point Double -> Point Double -> PathData Double
forall a. Point a -> Point a -> Point a -> PathData a
CubicP (Point Double
p Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
leg Double
0) (Point Double
c Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
- Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
leg Double
0) Point Double
c]
            | Point Double
p <- [Point Double]
lefts
            ]
              [Chart] -> [Chart] -> [Chart]
forall a. [a] -> [a] -> [a]
++ [ Style -> [PathData Double] -> Chart
PathChart
                     (Colour -> Double -> Style
pathStroke Colour
wireGrey Double
0.035)
                     [Point Double -> PathData Double
forall a. Point a -> PathData a
StartP Point Double
c, Point Double -> Point Double -> Point Double -> PathData Double
forall a. Point a -> Point a -> Point a -> PathData a
CubicP (Point Double
c Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
leg Double
0) (Point Double
p Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
- Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
leg Double
0) Point Double
p]
                 | Point Double
p <- [Point Double]
rights
                 ]
              [Chart] -> [Chart] -> [Chart]
forall a. [a] -> [a] -> [a]
++ [Style -> [Point Double] -> Chart
GlyphChart (Double -> Colour -> Style
dotStyle Double
0.12 Colour
accentBlue) [Point Double
c]]
          ),
      leftPorts :: [Point Double]
leftPorts = [Point Double]
lefts,
      rightPorts :: [Point Double]
rightPorts = [Point Double]
rights,
      bounds :: Rect Double
bounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0 Double
unitW (Double
ymin Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.05) (Double
ymax Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.05)
    }
  where
    c :: Point Double
c = Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
unitW Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) Double
0
    leg :: Double
leg = Double
0.18
    lefts :: [Point Double]
lefts = Int -> [Point Double]
portYs (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
m)
    rights :: [Point Double]
rights = (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
0 Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+) (Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Point Double]
portYs (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
n)
    ys :: [Double]
ys = [Double
y | Point Double
_ Double
y <- [Point Double]
lefts [Point Double] -> [Point Double] -> [Point Double]
forall a. [a] -> [a] -> [a]
++ [Point Double]
rights]
    ymin :: Double
ymin = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
ys)
    ymax :: Double
ymax = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
ys)

-- | Small filled circle style (spider dots, port pads, error markers).
dotStyle :: Double -> Colour -> Style
dotStyle :: Double -> Colour -> Style
dotStyle Double
s Colour
c =
  Style
defaultGlyphStyle
    Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style GlyphShape GlyphShape
-> GlyphShape -> 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 GlyphShape GlyphShape
#glyphShape GlyphShape
CircleGlyph
    Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
-> Double -> 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 Double Double
#size Double
s
    Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> 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 Colour Colour
#color Colour
c
    Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Colour Colour
-> Colour -> 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 Colour Colour
#borderColor Colour
c
    Style -> (Style -> Style) -> Style
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Style Style Double Double
-> Double -> 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 Double Double
#borderSize Double
0.02
    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

-- | Cup (counit): two inputs, closes on the right.
cupL :: Layout
cupL :: Layout
cupL =
  Layout
    { picture :: ChartTree
picture =
        [Chart] -> ChartTree
unnamed
          [ Style -> [PathData Double] -> Chart
PathChart
              (Colour -> Double -> Style
pathStroke Colour
accentBlue Double
0.04)
              [ Point Double -> PathData Double
forall a. Point a -> PathData a
StartP (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
top),
                Point Double -> Point Double -> Point Double -> PathData Double
forall a. Point a -> Point a -> Point a -> PathData a
CubicP (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0.55 Double
top) (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0.55 Double
bot) (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
bot)
              ]
          ],
      leftPorts :: [Point Double]
leftPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
top, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
bot],
      rightPorts :: [Point Double]
rightPorts = [],
      bounds :: Rect Double
bounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0 Double
0.6 (Double
bot Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.05) (Double
top Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.05)
    }
  where
    top :: Double
top = Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    bot :: Double
bot = -(Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)

-- | Cap (unit): opens on the left into two outputs.
capL :: Layout
capL :: Layout
capL =
  Layout
    { picture :: ChartTree
picture =
        [Chart] -> ChartTree
unnamed
          [ Style -> [PathData Double] -> Chart
PathChart
              (Colour -> Double -> Style
pathStroke Colour
accentBlue Double
0.04)
              [ Point Double -> PathData Double
forall a. Point a -> PathData a
StartP (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
top),
                Point Double -> Point Double -> Point Double -> PathData Double
forall a. Point a -> Point a -> Point a -> PathData a
CubicP (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0.45 Double
top) (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0.45 Double
bot) (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
bot)
              ]
          ],
      leftPorts :: [Point Double]
leftPorts = [],
      rightPorts :: [Point Double]
rightPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
top, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
bot],
      bounds :: Rect Double
bounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0.4 Double
unitW (Double
bot Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.05) (Double
top Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.05)
    }
  where
    top :: Double
top = Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    bot :: Double
bot = -(Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)

-- | Braid: under-strand continuous; over-strand gapped at the crossing.
swapL :: Layout
swapL :: Layout
swapL =
  Layout
    { picture :: ChartTree
picture =
        [Chart] -> ChartTree
unnamed
          [ -- under (magenta): bottom-left → top-right continuous
            Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
accentMagenta) [[Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
bot, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
top]],
            -- over (blue): top-left → bottom-right with gap
            Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
accentBlue) [[Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
top, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
gap) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
gapY)]],
            Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
accentBlue) [[Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
gap) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
gapY), Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
bot]]
          ],
      leftPorts :: [Point Double]
leftPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
top, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
0 Double
bot],
      rightPorts :: [Point Double]
rightPorts = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
top, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
unitW Double
bot],
      bounds :: Rect Double
bounds = Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0 Double
unitW (Double
bot Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.05) (Double
top Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.05)
    }
  where
    top :: Double
top = Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    bot :: Double
bot = -(Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
    cx :: Double
cx = Double
unitW Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    cy :: Double
cy = Double
0
    gap :: Double
gap = Double
0.08
    gapY :: Double
gapY = Double
gap Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
top Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
bot) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
unitW

--------------------------------------------------------------------------------
-- composition
--------------------------------------------------------------------------------

-- | Sequential composition: @a@ then @b@ (left to right).
--
-- The whole port list is aligned pairwise: @b@ is shifted so that its
-- first input port meets @a@'s first output port, and since every
-- primitive emits ports on the uniform 'portPitch' grid, equal-length
-- port lists then line up exactly.  A port-count mismatch is a wiring
-- error; layout stays total by truncating the connection to the common
-- prefix and marking each unmatched port with a dangling stub and dot
-- ('danglingPorts'), so the error is visible rather than silent.
thenL :: Layout -> Layout -> Layout
thenL :: Layout -> Layout -> Layout
thenL Layout
a Layout
b =
  Layout
    { picture :: ChartTree
picture = Maybe Text -> [ChartTree] -> ChartTree
group Maybe Text
forall a. Maybe a
Nothing [Layout -> ChartTree
picture Layout
a, Layout -> ChartTree
picture Layout
b', ChartTree
connectors, ChartTree
dangling],
      leftPorts :: [Point Double]
leftPorts = Layout -> [Point Double]
leftPorts Layout
a,
      rightPorts :: [Point Double]
rightPorts = Layout -> [Point Double]
rightPorts Layout
b',
      bounds :: Rect Double
bounds = Layout -> Rect Double
bounds Layout
a Rect Double -> Rect Double -> Rect Double
forall a. Semigroup a => a -> a -> a
<> Layout -> Rect Double
bounds Layout
b' Rect Double -> Rect Double -> Rect Double
forall a. Semigroup a => a -> a -> a
<> Rect Double
connBounds
    }
  where
    -- align b so its left ports match a's right ports (first port vertical align)
    dy :: Double
dy = [Point Double] -> [Point Double] -> Double
alignY (Layout -> [Point Double]
rightPorts Layout
a) (Layout -> [Point Double]
leftPorts Layout
b)
    dx :: Double
dx = Layout -> Double
rx Layout
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
composeGap Double -> Double -> Double
forall a. Num a => a -> a -> a
- Layout -> Double
lx Layout
b
    b' :: Layout
b' = Point Double -> Layout -> Layout
moveLayout (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
dx Double
dy) Layout
b
    outs :: [Point Double]
outs = Layout -> [Point Double]
rightPorts Layout
a
    ins :: [Point Double]
ins = Layout -> [Point Double]
leftPorts Layout
b'
    connectors :: ChartTree
connectors = [Point Double] -> [Point Double] -> ChartTree
connectPorts [Point Double]
outs [Point Double]
ins
    dangling :: ChartTree
dangling =
      [Point Double] -> Double -> ChartTree
danglingPorts (Int -> [Point Double] -> [Point Double]
forall a. Int -> [a] -> [a]
drop ([Point Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Point Double]
ins) [Point Double]
outs) Double
1
        ChartTree -> ChartTree -> ChartTree
forall a. Semigroup a => a -> a -> a
<> [Point Double] -> Double -> ChartTree
danglingPorts (Int -> [Point Double] -> [Point Double]
forall a. Int -> [a] -> [a]
drop ([Point Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Point Double]
outs) [Point Double]
ins) (-Double
1)
    connBounds :: Rect Double
connBounds =
      case [Point Double]
outs [Point Double] -> [Point Double] -> [Point Double]
forall a. Semigroup a => a -> a -> a
<> [Point Double]
ins [Point Double] -> [Point Double] -> [Point Double]
forall a. Semigroup a => a -> a -> a
<> [Point Double]
danglingEnds of
        [] -> Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
0 Double
0 Double
0 Double
0
        (Point Double
p0 : [Point Double]
ps) ->
          (Rect Double -> Rect Double -> Rect Double)
-> Rect Double -> [Rect Double] -> Rect Double
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
            Rect Double -> Rect Double -> Rect Double
forall a. Semigroup a => a -> a -> a
(<>)
            (let Point Double
x Double
y = Point Double
p0 in Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
x Double
x Double
y Double
y)
            [let Point Double
x Double
y = Point Double
p in Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect Double
x Double
x Double
y Double
y | Point Double
p <- [Point Double]
ps]
    danglingEnds :: [Point Double]
danglingEnds =
      [Point Double
p Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
stub Double
0 | Point Double
p <- Int -> [Point Double] -> [Point Double]
forall a. Int -> [a] -> [a]
drop ([Point Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Point Double]
ins) [Point Double]
outs]
        [Point Double] -> [Point Double] -> [Point Double]
forall a. [a] -> [a] -> [a]
++ [Point Double
p Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
- Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
stub Double
0 | Point Double
p <- Int -> [Point Double] -> [Point Double]
forall a. Int -> [a] -> [a]
drop ([Point Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Point Double]
outs) [Point Double]
ins]
    stub :: Double
stub = Double
0.15

-- | Visible wiring-error markers: a short stub continuing past an
-- unmatched port, ending in a magenta dot.  The 'Double' is the stub
-- direction (+1 to the right, -1 to the left).
danglingPorts :: [Point Double] -> Double -> ChartTree
danglingPorts :: [Point Double] -> Double -> ChartTree
danglingPorts [Point Double]
ps Double
dir =
  [Chart] -> ChartTree
unnamed
    ( [ Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
accentMagenta) [[Point Double
p, Point Double
p Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
dir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
stub) Double
0]]
      | Point Double
p <- [Point Double]
ps
      ]
        [Chart] -> [Chart] -> [Chart]
forall a. [a] -> [a] -> [a]
++ [ Style -> [Point Double] -> Chart
GlyphChart (Double -> Colour -> Style
dotStyle Double
0.08 Colour
accentMagenta) [Point Double
p Point Double -> Point Double -> Point Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
dir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
stub) Double
0 | Point Double
p <- [Point Double]
ps]
           | Bool -> Bool
not ([Point Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Point Double]
ps)
           ]
    )
  where
    stub :: Double
stub = Double
0.15

-- | Tensor: @a@ above @b@ (ports concatenated top-then-bottom).
--
-- When both sides have boundary ports, each is placed on a shared
-- vertical slot grid with 'portPitch' spacing: @a@ takes the top slots,
-- @b@ the next ones, so the concatenated port lists stay in vertical
-- order at a uniform pitch and downstream composition connects straight.
-- Each side anchors on its first left port (first right port when it has
-- no left ports) and moves rigidly, so internal wires stretch with their
-- diagram and nothing is rerouted across a box body.  Diagrams without
-- boundary ports fall back to bounding-box stacking with 'tensorGap'.
besideL :: Layout -> Layout -> Layout
besideL :: Layout -> Layout -> Layout
besideL Layout
a Layout
b
  | Layout -> Int
slots Layout
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Layout -> Int
slots Layout
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Layout -> Layout -> Layout
gridBeside Layout
a Layout
b
  | Bool
otherwise = Layout -> Layout -> Layout
boxBeside Layout
a Layout
b

-- | Slot-grid tensor: both sides share a uniform 'portPitch' grid.
gridBeside :: Layout -> Layout -> Layout
gridBeside :: Layout -> Layout -> Layout
gridBeside Layout
a Layout
b =
  Layout
    { picture :: ChartTree
picture = Maybe Text -> [ChartTree] -> ChartTree
group Maybe Text
forall a. Maybe a
Nothing [Layout -> ChartTree
picture Layout
a', Layout -> ChartTree
picture Layout
b'],
      leftPorts :: [Point Double]
leftPorts = Layout -> [Point Double]
leftPorts Layout
a' [Point Double] -> [Point Double] -> [Point Double]
forall a. Semigroup a => a -> a -> a
<> Layout -> [Point Double]
leftPorts Layout
b',
      rightPorts :: [Point Double]
rightPorts = Layout -> [Point Double]
rightPorts Layout
a' [Point Double] -> [Point Double] -> [Point Double]
forall a. Semigroup a => a -> a -> a
<> Layout -> [Point Double]
rightPorts Layout
b',
      bounds :: Rect Double
bounds = Layout -> Rect Double
bounds Layout
a' Rect Double -> Rect Double -> Rect Double
forall a. Semigroup a => a -> a -> a
<> Layout -> Rect Double
bounds Layout
b'
    }
  where
    half :: Double
half = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Layout -> Int
slots Layout
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Layout -> Int
slots Layout
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
portPitch Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    slotY :: Int -> Double
slotY Int
i = Double
half Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
portPitch
    a' :: Layout
a' = Point Double -> Layout -> Layout
moveLayout (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (-Layout -> Double
lx Layout
a) (Int -> Double
slotY Int
0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Layout -> Double
anchorY Layout
a)) Layout
a
    b' :: Layout
b' = Point Double -> Layout -> Layout
moveLayout (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (-Layout -> Double
lx Layout
b) (Int -> Double
slotY (Layout -> Int
slots Layout
a) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Layout -> Double
anchorY Layout
b)) Layout
b

-- | Bounding-box tensor: fallback for port-less diagrams.
boxBeside :: Layout -> Layout -> Layout
boxBeside :: Layout -> Layout -> Layout
boxBeside Layout
a Layout
b =
  Layout
    { picture :: ChartTree
picture = Maybe Text -> [ChartTree] -> ChartTree
group Maybe Text
forall a. Maybe a
Nothing [Layout -> ChartTree
picture Layout
a', Layout -> ChartTree
picture Layout
b'],
      leftPorts :: [Point Double]
leftPorts = Layout -> [Point Double]
leftPorts Layout
a' [Point Double] -> [Point Double] -> [Point Double]
forall a. Semigroup a => a -> a -> a
<> Layout -> [Point Double]
leftPorts Layout
b',
      rightPorts :: [Point Double]
rightPorts = Layout -> [Point Double]
rightPorts Layout
a' [Point Double] -> [Point Double] -> [Point Double]
forall a. Semigroup a => a -> a -> a
<> Layout -> [Point Double]
rightPorts Layout
b',
      bounds :: Rect Double
bounds = Layout -> Rect Double
bounds Layout
a' Rect Double -> Rect Double -> Rect Double
forall a. Semigroup a => a -> a -> a
<> Layout -> Rect Double
bounds Layout
b'
    }
  where
    -- place a above b with tensorGap between bounding boxes
    ay :: Double
ay = -(Layout -> Double
midY Layout
a) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Layout -> Double
layoutHeight Layout
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tensorGap Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    by :: Double
by = -(Layout -> Double
midY Layout
b) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Layout -> Double
layoutHeight Layout
b Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
tensorGap Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    a' :: Layout
a' = Point Double -> Layout -> Layout
moveLayout (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (-Layout -> Double
lx Layout
a) Double
ay) Layout
a
    b' :: Layout
b' = Point Double -> Layout -> Layout
moveLayout (Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (-Layout -> Double
lx Layout
b) Double
by) Layout
b

-- | Boundary slot count of a layout: the larger port-list length.
slots :: Layout -> Int
slots :: Layout -> Int
slots Layout
l = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max ([Point Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Layout -> [Point Double]
leftPorts Layout
l)) ([Point Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Layout -> [Point Double]
rightPorts Layout
l))

-- | Vertical anchor of a layout: its first left port, or its first right
-- port when it has no left ports.
anchorY :: Layout -> Double
anchorY :: Layout -> Double
anchorY Layout
l = case Layout -> [Point Double]
leftPorts Layout
l of
  (Point Double
_ Double
y : [Point Double]
_) -> Double
y
  [] -> case Layout -> [Point Double]
rightPorts Layout
l of
    (Point Double
_ Double
y : [Point Double]
_) -> Double
y
    [] -> Double
0

turnL :: Layout -> Layout
turnL :: Layout -> Layout
turnL Layout
lay =
  Layout
    { picture :: ChartTree
picture = Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
-> ([Chart] -> [Chart]) -> ChartTree -> ChartTree
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
charts' ((Chart -> Chart) -> [Chart] -> [Chart]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Point Double -> Chart -> Chart
rotateChartData Double
forall a. Floating a => a
pi Point Double
c)) (Layout -> ChartTree
picture Layout
lay),
      -- dual: old right becomes left, reversed; old left becomes right, reversed
      leftPorts :: [Point Double]
leftPorts = [Point Double] -> [Point Double]
forall a. [a] -> [a]
reverse (Point Double -> Point Double
reflect (Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Layout -> [Point Double]
rightPorts Layout
lay),
      rightPorts :: [Point Double]
rightPorts = [Point Double] -> [Point Double]
forall a. [a] -> [a]
reverse (Point Double -> Point Double
reflect (Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Layout -> [Point Double]
leftPorts Layout
lay),
      bounds :: Rect Double
bounds = Rect Double -> Rect Double
reflectRect (Layout -> Rect Double
bounds Layout
lay)
    }
  where
    c :: Point Double
c = Rect Double -> Point Double
centre (Layout -> Rect Double
bounds Layout
lay)
    reflect :: Point Double -> Point Double
reflect (Point Double
x Double
y) =
      let Point Double
cx Double
cy = Point Double
c
       in Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x) (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y)
    reflectRect :: Rect Double -> Rect Double
reflectRect (Rect Double
x Double
z Double
y Double
w) =
      let Point Double
cx Double
cy = Point Double
c
       in Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
z) (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x) (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w) (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y)

--------------------------------------------------------------------------------
-- helpers
--------------------------------------------------------------------------------

lx :: Layout -> Double
lx :: Layout -> Double
lx (Layout ChartTree
_ [Point Double]
_ [Point Double]
_ (Rect Double
x Double
_ Double
_ Double
_)) = Double
x

rx :: Layout -> Double
rx :: Layout -> Double
rx (Layout ChartTree
_ [Point Double]
_ [Point Double]
_ (Rect Double
_ Double
z Double
_ Double
_)) = Double
z

midY :: Layout -> Double
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

centre :: Rect Double -> Point Double
centre :: Rect Double -> Point Double
centre (Rect Double
x Double
z Double
y Double
w) = Double -> Double -> Point Double
forall a. a -> a -> Point a
Point ((Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
z) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) ((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)

alignY :: [Point Double] -> [Point Double] -> Double
alignY :: [Point Double] -> [Point Double] -> Double
alignY (Point Double
_ Double
ya : [Point Double]
_) (Point Double
_ Double
yb : [Point Double]
_) = Double
ya Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
yb
alignY [Point Double]
_ [Point Double]
_ = Double
0

connectPorts :: [Point Double] -> [Point Double] -> ChartTree
connectPorts :: [Point Double] -> [Point Double] -> ChartTree
connectPorts [Point Double]
as [Point Double]
bs =
  [Chart] -> ChartTree
unnamed
    [ Style -> [[Point Double]] -> Chart
LineChart (Colour -> Style
wireStyle Colour
wireGrey) [[Point Double
p, Point Double
q]]
    | (Point Double
p, Point Double
q) <- [Point Double] -> [Point Double] -> [(Point Double, Point Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Point Double]
as [Point Double]
bs,
      Point Double
p Point Double -> Point Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Point Double
q
    ]

rotateChartData :: Double -> Point Double -> Chart -> Chart
rotateChartData :: Double -> Point Double -> Chart -> Chart
rotateChartData Double
theta Point Double
c = Optic A_Lens NoIx Chart Chart ChartData ChartData
-> (ChartData -> ChartData) -> Chart -> Chart
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Lens NoIx Chart Chart ChartData ChartData
#chartData (Double -> Point Double -> ChartData -> ChartData
rotateData Double
theta Point Double
c)

rotateData :: Double -> Point Double -> ChartData -> ChartData
rotateData :: Double -> Point Double -> ChartData -> ChartData
rotateData Double
theta Point Double
c = \case
  RectData [Rect Double]
rs -> [Rect Double] -> ChartData
RectData ((Rect Double -> Rect Double) -> [Rect Double] -> [Rect Double]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Point Double -> Rect Double -> Rect Double
rotateRect Double
theta Point Double
c) [Rect Double]
rs)
  LineData [[Point Double]]
lss -> [[Point Double]] -> ChartData
LineData (([Point Double] -> [Point Double])
-> [[Point Double]] -> [[Point Double]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c)) [[Point Double]]
lss)
  GlyphData [Point Double]
ps -> [Point Double] -> ChartData
GlyphData ((Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c) [Point Double]
ps)
  TextData [(Text, Point Double)]
ts -> [(Text, Point Double)] -> ChartData
TextData (((Text, Point Double) -> (Text, Point Double))
-> [(Text, Point Double)] -> [(Text, Point Double)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point Double -> Point Double)
-> (Text, Point Double) -> (Text, Point Double)
forall a b. (a -> b) -> (Text, a) -> (Text, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c)) [(Text, Point Double)]
ts)
  PathData [PathData Double]
ps -> [PathData Double] -> ChartData
PathData ((PathData Double -> PathData Double)
-> [PathData Double] -> [PathData Double]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Point Double -> PathData Double -> PathData Double
rotatePath Double
theta Point Double
c) [PathData Double]
ps)
  BlankData [Rect Double]
rs -> [Rect Double] -> ChartData
BlankData ((Rect Double -> Rect Double) -> [Rect Double] -> [Rect Double]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Point Double -> Rect Double -> Rect Double
rotateRect Double
theta Point Double
c) [Rect Double]
rs)

rotatePoint :: Double -> Point Double -> Point Double -> Point Double
rotatePoint :: Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta (Point Double
cx Double
cy) (Point Double
x Double
y) =
  let dx :: Double
dx = Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cx
      dy :: Double
dy = Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cy
      ct :: Double
ct = Double -> Double
forall a. Floating a => a -> a
cos Double
theta
      st :: Double
st = Double -> Double
forall a. Floating a => a -> a
sin Double
theta
   in Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ct Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
st Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dy) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
st Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ct Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dy)

rotateRect :: Double -> Point Double -> Rect Double -> Rect Double
rotateRect :: Double -> Point Double -> Rect Double -> Rect Double
rotateRect Double
theta Point Double
c (Rect Double
x Double
z Double
y Double
w) =
  let corners :: [Point Double]
corners = [Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x Double
y, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
z Double
y, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
x Double
w, Double -> Double -> Point Double
forall a. a -> a -> Point a
Point Double
z Double
w]
      cs :: [Point Double]
cs = Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c (Point Double -> Point Double) -> [Point Double] -> [Point Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
corners
      xs :: [Double]
xs = (\(Point Double
px Double
_) -> Double
px) (Point Double -> Double) -> [Point Double] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
cs
      ys :: [Double]
ys = (\(Point Double
_ Double
py) -> Double
py) (Point Double -> Double) -> [Point Double] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
cs
   in Double -> Double -> Double -> Double -> Rect Double
forall a. a -> a -> a -> a -> Rect a
Rect ([Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Double]
xs) ([Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Double]
xs) ([Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Double]
ys) ([Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Double]
ys)

rotatePath :: Double -> Point Double -> PathData Double -> PathData Double
rotatePath :: Double -> Point Double -> PathData Double -> PathData Double
rotatePath Double
theta Point Double
c = \case
  StartP Point Double
p -> Point Double -> PathData Double
forall a. Point a -> PathData a
StartP (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
p)
  LineP Point Double
p -> Point Double -> PathData Double
forall a. Point a -> PathData a
LineP (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
p)
  CubicP Point Double
a Point Double
b Point Double
p -> Point Double -> Point Double -> Point Double -> PathData Double
forall a. Point a -> Point a -> Point a -> PathData a
CubicP (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
a) (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
b) (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
p)
  QuadP Point Double
a Point Double
p -> Point Double -> Point Double -> PathData Double
forall a. Point a -> Point a -> PathData a
QuadP (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
a) (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
p)
  ArcP ArcInfo Double
i Point Double
p -> ArcInfo Double -> Point Double -> PathData Double
forall a. ArcInfo a -> Point a -> PathData a
ArcP ArcInfo Double
i (Double -> Point Double -> Point Double -> Point Double
rotatePoint Double
theta Point Double
c Point Double
p)

--------------------------------------------------------------------------------
-- structural counts
--------------------------------------------------------------------------------

countCharts :: Layout -> Int
countCharts :: Layout -> Int
countCharts = [Chart] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Chart] -> Int) -> (Layout -> [Chart]) -> Layout -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
-> ChartTree -> [Chart]
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
charts' (ChartTree -> [Chart])
-> (Layout -> ChartTree) -> Layout -> [Chart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> ChartTree
picture

countLines :: Layout -> Int
countLines :: Layout -> Int
countLines = (Chart -> Bool) -> Layout -> Int
countPred Chart -> Bool
isLine
  where
    isLine :: Chart -> Bool
isLine (Chart Style
_ (LineData [[Point Double]]
_)) = Bool
True
    isLine Chart
_ = Bool
False

countRects :: Layout -> Int
countRects :: Layout -> Int
countRects = (Chart -> Bool) -> Layout -> Int
countPred Chart -> Bool
isRect
  where
    isRect :: Chart -> Bool
isRect (Chart Style
_ (RectData [Rect Double]
_)) = Bool
True
    isRect Chart
_ = Bool
False

countPaths :: Layout -> Int
countPaths :: Layout -> Int
countPaths = (Chart -> Bool) -> Layout -> Int
countPred Chart -> Bool
isPath
  where
    isPath :: Chart -> Bool
isPath (Chart Style
_ (PathData [PathData Double]
_)) = Bool
True
    isPath Chart
_ = Bool
False

-- | Glyph charts (spider dots, port pads, wiring-error markers).
countGlyphs :: Layout -> Int
countGlyphs :: Layout -> Int
countGlyphs = (Chart -> Bool) -> Layout -> Int
countPred Chart -> Bool
isGlyph
  where
    isGlyph :: Chart -> Bool
isGlyph (Chart Style
_ (GlyphData [Point Double]
_)) = Bool
True
    isGlyph Chart
_ = Bool
False

countPred :: (Chart -> Bool) -> Layout -> Int
countPred :: (Chart -> Bool) -> Layout -> Int
countPred Chart -> Bool
p = [Chart] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Chart] -> Int) -> (Layout -> [Chart]) -> Layout -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chart -> Bool) -> [Chart] -> [Chart]
forall a. (a -> Bool) -> [a] -> [a]
filter Chart -> Bool
p ([Chart] -> [Chart]) -> (Layout -> [Chart]) -> Layout -> [Chart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
-> ChartTree -> [Chart]
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf Optic A_Traversal NoIx ChartTree ChartTree [Chart] [Chart]
charts' (ChartTree -> [Chart])
-> (Layout -> ChartTree) -> Layout -> [Chart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> ChartTree
picture