{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Modelling.Auxiliary.Diagrams (
  arrowheadDiamond,
  arrowheadFilledDiamond,
  arrowheadTriangle,
  arrowheadV,
  arrowheadVee,
  connectOutside'',
  connectWithPath,
  flipArrow,
  nonEmptyPathBetween,
  text',
  textU,
  trailBetween,
  veeArrow,
  ) where

import Control.Lens.Operators           ((.~), (^.))
import Data.Data                        (Typeable)
import Data.Function                    ((&))
import Data.GraphViz                    (DirType (Back, Both, Forward, NoDir))
import Data.Maybe                       (fromJust, fromMaybe)
import Data.Semigroup                   (Any)
import Diagrams.Angle (
  Angle,
  (@@),
  cosA,
  deg,
  halfTurn,
  quarterTurn,
  rotate,
  sinA,
  tanA,
  )
import Diagrams.Attributes (
#if MIN_VERSION_SVGFonts(1,8,0)
  lw,
  none,
#endif
  lwL,
  )
import Diagrams.Backend.SVG (
  B,
  SVG,
  svgClass,
  )
import Diagrams.BoundingBox             (boundingBox, boxExtents)
import Diagrams.Combinators             (atop)
import Diagrams.Located                 (Located (unLoc), at)
import Diagrams.Names                   (IsName (toName), location, lookupName)
import Diagrams.Parametric              (Codomain, Parametric, atParam)
import Diagrams.Path                    (Path, pathPoints, pathTrails)
import Diagrams.Points                  (Point (P), (*.))
import Diagrams.Prelude (
  (*^),
  (^+^),
  (^-^),
  (^/),
  Affine (..),
#if MIN_VERSION_SVGFonts(1,8,0)
  Default (def),
#endif
  Diagram,
  Metric,
  N,
  OrderedField,
  QDiagram,
  V,
  V2,
  _x,
  _y,
  black,
  distanceA,
  fromMeasured,
  negated,
  norm,
  unP,
  unitX,
  unitY,
  )
import Diagrams.Tangent (
  Tangent,
  normalAtParam,
  tangentAtEnd,
  tangentAtStart,
  )
import Diagrams.Trace                   (maxTraceP, traceP)
import Diagrams.Trail                   (Trail)
import Diagrams.TrailLike               (fromVertices)
import Diagrams.Transform               (place, scale, translate)
import Diagrams.TwoD.Arc                (arcCCW, arcCW)
import Diagrams.TwoD.Align              (alignL, alignR, centerXY)
import Diagrams.TwoD.Arrow              (
  ArrowOpts,
  arrowBetween',
  arrowHead,
  arrowShaft,
  arrowTail,
  headGap,
  headLength,
  tailGap,
  tailLength,
  )
import Diagrams.TwoD.Arrowheads         (ArrowHT)
import Diagrams.TwoD.Attributes         (fc, lc)
import Diagrams.TwoD.Polygons (
  PolyOrientation (NoOrient),
  PolyType (PolySides),
  polyOrient,
  polyType,
  polygon,
  )
import Diagrams.TwoD.Shapes             (rect)
import Diagrams.TwoD.Transform          (reflectX, scaleX, scaleY)
import Diagrams.TwoD.Vector             (angleDir, signedAngleBetween, unit_X)
import Diagrams.Util                    ((#), with)
import Graphics.SVGFonts (
  TextOpts (..),
#if MIN_VERSION_SVGFonts(1,8,0)
  fit_height,
  set_envelope,
  svgText,
#else
  Spacing (..),
  Mode (..),
  textSVG_,
#endif
  )
import Graphics.SVGFonts.ReadFont       (PreparedFont)

veeArrow :: ArrowHT Double
veeArrow :: ArrowHT Double
veeArrow = Angle Double -> ArrowHT Double
forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadVee (Double
150 Double -> AReview (Angle Double) Double -> Angle Double
forall b a. b -> AReview a b -> a
@@ AReview (Angle Double) Double
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle Double) Double
deg)

arrowheadV :: RealFloat n => Angle n -> ArrowHT n
arrowheadV :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadV Angle n
theta n
arrowHeadLength n
shaftWidth =
  --(jt, mempty)
  (Path V2 n
jt Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# Path V2 n -> Path V2 n
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignR, Path V2 n
line Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# Path V2 n -> Path V2 n
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignR)
  where
    shift :: Bool -> Path V2 n -> Path V2 n
shift Bool
right =
      Vn (Path V2 n) -> Path V2 n -> Path V2 n
forall t. Transformable t => Vn t -> t -> t
translate (Point (V (Path V2 n)) (N (Path V2 n)) -> Vn (Path V2 n)
forall (f :: * -> *) a. Point f a -> f a
unP (Point (V (Path V2 n)) (N (Path V2 n)) -> Vn (Path V2 n))
-> Point (V (Path V2 n)) (N (Path V2 n)) -> Vn (Path V2 n)
forall a b. (a -> b) -> a -> b
$ (n
factor n -> n -> n
forall a. Num a => a -> a -> a
* Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
theta n -> n -> n
forall a. Num a => a -> a -> a
* n
arrowHeadLength n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2) n -> Point V2 n -> Point V2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
n -> Point v n -> Point v n
*. Point V2 n
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY)
      (Path V2 n -> Path V2 n)
-> (Path V2 n -> Path V2 n) -> Path V2 n -> Path V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vn (Path V2 n) -> Path V2 n -> Path V2 n
forall t. Transformable t => Vn t -> t -> t
translate (Point (V (Path V2 n)) (N (Path V2 n)) -> Vn (Path V2 n)
forall (f :: * -> *) a. Point f a -> f a
unP (Point (V (Path V2 n)) (N (Path V2 n)) -> Vn (Path V2 n))
-> Point (V (Path V2 n)) (N (Path V2 n)) -> Vn (Path V2 n)
forall a b. (a -> b) -> a -> b
$ (Angle n -> n
forall n. Floating n => Angle n -> n
cosA Angle n
theta n -> n -> n
forall a. Num a => a -> a -> a
* n
arrowHeadLength n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2) n -> Point V2 n -> Point V2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
n -> Point v n -> Point v n
*. Point V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX)
      where factor :: n
factor = if Bool
right then -n
1 else n
1
    opposingTheta :: Angle n
opposingTheta = (- (Angle n
theta Angle n -> Getting n (Angle n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (Angle n) n
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle n) n
deg)) n -> AReview (Angle n) n -> Angle n
forall b a. b -> AReview a b -> a
@@ AReview (Angle n) n
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle n) n
deg
    jt :: Path V2 n
jt = Bool -> Path V2 n -> Path V2 n
shift Bool
True (Angle n -> Path V2 n -> Path V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
opposingTheta Path V2 n
line)
      Path V2 n -> Path V2 n -> Path V2 n
forall a. Semigroup a => a -> a -> a
<> Bool -> Path V2 n -> Path V2 n
shift Bool
False (Angle n -> Path V2 n -> Path V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta Path V2 n
line)
      -- <> translate (unP $ (shaftWidth * sinA theta / 2) *. unitX) tip
    -- tip = rotate (-90 @@ deg) (scaleY (sinA theta) (triangle shaftWidth))
    line :: Path V2 n
line = n -> n -> Path V2 n
forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect n
arrowHeadLength n
shaftWidth

arrowheadVee :: RealFloat n => Angle n -> ArrowHT n
arrowheadVee :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadVee Angle n
theta n
arrowHeadLength n
shaftWidth = (
  Angle n -> Path V2 n -> Path V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
forall v. Floating v => Angle v
quarterTurn) (
    PolygonOpts n -> Path V2 n
forall n t. (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon (PolygonOpts n -> Path V2 n) -> PolygonOpts n -> Path V2 n
forall a b. (a -> b) -> a -> b
$ PolygonOpts n
forall d. Default d => d
with
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyType n -> Identity (PolyType n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyType n -> f (PolyType n))
-> PolygonOpts n -> f (PolygonOpts n)
polyType ((PolyType n -> Identity (PolyType n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyType n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyType n
polySides
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyOrientation n -> Identity (PolyOrientation n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyOrientation n -> f (PolyOrientation n))
-> PolygonOpts n -> f (PolygonOpts n)
polyOrient ((PolyOrientation n -> Identity (PolyOrientation n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyOrientation n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyOrientation n
forall n. PolyOrientation n
NoOrient
    ) Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# Path V2 n -> Path V2 n
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignL,
  Path V2 n
forall a. Monoid a => a
mempty
  )
  where
    start :: n
start = n
arrowHeadLength
    arrowHeadLength' :: n
arrowHeadLength' = n
arrowHeadLength n -> n -> n
forall a. Num a => a -> a -> a
- n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
tanA Angle n
theta' n -> n -> n
forall a. Num a => a -> a -> a
- n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2 n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
theta'
    theta' :: Angle n
theta' = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
theta
    a1 :: Angle n
a1 = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle n
theta'
    a2 :: Angle n
a2 = Angle n
theta Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
theta'
    w :: n
w = n
shaftWidth
    polySides :: PolyType n
polySides = ([Angle n] -> [n] -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Angle n] -> [n] -> PolyType n
forall n. [Angle n] -> [n] -> PolyType n
PolySides (([Angle n], [n]) -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b. (a -> b) -> a -> b
$ [(Angle n, n)] -> ([Angle n], [n])
forall a b. [(a, b)] -> ([a], [b])
unzip [
      (Angle n
a1, n
start),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
arrowHeadLength'),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w),
      (Angle n
a2, n
arrowHeadLength),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
arrowHeadLength),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w),
      (Angle n
a1, n
arrowHeadLength'),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
start),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w)
      ]

arrowheadTriangle :: RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle Angle n
theta n
arrowHeadLength n
shaftWidth = (
  Angle n -> Path V2 n -> Path V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
forall v. Floating v => Angle v
quarterTurn) (
    PolygonOpts n -> Path V2 n
forall n t. (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon (PolygonOpts n -> Path V2 n) -> PolygonOpts n -> Path V2 n
forall a b. (a -> b) -> a -> b
$ PolygonOpts n
forall d. Default d => d
with
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyType n -> Identity (PolyType n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyType n -> f (PolyType n))
-> PolygonOpts n -> f (PolygonOpts n)
polyType ((PolyType n -> Identity (PolyType n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyType n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyType n
polySides
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyOrientation n -> Identity (PolyOrientation n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyOrientation n -> f (PolyOrientation n))
-> PolygonOpts n -> f (PolygonOpts n)
polyOrient ((PolyOrientation n -> Identity (PolyOrientation n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyOrientation n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyOrientation n
forall n. PolyOrientation n
NoOrient
    ) Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# Path V2 n -> Path V2 n
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignL,
  Path V2 n
forall a. Monoid a => a
mempty
  )
  where
    start :: n
start = n
0
    arrowHeadLength' :: n
arrowHeadLength' = n
arrowHeadLength n -> n -> n
forall a. Num a => a -> a -> a
* Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
theta' n -> n -> n
forall a. Num a => a -> a -> a
- n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2
    arrowHeadLengthI' :: n
arrowHeadLengthI' = n
arrowHeadLengthI n -> n -> n
forall a. Num a => a -> a -> a
* Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
theta'
    arrowHeadLengthI :: n
arrowHeadLengthI = n
arrowHeadLength
      n -> n -> n
forall a. Num a => a -> a -> a
- n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
cosA Angle n
theta'
      n -> n -> n
forall a. Num a => a -> a -> a
- n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
tanA Angle n
theta'
      n -> n -> n
forall a. Num a => a -> a -> a
- n
w n -> n -> n
forall a. Num a => a -> a -> a
* Angle n -> n
forall n. Floating n => Angle n -> n
tanA Angle n
theta'
    theta' :: Angle n
theta' = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
theta
    a1 :: Angle n
a1 = Angle n
forall v. Floating v => Angle v
quarterTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle n
theta'
    a2 :: Angle n
a2 = Angle n
theta Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
theta'
    a2' :: Angle n
a2' = Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
a2
    a1' :: Angle n
a1' = Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
a1
    w :: n
w = n
shaftWidth
    polySides :: PolyType n
polySides = ([Angle n] -> [n] -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Angle n] -> [n] -> PolyType n
forall n. [Angle n] -> [n] -> PolyType n
PolySides (([Angle n], [n]) -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b. (a -> b) -> a -> b
$ [(Angle n, n)] -> ([Angle n], [n])
forall a b. [(a, b)] -> ([a], [b])
unzip [
      (Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
forall v. Floating v => Angle v
quarterTurn, n
start),
      (Angle n
a1, n
arrowHeadLength'),
      (Angle n
a2, n
arrowHeadLength),
      (Angle n
a1, n
arrowHeadLength),
      (Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
forall v. Floating v => Angle v
quarterTurn, n
arrowHeadLength'),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
start),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w n -> n -> n
forall a. Num a => a -> a -> a
+ n
start),
      (Angle n
a1', n
arrowHeadLengthI'),
      (Angle n
a2', n
arrowHeadLengthI),
      (Angle n
a1', n
arrowHeadLengthI),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
arrowHeadLengthI'),
      (Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
forall v. Floating v => Angle v
quarterTurn, n
w n -> n -> n
forall a. Num a => a -> a -> a
+ n
start),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2)
      ]

arrowheadDiamond :: RealFloat n => Angle n -> ArrowHT n
arrowheadDiamond :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadDiamond Angle n
theta n
arrowHeadLength n
shaftWidth = (
  Angle n -> Path V2 n -> Path V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate (Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
forall v. Floating v => Angle v
quarterTurn) (
    PolygonOpts n -> Path V2 n
forall n t. (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon (PolygonOpts n -> Path V2 n) -> PolygonOpts n -> Path V2 n
forall a b. (a -> b) -> a -> b
$ PolygonOpts n
forall d. Default d => d
with
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyType n -> Identity (PolyType n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyType n -> f (PolyType n))
-> PolygonOpts n -> f (PolygonOpts n)
polyType ((PolyType n -> Identity (PolyType n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyType n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~  PolyType n
polySides
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyOrientation n -> Identity (PolyOrientation n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyOrientation n -> f (PolyOrientation n))
-> PolygonOpts n -> f (PolygonOpts n)
polyOrient ((PolyOrientation n -> Identity (PolyOrientation n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyOrientation n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyOrientation n
forall n. PolyOrientation n
NoOrient
    ) Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# Path V2 n -> Path V2 n
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignL,
  Path V2 n
forall a. Monoid a => a
mempty
  )
  where
    dw :: n
dw = n
w n -> n -> n
forall a. Num a => a -> a -> a
+ n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
theta' n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2
    w' :: n
w' = n
shaftWidth n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
theta n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2
    arrowHeadLength' :: n
arrowHeadLength' = n
arrowHeadLength n -> n -> n
forall a. Num a => a -> a -> a
- n
w'
    arrowHeadLengthI' :: n
arrowHeadLengthI' = n
arrowHeadLength n -> n -> n
forall a. Num a => a -> a -> a
- n
2 n -> n -> n
forall a. Num a => a -> a -> a
* n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
a1
    theta' :: Angle n
theta' = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
theta
    a1 :: Angle n
a1 = n
2 n -> Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Angle n
theta'
    a2 :: Angle n
a2 = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
a1
    a3 :: Angle n
a3 = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle n
theta
    a3' :: Angle n
a3' = Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
a3
    a2' :: Angle n
a2' = Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
a2
    a1' :: Angle n
a1' = Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
a1
    w :: n
w = n
shaftWidth
    polySides :: PolyType n
polySides = ([Angle n] -> [n] -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Angle n] -> [n] -> PolyType n
forall n. [Angle n] -> [n] -> PolyType n
PolySides (([Angle n], [n]) -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b. (a -> b) -> a -> b
$ [(Angle n, n)] -> ([Angle n], [n])
forall a b. [(a, b)] -> ([a], [b])
unzip [
      (Angle n
a3, n
w),
      (Angle n
a1, n
arrowHeadLength'),
      (Angle n
a2, n
arrowHeadLength),
      (Angle n
a1, n
arrowHeadLength),
      (Angle n
a3, n
arrowHeadLength'),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2),
      (Angle n
a3', n
dw),
      (Angle n
a1', n
arrowHeadLengthI'),
      (Angle n
a2', n
arrowHeadLengthI'),
      (Angle n
a1', n
arrowHeadLengthI'),
      (Angle n
a3', n
arrowHeadLengthI'),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
dw),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2)
      ]

arrowheadFilledDiamond :: RealFloat n => Angle n -> ArrowHT n
arrowheadFilledDiamond :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadFilledDiamond Angle n
theta n
arrowHeadLength n
shaftWidth = (
  Path V2 n -> Path V2 n
forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
t -> t
reflectX (Path V2 n -> Path V2 n) -> Path V2 n -> Path V2 n
forall a b. (a -> b) -> a -> b
$
    PolygonOpts n -> Path V2 n
forall n t. (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon (
      PolygonOpts n
forall d. Default d => d
with
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyType n -> Identity (PolyType n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyType n -> f (PolyType n))
-> PolygonOpts n -> f (PolygonOpts n)
polyType ((PolyType n -> Identity (PolyType n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyType n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyType n
polySides
      PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyOrientation n -> Identity (PolyOrientation n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyOrientation n -> f (PolyOrientation n))
-> PolygonOpts n -> f (PolygonOpts n)
polyOrient ((PolyOrientation n -> Identity (PolyOrientation n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyOrientation n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyOrientation n
forall n. PolyOrientation n
NoOrient
    ) Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# Path V2 n -> Path V2 n
forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignR,
  Path V2 n
forall a. Monoid a => a
mempty
  )
  where
    arrowHeadLength' :: n
arrowHeadLength' = n
arrowHeadLength n -> n -> n
forall a. Num a => a -> a -> a
- n
shaftWidth n -> n -> n
forall a. Fractional a => a -> a -> a
/ Angle n -> n
forall n. Floating n => Angle n -> n
sinA Angle n
theta n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2
    theta' :: Angle n
theta' = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
theta
    a1 :: Angle n
a1 = n
2 n -> Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Angle n
theta'
    a2 :: Angle n
a2 = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
a1
    a3 :: Angle n
a3 = Angle n
forall v. Floating v => Angle v
halfTurn Angle n -> Angle n -> Angle n
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle n
theta
    w :: n
w = n
shaftWidth
    polySides :: PolyType n
polySides = ([Angle n] -> [n] -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Angle n] -> [n] -> PolyType n
forall n. [Angle n] -> [n] -> PolyType n
PolySides (([Angle n], [n]) -> PolyType n) -> ([Angle n], [n]) -> PolyType n
forall a b. (a -> b) -> a -> b
$ [(Angle n, n)] -> ([Angle n], [n])
forall a b. [(a, b)] -> ([a], [b])
unzip [
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w),
      (Angle n
a3, n
w),
      (Angle n
a1, n
arrowHeadLength'),
      (Angle n
a2, n
arrowHeadLength),
      (Angle n
a1, n
arrowHeadLength),
      (Angle n
a3, n
arrowHeadLength'),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w),
      (Angle n
forall v. Floating v => Angle v
quarterTurn, n
w)
      ]

nonEmptyPathBetween
  :: (IsName p1, IsName p2, Metric v, RealFloat n, Semigroup m)
  => Path v n
  -> p1
  -> p2
  -> QDiagram b v n m
  -> Path v n
nonEmptyPathBetween :: forall p1 p2 (v :: * -> *) n m b.
(IsName p1, IsName p2, Metric v, RealFloat n, Semigroup m) =>
Path v n -> p1 -> p2 -> QDiagram b v n m -> Path v n
nonEmptyPathBetween Path v n
p p1
ls p2
lt QDiagram b v n m
g =
  let (Point v n
x, Point v n
y, Point v n
z) = Maybe (Point v n, Point v n, Point v n)
-> (Point v n, Point v n, Point v n)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Point v n, Point v n, Point v n)
 -> (Point v n, Point v n, Point v n))
-> Maybe (Point v n, Point v n, Point v n)
-> (Point v n, Point v n, Point v n)
forall a b. (a -> b) -> a -> b
$ p1
-> p2
-> QDiagram b v n m
-> Maybe (Point v n, Point v n, Point v n)
forall n1 n2 (v :: * -> *) n m b.
(IsName n1, IsName n2, Metric v, RealFloat n, Semigroup m) =>
n1
-> n2
-> QDiagram b v n m
-> Maybe (Point v n, Point v n, Point v n)
pointsFromTo p1
ls p2
lt QDiagram b v n m
g
  in case Path v n -> [[Point v n]]
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Path v n -> [[Point v n]]
pathPoints Path v n
p of
    [] -> [Point (V (Path v n)) (N (Path v n))] -> Path v n
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices [Point v n
Point (V (Path v n)) (N (Path v n))
x, Point v n
Point (V (Path v n)) (N (Path v n))
y, Point v n
Point (V (Path v n)) (N (Path v n))
z]
    [[Point v n]]
_  -> Path v n
p

trailBetween
  :: (IsName n1, IsName n2, Semigroup m)
  => Path V2 Double
  -> n1
  -> n2
  -> QDiagram b V2 Double m
  -> Located (Trail V2 Double)
trailBetween :: forall n1 n2 m b.
(IsName n1, IsName n2, Semigroup m) =>
Path V2 Double
-> n1 -> n2 -> QDiagram b V2 Double m -> Located (Trail V2 Double)
trailBetween Path V2 Double
path n1
l1 n2
l2 QDiagram b V2 Double m
d =
  let x :: Located (Trail V2 Double)
x = [Located (Trail V2 Double)] -> Located (Trail V2 Double)
forall a. HasCallStack => [a] -> a
head ([Located (Trail V2 Double)] -> Located (Trail V2 Double))
-> [Located (Trail V2 Double)] -> Located (Trail V2 Double)
forall a b. (a -> b) -> a -> b
$ Path V2 Double -> [Located (Trail V2 Double)]
forall (v :: * -> *) n. Path v n -> [Located (Trail v n)]
pathTrails Path V2 Double
path
      points :: [Point V2 Double]
points = [[Point V2 Double]] -> [Point V2 Double]
forall a. HasCallStack => [a] -> a
head ([[Point V2 Double]] -> [Point V2 Double])
-> [[Point V2 Double]] -> [Point V2 Double]
forall a b. (a -> b) -> a -> b
$ Path V2 Double -> [[Point V2 Double]]
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Path v n -> [[Point v n]]
pathPoints Path V2 Double
path
      oldPos :: Point V2 Double
oldPos = [Point V2 Double] -> Point V2 Double
forall a. HasCallStack => [a] -> a
head [Point V2 Double]
points
      oldE :: Point V2 Double
oldE = [Point V2 Double] -> Point V2 Double
forall a. HasCallStack => [a] -> a
last [Point V2 Double]
points
  in Located (Trail V2 Double)
-> ((Point V2 Double, Point V2 Double, Point V2 Double)
    -> Located (Trail V2 Double))
-> Maybe (Point V2 Double, Point V2 Double, Point V2 Double)
-> Located (Trail V2 Double)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
       Located (Trail V2 Double)
x
       (\(Point V2 Double
pos, Point V2 Double
_, Point V2 Double
e) -> Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Located (Trail V2 Double)
-> Located (Trail V2 Double)
scaleAndPositionTrail Point V2 Double
pos Point V2 Double
e Point V2 Double
oldPos Point V2 Double
oldE Located (Trail V2 Double)
x)
       (Maybe (Point V2 Double, Point V2 Double, Point V2 Double)
 -> Located (Trail V2 Double))
-> Maybe (Point V2 Double, Point V2 Double, Point V2 Double)
-> Located (Trail V2 Double)
forall a b. (a -> b) -> a -> b
$ if n1 -> Name
forall a. IsName a => a -> Name
toName n1
l1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== n2 -> Name
forall a. IsName a => a -> Name
toName n2
l2 then Maybe (Point V2 Double, Point V2 Double, Point V2 Double)
forall a. Maybe a
Nothing else n1
-> n2
-> QDiagram b V2 Double m
-> Maybe (Point V2 Double, Point V2 Double, Point V2 Double)
forall n1 n2 (v :: * -> *) n m b.
(IsName n1, IsName n2, Metric v, RealFloat n, Semigroup m) =>
n1
-> n2
-> QDiagram b v n m
-> Maybe (Point v n, Point v n, Point v n)
pointsFromTo n1
l1 n2
l2 QDiagram b V2 Double m
d

scaleAndPositionTrail
  :: Point V2 Double
  -> Point V2 Double
  -> Point V2 Double
  -> Point V2 Double
  -> Located (Trail V2 Double)
  -> Located (Trail V2 Double)
scaleAndPositionTrail :: Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Located (Trail V2 Double)
-> Located (Trail V2 Double)
scaleAndPositionTrail Point V2 Double
pos Point V2 Double
e Point V2 Double
oldPos Point V2 Double
oldE Located (Trail V2 Double)
x = Double -> Trail V2 Double -> Trail V2 Double
forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale
  (Point V2 Double -> Point V2 Double -> Double
forall a (p :: * -> *).
(Floating a, Foldable (Diff p), Affine p) =>
p a -> p a -> a
distanceA Point V2 Double
e Point V2 Double
pos Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Point V2 Double -> Point V2 Double -> Double
forall a (p :: * -> *).
(Floating a, Foldable (Diff p), Affine p) =>
p a -> p a -> a
distanceA Point V2 Double
oldPos Point V2 Double
oldE)
  (Located (Trail V2 Double) -> Trail V2 Double
forall a. Located a -> a
unLoc Located (Trail V2 Double)
x)
  Trail V2 Double
-> Point (V (Trail V2 Double)) (N (Trail V2 Double))
-> Located (Trail V2 Double)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V (Trail V2 Double)) (N (Trail V2 Double))
Point V2 Double
pos

pointsFromTo
  :: (IsName n1, IsName n2, Metric v, RealFloat n, Semigroup m)
  => n1
  -> n2
  -> QDiagram b v n m
  -> Maybe (Point v n, Point v n, Point v n)
pointsFromTo :: forall n1 n2 (v :: * -> *) n m b.
(IsName n1, IsName n2, Metric v, RealFloat n, Semigroup m) =>
n1
-> n2
-> QDiagram b v n m
-> Maybe (Point v n, Point v n, Point v n)
pointsFromTo n1
n1 n2
n2 QDiagram b v n m
g = do
  Subdiagram b v n m
b1 <- n1 -> QDiagram b v n m -> Maybe (Subdiagram b v n m)
forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm -> QDiagram b v n m -> Maybe (Subdiagram b v n m)
lookupName n1
n1 QDiagram b v n m
g
  Subdiagram b v n m
b2 <- n2 -> QDiagram b v n m -> Maybe (Subdiagram b v n m)
forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm -> QDiagram b v n m -> Maybe (Subdiagram b v n m)
lookupName n2
n2 QDiagram b v n m
g
  let v :: Diff (Point v) n
v = Subdiagram b v n m -> Point v n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram b v n m
b2 Point v n -> Point v n -> Diff (Point v) n
forall a. Num a => Point v a -> Point v a -> Diff (Point v) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Subdiagram b v n m -> Point v n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram b v n m
b1
      midpoint :: Point v n
midpoint = Subdiagram b v n m -> Point v n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram b v n m
b1 Point v n -> Diff (Point v) n -> Point v n
forall a. Num a => Point v a -> Diff (Point v) a -> Point v a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (v n
Diff (Point v) n
v v n -> n -> v n
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ n
2)
      s' :: Point v n
s' = Point v n -> Maybe (Point v n) -> Point v n
forall a. a -> Maybe a -> a
fromMaybe (Subdiagram b v n m -> Point v n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram b v n m
b1) (Maybe (Point v n) -> Point v n) -> Maybe (Point v n) -> Point v n
forall a b. (a -> b) -> a -> b
$ Point (V (Subdiagram b v n m)) n
-> V (Subdiagram b v n m) n
-> Subdiagram b v n m
-> Maybe (Point (V (Subdiagram b v n m)) n)
forall n a.
(n ~ N a, Traced a, Num n) =>
Point (V a) n -> V a n -> a -> Maybe (Point (V a) n)
traceP Point v n
Point (V (Subdiagram b v n m)) n
midpoint (v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
Diff (Point v) n
v) Subdiagram b v n m
b1
      e' :: Point v n
e' = Point v n -> Maybe (Point v n) -> Point v n
forall a. a -> Maybe a -> a
fromMaybe (Subdiagram b v n m -> Point v n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram b v n m
b2) (Maybe (Point v n) -> Point v n) -> Maybe (Point v n) -> Point v n
forall a b. (a -> b) -> a -> b
$ Point (V (Subdiagram b v n m)) n
-> V (Subdiagram b v n m) n
-> Subdiagram b v n m
-> Maybe (Point (V (Subdiagram b v n m)) n)
forall n a.
(n ~ N a, Traced a, Num n) =>
Point (V a) n -> V a n -> a -> Maybe (Point (V a) n)
traceP Point v n
Point (V (Subdiagram b v n m)) n
midpoint V (Subdiagram b v n m) n
Diff (Point v) n
v Subdiagram b v n m
b2
  (Point v n, Point v n, Point v n)
-> Maybe (Point v n, Point v n, Point v n)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point v n
s', Point v n
midpoint, Point v n
e')

connectOutside''
  ::(IsName n1, IsName n2, RealFloat n, Show n, Typeable n)
  => ArrowOpts n
  -> n1
  -> n2
  -> QDiagram SVG V2 n Any
  -> QDiagram SVG V2 n Any
connectOutside'' :: forall n1 n2 n.
(IsName n1, IsName n2, RealFloat n, Show n, Typeable n) =>
ArrowOpts n
-> n1 -> n2 -> QDiagram B V2 n Any -> QDiagram B V2 n Any
connectOutside'' ArrowOpts n
opts n1
n1 n2
n2 QDiagram B V2 n Any
g =
  let (Point V2 n
s', Point V2 n
_, Point V2 n
e') = Maybe (Point V2 n, Point V2 n, Point V2 n)
-> (Point V2 n, Point V2 n, Point V2 n)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Point V2 n, Point V2 n, Point V2 n)
 -> (Point V2 n, Point V2 n, Point V2 n))
-> Maybe (Point V2 n, Point V2 n, Point V2 n)
-> (Point V2 n, Point V2 n, Point V2 n)
forall a b. (a -> b) -> a -> b
$ n1
-> n2
-> QDiagram B V2 n Any
-> Maybe (Point V2 n, Point V2 n, Point V2 n)
forall n1 n2 (v :: * -> *) n m b.
(IsName n1, IsName n2, Metric v, RealFloat n, Semigroup m) =>
n1
-> n2
-> QDiagram b v n m
-> Maybe (Point v n, Point v n, Point v n)
pointsFromTo n1
n1 n2
n2 QDiagram B V2 n Any
g
  in ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram B V2 n Any
forall n b.
(TypeableFloat n, Renderable (Path V2 n) b) =>
ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram b V2 n Any
arrowBetween' ArrowOpts n
opts Point V2 n
s' Point V2 n
e' QDiagram B V2 n Any
-> (QDiagram B V2 n Any -> QDiagram B V2 n Any)
-> QDiagram B V2 n Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram B V2 n Any -> QDiagram B V2 n Any
forall n.
SVGFloat n =>
String -> QDiagram B V2 n Any -> QDiagram B V2 n Any
svgClass String
"edge"
     QDiagram B V2 n Any -> QDiagram B V2 n Any -> QDiagram B V2 n Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
`atop` QDiagram B V2 n Any
g

pointsFromToWithAngle
  :: (IsName n1, IsName n2, RealFloat n)
  => n1
  -> n2
  -> Angle n
  -> Angle n
  -> QDiagram b V2 n Any
  -> Maybe (Point V2 n, Point V2 n)
pointsFromToWithAngle :: forall n1 n2 n b.
(IsName n1, IsName n2, RealFloat n) =>
n1
-> n2
-> Angle n
-> Angle n
-> QDiagram b V2 n Any
-> Maybe (Point V2 n, Point V2 n)
pointsFromToWithAngle n1
n1 n2
n2 Angle n
a1 Angle n
a2 QDiagram b V2 n Any
g = do
  Subdiagram b V2 n Any
sub1 <- n1 -> QDiagram b V2 n Any -> Maybe (Subdiagram b V2 n Any)
forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm -> QDiagram b v n m -> Maybe (Subdiagram b v n m)
lookupName n1
n1 QDiagram b V2 n Any
g
  Subdiagram b V2 n Any
sub2 <- n2 -> QDiagram b V2 n Any -> Maybe (Subdiagram b V2 n Any)
forall nm (v :: * -> *) m n b.
(IsName nm, Metric v, Semigroup m, OrderedField n) =>
nm -> QDiagram b v n m -> Maybe (Subdiagram b v n m)
lookupName n2
n2 QDiagram b V2 n Any
g
  let os :: Point V2 n
os = Subdiagram b V2 n Any -> Point V2 n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram b V2 n Any
sub1
      oe :: Point V2 n
oe = Subdiagram b V2 n Any -> Point V2 n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location Subdiagram b V2 n Any
sub2
      s :: Point V2 n
s = Point V2 n -> Maybe (Point V2 n) -> Point V2 n
forall a. a -> Maybe a -> a
fromMaybe Point V2 n
os (Point (V (Subdiagram b V2 n Any)) n
-> V (Subdiagram b V2 n Any) n
-> Subdiagram b V2 n Any
-> Maybe (Point (V (Subdiagram b V2 n Any)) n)
forall n a.
(n ~ N a, Num n, Traced a) =>
Point (V a) n -> V a n -> a -> Maybe (Point (V a) n)
maxTraceP Point (V (Subdiagram b V2 n Any)) n
Point V2 n
os (V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX V2 n -> (V2 n -> V2 n) -> V2 n
forall a b. a -> (a -> b) -> b
# Angle n -> V2 n -> V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
a1) Subdiagram b V2 n Any
sub1)
      e :: Point V2 n
e = Point V2 n -> Maybe (Point V2 n) -> Point V2 n
forall a. a -> Maybe a -> a
fromMaybe Point V2 n
oe (Point (V (Subdiagram b V2 n Any)) n
-> V (Subdiagram b V2 n Any) n
-> Subdiagram b V2 n Any
-> Maybe (Point (V (Subdiagram b V2 n Any)) n)
forall n a.
(n ~ N a, Num n, Traced a) =>
Point (V a) n -> V a n -> a -> Maybe (Point (V a) n)
maxTraceP Point (V (Subdiagram b V2 n Any)) n
Point V2 n
oe (V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX V2 n -> (V2 n -> V2 n) -> V2 n
forall a b. a -> (a -> b) -> b
# Angle n -> V2 n -> V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
a2) Subdiagram b V2 n Any
sub2)
  (Point V2 n, Point V2 n) -> Maybe (Point V2 n, Point V2 n)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point V2 n
s, Point V2 n
e)

connectPerim''
  :: (IsName n1, IsName n2, RealFloat n, Typeable n, Show n)
  => ArrowOpts n
  -> n1
  -> n2
  -> Angle n
  -> Angle n
  -> QDiagram SVG V2 n Any
  -> QDiagram SVG V2 n Any
connectPerim'' :: forall n1 n2 n.
(IsName n1, IsName n2, RealFloat n, Typeable n, Show n) =>
ArrowOpts n
-> n1
-> n2
-> Angle n
-> Angle n
-> QDiagram B V2 n Any
-> QDiagram B V2 n Any
connectPerim'' ArrowOpts n
opts n1
n1 n2
n2 Angle n
a1 Angle n
a2 QDiagram B V2 n Any
g =
  let (Point V2 n
s', Point V2 n
e') = Maybe (Point V2 n, Point V2 n) -> (Point V2 n, Point V2 n)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Point V2 n, Point V2 n) -> (Point V2 n, Point V2 n))
-> Maybe (Point V2 n, Point V2 n) -> (Point V2 n, Point V2 n)
forall a b. (a -> b) -> a -> b
$ n1
-> n2
-> Angle n
-> Angle n
-> QDiagram B V2 n Any
-> Maybe (Point V2 n, Point V2 n)
forall n1 n2 n b.
(IsName n1, IsName n2, RealFloat n) =>
n1
-> n2
-> Angle n
-> Angle n
-> QDiagram b V2 n Any
-> Maybe (Point V2 n, Point V2 n)
pointsFromToWithAngle n1
n1 n2
n2 Angle n
a1 Angle n
a2 QDiagram B V2 n Any
g
  in ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram B V2 n Any
forall n b.
(TypeableFloat n, Renderable (Path V2 n) b) =>
ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram b V2 n Any
arrowBetween' ArrowOpts n
opts Point V2 n
s' Point V2 n
e' QDiagram B V2 n Any
-> (QDiagram B V2 n Any -> QDiagram B V2 n Any)
-> QDiagram B V2 n Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram B V2 n Any -> QDiagram B V2 n Any
forall n.
SVGFloat n =>
String -> QDiagram B V2 n Any -> QDiagram B V2 n Any
svgClass String
"edge"
     QDiagram B V2 n Any -> QDiagram B V2 n Any -> QDiagram B V2 n Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
`atop` QDiagram B V2 n Any
g

trailBetweenWithAngle
  :: (IsName n1, IsName n2)
  => ArrowOpts Double
  -> Path V2 Double
  -> n1
  -> n2
  -> Angle Double
  -> Angle Double
  -> QDiagram b V2 Double Any
  -> Located (Trail V2 Double)
trailBetweenWithAngle :: forall n1 n2 b.
(IsName n1, IsName n2) =>
ArrowOpts Double
-> Path V2 Double
-> n1
-> n2
-> Angle Double
-> Angle Double
-> QDiagram b V2 Double Any
-> Located (Trail V2 Double)
trailBetweenWithAngle ArrowOpts Double
opts Path V2 Double
path n1
l1 n2
l2 Angle Double
a1 Angle Double
a2 QDiagram b V2 Double Any
d = Located (Trail V2 Double)
-> ((Point V2 Double, Point V2 Double)
    -> Located (Trail V2 Double))
-> Maybe (Point V2 Double, Point V2 Double)
-> Located (Trail V2 Double)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
  Located (Trail V2 Double)
x
  ((Point V2 Double -> Point V2 Double -> Located (Trail V2 Double))
-> (Point V2 Double, Point V2 Double) -> Located (Trail V2 Double)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Point V2 Double -> Point V2 Double -> Located (Trail V2 Double)
rescale)
  (Maybe (Point V2 Double, Point V2 Double)
 -> Located (Trail V2 Double))
-> Maybe (Point V2 Double, Point V2 Double)
-> Located (Trail V2 Double)
forall a b. (a -> b) -> a -> b
$ n1
-> n2
-> Angle Double
-> Angle Double
-> QDiagram b V2 Double Any
-> Maybe (Point V2 Double, Point V2 Double)
forall n1 n2 n b.
(IsName n1, IsName n2, RealFloat n) =>
n1
-> n2
-> Angle n
-> Angle n
-> QDiagram b V2 n Any
-> Maybe (Point V2 n, Point V2 n)
pointsFromToWithAngle n1
l1 n2
l2 Angle Double
a1 Angle Double
a2 QDiagram b V2 Double Any
d
  where
   x :: Located (Trail V2 Double)
x = [Located (Trail V2 Double)] -> Located (Trail V2 Double)
forall a. HasCallStack => [a] -> a
head ([Located (Trail V2 Double)] -> Located (Trail V2 Double))
-> [Located (Trail V2 Double)] -> Located (Trail V2 Double)
forall a b. (a -> b) -> a -> b
$ Path V2 Double -> [Located (Trail V2 Double)]
forall (v :: * -> *) n. Path v n -> [Located (Trail v n)]
pathTrails Path V2 Double
path
   rescale :: Point V2 Double -> Point V2 Double -> Located (Trail V2 Double)
rescale Point V2 Double
pos Point V2 Double
e
      | n1 -> Name
forall a. IsName a => a -> Name
toName n1
l1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== n2 -> Name
forall a. IsName a => a -> Name
toName n2
l2
      = Vn (Located (Trail V2 Double))
-> Located (Trail V2 Double) -> Located (Trail V2 Double)
forall t. Transformable t => Vn t -> t -> t
translate (Point V2 Double -> V2 Double
forall (f :: * -> *) a. Point f a -> f a
unP Point V2 Double
out) (Located (Trail V2 Double) -> Located (Trail V2 Double))
-> Located (Trail V2 Double) -> Located (Trail V2 Double)
forall a b. (a -> b) -> a -> b
$ Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Located (Trail V2 Double)
-> Located (Trail V2 Double)
scaleAndPositionTrail Point V2 Double
pos Point V2 Double
e Point V2 Double
oldPos Point V2 Double
oldE Located (Trail V2 Double)
selfArc
      | Bool
otherwise
      = Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Point V2 Double
-> Located (Trail V2 Double)
-> Located (Trail V2 Double)
scaleAndPositionTrail Point V2 Double
pos Point V2 Double
e Point V2 Double
oldPos Point V2 Double
oldE Located (Trail V2 Double)
x
    where
    points :: [Point V2 Double]
points = [[Point V2 Double]] -> [Point V2 Double]
forall a. HasCallStack => [a] -> a
head ([[Point V2 Double]] -> [Point V2 Double])
-> [[Point V2 Double]] -> [Point V2 Double]
forall a b. (a -> b) -> a -> b
$ Path V2 Double -> [[Point V2 Double]]
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Path v n -> [[Point v n]]
pathPoints Path V2 Double
path
    oldPos :: Point V2 Double
oldPos = [Point V2 Double] -> Point V2 Double
forall a. HasCallStack => [a] -> a
head [Point V2 Double]
points
    oldE :: Point V2 Double
oldE = [Point V2 Double] -> Point V2 Double
forall a. HasCallStack => [a] -> a
last [Point V2 Double]
points
    arc :: Direction V2 Double
-> Direction V2 Double -> Located (Trail V2 Double)
arc = if Angle Double
a1 Angle Double -> Angle Double -> Bool
forall a. Ord a => a -> a -> Bool
> Angle Double
a2 then Direction V2 Double
-> Direction V2 Double -> Located (Trail V2 Double)
forall n t.
(InSpace V2 n t, RealFloat n, TrailLike t) =>
Direction V2 n -> Direction V2 n -> t
arcCW else Direction V2 Double
-> Direction V2 Double -> Located (Trail V2 Double)
forall n t.
(InSpace V2 n t, RealFloat n, TrailLike t) =>
Direction V2 n -> Direction V2 n -> t
arcCCW
    a1' :: Angle Double
a1' = Angle Double
a1 Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle Double
forall v. Floating v => Angle v
quarterTurn
    a2' :: Angle Double
a2' = Angle Double
a2 Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle Double
forall v. Floating v => Angle v
quarterTurn
    unitSelfArc :: Located (Trail V2 Double)
unitSelfArc = Direction V2 Double
-> Direction V2 Double -> Located (Trail V2 Double)
arc (Angle Double -> Direction V2 Double
forall n. Floating n => Angle n -> Direction V2 n
angleDir Angle Double
a1') (Angle Double -> Direction V2 Double
forall n. Floating n => Angle n -> Direction V2 n
angleDir Angle Double
a2')
    selfArc :: Located (Trail V2 Double)
selfArc = Double -> Located (Trail V2 Double) -> Located (Trail V2 Double)
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleY (Getting Double (Point V2 Double) Double -> Double
portion Getting Double (Point V2 Double) Double
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (Located (Trail V2 Double) -> Located (Trail V2 Double))
-> Located (Trail V2 Double) -> Located (Trail V2 Double)
forall a b. (a -> b) -> a -> b
$ Double -> Located (Trail V2 Double) -> Located (Trail V2 Double)
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX (Getting Double (Point V2 Double) Double -> Double
portion Getting Double (Point V2 Double) Double
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Located (Trail V2 Double)
unitSelfArc
    between :: Point V2 Double
between = Point V2 Double
e' Point V2 Double -> Point V2 Double -> Point V2 Double
forall a. Num a => Point V2 a -> Point V2 a -> Point V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point V2 Double
pos'
    portion :: Getting Double (Point V2 Double) Double -> Double
portion Getting Double (Point V2 Double) Double
f = Point V2 Double -> Double
forall a. Floating a => Point V2 a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm Point V2 Double
between Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Point V2 Double
eSelfArc Point V2 Double
-> Getting Double (Point V2 Double) Double -> Double
forall s a. s -> Getting a s a -> a
^.Getting Double (Point V2 Double) Double
f Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
    eSelfArc :: Point V2 Double
eSelfArc = V2 Double -> Point V2 Double
forall (f :: * -> *) a. f a -> Point f a
P (V2 Double -> Point V2 Double) -> V2 Double -> Point V2 Double
forall a b. (a -> b) -> a -> b
$ BoundingBox V2 Double -> V2 Double
forall (v :: * -> *) n.
(Additive v, Num n) =>
BoundingBox v n -> v n
boxExtents (BoundingBox V2 Double -> V2 Double)
-> BoundingBox V2 Double -> V2 Double
forall a b. (a -> b) -> a -> b
$ Located (Trail V2 Double) -> BoundingBox V2 Double
forall (v :: * -> *) n a.
(InSpace v n a, HasBasis v, Enveloped a) =>
a -> BoundingBox v n
boundingBox Located (Trail V2 Double)
unitSelfArc
    pos' :: Point V2 Double
pos' = Point V2 Double
pos Point V2 Double -> Point V2 Double -> Point V2 Double
forall a. Num a => Point V2 a -> Point V2 a -> Point V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point V2 Double
out
    out :: Point V2 Double
out = Angle Double -> Point V2 Double -> Point V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate
      (Angle Double
a1 Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle Double
forall v. Floating v => Angle v
halfTurn)
      (Point V2 Double -> Point V2 Double)
-> Point V2 Double -> Point V2 Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Measured Double Double -> Double
forall n a. Num n => n -> n -> Measured n a -> a
fromMeasured Double
1.0 Double
1.0 (ArrowOpts Double
opts ArrowOpts Double
-> Getting
     (Measured Double Double)
     (ArrowOpts Double)
     (Measured Double Double)
-> Measured Double Double
forall s a. s -> Getting a s a -> a
^. Getting
  (Measured Double Double)
  (ArrowOpts Double)
  (Measured Double Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
tailLength) Double -> Point V2 Double -> Point V2 Double
forall (v :: * -> *) n.
(Functor v, Num n) =>
n -> Point v n -> Point v n
*. Point V2 Double
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X
    e' :: Point V2 Double
e' = Point V2 Double
e Point V2 Double -> Point V2 Double -> Point V2 Double
forall a. Num a => Point V2 a -> Point V2 a -> Point V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle Double -> Point V2 Double -> Point V2 Double
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate
      (Angle Double
a2 Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle Double
forall v. Floating v => Angle v
halfTurn)
      (Double -> Double -> Measured Double Double -> Double
forall n a. Num n => n -> n -> Measured n a -> a
fromMeasured Double
1.0 Double
1.0 (ArrowOpts Double
opts ArrowOpts Double
-> Getting
     (Measured Double Double)
     (ArrowOpts Double)
     (Measured Double Double)
-> Measured Double Double
forall s a. s -> Getting a s a -> a
^. Getting
  (Measured Double Double)
  (ArrowOpts Double)
  (Measured Double Double)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headLength) Double -> Point V2 Double -> Point V2 Double
forall (v :: * -> *) n.
(Functor v, Num n) =>
n -> Point v n -> Point v n
*. Point V2 Double
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X)

connectWithPath
  :: (IsName n1, IsName n2)
  => ArrowOpts Double
  -> PreparedFont Double
  -> DirType
  -> n1
  -> n2
  -> Maybe String
  -> Maybe String
  -> Maybe String
  -> Path V2 Double
  -> QDiagram SVG V2 Double Any
  -> QDiagram SVG V2 Double Any
connectWithPath :: forall n1 n2.
(IsName n1, IsName n2) =>
ArrowOpts Double
-> PreparedFont Double
-> DirType
-> n1
-> n2
-> Maybe String
-> Maybe String
-> Maybe String
-> Path V2 Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
connectWithPath ArrowOpts Double
opts PreparedFont Double
font DirType
dir n1
l1 n2
l2 Maybe String
ml Maybe String
fl Maybe String
tl Path V2 Double
path QDiagram B V2 Double Any
g =
  ((Where, Maybe String)
 -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
-> [(Where, Maybe String)]
-> QDiagram B V2 Double Any
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (Where, Maybe String)
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
addLabel
    (ArrowOpts Double
-> n1
-> n2
-> Angle Double
-> Angle Double
-> QDiagram B V2 Double Any
-> QDiagram B V2 Double Any
forall n1 n2 n.
(IsName n1, IsName n2, RealFloat n, Typeable n, Show n) =>
ArrowOpts n
-> n1
-> n2
-> Angle n
-> Angle n
-> QDiagram B V2 n Any
-> QDiagram B V2 n Any
connectPerim'' ArrowOpts Double
opts' n1
l1 n2
l2 Angle Double
angle1 Angle Double
angle2 QDiagram B V2 Double Any
g)
    [(Where, Maybe String)]
points
  # svgClass "."
  where
    points :: [(Where, Maybe String)]
points = [(Where
Middle, Maybe String
ml), (Where
Begin, Maybe String
fl), (Where
End, Maybe String
tl)]
    opts' :: ArrowOpts Double
opts' = ArrowOpts Double -> DirType -> ArrowOpts Double
forall n.
(Floating n, Ord n) =>
ArrowOpts n -> DirType -> ArrowOpts n
amendOptsByDirection ArrowOpts Double
opts DirType
dir
      ArrowOpts Double
-> (ArrowOpts Double -> ArrowOpts Double) -> ArrowOpts Double
forall a b. a -> (a -> b) -> b
& (Trail V2 Double -> Identity (Trail V2 Double))
-> ArrowOpts Double -> Identity (ArrowOpts Double)
forall n (f :: * -> *).
Functor f =>
(Trail V2 n -> f (Trail V2 n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowShaft ((Trail V2 Double -> Identity (Trail V2 Double))
 -> ArrowOpts Double -> Identity (ArrowOpts Double))
-> Trail V2 Double -> ArrowOpts Double -> ArrowOpts Double
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Located (Trail V2 Double) -> Trail V2 Double
forall a. Located a -> a
unLoc Located (Trail V2 Double)
shaft
    addLabel :: (Where, Maybe String)
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
addLabel (Where
loc, Maybe String
ml')
      | Just String
l <- Maybe String
ml' =
          let txt :: Diagram B
txt = Diagram B -> Diagram B
forall (v :: * -> *) n a.
(InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerXY (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ PreparedFont Double -> Double -> String -> Diagram B
text' PreparedFont Double
font Double
16 String
l
              shift :: V2 Double
shift = BoundingBox V2 Double -> V2 Double
forall (v :: * -> *) n.
(Additive v, Num n) =>
BoundingBox v n -> v n
boxExtents (QDiagram B V2 Double Any -> BoundingBox V2 Double
forall (v :: * -> *) n a.
(InSpace v n a, HasBasis v, Enveloped a) =>
a -> BoundingBox v n
boundingBox Diagram B
QDiagram B V2 Double Any
txt) V2 Double -> Double -> V2 Double
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/Double
2
              param :: Double
param = Where -> DirType -> Double
forall p. Fractional p => Where -> DirType -> p
dirParam Where
loc DirType
dir
              dist :: V2 Double
dist = case Where
loc of
                Where
Begin
                  | DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Back Bool -> Bool -> Bool
|| DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Both -> V2 Double
4
                  | Bool
otherwise -> V2 Double
2
                Where
Middle -> V2 Double
0
                Where
End
                  | DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Forward Bool -> Bool -> Bool
|| DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Both -> V2 Double
4
                  | Bool
otherwise -> V2 Double
2
              p :: Codomain
  (Located (Trail V2 Double)) (N (Located (Trail V2 Double)))
p = Located (Trail V2 Double)
-> N (Located (Trail V2 Double))
-> V2 (N (Located (Trail V2 Double)))
-> V2 (N (Located (Trail V2 Double)))
-> Codomain
     (Located (Trail V2 Double)) (N (Located (Trail V2 Double)))
forall p.
(Floating (N p), Affine (Codomain p), Parametric p,
 Parametric (Tangent p), Diff (Codomain p) ~ V2, V p ~ V2) =>
p -> N p -> V2 (N p) -> V2 (N p) -> Codomain p (N p)
pointAtShiftedBy Located (Trail V2 Double)
shaft Double
N (Located (Trail V2 Double))
param V2 Double
V2 (N (Located (Trail V2 Double)))
shift V2 Double
V2 (N (Located (Trail V2 Double)))
dist
          in QDiagram B V2 Double Any
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
atop (QDiagram B V2 Double Any
-> Point V2 Double -> QDiagram B V2 Double Any
forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place Diagram B
QDiagram B V2 Double Any
txt Point V2 Double
Codomain
  (Located (Trail V2 Double)) (N (Located (Trail V2 Double)))
p QDiagram B V2 Double Any
-> (QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> QDiagram B V2 Double Any
forall a b. a -> (a -> b) -> b
# String -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall n.
SVGFloat n =>
String -> QDiagram B V2 n Any -> QDiagram B V2 n Any
svgClass String
"elabel")
      | Bool
otherwise     = QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall a. a -> a
id
    shaft :: Located (Trail V2 Double)
shaft = ArrowOpts Double
-> Path V2 Double
-> n1
-> n2
-> Angle Double
-> Angle Double
-> QDiagram B V2 Double Any
-> Located (Trail V2 Double)
forall n1 n2 b.
(IsName n1, IsName n2) =>
ArrowOpts Double
-> Path V2 Double
-> n1
-> n2
-> Angle Double
-> Angle Double
-> QDiagram b V2 Double Any
-> Located (Trail V2 Double)
trailBetweenWithAngle ArrowOpts Double
opts' Path V2 Double
path n1
l1 n2
l2 Angle Double
angle1 Angle Double
angle2 QDiagram B V2 Double Any
g
    (Angle Double
angle1, Angle Double
angle2) = Path V2 Double
-> n1
-> n2
-> QDiagram B V2 Double Any
-> (Angle Double, Angle Double)
forall n1 n2 m b.
(IsName n1, IsName n2, Semigroup m) =>
Path V2 Double
-> n1
-> n2
-> QDiagram b V2 Double m
-> (Angle Double, Angle Double)
inAndOutAngle Path V2 Double
path n1
l1 n2
l2 QDiagram B V2 Double Any
g

amendOptsByDirection
  :: (Floating n, Ord n)
  => ArrowOpts n
  -> DirType
  -> ArrowOpts n
amendOptsByDirection :: forall n.
(Floating n, Ord n) =>
ArrowOpts n -> DirType -> ArrowOpts n
amendOptsByDirection ArrowOpts n
opts DirType
dir = ArrowOpts n
opts ArrowOpts n -> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n
forall a b. a -> (a -> b) -> b
& case DirType
dir of
  DirType
Back -> ArrowOpts n -> ArrowOpts n
amendTail (ArrowOpts n -> ArrowOpts n)
-> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n -> ArrowOpts n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrowOpts n -> ArrowOpts n
amendHead
  DirType
Both -> ArrowOpts n -> ArrowOpts n
amendTail
  DirType
Forward -> ArrowOpts n -> ArrowOpts n
forall a. a -> a
id
  DirType
NoDir -> ArrowOpts n -> ArrowOpts n
amendHead
  where
    head' :: ArrowHT n
head' = ArrowHT n -> ArrowHT n
forall n. OrderedField n => ArrowHT n -> ArrowHT n
flipArrow (ArrowHT n -> ArrowHT n) -> ArrowHT n -> ArrowHT n
forall a b. (a -> b) -> a -> b
$ ArrowOpts n
opts ArrowOpts n
-> Getting (ArrowHT n) (ArrowOpts n) (ArrowHT n) -> ArrowHT n
forall s a. s -> Getting a s a -> a
^. Getting (ArrowHT n) (ArrowOpts n) (ArrowHT n)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowTail
    amendHead :: ArrowOpts n -> ArrowOpts n
amendHead ArrowOpts n
x = ArrowOpts n
x
      ArrowOpts n -> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n
forall a b. a -> (a -> b) -> b
& (ArrowHT n -> Identity (ArrowHT n))
-> ArrowOpts n -> Identity (ArrowOpts n)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowHead ((ArrowHT n -> Identity (ArrowHT n))
 -> ArrowOpts n -> Identity (ArrowOpts n))
-> ArrowHT n -> ArrowOpts n -> ArrowOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowHT n
head'
      ArrowOpts n -> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n
forall a b. a -> (a -> b) -> b
& (Measure n -> Identity (Measure n))
-> ArrowOpts n -> Identity (ArrowOpts n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headLength ((Measure n -> Identity (Measure n))
 -> ArrowOpts n -> Identity (ArrowOpts n))
-> Measure n -> ArrowOpts n -> ArrowOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowOpts n
opts ArrowOpts n
-> Getting (Measure n) (ArrowOpts n) (Measure n) -> Measure n
forall s a. s -> Getting a s a -> a
^. Getting (Measure n) (ArrowOpts n) (Measure n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
tailLength
      ArrowOpts n -> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n
forall a b. a -> (a -> b) -> b
& (Measure n -> Identity (Measure n))
-> ArrowOpts n -> Identity (ArrowOpts n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headGap ((Measure n -> Identity (Measure n))
 -> ArrowOpts n -> Identity (ArrowOpts n))
-> Measure n -> ArrowOpts n -> ArrowOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowOpts n
opts ArrowOpts n
-> Getting (Measure n) (ArrowOpts n) (Measure n) -> Measure n
forall s a. s -> Getting a s a -> a
^. Getting (Measure n) (ArrowOpts n) (Measure n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
tailGap
    tail' :: ArrowHT n
tail' = ArrowHT n -> ArrowHT n
forall n. OrderedField n => ArrowHT n -> ArrowHT n
flipArrow (ArrowHT n -> ArrowHT n) -> ArrowHT n -> ArrowHT n
forall a b. (a -> b) -> a -> b
$ ArrowOpts n
opts ArrowOpts n
-> Getting (ArrowHT n) (ArrowOpts n) (ArrowHT n) -> ArrowHT n
forall s a. s -> Getting a s a -> a
^. Getting (ArrowHT n) (ArrowOpts n) (ArrowHT n)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowHead
    amendTail :: ArrowOpts n -> ArrowOpts n
amendTail ArrowOpts n
x = ArrowOpts n
x
      ArrowOpts n -> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n
forall a b. a -> (a -> b) -> b
& (ArrowHT n -> Identity (ArrowHT n))
-> ArrowOpts n -> Identity (ArrowOpts n)
forall n (f :: * -> *).
Functor f =>
(ArrowHT n -> f (ArrowHT n)) -> ArrowOpts n -> f (ArrowOpts n)
arrowTail ((ArrowHT n -> Identity (ArrowHT n))
 -> ArrowOpts n -> Identity (ArrowOpts n))
-> ArrowHT n -> ArrowOpts n -> ArrowOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowHT n
tail'
      ArrowOpts n -> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n
forall a b. a -> (a -> b) -> b
& (Measure n -> Identity (Measure n))
-> ArrowOpts n -> Identity (ArrowOpts n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
tailLength ((Measure n -> Identity (Measure n))
 -> ArrowOpts n -> Identity (ArrowOpts n))
-> Measure n -> ArrowOpts n -> ArrowOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowOpts n
opts ArrowOpts n
-> Getting (Measure n) (ArrowOpts n) (Measure n) -> Measure n
forall s a. s -> Getting a s a -> a
^. Getting (Measure n) (ArrowOpts n) (Measure n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headLength
      ArrowOpts n -> (ArrowOpts n -> ArrowOpts n) -> ArrowOpts n
forall a b. a -> (a -> b) -> b
& (Measure n -> Identity (Measure n))
-> ArrowOpts n -> Identity (ArrowOpts n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
tailGap ((Measure n -> Identity (Measure n))
 -> ArrowOpts n -> Identity (ArrowOpts n))
-> Measure n -> ArrowOpts n -> ArrowOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ArrowOpts n
opts ArrowOpts n
-> Getting (Measure n) (ArrowOpts n) (Measure n) -> Measure n
forall s a. s -> Getting a s a -> a
^. Getting (Measure n) (ArrowOpts n) (Measure n)
forall n (f :: * -> *).
Functor f =>
(Measure n -> f (Measure n)) -> ArrowOpts n -> f (ArrowOpts n)
headGap

inAndOutAngle
  :: (IsName n1, IsName n2, Semigroup m)
  => Path V2 Double
  -> n1
  -> n2
  -> QDiagram b V2 Double m
  -> (Angle Double, Angle Double)
inAndOutAngle :: forall n1 n2 m b.
(IsName n1, IsName n2, Semigroup m) =>
Path V2 Double
-> n1
-> n2
-> QDiagram b V2 Double m
-> (Angle Double, Angle Double)
inAndOutAngle Path V2 Double
path n1
l1 n2
l2 QDiagram b V2 Double m
g = (Angle Double
angle1, Angle Double
angle2)
  where
    trail :: Located (Trail V2 Double)
trail = Path V2 Double
-> n1 -> n2 -> QDiagram b V2 Double m -> Located (Trail V2 Double)
forall n1 n2 m b.
(IsName n1, IsName n2, Semigroup m) =>
Path V2 Double
-> n1 -> n2 -> QDiagram b V2 Double m -> Located (Trail V2 Double)
trailBetween Path V2 Double
path n1
l1 n2
l2 QDiagram b V2 Double m
g
    angle1 :: Angle Double
angle1 = V2 Double -> V2 Double -> Angle Double
forall n. RealFloat n => V2 n -> V2 n -> Angle n
signedAngleBetween (Located (Trail V2 Double) -> Vn (Located (Trail V2 Double))
forall t. EndValues (Tangent t) => t -> Vn t
tangentAtStart Located (Trail V2 Double)
trail) (-V2 Double
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X) Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Angle Double
adjustAngle
    angle2 :: Angle Double
angle2 = V2 Double -> V2 Double -> Angle Double
forall n. RealFloat n => V2 n -> V2 n -> Angle n
signedAngleBetween (Located (Trail V2 Double) -> Vn (Located (Trail V2 Double))
forall t. EndValues (Tangent t) => t -> Vn t
tangentAtEnd Located (Trail V2 Double)
trail) V2 Double
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X Angle Double -> Angle Double -> Angle Double
forall a. Num a => Angle a -> Angle a -> Angle a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle Double
adjustAngle
    adjustAngle :: Angle Double
adjustAngle
      | n1 -> Name
forall a. IsName a => a -> Name
toName n1
l1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== n2 -> Name
forall a. IsName a => a -> Name
toName n2
l2 = Double
20 Double -> AReview (Angle Double) Double -> Angle Double
forall b a. b -> AReview a b -> a
@@ AReview (Angle Double) Double
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle Double) Double
deg
      | Bool
otherwise              = Double
0 Double -> AReview (Angle Double) Double -> Angle Double
forall b a. b -> AReview a b -> a
@@ AReview (Angle Double) Double
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle Double) Double
deg

{-|
Makes an arrow head an arrow tail and vice versa.
-}
flipArrow :: OrderedField n => ArrowHT n -> ArrowHT n
flipArrow :: forall n. OrderedField n => ArrowHT n -> ArrowHT n
flipArrow ArrowHT n
hd = ArrowHT n
tl
  where
    tl :: ArrowHT n
tl n
sz n
shaftWidth = (Path V2 n
t, Path V2 n
j)
      where
        (Path V2 n
t', Path V2 n
j') = ArrowHT n
hd n
sz n
shaftWidth
        t :: Path V2 n
t = Path V2 n -> Path V2 n
forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
t -> t
reflectX Path V2 n
t'
        j :: Path V2 n
j = Path V2 n -> Path V2 n
forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
t -> t
reflectX Path V2 n
j'

data Where = Begin | Middle | End

dirParam :: Fractional p => Where -> DirType -> p
dirParam :: forall p. Fractional p => Where -> DirType -> p
dirParam Where
Begin DirType
dir
  | DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Back    = p
0.93
  | Bool
otherwise      = p
0.07
dirParam Where
End DirType
dir
  | DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Back    = p
0.07
  | Bool
otherwise      = p
0.93
dirParam Where
Middle DirType
dir
  | DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Forward = p
0.4
  | DirType
dir DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
Back    = p
0.6
  | Bool
otherwise      = p
0.5

pointAtShiftedBy
  :: (Floating (N p), Affine (Codomain p), Parametric p, Parametric (Tangent p),
      Diff (Codomain p) ~ V2, V p ~ V2)
  => p
  -> N p
  -> V2 (N p)
  -> V2 (N p)
  -> Codomain p (N p)
pointAtShiftedBy :: forall p.
(Floating (N p), Affine (Codomain p), Parametric p,
 Parametric (Tangent p), Diff (Codomain p) ~ V2, V p ~ V2) =>
p -> N p -> V2 (N p) -> V2 (N p) -> Codomain p (N p)
pointAtShiftedBy p
shaft N p
param V2 (N p)
v V2 (N p)
additionalDistance =
  p
shaft p -> N p -> Codomain p (N p)
forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` N p
param Codomain p (N p) -> Diff (Codomain p) (N p) -> Codomain p (N p)
forall a.
Num a =>
Codomain p a -> Diff (Codomain p) a -> Codomain p a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ V2 (N p)
Diff (Codomain p) (N p)
n' Codomain p (N p) -> Diff (Codomain p) (N p) -> Codomain p (N p)
forall a.
Num a =>
Codomain p a -> Diff (Codomain p) a -> Codomain p a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ V2 (N p)
additionalDistance V2 (N p) -> V2 (N p) -> V2 (N p)
forall a. Num a => a -> a -> a
* V2 (N p)
n
  where
    n :: V2 (N p)
n = p
shaft p -> N p -> V2 (N p)
forall n t.
(InSpace V2 n t, Parametric (Tangent t), Floating n) =>
t -> n -> V2 n
`normalAtParam` N p
param
    x :: N p
x = V2 (N p)
v V2 (N p) -> Getting (N p) (V2 (N p)) (N p) -> N p
forall s a. s -> Getting a s a -> a
^. Getting (N p) (V2 (N p)) (N p)
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x
    y :: N p
y = V2 (N p)
v V2 (N p) -> Getting (N p) (V2 (N p)) (N p) -> N p
forall s a. s -> Getting a s a -> a
^. Getting (N p) (V2 (N p)) (N p)
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y
    n' :: V2 (N p)
n' = N p -> V2 (N p) -> V2 (N p)
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX (N p -> N p
forall a. Num a => a -> a
abs N p
x) (V2 (N p) -> V2 (N p))
-> (V2 (N p) -> V2 (N p)) -> V2 (N p) -> V2 (N p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. N p -> V2 (N p) -> V2 (N p)
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleY (N p -> N p
forall a. Num a => a -> a
abs N p
y) (V2 (N p) -> V2 (N p)) -> V2 (N p) -> V2 (N p)
forall a b. (a -> b) -> a -> b
$ V2 (N p)
n

{-|
Render text as a diagram.
-}
renderText
  :: Bool
  -- ^ whether to underline
  -> PreparedFont Double
  -- ^ which font to use
  -> Double
  -- ^ font size
  -> String
  -- ^ what to write
  -> Diagram B
renderText :: Bool -> PreparedFont Double -> Double -> String -> Diagram B
renderText Bool
u PreparedFont Double
preparedFont Double
s String
x = String
x
#if MIN_VERSION_SVGFonts(1,8,0)
  # svgText (def :: TextOpts Double) {textFont = preparedFont, underline = u}
  # fit_height s
  # set_envelope
  # lw none
#else
  # textSVG_ (TextOpts preparedFont INSIDE_H KERN u s s)
#endif
  # fc black
  # lc black
  # lwL 0.4

{-|
Render normal text as a diagram.
-}
text'
  :: PreparedFont Double
  -- ^ which font to use
  -> Double
  -- ^ font size
  -> String
  -- ^ what to write
  -> Diagram B
text' :: PreparedFont Double -> Double -> String -> Diagram B
text' = Bool -> PreparedFont Double -> Double -> String -> Diagram B
renderText Bool
False

{-|
Render underlined text as a diagram.
-}
textU
  :: PreparedFont Double
  -- ^ which font to use
  -> Double
  -- ^ font size
  -> String
  -- ^ what to write
  -> Diagram B
textU :: PreparedFont Double -> Double -> String -> Diagram B
textU = Bool -> PreparedFont Double -> Double -> String -> Diagram B
renderText Bool
True