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.

---
 demos/pong/Main.hs    | 15 +++++++--------
 demos/pong/Pong.hs    | 46 ++++++++++++++++++++++++++++------------------
 demos/pong/pong.cabal |  2 +-
 3 files changed, 36 insertions(+), 27 deletions(-)

(limited to 'demos')

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