{-# LANGUAGE DataKinds #-}

-- | Floating window input: dragging by the title bar, edge and inner-east
-- resizing, the resize cursor, and persisting window placement.
module NanoUI.Frame.Window
  ( contextMeasurers
  , lookupWindowPos
  , lookupWindowSize
  , persistWindowPositions
  , updateWindowDrag
  , updateWindowResize
  , WindowResizeEdge (..)
  , windowResizeCursorKind
  ) where

import Control.Monad (when)
import qualified Data.IntMap.Strict as IM
import Data.Maybe (fromMaybe, isJust)
import NanoUI.Context
  ( Context (..)
  , WidgetStore (..)
  , WindowResizeDrag (..)
  , WindowResizeEdge (..)
  , damageWidget
  , getStore
  , getWindowDrag
  , getWindowResize
  , intKey
  , markDirty
  , setStore
  , slotKey
  , Slot (..)
  , InteractionState (..)
  , modifyInteraction
  , lookupCustomMeasure
  )
import NanoUI.Font (ScrollBarSlot (..))
import NanoUI.Frame.Hit (findNodeByWidgetId, nodeInSubtree, topmostOverlayAtMouse)
import NanoUI.Frame.Input (findTopWidgetUnderMouse, isInteractiveNode)
import NanoUI.Frame.Redraw (probeHotId)
import NanoUI.Frame.Scroll.Geometry (scrollChromeLane)
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input (Input (..), UiCursorKind (..), inputMouseDown, inputMousePos, inputMousePressed)
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (..)
  , findChildM
  , findNodeRevM
  , foldNodesM
  , getDirection
  , getFirstChild
  , getMinMax
  , getNextSibling
  , getNodeType
  , getNodeValue
  , getPadding
  , getRect
  , getWidgetId
  )
import NanoUI.Layout.Solve (Measurers (..), placeWindowNode, scrollBarSlotOf)
import NanoUI.Style (Padding (..))
import NanoUI.Types (DamageBounds (..), Rect (..), V2 (..), haloDamageSlop, rectContains, rectInflate)

topmostWindowAtResizeHalo :: Context -> V2 -> IO (Maybe NodeIdx)
topmostWindowAtResizeHalo :: Context -> V2 -> IO (Maybe NodeIdx)
topmostWindowAtResizeHalo Context
ctx V2
mouse =
  NodeArena -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findNodeRevM (Context -> NodeArena
ctxNodeArena Context
ctx) ((NodeIdx -> IO Bool) -> IO (Maybe NodeIdx))
-> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
forall a b. (a -> b) -> a -> b
$ \NodeIdx
idx -> do
    nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
    if nt /= NodeWindow
      then pure False
      else do
        (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
        if w <= 0 || h <= 0
          then pure False
          else do
            let rect = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
            if rectContains (rectInflate windowResizeHandleFor rect) mouse
              then pure True
              else windowInnerEastResizeHit ctx idx rect mouse

windowInnerEastResizeHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool
windowInnerEastResizeHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool
windowInnerEastResizeHit Context
ctx NodeIdx
winIdx (Rect Float
x Float
_ Float
w Float
_) mouse :: V2
mouse@(V2 Float
mx Float
_) = do
  pad <- NodeArena -> NodeIdx -> IO Padding
getPadding (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
winIdx
  if mx < x + w - padR pad || mx > x + w
    then pure False
    else do
      mLane <- windowBodyScrollLane ctx winIdx
      pure (not (maybe False (`rectContains` mouse) mLane))

lookupWindowPos :: Context -> WidgetId -> IO (Maybe (Float, Float))
lookupWindowPos :: Context -> WidgetId -> IO (Maybe (Float, Float))
lookupWindowPos Context
ctx WidgetId
wid = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  pure (IM.lookup (intKey wid) (storePoint store))

lookupWindowSize :: Context -> WidgetId -> IO (Maybe (Float, Float))
lookupWindowSize :: Context -> WidgetId -> IO (Maybe (Float, Float))
lookupWindowSize Context
ctx WidgetId
wid = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  pure (IM.lookup (slotKey SlotWinSize (intKey wid)) (storePoint store))

persistWindowPositions :: Context -> IO ()
persistWindowPositions :: Context -> IO ()
persistWindowPositions Context
ctx = do
  store0 <- Context -> IO WidgetStore
getStore Context
ctx
  let na = Context -> NodeArena
ctxNodeArena Context
ctx
      record WidgetStore
acc NodeIdx
idx = do
        nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
idx
        if nt /= NodeWindow
          then pure acc
          else do
            wid <- getWidgetId na idx
            (x, y, w, h) <- getRect na idx
            let k = WidgetId -> NodeIdx
intKey WidgetId
wid
                sizeKey = Slot -> NodeIdx -> NodeIdx
slotKey Slot
SlotWinSize NodeIdx
k
                points = WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
acc
            -- Keep an unchanged map as is, so the store comparison below
            -- short-circuits on pointer equality.
            pure $
              if IM.lookup k points == Just (x, y) && IM.lookup sizeKey points == Just (w, h)
                then acc
                else acc {storePoint = IM.insert k (x, y) (IM.insert sizeKey (w, h) points)}
  store1 <- foldNodesM na record store0
  when (store1 /= store0) $ setStore ctx store1

updateWindowDrag :: Context -> Input -> IO Bool
updateWindowDrag :: Context -> Input -> IO Bool
updateWindowDrag Context
ctx Input
inp = do
  resizing <- Maybe WindowResizeDrag -> Bool
forall a. Maybe a -> Bool
isJust (Maybe WindowResizeDrag -> Bool)
-> IO (Maybe WindowResizeDrag) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO (Maybe WindowResizeDrag)
getWindowResize Context
ctx
  if resizing
    then pure False
    else do
      drag <- getWindowDrag ctx
      case drag of
        Just (WidgetId
wid, Float
gx, Float
gy)
          | Input -> Bool
inputMouseDown Input
inp -> do
              let V2 Float
mx Float
my = Input -> V2
inputMousePos Input
inp
              store <- Context -> IO WidgetStore
getStore Context
ctx
              setStore ctx (store {storePoint = IM.insert (intKey wid) (mx - gx, my - gy) (storePoint store)})
              damageWidget ctx wid (DamageInflated haloDamageSlop)
              markDirty ctx
              pure True
          | Bool
otherwise -> do
              Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isWindowDrag = Nothing})
              Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Maybe (WidgetId, Float, Float)
Nothing
          | Input -> Bool
inputMousePressed Input
inp -> Context -> V2 -> IO Bool
tryStartWindowDrag Context
ctx (Input -> V2
inputMousePos Input
inp)
          | Bool
otherwise -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

windowResizeHandleFor :: Float
windowResizeHandleFor :: Float
windowResizeHandleFor = Float
12

-- Handles sit outside the window. The right pad strip also resizes beside the bar.
windowResizeEdgeAt :: Rect -> V2 -> Maybe WindowResizeEdge
windowResizeEdgeAt :: Rect -> V2 -> Maybe WindowResizeEdge
windowResizeEdgeAt (Rect Float
x Float
y Float
w Float
h) (V2 Float
mx Float
my) =
  let s :: Float
s = Float
windowResizeHandleFor
      onL :: Bool
onL = Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s Bool -> Bool -> Bool
&& Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
x
      onR :: Bool
onR = Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Bool -> Bool -> Bool
&& Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s
      onT :: Bool
onT = Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
y
      onB :: Bool
onB = Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
s
   in if Bool -> Bool
not (Bool
onL Bool -> Bool -> Bool
|| Bool
onR Bool -> Bool -> Bool
|| Bool
onT Bool -> Bool -> Bool
|| Bool
onB)
        then Maybe WindowResizeEdge
forall a. Maybe a
Nothing
        else
          WindowResizeEdge -> Maybe WindowResizeEdge
forall a. a -> Maybe a
Just (WindowResizeEdge -> Maybe WindowResizeEdge)
-> WindowResizeEdge -> Maybe WindowResizeEdge
forall a b. (a -> b) -> a -> b
$
            case (Bool
onT, Bool
onB, Bool
onL, Bool
onR) of
              (Bool
True, Bool
_, Bool
True, Bool
_) -> WindowResizeEdge
ResizeNW
              (Bool
True, Bool
_, Bool
_, Bool
True) -> WindowResizeEdge
ResizeNE
              (Bool
_, Bool
True, Bool
True, Bool
_) -> WindowResizeEdge
ResizeSW
              (Bool
_, Bool
True, Bool
_, Bool
True) -> WindowResizeEdge
ResizeSE
              (Bool
True, Bool
_, Bool
_, Bool
_) -> WindowResizeEdge
ResizeN
              (Bool
_, Bool
True, Bool
_, Bool
_) -> WindowResizeEdge
ResizeS
              (Bool
_, Bool
_, Bool
True, Bool
_) -> WindowResizeEdge
ResizeW
              (Bool, Bool, Bool, Bool)
_ -> WindowResizeEdge
ResizeE

innerEastCornerEdge :: Padding -> Rect -> Float -> WindowResizeEdge
innerEastCornerEdge :: Padding -> Rect -> Float -> WindowResizeEdge
innerEastCornerEdge Padding
pad (Rect Float
_ Float
y Float
_ Float
h) Float
my =
  let s :: Float
s = Float
windowResizeHandleFor
      minBand :: Float
minBand = Float
6
      topBand :: Float
topBand = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minBand (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
s (Padding -> Float
padT Padding
pad))
      botBand :: Float
botBand = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minBand (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
s (Padding -> Float
padB Padding
pad))
   in if Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
y Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
topBand
        then WindowResizeEdge
ResizeNE
        else if Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
botBand Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h then WindowResizeEdge
ResizeSE else WindowResizeEdge
ResizeE

-- | Lane of the window body's scrollbar while its content overflows.
windowBodyScrollLane :: Context -> NodeIdx -> IO (Maybe Rect)
windowBodyScrollLane :: Context -> NodeIdx -> IO (Maybe Rect)
windowBodyScrollLane Context
ctx NodeIdx
winIdx = do
  let na :: NodeArena
na = Context -> NodeArena
ctxNodeArena Context
ctx
  mBody <-
    NodeArena -> NodeIdx -> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
findChildM NodeArena
na NodeIdx
winIdx ((NodeIdx -> IO Bool) -> IO (Maybe NodeIdx))
-> (NodeIdx -> IO Bool) -> IO (Maybe NodeIdx)
forall a b. (a -> b) -> a -> b
$ \NodeIdx
ci -> do
      nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType NodeArena
na NodeIdx
ci
      if nt /= NodeScrollContainer
        then pure False
        else do
          slot <- scrollBarSlotOf na ci
          if slot /= ScrollBarWindow
            then pure False
            else do
              (_, _, _, h) <- getRect na ci
              pad <- getPadding na ci
              contentSize <- getNodeValue na ci
              pure (contentSize > h - padT pad - padB pad)
  traverse
    ( \NodeIdx
ci -> do
        (x, y, w, h) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect NodeArena
na NodeIdx
ci
        pad <- getPadding na ci
        dir <- getDirection na ci
        pure (scrollChromeLane ScrollBarWindow dir x y w h pad)
    )
    mBody

windowInnerResizeEdgeAt :: Context -> NodeIdx -> Rect -> V2 -> IO (Maybe WindowResizeEdge)
windowInnerResizeEdgeAt :: Context -> NodeIdx -> Rect -> V2 -> IO (Maybe WindowResizeEdge)
windowInnerResizeEdgeAt Context
ctx NodeIdx
winIdx winRect :: Rect
winRect@(Rect Float
x Float
y Float
w Float
h) mouse :: V2
mouse@(V2 Float
mx Float
my) = do
  hit <- Context -> NodeIdx -> Rect -> V2 -> IO Bool
windowInnerEastResizeHit Context
ctx NodeIdx
winIdx Rect
winRect V2
mouse
  if hit
    then do
      pad <- getPadding (ctxNodeArena ctx) winIdx
      pure (Just (innerEastCornerEdge pad winRect my))
    else do
      let cornerW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
16 (Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3)
          cornerH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
16 (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3)
          botH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
6 (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
3)
          inBotRightCorner = Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cornerW Bool -> Bool -> Bool
&& Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cornerH Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h
          inBotEdge = Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
x Bool -> Bool -> Bool
&& Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
botH Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h
      pure $
        if inBotRightCorner
          then Just ResizeSE
          else if inBotEdge then Just ResizeS else Nothing

windowResizeEdgeFor :: Context -> NodeIdx -> Rect -> V2 -> IO (Maybe WindowResizeEdge)
windowResizeEdgeFor :: Context -> NodeIdx -> Rect -> V2 -> IO (Maybe WindowResizeEdge)
windowResizeEdgeFor Context
ctx NodeIdx
winIdx Rect
winRect V2
mouse =
  case Rect -> V2 -> Maybe WindowResizeEdge
windowResizeEdgeAt Rect
winRect V2
mouse of
    Just WindowResizeEdge
edge -> Maybe WindowResizeEdge -> IO (Maybe WindowResizeEdge)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WindowResizeEdge -> Maybe WindowResizeEdge
forall a. a -> Maybe a
Just WindowResizeEdge
edge)
    Maybe WindowResizeEdge
Nothing -> Context -> NodeIdx -> Rect -> V2 -> IO (Maybe WindowResizeEdge)
windowInnerResizeEdgeAt Context
ctx NodeIdx
winIdx Rect
winRect V2
mouse

cursorForResizeEdge :: WindowResizeEdge -> UiCursorKind
cursorForResizeEdge :: WindowResizeEdge -> UiCursorKind
cursorForResizeEdge = \case
  WindowResizeEdge
ResizeN -> UiCursorKind
UiCursorNsResize
  WindowResizeEdge
ResizeS -> UiCursorKind
UiCursorNsResize
  WindowResizeEdge
ResizeE -> UiCursorKind
UiCursorEwResize
  WindowResizeEdge
ResizeW -> UiCursorKind
UiCursorEwResize
  WindowResizeEdge
ResizeNW -> UiCursorKind
UiCursorNwseResize
  WindowResizeEdge
ResizeSE -> UiCursorKind
UiCursorNwseResize
  WindowResizeEdge
ResizeNE -> UiCursorKind
UiCursorNeswResize
  WindowResizeEdge
ResizeSW -> UiCursorKind
UiCursorNeswResize

resizeFromEdge :: WindowResizeDrag -> V2 -> Float -> Float -> (Float, Float, Float, Float)
resizeFromEdge :: WindowResizeDrag
-> V2 -> Float -> Float -> (Float, Float, Float, Float)
resizeFromEdge WindowResizeDrag
wrd (V2 Float
mx Float
my) Float
winW Float
winH =
  let !dx :: Float
dx = Float
mx Float -> Float -> Float
forall a. Num a => a -> a -> a
- WindowResizeDrag -> Float
wrdGrabX WindowResizeDrag
wrd
      !dy :: Float
dy = Float
my Float -> Float -> Float
forall a. Num a => a -> a -> a
- WindowResizeDrag -> Float
wrdGrabY WindowResizeDrag
wrd
      !minW :: Float
minW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (WindowResizeDrag -> Float
wrdMinW WindowResizeDrag
wrd) Float
1.0
      !minH :: Float
minH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (WindowResizeDrag -> Float
wrdMinH WindowResizeDrag
wrd) Float
1.0
      !maxW :: Float
maxW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (WindowResizeDrag -> Float
wrdMaxW WindowResizeDrag
wrd) Float
winW
      !maxH :: Float
maxH = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (WindowResizeDrag -> Float
wrdMaxH WindowResizeDrag
wrd) Float
winH
      !right0 :: Float
right0 = WindowResizeDrag -> Float
wrdStartX WindowResizeDrag
wrd Float -> Float -> Float
forall a. Num a => a -> a -> a
+ WindowResizeDrag -> Float
wrdStartW WindowResizeDrag
wrd
      !bottom0 :: Float
bottom0 = WindowResizeDrag -> Float
wrdStartY WindowResizeDrag
wrd Float -> Float -> Float
forall a. Num a => a -> a -> a
+ WindowResizeDrag -> Float
wrdStartH WindowResizeDrag
wrd
      edge :: WindowResizeEdge
edge = WindowResizeDrag -> WindowResizeEdge
wrdEdge WindowResizeDrag
wrd
      !fromE :: Bool
fromE = WindowResizeEdge
edge WindowResizeEdge -> [WindowResizeEdge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WindowResizeEdge
ResizeE, WindowResizeEdge
ResizeNE, WindowResizeEdge
ResizeSE]
      !fromW :: Bool
fromW = WindowResizeEdge
edge WindowResizeEdge -> [WindowResizeEdge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WindowResizeEdge
ResizeW, WindowResizeEdge
ResizeNW, WindowResizeEdge
ResizeSW]
      !fromS :: Bool
fromS = WindowResizeEdge
edge WindowResizeEdge -> [WindowResizeEdge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WindowResizeEdge
ResizeS, WindowResizeEdge
ResizeSE, WindowResizeEdge
ResizeSW]
      !fromN :: Bool
fromN = WindowResizeEdge
edge WindowResizeEdge -> [WindowResizeEdge] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WindowResizeEdge
ResizeN, WindowResizeEdge
ResizeNE, WindowResizeEdge
ResizeNW]
      !w0 :: Float
w0
        | Bool
fromE = WindowResizeDrag -> Float
wrdStartW WindowResizeDrag
wrd Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dx
        | Bool
fromW = WindowResizeDrag -> Float
wrdStartW WindowResizeDrag
wrd Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dx
        | Bool
otherwise = WindowResizeDrag -> Float
wrdStartW WindowResizeDrag
wrd
      !h0 :: Float
h0
        | Bool
fromS = WindowResizeDrag -> Float
wrdStartH WindowResizeDrag
wrd Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dy
        | Bool
fromN = WindowResizeDrag -> Float
wrdStartH WindowResizeDrag
wrd Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dy
        | Bool
otherwise = WindowResizeDrag -> Float
wrdStartH WindowResizeDrag
wrd
      !w :: Float
w = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minW (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
maxW Float
w0)
      !h :: Float
h = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
minH (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
maxH Float
h0)
      !x0 :: Float
x0 = if Bool
fromW then Float
right0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
w else WindowResizeDrag -> Float
wrdStartX WindowResizeDrag
wrd
      !y0 :: Float
y0 = if Bool
fromN then Float
bottom0 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
h else WindowResizeDrag -> Float
wrdStartY WindowResizeDrag
wrd
      !x :: Float
x = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
x0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
winW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
w)))
      !y :: Float
y = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
y0 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
winH Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
h)))
   in (Float
w, Float
h, Float
x, Float
y)

updateWindowResize :: Context -> Input -> Float -> Float -> IO Bool
updateWindowResize :: Context -> Input -> Float -> Float -> IO Bool
updateWindowResize Context
ctx Input
inp Float
winW Float
winH = do
  drag <- Context -> IO (Maybe WindowResizeDrag)
getWindowResize Context
ctx
  case drag of
    Just WindowResizeDrag
wrd
      | Input -> Bool
inputMouseDown Input
inp -> do
          let (Float
nw, Float
nh, Float
nx, Float
ny) = WindowResizeDrag
-> V2 -> Float -> Float -> (Float, Float, Float, Float)
resizeFromEdge WindowResizeDrag
wrd (Input -> V2
inputMousePos Input
inp) Float
winW Float
winH
              key :: NodeIdx
key = WidgetId -> NodeIdx
intKey (WindowResizeDrag -> WidgetId
wrdWidget WindowResizeDrag
wrd)
          store <- Context -> IO WidgetStore
getStore Context
ctx
          setStore ctx (store {storePoint = IM.insert (slotKey SlotWinSize key) (nw, nh) (IM.insert key (nx, ny) (storePoint store))})
          relayoutWindow ctx winW winH (wrdWidget wrd) nw nh
          damageWidget ctx (wrdWidget wrd) (DamageInflated haloDamageSlop)
          markDirty ctx
          pure True
      | Bool
otherwise -> do
          Context -> (InteractionState -> InteractionState) -> IO ()
modifyInteraction Context
ctx (\InteractionState
s -> InteractionState
s {isWindowResize = Nothing})
          Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Maybe WindowResizeDrag
Nothing
      | Input -> Bool
inputMousePressed Input
inp -> Context -> V2 -> IO Bool
tryStartWindowResize Context
ctx (Input -> V2
inputMousePos Input
inp)
      | Bool
otherwise -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

relayoutWindow :: Context -> Float -> Float -> WidgetId -> Float -> Float -> IO ()
relayoutWindow :: Context -> Float -> Float -> WidgetId -> Float -> Float -> IO ()
relayoutWindow Context
ctx Float
winW Float
winH WidgetId
wid Float
nw Float
nh = do
  mIdx <- Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid
  case mIdx of
    Maybe NodeIdx
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just NodeIdx
idx -> do
      mpos <- Context -> WidgetId -> IO (Maybe (Float, Float))
lookupWindowPos Context
ctx WidgetId
wid
      (x, y, _, _) <- getRect (ctxNodeArena ctx) idx
      placeWindowNode (ctxNodeArena ctx) (contextMeasurers ctx) winW winH idx nw nh (const (fromMaybe (x, y) mpos))

-- | Resize edge under @mouse@ for the topmost window whose halo holds it,
-- unless the halo is blocked or the pointer is on the title bar or one of its
-- controls.
resizeEdgeTarget :: Context -> V2 -> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))
resizeEdgeTarget :: Context -> V2 -> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))
resizeEdgeTarget Context
ctx V2
mouse = do
  mWin <- Context -> V2 -> IO (Maybe NodeIdx)
topmostWindowAtResizeHalo Context
ctx V2
mouse
  case mWin of
    Maybe NodeIdx
Nothing -> Maybe (NodeIdx, Rect, WindowResizeEdge)
-> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (NodeIdx, Rect, WindowResizeEdge)
forall a. Maybe a
Nothing
    Just NodeIdx
idx -> do
      (x, y, w, h) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
      let rect = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
      -- The halo covers the window interior, so find the edge first and run
      -- the hover probe and node scans only when there is one.
      mEdge <- windowResizeEdgeFor ctx idx rect mouse
      case mEdge of
        Maybe WindowResizeEdge
Nothing -> Maybe (NodeIdx, Rect, WindowResizeEdge)
-> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (NodeIdx, Rect, WindowResizeEdge)
forall a. Maybe a
Nothing
        Just WindowResizeEdge
edge -> do
          mTitle <- Context -> NodeIdx -> IO (Maybe Rect)
windowTitleRect Context
ctx NodeIdx
idx
          if maybe False (`rectContains` mouse) mTitle
            then pure Nothing
            else do
              blocked <- resizeHaloBlocked ctx mouse idx
              overControl <- if blocked then pure False else windowTitleHasInteractive ctx idx mouse
              pure (if blocked || overControl then Nothing else Just (idx, rect, edge))

tryStartWindowResize :: Context -> V2 -> IO Bool
tryStartWindowResize :: Context -> V2 -> IO Bool
tryStartWindowResize Context
ctx mouse :: V2
mouse@(V2 Float
mx Float
my) = do
  mTarget <- Context -> V2 -> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))
resizeEdgeTarget Context
ctx V2
mouse
  case mTarget of
    Maybe (NodeIdx, Rect, WindowResizeEdge)
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just (NodeIdx
idx, Rect Float
x Float
y Float
w Float
h, WindowResizeEdge
edge) -> do
      wid <- NodeArena -> NodeIdx -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
      (minW, minH, maxW, maxH) <- getMinMax (ctxNodeArena ctx) idx
      modifyInteraction ctx $ \InteractionState
s ->
        InteractionState
s
          { isWindowResize =
              Just
                WindowResizeDrag
                  { wrdWidget = wid
                  , wrdEdge = edge
                  , wrdGrabX = mx
                  , wrdGrabY = my
                  , wrdStartX = x
                  , wrdStartY = y
                  , wrdStartW = w
                  , wrdStartH = h
                  , wrdMinW = minW
                  , wrdMinH = minH
                  , wrdMaxW = maxW
                  , wrdMaxH = maxH
                  }
          }
      markDirty ctx
      pure True

windowResizeCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
windowResizeCursorKind :: Context -> Input -> IO (Maybe UiCursorKind)
windowResizeCursorKind Context
ctx Input
inp = do
  mDrag <- Context -> IO (Maybe WindowResizeDrag)
getWindowResize Context
ctx
  case mDrag of
    Just WindowResizeDrag
wrd
      | Input -> Bool
inputMouseDown Input
inp -> Maybe UiCursorKind -> IO (Maybe UiCursorKind)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UiCursorKind -> Maybe UiCursorKind
forall a. a -> Maybe a
Just (WindowResizeEdge -> UiCursorKind
cursorForResizeEdge (WindowResizeDrag -> WindowResizeEdge
wrdEdge WindowResizeDrag
wrd)))
      | Bool
otherwise -> Maybe UiCursorKind -> IO (Maybe UiCursorKind)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UiCursorKind
forall a. Maybe a
Nothing
    Maybe WindowResizeDrag
Nothing -> ((NodeIdx, Rect, WindowResizeEdge) -> UiCursorKind)
-> Maybe (NodeIdx, Rect, WindowResizeEdge) -> Maybe UiCursorKind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(NodeIdx
_, Rect
_, WindowResizeEdge
edge) -> WindowResizeEdge -> UiCursorKind
cursorForResizeEdge WindowResizeEdge
edge) (Maybe (NodeIdx, Rect, WindowResizeEdge) -> Maybe UiCursorKind)
-> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))
-> IO (Maybe UiCursorKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> V2 -> IO (Maybe (NodeIdx, Rect, WindowResizeEdge))
resizeEdgeTarget Context
ctx (Input -> V2
inputMousePos Input
inp)

-- Halo must not steal hits from page widgets or another window's interior.
resizeHaloBlocked :: Context -> V2 -> NodeIdx -> IO Bool
resizeHaloBlocked :: Context -> V2 -> NodeIdx -> IO Bool
resizeHaloBlocked Context
ctx V2
mouse NodeIdx
winIdx = do
  mInside <- Context -> V2 -> IO (Maybe NodeIdx)
topmostOverlayAtMouse Context
ctx V2
mouse
  case mInside of
    Just NodeIdx
other | NodeIdx
other NodeIdx -> NodeIdx -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeIdx
winIdx -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Maybe NodeIdx
_ -> do
      hot <- Context -> V2 -> IO WidgetId
probeHotId Context
ctx V2
mouse
      if hashWidgetId hot == 0
        then pure False
        else do
          mHot <- findNodeByWidgetId ctx hot
          case mHot of
            Maybe NodeIdx
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Just NodeIdx
hotIdx -> Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> NodeIdx -> NodeIdx -> IO Bool
nodeInSubtree Context
ctx NodeIdx
hotIdx NodeIdx
winIdx

tryStartWindowDrag :: Context -> V2 -> IO Bool
tryStartWindowDrag :: Context -> V2 -> IO Bool
tryStartWindowDrag Context
ctx mouse :: V2
mouse@(V2 Float
mx Float
my) = do
  mTop <- Context -> V2 -> IO (Maybe NodeIdx)
topmostOverlayAtMouse Context
ctx V2
mouse
  case mTop of
    Maybe NodeIdx
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just NodeIdx
idx -> do
      nt <- NodeArena -> NodeIdx -> IO NodeType
getNodeType (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
      mTitle <- if nt == NodeWindow then windowTitleRect ctx idx else pure Nothing
      case mTitle of
        Just Rect
title | Rect -> V2 -> Bool
rectContains Rect
title V2
mouse -> do
          overClose <- Context -> NodeIdx -> V2 -> IO Bool
windowTitleHasInteractive Context
ctx NodeIdx
idx V2
mouse
          if overClose
            then pure False
            else do
              wid <- getWidgetId (ctxNodeArena ctx) idx
              (wx, wy, _, _) <- getRect (ctxNodeArena ctx) idx
              modifyInteraction ctx (\InteractionState
s -> InteractionState
s {isWindowDrag = Just (wid, mx - wx, my - wy)})
              markDirty ctx
              pure True
        Maybe Rect
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Title bar: the window's topmost child, stretched up to the window top.
windowTitleRect :: Context -> NodeIdx -> IO (Maybe Rect)
windowTitleRect :: Context -> NodeIdx -> IO (Maybe Rect)
windowTitleRect Context
ctx NodeIdx
idx = do
  (_, wy, _, _) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
  fc <- getFirstChild (ctxNodeArena ctx) idx
  mBest <- go fc Nothing
  pure $ case mBest of
    Maybe Rect
Nothing -> Maybe Rect
forall a. Maybe a
Nothing
    Just (Rect Float
cx Float
cy Float
cw Float
ch) ->
      let topY :: Float
topY = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
wy Float
cy
       in Rect -> Maybe Rect
forall a. a -> Maybe a
Just (Float -> Float -> Float -> Float -> Rect
Rect Float
cx Float
topY Float
cw ((Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
topY) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ch))
  where
    go :: NodeIdx -> Maybe Rect -> IO (Maybe Rect)
go NodeIdx
ci Maybe Rect
best
      | NodeIdx
ci NodeIdx -> NodeIdx -> Bool
forall a. Ord a => a -> a -> Bool
< NodeIdx
0 = Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Rect
best
      | Bool
otherwise = do
          (x, y, w, h) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
ci
          ns <- getNextSibling (ctxNodeArena ctx) ci
          let here = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
          go ns $ case best of
            Just b :: Rect
b@(Rect Float
_ Float
by Float
_ Float
_) | Float
y Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
by -> Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
b
            Maybe Rect
_ -> Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
here

windowTitleHasInteractive :: Context -> NodeIdx -> V2 -> IO Bool
windowTitleHasInteractive :: Context -> NodeIdx -> V2 -> IO Bool
windowTitleHasInteractive Context
ctx NodeIdx
idx V2
mouse = do
  mWid <- Context -> V2 -> (NodeType -> Bool) -> IO (Maybe WidgetId)
findTopWidgetUnderMouse Context
ctx V2
mouse NodeType -> Bool
isInteractiveNode
  case mWid of
    Maybe WidgetId
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just WidgetId
wid -> do
      mNode <- Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid
      maybe (pure False) (\NodeIdx
wi -> Context -> NodeIdx -> NodeIdx -> IO Bool
nodeInSubtree Context
ctx NodeIdx
wi NodeIdx
idx) mNode

-- | How the context measures text and custom widgets, for the solve and for
-- placing floating nodes after it.
contextMeasurers :: Context -> Measurers
contextMeasurers :: Context -> Measurers
contextMeasurers Context
ctx =
  Measurers
    { msFm :: FontMetrics
msFm = Context -> FontMetrics
ctxFontMetrics Context
ctx
    , msMonoFm :: FontMetrics
msMonoFm = Context -> FontMetrics
ctxMonoFontMetrics Context
ctx
    , msMeasure :: Text -> IO (Float, Float)
msMeasure = Context -> Text -> IO (Float, Float)
ctxMeasureText Context
ctx
    , msResolveFont :: FontResolver
msResolveFont = \Float
sz FontWeight
weight FontStyle
style FontVariant
var -> do
        (fm, _) <- Context
-> Float
-> FontWeight
-> FontStyle
-> FontVariant
-> IO (FontMetrics, Bool)
ctxResolveFont Context
ctx Float
sz FontWeight
weight FontStyle
style FontVariant
var
        pure (fm, ctxResolveMeasure ctx sz weight style var)
    , msLookupMeasure :: WidgetId -> IO (Maybe CustomMeasureFn)
msLookupMeasure = Context -> WidgetId -> IO (Maybe CustomMeasureFn)
lookupCustomMeasure Context
ctx
    }