Layout.hs

module Engine.UI.Layout
  ( BoxProcess
  , Box(..)
  , trackScreen
  , padAbs
  , hSplitRel
  , vSplitRel

  , splitsRelStatic
  , sharePadsH
  , sharePadsV

  , boxPadAbs
  , sharePads

  , fitPlaceAbs
  , boxFitPlace
  , boxFitScale

  , boxRectAbs
  , boxTransformAbs

  , Alignment(..)
  , pattern LeftTop
  , pattern LeftMiddle
  , pattern LeftBottom
  , pattern CenterTop
  , pattern Center
  , pattern CenterBottom
  , pattern RightTop
  , pattern RightMiddle
  , pattern RightBottom
  , Origin(..)

  , whenInBoxP
  , pointInBox
  ) where

import RIO

import Data.Traversable (mapAccumL)
import Geomancy (Transform, Vec2, Vec4, vec2, vec4, withVec2, pattern WithVec2, pattern WithVec4)
import Geomancy.Transform qualified as Transform
import Geomancy.Vec4 qualified as Vec4
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))

import Engine.Types qualified as Engine
import Engine.Worker qualified as Worker

data Box = Box
  { boxPosition :: Vec2
  , boxSize     :: Vec2
  }
  deriving (Eq, Ord, Show)

data Alignment = Alignment
  { alignX :: Origin -- ^ left/center/right
  , alignY :: Origin -- ^ top/middle/bottom
  }

pattern LeftTop :: Alignment
pattern LeftTop = Alignment Begin  Begin

pattern LeftMiddle :: Alignment
pattern LeftMiddle = Alignment Begin Middle

pattern LeftBottom :: Alignment
pattern LeftBottom = Alignment Begin End

pattern CenterTop :: Alignment
pattern CenterTop = Alignment Middle Begin

pattern Center :: Alignment
pattern Center = Alignment Middle Middle

pattern CenterBottom :: Alignment
pattern CenterBottom = Alignment Middle End

pattern RightTop :: Alignment
pattern RightTop = Alignment End Begin

pattern RightMiddle :: Alignment
pattern RightMiddle = Alignment End Middle

pattern RightBottom :: Alignment
pattern RightBottom = Alignment End End

data Origin
  = Begin
  | Middle
  | End
  deriving (Eq, Ord, Show, Enum, Bounded)

type BoxProcess = Worker.Merge Box

trackScreen :: Engine.StageRIO st BoxProcess
trackScreen = do
  screen <- Engine.askScreenVar
  Worker.spawnMerge1 mkBox screen
  where
    mkBox Vk.Extent2D{width, height} = Box
      { boxPosition = 0
      , boxSize     = vec2 (fromIntegral width) (fromIntegral height)
      }

padAbs
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput padding
     , Worker.GetOutput padding ~ Vec4
     )
  => parent
  -> padding
  -> m BoxProcess
padAbs = Worker.spawnMerge2 boxPadAbs

{-# INLINEABLE boxPadAbs #-}
boxPadAbs :: Box -> Vec4 -> Box
boxPadAbs Box{..} (WithVec4 top right bottom left) = Box
  { boxPosition = boxPosition + vec2 dx dy
  , boxSize     = boxSize - vec2 dw dh
  }
  where
    WithVec2 w h = boxSize
    dx = left * 0.5 - right * 0.5
    dy = top * 0.5 - bottom * 0.5
    dw = min w (left + right)
    dh = min h (top + bottom)

padRel
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput padding
     , Worker.GetOutput padding ~ Vec4
     )
  => parent
  -> padding
  -> m BoxProcess
padRel = Worker.spawnMerge2 boxPadRel

{-# INLINEABLE boxPadRel #-}
boxPadRel :: Box -> Vec4 -> Box
boxPadRel box@Box{boxSize=WithVec2 w h} pad =
  boxPadAbs box (pad * vec4 h w h w)

fitPlaceAbs
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     )
  => Alignment
  -> "dimensions" ::: Vec2
  -> parent
  -> m BoxProcess
fitPlaceAbs align dimensions =
  Worker.spawnMerge1
    (boxFitPlace align dimensions)

{-# INLINEABLE boxFitPlace #-}
boxFitPlace
  :: Alignment
  -> "dimensions" ::: Vec2
  -> "parent" ::: Box
  -> Box
boxFitPlace Alignment{..} wh parent =
  boxPadAbs parent (vec4 t r b l)
  where
    (WithVec2 dw dh, _box) = boxFitScale wh parent

    (l, r) = case alignX of
      Begin  -> (0,      dw)
      Middle -> (dw / 2, dw / 2)
      End    -> (dw,     0)

    (t, b) = case alignY of
      Begin  -> (0,      dh)
      Middle -> (dh / 2, dh / 2)
      End    -> (dh,     0)

{-# INLINEABLE boxFitScale #-}
boxFitScale
  :: "dimensions" ::: Vec2
  -> "parent" ::: Box
  -> ( "leftovers" ::: Vec2
     , Box
     )
boxFitScale (WithVec2 w h) parent =
  ( vec2 (pw - sw) (ph - sh)
  , Box
      { boxSize     = vec2 sw sh
      , boxPosition = boxPosition parent
      }
  )
  where
    Box{boxSize=WithVec2 pw ph} = parent

    sw = scale * w
    sh = scale * h

    scale =
      if parentAspect > aspect then
        ph / h
      else
        pw / w
      where
        parentAspect = pw / ph
        aspect = w / h

splitsRelStatic
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Traversable t -- XXX: nested traversables may behave suprisingly
     )
  => ((Float, Float) -> Vec4)
  -> parent
  -> t Float
  -> m (t BoxProcess)
splitsRelStatic padF parentVar shares =
  for (sharePads totalShares shares) \pads -> do
    shareVar <- Worker.newVar $ padF pads Vec4.^/ totalShares
    padRel parentVar shareVar
  where
    totalShares = sum shares

sharePadsH :: (Float, Float) -> Vec4
sharePadsH (left, right) = vec4 0 right 0 left

sharePadsV :: (Float, Float) -> Vec4
sharePadsV (top, bottom) = vec4 top 0 bottom 0

sharePads :: Traversable t => Float -> t Float -> t (Float, Float)
sharePads totalShares shares = snd $ mapAccumL f 0 shares
  where
    f sharesBefore share =
      ( sharesBefore + share
      , ( sharesBefore
        , totalShares - sharesBefore - share
        )
      )

hSplitRel
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput proportion
     , Worker.GetOutput proportion ~ Float
     )
  => parent
  -> proportion
  -> m (BoxProcess, BoxProcess)
hSplitRel parentVar proportionVar = (,)
  <$> spawnLeft parentVar proportionVar
  <*> spawnRight parentVar proportionVar
  where
    spawnLeft = Worker.spawnMerge2 \parent proportion ->
      let
        rightWidth =
          withVec2 (boxSize parent) \width _height ->
            width - width * proportion
      in
        boxPadAbs parent (vec4 0 rightWidth 0 0)

    spawnRight = Worker.spawnMerge2 \parent proportion ->
      let
        leftWidth =
          withVec2 (boxSize parent) \width _height ->
            width * proportion
      in
        boxPadAbs parent (vec4 0 0 0 leftWidth)

vSplitRel
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput proportion
     , Worker.GetOutput proportion ~ Float
     )
  => parent
  -> proportion
  -> m (BoxProcess, BoxProcess)
vSplitRel parentVar proportionVar = (,)
  <$> spawnTop parentVar proportionVar
  <*> spawnBottom parentVar proportionVar
  where
    spawnTop = Worker.spawnMerge2 \parent proportion ->
      let
        bottomHeight =
          withVec2 (boxSize parent) \_width height ->
            height - height * proportion
      in
        boxPadAbs parent (vec4 0 0 bottomHeight 0)

    spawnBottom = Worker.spawnMerge2 \parent proportion ->
      let
        topHeight =
          withVec2 (boxSize parent) \_width height ->
            height * proportion
      in
        boxPadAbs parent (vec4 topHeight 0 0 0)

{-# INLINEABLE boxRectAbs #-}
boxRectAbs :: Box -> Vk.Rect2D
boxRectAbs Box{..} =
  withVec2 boxPosition \x y ->
  withVec2 boxSize \w h ->
    let
      r = Vk.Rect2D
        { offset = Vk.Offset2D (truncate $ x) (truncate $ y) -- FIXME: rects have top-left origin
        , extent = Vk.Extent2D (truncate w) (truncate h)
        }
    in
      -- traceShow (Box{..}, r)
      r

{-# INLINEABLE boxTransformAbs #-}
boxTransformAbs :: Box -> Transform
boxTransformAbs Box{..} = mconcat
  [ withVec2 boxSize Transform.scaleXY
  , withVec2 boxPosition translateXY
  ]

{-# INLINE translateXY #-}
translateXY :: Float -> Float -> Transform
translateXY x y = Transform.translate x y 0

whenInBoxP
  :: ( MonadIO m
     , Worker.HasOutput box
     , Worker.GetOutput box ~ Box
     )
  => "screen" ::: Vec2
  -> box
  -> ("local" ::: Vec2 -> m ())
  -> m ()
whenInBoxP cursorPos boxP action = do
  box <- Worker.getOutputData boxP
  when (pointInBox cursorPos box) $
    action $ cursorPos - boxPosition box

pointInBox :: Vec2 -> Box -> Bool
pointInBox point Box{..} =
  withVec2 (point - boxPosition) \px py ->
    withVec2 (boxSize / 2) \hw hh ->
      px > -hw && px < hw &&
      py > -hh && py < hh