-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow.Utils.Graph
-- License     :  BSD3-style (see the file LICENSE)
--
-- Pure port of @utils\/graph.ts@ from @\@xyflow\/system@.
----------------------------------------------------------------------------
module Miso.Flow.Utils.Graph
  ( getOutgoers
  , getIncomers
  , getNodePositionWithOrigin
  , getNodesBounds
  , getNodesBoundsWithLookup
  , getInternalNodesBounds
  , getNodesInside
  , getConnectedEdges
  , getFitViewNodes
  , fitViewportFor
  , calculateNodePosition
  , getElementsToRemove
  ) where
-----------------------------------------------------------------------------
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe, mapMaybe, isJust)
import qualified Data.Set as S
import           Prelude
-----------------------------------------------------------------------------
import           Miso.Flow.Constants (infiniteExtent)
import           Miso.Flow.Types
import           Miso.Flow.Utils.General
-----------------------------------------------------------------------------
-- | Nodes connected to the given node as the target of an edge.
getOutgoers :: NodeId -> [Node n] -> [Edge e] -> [Node n]
getOutgoers :: forall n e. NodeId -> [Node n] -> [Edge e] -> [Node n]
getOutgoers NodeId
nid [Node n]
nodes [Edge e]
edges =
  let outgoerIds :: Set NodeId
outgoerIds = [NodeId] -> Set NodeId
forall a. Ord a => [a] -> Set a
S.fromList [ Edge e -> NodeId
forall e. Edge e -> NodeId
edgeTarget Edge e
e | Edge e
e <- [Edge e]
edges, Edge e -> NodeId
forall e. Edge e -> NodeId
edgeSource Edge e
e NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== NodeId
nid ]
  in [ Node n
n | Node n
n <- [Node n]
nodes, Node n -> NodeId
forall n. Node n -> NodeId
nodeId Node n
n NodeId -> Set NodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NodeId
outgoerIds ]
-----------------------------------------------------------------------------
-- | Nodes connected to the given node as the source of an edge.
getIncomers :: NodeId -> [Node n] -> [Edge e] -> [Node n]
getIncomers :: forall n e. NodeId -> [Node n] -> [Edge e] -> [Node n]
getIncomers NodeId
nid [Node n]
nodes [Edge e]
edges =
  let incomerIds :: Set NodeId
incomerIds = [NodeId] -> Set NodeId
forall a. Ord a => [a] -> Set a
S.fromList [ Edge e -> NodeId
forall e. Edge e -> NodeId
edgeSource Edge e
e | Edge e
e <- [Edge e]
edges, Edge e -> NodeId
forall e. Edge e -> NodeId
edgeTarget Edge e
e NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== NodeId
nid ]
  in [ Node n
n | Node n
n <- [Node n]
nodes, Node n -> NodeId
forall n. Node n -> NodeId
nodeId Node n
n NodeId -> Set NodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NodeId
incomerIds ]
-----------------------------------------------------------------------------
-- | Position of a node adjusted by its origin.
getNodePositionWithOrigin :: Node n -> NodeOrigin -> XYPosition
getNodePositionWithOrigin :: forall n. Node n -> NodeOrigin -> XYPosition
getNodePositionWithOrigin Node n
n NodeOrigin
nodeOrigin' =
  let Dimensions Double
w Double
h = Node n -> Dimensions
forall n. Node n -> Dimensions
getNodeDimensions Node n
n
      NodeOrigin Double
ox Double
oy = NodeOrigin -> Maybe NodeOrigin -> NodeOrigin
forall a. a -> Maybe a -> a
fromMaybe NodeOrigin
nodeOrigin' (Node n -> Maybe NodeOrigin
forall n. Node n -> Maybe NodeOrigin
nodeOrigin Node n
n)
  in Double -> Double -> XYPosition
XYPosition
      (XYPosition -> Double
xyX (Node n -> XYPosition
forall n. Node n -> XYPosition
nodePosition Node n
n) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ox)
      (XYPosition -> Double
xyY (Node n -> XYPosition
forall n. Node n -> XYPosition
nodePosition Node n
n) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
oy)
-----------------------------------------------------------------------------
-- | Bounding box containing all given nodes (no lookup: positions are
-- taken from the user nodes and the given origin).
getNodesBounds :: [Node n] -> NodeOrigin -> Rect
getNodesBounds :: forall n. [Node n] -> NodeOrigin -> Rect
getNodesBounds [] NodeOrigin
_ = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 Double
0 Double
0
getNodesBounds [Node n]
nodes NodeOrigin
origin =
  Box -> Rect
boxToRect ((Box -> Node n -> Box) -> Box -> [Node n] -> Box
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Box -> Node n -> Box
forall {n}. Box -> Node n -> Box
step Box
emptyBox [Node n]
nodes)
  where
    step :: Box -> Node n -> Box
step Box
acc Node n
n = Box -> Box -> Box
getBoundsOfBoxes Box
acc (Node n -> NodeOrigin -> Box
forall n. Node n -> NodeOrigin -> Box
nodeToBox Node n
n NodeOrigin
origin)
-----------------------------------------------------------------------------
-- | Bounding box containing all the given node ids, resolved through a
-- 'NodeLookup' so sub-flow (parent) positions are correct. Unknown ids
-- are skipped.
getNodesBoundsWithLookup :: [NodeId] -> NodeLookup n -> Rect
getNodesBoundsWithLookup :: forall n. [NodeId] -> NodeLookup n -> Rect
getNodesBoundsWithLookup [NodeId]
ids NodeLookup n
nodeLookup =
  case (NodeId -> Maybe (InternalNode n)) -> [NodeId] -> [InternalNode n]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeId -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` NodeLookup n
nodeLookup) [NodeId]
ids of
    [] -> Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 Double
0 Double
0
    [InternalNode n]
found -> Box -> Rect
boxToRect ((Box -> InternalNode n -> Box) -> Box -> [InternalNode n] -> Box
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Box
acc InternalNode n
n -> Box -> Box -> Box
getBoundsOfBoxes Box
acc (InternalNode n -> Box
forall n. InternalNode n -> Box
internalNodeToBox InternalNode n
n)) Box
emptyBox [InternalNode n]
found)
-----------------------------------------------------------------------------
-- | Bounding box of the internal nodes matching the filter.
getInternalNodesBounds
  :: (InternalNode n -> Bool)
  -> NodeLookup n
  -> Rect
getInternalNodesBounds :: forall n. (InternalNode n -> Bool) -> NodeLookup n -> Rect
getInternalNodesBounds InternalNode n -> Bool
p NodeLookup n
nodeLookup =
  case (InternalNode n -> Bool) -> [InternalNode n] -> [InternalNode n]
forall a. (a -> Bool) -> [a] -> [a]
filter InternalNode n -> Bool
p (NodeLookup n -> [InternalNode n]
forall k a. Map k a -> [a]
M.elems NodeLookup n
nodeLookup) of
    [] -> Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 Double
0 Double
0
    [InternalNode n]
visible ->
      Box -> Rect
boxToRect ((Box -> InternalNode n -> Box) -> Box -> [InternalNode n] -> Box
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Box
acc InternalNode n
n -> Box -> Box -> Box
getBoundsOfBoxes Box
acc (InternalNode n -> Box
forall n. InternalNode n -> Box
internalNodeToBox InternalNode n
n)) Box
emptyBox [InternalNode n]
visible)
-----------------------------------------------------------------------------
emptyBox :: Box
emptyBox :: Box
emptyBox = Double -> Double -> Double -> Double -> Box
Box (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0)
-----------------------------------------------------------------------------
-- | Internal nodes inside (or partially inside) the given rect.
getNodesInside
  :: NodeLookup n
  -> Rect
  -> Transform
  -> Bool
  -- ^ partially: also include nodes only partially inside
  -> Bool
  -- ^ exclude non-selectable nodes
  -> [InternalNode n]
getNodesInside :: forall n.
NodeLookup n
-> Rect -> Transform -> Bool -> Bool -> [InternalNode n]
getNodesInside NodeLookup n
nodeLookup Rect
rect (Viewport Double
tx Double
ty Double
tScale) Bool
partially Bool
excludeNonSelectable =
  [ InternalNode n
n | InternalNode n
n <- NodeLookup n -> [InternalNode n]
forall k a. Map k a -> [a]
M.elems NodeLookup n
nodeLookup, InternalNode n -> Node n -> Bool
forall {n} {n}. InternalNode n -> Node n -> Bool
keep InternalNode n
n (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n) ]
  where
    paneX :: Double
paneX = (Rect -> Double
rectX Rect
rect Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
tx) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
    paneY :: Double
paneY = (Rect -> Double
rectY Rect
rect Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ty) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
    paneWidth :: Double
paneWidth = Rect -> Double
rectWidth Rect
rect Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
    paneHeight :: Double
paneHeight = Rect -> Double
rectHeight Rect
rect Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale
    keep :: InternalNode n -> Node n -> Bool
keep InternalNode n
n Node n
u
      | Bool
excludeNonSelectable Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Node n -> Maybe Bool
forall n. Node n -> Maybe Bool
nodeSelectable Node n
u)) = Bool
False
      | Node n -> Bool
forall n. Node n -> Bool
nodeHidden Node n
u = Bool
False
      | Bool
otherwise =
          let Dimensions Double
w Double
h = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
n
              XYPosition Double
x Double
y = InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
n
              overlappingArea :: Double
overlappingArea =
                Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
getRectsOverlappingArea Double
paneX Double
paneY Double
paneWidth Double
paneHeight Double
x Double
y Double
w Double
h
              area :: Double
area = Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
h
              partiallyVisible :: Bool
partiallyVisible = Bool
partially Bool -> Bool -> Bool
&& Double
overlappingArea Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
              forceInitialRender :: Bool
forceInitialRender = InternalNode n -> Maybe NodeHandleBounds
forall n. InternalNode n -> Maybe NodeHandleBounds
internalHandleBounds InternalNode n
n Maybe NodeHandleBounds -> Maybe NodeHandleBounds -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe NodeHandleBounds
forall a. Maybe a
Nothing
              isVisible :: Bool
isVisible =
                Bool
forceInitialRender Bool -> Bool -> Bool
|| Bool
partiallyVisible Bool -> Bool -> Bool
|| Double
overlappingArea Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
area
          in Bool
isVisible Bool -> Bool -> Bool
|| Node n -> Bool
forall n. Node n -> Bool
nodeDragging Node n
u
-----------------------------------------------------------------------------
-- | Edges where either endpoint is one of the given nodes.
getConnectedEdges :: [Node n] -> [Edge e] -> [Edge e]
getConnectedEdges :: forall n e. [Node n] -> [Edge e] -> [Edge e]
getConnectedEdges [Node n]
nodes [Edge e]
edges =
  let nodeIds :: Set NodeId
nodeIds = [NodeId] -> Set NodeId
forall a. Ord a => [a] -> Set a
S.fromList ((Node n -> NodeId) -> [Node n] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map Node n -> NodeId
forall n. Node n -> NodeId
nodeId [Node n]
nodes)
  in [ Edge e
e | Edge e
e <- [Edge e]
edges
     , Edge e -> NodeId
forall e. Edge e -> NodeId
edgeSource Edge e
e NodeId -> Set NodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NodeId
nodeIds Bool -> Bool -> Bool
|| Edge e -> NodeId
forall e. Edge e -> NodeId
edgeTarget Edge e
e NodeId -> Set NodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NodeId
nodeIds ]
-----------------------------------------------------------------------------
-- | Which nodes participate in a fit-view; port of @getFitViewNodes@.
getFitViewNodes :: NodeLookup n -> FitViewOptions -> NodeLookup n
getFitViewNodes :: forall n. NodeLookup n -> FitViewOptions -> NodeLookup n
getFitViewNodes NodeLookup n
nodeLookup FitViewOptions
opts =
  (InternalNode n -> Bool) -> NodeLookup n -> NodeLookup n
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter InternalNode n -> Bool
forall {n}. InternalNode n -> Bool
keep NodeLookup n
restricted
  where
    restricted :: NodeLookup n
restricted = case FitViewOptions -> Maybe [NodeId]
fitViewNodes FitViewOptions
opts of
      Maybe [NodeId]
Nothing -> NodeLookup n
nodeLookup
      Just [NodeId]
ids ->
        let idSet :: Set NodeId
idSet = [NodeId] -> Set NodeId
forall a. Ord a => [a] -> Set a
S.fromList [NodeId]
ids
        in (NodeId -> InternalNode n -> Bool) -> NodeLookup n -> NodeLookup n
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\NodeId
k InternalNode n
_ -> NodeId
k NodeId -> Set NodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NodeId
idSet) NodeLookup n
nodeLookup
    keep :: InternalNode n -> Bool
keep InternalNode n
n
      | FitViewOptions -> Bool
fitViewIncludeHiddenNodes FitViewOptions
opts =
          let Dimensions Double
w Double
h = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
n
          in Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
h Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
      | Bool
otherwise =
          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
&& Measured -> Maybe Double
measuredWidth (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n) Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double -> Maybe Double
forall a. a -> Maybe a
Just Double
0
            Bool -> Bool -> Bool
&& Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust (Measured -> Maybe Double
measuredHeight (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n))
            Bool -> Bool -> Bool
&& Measured -> Maybe Double
measuredHeight (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n) Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double -> Maybe Double
forall a. a -> Maybe a
Just Double
0
            Bool -> Bool -> Bool
&& Bool -> Bool
not (Node n -> Bool
forall n. Node n -> Bool
nodeHidden (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n))
-----------------------------------------------------------------------------
-- | Pure core of @fitViewport@: computes the viewport for fitting the
-- given nodes into @width@ × @height@. Returns 'Nothing' for an empty
-- lookup (the effectful caller then leaves the viewport unchanged).
fitViewportFor
  :: NodeLookup n
  -> Double
  -- ^ width
  -> Double
  -- ^ height
  -> Double
  -- ^ min zoom
  -> Double
  -- ^ max zoom
  -> FitViewOptions
  -> Maybe Viewport
fitViewportFor :: forall n.
NodeLookup n
-> Double
-> Double
-> Double
-> Double
-> FitViewOptions
-> Maybe Transform
fitViewportFor NodeLookup n
nodeLookup Double
width Double
height Double
minZoom Double
maxZoom FitViewOptions
opts
  | NodeLookup n -> Bool
forall k a. Map k a -> Bool
M.null NodeLookup n
nodeLookup = Maybe Transform
forall a. Maybe a
Nothing
  | Bool
otherwise =
      let nodesToFit :: NodeLookup n
nodesToFit = NodeLookup n -> FitViewOptions -> NodeLookup n
forall n. NodeLookup n -> FitViewOptions -> NodeLookup n
getFitViewNodes NodeLookup n
nodeLookup FitViewOptions
opts
          bounds :: Rect
bounds = (InternalNode n -> Bool) -> NodeLookup n -> Rect
forall n. (InternalNode n -> Bool) -> NodeLookup n -> Rect
getInternalNodesBounds (Bool -> InternalNode n -> Bool
forall a b. a -> b -> a
const Bool
True) NodeLookup n
nodesToFit
      in Transform -> Maybe Transform
forall a. a -> Maybe a
Just (Transform -> Maybe Transform) -> Transform -> Maybe Transform
forall a b. (a -> b) -> a -> b
$ Rect
-> Double -> Double -> Double -> Double -> Padding -> Transform
getViewportForBounds
           Rect
bounds
           Double
width
           Double
height
           (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
minZoom (FitViewOptions -> Maybe Double
fitViewMinZoom FitViewOptions
opts))
           (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
maxZoom (FitViewOptions -> Maybe Double
fitViewMaxZoom FitViewOptions
opts))
           (FitViewOptions -> Padding
fitViewPadding FitViewOptions
opts)
-----------------------------------------------------------------------------
-- | Next position of a node given its extent, parent and origin; port of
-- @calculateNodePosition@. Returns @(position, positionAbsolute)@;
-- 'Nothing' when the node is missing from the lookup.
calculateNodePosition
  :: NodeId
  -> XYPosition
  -- ^ next (absolute) position
  -> NodeLookup n
  -> NodeOrigin
  -> Maybe CoordinateExtent
  -- ^ global node extent
  -> Maybe (XYPosition, XYPosition)
calculateNodePosition :: forall n.
NodeId
-> XYPosition
-> NodeLookup n
-> NodeOrigin
-> Maybe CoordinateExtent
-> Maybe (XYPosition, XYPosition)
calculateNodePosition NodeId
nid XYPosition
nextPosition NodeLookup n
nodeLookup NodeOrigin
nodeOrigin' Maybe CoordinateExtent
nodeExtent' = do
  n <- NodeId -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeId
nid NodeLookup n
nodeLookup
  let u = InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n
      parentNode = (NodeId -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` NodeLookup n
nodeLookup) (NodeId -> Maybe (InternalNode n))
-> Maybe NodeId -> Maybe (InternalNode n)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node n -> Maybe NodeId
forall n. Node n -> Maybe NodeId
nodeParentId Node n
u
      XYPosition parentX parentY =
        maybe zeroPosition internalPositionAbsolute parentNode
      NodeOrigin ox oy = fromMaybe nodeOrigin' (nodeOrigin u)
      extent =
        case Node n -> Maybe NodeExtent
forall n. Node n -> Maybe NodeExtent
nodeExtent Node n
u of
          Just NodeExtent
ExtentParent
            | Bool -> Bool
not (Node n -> Bool
forall n. Node n -> Bool
nodeExpandParent Node n
u) ->
                case Maybe (InternalNode n)
parentNode of
                  Maybe (InternalNode n)
Nothing -> CoordinateExtent -> NodeExtent
ExtentCoordinates (CoordinateExtent -> NodeExtent)
-> Maybe CoordinateExtent -> Maybe NodeExtent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CoordinateExtent
nodeExtent'
                  Just InternalNode n
parent ->
                    let Dimensions Double
pw Double
ph = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
parent
                    in if Double
pw Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 Bool -> Bool -> Bool
&& Double
ph Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0
                         then NodeExtent -> Maybe NodeExtent
forall a. a -> Maybe a
Just (NodeExtent -> Maybe NodeExtent) -> NodeExtent -> Maybe NodeExtent
forall a b. (a -> b) -> a -> b
$ CoordinateExtent -> NodeExtent
ExtentCoordinates (CoordinateExtent -> NodeExtent) -> CoordinateExtent -> NodeExtent
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> CoordinateExtent
CoordinateExtent
                                Double
parentX Double
parentY (Double
parentX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
pw) (Double
parentY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ph)
                         else CoordinateExtent -> NodeExtent
ExtentCoordinates (CoordinateExtent -> NodeExtent)
-> Maybe CoordinateExtent -> Maybe NodeExtent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CoordinateExtent
nodeExtent'
          Just (ExtentCoordinates CoordinateExtent
ce) ->
            case Maybe (InternalNode n)
parentNode of
              Just InternalNode n
_ -> NodeExtent -> Maybe NodeExtent
forall a. a -> Maybe a
Just (NodeExtent -> Maybe NodeExtent) -> NodeExtent -> Maybe NodeExtent
forall a b. (a -> b) -> a -> b
$ CoordinateExtent -> NodeExtent
ExtentCoordinates (CoordinateExtent -> NodeExtent) -> CoordinateExtent -> NodeExtent
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> CoordinateExtent
CoordinateExtent
                (CoordinateExtent -> Double
extentMinX CoordinateExtent
ce Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
parentX) (CoordinateExtent -> Double
extentMinY CoordinateExtent
ce Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
parentY)
                (CoordinateExtent -> Double
extentMaxX CoordinateExtent
ce Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
parentX) (CoordinateExtent -> Double
extentMaxY CoordinateExtent
ce Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
parentY)
              Maybe (InternalNode n)
Nothing -> NodeExtent -> Maybe NodeExtent
forall a. a -> Maybe a
Just (CoordinateExtent -> NodeExtent
ExtentCoordinates CoordinateExtent
ce)
          Just NodeExtent
ExtentParent -> CoordinateExtent -> NodeExtent
ExtentCoordinates (CoordinateExtent -> NodeExtent)
-> Maybe CoordinateExtent -> Maybe NodeExtent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CoordinateExtent
nodeExtent'
          Maybe NodeExtent
Nothing -> CoordinateExtent -> NodeExtent
ExtentCoordinates (CoordinateExtent -> NodeExtent)
-> Maybe CoordinateExtent -> Maybe NodeExtent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CoordinateExtent
nodeExtent'
      measuredDims = Double -> Double -> Dimensions
Dimensions
        (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Measured -> Maybe Double
measuredWidth (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n)))
        (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Measured -> Maybe Double
measuredHeight (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n)))
      positionAbsolute =
        case Maybe NodeExtent
extent of
          Just (ExtentCoordinates CoordinateExtent
ce) -> XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition XYPosition
nextPosition CoordinateExtent
ce Dimensions
measuredDims
          Maybe NodeExtent
_ -> XYPosition
nextPosition
      mw = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Measured -> Maybe Double
measuredWidth (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n))
      mh = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Measured -> Maybe Double
measuredHeight (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n))
  pure
    ( XYPosition
        (xyX positionAbsolute - parentX + mw * ox)
        (xyY positionAbsolute - parentY + mh * oy)
    , positionAbsolute
    )
-----------------------------------------------------------------------------
-- | Which of the requested nodes and edges may actually be deleted; port
-- of @getElementsToRemove@ (without the async @onBeforeDelete@ hook —
-- run your own check on the result instead).
getElementsToRemove
  :: [NodeId]
  -- ^ nodes to remove
  -> [EdgeId]
  -- ^ edges to remove
  -> [Node n]
  -- ^ all nodes
  -> [Edge e]
  -- ^ all edges
  -> ([Node n], [Edge e])
getElementsToRemove :: forall n e.
[NodeId]
-> [NodeId] -> [Node n] -> [Edge e] -> ([Node n], [Edge e])
getElementsToRemove [NodeId]
nodesToRemove [NodeId]
edgesToRemove [Node n]
nodes [Edge e]
edges =
  ([Node n]
matchingNodes, [Edge e]
matchingEdges)
  where
    nodeIds :: Set NodeId
nodeIds = [NodeId] -> Set NodeId
forall a. Ord a => [a] -> Set a
S.fromList [NodeId]
nodesToRemove
    matchingNodes :: [Node n]
matchingNodes = ([Node n] -> Node n -> [Node n])
-> [Node n] -> [Node n] -> [Node n]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Node n] -> Node n -> [Node n]
forall {n}. [Node n] -> Node n -> [Node n]
step [] [Node n]
nodes
      where
        step :: [Node n] -> Node n -> [Node n]
step [Node n]
acc Node n
n
          | Node n -> Maybe Bool
forall n. Node n -> Maybe Bool
nodeDeletable Node n
n Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False = [Node n]
acc
          | Bool
isIncluded Bool -> Bool -> Bool
|| Bool
parentHit = [Node n]
acc [Node n] -> [Node n] -> [Node n]
forall a. Semigroup a => a -> a -> a
<> [Node n
n]
          | Bool
otherwise = [Node n]
acc
          where
            isIncluded :: Bool
isIncluded = Node n -> NodeId
forall n. Node n -> NodeId
nodeId Node n
n NodeId -> Set NodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NodeId
nodeIds
            parentHit :: Bool
parentHit =
              Bool -> Bool
not Bool
isIncluded Bool -> Bool -> Bool
&&
              case Node n -> Maybe NodeId
forall n. Node n -> Maybe NodeId
nodeParentId Node n
n of
                Maybe NodeId
Nothing -> Bool
False
                Just NodeId
pid -> (Node n -> Bool) -> [Node n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== NodeId
pid) (NodeId -> Bool) -> (Node n -> NodeId) -> Node n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node n -> NodeId
forall n. Node n -> NodeId
nodeId) [Node n]
acc
    edgeIds :: Set NodeId
edgeIds = [NodeId] -> Set NodeId
forall a. Ord a => [a] -> Set a
S.fromList [NodeId]
edgesToRemove
    deletableEdges :: [Edge e]
deletableEdges = [ Edge e
e | Edge e
e <- [Edge e]
edges, Edge e -> Maybe Bool
forall e. Edge e -> Maybe Bool
edgeDeletable Edge e
e Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False ]
    connectedEdges :: [Edge e]
connectedEdges = [Node n] -> [Edge e] -> [Edge e]
forall n e. [Node n] -> [Edge e] -> [Edge e]
getConnectedEdges [Node n]
matchingNodes [Edge e]
deletableEdges
    matchingEdges :: [Edge e]
matchingEdges =
      [Edge e]
connectedEdges [Edge e] -> [Edge e] -> [Edge e]
forall a. Semigroup a => a -> a -> a
<>
      [ Edge e
e | Edge e
e <- [Edge e]
deletableEdges
      , Edge e -> NodeId
forall e. Edge e -> NodeId
edgeId Edge e
e NodeId -> Set NodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set NodeId
edgeIds
      , NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (Edge e -> NodeId
forall e. Edge e -> NodeId
edgeId Edge e
e) ((Edge e -> NodeId) -> [Edge e] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map Edge e -> NodeId
forall e. Edge e -> NodeId
edgeId [Edge e]
connectedEdges)
      ]
-----------------------------------------------------------------------------