-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow.Utils.Edges
-- License     :  BSD3-style (see the file LICENSE)
--
-- Pure port of @utils\/edges\/*@ from @\@xyflow\/system@: bezier, smooth
-- step and straight edge paths, edge centers, z-indexes, visibility,
-- 'addEdge' \/ 'reconnectEdge', and edge \/ handle position resolution.
--
-- All path-producing functions return SVG path strings identical (to the
-- byte) to the ones produced by the original TypeScript.
----------------------------------------------------------------------------
module Miso.Flow.Utils.Edges
  ( -- * Path results
    EdgePath (..)
    -- * Bezier (@bezier-edge.ts@)
  , GetBezierPathParams (..)
  , bezierPathParams
  , getBezierPath
  , getBezierEdgeCenter
    -- * Simple bezier (from the framework packages)
  , getSimpleBezierPath
    -- * Smooth step (@smoothstep-edge.ts@)
  , GetSmoothStepPathParams (..)
  , smoothStepPathParams
  , getSmoothStepPath
    -- * Straight (@straight-edge.ts@)
  , getStraightPath
    -- * General (@edges\/general.ts@)
  , getEdgeCenter
  , getElevatedEdgeZIndex
  , isEdgeVisible
  , getEdgeId
  , connectionToEdge
  , addEdge
  , addEdgeWith
  , reconnectEdge
  , reconnectEdgeWith
    -- * Positions (@edges\/positions.ts@)
  , getEdgePosition
  , getHandlePosition
  , toHandleBounds
  ) where
-----------------------------------------------------------------------------
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe, isJust)
import           Prelude
-----------------------------------------------------------------------------
import           Miso.String (MisoString)
-----------------------------------------------------------------------------
import           Miso.Flow.Internal.JSNum (jsShow)
import           Miso.Flow.Types
import           Miso.Flow.Utils.General
-----------------------------------------------------------------------------
-- | Everything needed to render an edge: the SVG path plus the label
-- anchor. Port of the @[path, labelX, labelY, offsetX, offsetY]@ tuples.
data EdgePath = EdgePath
  { EdgePath -> EdgeId
edgePath        :: !MisoString
    -- ^ value for the @d@ attribute of an SVG @\<path\>@
  , EdgePath -> Double
edgePathLabelX  :: !Double
  , EdgePath -> Double
edgePathLabelY  :: !Double
  , EdgePath -> Double
edgePathOffsetX :: !Double
  , EdgePath -> Double
edgePathOffsetY :: !Double
  } deriving (Int -> EdgePath -> ShowS
[EdgePath] -> ShowS
EdgePath -> String
(Int -> EdgePath -> ShowS)
-> (EdgePath -> String) -> ([EdgePath] -> ShowS) -> Show EdgePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgePath -> ShowS
showsPrec :: Int -> EdgePath -> ShowS
$cshow :: EdgePath -> String
show :: EdgePath -> String
$cshowList :: [EdgePath] -> ShowS
showList :: [EdgePath] -> ShowS
Show, EdgePath -> EdgePath -> Bool
(EdgePath -> EdgePath -> Bool)
-> (EdgePath -> EdgePath -> Bool) -> Eq EdgePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgePath -> EdgePath -> Bool
== :: EdgePath -> EdgePath -> Bool
$c/= :: EdgePath -> EdgePath -> Bool
/= :: EdgePath -> EdgePath -> Bool
Eq)
-----------------------------------------------------------------------------
data GetBezierPathParams = GetBezierPathParams
  { GetBezierPathParams -> Double
bezierSourceX        :: !Double
  , GetBezierPathParams -> Double
bezierSourceY        :: !Double
  , GetBezierPathParams -> Position
bezierSourcePosition :: !Position  -- ^ default 'PositionBottom'
  , GetBezierPathParams -> Double
bezierTargetX        :: !Double
  , GetBezierPathParams -> Double
bezierTargetY        :: !Double
  , GetBezierPathParams -> Position
bezierTargetPosition :: !Position  -- ^ default 'PositionTop'
  , GetBezierPathParams -> Double
bezierCurvatureParam :: !Double    -- ^ default 0.25
  } deriving (Int -> GetBezierPathParams -> ShowS
[GetBezierPathParams] -> ShowS
GetBezierPathParams -> String
(Int -> GetBezierPathParams -> ShowS)
-> (GetBezierPathParams -> String)
-> ([GetBezierPathParams] -> ShowS)
-> Show GetBezierPathParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetBezierPathParams -> ShowS
showsPrec :: Int -> GetBezierPathParams -> ShowS
$cshow :: GetBezierPathParams -> String
show :: GetBezierPathParams -> String
$cshowList :: [GetBezierPathParams] -> ShowS
showList :: [GetBezierPathParams] -> ShowS
Show, GetBezierPathParams -> GetBezierPathParams -> Bool
(GetBezierPathParams -> GetBezierPathParams -> Bool)
-> (GetBezierPathParams -> GetBezierPathParams -> Bool)
-> Eq GetBezierPathParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetBezierPathParams -> GetBezierPathParams -> Bool
== :: GetBezierPathParams -> GetBezierPathParams -> Bool
$c/= :: GetBezierPathParams -> GetBezierPathParams -> Bool
/= :: GetBezierPathParams -> GetBezierPathParams -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Params with xyflow's defaults filled in.
bezierPathParams
  :: Double -- ^ source x
  -> Double -- ^ source y
  -> Double -- ^ target x
  -> Double -- ^ target y
  -> GetBezierPathParams
bezierPathParams :: Double -> Double -> Double -> Double -> GetBezierPathParams
bezierPathParams Double
sx Double
sy Double
tx Double
ty = GetBezierPathParams
  { bezierSourceX :: Double
bezierSourceX = Double
sx
  , bezierSourceY :: Double
bezierSourceY = Double
sy
  , bezierSourcePosition :: Position
bezierSourcePosition = Position
PositionBottom
  , bezierTargetX :: Double
bezierTargetX = Double
tx
  , bezierTargetY :: Double
bezierTargetY = Double
ty
  , bezierTargetPosition :: Position
bezierTargetPosition = Position
PositionTop
  , bezierCurvatureParam :: Double
bezierCurvatureParam = Double
0.25
  }
-----------------------------------------------------------------------------
-- | Center of a cubic bezier edge (t = 0.5 point) and offsets from the
-- source.
getBezierEdgeCenter
  :: Double -> Double  -- ^ source x, y
  -> Double -> Double  -- ^ target x, y
  -> Double -> Double  -- ^ source control x, y
  -> Double -> Double  -- ^ target control x, y
  -> (Double, Double, Double, Double)
getBezierEdgeCenter :: Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Double, Double, Double, Double)
getBezierEdgeCenter Double
sourceX Double
sourceY Double
targetX Double
targetY Double
scX Double
scY Double
tcX Double
tcY =
  ( Double
centerX, Double
centerY, Double -> Double
forall a. Num a => a -> a
abs (Double
centerX Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sourceX), Double -> Double
forall a. Num a => a -> a
abs (Double
centerY Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sourceY) )
  where
    centerX :: Double
centerX = Double
sourceX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.125 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
scX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.375 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tcX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.375 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
targetX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.125
    centerY :: Double
centerY = Double
sourceY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.125 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
scY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.375 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tcY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.375 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
targetY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.125
-----------------------------------------------------------------------------
calculateControlOffset :: Double -> Double -> Double
calculateControlOffset :: Double -> Double -> Double
calculateControlOffset Double
distance Double
curvature
  | Double
distance Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 = Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
distance
  | Bool
otherwise = Double
curvature Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
25 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double
forall a. Num a => a -> a
negate Double
distance)
-----------------------------------------------------------------------------
getControlWithCurvature
  :: Position -> Double -> Double -> Double -> Double -> Double
  -> (Double, Double)
getControlWithCurvature :: Position
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Double, Double)
getControlWithCurvature Position
pos Double
x1 Double
y1 Double
x2 Double
y2 Double
c =
  case Position
pos of
    Position
PositionLeft   -> (Double
x1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
calculateControlOffset (Double
x1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x2) Double
c, Double
y1)
    Position
PositionRight  -> (Double
x1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Double
calculateControlOffset (Double
x2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x1) Double
c, Double
y1)
    Position
PositionTop    -> (Double
x1, Double
y1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
calculateControlOffset (Double
y1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y2) Double
c)
    Position
PositionBottom -> (Double
x1, Double
y1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Double
calculateControlOffset (Double
y2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y1) Double
c)
-----------------------------------------------------------------------------
-- | Bezier path between two points; port of @getBezierPath@.
getBezierPath :: GetBezierPathParams -> EdgePath
getBezierPath :: GetBezierPathParams -> EdgePath
getBezierPath GetBezierPathParams {Double
Position
bezierSourceX :: GetBezierPathParams -> Double
bezierSourceY :: GetBezierPathParams -> Double
bezierSourcePosition :: GetBezierPathParams -> Position
bezierTargetX :: GetBezierPathParams -> Double
bezierTargetY :: GetBezierPathParams -> Double
bezierTargetPosition :: GetBezierPathParams -> Position
bezierCurvatureParam :: GetBezierPathParams -> Double
bezierSourceX :: Double
bezierSourceY :: Double
bezierSourcePosition :: Position
bezierTargetX :: Double
bezierTargetY :: Double
bezierTargetPosition :: Position
bezierCurvatureParam :: Double
..} =
  EdgePath
    { edgePath :: EdgeId
edgePath = [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
        [ EdgeId
"M", Double -> EdgeId
jsShow Double
bezierSourceX, EdgeId
",", Double -> EdgeId
jsShow Double
bezierSourceY
        , EdgeId
" C", Double -> EdgeId
jsShow Double
scX, EdgeId
",", Double -> EdgeId
jsShow Double
scY
        , EdgeId
" ", Double -> EdgeId
jsShow Double
tcX, EdgeId
",", Double -> EdgeId
jsShow Double
tcY
        , EdgeId
" ", Double -> EdgeId
jsShow Double
bezierTargetX, EdgeId
",", Double -> EdgeId
jsShow Double
bezierTargetY
        ]
    , edgePathLabelX :: Double
edgePathLabelX = Double
labelX
    , edgePathLabelY :: Double
edgePathLabelY = Double
labelY
    , edgePathOffsetX :: Double
edgePathOffsetX = Double
offsetX
    , edgePathOffsetY :: Double
edgePathOffsetY = Double
offsetY
    }
  where
    (Double
scX, Double
scY) = Position
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Double, Double)
getControlWithCurvature
      Position
bezierSourcePosition Double
bezierSourceX Double
bezierSourceY
      Double
bezierTargetX Double
bezierTargetY Double
bezierCurvatureParam
    (Double
tcX, Double
tcY) = Position
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Double, Double)
getControlWithCurvature
      Position
bezierTargetPosition Double
bezierTargetX Double
bezierTargetY
      Double
bezierSourceX Double
bezierSourceY Double
bezierCurvatureParam
    (Double
labelX, Double
labelY, Double
offsetX, Double
offsetY) =
      Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Double, Double, Double, Double)
getBezierEdgeCenter
        Double
bezierSourceX Double
bezierSourceY Double
bezierTargetX Double
bezierTargetY
        Double
scX Double
scY Double
tcX Double
tcY
-----------------------------------------------------------------------------
-- | Simple bezier path (control points halfway along the axis of the
-- handle position); port of @getSimpleBezierPath@ from the framework
-- packages.
getSimpleBezierPath
  :: Double -> Double -> Position  -- ^ source x, y, position
  -> Double -> Double -> Position  -- ^ target x, y, position
  -> EdgePath
getSimpleBezierPath :: Double
-> Double -> Position -> Double -> Double -> Position -> EdgePath
getSimpleBezierPath Double
sourceX Double
sourceY Position
sourcePosition Double
targetX Double
targetY Position
targetPosition =
  EdgePath
    { edgePath :: EdgeId
edgePath = [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
        [ EdgeId
"M", Double -> EdgeId
jsShow Double
sourceX, EdgeId
",", Double -> EdgeId
jsShow Double
sourceY
        , EdgeId
" C", Double -> EdgeId
jsShow Double
scX, EdgeId
",", Double -> EdgeId
jsShow Double
scY
        , EdgeId
" ", Double -> EdgeId
jsShow Double
tcX, EdgeId
",", Double -> EdgeId
jsShow Double
tcY
        , EdgeId
" ", Double -> EdgeId
jsShow Double
targetX, EdgeId
",", Double -> EdgeId
jsShow Double
targetY
        ]
    , edgePathLabelX :: Double
edgePathLabelX = Double
labelX
    , edgePathLabelY :: Double
edgePathLabelY = Double
labelY
    , edgePathOffsetX :: Double
edgePathOffsetX = Double
offsetX
    , edgePathOffsetY :: Double
edgePathOffsetY = Double
offsetY
    }
  where
    control :: Position -> a -> b -> a -> b -> (a, b)
control Position
pos a
x1 b
y1 a
x2 b
y2 =
      case Position
pos of
        Position
PositionLeft   -> ((a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2, b
y1)
        Position
PositionRight  -> ((a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2, b
y1)
        Position
PositionTop    -> (a
x1, (b
y1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
y2) b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
2)
        Position
PositionBottom -> (a
x1, (b
y1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
y2) b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
2)
    (Double
scX, Double
scY) = Position
-> Double -> Double -> Double -> Double -> (Double, Double)
forall {a} {b}.
(Fractional a, Fractional b) =>
Position -> a -> b -> a -> b -> (a, b)
control Position
sourcePosition Double
sourceX Double
sourceY Double
targetX Double
targetY
    (Double
tcX, Double
tcY) = Position
-> Double -> Double -> Double -> Double -> (Double, Double)
forall {a} {b}.
(Fractional a, Fractional b) =>
Position -> a -> b -> a -> b -> (a, b)
control Position
targetPosition Double
targetX Double
targetY Double
sourceX Double
sourceY
    (Double
labelX, Double
labelY, Double
offsetX, Double
offsetY) =
      Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Double, Double, Double, Double)
getBezierEdgeCenter Double
sourceX Double
sourceY Double
targetX Double
targetY Double
scX Double
scY Double
tcX Double
tcY
-----------------------------------------------------------------------------
data GetSmoothStepPathParams = GetSmoothStepPathParams
  { GetSmoothStepPathParams -> Double
smoothSourceX        :: !Double
  , GetSmoothStepPathParams -> Double
smoothSourceY        :: !Double
  , GetSmoothStepPathParams -> Position
smoothSourcePosition :: !Position       -- ^ default 'PositionBottom'
  , GetSmoothStepPathParams -> Double
smoothTargetX        :: !Double
  , GetSmoothStepPathParams -> Double
smoothTargetY        :: !Double
  , GetSmoothStepPathParams -> Position
smoothTargetPosition :: !Position       -- ^ default 'PositionTop'
  , GetSmoothStepPathParams -> Double
smoothBorderRadius   :: !Double         -- ^ default 5
  , GetSmoothStepPathParams -> Maybe Double
smoothCenterX        :: !(Maybe Double)
  , GetSmoothStepPathParams -> Maybe Double
smoothCenterY        :: !(Maybe Double)
  , GetSmoothStepPathParams -> Double
smoothOffset         :: !Double         -- ^ default 20
  , GetSmoothStepPathParams -> Double
smoothStepPosition'  :: !Double         -- ^ default 0.5
  } deriving (Int -> GetSmoothStepPathParams -> ShowS
[GetSmoothStepPathParams] -> ShowS
GetSmoothStepPathParams -> String
(Int -> GetSmoothStepPathParams -> ShowS)
-> (GetSmoothStepPathParams -> String)
-> ([GetSmoothStepPathParams] -> ShowS)
-> Show GetSmoothStepPathParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetSmoothStepPathParams -> ShowS
showsPrec :: Int -> GetSmoothStepPathParams -> ShowS
$cshow :: GetSmoothStepPathParams -> String
show :: GetSmoothStepPathParams -> String
$cshowList :: [GetSmoothStepPathParams] -> ShowS
showList :: [GetSmoothStepPathParams] -> ShowS
Show, GetSmoothStepPathParams -> GetSmoothStepPathParams -> Bool
(GetSmoothStepPathParams -> GetSmoothStepPathParams -> Bool)
-> (GetSmoothStepPathParams -> GetSmoothStepPathParams -> Bool)
-> Eq GetSmoothStepPathParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetSmoothStepPathParams -> GetSmoothStepPathParams -> Bool
== :: GetSmoothStepPathParams -> GetSmoothStepPathParams -> Bool
$c/= :: GetSmoothStepPathParams -> GetSmoothStepPathParams -> Bool
/= :: GetSmoothStepPathParams -> GetSmoothStepPathParams -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Params with xyflow's defaults filled in.
smoothStepPathParams
  :: Double -- ^ source x
  -> Double -- ^ source y
  -> Double -- ^ target x
  -> Double -- ^ target y
  -> GetSmoothStepPathParams
smoothStepPathParams :: Double -> Double -> Double -> Double -> GetSmoothStepPathParams
smoothStepPathParams Double
sx Double
sy Double
tx Double
ty = GetSmoothStepPathParams
  { smoothSourceX :: Double
smoothSourceX = Double
sx
  , smoothSourceY :: Double
smoothSourceY = Double
sy
  , smoothSourcePosition :: Position
smoothSourcePosition = Position
PositionBottom
  , smoothTargetX :: Double
smoothTargetX = Double
tx
  , smoothTargetY :: Double
smoothTargetY = Double
ty
  , smoothTargetPosition :: Position
smoothTargetPosition = Position
PositionTop
  , smoothBorderRadius :: Double
smoothBorderRadius = Double
5
  , smoothCenterX :: Maybe Double
smoothCenterX = Maybe Double
forall a. Maybe a
Nothing
  , smoothCenterY :: Maybe Double
smoothCenterY = Maybe Double
forall a. Maybe a
Nothing
  , smoothOffset :: Double
smoothOffset = Double
20
  , smoothStepPosition' :: Double
smoothStepPosition' = Double
0.5
  }
-----------------------------------------------------------------------------
handleDirection :: Position -> XYPosition
handleDirection :: Position -> XYPosition
handleDirection = \case
  Position
PositionLeft   -> Double -> Double -> XYPosition
XYPosition (-Double
1) Double
0
  Position
PositionRight  -> Double -> Double -> XYPosition
XYPosition Double
1 Double
0
  Position
PositionTop    -> Double -> Double -> XYPosition
XYPosition Double
0 (-Double
1)
  Position
PositionBottom -> Double -> Double -> XYPosition
XYPosition Double
0 Double
1
-----------------------------------------------------------------------------
getDirection :: XYPosition -> Position -> XYPosition -> XYPosition
getDirection :: XYPosition -> Position -> XYPosition -> XYPosition
getDirection XYPosition
source Position
sourcePosition XYPosition
target
  | Position
sourcePosition Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
PositionLeft Bool -> Bool -> Bool
|| Position
sourcePosition Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
PositionRight =
      if XYPosition -> Double
xyX XYPosition
source Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyX XYPosition
target then Double -> Double -> XYPosition
XYPosition Double
1 Double
0 else Double -> Double -> XYPosition
XYPosition (-Double
1) Double
0
  | Bool
otherwise =
      if XYPosition -> Double
xyY XYPosition
source Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyY XYPosition
target then Double -> Double -> XYPosition
XYPosition Double
0 Double
1 else Double -> Double -> XYPosition
XYPosition Double
0 (-Double
1)
-----------------------------------------------------------------------------
distanceBetween :: XYPosition -> XYPosition -> Double
distanceBetween :: XYPosition -> XYPosition -> Double
distanceBetween XYPosition
a XYPosition
b =
  Double -> Double
forall a. Floating a => a -> a
sqrt ((XYPosition -> Double
xyX XYPosition
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyX XYPosition
a) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (XYPosition -> Double
xyY XYPosition
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyY XYPosition
a) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
2)
-----------------------------------------------------------------------------
data Axis = AxisX | AxisY deriving (Axis -> Axis -> Bool
(Axis -> Axis -> Bool) -> (Axis -> Axis -> Bool) -> Eq Axis
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Axis -> Axis -> Bool
== :: Axis -> Axis -> Bool
$c/= :: Axis -> Axis -> Bool
/= :: Axis -> Axis -> Bool
Eq)
-----------------------------------------------------------------------------
axis :: Axis -> XYPosition -> Double
axis :: Axis -> XYPosition -> Double
axis Axis
AxisX = XYPosition -> Double
xyX
axis Axis
AxisY = XYPosition -> Double
xyY
-----------------------------------------------------------------------------
setAxis :: Axis -> Double -> XYPosition -> XYPosition
setAxis :: Axis -> Double -> XYPosition -> XYPosition
setAxis Axis
AxisX Double
v XYPosition
p = XYPosition
p { xyX = v }
setAxis Axis
AxisY Double
v XYPosition
p = XYPosition
p { xyY = v }
-----------------------------------------------------------------------------
-- | Orthogonal routing points for step edges; port of @getPoints@.
getPoints
  :: XYPosition -> Position   -- ^ source, source position
  -> XYPosition -> Position   -- ^ target, target position
  -> (Maybe Double, Maybe Double)  -- ^ center override
  -> Double                   -- ^ offset
  -> Double                   -- ^ step position
  -> ([XYPosition], Double, Double, Double, Double)
getPoints :: XYPosition
-> Position
-> XYPosition
-> Position
-> (Maybe Double, Maybe Double)
-> Double
-> Double
-> ([XYPosition], Double, Double, Double, Double)
getPoints XYPosition
source Position
sourcePosition XYPosition
target Position
targetPosition (Maybe Double
centerX', Maybe Double
centerY') Double
offset Double
stepPosition =
  ([XYPosition]
pathPoints, Double
centerX, Double
centerY, Double
defaultOffsetX, Double
defaultOffsetY)
  where
    sourceDir :: XYPosition
sourceDir = Position -> XYPosition
handleDirection Position
sourcePosition
    targetDir :: XYPosition
targetDir = Position -> XYPosition
handleDirection Position
targetPosition
    sourceGapped :: XYPosition
sourceGapped = Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
source Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
sourceDir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
offset)
                              (XYPosition -> Double
xyY XYPosition
source Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
sourceDir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
offset)
    targetGapped :: XYPosition
targetGapped = Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
target Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
targetDir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
offset)
                              (XYPosition -> Double
xyY XYPosition
target Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
targetDir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
offset)
    dir :: XYPosition
dir = XYPosition -> Position -> XYPosition -> XYPosition
getDirection XYPosition
sourceGapped Position
sourcePosition XYPosition
targetGapped
    dirAccessor :: Axis
dirAccessor = if XYPosition -> Double
xyX XYPosition
dir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 then Axis
AxisX else Axis
AxisY
    currDir :: Double
currDir = Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
dir

    (Double
_, Double
_, Double
defaultOffsetX, Double
defaultOffsetY) =
      Double
-> Double -> Double -> Double -> (Double, Double, Double, Double)
getEdgeCenter (XYPosition -> Double
xyX XYPosition
source) (XYPosition -> Double
xyY XYPosition
source) (XYPosition -> Double
xyX XYPosition
target) (XYPosition -> Double
xyY XYPosition
target)

    oppositeHandles :: Bool
oppositeHandles = Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
sourceDir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
targetDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== -Double
1

    ([XYPosition]
points, Double
centerX, Double
centerY, XYPosition
sourceGapOffset, XYPosition
targetGapOffset)
      | Bool
oppositeHandles =
          let cX :: Double
cX = case Axis
dirAccessor of
                Axis
AxisX -> Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe
                  (XYPosition -> Double
xyX XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (XYPosition -> Double
xyX XYPosition
targetGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyX XYPosition
sourceGapped) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
stepPosition)
                  Maybe Double
centerX'
                Axis
AxisY -> Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe
                  ((XYPosition -> Double
xyX XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
targetGapped) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) Maybe Double
centerX'
              cY :: Double
cY = case Axis
dirAccessor of
                Axis
AxisX -> Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe
                  ((XYPosition -> Double
xyY XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
targetGapped) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) Maybe Double
centerY'
                Axis
AxisY -> Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe
                  (XYPosition -> Double
xyY XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (XYPosition -> Double
xyY XYPosition
targetGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyY XYPosition
sourceGapped) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
stepPosition)
                  Maybe Double
centerY'
              verticalSplit :: [XYPosition]
verticalSplit =
                [ Double -> Double -> XYPosition
XYPosition Double
cX (XYPosition -> Double
xyY XYPosition
sourceGapped)
                , Double -> Double -> XYPosition
XYPosition Double
cX (XYPosition -> Double
xyY XYPosition
targetGapped) ]
              horizontalSplit :: [XYPosition]
horizontalSplit =
                [ Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
sourceGapped) Double
cY
                , Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
targetGapped) Double
cY ]
              ps :: [XYPosition]
ps | Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
sourceDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
currDir =
                     if Axis
dirAccessor Axis -> Axis -> Bool
forall a. Eq a => a -> a -> Bool
== Axis
AxisX then [XYPosition]
verticalSplit else [XYPosition]
horizontalSplit
                 | Bool
otherwise =
                     if Axis
dirAccessor Axis -> Axis -> Bool
forall a. Eq a => a -> a -> Bool
== Axis
AxisX then [XYPosition]
horizontalSplit else [XYPosition]
verticalSplit
          in ([XYPosition]
ps, Double
cX, Double
cY, XYPosition
zeroPosition, XYPosition
zeroPosition)
      | Bool
otherwise =
          let sourceTarget :: [XYPosition]
sourceTarget = [ Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
sourceGapped) (XYPosition -> Double
xyY XYPosition
targetGapped) ]
              targetSource :: [XYPosition]
targetSource = [ Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
targetGapped) (XYPosition -> Double
xyY XYPosition
sourceGapped) ]
              ps0 :: [XYPosition]
ps0 | Axis
dirAccessor Axis -> Axis -> Bool
forall a. Eq a => a -> a -> Bool
== Axis
AxisX =
                      if XYPosition -> Double
xyX XYPosition
sourceDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
currDir then [XYPosition]
targetSource else [XYPosition]
sourceTarget
                  | Bool
otherwise =
                      if XYPosition -> Double
xyY XYPosition
sourceDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
currDir then [XYPosition]
sourceTarget else [XYPosition]
targetSource
              -- same handle positions: keep gapped points from overlapping
              (XYPosition
sourceGapOff, XYPosition
targetGapOff)
                | Position
sourcePosition Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
targetPosition =
                    let diff :: Double
diff = Double -> Double
forall a. Num a => a -> a
abs (Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
source Double -> Double -> Double
forall a. Num a => a -> a -> a
- Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
target)
                    in if Double
diff Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
offset
                         then
                           let gapOffset :: Double
gapOffset = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double
offset Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1) (Double
offset Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
diff)
                           in if Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
sourceDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
currDir
                                then ( Axis -> Double -> XYPosition -> XYPosition
setAxis Axis
dirAccessor
                                         ((if Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
sourceGapped Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
source then -Double
1 else Double
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
gapOffset)
                                         XYPosition
zeroPosition
                                     , XYPosition
zeroPosition )
                                else ( XYPosition
zeroPosition
                                     , Axis -> Double -> XYPosition -> XYPosition
setAxis Axis
dirAccessor
                                         ((if Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
targetGapped Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
target then -Double
1 else Double
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
gapOffset)
                                         XYPosition
zeroPosition )
                         else (XYPosition
zeroPosition, XYPosition
zeroPosition)
                | Bool
otherwise = (XYPosition
zeroPosition, XYPosition
zeroPosition)
              -- mixed handle positions (e.g. Right -> Bottom)
              ps :: [XYPosition]
ps | Position
sourcePosition Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
/= Position
targetPosition =
                    let dirAccessorOpposite :: Axis
dirAccessorOpposite = if Axis
dirAccessor Axis -> Axis -> Bool
forall a. Eq a => a -> a -> Bool
== Axis
AxisX then Axis
AxisY else Axis
AxisX
                        isSameDir :: Bool
isSameDir = Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
sourceDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Axis -> XYPosition -> Double
axis Axis
dirAccessorOpposite XYPosition
targetDir
                        sourceGtTargetOppo :: Bool
sourceGtTargetOppo =
                          Axis -> XYPosition -> Double
axis Axis
dirAccessorOpposite XYPosition
sourceGapped Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Axis -> XYPosition -> Double
axis Axis
dirAccessorOpposite XYPosition
targetGapped
                        sourceLtTargetOppo :: Bool
sourceLtTargetOppo =
                          Axis -> XYPosition -> Double
axis Axis
dirAccessorOpposite XYPosition
sourceGapped Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Axis -> XYPosition -> Double
axis Axis
dirAccessorOpposite XYPosition
targetGapped
                        flipSourceTarget :: Bool
flipSourceTarget =
                          (Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
sourceDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1 Bool -> Bool -> Bool
&&
                            ((Bool -> Bool
not Bool
isSameDir Bool -> Bool -> Bool
&& Bool
sourceGtTargetOppo) Bool -> Bool -> Bool
|| (Bool
isSameDir Bool -> Bool -> Bool
&& Bool
sourceLtTargetOppo)))
                          Bool -> Bool -> Bool
||
                          (Axis -> XYPosition -> Double
axis Axis
dirAccessor XYPosition
sourceDir Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
1 Bool -> Bool -> Bool
&&
                            ((Bool -> Bool
not Bool
isSameDir Bool -> Bool -> Bool
&& Bool
sourceLtTargetOppo) Bool -> Bool -> Bool
|| (Bool
isSameDir Bool -> Bool -> Bool
&& Bool
sourceGtTargetOppo)))
                    in if Bool
flipSourceTarget
                         then if Axis
dirAccessor Axis -> Axis -> Bool
forall a. Eq a => a -> a -> Bool
== Axis
AxisX then [XYPosition]
sourceTarget else [XYPosition]
targetSource
                         else [XYPosition]
ps0
                 | Bool
otherwise = [XYPosition]
ps0
              sourceGapPoint :: XYPosition
sourceGapPoint = Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
sourceGapOff)
                                          (XYPosition -> Double
xyY XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
sourceGapOff)
              targetGapPoint :: XYPosition
targetGapPoint = Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
targetGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
targetGapOff)
                                          (XYPosition -> Double
xyY XYPosition
targetGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
targetGapOff)
              p0 :: XYPosition
p0 = [XYPosition] -> XYPosition
forall a. HasCallStack => [a] -> a
head [XYPosition]
ps
              maxXDistance :: Double
maxXDistance = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Double -> Double
forall a. Num a => a -> a
abs (XYPosition -> Double
xyX XYPosition
sourceGapPoint Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyX XYPosition
p0))
                                 (Double -> Double
forall a. Num a => a -> a
abs (XYPosition -> Double
xyX XYPosition
targetGapPoint Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyX XYPosition
p0))
              maxYDistance :: Double
maxYDistance = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Double -> Double
forall a. Num a => a -> a
abs (XYPosition -> Double
xyY XYPosition
sourceGapPoint Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyY XYPosition
p0))
                                 (Double -> Double
forall a. Num a => a -> a
abs (XYPosition -> Double
xyY XYPosition
targetGapPoint Double -> Double -> Double
forall a. Num a => a -> a -> a
- XYPosition -> Double
xyY XYPosition
p0))
              (Double
cX, Double
cY)
                | Double
maxXDistance Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
maxYDistance =
                    ((XYPosition -> Double
xyX XYPosition
sourceGapPoint Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
targetGapPoint) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, XYPosition -> Double
xyY XYPosition
p0)
                | Bool
otherwise =
                    (XYPosition -> Double
xyX XYPosition
p0, (XYPosition -> Double
xyY XYPosition
sourceGapPoint Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
targetGapPoint) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
          in ([XYPosition]
ps, Double
cX, Double
cY, XYPosition
sourceGapOff, XYPosition
targetGapOff)

    gappedSource :: XYPosition
gappedSource = Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
sourceGapOffset)
                              (XYPosition -> Double
xyY XYPosition
sourceGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
sourceGapOffset)
    gappedTarget :: XYPosition
gappedTarget = Double -> Double -> XYPosition
XYPosition (XYPosition -> Double
xyX XYPosition
targetGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
targetGapOffset)
                              (XYPosition -> Double
xyY XYPosition
targetGapped Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
targetGapOffset)
    firstPoint :: XYPosition
firstPoint = [XYPosition] -> XYPosition
forall a. HasCallStack => [a] -> a
head [XYPosition]
points
    lastPoint :: XYPosition
lastPoint = [XYPosition] -> XYPosition
forall a. HasCallStack => [a] -> a
last [XYPosition]
points
    pathPoints :: [XYPosition]
pathPoints = [[XYPosition]] -> [XYPosition]
forall a. Monoid a => [a] -> a
mconcat
      [ [ XYPosition
source ]
      , [ XYPosition
gappedSource | XYPosition
gappedSource XYPosition -> XYPosition -> Bool
forall a. Eq a => a -> a -> Bool
/= XYPosition
firstPoint ]
      , [XYPosition]
points
      , [ XYPosition
gappedTarget | XYPosition
gappedTarget XYPosition -> XYPosition -> Bool
forall a. Eq a => a -> a -> Bool
/= XYPosition
lastPoint ]
      , [ XYPosition
target ]
      ]
-----------------------------------------------------------------------------
-- | Rounded bend between three points; port of @getBend@.
getBend :: XYPosition -> XYPosition -> XYPosition -> Double -> MisoString
getBend :: XYPosition -> XYPosition -> XYPosition -> Double -> EdgeId
getBend XYPosition
a XYPosition
b XYPosition
c Double
size
  -- no bend
  | (XYPosition -> Double
xyX XYPosition
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
x Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== XYPosition -> Double
xyX XYPosition
c) Bool -> Bool -> Bool
|| (XYPosition -> Double
xyY XYPosition
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y Bool -> Bool -> Bool
&& Double
y Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== XYPosition -> Double
xyY XYPosition
c) =
      EdgeId
"L" EdgeId -> EdgeId -> EdgeId
forall a. Semigroup a => a -> a -> a
<> Double -> EdgeId
jsShow Double
x EdgeId -> EdgeId -> EdgeId
forall a. Semigroup a => a -> a -> a
<> EdgeId
" " EdgeId -> EdgeId -> EdgeId
forall a. Semigroup a => a -> a -> a
<> Double -> EdgeId
jsShow Double
y
  -- first segment is horizontal
  | XYPosition -> Double
xyY XYPosition
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y =
      let xDir :: Double
xDir = if XYPosition -> Double
xyX XYPosition
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyX XYPosition
c then -Double
1 else Double
1
          yDir :: Double
yDir = if XYPosition -> Double
xyY XYPosition
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyY XYPosition
c then Double
1 else -Double
1
      in [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
        [ EdgeId
"L ", Double -> EdgeId
jsShow (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bendSize Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
xDir), EdgeId
",", Double -> EdgeId
jsShow Double
y
        , EdgeId
"Q ", Double -> EdgeId
jsShow Double
x, EdgeId
",", Double -> EdgeId
jsShow Double
y
        , EdgeId
" ", Double -> EdgeId
jsShow Double
x, EdgeId
",", Double -> EdgeId
jsShow (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bendSize Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
yDir)
        ]
  | Bool
otherwise =
      let xDir :: Double
xDir = if XYPosition -> Double
xyX XYPosition
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyX XYPosition
c then Double
1 else -Double
1
          yDir :: Double
yDir = if XYPosition -> Double
xyY XYPosition
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyY XYPosition
c then -Double
1 else Double
1
      in [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
        [ EdgeId
"L ", Double -> EdgeId
jsShow Double
x, EdgeId
",", Double -> EdgeId
jsShow (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bendSize Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
yDir)
        , EdgeId
"Q ", Double -> EdgeId
jsShow Double
x, EdgeId
",", Double -> EdgeId
jsShow Double
y
        , EdgeId
" ", Double -> EdgeId
jsShow (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bendSize Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
xDir), EdgeId
",", Double -> EdgeId
jsShow Double
y
        ]
  where
    bendSize :: Double
bendSize = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ XYPosition -> XYPosition -> Double
distanceBetween XYPosition
a XYPosition
b Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, XYPosition -> XYPosition -> Double
distanceBetween XYPosition
b XYPosition
c Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, Double
size ]
    x :: Double
x = XYPosition -> Double
xyX XYPosition
b
    y :: Double
y = XYPosition -> Double
xyY XYPosition
b
-----------------------------------------------------------------------------
-- | Stepped path between two points with rounded corners; port of
-- @getSmoothStepPath@. Use @smoothBorderRadius = 0@ for a plain step
-- edge.
getSmoothStepPath :: GetSmoothStepPathParams -> EdgePath
getSmoothStepPath :: GetSmoothStepPathParams -> EdgePath
getSmoothStepPath GetSmoothStepPathParams {Double
Maybe Double
Position
smoothSourceX :: GetSmoothStepPathParams -> Double
smoothSourceY :: GetSmoothStepPathParams -> Double
smoothSourcePosition :: GetSmoothStepPathParams -> Position
smoothTargetX :: GetSmoothStepPathParams -> Double
smoothTargetY :: GetSmoothStepPathParams -> Double
smoothTargetPosition :: GetSmoothStepPathParams -> Position
smoothBorderRadius :: GetSmoothStepPathParams -> Double
smoothCenterX :: GetSmoothStepPathParams -> Maybe Double
smoothCenterY :: GetSmoothStepPathParams -> Maybe Double
smoothOffset :: GetSmoothStepPathParams -> Double
smoothStepPosition' :: GetSmoothStepPathParams -> Double
smoothSourceX :: Double
smoothSourceY :: Double
smoothSourcePosition :: Position
smoothTargetX :: Double
smoothTargetY :: Double
smoothTargetPosition :: Position
smoothBorderRadius :: Double
smoothCenterX :: Maybe Double
smoothCenterY :: Maybe Double
smoothOffset :: Double
smoothStepPosition' :: Double
..} =
  EdgePath
    { edgePath :: EdgeId
edgePath = EdgeId
path
    , edgePathLabelX :: Double
edgePathLabelX = Double
labelX
    , edgePathLabelY :: Double
edgePathLabelY = Double
labelY
    , edgePathOffsetX :: Double
edgePathOffsetX = Double
offsetX
    , edgePathOffsetY :: Double
edgePathOffsetY = Double
offsetY
    }
  where
    ([XYPosition]
points, Double
labelX, Double
labelY, Double
offsetX, Double
offsetY) =
      XYPosition
-> Position
-> XYPosition
-> Position
-> (Maybe Double, Maybe Double)
-> Double
-> Double
-> ([XYPosition], Double, Double, Double, Double)
getPoints
        (Double -> Double -> XYPosition
XYPosition Double
smoothSourceX Double
smoothSourceY) Position
smoothSourcePosition
        (Double -> Double -> XYPosition
XYPosition Double
smoothTargetX Double
smoothTargetY) Position
smoothTargetPosition
        (Maybe Double
smoothCenterX, Maybe Double
smoothCenterY)
        Double
smoothOffset
        Double
smoothStepPosition'
    firstPoint :: XYPosition
firstPoint = [XYPosition] -> XYPosition
forall a. HasCallStack => [a] -> a
head [XYPosition]
points
    lastPoint :: XYPosition
lastPoint = [XYPosition] -> XYPosition
forall a. HasCallStack => [a] -> a
last [XYPosition]
points
    bends :: EdgeId
bends = [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
      [ XYPosition -> XYPosition -> XYPosition -> Double -> EdgeId
getBend ([XYPosition]
points [XYPosition] -> Int -> XYPosition
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) ([XYPosition]
points [XYPosition] -> Int -> XYPosition
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) ([XYPosition]
points [XYPosition] -> Int -> XYPosition
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Double
smoothBorderRadius
      | Int
i <- [Int
1 .. [XYPosition] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XYPosition]
points Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2]
      ]
    path :: EdgeId
path = [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
      [ EdgeId
"M", Double -> EdgeId
jsShow (XYPosition -> Double
xyX XYPosition
firstPoint), EdgeId
" ", Double -> EdgeId
jsShow (XYPosition -> Double
xyY XYPosition
firstPoint)
      , EdgeId
bends
      , EdgeId
"L", Double -> EdgeId
jsShow (XYPosition -> Double
xyX XYPosition
lastPoint), EdgeId
" ", Double -> EdgeId
jsShow (XYPosition -> Double
xyY XYPosition
lastPoint)
      ]
-----------------------------------------------------------------------------
-- | Straight line between two points; port of @getStraightPath@.
getStraightPath
  :: Double -- ^ source x
  -> Double -- ^ source y
  -> Double -- ^ target x
  -> Double -- ^ target y
  -> EdgePath
getStraightPath :: Double -> Double -> Double -> Double -> EdgePath
getStraightPath Double
sourceX Double
sourceY Double
targetX Double
targetY =
  EdgePath
    { edgePath :: EdgeId
edgePath = [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
        [ EdgeId
"M ", Double -> EdgeId
jsShow Double
sourceX, EdgeId
",", Double -> EdgeId
jsShow Double
sourceY
        , EdgeId
"L ", Double -> EdgeId
jsShow Double
targetX, EdgeId
",", Double -> EdgeId
jsShow Double
targetY
        ]
    , edgePathLabelX :: Double
edgePathLabelX = Double
labelX
    , edgePathLabelY :: Double
edgePathLabelY = Double
labelY
    , edgePathOffsetX :: Double
edgePathOffsetX = Double
offsetX
    , edgePathOffsetY :: Double
edgePathOffsetY = Double
offsetY
    }
  where
    (Double
labelX, Double
labelY, Double
offsetX, Double
offsetY) =
      Double
-> Double -> Double -> Double -> (Double, Double, Double, Double)
getEdgeCenter Double
sourceX Double
sourceY Double
targetX Double
targetY
-----------------------------------------------------------------------------
-- | Center point of a straight edge and the offsets from the source;
-- returns @(centerX, centerY, offsetX, offsetY)@.
getEdgeCenter
  :: Double -> Double -> Double -> Double
  -> (Double, Double, Double, Double)
getEdgeCenter :: Double
-> Double -> Double -> Double -> (Double, Double, Double, Double)
getEdgeCenter Double
sourceX Double
sourceY Double
targetX Double
targetY =
  (Double
centerX, Double
centerY, Double
xOffset, Double
yOffset)
  where
    xOffset :: Double
xOffset = Double -> Double
forall a. Num a => a -> a
abs (Double
targetX Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sourceX) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    centerX :: Double
centerX = if Double
targetX Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
sourceX then Double
targetX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
xOffset else Double
targetX Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
xOffset
    yOffset :: Double
yOffset = Double -> Double
forall a. Num a => a -> a
abs (Double
targetY Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sourceY) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    centerY :: Double
centerY = if Double
targetY Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
sourceY then Double
targetY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
yOffset else Double
targetY Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
yOffset
-----------------------------------------------------------------------------
-- | Z-index for an edge based on its endpoint nodes and selection state;
-- port of @getElevatedEdgeZIndex@.
getElevatedEdgeZIndex
  :: InternalNode n  -- ^ source node
  -> InternalNode n  -- ^ target node
  -> Bool            -- ^ selected
  -> Double          -- ^ z-index (default 0)
  -> Bool            -- ^ elevate on select
  -> ZIndexMode      -- ^ default 'ZIndexBasic'
  -> Double
getElevatedEdgeZIndex :: forall n.
InternalNode n
-> InternalNode n -> Bool -> Double -> Bool -> ZIndexMode -> Double
getElevatedEdgeZIndex InternalNode n
sourceNode InternalNode n
targetNode Bool
selected Double
zIndex Bool
elevateOnSelect ZIndexMode
zIndexMode
  | ZIndexMode
zIndexMode ZIndexMode -> ZIndexMode -> Bool
forall a. Eq a => a -> a -> Bool
== ZIndexMode
ZIndexManual = Double
zIndex
  | Bool
otherwise = Double
edgeZ Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
nodeZ
  where
    edgeZ :: Double
edgeZ = if Bool
elevateOnSelect Bool -> Bool -> Bool
&& Bool
selected then Double
zIndex Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1000 else Double
zIndex
    nodeContrib :: InternalNode n -> Double
nodeContrib InternalNode n
n =
      if Maybe EdgeId -> Bool
forall a. Maybe a -> Bool
isJust (Node n -> Maybe EdgeId
forall n. Node n -> Maybe EdgeId
nodeParentId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n))
           Bool -> Bool -> Bool
|| (Bool
elevateOnSelect Bool -> Bool -> Bool
&& Node n -> Bool
forall n. Node n -> Bool
nodeSelected (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n))
        then InternalNode n -> Double
forall n. InternalNode n -> Double
internalZ InternalNode n
n
        else Double
0
    nodeZ :: Double
nodeZ = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (InternalNode n -> Double
forall n. InternalNode n -> Double
nodeContrib InternalNode n
sourceNode) (InternalNode n -> Double
forall n. InternalNode n -> Double
nodeContrib InternalNode n
targetNode)
-----------------------------------------------------------------------------
-- | Whether any part of the edge's bounding box is inside the viewport.
isEdgeVisible
  :: InternalNode n  -- ^ source node
  -> InternalNode n  -- ^ target node
  -> Double          -- ^ viewport width
  -> Double          -- ^ viewport height
  -> Transform
  -> Bool
isEdgeVisible :: forall n.
InternalNode n
-> InternalNode n -> Double -> Double -> Transform -> Bool
isEdgeVisible InternalNode n
sourceNode InternalNode n
targetNode Double
width Double
height (Viewport Double
tx Double
ty Double
tScale) =
  Rect -> Rect -> Double
getOverlappingArea Rect
viewRect (Box -> Rect
boxToRect Box
edgeBox') Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
  where
    edgeBox :: Box
edgeBox = Box -> Box -> Box
getBoundsOfBoxes
      (InternalNode n -> Box
forall n. InternalNode n -> Box
internalNodeToBox InternalNode n
sourceNode)
      (InternalNode n -> Box
forall n. InternalNode n -> Box
internalNodeToBox InternalNode n
targetNode)
    edgeBox' :: Box
edgeBox' = Box
edgeBox
      { boxX2 = if boxX edgeBox == boxX2 edgeBox then boxX2 edgeBox + 1 else boxX2 edgeBox
      , boxY2 = if boxY edgeBox == boxY2 edgeBox then boxY2 edgeBox + 1 else boxY2 edgeBox
      }
    viewRect :: Rect
viewRect = Rect
      { rectX :: Double
rectX = Double -> Double
forall a. Num a => a -> a
negate Double
tx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
      , rectY :: Double
rectY = Double -> Double
forall a. Num a => a -> a
negate Double
ty Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
      , rectWidth :: Double
rectWidth = Double
width Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
      , rectHeight :: Double
rectHeight = Double
height Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
      }
-----------------------------------------------------------------------------
-- | Default edge id for a connection:
-- @xy-edge__\<source>\<sourceHandle>-\<target>\<targetHandle>@.
getEdgeId :: Connection -> EdgeId
getEdgeId :: Connection -> EdgeId
getEdgeId Connection {Maybe EdgeId
EdgeId
connectionSource :: EdgeId
connectionTarget :: EdgeId
connectionSourceHandle :: Maybe EdgeId
connectionTargetHandle :: Maybe EdgeId
connectionSource :: Connection -> EdgeId
connectionSourceHandle :: Connection -> Maybe EdgeId
connectionTarget :: Connection -> EdgeId
connectionTargetHandle :: Connection -> Maybe EdgeId
..} = [EdgeId] -> EdgeId
forall a. Monoid a => [a] -> a
mconcat
  [ EdgeId
"xy-edge__"
  , EdgeId
connectionSource, EdgeId -> Maybe EdgeId -> EdgeId
forall a. a -> Maybe a -> a
fromMaybe EdgeId
"" Maybe EdgeId
connectionSourceHandle
  , EdgeId
"-"
  , EdgeId
connectionTarget, EdgeId -> Maybe EdgeId -> EdgeId
forall a. a -> Maybe a -> a
fromMaybe EdgeId
"" Maybe EdgeId
connectionTargetHandle
  ]
-----------------------------------------------------------------------------
-- | Upgrade a 'Connection' to an 'Edge' using the given id generator.
connectionToEdge :: (Connection -> EdgeId) -> Connection -> Edge e
connectionToEdge :: forall e. (Connection -> EdgeId) -> Connection -> Edge e
connectionToEdge Connection -> EdgeId
mkId Connection
c =
  (EdgeId -> EdgeId -> EdgeId -> Edge e
forall e. EdgeId -> EdgeId -> EdgeId -> Edge e
edge (Connection -> EdgeId
mkId Connection
c) (Connection -> EdgeId
connectionSource Connection
c) (Connection -> EdgeId
connectionTarget Connection
c))
    { edgeSourceHandle = connectionSourceHandle c
    , edgeTargetHandle = connectionTargetHandle c
    }
-----------------------------------------------------------------------------
connectionExists :: Edge e -> [Edge e] -> Bool
connectionExists :: forall e. Edge e -> [Edge e] -> Bool
connectionExists Edge e
e = (Edge e -> Bool) -> [Edge e] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Edge e -> Bool) -> [Edge e] -> Bool)
-> (Edge e -> Bool) -> [Edge e] -> Bool
forall a b. (a -> b) -> a -> b
$ \Edge e
el ->
  Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeSource Edge e
el EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeSource Edge e
e
    Bool -> Bool -> Bool
&& Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeTarget Edge e
el EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeTarget Edge e
e
    Bool -> Bool -> Bool
&& (Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeSourceHandle Edge e
el Maybe EdgeId -> Maybe EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeSourceHandle Edge e
e
          Bool -> Bool -> Bool
|| (Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeSourceHandle Edge e
el Maybe EdgeId -> Maybe EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe EdgeId
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeSourceHandle Edge e
e Maybe EdgeId -> Maybe EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe EdgeId
forall a. Maybe a
Nothing))
    Bool -> Bool -> Bool
&& (Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeTargetHandle Edge e
el Maybe EdgeId -> Maybe EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeTargetHandle Edge e
e
          Bool -> Bool -> Bool
|| (Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeTargetHandle Edge e
el Maybe EdgeId -> Maybe EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe EdgeId
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Edge e -> Maybe EdgeId
forall e. Edge e -> Maybe EdgeId
edgeTargetHandle Edge e
e Maybe EdgeId -> Maybe EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe EdgeId
forall a. Maybe a
Nothing))
-----------------------------------------------------------------------------
-- | Add a connection to an array of edges, unless an equivalent
-- connection already exists; port of @addEdge@ (for the @Connection@
-- overload — pass an existing 'Edge' through 'addEdgeWith' 'id').
addEdge :: Connection -> [Edge e] -> [Edge e]
addEdge :: forall e. Connection -> [Edge e] -> [Edge e]
addEdge = (Connection -> Edge e) -> Connection -> [Edge e] -> [Edge e]
forall e.
(Connection -> Edge e) -> Connection -> [Edge e] -> [Edge e]
addEdgeWith ((Connection -> EdgeId) -> Connection -> Edge e
forall e. (Connection -> EdgeId) -> Connection -> Edge e
connectionToEdge Connection -> EdgeId
getEdgeId)
-----------------------------------------------------------------------------
-- | 'addEdge' with a custom @Connection -> Edge@ upgrade (covers the
-- custom @getEdgeId@ option and the edge overload of the original).
addEdgeWith :: (Connection -> Edge e) -> Connection -> [Edge e] -> [Edge e]
addEdgeWith :: forall e.
(Connection -> Edge e) -> Connection -> [Edge e] -> [Edge e]
addEdgeWith Connection -> Edge e
mkEdge Connection
c [Edge e]
edges
  | Connection -> EdgeId
connectionSource Connection
c EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeId
"" Bool -> Bool -> Bool
|| Connection -> EdgeId
connectionTarget Connection
c EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeId
"" = [Edge e]
edges
  | Edge e -> [Edge e] -> Bool
forall e. Edge e -> [Edge e] -> Bool
connectionExists Edge e
e [Edge e]
edges = [Edge e]
edges
  | Bool
otherwise = [Edge e]
edges [Edge e] -> [Edge e] -> [Edge e]
forall a. Semigroup a => a -> a -> a
<> [Edge e
e]
  where
    e :: Edge e
e = Connection -> Edge e
mkEdge Connection
c
-----------------------------------------------------------------------------
-- | Replace an edge with a new connection; port of @reconnectEdge@ with
-- @shouldReplaceId = True@.
reconnectEdge :: Edge e -> Connection -> [Edge e] -> [Edge e]
reconnectEdge :: forall e. Edge e -> Connection -> [Edge e] -> [Edge e]
reconnectEdge = Bool
-> (Connection -> EdgeId)
-> Edge e
-> Connection
-> [Edge e]
-> [Edge e]
forall e.
Bool
-> (Connection -> EdgeId)
-> Edge e
-> Connection
-> [Edge e]
-> [Edge e]
reconnectEdgeWith Bool
True Connection -> EdgeId
getEdgeId
-----------------------------------------------------------------------------
-- | 'reconnectEdge' with explicit @shouldReplaceId@ and id generator.
reconnectEdgeWith
  :: Bool
  -- ^ replace the old id with the generated connection id
  -> (Connection -> EdgeId)
  -> Edge e
  -> Connection
  -> [Edge e]
  -> [Edge e]
reconnectEdgeWith :: forall e.
Bool
-> (Connection -> EdgeId)
-> Edge e
-> Connection
-> [Edge e]
-> [Edge e]
reconnectEdgeWith Bool
shouldReplaceId Connection -> EdgeId
mkId Edge e
oldEdge Connection
newConnection [Edge e]
edges
  | Connection -> EdgeId
connectionSource Connection
newConnection EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeId
""
      Bool -> Bool -> Bool
|| Connection -> EdgeId
connectionTarget Connection
newConnection EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeId
"" = [Edge e]
edges
  | Bool -> Bool
not ((Edge e -> Bool) -> [Edge e] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeId Edge e
oldEdge) (EdgeId -> Bool) -> (Edge e -> EdgeId) -> Edge e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeId) [Edge e]
edges) = [Edge e]
edges
  | Bool
otherwise =
      [ Edge e
e | Edge e
e <- [Edge e]
edges, Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeId Edge e
e EdgeId -> EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
/= Edge e -> EdgeId
forall e. Edge e -> EdgeId
edgeId Edge e
oldEdge ] [Edge e] -> [Edge e] -> [Edge e]
forall a. Semigroup a => a -> a -> a
<> [ Edge e
newEdge ]
  where
    newEdge :: Edge e
newEdge = Edge e
oldEdge
      { edgeId = if shouldReplaceId then mkId newConnection else edgeId oldEdge
      , edgeSource = connectionSource newConnection
      , edgeTarget = connectionTarget newConnection
      , edgeSourceHandle = connectionSourceHandle newConnection
      , edgeTargetHandle = connectionTargetHandle newConnection
      , edgeSelected = False
      }
-----------------------------------------------------------------------------
isNodeInitialized :: InternalNode n -> Bool
isNodeInitialized :: forall n. InternalNode n -> Bool
isNodeInitialized InternalNode n
n =
  (Maybe NodeHandleBounds -> Bool
forall a. Maybe a -> Bool
isJust (InternalNode n -> Maybe NodeHandleBounds
forall n. InternalNode n -> Maybe NodeHandleBounds
internalHandleBounds InternalNode n
n)
     Bool -> Bool -> Bool
|| Bool -> ([NodeHandle] -> Bool) -> Maybe [NodeHandle] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool) -> ([NodeHandle] -> Bool) -> [NodeHandle] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NodeHandle] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Node n -> Maybe [NodeHandle]
forall n. Node n -> Maybe [NodeHandle]
nodeHandles Node n
u))
  Bool -> Bool -> Bool
&& (Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust (Measured -> Maybe Double
measuredWidth (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n))
       Bool -> Bool -> Bool
|| Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust (Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeWidth Node n
u)
       Bool -> Bool -> Bool
|| Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust (Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeInitialWidth Node n
u))
  where u :: Node n
u = InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n
-----------------------------------------------------------------------------
-- | Resolve the concrete start\/end coordinates and positions of an edge
-- from its endpoint nodes; port of @getEdgePosition@. Returns 'Nothing'
-- when either node is not yet initialized or a handle can't be found.
getEdgePosition
  :: InternalNode n        -- ^ source node
  -> Maybe MisoString      -- ^ source handle id
  -> InternalNode n        -- ^ target node
  -> Maybe MisoString      -- ^ target handle id
  -> ConnectionMode
  -> Maybe EdgePosition
getEdgePosition :: forall n.
InternalNode n
-> Maybe EdgeId
-> InternalNode n
-> Maybe EdgeId
-> ConnectionMode
-> Maybe EdgePosition
getEdgePosition InternalNode n
sourceNode Maybe EdgeId
sourceHandleId InternalNode n
targetNode Maybe EdgeId
targetHandleId ConnectionMode
connectionMode
  | Bool -> Bool
not (InternalNode n -> Bool
forall n. InternalNode n -> Bool
isNodeInitialized InternalNode n
sourceNode) Bool -> Bool -> Bool
|| Bool -> Bool
not (InternalNode n -> Bool
forall n. InternalNode n -> Bool
isNodeInitialized InternalNode n
targetNode) =
      Maybe EdgePosition
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      let sourceBounds :: Maybe NodeHandleBounds
sourceBounds = InternalNode n -> Maybe NodeHandleBounds
forall n. InternalNode n -> Maybe NodeHandleBounds
handleBoundsOf InternalNode n
sourceNode
          targetBounds :: Maybe NodeHandleBounds
targetBounds = InternalNode n -> Maybe NodeHandleBounds
forall n. InternalNode n -> Maybe NodeHandleBounds
handleBoundsOf InternalNode n
targetNode
      sourceHandle <- [Handle] -> Maybe EdgeId -> Maybe Handle
pickHandle
        ([Handle] -> Maybe [Handle] -> [Handle]
forall a. a -> Maybe a -> a
fromMaybe [] (NodeHandleBounds -> Maybe [Handle]
nhbSource (NodeHandleBounds -> Maybe [Handle])
-> Maybe NodeHandleBounds -> Maybe [Handle]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe NodeHandleBounds
sourceBounds)) Maybe EdgeId
sourceHandleId
      targetHandle <- pickHandle
        (case connectionMode of
           ConnectionMode
ConnectionModeStrict ->
             [Handle] -> Maybe [Handle] -> [Handle]
forall a. a -> Maybe a -> a
fromMaybe [] (NodeHandleBounds -> Maybe [Handle]
nhbTarget (NodeHandleBounds -> Maybe [Handle])
-> Maybe NodeHandleBounds -> Maybe [Handle]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe NodeHandleBounds
targetBounds)
           ConnectionMode
ConnectionModeLoose ->
             [Handle] -> Maybe [Handle] -> [Handle]
forall a. a -> Maybe a -> a
fromMaybe [] (NodeHandleBounds -> Maybe [Handle]
nhbTarget (NodeHandleBounds -> Maybe [Handle])
-> Maybe NodeHandleBounds -> Maybe [Handle]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe NodeHandleBounds
targetBounds)
               [Handle] -> [Handle] -> [Handle]
forall a. Semigroup a => a -> a -> a
<> [Handle] -> Maybe [Handle] -> [Handle]
forall a. a -> Maybe a -> a
fromMaybe [] (NodeHandleBounds -> Maybe [Handle]
nhbSource (NodeHandleBounds -> Maybe [Handle])
-> Maybe NodeHandleBounds -> Maybe [Handle]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe NodeHandleBounds
targetBounds))
        targetHandleId
      let sourcePosition = Handle -> Position
hPosition Handle
sourceHandle
          targetPosition = Handle -> Position
hPosition Handle
targetHandle
          source = InternalNode n -> Maybe Handle -> Position -> Bool -> XYPosition
forall n.
InternalNode n -> Maybe Handle -> Position -> Bool -> XYPosition
getHandlePosition InternalNode n
sourceNode (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
sourceHandle) Position
sourcePosition Bool
False
          target = InternalNode n -> Maybe Handle -> Position -> Bool -> XYPosition
forall n.
InternalNode n -> Maybe Handle -> Position -> Bool -> XYPosition
getHandlePosition InternalNode n
targetNode (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
targetHandle) Position
targetPosition Bool
False
      pure EdgePosition
        { epSourceX = xyX source
        , epSourceY = xyY source
        , epTargetX = xyX target
        , epTargetY = xyY target
        , epSourcePosition = sourcePosition
        , epTargetPosition = targetPosition
        }
  where
    handleBoundsOf :: InternalNode n -> Maybe NodeHandleBounds
handleBoundsOf InternalNode n
n =
      case InternalNode n -> Maybe NodeHandleBounds
forall n. InternalNode n -> Maybe NodeHandleBounds
internalHandleBounds InternalNode n
n of
        Just NodeHandleBounds
hb -> NodeHandleBounds -> Maybe NodeHandleBounds
forall a. a -> Maybe a
Just NodeHandleBounds
hb
        Maybe NodeHandleBounds
Nothing -> EdgeId -> Maybe [NodeHandle] -> Maybe NodeHandleBounds
toHandleBounds (Node n -> EdgeId
forall n. Node n -> EdgeId
nodeId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n)) (Node n -> Maybe [NodeHandle]
forall n. Node n -> Maybe [NodeHandle]
nodeHandles (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n))
    pickHandle :: [Handle] -> Maybe EdgeId -> Maybe Handle
pickHandle [Handle]
bounds Maybe EdgeId
handleId' =
      case Maybe EdgeId
handleId' of
        Maybe EdgeId
Nothing -> case [Handle]
bounds of
          (Handle
h : [Handle]
_) -> Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h
          [] -> Maybe Handle
forall a. Maybe a
Nothing
        Just EdgeId
hid -> case (Handle -> Bool) -> [Handle] -> [Handle]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe EdgeId -> Maybe EdgeId -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeId -> Maybe EdgeId
forall a. a -> Maybe a
Just EdgeId
hid) (Maybe EdgeId -> Bool)
-> (Handle -> Maybe EdgeId) -> Handle -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Maybe EdgeId
hId) [Handle]
bounds of
          (Handle
h : [Handle]
_) -> Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h
          [] -> Maybe Handle
forall a. Maybe a
Nothing
-----------------------------------------------------------------------------
-- | Group a node's declared handles by type; port of @toHandleBounds@.
toHandleBounds :: NodeId -> Maybe [NodeHandle] -> Maybe NodeHandleBounds
toHandleBounds :: EdgeId -> Maybe [NodeHandle] -> Maybe NodeHandleBounds
toHandleBounds EdgeId
_ Maybe [NodeHandle]
Nothing = Maybe NodeHandleBounds
forall a. Maybe a
Nothing
toHandleBounds EdgeId
nid (Just [NodeHandle]
handles) =
  NodeHandleBounds -> Maybe NodeHandleBounds
forall a. a -> Maybe a
Just NodeHandleBounds
    { nhbSource :: Maybe [Handle]
nhbSource = [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just [ Handle
h | Handle
h <- [Handle]
hs, Handle -> HandleType
hType Handle
h HandleType -> HandleType -> Bool
forall a. Eq a => a -> a -> Bool
== HandleType
SourceHandle ]
    , nhbTarget :: Maybe [Handle]
nhbTarget = [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just [ Handle
h | Handle
h <- [Handle]
hs, Handle -> HandleType
hType Handle
h HandleType -> HandleType -> Bool
forall a. Eq a => a -> a -> Bool
== HandleType
TargetHandle ]
    }
  where
    hs :: [Handle]
hs = (NodeHandle -> Handle) -> [NodeHandle] -> [Handle]
forall a b. (a -> b) -> [a] -> [b]
map NodeHandle -> Handle
toHandle [NodeHandle]
handles
    toHandle :: NodeHandle -> Handle
toHandle NodeHandle
nh = Handle
      { hId :: Maybe EdgeId
hId = NodeHandle -> Maybe EdgeId
nhId NodeHandle
nh
      , hNodeId :: EdgeId
hNodeId = EdgeId
nid
      , hX :: Double
hX = NodeHandle -> Double
nhX NodeHandle
nh
      , hY :: Double
hY = NodeHandle -> Double
nhY NodeHandle
nh
      , hPosition :: Position
hPosition = NodeHandle -> Position
nhPosition NodeHandle
nh
      , hType :: HandleType
hType = NodeHandle -> HandleType
nhType NodeHandle
nh
      , hWidth :: Double
hWidth = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (NodeHandle -> Maybe Double
nhWidth NodeHandle
nh)
      , hHeight :: Double
hHeight = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (NodeHandle -> Maybe Double
nhHeight NodeHandle
nh)
      }
-----------------------------------------------------------------------------
-- | Absolute position of a handle on a node; port of @getHandlePosition@.
getHandlePosition
  :: InternalNode n
  -> Maybe Handle
  -> Position
  -- ^ fallback position (original default: 'PositionLeft')
  -> Bool
  -- ^ center: return the handle center instead of its edge anchor
  -> XYPosition
getHandlePosition :: forall n.
InternalNode n -> Maybe Handle -> Position -> Bool -> XYPosition
getHandlePosition InternalNode n
n Maybe Handle
mHandle Position
fallbackPosition Bool
center =
  if Bool
center
    then Double -> Double -> XYPosition
XYPosition (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w 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
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
    else case Position
position of
      Position
PositionTop    -> Double -> Double -> XYPosition
XYPosition (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) Double
y
      Position
PositionRight  -> Double -> Double -> XYPosition
XYPosition (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
      Position
PositionBottom -> Double -> Double -> XYPosition
XYPosition (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w 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
h)
      Position
PositionLeft   -> Double -> Double -> XYPosition
XYPosition Double
x (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
  where
    x :: Double
x = Double -> (Handle -> Double) -> Maybe Handle -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 Handle -> Double
hX Maybe Handle
mHandle Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX (InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
n)
    y :: Double
y = Double -> (Handle -> Double) -> Maybe Handle -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 Handle -> Double
hY Maybe Handle
mHandle Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY (InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
n)
    Dimensions Double
w Double
h = case Maybe Handle
mHandle of
      Just Handle
handle -> Double -> Double -> Dimensions
Dimensions (Handle -> Double
hWidth Handle
handle) (Handle -> Double
hHeight Handle
handle)
      Maybe Handle
Nothing -> InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
n
    position :: Position
position = Position -> (Handle -> Position) -> Maybe Handle -> Position
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Position
fallbackPosition Handle -> Position
hPosition Maybe Handle
mHandle
-----------------------------------------------------------------------------