From d81c62adbc955855438f1626c685e92794017d2d Mon Sep 17 00:00:00 2001
From: 3gg <3gg@shellblade.net>
Date: Sun, 18 Sep 2022 17:18:03 -0700
Subject: Add App module.

---
 Spear.cabal           |   3 +-
 Spear/App.hs          |  62 +++++++++++++++++++++
 Spear/Window.hs       | 147 ++++++++++++++++----------------------------------
 demos/pong/Main.hs    |  15 +++---
 demos/pong/Pong.hs    |  46 +++++++++-------
 demos/pong/pong.cabal |   2 +-
 6 files changed, 146 insertions(+), 129 deletions(-)
 create mode 100644 Spear/App.hs

diff --git a/Spear.cabal b/Spear.cabal
index 4c75dd8..07894c4 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -28,7 +28,8 @@ library
                    vector -any,
                    array -any
 
-    exposed-modules: Spear.Assets.Image
+    exposed-modules: Spear.App
+                     Spear.Assets.Image
                      Spear.Assets.Model
                      Spear.Game
                      Spear.GL
diff --git a/Spear/App.hs b/Spear/App.hs
new file mode 100644
index 0000000..dc17dec
--- /dev/null
+++ b/Spear/App.hs
@@ -0,0 +1,62 @@
+module Spear.App
+  ( Elapsed,
+    Dt,
+    Step,
+    loop,
+  )
+where
+
+import Control.Monad
+import GHC.Float
+import Spear.Game
+import Spear.Sys.Timer as Timer
+import Spear.Window
+
+maxFPS = 60
+
+-- | Time elapsed since the application started.
+type Elapsed = Double
+
+-- | Time elapsed since the last frame.
+type Dt = Float
+
+-- | Return true if the application should continue running, false otherwise.
+type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool
+
+-- | Enter the main application loop.
+loop :: Step s -> Window -> Game s ()
+loop step window = do
+  let ddt = 1.0 / fromIntegral maxFPS -- Desired delta time.
+  frameTimer <- gameIO $ start newTimer
+  controlTimer <- gameIO $ start newTimer
+  loop' window ddt frameTimer controlTimer 0 step
+  return ()
+
+loop' ::
+  Window ->
+  Dt ->
+  Timer ->
+  Timer ->
+  Elapsed ->
+  Step s ->
+  Game s ()
+loop' window ddt frameTimer controlTimer elapsed step = do
+  controlTimer' <- gameIO $ tick controlTimer
+  frameTimer' <- gameIO $ tick frameTimer
+  let dt = getDelta frameTimer'
+  let elapsed' = elapsed + float2Double dt
+  inputEvents <- gameIO $ pollEvents window
+  continue <- step elapsed' dt inputEvents
+  gameIO $ swapBuffers window
+  close <- gameIO $ shouldWindowClose window
+  controlTimer'' <- gameIO $ tick controlTimer'
+  let dt = getDelta controlTimer''
+  when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt)
+  when (continue && not close) $
+    loop'
+      window
+      ddt
+      frameTimer'
+      controlTimer''
+      elapsed'
+      step
diff --git a/Spear/Window.hs b/Spear/Window.hs
index 85a3dc8..a6471b0 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -3,7 +3,6 @@ module Spear.Window
     Dimensions,
     Context,
     WindowTitle,
-    FrameCap,
 
     -- * Window
     Window,
@@ -11,14 +10,9 @@ module Spear.Window
     Height,
     Init,
     withWindow,
-    events,
-
-    -- * Animation
-    Elapsed,
-    Dt,
-    Step,
-    loop,
-    GLFW.swapBuffers,
+    pollEvents,
+    shouldWindowClose,
+    swapBuffers,
 
     -- * Input
     whenKeyDown,
@@ -37,16 +31,9 @@ where
 import Control.Concurrent.MVar
 import Control.Exception
 import Control.Monad (foldM, unless, void, when)
-import Control.Monad.IO.Class
-import Data.Char (ord)
 import Data.Maybe (fromJust, fromMaybe, isJust)
-import GHC.Float
-import qualified Graphics.Rendering.OpenGL as GL
 import qualified Graphics.UI.GLFW as GLFW
 import Spear.Game
-import Spear.Sys.Timer as Timer
-
-maxFPS = 60
 
 type Width = Int
 
@@ -55,13 +42,21 @@ type Height = Int
 -- | Window dimensions.
 type Dimensions = (Width, Height)
 
--- | A tuple specifying the desired OpenGL context, of the form (Major, Minor).
+-- | A pair specifying the desired OpenGL context, of the form (Major, Minor).
 type Context = (Int, Int)
 
 type WindowTitle = String
 
 type CloseRequest = MVar Bool
 
+-- | Game initialiser.
+type Init s = Window -> Game () s
+
+-- | Window exception.
+newtype WindowException = WindowException String deriving (Show)
+
+instance Exception WindowException
+
 -- | A window.
 data Window = Window
   { glfwWindow :: GLFW.Window,
@@ -69,19 +64,6 @@ data Window = Window
     inputEvents :: MVar [InputEvent]
   }
 
--- | Poll the window's events.
-events :: MonadIO m => Window -> m [InputEvent]
-events window = liftIO $ do
-  es <-
-    tryTakeMVar (inputEvents window) >>= \xs -> case xs of
-      Nothing -> return []
-      Just es -> return es
-  putMVar (inputEvents window) []
-  return es
-
--- | Game initialiser.
-type Init s = Window -> Game () s
-
 withWindow ::
   Dimensions ->
   Context ->
@@ -91,8 +73,10 @@ withWindow ::
   IO a
 withWindow dim@(w, h) glVersion windowTitle init run = do
   flip runGame' () $ do
-    glfwInit
-    window <- setup dim glVersion windowTitle
+    window <- gameIO $ do
+      success <- GLFW.init
+      unless success $ throw (WindowException "GLFW.initialize failed")
+      setup dim glVersion windowTitle
     gameIO $ GLFW.makeContextCurrent (Just . glfwWindow $ window)
     gameState <- init window
     result <- evalSubGame (run window) gameState
@@ -105,86 +89,47 @@ setup ::
   Dimensions ->
   Context ->
   Maybe WindowTitle ->
-  Game s Window
+  IO Window
 setup (w, h) (major, minor) windowTitle = do
-  closeRequest <- gameIO newEmptyMVar
-  inputEvents <- gameIO newEmptyMVar
+  closeRequest <- newEmptyMVar
+  inputEvents <- newEmptyMVar
   let onResize' = onResize inputEvents
   let title = fromMaybe "" windowTitle
   let monitor = Nothing
-  maybeWindow <- gameIO $ do
+  maybeWindow <- do
     GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major
     GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor
     when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Compat
     GLFW.createWindow w h title monitor Nothing
-  unless (isJust maybeWindow) $ gameError "GLFW.openWindow failed"
+  unless (isJust maybeWindow) $ throwIO (WindowException "GLFW.openWindow failed")
   let window = fromJust maybeWindow
-  liftIO $ do
-    GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest
-    GLFW.setWindowSizeCallback window . Just $ onResize'
-    GLFW.setKeyCallback window . Just $ onKey inputEvents
-    GLFW.setCharCallback window . Just $ onChar inputEvents
-    GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents
-    onMouseMove inputEvents >>= GLFW.setCursorPosCallback window . Just
-    onResize' window w h
+  GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest
+  GLFW.setWindowSizeCallback window . Just $ onResize'
+  GLFW.setKeyCallback window . Just $ onKey inputEvents
+  GLFW.setCharCallback window . Just $ onChar inputEvents
+  GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents
+  onMouseMove inputEvents >>= GLFW.setCursorPosCallback window . Just
+  onResize' window w h
   return $ Spear.Window.Window window closeRequest inputEvents
 
-glfwInit :: Game s ()
-glfwInit = do
-  result <- gameIO GLFW.init
-  if result then return () else gameError "GLFW.initialize failed"
-
--- | Time elapsed since the application started.
-type Elapsed = Double
-
--- | Time elapsed since the last frame.
-type Dt = Float
-
--- | Return true if the application should continue running, false otherwise.
-type Step s = Elapsed -> Dt -> Game s Bool
-
--- | Maximum frame rate.
-type FrameCap = Int
-
-loop :: Step s -> Window -> Game s ()
-loop step window = do
-  let ddt = 1.0 / fromIntegral maxFPS
-      closeReq = closeRequest window
-  frameTimer <- gameIO $ start newTimer
-  controlTimer <- gameIO $ start newTimer
-  loop' window closeReq ddt frameTimer controlTimer 0 step
-  return ()
-
-loop' ::
-  Window ->
-  CloseRequest ->
-  Float ->
-  Timer ->
-  Timer ->
-  Elapsed ->
-  Step s ->
-  Game s ()
-loop' window closeRequest ddt frameTimer controlTimer elapsed step = do
-  controlTimer' <- gameIO $ tick controlTimer
-  frameTimer' <- gameIO $ tick frameTimer
-  let dt = getDelta frameTimer'
-  let elapsed' = elapsed + float2Double dt
-  gameIO GLFW.pollEvents
-  continue <- step elapsed' dt
-  gameIO . GLFW.swapBuffers $ glfwWindow window
-  close <- gameIO $ getRequest closeRequest
-  controlTimer'' <- gameIO $ tick controlTimer'
-  let dt = getDelta controlTimer''
-  when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt)
-  when (continue && not close) $
-    loop'
-      window
-      closeRequest
-      ddt
-      frameTimer'
-      controlTimer''
-      elapsed'
-      step
+-- | Poll the window's events.
+pollEvents :: Window -> IO [InputEvent]
+pollEvents window = do
+  GLFW.pollEvents
+  events <-
+    tryTakeMVar (inputEvents window) >>= \xs -> case xs of
+      Nothing -> return []
+      Just events -> return events
+  putMVar (inputEvents window) []
+  return events
+
+-- | Return true when the user requests to close the window.
+shouldWindowClose :: Window -> IO Bool
+shouldWindowClose = getRequest . closeRequest
+
+-- | Swaps buffers.
+swapBuffers :: Window -> IO ()
+swapBuffers = GLFW.swapBuffers . glfwWindow
 
 getRequest :: MVar Bool -> IO Bool
 getRequest mvar =
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs
index 3563c30..a9dfcdd 100644
--- a/demos/pong/Main.hs
+++ b/demos/pong/Main.hs
@@ -4,6 +4,7 @@ import Data.Maybe (mapMaybe)
 import Graphics.Rendering.OpenGL.GL (($=))
 import qualified Graphics.Rendering.OpenGL.GL as GL
 import Pong
+import Spear.App
 import Spear.Game
 import Spear.Math.AABB
 import Spear.Math.Spatial2
@@ -27,19 +28,17 @@ initGame window = do
     GL.loadIdentity
   return $ GameState window newWorld
 
-step :: Elapsed -> Dt -> Game GameState Bool
-step elapsed dt = do
-  --gameIO $ putStrLn "Tick"
+step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
+step elapsed dt inputEvents = do
   gs <- getGameState
-  evts <- events (window gs)
-  gameIO . process $ evts
-  let evts' = translate evts
+  gameIO . process $ inputEvents
+  let events = translate inputEvents
   modifyGameState $ \gs ->
     gs
-      { world = stepWorld elapsed dt evts' (world gs)
+      { world = stepWorld elapsed dt events (world gs)
       }
   getGameState >>= \gs -> gameIO . render $ world gs
-  return (not $ exitRequested evts)
+  return (not $ exitRequested inputEvents)
 
 render world = do
   GL.clear [GL.ColorBuffer]
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs
index 232c69a..906e89b 100644
--- a/demos/pong/Pong.hs
+++ b/demos/pong/Pong.hs
@@ -14,6 +14,22 @@ import Spear.Math.Spatial2
 import Spear.Math.Vector
 import Spear.Step
 
+-- Configuration
+
+padSize = vec2 0.05 0.02
+
+ballSize = 0.01
+
+ballVelocity = vec2 0.3 0.3
+
+playerSpeed = 0.7
+
+initialEnemyPos = vec2 0.5 0.9
+
+initialPlayerPos = vec2 0.5 0.1
+
+initialBallPos = vec2 0.5 0.5
+
 -- Game events
 
 data GameEvent
@@ -43,21 +59,16 @@ update elapsed dt evts gos go =
   let (go', s') = runStep (gostep go) elapsed dt gos evts go
    in go' {gostep = s'}
 
-ballBox :: AABB2
-ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01
-
-padSize = vec2 0.05 0.02
-
+ballBox, padBox :: AABB2
+ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = ballSize
 padBox = AABB2 (- padSize) padSize
 
-obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
-
-ballVelocity = Vector2 0.3 0.3
+obj2 = obj2FromVectors unitx2 unity2
 
 newWorld =
-  [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity,
-    GameObject padBox (obj2 0.5 0.9) stepEnemy,
-    GameObject padBox (obj2 0.5 0.1) stepPlayer
+  [ GameObject ballBox (obj2 initialBallPos) $ stepBall ballVelocity,
+    GameObject padBox (obj2 initialEnemyPos) stepEnemy,
+    GameObject padBox (obj2 initialPlayerPos) stepPlayer
   ]
 
 -- Ball steppers
@@ -110,8 +121,8 @@ stepPlayer = sfold moveGO .> clamp
 
 moveGO =
   mconcat
-    [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0),
-      switch StopRight sid MoveRight (moveGO' $ vec2 1 0)
+    [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (- playerSpeed) 0),
+      switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0)
     ]
 
 moveGO' :: Vector2 -> Step s e GameObject GameObject
@@ -121,10 +132,9 @@ clamp :: Step s e GameObject GameObject
 clamp = spure $ \go ->
   let p' = vec2 (clamp' x s (1 - s)) y
       (Vector2 x y) = pos go
-      clamp' x a b = if x < a then a else if x > b then b else x
+      clamp' x a b
+        | x < a = a
+        | x > b = b
+        | otherwise = x
       (Vector2 s _) = padSize
    in setPos p' go
-
-toDir True MoveLeft = vec2 (-1) 0
-toDir True MoveRight = vec2 1 0
-toDir _ _ = vec2 0 0
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal
index 23ada51..aec96ee 100644
--- a/demos/pong/pong.cabal
+++ b/demos/pong/pong.cabal
@@ -17,5 +17,5 @@ cabal-version:       >=1.8
 executable pong
   -- hs-source-dirs:      src
   main-is:             Main.hs
-  -- other-modules:
+  other-modules:       Pong
   build-depends:       base, Spear, OpenGL
-- 
cgit v1.2.3