Box.hs

module Geomancy.Layout.Box where

import Prelude hiding (or)
import Geomancy

import Control.Monad (when)
import Foreign qualified
import Geomancy.Mat4 qualified as Mat4
import GHC.Generics (Generic)
import Graphics.Gl.Block qualified as Block

{- | 2D rectangle with its origin at the center.

Size transformations don't affect its position and vice versa.

@
┏━━━━━┓
┃     ┃
┃  *  ┃
┃     ┃
┗━━━━━┛
@
-}
data Box = Box
  { position :: Vec2
  , size     :: Vec2
  }
  deriving stock (Eq, Ord, Show, Generic)
  deriving anyclass Block.Block
  deriving Foreign.Storable via (Block.Packed Box)

-- | Place a 'Box' with given dimensions at @(0,0)@.
{-# INLINE box_ #-}
box_ :: Vec2 -> Box
box_ = Box 0

instance Semigroup Box where
  {-# INLINE (<>) #-}
  (<>) = union

-- | Check if one of the dimensions is negative.
{-# INLINE degenerate #-}
degenerate :: Box -> Bool
degenerate box =
  withVec2 box.size \w h ->
    w <= 0 ||
    h <= 0

-- | Move the 'Box' by the given vector.
{-# INLINE move #-}
move :: Vec2 -> Box -> Box
move delta box = box
  { position =
      box.position + delta
  }

-- | Adjust 'Box' size by a given amount (absolute).
{-# INLINE resize #-}
resize :: Vec2 -> Box -> Box
resize delta box = box
  { size =
      box.size + delta
  }

-- | Adjust 'Box' size by a given amount (relative).
{-# INLINE rescale #-}
rescale :: Vec2 -> Box -> Box
rescale delta box = box
  { size =
      box.size * delta
  }

-- * Edge representation

-- | Packed top- right- bottom- left- edge values.
newtype TRBL = TRBL Vec4
  deriving stock (Eq, Ord, Show, Generic)

instance Semigroup TRBL where
  {-# INLINE (<>) #-}
  TRBL a <> TRBL b =
    withVec4 a \at ar ab al ->
      withVec4 b \bt br bb bl ->
        TRBL $ vec4 (min at bt) (min ar br) (min ab bb) (max al bl)

type WithTRBL r = Float -> Float -> Float -> Float -> r

{-# INLINE fromTRBL #-}
fromTRBL :: WithTRBL Box
fromTRBL t r b l =
  Box
    { position =
        -- XXX: recover midpoint
        vec2
          (l * 0.5 + r * 0.5)
          (t * 0.5 + b * 0.5)
    , size =
        -- XXX: recover size
        vec2 (r - l) (b - t)
    }

{-# INLINE toTRBL #-}
toTRBL :: Box -> TRBL
toTRBL box = TRBL $ withTRBL box vec4

{-# INLINE withTRBL #-}
withTRBL :: Box -> WithTRBL r -> r
withTRBL Box{..} f =
  withVec2 position \x y ->
    withVec2 size \w h ->
      let
        t = y - h * 0.5
        r = x + w * 0.5
        b = y + h * 0.5
        l = x - w * 0.5
      in
        f t r b l

-- | Construct a smaller Box by adding non-uniform padding.
{-# INLINE addPadding #-}
addPadding :: TRBL -> Box -> Box
addPadding (TRBL padding) box =
  withVec4 padding \pt pr pb pl ->
    withTRBL box \t r b l ->
      fromTRBL (t + pt) (r - pr) (b - pb) (l + pl)

-- | Construct a smaller Box by adding non-uniform padding as a fraction of 'Box' size.
{-# INLINE addPaddingRel #-}
addPaddingRel :: TRBL -> Box -> Box
addPaddingRel (TRBL padding) box =
  withVec2 box.size \w h ->
    addPadding (TRBL $ padding * vec4 h w h w) box

-- | Construct a larger Box by adding non-uniform margins.
{-# INLINE addMargins #-}
addMargins :: TRBL -> Box -> Box
addMargins (TRBL margins) box =
  withVec4 margins \mt mr mb ml ->
    withTRBL box \t r b l ->
      fromTRBL (t - mt) (r + mr) (b + mb) (l - ml)

-- | Construct a larger Box by adding non-uniform margins as a fraction of 'Box' size.
{-# INLINE addMarginsRel #-}
addMarginsRel :: TRBL -> Box -> Box
addMarginsRel (TRBL margins) box =
  withVec2 box.size \w h ->
    addMargins (TRBL $ margins * vec4 h w h w) box

-- * AABB representation

-- | Bounding box from 2 points, automatically sorted.
{-# INLINE fromCorners #-}
fromCorners :: Vec2 -> Vec2 -> Box
fromCorners a b =
  withVec2 a \ax ay ->
    withVec2 b \bx by ->
      fromTRBL (min ay by) (max ax bx) (max ay by) (min ax bx)

-- | 2-point AABB.
{-# INLINE toCorners #-}
toCorners :: Box -> (Vec2, Vec2)
toCorners box = withCorners box (,)

{-# INLINE withCorners #-}
withCorners :: Box -> (Vec2 -> Vec2 -> r) -> r
withCorners box f =
  withTRBL box \t r b l ->
    f (vec2 l t) (vec2 r b)

-- * Point-box interaction

-- | Project a point into the 'Box' space.
{-# INLINE projectInto #-}
projectInto :: Vec2 -> Box -> Vec2
projectInto point box = point - box.position

-- | Test if a point is within the 'Box' bounds.
{-# INLINE inside #-}
inside :: Vec2 -> Box -> Bool
inside point box =
  withVec2 (point `projectInto` box) \px py ->
    withVec2 (box.size / 2) \hw hh ->
      px > -hw && px < hw &&
      py > -hh && py < hh

whenInside :: Applicative m => Vec2 -> Box -> (Vec2 -> m ()) -> m ()
whenInside point box action =
  when (inside point box) $
    action (point `projectInto` box)

-- * Box-box interaction

-- | Test if a 'Box' can contain a given 'Box'.
{-# INLINE canContain #-}
canContain :: Box -> Box -> Bool
canContain outer inner =
  withVec2 inner.size \iw ih ->
    withVec2 outer.size \ow oh ->
      iw <= ow &&
      ih <= oh

-- | Test if a 'Box' fully contains a given 'Box'.
{-# INLINE contains #-}
contains :: Box -> Box -> Bool
contains outer inner =
  withTRBL outer \ot or ob ol ->
    withTRBL inner \it ir ib il ->
      it >= ot &&
      ir <= or &&
      ib <= ob &&
      il >= ol

{-# INLINE union #-}
-- | Get a 'Box' that tightly wraps both its elements.
union :: Box -> Box -> Box
union a b =
  withTRBL a \at ar ab al ->
    withTRBL b \bt br bb bl ->
      fromTRBL (min at bt) (max ar br) (max ab bb) (min al bl)

{- | Get an intersection between two boxes, if there is one.

Use faster `intersects` instead if only need a test.
-}
intersection :: Box -> Box -> Maybe Box
intersection a b =
  if degenerate candidate then
    Nothing
  else
    Just candidate
  where
    candidate = intersectionDirty a b

-- | Get a potentially-degenerate intersection between two boxes.
{-# INLINE intersectionDirty #-}
intersectionDirty :: Box -> Box -> Box
intersectionDirty a b =
  withTRBL a \at ar ab al ->
    withTRBL b \bt br bb bl ->
      fromTRBL (max at bt) (min ar br) (min ab bb) (max al bl)

{- | Box-box intersection test.

Any edge contact counts as intersection.
For area contact use 'intersection`, which is a little less efficient.
-}
{-# INLINE intersects #-}
intersects :: Box -> Box -> Bool
intersects a b =
  withTRBL a \at ar ab al ->
    withTRBL b \bt br bb bl ->
      at <= bb &&
      al <= br &&
      bl <= ar &&
      bt <= ab
-- TODO: SIMD `intersects`

{- | Remaining space when one box is placed inside another.

All positive when the box is fully inside.
Negative edges mean the box is "outside" in that direction.

@
addPadding (leftovers inner outer) inner === outer
addMargins (leftovers inner outer) outer === inner
@
-}
leftovers :: Box -> Box -> TRBL
leftovers a b =
  TRBL $ withLeftovers a b vec4

withLeftovers :: Box -> Box -> WithTRBL r -> r
withLeftovers a b f =
  withTRBL a \ta ra ba la ->
    withTRBL b \tb rb bb lb ->
      f
        (tb - ta)
        (ra - rb)
        (ba - bb)
        (lb - la)

-- * Conversion

-- | Build a transformation matrix to stretch a unit square and place it at depth 0.0.
{-# INLINE mkTransform #-}
mkTransform :: Box -> Transform
mkTransform = mkTransformZ 0.0

-- | Build a transformation matrix to stretch a unit square and place it at a given depth.
{-# INLINE mkTransformZ #-}
mkTransformZ :: Float -> Box -> Transform
mkTransformZ z Box{..} =
  withVec2 position \x y ->
    withVec2 size \w h ->
      Mat4.rowMajor
        w 0 0 0
        0 h 0 0
        0 0 1 0
        x y z 1