-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow.Utils.General
-- License     :  BSD3-style (see the file LICENSE)
--
-- Pure port of @utils\/general.ts@ from @\@xyflow\/system@: clamping,
-- box\/rect algebra, viewport math and @getViewportForBounds@.
----------------------------------------------------------------------------
module Miso.Flow.Utils.General
  ( clamp
  , clampPosition
  , clampPositionToParent
  , calcAutoPanVelocity
  , calcAutoPan
  , getBoundsOfBoxes
  , rectToBox
  , boxToRect
  , nodeToRect
  , internalNodeToRect
  , nodeToBox
  , internalNodeToBox
  , getBoundsOfRects
  , getRectsOverlappingArea
  , getOverlappingArea
  , isNumeric
  , snapPosition
  , pointToRendererPoint
  , rendererPointToPoint
  , parsePadding
  , ParsedPaddings (..)
  , parsePaddings
  , getViewportForBounds
  , getNodeDimensions
  , getInternalNodeDimensions
  , nodeHasDimensions
  , evaluateAbsolutePosition
  ) where
-----------------------------------------------------------------------------
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe)
import           Prelude
-----------------------------------------------------------------------------
import           Miso.Flow.Types
-----------------------------------------------------------------------------
-- | @clamp val min max@.
clamp :: Double -> Double -> Double -> Double
clamp :: Double -> Double -> Double -> Double
clamp Double
val Double
lo Double
hi = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
val Double
lo) Double
hi
-----------------------------------------------------------------------------
-- | Clamp a position into a 'CoordinateExtent', accounting for the
-- element's dimensions.
clampPosition :: XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition :: XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition (XYPosition Double
x Double
y) CoordinateExtent {Double
extentMinX :: Double
extentMinY :: Double
extentMaxX :: Double
extentMaxY :: Double
extentMaxX :: CoordinateExtent -> Double
extentMaxY :: CoordinateExtent -> Double
extentMinX :: CoordinateExtent -> Double
extentMinY :: CoordinateExtent -> Double
..} (Dimensions Double
w Double
h) =
  Double -> Double -> XYPosition
XYPosition
    (Double -> Double -> Double -> Double
clamp Double
x Double
extentMinX (Double
extentMaxX Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
w))
    (Double -> Double -> Double -> Double
clamp Double
y Double
extentMinY (Double
extentMaxY Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
h))
-----------------------------------------------------------------------------
-- | Clamp a child position into the bounds of its parent node.
clampPositionToParent
  :: XYPosition
  -> Dimensions
  -> InternalNode n
  -> XYPosition
clampPositionToParent :: forall n. XYPosition -> Dimensions -> InternalNode n -> XYPosition
clampPositionToParent XYPosition
childPosition Dimensions
childDimensions InternalNode n
parent =
  let Dimensions Double
pw Double
ph = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
parent
      XYPosition Double
px Double
py = InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
parent
  in XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition XYPosition
childPosition
       (Double -> Double -> Double -> Double -> CoordinateExtent
CoordinateExtent Double
px Double
py (Double
px Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
pw) (Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ph))
       Dimensions
childDimensions
-----------------------------------------------------------------------------
-- | Velocity (-1..1) of auto panning when the pointer is close to a pane
-- edge. @calcAutoPanVelocity value min max@.
calcAutoPanVelocity :: Double -> Double -> Double -> Double
calcAutoPanVelocity :: Double -> Double -> Double -> Double
calcAutoPanVelocity Double
value Double
lo Double
hi
  | Double
value Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
lo = Double -> Double -> Double -> Double
clamp (Double -> Double
forall a. Num a => a -> a
abs (Double
value Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
lo)) Double
1 Double
lo Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lo
  | Double
value Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
hi = Double -> Double
forall a. Num a => a -> a
negate (Double -> Double -> Double -> Double
clamp (Double -> Double
forall a. Num a => a -> a
abs (Double
value Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
hi)) Double
1 Double
lo) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lo
  | Bool
otherwise = Double
0
-----------------------------------------------------------------------------
-- | X\/Y auto-pan movement for the given pointer position and pane bounds.
-- Speed defaults to 15, edge distance to 40 in the original.
calcAutoPan
  :: XYPosition
  -- ^ pointer position
  -> Dimensions
  -- ^ pane bounds
  -> Double
  -- ^ speed (original default: 15)
  -> Double
  -- ^ distance (original default: 40)
  -> (Double, Double)
calcAutoPan :: XYPosition -> Dimensions -> Double -> Double -> (Double, Double)
calcAutoPan (XYPosition Double
x Double
y) (Dimensions Double
w Double
h) Double
speed Double
distance =
  ( Double -> Double -> Double -> Double
calcAutoPanVelocity Double
x Double
distance (Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
distance) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
speed
  , Double -> Double -> Double -> Double
calcAutoPanVelocity Double
y Double
distance (Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
distance) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
speed
  )
-----------------------------------------------------------------------------
getBoundsOfBoxes :: Box -> Box -> Box
getBoundsOfBoxes :: Box -> Box -> Box
getBoundsOfBoxes Box
b1 Box
b2 = Box
  { boxX :: Double
boxX  = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Box -> Double
boxX Box
b1) (Box -> Double
boxX Box
b2)
  , boxY :: Double
boxY  = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Box -> Double
boxY Box
b1) (Box -> Double
boxY Box
b2)
  , boxX2 :: Double
boxX2 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Box -> Double
boxX2 Box
b1) (Box -> Double
boxX2 Box
b2)
  , boxY2 :: Double
boxY2 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Box -> Double
boxY2 Box
b1) (Box -> Double
boxY2 Box
b2)
  }
-----------------------------------------------------------------------------
rectToBox :: Rect -> Box
rectToBox :: Rect -> Box
rectToBox (Rect Double
x Double
y Double
w Double
h) = Double -> Double -> Double -> Double -> Box
Box Double
x Double
y (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)
-----------------------------------------------------------------------------
boxToRect :: Box -> Rect
boxToRect :: Box -> Rect
boxToRect (Box Double
x Double
y Double
x2 Double
y2) = Double -> Double -> Double -> Double -> Rect
Rect Double
x Double
y (Double
x2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x) (Double
y2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y)
-----------------------------------------------------------------------------
-- | Bounding rect of a user node (positioned by origin). Port of
-- @nodeToRect@ for the non-internal case.
nodeToRect :: Node n -> NodeOrigin -> Rect
nodeToRect :: forall n. Node n -> NodeOrigin -> Rect
nodeToRect Node n
n NodeOrigin
nodeOrigin' =
  let XYPosition Double
x Double
y = Node n -> NodeOrigin -> XYPosition
forall n. Node n -> NodeOrigin -> XYPosition
getNodePositionWithOriginLocal Node n
n NodeOrigin
nodeOrigin'
      Dimensions Double
w Double
h = Node n -> Dimensions
forall n. Node n -> Dimensions
getNodeDimensions Node n
n
  in Double -> Double -> Double -> Double -> Rect
Rect Double
x Double
y Double
w Double
h
-----------------------------------------------------------------------------
-- | Bounding rect of an internal node (uses @positionAbsolute@). Port of
-- @nodeToRect@ for the internal case.
internalNodeToRect :: InternalNode n -> Rect
internalNodeToRect :: forall n. InternalNode n -> Rect
internalNodeToRect InternalNode n
n =
  let XYPosition Double
x Double
y = InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
n
      Dimensions Double
w Double
h = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
n
  in Double -> Double -> Double -> Double -> Rect
Rect Double
x Double
y Double
w Double
h
-----------------------------------------------------------------------------
nodeToBox :: Node n -> NodeOrigin -> Box
nodeToBox :: forall n. Node n -> NodeOrigin -> Box
nodeToBox Node n
n NodeOrigin
o = Rect -> Box
rectToBox (Node n -> NodeOrigin -> Rect
forall n. Node n -> NodeOrigin -> Rect
nodeToRect Node n
n NodeOrigin
o)
-----------------------------------------------------------------------------
internalNodeToBox :: InternalNode n -> Box
internalNodeToBox :: forall n. InternalNode n -> Box
internalNodeToBox = Rect -> Box
rectToBox (Rect -> Box) -> (InternalNode n -> Rect) -> InternalNode n -> Box
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalNode n -> Rect
forall n. InternalNode n -> Rect
internalNodeToRect
-----------------------------------------------------------------------------
getBoundsOfRects :: Rect -> Rect -> Rect
getBoundsOfRects :: Rect -> Rect -> Rect
getBoundsOfRects Rect
r1 Rect
r2 = Box -> Rect
boxToRect (Box -> Box -> Box
getBoundsOfBoxes (Rect -> Box
rectToBox Rect
r1) (Rect -> Box
rectToBox Rect
r2))
-----------------------------------------------------------------------------
getRectsOverlappingArea
  :: Double -> Double -> Double -> Double
  -> Double -> Double -> Double -> Double
  -> Double
getRectsOverlappingArea :: Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
getRectsOverlappingArea Double
aX Double
aY Double
aWidth Double
aHeight Double
bX Double
bY Double
bWidth Double
bHeight =
  let xOverlap :: Double
xOverlap = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double
aX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
aWidth) (Double
bX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bWidth) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
aX Double
bX)
      yOverlap :: Double
yOverlap = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double
aY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
aHeight) (Double
bY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bHeight) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
aY Double
bY)
  in Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double
xOverlap Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
yOverlap) :: Integer)
-----------------------------------------------------------------------------
getOverlappingArea :: Rect -> Rect -> Double
getOverlappingArea :: Rect -> Rect -> Double
getOverlappingArea (Rect Double
ax Double
ay Double
aw Double
ah) (Rect Double
bx Double
by Double
bw Double
bh) =
  Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
getRectsOverlappingArea Double
ax Double
ay Double
aw Double
ah Double
bx Double
by Double
bw Double
bh
-----------------------------------------------------------------------------
-- | JS @isNumeric@: finite and not NaN.
isNumeric :: Double -> Bool
isNumeric :: Double -> Bool
isNumeric Double
n = Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
n) Bool -> Bool -> Bool
&& Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
n)
-----------------------------------------------------------------------------
snapPosition :: XYPosition -> SnapGrid -> XYPosition
snapPosition :: XYPosition -> SnapGrid -> XYPosition
snapPosition (XYPosition Double
x Double
y) (SnapGrid Double
gx Double
gy) = Double -> Double -> XYPosition
XYPosition
  (Double
gx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
jsRound (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
gx))
  (Double
gy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
jsRound (Double
y Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
gy))
-----------------------------------------------------------------------------
-- | @Math.round@: half-up (towards +Infinity), unlike Haskell's
-- banker's rounding.
jsRound :: Double -> Double
jsRound :: Double -> Double
jsRound Double
v = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5) :: Integer)
-----------------------------------------------------------------------------
-- | Screen point → flow point, optionally snapped to grid.
pointToRendererPoint
  :: XYPosition
  -> Transform
  -> Bool
  -- ^ snap to grid
  -> SnapGrid
  -> XYPosition
pointToRendererPoint :: XYPosition -> Transform -> Bool -> SnapGrid -> XYPosition
pointToRendererPoint (XYPosition Double
x Double
y) (Viewport Double
tx Double
ty Double
tScale) Bool
snapToGrid SnapGrid
snapGrid =
  let position :: XYPosition
position = Double -> Double -> XYPosition
XYPosition ((Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
tx) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale) ((Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ty) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tScale)
  in if Bool
snapToGrid then XYPosition -> SnapGrid -> XYPosition
snapPosition XYPosition
position SnapGrid
snapGrid else XYPosition
position
-----------------------------------------------------------------------------
-- | Flow point → screen point.
rendererPointToPoint :: XYPosition -> Transform -> XYPosition
rendererPointToPoint :: XYPosition -> Transform -> XYPosition
rendererPointToPoint (XYPosition Double
x Double
y) (Viewport Double
tx Double
ty Double
tScale) =
  Double -> Double -> XYPosition
XYPosition (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
tScale Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tx) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
tScale Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ty)
-----------------------------------------------------------------------------
-- | Resolve a single padding value to pixels; @parsePadding padding viewport@
-- where @viewport@ is the relevant viewport dimension.
parsePadding :: PaddingWithUnit -> Double -> Double
parsePadding :: PaddingWithUnit -> Double -> Double
parsePadding PaddingWithUnit
p Double
viewport =
  case PaddingWithUnit
p of
    PaddingRatio Double
r ->
      Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Double
viewport Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
viewport Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.5) :: Integer)
    PaddingPx Double
v -> Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
v :: Integer)
    PaddingPercent Double
v -> Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
viewport Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.01) :: Integer)
-----------------------------------------------------------------------------
data ParsedPaddings = ParsedPaddings
  { ParsedPaddings -> Double
ppTop    :: !Double
  , ParsedPaddings -> Double
ppRight  :: !Double
  , ParsedPaddings -> Double
ppBottom :: !Double
  , ParsedPaddings -> Double
ppLeft   :: !Double
  , ParsedPaddings -> Double
ppX      :: !Double
  , ParsedPaddings -> Double
ppY      :: !Double
  } deriving (Int -> ParsedPaddings -> ShowS
[ParsedPaddings] -> ShowS
ParsedPaddings -> String
(Int -> ParsedPaddings -> ShowS)
-> (ParsedPaddings -> String)
-> ([ParsedPaddings] -> ShowS)
-> Show ParsedPaddings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParsedPaddings -> ShowS
showsPrec :: Int -> ParsedPaddings -> ShowS
$cshow :: ParsedPaddings -> String
show :: ParsedPaddings -> String
$cshowList :: [ParsedPaddings] -> ShowS
showList :: [ParsedPaddings] -> ShowS
Show, ParsedPaddings -> ParsedPaddings -> Bool
(ParsedPaddings -> ParsedPaddings -> Bool)
-> (ParsedPaddings -> ParsedPaddings -> Bool) -> Eq ParsedPaddings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParsedPaddings -> ParsedPaddings -> Bool
== :: ParsedPaddings -> ParsedPaddings -> Bool
$c/= :: ParsedPaddings -> ParsedPaddings -> Bool
/= :: ParsedPaddings -> ParsedPaddings -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Resolve a 'Padding' to per-side pixel values for the given viewport
-- width and height.
parsePaddings :: Padding -> Double -> Double -> ParsedPaddings
parsePaddings :: Padding -> Double -> Double -> ParsedPaddings
parsePaddings Padding
padding Double
width Double
height =
  case Padding
padding of
    PaddingUniform PaddingWithUnit
p ->
      let py :: Double
py = PaddingWithUnit -> Double -> Double
parsePadding PaddingWithUnit
p Double
height
          px :: Double
px = PaddingWithUnit -> Double -> Double
parsePadding PaddingWithUnit
p Double
width
      in Double
-> Double -> Double -> Double -> Double -> Double -> ParsedPaddings
ParsedPaddings Double
py Double
px Double
py Double
px (Double
px Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2) (Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2)
    PaddingSides {Maybe PaddingWithUnit
paddingTop :: Maybe PaddingWithUnit
paddingRight :: Maybe PaddingWithUnit
paddingBottom :: Maybe PaddingWithUnit
paddingLeft :: Maybe PaddingWithUnit
paddingX :: Maybe PaddingWithUnit
paddingY :: Maybe PaddingWithUnit
paddingBottom :: Padding -> Maybe PaddingWithUnit
paddingLeft :: Padding -> Maybe PaddingWithUnit
paddingRight :: Padding -> Maybe PaddingWithUnit
paddingTop :: Padding -> Maybe PaddingWithUnit
paddingX :: Padding -> Maybe PaddingWithUnit
paddingY :: Padding -> Maybe PaddingWithUnit
..} ->
      let zero :: PaddingWithUnit
zero = Double -> PaddingWithUnit
PaddingRatio Double
0
          top :: Double
top = PaddingWithUnit -> Double -> Double
parsePadding (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe PaddingWithUnit
zero Maybe PaddingWithUnit
paddingY) Maybe PaddingWithUnit
paddingTop) Double
height
          bottom :: Double
bottom = PaddingWithUnit -> Double -> Double
parsePadding (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe PaddingWithUnit
zero Maybe PaddingWithUnit
paddingY) Maybe PaddingWithUnit
paddingBottom) Double
height
          left :: Double
left = PaddingWithUnit -> Double -> Double
parsePadding (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe PaddingWithUnit
zero Maybe PaddingWithUnit
paddingX) Maybe PaddingWithUnit
paddingLeft) Double
width
          right :: Double
right = PaddingWithUnit -> Double -> Double
parsePadding (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe (PaddingWithUnit -> Maybe PaddingWithUnit -> PaddingWithUnit
forall a. a -> Maybe a -> a
fromMaybe PaddingWithUnit
zero Maybe PaddingWithUnit
paddingX) Maybe PaddingWithUnit
paddingRight) Double
width
      in Double
-> Double -> Double -> Double -> Double -> Double -> ParsedPaddings
ParsedPaddings Double
top Double
right Double
bottom Double
left (Double
left Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
right) (Double
top Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bottom)
-----------------------------------------------------------------------------
-- | Minimum padding that remains around @bounds@ if the viewport
-- @(x, y, zoom)@ is applied; port of @calculateAppliedPaddings@.
calculateAppliedPaddings
  :: Rect -> Double -> Double -> Double -> Double -> Double
  -> ParsedPaddings
calculateAppliedPaddings :: Rect
-> Double -> Double -> Double -> Double -> Double -> ParsedPaddings
calculateAppliedPaddings Rect
bounds Double
x Double
y Double
zoom Double
width Double
height =
  let vp :: Transform
vp = Double -> Double -> Double -> Transform
Viewport Double
x Double
y Double
zoom
      XYPosition Double
left Double
top =
        XYPosition -> Transform -> XYPosition
rendererPointToPoint (Double -> Double -> XYPosition
XYPosition (Rect -> Double
rectX Rect
bounds) (Rect -> Double
rectY Rect
bounds)) Transform
vp
      XYPosition Double
boundRight Double
boundBottom =
        XYPosition -> Transform -> XYPosition
rendererPointToPoint
          (Double -> Double -> XYPosition
XYPosition (Rect -> Double
rectX Rect
bounds Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Rect -> Double
rectWidth Rect
bounds)
                      (Rect -> Double
rectY Rect
bounds Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Rect -> Double
rectHeight Rect
bounds)) Transform
vp
      right :: Double
right = Double
width Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
boundRight
      bottom :: Double
bottom = Double
height Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
boundBottom
      f :: a -> b
f a
v = Integer -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Integer
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor a
v :: Integer)
  in Double
-> Double -> Double -> Double -> Double -> Double -> ParsedPaddings
ParsedPaddings (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
top) (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
right) (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
bottom) (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
left)
       (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
left Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
right) (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
top Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
f Double
bottom)
-----------------------------------------------------------------------------
-- | Viewport that encloses the given bounds with padding; port of
-- @getViewportForBounds@.
getViewportForBounds
  :: Rect
  -- ^ bounds to fit
  -> Double
  -- ^ viewport width
  -> Double
  -- ^ viewport height
  -> Double
  -- ^ min zoom
  -> Double
  -- ^ max zoom
  -> Padding
  -> Viewport
getViewportForBounds :: Rect
-> Double -> Double -> Double -> Double -> Padding -> Transform
getViewportForBounds Rect
bounds Double
width Double
height Double
minZoom Double
maxZoom Padding
padding =
  let p :: ParsedPaddings
p = Padding -> Double -> Double -> ParsedPaddings
parsePaddings Padding
padding Double
width Double
height
      xZoom :: Double
xZoom = (Double
width Double -> Double -> Double
forall a. Num a => a -> a -> a
- ParsedPaddings -> Double
ppX ParsedPaddings
p) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Rect -> Double
rectWidth Rect
bounds
      yZoom :: Double
yZoom = (Double
height Double -> Double -> Double
forall a. Num a => a -> a -> a
- ParsedPaddings -> Double
ppY ParsedPaddings
p) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Rect -> Double
rectHeight Rect
bounds
      zoom :: Double
zoom = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
xZoom Double
yZoom
      clampedZoom :: Double
clampedZoom = Double -> Double -> Double -> Double
clamp Double
zoom Double
minZoom Double
maxZoom
      boundsCenterX :: Double
boundsCenterX = Rect -> Double
rectX Rect
bounds Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Rect -> Double
rectWidth Rect
bounds Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
      boundsCenterY :: Double
boundsCenterY = Rect -> Double
rectY Rect
bounds Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Rect -> Double
rectHeight Rect
bounds Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
      x :: Double
x = Double
width Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
boundsCenterX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
clampedZoom
      y :: Double
y = Double
height Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
boundsCenterY Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
clampedZoom
      newPadding :: ParsedPaddings
newPadding = Rect
-> Double -> Double -> Double -> Double -> Double -> ParsedPaddings
calculateAppliedPaddings Rect
bounds Double
x Double
y Double
clampedZoom Double
width Double
height
      offLeft :: Double
offLeft = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (ParsedPaddings -> Double
ppLeft ParsedPaddings
newPadding Double -> Double -> Double
forall a. Num a => a -> a -> a
- ParsedPaddings -> Double
ppLeft ParsedPaddings
p) Double
0
      offTop :: Double
offTop = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (ParsedPaddings -> Double
ppTop ParsedPaddings
newPadding Double -> Double -> Double
forall a. Num a => a -> a -> a
- ParsedPaddings -> Double
ppTop ParsedPaddings
p) Double
0
      offRight :: Double
offRight = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (ParsedPaddings -> Double
ppRight ParsedPaddings
newPadding Double -> Double -> Double
forall a. Num a => a -> a -> a
- ParsedPaddings -> Double
ppRight ParsedPaddings
p) Double
0
      offBottom :: Double
offBottom = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (ParsedPaddings -> Double
ppBottom ParsedPaddings
newPadding Double -> Double -> Double
forall a. Num a => a -> a -> a
- ParsedPaddings -> Double
ppBottom ParsedPaddings
p) Double
0
  in Viewport
      { viewportX :: Double
viewportX = Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
offLeft Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offRight
      , viewportY :: Double
viewportY = Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
offTop Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offBottom
      , viewportZoom :: Double
viewportZoom = Double
clampedZoom
      }
-----------------------------------------------------------------------------
-- | @measured.width ?? width ?? initialWidth ?? 0@ (and same for height).
getNodeDimensions :: Node n -> Dimensions
getNodeDimensions :: forall n. Node n -> Dimensions
getNodeDimensions Node n
n = Double -> Double -> Dimensions
Dimensions
  (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 ([Maybe Double] -> Maybe Double
forall a. [Maybe a] -> Maybe a
firstJust [Measured -> Maybe Double
measuredWidth (Measured -> Maybe Double) -> Maybe Measured -> Maybe Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node n -> Maybe Measured
forall n. Node n -> Maybe Measured
nodeMeasured Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeWidth Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeInitialWidth Node n
n]))
  (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 ([Maybe Double] -> Maybe Double
forall a. [Maybe a] -> Maybe a
firstJust [Measured -> Maybe Double
measuredHeight (Measured -> Maybe Double) -> Maybe Measured -> Maybe Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node n -> Maybe Measured
forall n. Node n -> Maybe Measured
nodeMeasured Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeHeight Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeInitialHeight Node n
n]))
-----------------------------------------------------------------------------
-- | 'getNodeDimensions' with the internal @measured@ taking precedence.
getInternalNodeDimensions :: InternalNode n -> Dimensions
getInternalNodeDimensions :: forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
n = Double -> Double -> Dimensions
Dimensions
  (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 ([Maybe Double] -> Maybe Double
forall a. [Maybe a] -> Maybe a
firstJust
    [ Measured -> Maybe Double
measuredWidth (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n)
    , Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeWidth Node n
u, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeInitialWidth Node n
u ]))
  (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 ([Maybe Double] -> Maybe Double
forall a. [Maybe a] -> Maybe a
firstJust
    [ Measured -> Maybe Double
measuredHeight (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
n)
    , Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeHeight Node n
u, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeInitialHeight Node n
u ]))
  where u :: Node n
u = InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n
-----------------------------------------------------------------------------
nodeHasDimensions :: Node n -> Bool
nodeHasDimensions :: forall n. Node n -> Bool
nodeHasDimensions Node n
n =
  [Maybe Double] -> Bool
hasJust [Measured -> Maybe Double
measuredWidth (Measured -> Maybe Double) -> Maybe Measured -> Maybe Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node n -> Maybe Measured
forall n. Node n -> Maybe Measured
nodeMeasured Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeWidth Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeInitialWidth Node n
n]
  Bool -> Bool -> Bool
&& [Maybe Double] -> Bool
hasJust [Measured -> Maybe Double
measuredHeight (Measured -> Maybe Double) -> Maybe Measured -> Maybe Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node n -> Maybe Measured
forall n. Node n -> Maybe Measured
nodeMeasured Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeHeight Node n
n, Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeInitialHeight Node n
n]
  where hasJust :: [Maybe Double] -> Bool
hasJust = (Maybe Double -> Bool) -> [Maybe Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Double
forall a. Maybe a
Nothing)
-----------------------------------------------------------------------------
-- | Convert a child position to an absolute position; port of
-- @evaluateAbsolutePosition@.
evaluateAbsolutePosition
  :: XYPosition
  -> Maybe Dimensions
  -- ^ dimensions (defaults to 0x0)
  -> NodeId
  -- ^ parent id
  -> NodeLookup n
  -> NodeOrigin
  -> XYPosition
evaluateAbsolutePosition :: forall n.
XYPosition
-> Maybe Dimensions
-> NodeId
-> NodeLookup n
-> NodeOrigin
-> XYPosition
evaluateAbsolutePosition XYPosition
position Maybe Dimensions
dims NodeId
parentId NodeLookup n
nodeLookup NodeOrigin
nodeOrigin' =
  case NodeId -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeId
parentId NodeLookup n
nodeLookup of
    Maybe (InternalNode n)
Nothing -> XYPosition
position
    Just InternalNode n
parent ->
      let 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 (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
parent))
          Dimensions Double
w Double
h = Dimensions -> Maybe Dimensions -> Dimensions
forall a. a -> Maybe a -> a
fromMaybe Dimensions
zeroDimensions Maybe Dimensions
dims
          XYPosition Double
px Double
py = InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
parent
      in Double -> Double -> XYPosition
XYPosition
           (XYPosition -> Double
xyX XYPosition
position Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
px 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 XYPosition
position Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
oy)
-----------------------------------------------------------------------------
-- | Position of a node adjusted by its origin; local copy to avoid a
-- module cycle with "Miso.Flow.Utils.Graph" (which re-exports the public
-- version).
getNodePositionWithOriginLocal :: Node n -> NodeOrigin -> XYPosition
getNodePositionWithOriginLocal :: forall n. Node n -> NodeOrigin -> XYPosition
getNodePositionWithOriginLocal 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)
-----------------------------------------------------------------------------
firstJust :: [Maybe a] -> Maybe a
firstJust :: forall a. [Maybe a] -> Maybe a
firstJust = (Maybe a -> Maybe a -> Maybe a) -> Maybe a -> [Maybe a] -> Maybe a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Maybe a
m Maybe a
acc -> Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
acc a -> Maybe a
forall a. a -> Maybe a
Just Maybe a
m) Maybe a
forall a. Maybe a
Nothing
-----------------------------------------------------------------------------