From 678a4631a36b55face6541c473d5dfb854225547 Mon Sep 17 00:00:00 2001
From: 3gg <3gg@shellblade.net>
Date: Thu, 15 Aug 2024 22:49:21 -0700
Subject: Better event handling.

---
 Demos/Pong/Main.hs | 16 +++++++++-------
 Demos/Pong/Pong.hs | 13 +++++--------
 Spear/App.hs       |  2 ++
 Spear/Step.hs      | 41 ++++++++++++++++++-----------------------
 Spear/Window.hs    | 36 ++++++++++++++++++------------------
 5 files changed, 52 insertions(+), 56 deletions(-)

diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index c768142..ee55622 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -14,6 +14,7 @@ import           Spear.Render.Core.State
 import           Spear.Render.Immediate
 import           Spear.Window
 
+import           Control.Monad              (when)
 import           Data.Maybe                 (mapMaybe)
 
 
@@ -44,7 +45,8 @@ endGame = do
 step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
 step elapsed dt inputEvents = do
   gs <- getGameState
-  let events = translateEvents inputEvents
+  events <- processInput (window gs)
+  --when (events /= []) $ gameIO . putStrLn $ show events
   modifyGameState $ \gs ->
     gs
       { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
@@ -112,11 +114,11 @@ resize (ResizeEvent w h) =
       viewProjection = Matrix4.ortho left right bottom top (-1) 1
     }
 
-translateEvents = mapMaybe translateEvents'
-  where translateEvents' (KeyDown KEY_A) = Just MoveLeft
-        translateEvents' (KeyDown KEY_D) = Just MoveRight
-        translateEvents' (KeyUp KEY_A)   = Just StopLeft
-        translateEvents' (KeyUp KEY_D)   = Just StopRight
-        translateEvents' _               = Nothing
+
+processInput :: Window -> Game GameState [GameEvent]
+processInput window = processKeys window
+  [ (KEY_A, MoveLeft)
+  , (KEY_D, MoveRight)
+  ]
 
 exitRequested = elem (KeyDown KEY_ESC)
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs
index 943682f..2bd9df1 100644
--- a/Demos/Pong/Pong.hs
+++ b/Demos/Pong/Pong.hs
@@ -40,9 +40,7 @@ initialBallPos      = vec2 0.5 0.5
 data GameEvent
   = MoveLeft
   | MoveRight
-  | StopLeft
-  | StopRight
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 -- Game objects
 
@@ -163,11 +161,10 @@ movePad = step $ \elapsed _ _ _ pad ->
 
 stepPlayer = sfold moveGO .> clamp
 
-moveGO =
-  mconcat
-    [ switch StopLeft  sid MoveLeft  (moveGO' $ vec2 (-playerSpeed) 0),
-      switch StopRight sid MoveRight (moveGO' $ vec2   playerSpeed  0)
-    ]
+moveGO = mconcat
+  [ swhen MoveLeft  $ moveGO' (vec2 (-playerSpeed) 0)
+  , swhen MoveRight $ moveGO' (vec2   playerSpeed  0)
+  ]
 
 moveGO' :: Vector2 -> Step s e GameObject GameObject
 moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir)
diff --git a/Spear/App.hs b/Spear/App.hs
index 1a0095b..b0c7141 100644
--- a/Spear/App.hs
+++ b/Spear/App.hs
@@ -62,6 +62,8 @@ loop' window ddt inputTimer elapsed timeBudget app = do
   let timeBudgetThisFrame = timeBudget + deltaTime timer
   let steps = timeBudgetThisFrame `div` ddt
 
+  --gameIO . putStrLn $ "Steps: " ++ show steps
+
   continue <- and <$> forM [1..steps] (\i -> do
     let t  = timeDeltaToSec $ elapsed + i * ddt
     let dt = timeDeltaToSec ddt
diff --git a/Spear/Step.hs b/Spear/Step.hs
index cb4f71c..e767166 100644
--- a/Spear/Step.hs
+++ b/Spear/Step.hs
@@ -21,6 +21,7 @@ module Spear.Step
     (.>),
     (<.),
     szip,
+    swhen,
     switch,
     multiSwitch,
   )
@@ -36,8 +37,8 @@ type Elapsed = Float
 type Dt = Float
 
 -- | A step function.
-newtype Step state events input a = Step
-  { runStep :: Elapsed -> Dt -> state -> events -> input -> (a, Step state events input a)
+newtype Step state events a b = Step
+  { runStep :: Elapsed -> Dt -> state -> events -> a -> (b, Step state events a b)
   }
 
 instance Functor (Step s e a) where
@@ -73,29 +74,12 @@ ssnd = spure snd
 
 -- | Construct a step that folds a given list of inputs.
 --
--- The step is run N+1 times, where N is the size of the input list.
+-- The step is run once per input, or not at all if the list is empty.
 sfold :: Step s (Maybe e) a a -> Step s [e] a a
 sfold s = Step $ \elapsed dt g es a ->
-  case es of
-    [] ->
-      let (b', s') = runStep s elapsed dt g Nothing a
-       in (b', sfold s')
-    es ->
-      let (b', s') = sfold' elapsed dt g s a es
-       in (b', sfold s')
-
-sfold' ::
-  Elapsed ->
-  Dt ->
-  s ->
-  Step s (Maybe e) a a ->
-  a ->
-  [e] ->
-  (a, Step s (Maybe e) a a)
-sfold' elapsed dt g s a = foldl' f (a', s')
-  where
-    f (a, s) e = runStep s elapsed dt g (Just e) a
-    (a', s') = runStep s elapsed dt g Nothing a
+  let (a', s')   = foldl' f (a, s) es
+      f (a, s) e = runStep s elapsed dt g (Just e) a
+  in (a', sfold s')
 
 -- Combinators
 
@@ -117,6 +101,17 @@ szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d ->
       (b, s2') = s2 elapsed dt g e d
    in (f a b, szip f s1' s2')
 
+-- | Construct a step that is executed when the given event occurs.
+swhen :: Eq e => e -> Step s () a a -> Step s (Maybe e) a a
+swhen expectedEvent step = Step $ \elapsed dt state maybeEvent a ->
+  case maybeEvent of
+    Nothing -> (a, swhen expectedEvent step)
+    Just event ->
+      if event == expectedEvent
+      then let (a', step') = runStep step elapsed dt state () a
+             in (a', swhen expectedEvent step')
+      else (a, swhen expectedEvent step)
+
 -- | Construct a step that switches between two steps based on input.
 --
 -- The initial step is the first one.
diff --git a/Spear/Window.hs b/Spear/Window.hs
index 20d7acc..be52080 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -183,12 +183,12 @@ onResize windowEvents window w h = modifyMVar_ windowEvents (return <$> const [R
 
 onKey :: MVar [InputEvent] -> GLFW.KeyCallback
 onKey events window key _ GLFW.KeyState'Pressed   _ = addEvent events $ KeyDown (fromGLFWkey key)
-onKey events window key _ GLFW.KeyState'Released  _ = addEvent events $ KeyUp (fromGLFWkey key)
+onKey events window key _ GLFW.KeyState'Released  _ = addEvent events $ KeyUp   (fromGLFWkey key)
 onKey events window key _ GLFW.KeyState'Repeating _ = return ()
 
 onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback
-onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button)
-onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button)
+onMouseButton events window button GLFW.MouseButtonState'Pressed _  = addEvent events $ MouseDown (fromGLFWbutton button)
+onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp   (fromGLFWbutton button)
 
 onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback
 onMouseMove oldPos events window x y = do
@@ -206,45 +206,45 @@ replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val
 addEvent :: MVar [a] -> a -> IO ()
 addEvent mvar val =
   tryTakeMVar mvar >>= \xs -> case xs of
-    Nothing     -> putMVar mvar [val]
-    Just events -> putMVar mvar (val : events)
+    Nothing     -> putMVar mvar [val] -- >> (putStrLn $ show val)
+    Just events -> putMVar mvar (val : events) -- >> (putStrLn $ show (val:events))
 
 -- Input
 
 -- | Run the game action when the key is down.
 whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s ()
-whenKeyDown = whenKeyInState (== GLFW.KeyState'Pressed)
+whenKeyDown = whenKeyInState GLFW.KeyState'Pressed
 
 -- | Run the game action when the key is up.
 whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s ()
-whenKeyUp = whenKeyInState (== GLFW.KeyState'Released)
+whenKeyUp = whenKeyInState GLFW.KeyState'Released
 
-whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s ()
-whenKeyInState pred window key game = do
-  isDown <- fmap pred $ gameIO . GLFW.getKey window . toGLFWkey $ key
+whenKeyInState :: GLFW.KeyState -> GLFW.Window -> Key -> Game s a -> Game s ()
+whenKeyInState state window key game = do
+  isDown <- fmap (==state) $ gameIO . GLFW.getKey window . toGLFWkey $ key
   when isDown $ void game
 
--- | Process the keyboard keys, returning those values for which their
--- corresponding key is pressed.
-processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a]
+-- | Check whether the given keys are pressed and return the value associated
+-- with each of the pressed keys.
+processKeys :: Window -> [(Key, a)] -> Game s [a]
 processKeys window = foldM f []
   where
     f acc (key, result) = do
       isDown <-
         fmap (== GLFW.KeyState'Pressed) $
-          gameIO . GLFW.getKey window . toGLFWkey $
+          gameIO . GLFW.getKey (glfwWindow window) . toGLFWkey $
             key
       return $ if isDown then result : acc else acc
 
--- | Process the mouse buttons, returning those values for which their
--- corresponding button is pressed.
-processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a]
+-- | Check whether the given buttons are pressed and return the value associated
+-- with each of the pressed buttons.
+processButtons :: Window -> [(MouseButton, a)] -> Game s [a]
 processButtons window = foldM f []
   where
     f acc (button, result) = do
       isDown <-
         fmap (== GLFW.MouseButtonState'Pressed) $
-          gameIO . GLFW.getMouseButton window . toGLFWbutton $
+          gameIO . GLFW.getMouseButton (glfwWindow window) . toGLFWbutton $
             button
       return $ if isDown then result : acc else acc
 
-- 
cgit v1.2.3