module Engine.ReactiveBanana.Window where

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Engine.ReactiveBanana (eventHandler)
import Engine.Types (StageRIO)
import Engine.Types qualified as Engine
import Engine.UI.Layout qualified as Layout
import Engine.Window.CursorPos qualified as CursorPos
import Engine.Window.Drop qualified as Drop
import Engine.Window.Key qualified as Key
import Engine.Window.MouseButton qualified as MouseButton
import Engine.Window.Scroll qualified as Scroll
import Engine.Worker qualified as Worker
import Geomancy (Vec2, vec2, (^/))
import GHC.Float (double2Float)
import Reactive.Banana ((<@>), (<@>))
import Reactive.Banana qualified as RB
import Reactive.Banana.Frameworks qualified as RBF
import Vulkan.Core10 qualified as Vk

-- * Wrapped Engine.Window.* callbacks

-- | Set up a window callback to fire window "CursorPos"  events.
allocateCursorPos :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event (Double, Double)))
allocateCursorPos :: forall st.
ResourceT (StageRIO st) (MomentIO (Event (Double, Double)))
allocateCursorPos = (((Double, Double) -> RIO (App GlobalHandles st) ())
 -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st)) (MomentIO (Event (Double, Double)))
forall (m :: * -> *) (io :: * -> *) a.
(MonadResource m, MonadIO io) =>
((a -> io ()) -> m ReleaseKey) -> ResourceT m (MomentIO (Event a))
eventHandler ((((Double, Double) -> RIO (App GlobalHandles st) ())
  -> RIO (App GlobalHandles st) ReleaseKey)
 -> ResourceT
      (RIO (App GlobalHandles st)) (MomentIO (Event (Double, Double))))
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st)) (MomentIO (Event (Double, Double)))
forall a b. (a -> b) -> a -> b
$ Callback st -> RIO (App GlobalHandles st) ReleaseKey
forall st. Callback st -> StageRIO st ReleaseKey
CursorPos.callback (Callback st -> RIO (App GlobalHandles st) ReleaseKey)
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> Callback st)
-> ((Double, Double) -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double, Double) -> RIO (App GlobalHandles st) ()) -> Callback st
forall a b c. ((a, b) -> c) -> a -> b -> c
curry

-- | Set up a window callback to fire window "Drop"  events.
allocateDrop :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event [FilePath]))
allocateDrop :: forall st. ResourceT (StageRIO st) (MomentIO (Event [FilePath]))
allocateDrop = (([FilePath] -> RIO (App GlobalHandles st) ())
 -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st)) (MomentIO (Event [FilePath]))
forall (m :: * -> *) (io :: * -> *) a.
(MonadResource m, MonadIO io) =>
((a -> io ()) -> m ReleaseKey) -> ResourceT m (MomentIO (Event a))
eventHandler ([FilePath] -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ReleaseKey
forall st. Callback st -> StageRIO st ReleaseKey
Drop.callback

{- | Set up a window callback to fire window "MouseButton"  events.

To prevent clicks when hovering over some ImGui window wrap in a `RB.whenE` filter:

@
imguiCaptureMouse <- RBF.fromPoll ImGui.wantCaptureMouse
mouseButtonE <- fmap (RB.whenE $ fmap not imguiCaptureMouse) fromMouseButton
@
-}
allocateMouseButton
  :: ResourceT
      (StageRIO st)
      ( RBF.MomentIO
          ( RB.Event
            ( MouseButton.ModifierKeys
            , MouseButton.MouseButtonState
            , MouseButton.MouseButton
            )
          )
        )
allocateMouseButton :: forall st.
ResourceT
  (StageRIO st)
  (MomentIO (Event (ModifierKeys, MouseButtonState, MouseButton)))
allocateMouseButton = (((ModifierKeys, MouseButtonState, MouseButton)
  -> RIO (App GlobalHandles st) ())
 -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st))
     (MomentIO (Event (ModifierKeys, MouseButtonState, MouseButton)))
forall (m :: * -> *) (io :: * -> *) a.
(MonadResource m, MonadIO io) =>
((a -> io ()) -> m ReleaseKey) -> ResourceT m (MomentIO (Event a))
eventHandler ((ModifierKeys, MouseButtonState, MouseButton)
 -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ReleaseKey
forall st. Callback st -> StageRIO st ReleaseKey
MouseButton.callback

-- | Set up a window callback to fire window "Scroll"  events.
allocateScroll :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event (Double, Double)))
allocateScroll :: forall st.
ResourceT (StageRIO st) (MomentIO (Event (Double, Double)))
allocateScroll = (((Double, Double) -> RIO (App GlobalHandles st) ())
 -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st)) (MomentIO (Event (Double, Double)))
forall (m :: * -> *) (io :: * -> *) a.
(MonadResource m, MonadIO io) =>
((a -> io ()) -> m ReleaseKey) -> ResourceT m (MomentIO (Event a))
eventHandler ((((Double, Double) -> RIO (App GlobalHandles st) ())
  -> RIO (App GlobalHandles st) ReleaseKey)
 -> ResourceT
      (RIO (App GlobalHandles st)) (MomentIO (Event (Double, Double))))
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st)) (MomentIO (Event (Double, Double)))
forall a b. (a -> b) -> a -> b
$ Callback st -> RIO (App GlobalHandles st) ReleaseKey
forall st. Callback st -> StageRIO st ReleaseKey
Scroll.callback (Callback st -> RIO (App GlobalHandles st) ReleaseKey)
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> Callback st)
-> ((Double, Double) -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double, Double) -> RIO (App GlobalHandles st) ()) -> Callback st
forall a b c. ((a, b) -> c) -> a -> b -> c
curry

{- | Set up a window callback to fire window "Key"  events.

To prevent clicks when ImGui is busy with text input wrap in a `RB.whenE` filter:

@
imguiCaptureKeyboard <- RBF.fromPoll ImGui.wantCaptureKeyboard
keyE <- fmap (RB.whenE $ fmap not imguiCaptureKeyboard) fromKey
@
-}
allocateKey :: ResourceT (StageRIO st) (RBF.MomentIO (RB.Event (Int, (MouseButton.ModifierKeys, Key.KeyState, Key.Key))))
allocateKey :: forall st.
ResourceT
  (StageRIO st)
  (MomentIO (Event (Int, (ModifierKeys, KeyState, Key))))
allocateKey = (((Int, (ModifierKeys, KeyState, Key))
  -> RIO (App GlobalHandles st) ())
 -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st))
     (MomentIO (Event (Int, (ModifierKeys, KeyState, Key))))
forall (m :: * -> *) (io :: * -> *) a.
(MonadResource m, MonadIO io) =>
((a -> io ()) -> m ReleaseKey) -> ResourceT m (MomentIO (Event a))
eventHandler ((((Int, (ModifierKeys, KeyState, Key))
   -> RIO (App GlobalHandles st) ())
  -> RIO (App GlobalHandles st) ReleaseKey)
 -> ResourceT
      (RIO (App GlobalHandles st))
      (MomentIO (Event (Int, (ModifierKeys, KeyState, Key)))))
-> (((Int, (ModifierKeys, KeyState, Key))
     -> RIO (App GlobalHandles st) ())
    -> RIO (App GlobalHandles st) ReleaseKey)
-> ResourceT
     (RIO (App GlobalHandles st))
     (MomentIO (Event (Int, (ModifierKeys, KeyState, Key))))
forall a b. (a -> b) -> a -> b
$ Callback st -> RIO (App GlobalHandles st) ReleaseKey
forall st. Callback st -> StageRIO st ReleaseKey
Key.callback (Callback st -> RIO (App GlobalHandles st) ReleaseKey)
-> (((Int, (ModifierKeys, KeyState, Key))
     -> RIO (App GlobalHandles st) ())
    -> Callback st)
-> ((Int, (ModifierKeys, KeyState, Key))
    -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (ModifierKeys, KeyState, Key))
 -> RIO (App GlobalHandles st) ())
-> Callback st
forall a b c. ((a, b) -> c) -> a -> b -> c
curry

-- * 'Engine.UI.Layout' helpers

-- | Screen-sized layout base.
setupScreenBox
  :: (forall a. StageRIO env a -> RBF.MomentIO a)
  -> RBF.MomentIO (RB.Behavior Layout.Box)
setupScreenBox :: forall env.
(forall a. StageRIO env a -> MomentIO a) -> MomentIO (Behavior Box)
setupScreenBox forall a. StageRIO env a -> MomentIO a
unlift = do
  Behavior Extent2D
screenExtent <- StageRIO env (Var Extent2D) -> MomentIO (Var Extent2D)
forall a. StageRIO env a -> MomentIO a
unlift StageRIO env (Var Extent2D)
forall env. StageRIO env (Var Extent2D)
Engine.askScreenVar MomentIO (Var Extent2D)
-> (Var Extent2D -> MomentIO (Behavior Extent2D))
-> MomentIO (Behavior Extent2D)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    IO Extent2D -> MomentIO (Behavior Extent2D)
forall a. IO a -> MomentIO (Behavior a)
RBF.fromPoll (IO Extent2D -> MomentIO (Behavior Extent2D))
-> (Var Extent2D -> IO Extent2D)
-> Var Extent2D
-> MomentIO (Behavior Extent2D)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var Extent2D -> IO Extent2D
forall worker (m :: * -> *).
(HasOutput worker, MonadIO m) =>
worker -> m (GetOutput worker)
Worker.getOutputData

  let
    screenSize :: Behavior Vec2
screenSize =
      Behavior Extent2D
screenExtent Behavior Extent2D -> (Extent2D -> Vec2) -> Behavior Vec2
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
        \Vk.Extent2D{Word32
$sel:width:Extent2D :: Extent2D -> Word32
width :: Word32
width, Word32
$sel:height:Extent2D :: Extent2D -> Word32
height :: Word32
height} ->
          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)

    screenBox :: Behavior Box
screenBox =
      Behavior Vec2
screenSize Behavior Vec2 -> (Vec2 -> Box) -> Behavior Box
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Vec2
size ->
        Box :: Vec2 -> Vec2 -> Box
Layout.Box
          { $sel:boxPosition:Box :: Vec2
boxPosition = Vec2
0 -- XXX: since Camera.spawnOrthoPixelsCentered
          , $sel:boxSize:Box :: Vec2
boxSize     = Vec2
size
          }

  Behavior Box -> MomentIO (Behavior Box)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Behavior Box
screenBox

-- | Project window cursor position to layout.
setupCursorPos
  :: RB.MonadMoment m
  => m (RB.Event (Double, Double))
  -> RB.Behavior Layout.Box
  -> m (RB.Event Vec2, RB.Behavior Vec2)
setupCursorPos :: forall (m :: * -> *).
MonadMoment m =>
m (Event (Double, Double))
-> Behavior Box -> m (Event Vec2, Behavior Vec2)
setupCursorPos m (Event (Double, Double))
fromCursorPos Behavior Box
screenBox = do
  Event (Double, Double)
cursorPosRawE <- m (Event (Double, Double))
fromCursorPos
  let cursorPosE :: Event Vec2
cursorPosE = Box -> (Double, Double) -> Vec2
convertPos (Box -> (Double, Double) -> Vec2)
-> Behavior Box -> Behavior ((Double, Double) -> Vec2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior Box
screenBox Behavior ((Double, Double) -> Vec2)
-> Event (Double, Double) -> Event Vec2
forall a b. Behavior (a -> b) -> Event a -> Event b
<@> Event (Double, Double)
cursorPosRawE

  Behavior Vec2
cursorPos <- Vec2 -> Event Vec2 -> m (Behavior Vec2)
forall (m :: * -> *) a.
MonadMoment m =>
a -> Event a -> m (Behavior a)
RB.stepper
    (Vec2
1Vec2 -> Vec2 -> Vec2
forall a. Fractional a => a -> a -> a
/Vec2
0) -- XXX: prevent accidental flash of hover at (0, 0)
    Event Vec2
cursorPosE
  pure (Event Vec2
cursorPosE, Behavior Vec2
cursorPos)
  where
    convertPos :: Box -> (Double, Double) -> Vec2
convertPos Layout.Box{Vec2
boxSize :: Vec2
$sel:boxSize:Box :: Box -> Vec2
boxSize} (Double
cx, Double
cy) =
      -- XXX: since Camera.spawnOrthoPixelsCentered
      Float -> Float -> Vec2
vec2 (Double -> Float
double2Float Double
cx) (Double -> Float
double2Float Double
cy) Vec2 -> Vec2 -> Vec2
forall a. Num a => a -> a -> a
-
      Vec2
boxSize Vec2 -> Float -> Vec2
forall v a. VectorSpace v a => v -> a -> v
^/ Float
2

-- | Set up a per-button collection of fused (position, modifier) click ("button pressed") events.
setupMouseClicks
  :: RBF.MomentIO (RB.Event (MouseButton.ModifierKeys, MouseButton.MouseButtonState, MouseButton.MouseButton))
  -> RB.Behavior cursor
  -> RBF.MomentIO (MouseButton.Collection (RB.Event (MouseButton.ModifierKeys, cursor)))
setupMouseClicks :: forall cursor.
MomentIO (Event (ModifierKeys, MouseButtonState, MouseButton))
-> Behavior cursor
-> MomentIO (Collection (Event (ModifierKeys, cursor)))
setupMouseClicks MomentIO (Event (ModifierKeys, MouseButtonState, MouseButton))
fromMouseButton Behavior cursor
cursorPos = do

  Event (ModifierKeys, MouseButtonState, MouseButton)
mouseButtonE <- MomentIO (Event (ModifierKeys, MouseButtonState, MouseButton))
fromMouseButton

  -- XXX: Set up cursor event fusion, driven by mouseButtonE
  Collection
  (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
mouseButtons' <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA @MouseButton.Collection (Collection
   (MomentIO
      (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor)))
 -> MomentIO
      (Collection
         (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))))
-> Collection
     (MomentIO
        (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor)))
-> MomentIO
     (Collection
        (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor)))
forall a b. (a -> b) -> a -> b
$ MomentIO
  (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
-> Collection
     (MomentIO
        (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure MomentIO
  (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
forall a. MomentIO (Event a, Handler a)
RBF.newEvent

  let
    dispatchButtons :: cursor -> (ModifierKeys, MouseButtonState, MouseButton) -> IO ()
dispatchButtons cursor
pos (ModifierKeys
mods, MouseButtonState
state, MouseButton
mb) =
      MouseButtonState -> IO () -> IO ()
forall (f :: * -> *).
Applicative f =>
MouseButtonState -> f () -> f ()
MouseButton.whenPressed MouseButtonState
state (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        -- XXX: Use one event handler to drive multiple derived events
        (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
-> Handler (ModifierKeys, cursor)
forall a b. (a, b) -> b
snd (Collection
  (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
-> MouseButton
-> (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
forall a. Collection a -> MouseButton -> a
MouseButton.atGlfw Collection
  (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
mouseButtons' MouseButton
mb) (ModifierKeys
mods, cursor
pos)

  Event (IO ()) -> MomentIO ()
RBF.reactimate (Event (IO ()) -> MomentIO ()) -> Event (IO ()) -> MomentIO ()
forall a b. (a -> b) -> a -> b
$
    cursor -> (ModifierKeys, MouseButtonState, MouseButton) -> IO ()
dispatchButtons (cursor -> (ModifierKeys, MouseButtonState, MouseButton) -> IO ())
-> Behavior cursor
-> Behavior
     ((ModifierKeys, MouseButtonState, MouseButton) -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior cursor
cursorPos Behavior ((ModifierKeys, MouseButtonState, MouseButton) -> IO ())
-> Event (ModifierKeys, MouseButtonState, MouseButton)
-> Event (IO ())
forall a b. Behavior (a -> b) -> Event a -> Event b
<@> Event (ModifierKeys, MouseButtonState, MouseButton)
mouseButtonE

  pure $ ((Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
 -> Event (ModifierKeys, cursor))
-> Collection
     (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
-> Collection (Event (ModifierKeys, cursor))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
-> Event (ModifierKeys, cursor)
forall a b. (a, b) -> a
fst Collection
  (Event (ModifierKeys, cursor), Handler (ModifierKeys, cursor))
mouseButtons'