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.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 Geomancy.Layout.Box (Box(..), box_)
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) ())
 -> StageRIO st ReleaseKey)
-> ResourceT (StageRIO 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) ())
  -> StageRIO st ReleaseKey)
 -> ResourceT (StageRIO st) (MomentIO (Event (Double, Double))))
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> StageRIO st ReleaseKey)
-> ResourceT (StageRIO st) (MomentIO (Event (Double, Double)))
forall a b. (a -> b) -> a -> b
$ Callback (StageRIO st) -> StageRIO st ReleaseKey
forall rs (m :: * -> *).
MonadSink rs m =>
Callback m -> m ReleaseKey
CursorPos.callback (Callback (StageRIO st) -> StageRIO st ReleaseKey)
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> Callback (StageRIO st))
-> ((Double, Double) -> RIO (App GlobalHandles st) ())
-> StageRIO st ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double, Double) -> RIO (App GlobalHandles st) ())
-> Callback (StageRIO 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] -> StageRIO st ()) -> StageRIO st ReleaseKey)
-> ResourceT (StageRIO st) (MomentIO (Event [FilePath]))
forall (m :: * -> *) (io :: * -> *) a.
(MonadResource m, MonadIO io) =>
((a -> io ()) -> m ReleaseKey) -> ResourceT m (MomentIO (Event a))
eventHandler ([FilePath] -> StageRIO st ()) -> StageRIO st ReleaseKey
forall rs (m :: * -> *).
MonadSink rs m =>
Callback m -> m 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) -> StageRIO st ())
 -> StageRIO st ReleaseKey)
-> ResourceT
     (StageRIO 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) -> StageRIO st ())
-> StageRIO st ReleaseKey
forall rs (m :: * -> *).
MonadSink rs m =>
Callback m -> m 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) ())
 -> StageRIO st ReleaseKey)
-> ResourceT (StageRIO 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) ())
  -> StageRIO st ReleaseKey)
 -> ResourceT (StageRIO st) (MomentIO (Event (Double, Double))))
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> StageRIO st ReleaseKey)
-> ResourceT (StageRIO st) (MomentIO (Event (Double, Double)))
forall a b. (a -> b) -> a -> b
$ Callback (StageRIO st) -> StageRIO st ReleaseKey
forall rs (m :: * -> *).
MonadSink rs m =>
Callback m -> m ReleaseKey
Scroll.callback (Callback (StageRIO st) -> StageRIO st ReleaseKey)
-> (((Double, Double) -> RIO (App GlobalHandles st) ())
    -> Callback (StageRIO st))
-> ((Double, Double) -> RIO (App GlobalHandles st) ())
-> StageRIO st ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double, Double) -> RIO (App GlobalHandles st) ())
-> Callback (StageRIO 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) ())
 -> StageRIO st ReleaseKey)
-> ResourceT
     (StageRIO 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) ())
  -> StageRIO st ReleaseKey)
 -> ResourceT
      (StageRIO st)
      (MomentIO (Event (Int, (ModifierKeys, KeyState, Key)))))
-> (((Int, (ModifierKeys, KeyState, Key))
     -> RIO (App GlobalHandles st) ())
    -> StageRIO st ReleaseKey)
-> ResourceT
     (StageRIO st)
     (MomentIO (Event (Int, (ModifierKeys, KeyState, Key))))
forall a b. (a -> b) -> a -> b
$ Callback (StageRIO st) -> StageRIO st ReleaseKey
forall rs (m :: * -> *).
MonadSink rs m =>
Callback m -> m ReleaseKey
Key.callback (Callback (StageRIO st) -> StageRIO st ReleaseKey)
-> (((Int, (ModifierKeys, KeyState, Key))
     -> RIO (App GlobalHandles st) ())
    -> Callback (StageRIO st))
-> ((Int, (ModifierKeys, KeyState, Key))
    -> RIO (App GlobalHandles st) ())
-> StageRIO st ReleaseKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (ModifierKeys, KeyState, Key))
 -> RIO (App GlobalHandles st) ())
-> Callback (StageRIO 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 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 st (m :: * -> *).
MonadReader (App GlobalHandles st) m =>
m (Var Extent2D)
Engine.askScreenVar MomentIO (Var Extent2D)
-> (Var Extent2D -> MomentIO (Behavior Extent2D))
-> MomentIO (Behavior Extent2D)
forall a b. MomentIO a -> (a -> MomentIO b) -> MomentIO b
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
Var Extent2D -> IO (GetOutput (Var 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
width :: Word32
$sel:width:Extent2D :: Extent2D -> Word32
width, Word32
height :: Word32
$sel:height:Extent2D :: Extent2D -> 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 =
      -- XXX: since Camera.spawnOrthoPixelsCentered
      (Vec2 -> Box) -> Behavior Vec2 -> Behavior Box
forall a b. (a -> b) -> Behavior a -> Behavior b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vec2 -> Box
box_ Behavior Vec2
screenSize

  Behavior Box -> MomentIO (Behavior Box)
forall a. a -> MomentIO a
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 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 Box{Vec2
size :: Vec2
size :: Box -> Vec2
size} (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
size 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 a. a -> Collection a
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 a b. (a -> b) -> Collection a -> Collection b
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'