{-# LANGUAGE DataKinds #-}

-- | Layout hit testing for modals, windows, and overlay stacking.
module NanoUI.Frame.Hit
  ( findNodeByWidgetId
  , findNodeByKey
  , modalTreeOpen
  , nodeInSubtree
  , widgetIdInSubtree
  , overlayHitAllowed
  , topmostOverlayAtMouse
  , topmostModalAtMouse
  , widgetOverlayAllowed
  , scrollHitRect
  , nodePointVisible
  , nodeClippedHit
  , nodeInteractionHit
  ) where

import Data.Maybe (isJust)
import NanoUI.Context (Context (..), getPrevRect, getPrevClipRect)
import NanoUI.Id (WidgetId)
import NanoUI.Layout.Arena
  ( NodeIdx
  , NodeType (NodeModal, NodePopup, NodeScrollContainer, NodeWindow)
  , findNodeRevM
  , getClipRect
  , getNodeType
  , getParent
  , getRect
  , getWidgetId
  , lookupNodeByKey
  , lookupNodeByWidgetId
  , topModalNode
  )
import NanoUI.Types (Rect (..), V2 (..), rectContains, rectH, rectW)

findNodeByWidgetId :: Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId :: Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid = NodeArena -> WidgetId -> IO (Maybe NodeIdx)
lookupNodeByWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) WidgetId
wid

findNodeByKey :: Context -> Int -> IO (Maybe NodeIdx)
findNodeByKey :: Context -> NodeIdx -> IO (Maybe NodeIdx)
findNodeByKey Context
ctx NodeIdx
k = NodeArena -> NodeIdx -> IO (Maybe NodeIdx)
lookupNodeByKey (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
k

modalTreeOpen :: Context -> IO Bool
modalTreeOpen :: Context -> IO Bool
modalTreeOpen Context
ctx = do
  top <- NodeArena -> IO (Maybe NodeIdx)
topModalNode (Context -> NodeArena
ctxNodeArena Context
ctx)
  pure (isJust top)

nodeInSubtree :: Context -> NodeIdx -> NodeIdx -> IO Bool
nodeInSubtree :: Context -> NodeIdx -> NodeIdx -> IO Bool
nodeInSubtree Context
ctx NodeIdx
idx NodeIdx
top = NodeIdx -> IO Bool
go NodeIdx
idx
  where
    go :: NodeIdx -> IO Bool
go NodeIdx
i
      | NodeIdx
i NodeIdx -> NodeIdx -> Bool
forall a. Ord a => a -> a -> Bool
< NodeIdx
0 = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      | NodeIdx
i NodeIdx -> NodeIdx -> Bool
forall a. Eq a => a -> a -> Bool
== NodeIdx
top = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      | Bool
otherwise = do
          parent <- NodeArena -> NodeIdx -> IO NodeIdx
getParent (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
i
          go parent

-- | Membership predicate for an already-resolved subtree root. Callers
-- filtering many widgets can resolve the root once for the whole operation.
widgetIdInSubtree :: Context -> NodeIdx -> WidgetId -> IO Bool
widgetIdInSubtree :: Context -> NodeIdx -> WidgetId -> IO Bool
widgetIdInSubtree Context
ctx NodeIdx
root WidgetId
wid = do
  node <- Context -> WidgetId -> IO (Maybe NodeIdx)
findNodeByWidgetId Context
ctx WidgetId
wid
  maybe (pure False) (\NodeIdx
idx -> Context -> NodeIdx -> NodeIdx -> IO Bool
nodeInSubtree Context
ctx NodeIdx
idx NodeIdx
root) node

overlayHitAllowed :: Context -> NodeIdx -> V2 -> IO Bool
overlayHitAllowed :: Context -> NodeIdx -> V2 -> IO Bool
overlayHitAllowed Context
ctx NodeIdx
idx V2
mouse = do
  mModal <- NodeArena -> IO (Maybe NodeIdx)
topModalNode (Context -> NodeArena
ctxNodeArena Context
ctx)
  case mModal of
    Just NodeIdx
top -> Context -> NodeIdx -> NodeIdx -> IO Bool
nodeInSubtree Context
ctx NodeIdx
idx NodeIdx
top
    Maybe NodeIdx
Nothing -> 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
True
        Just NodeIdx
tidx -> Context -> NodeIdx -> NodeIdx -> IO Bool
nodeInSubtree Context
ctx NodeIdx
idx NodeIdx
tidx

topmostOverlayAtMouse :: Context -> V2 -> IO (Maybe NodeIdx)
topmostOverlayAtMouse :: Context -> V2 -> IO (Maybe NodeIdx)
topmostOverlayAtMouse Context
ctx V2
mouse =
  Context -> V2 -> (NodeType -> Bool) -> IO (Maybe NodeIdx)
topmostFloatingAtMouse Context
ctx V2
mouse (\NodeType
nt -> NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeWindow Bool -> Bool -> Bool
|| NodeType
nt NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodePopup)

topmostModalAtMouse :: Context -> V2 -> IO (Maybe NodeIdx)
topmostModalAtMouse :: Context -> V2 -> IO (Maybe NodeIdx)
topmostModalAtMouse Context
ctx V2
mouse =
  Context -> V2 -> (NodeType -> Bool) -> IO (Maybe NodeIdx)
topmostFloatingAtMouse Context
ctx V2
mouse (NodeType -> NodeType -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType
NodeModal)

topmostFloatingAtMouse :: Context -> V2 -> (NodeType -> Bool) -> IO (Maybe NodeIdx)
topmostFloatingAtMouse :: Context -> V2 -> (NodeType -> Bool) -> IO (Maybe NodeIdx)
topmostFloatingAtMouse Context
ctx V2
mouse NodeType -> Bool
wanted =
  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 not (wanted nt)
      then pure False
      else do
        (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
        pure (w > 0 && h > 0 && rectContains (Rect x y w h) mouse)

widgetOverlayAllowed :: Context -> WidgetId -> IO Bool
widgetOverlayAllowed :: Context -> WidgetId -> IO Bool
widgetOverlayAllowed Context
ctx WidgetId
wid = do
  top <- NodeArena -> IO (Maybe NodeIdx)
topModalNode (Context -> NodeArena
ctxNodeArena Context
ctx)
  case top of
    Maybe NodeIdx
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just NodeIdx
modal -> Context -> NodeIdx -> WidgetId -> IO Bool
widgetIdInSubtree Context
ctx NodeIdx
modal WidgetId
wid

-- Prev rects are visual space (snapshot after applyScrollOffsets).
scrollHitRect :: Context -> WidgetId -> IO (Maybe Rect)
scrollHitRect :: Context -> WidgetId -> IO (Maybe Rect)
scrollHitRect = Context -> WidgetId -> IO (Maybe Rect)
getPrevRect

{-# INLINE nodePointVisible #-}
nodePointVisible :: Context -> NodeIdx -> V2 -> IO Bool
nodePointVisible :: Context -> NodeIdx -> V2 -> IO Bool
nodePointVisible Context
ctx NodeIdx
idx V2
mouse = do
  (x, y, w, h) <- NodeArena -> NodeIdx -> IO (Float, Float, Float, Float)
getRect (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
idx
  let vis = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
  if not (w > 0 && h > 0 && rectContains vis mouse)
    then pure False
    else do
      mClip <- getClipRect (ctxNodeArena ctx) idx
      pure (maybe True (`rectContains` mouse) mClip)

{-# INLINE nodeClippedHit #-}
nodeClippedHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool
nodeClippedHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool
nodeClippedHit Context
ctx NodeIdx
idx Rect
rect V2
mouse = do
  if Bool -> Bool
not (Rect -> Float
rectW Rect
rect Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Rect -> Float
rectH Rect
rect Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Rect -> V2 -> Bool
rectContains Rect
rect V2
mouse)
    then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else do
      na <- NodeArena -> IO NodeArena
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> NodeArena
ctxNodeArena Context
ctx)
      mLive <- getClipRect na idx
      mClip <-
        case mLive of
          Just Rect
r -> Maybe Rect -> IO (Maybe Rect)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect -> Maybe Rect
forall a. a -> Maybe a
Just Rect
r)
          Maybe Rect
Nothing -> do
            wid <- NodeArena -> NodeIdx -> IO WidgetId
getWidgetId NodeArena
na NodeIdx
idx
            getPrevClipRect ctx wid
      pure (maybe True (`rectContains` mouse) mClip)

-- | Hit test during UI build (before applyScrollOffsets). Uses prev rects and
-- scroll viewport clips only, not per-node live clips.
{-# INLINE nodeInteractionHit #-}
nodeInteractionHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool
nodeInteractionHit :: Context -> NodeIdx -> Rect -> V2 -> IO Bool
nodeInteractionHit Context
ctx NodeIdx
idx Rect
rect V2
mouse = do
  if Bool -> Bool
not (Rect -> Float
rectW Rect
rect Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Rect -> Float
rectH Rect
rect Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Rect -> V2 -> Bool
rectContains Rect
rect V2
mouse)
    then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else Context -> NodeIdx -> V2 -> IO Bool
scrollViewportHit Context
ctx NodeIdx
idx V2
mouse

scrollViewportHit :: Context -> NodeIdx -> V2 -> IO Bool
scrollViewportHit :: Context -> NodeIdx -> V2 -> IO Bool
scrollViewportHit Context
ctx NodeIdx
idx V2
mouse = NodeIdx -> IO Bool
go NodeIdx
idx
  where
    go :: NodeIdx -> IO Bool
go NodeIdx
i
      | NodeIdx
i NodeIdx -> NodeIdx -> Bool
forall a. Ord a => a -> a -> Bool
<= NodeIdx
0 = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      | Bool
otherwise = do
          p <- NodeArena -> NodeIdx -> IO NodeIdx
getParent (Context -> NodeArena
ctxNodeArena Context
ctx) NodeIdx
i
          if p < 0
            then pure True
            else do
              nt <- getNodeType (ctxNodeArena ctx) p
              if nt == NodeScrollContainer
                then do
                  wid <- getWidgetId (ctxNodeArena ctx) p
                  mClip <- getPrevClipRect ctx wid
                  case mClip of
                    Maybe Rect
Nothing -> NodeIdx -> IO Bool
go NodeIdx
p
                    Just Rect
clip ->
                      if Rect -> V2 -> Bool
rectContains Rect
clip V2
mouse then NodeIdx -> IO Bool
go NodeIdx
p else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                else go p