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
  { Box -> Vec2
boxPosition :: Vec2
  , Box -> Vec2
boxSize     :: Vec2
  }
  deriving (Box -> Box -> Bool
(Box -> Box -> Bool) -> (Box -> Box -> Bool) -> Eq Box
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Box -> Box -> Bool
$c/= :: Box -> Box -> Bool
== :: Box -> Box -> Bool
$c== :: Box -> Box -> Bool
Eq, Eq Box
Eq Box
-> (Box -> Box -> Ordering)
-> (Box -> Box -> Bool)
-> (Box -> Box -> Bool)
-> (Box -> Box -> Bool)
-> (Box -> Box -> Bool)
-> (Box -> Box -> Box)
-> (Box -> Box -> Box)
-> Ord Box
Box -> Box -> Bool
Box -> Box -> Ordering
Box -> Box -> Box
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Box -> Box -> Box
$cmin :: Box -> Box -> Box
max :: Box -> Box -> Box
$cmax :: Box -> Box -> Box
>= :: Box -> Box -> Bool
$c>= :: Box -> Box -> Bool
> :: Box -> Box -> Bool
$c> :: Box -> Box -> Bool
<= :: Box -> Box -> Bool
$c<= :: Box -> Box -> Bool
< :: Box -> Box -> Bool
$c< :: Box -> Box -> Bool
compare :: Box -> Box -> Ordering
$ccompare :: Box -> Box -> Ordering
Ord, Int -> Box -> ShowS
[Box] -> ShowS
Box -> String
(Int -> Box -> ShowS)
-> (Box -> String) -> ([Box] -> ShowS) -> Show Box
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Box] -> ShowS
$cshowList :: [Box] -> ShowS
show :: Box -> String
$cshow :: Box -> String
showsPrec :: Int -> Box -> ShowS
$cshowsPrec :: Int -> Box -> ShowS
Show)

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

pattern LeftTop :: Alignment
pattern $bLeftTop :: Alignment
$mLeftTop :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
LeftTop = Alignment Begin  Begin

pattern LeftMiddle :: Alignment
pattern $bLeftMiddle :: Alignment
$mLeftMiddle :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
LeftMiddle = Alignment Begin Middle

pattern LeftBottom :: Alignment
pattern $bLeftBottom :: Alignment
$mLeftBottom :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
LeftBottom = Alignment Begin End

pattern CenterTop :: Alignment
pattern $bCenterTop :: Alignment
$mCenterTop :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
CenterTop = Alignment Middle Begin

pattern Center :: Alignment
pattern $bCenter :: Alignment
$mCenter :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
Center = Alignment Middle Middle

pattern CenterBottom :: Alignment
pattern $bCenterBottom :: Alignment
$mCenterBottom :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
CenterBottom = Alignment Middle End

pattern RightTop :: Alignment
pattern $bRightTop :: Alignment
$mRightTop :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
RightTop = Alignment End Begin

pattern RightMiddle :: Alignment
pattern $bRightMiddle :: Alignment
$mRightMiddle :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
RightMiddle = Alignment End Middle

pattern RightBottom :: Alignment
pattern $bRightBottom :: Alignment
$mRightBottom :: forall {r}. Alignment -> (Void# -> r) -> (Void# -> r) -> r
RightBottom = Alignment End End

data Origin
  = Begin
  | Middle
  | End
  deriving (Origin -> Origin -> Bool
(Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool) -> Eq Origin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Origin -> Origin -> Bool
$c/= :: Origin -> Origin -> Bool
== :: Origin -> Origin -> Bool
$c== :: Origin -> Origin -> Bool
Eq, Eq Origin
Eq Origin
-> (Origin -> Origin -> Ordering)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool)
-> (Origin -> Origin -> Origin)
-> (Origin -> Origin -> Origin)
-> Ord Origin
Origin -> Origin -> Bool
Origin -> Origin -> Ordering
Origin -> Origin -> Origin
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Origin -> Origin -> Origin
$cmin :: Origin -> Origin -> Origin
max :: Origin -> Origin -> Origin
$cmax :: Origin -> Origin -> Origin
>= :: Origin -> Origin -> Bool
$c>= :: Origin -> Origin -> Bool
> :: Origin -> Origin -> Bool
$c> :: Origin -> Origin -> Bool
<= :: Origin -> Origin -> Bool
$c<= :: Origin -> Origin -> Bool
< :: Origin -> Origin -> Bool
$c< :: Origin -> Origin -> Bool
compare :: Origin -> Origin -> Ordering
$ccompare :: Origin -> Origin -> Ordering
Ord, Int -> Origin -> ShowS
[Origin] -> ShowS
Origin -> String
(Int -> Origin -> ShowS)
-> (Origin -> String) -> ([Origin] -> ShowS) -> Show Origin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Origin] -> ShowS
$cshowList :: [Origin] -> ShowS
show :: Origin -> String
$cshow :: Origin -> String
showsPrec :: Int -> Origin -> ShowS
$cshowsPrec :: Int -> Origin -> ShowS
Show, Int -> Origin
Origin -> Int
Origin -> [Origin]
Origin -> Origin
Origin -> Origin -> [Origin]
Origin -> Origin -> Origin -> [Origin]
(Origin -> Origin)
-> (Origin -> Origin)
-> (Int -> Origin)
-> (Origin -> Int)
-> (Origin -> [Origin])
-> (Origin -> Origin -> [Origin])
-> (Origin -> Origin -> [Origin])
-> (Origin -> Origin -> Origin -> [Origin])
-> Enum Origin
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Origin -> Origin -> Origin -> [Origin]
$cenumFromThenTo :: Origin -> Origin -> Origin -> [Origin]
enumFromTo :: Origin -> Origin -> [Origin]
$cenumFromTo :: Origin -> Origin -> [Origin]
enumFromThen :: Origin -> Origin -> [Origin]
$cenumFromThen :: Origin -> Origin -> [Origin]
enumFrom :: Origin -> [Origin]
$cenumFrom :: Origin -> [Origin]
fromEnum :: Origin -> Int
$cfromEnum :: Origin -> Int
toEnum :: Int -> Origin
$ctoEnum :: Int -> Origin
pred :: Origin -> Origin
$cpred :: Origin -> Origin
succ :: Origin -> Origin
$csucc :: Origin -> Origin
Enum, Origin
Origin -> Origin -> Bounded Origin
forall a. a -> a -> Bounded a
maxBound :: Origin
$cmaxBound :: Origin
minBound :: Origin
$cminBound :: Origin
Bounded)

type BoxProcess = Worker.Merge Box

trackScreen :: Engine.StageRIO st BoxProcess
trackScreen :: forall st. StageRIO st BoxProcess
trackScreen = do
  Var Extent2D
screen <- StageRIO st (Var Extent2D)
forall env. StageRIO env (Var Extent2D)
Engine.askScreenVar
  (GetOutput (Var Extent2D) -> Box)
-> Var Extent2D -> StageRIO st BoxProcess
forall (m :: * -> *) i o.
(MonadUnliftIO m, HasOutput i) =>
(GetOutput i -> o) -> i -> m (Merge o)
Worker.spawnMerge1 Extent2D -> Box
GetOutput (Var Extent2D) -> Box
mkBox Var Extent2D
screen
  where
    mkBox :: Extent2D -> Box
mkBox Vk.Extent2D{Word32
$sel:width:Extent2D :: Extent2D -> Word32
width :: Word32
width, Word32
$sel:height:Extent2D :: Extent2D -> Word32
height :: Word32
height} = Box :: Vec2 -> Vec2 -> Box
Box
      { $sel:boxPosition:Box :: Vec2
boxPosition = Vec2
0
      , $sel:boxSize:Box :: Vec2
boxSize     = Float -> Float -> Vec2
vec2 (Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
width) (Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
height)
      }

padAbs
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput padding
     , Worker.GetOutput padding ~ Vec4
     )
  => parent
  -> padding
  -> m BoxProcess
padAbs :: forall (m :: * -> *) parent padding.
(MonadUnliftIO m, HasOutput parent, GetOutput parent ~ Box,
 HasOutput padding, GetOutput padding ~ Vec4) =>
parent -> padding -> m BoxProcess
padAbs = (GetOutput parent -> GetOutput padding -> Box)
-> parent -> padding -> m BoxProcess
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 GetOutput parent -> GetOutput padding -> Box
Box -> Vec4 -> Box
boxPadAbs

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

padRel
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput padding
     , Worker.GetOutput padding ~ Vec4
     )
  => parent
  -> padding
  -> m BoxProcess
padRel :: forall (m :: * -> *) parent padding.
(MonadUnliftIO m, HasOutput parent, GetOutput parent ~ Box,
 HasOutput padding, GetOutput padding ~ Vec4) =>
parent -> padding -> m BoxProcess
padRel = (GetOutput parent -> GetOutput padding -> Box)
-> parent -> padding -> m BoxProcess
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 GetOutput parent -> GetOutput padding -> Box
Box -> Vec4 -> Box
boxPadRel

{-# INLINEABLE boxPadRel #-}
boxPadRel :: Box -> Vec4 -> Box
boxPadRel :: Box -> Vec4 -> Box
boxPadRel box :: Box
box@Box{$sel:boxSize:Box :: Box -> Vec2
boxSize=WithVec2 Float
w Float
h} Vec4
pad =
  Box -> Vec4 -> Box
boxPadAbs Box
box (Vec4
pad Vec4 -> Vec4 -> Vec4
forall a. Num a => a -> a -> a
* Float -> Float -> Float -> Float -> Vec4
vec4 Float
h Float
w Float
h Float
w)

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

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

    (Float
l, Float
r) = case Origin
alignX of
      Origin
Begin  -> (Float
0,      Float
dw)
      Origin
Middle -> (Float
dw Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2, Float
dw Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
      Origin
End    -> (Float
dw,     Float
0)

    (Float
t, Float
b) = case Origin
alignY of
      Origin
Begin  -> (Float
0,      Float
dh)
      Origin
Middle -> (Float
dh Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2, Float
dh Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
      Origin
End    -> (Float
dh,     Float
0)

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

    sw :: Float
sw = Float
scale Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
w
    sh :: Float
sh = Float
scale Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
h

    scale :: Float
scale =
      if Float
parentAspect Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
aspect then
        Float
ph Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
h
      else
        Float
pw Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
w
      where
        parentAspect :: Float
parentAspect = Float
pw Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
ph
        aspect :: Float
aspect = Float
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
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 :: forall (m :: * -> *) parent (t :: * -> *).
(MonadUnliftIO m, HasOutput parent, GetOutput parent ~ Box,
 Traversable t) =>
((Float, Float) -> Vec4) -> parent -> t Float -> m (t BoxProcess)
splitsRelStatic (Float, Float) -> Vec4
padF parent
parentVar t Float
shares =
  t (Float, Float)
-> ((Float, Float) -> m BoxProcess) -> m (t BoxProcess)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Float -> t Float -> t (Float, Float)
forall (t :: * -> *).
Traversable t =>
Float -> t Float -> t (Float, Float)
sharePads Float
totalShares t Float
shares) \(Float, Float)
pads -> do
    Var Vec4
shareVar <- Vec4 -> m (Var Vec4)
forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a)
Worker.newVar (Vec4 -> m (Var Vec4)) -> Vec4 -> m (Var Vec4)
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Vec4
padF (Float, Float)
pads Vec4 -> Float -> Vec4
Vec4.^/ Float
totalShares
    parent -> Var Vec4 -> m BoxProcess
forall (m :: * -> *) parent padding.
(MonadUnliftIO m, HasOutput parent, GetOutput parent ~ Box,
 HasOutput padding, GetOutput padding ~ Vec4) =>
parent -> padding -> m BoxProcess
padRel parent
parentVar Var Vec4
shareVar
  where
    totalShares :: Float
totalShares = t Float -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum t Float
shares

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

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

sharePads :: Traversable t => Float -> t Float -> t (Float, Float)
sharePads :: forall (t :: * -> *).
Traversable t =>
Float -> t Float -> t (Float, Float)
sharePads Float
totalShares t Float
shares = (Float, t (Float, Float)) -> t (Float, Float)
forall a b. (a, b) -> b
snd ((Float, t (Float, Float)) -> t (Float, Float))
-> (Float, t (Float, Float)) -> t (Float, Float)
forall a b. (a -> b) -> a -> b
$ (Float -> Float -> (Float, (Float, Float)))
-> Float -> t Float -> (Float, t (Float, Float))
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Float -> Float -> (Float, (Float, Float))
f Float
0 t Float
shares
  where
    f :: Float -> Float -> (Float, (Float, Float))
f Float
sharesBefore Float
share =
      ( Float
sharesBefore Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
share
      , ( Float
sharesBefore
        , Float
totalShares Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
sharesBefore Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
share
        )
      )

hSplitRel
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput proportion
     , Worker.GetOutput proportion ~ Float
     )
  => parent
  -> proportion
  -> m (BoxProcess, BoxProcess)
hSplitRel :: forall (m :: * -> *) parent proportion.
(MonadUnliftIO m, HasOutput parent, GetOutput parent ~ Box,
 HasOutput proportion, GetOutput proportion ~ Float) =>
parent -> proportion -> m (BoxProcess, BoxProcess)
hSplitRel parent
parentVar proportion
proportionVar = (,)
  (BoxProcess -> BoxProcess -> (BoxProcess, BoxProcess))
-> m BoxProcess -> m (BoxProcess -> (BoxProcess, BoxProcess))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> parent -> proportion -> m BoxProcess
spawnLeft parent
parentVar proportion
proportionVar
  m (BoxProcess -> (BoxProcess, BoxProcess))
-> m BoxProcess -> m (BoxProcess, BoxProcess)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> parent -> proportion -> m BoxProcess
spawnRight parent
parentVar proportion
proportionVar
  where
    spawnLeft :: parent -> proportion -> m BoxProcess
spawnLeft = (GetOutput parent -> GetOutput proportion -> Box)
-> parent -> proportion -> m BoxProcess
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 \GetOutput parent
parent GetOutput proportion
proportion ->
      let
        rightWidth :: Float
rightWidth =
          Vec2 -> (Float -> Float -> Float) -> Float
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 (Box -> Vec2
boxSize GetOutput parent
Box
parent) \Float
width Float
_height ->
            Float
width Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
width Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
GetOutput proportion
proportion
      in
        Box -> Vec4 -> Box
boxPadAbs GetOutput parent
Box
parent (Float -> Float -> Float -> Float -> Vec4
vec4 Float
0 Float
rightWidth Float
0 Float
0)

    spawnRight :: parent -> proportion -> m BoxProcess
spawnRight = (GetOutput parent -> GetOutput proportion -> Box)
-> parent -> proportion -> m BoxProcess
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 \GetOutput parent
parent GetOutput proportion
proportion ->
      let
        leftWidth :: Float
leftWidth =
          Vec2 -> (Float -> Float -> Float) -> Float
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 (Box -> Vec2
boxSize GetOutput parent
Box
parent) \Float
width Float
_height ->
            Float
width Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
GetOutput proportion
proportion
      in
        Box -> Vec4 -> Box
boxPadAbs GetOutput parent
Box
parent (Float -> Float -> Float -> Float -> Vec4
vec4 Float
0 Float
0 Float
0 Float
leftWidth)

vSplitRel
  :: ( MonadUnliftIO m
     , Worker.HasOutput parent
     , Worker.GetOutput parent ~ Box
     , Worker.HasOutput proportion
     , Worker.GetOutput proportion ~ Float
     )
  => parent
  -> proportion
  -> m (BoxProcess, BoxProcess)
vSplitRel :: forall (m :: * -> *) parent proportion.
(MonadUnliftIO m, HasOutput parent, GetOutput parent ~ Box,
 HasOutput proportion, GetOutput proportion ~ Float) =>
parent -> proportion -> m (BoxProcess, BoxProcess)
vSplitRel parent
parentVar proportion
proportionVar = (,)
  (BoxProcess -> BoxProcess -> (BoxProcess, BoxProcess))
-> m BoxProcess -> m (BoxProcess -> (BoxProcess, BoxProcess))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> parent -> proportion -> m BoxProcess
spawnTop parent
parentVar proportion
proportionVar
  m (BoxProcess -> (BoxProcess, BoxProcess))
-> m BoxProcess -> m (BoxProcess, BoxProcess)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> parent -> proportion -> m BoxProcess
spawnBottom parent
parentVar proportion
proportionVar
  where
    spawnTop :: parent -> proportion -> m BoxProcess
spawnTop = (GetOutput parent -> GetOutput proportion -> Box)
-> parent -> proportion -> m BoxProcess
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 \GetOutput parent
parent GetOutput proportion
proportion ->
      let
        bottomHeight :: Float
bottomHeight =
          Vec2 -> (Float -> Float -> Float) -> Float
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 (Box -> Vec2
boxSize GetOutput parent
Box
parent) \Float
_width Float
height ->
            Float
height Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
height Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
GetOutput proportion
proportion
      in
        Box -> Vec4 -> Box
boxPadAbs GetOutput parent
Box
parent (Float -> Float -> Float -> Float -> Vec4
vec4 Float
0 Float
0 Float
bottomHeight Float
0)

    spawnBottom :: parent -> proportion -> m BoxProcess
spawnBottom = (GetOutput parent -> GetOutput proportion -> Box)
-> parent -> proportion -> m BoxProcess
forall (m :: * -> *) i1 i2 o.
(MonadUnliftIO m, HasOutput i1, HasOutput i2) =>
(GetOutput i1 -> GetOutput i2 -> o) -> i1 -> i2 -> m (Merge o)
Worker.spawnMerge2 \GetOutput parent
parent GetOutput proportion
proportion ->
      let
        topHeight :: Float
topHeight =
          Vec2 -> (Float -> Float -> Float) -> Float
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 (Box -> Vec2
boxSize GetOutput parent
Box
parent) \Float
_width Float
height ->
            Float
height Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
GetOutput proportion
proportion
      in
        Box -> Vec4 -> Box
boxPadAbs GetOutput parent
Box
parent (Float -> Float -> Float -> Float -> Vec4
vec4 Float
topHeight Float
0 Float
0 Float
0)

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

{-# INLINEABLE boxTransformAbs #-}
boxTransformAbs :: Box -> Transform
boxTransformAbs :: Box -> Transform
boxTransformAbs Box{Vec2
boxSize :: Vec2
boxPosition :: Vec2
$sel:boxSize:Box :: Box -> Vec2
$sel:boxPosition:Box :: Box -> Vec2
..} = [Transform] -> Transform
forall a. Monoid a => [a] -> a
mconcat
  [ Vec2 -> (Float -> Float -> Transform) -> Transform
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 Vec2
boxSize Float -> Float -> Transform
Transform.scaleXY
  , Vec2 -> (Float -> Float -> Transform) -> Transform
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 Vec2
boxPosition Float -> Float -> Transform
translateXY
  ]

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

whenInBoxP
  :: ( MonadIO m
     , Worker.HasOutput box
     , Worker.GetOutput box ~ Box
     )
  => "screen" ::: Vec2
  -> box
  -> ("local" ::: Vec2 -> m ())
  -> m ()
whenInBoxP :: forall (m :: * -> *) box.
(MonadIO m, HasOutput box, GetOutput box ~ Box) =>
Vec2 -> box -> (Vec2 -> m ()) -> m ()
whenInBoxP Vec2
cursorPos box
boxP Vec2 -> m ()
action = do
  Box
box <- box -> m (GetOutput box)
forall worker (m :: * -> *).
(HasOutput worker, MonadIO m) =>
worker -> m (GetOutput worker)
Worker.getOutputData box
boxP
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Vec2 -> Box -> Bool
pointInBox Vec2
cursorPos Box
box) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Vec2 -> m ()
action (Vec2 -> m ()) -> Vec2 -> m ()
forall a b. (a -> b) -> a -> b
$ Vec2
cursorPos Vec2 -> Vec2 -> Vec2
forall a. Num a => a -> a -> a
- Box -> Vec2
boxPosition Box
box

pointInBox :: Vec2 -> Box -> Bool
pointInBox :: Vec2 -> Box -> Bool
pointInBox Vec2
point Box{Vec2
boxSize :: Vec2
boxPosition :: Vec2
$sel:boxSize:Box :: Box -> Vec2
$sel:boxPosition:Box :: Box -> Vec2
..} =
  Vec2 -> (Float -> Float -> Bool) -> Bool
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 (Vec2
point Vec2 -> Vec2 -> Vec2
forall a. Num a => a -> a -> a
- Vec2
boxPosition) \Float
px Float
py ->
    Vec2 -> (Float -> Float -> Bool) -> Bool
forall r. Vec2 -> (Float -> Float -> r) -> r
withVec2 (Vec2
boxSize Vec2 -> Vec2 -> Vec2
forall a. Fractional a => a -> a -> a
/ Vec2
2) \Float
hw Float
hh ->
      Float
px Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> -Float
hw Bool -> Bool -> Bool
&& Float
px Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
hw Bool -> Bool -> Bool
&&
      Float
py Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> -Float
hh Bool -> Bool -> Bool
&& Float
py Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
hh