Hover.hs

module BrushStroking.Hover where

-- base
import GHC.Generics
  ( Generic )

-- acts
import Data.Act
  ( Act(..) )


-- deepseq
import Control.DeepSeq
  ( NFData(..) )

-- brush-strokes
import Math.Module
  ( quadrance
  , closestPointOnSegment
  )
import Math.Linear
  ( ℝ(..), T(..), Segment(..) )

-- MetaBrush
import BrushStroking.Document

--------------------------------------------------------------------------------

-- | An axis-aligned bounding box.
data AABB
  = AABB
  { topLeft, botRight :: !( ℝ 2 ) }
  deriving stock    ( Show, Generic )
  deriving anyclass NFData

-- | Create an 'AABB'.
mkAABB :: ℝ 2 -> ℝ 2 -> AABB
mkAABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) = AABB ( ℝ2 xmin ymin ) ( ℝ2 xmax ymax )
  where
    ( xmin, xmax )
      | x1 > x2   = ( x2, x1 )
      | otherwise = ( x1, x2 )
    ( ymin, ymax )
      | y1 > y2   = ( y2, y1 )
      | otherwise = ( y1, y2 )

-- | A hover (mouse cursor or entire rectangle).
data HoverContext
  = MouseHover     !( ℝ 2 )
  | RectangleHover !AABB
  deriving stock    ( Show, Generic )
  deriving anyclass NFData

instance Act ( T ( ℝ 2 ) ) HoverContext where
  v • MouseHover p = MouseHover ( v • p )
  v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )

instance Act ( T ( ℝ 2 ) ) ( Maybe HoverContext ) where
  (•) v = fmap ( v • )

class Hoverable a where
  hovered :: HoverContext -> Zoom -> a -> Bool

instance Hoverable ( ℝ 2 ) where
  hovered ( MouseHover p ) zoom q
    = inLargePointClickRange zoom p q
  hovered ( RectangleHover ( AABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ) ) _ ( ℝ2 x y )
    = x >= x1 && x <= x2 && y >= y1 && y <= y2

instance Hoverable ( Segment ( ℝ 2 ) ) where
  hovered ( MouseHover p ) zoom seg
    = hovered ( MouseHover p ) zoom p'
    where
      ( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg
  hovered hov@(RectangleHover {} ) zoom ( Segment p0 p1 )
    -- Only consider a segment to be "hovered" if it lies entirely within the
    -- hover rectangle, not just if the hover rectangle intersects it.
    = hovered hov zoom p0 && hovered hov zoom p1

inLargePointClickRange :: Zoom -> ℝ 2 -> ℝ 2 -> Bool
inLargePointClickRange ( Zoom { zoomFactor } ) c p =
  quadrance @( T ( ℝ 2 ) ) c p < 16 / ( zoomFactor * zoomFactor )

inSmallPointClickRange :: Zoom -> ℝ 2 -> ℝ 2 -> Bool
inSmallPointClickRange ( Zoom { zoomFactor } ) c p =
  quadrance @( T ( ℝ 2 ) ) c p < 6 / ( zoomFactor * zoomFactor )