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
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
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
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
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
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
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
, $sel:boxSize:Box :: Vec2
boxSize = Vec2
size
}
Behavior Box -> MomentIO (Behavior Box)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Behavior Box
screenBox
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)
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) =
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
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
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
$
(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'