From 6e26564f4235eeea5dda386282e18081db6f8f07 Mon Sep 17 00:00:00 2001
From: 3gg <3gg@shellblade.net>
Date: Fri, 10 Mar 2023 09:03:32 -0800
Subject: Compile demos with main project.

---
 Demos/Pong/Main.hs  |  83 ++++++++++++++++++++++++++++++
 Demos/Pong/Pong.hs  | 142 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 Demos/Pong/Setup.hs |   3 ++
 Spear.cabal         |   2 +-
 demos/pong/Main.hs  |  81 ------------------------------
 demos/pong/Pong.hs  | 141 ---------------------------------------------------
 demos/pong/Setup.hs |   3 --
 7 files changed, 229 insertions(+), 226 deletions(-)
 create mode 100644 Demos/Pong/Main.hs
 create mode 100644 Demos/Pong/Pong.hs
 create mode 100644 Demos/Pong/Setup.hs
 delete mode 100644 demos/pong/Main.hs
 delete mode 100644 demos/pong/Pong.hs
 delete mode 100644 demos/pong/Setup.hs

diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
new file mode 100644
index 0000000..4dbe0a3
--- /dev/null
+++ b/Demos/Pong/Main.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Main where
+
+import Data.Maybe (mapMaybe)
+import Graphics.Rendering.OpenGL.GL (($=))
+import Graphics.Rendering.OpenGL.GL qualified as GL
+import Pong
+import Spear.App
+import Spear.Game
+import Spear.Math.AABB
+import Spear.Math.Spatial2
+import Spear.Math.Vector
+import Spear.Window
+
+data GameState = GameState
+  { window :: Window,
+    world :: [GameObject]
+  }
+
+main =
+  withWindow (900, 600) (2, 0) (Just "Pong") initGame $
+    loop step
+
+initGame :: Window -> Game () GameState
+initGame window = do
+  gameIO $ do
+    GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0
+    GL.matrixMode $= GL.Modelview 0
+    GL.loadIdentity
+  return $ GameState window newWorld
+
+step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
+step elapsed dt inputEvents = do
+  gs <- getGameState
+  gameIO . process $ inputEvents
+  let events = translate inputEvents
+  modifyGameState $ \gs ->
+    gs
+      { world = stepWorld elapsed dt events (world gs)
+      }
+  getGameState >>= \gs -> gameIO . render $ world gs
+  return (not $ exitRequested inputEvents)
+
+render world = do
+  GL.clear [GL.ColorBuffer]
+  mapM_ renderGO world
+
+renderGO :: GameObject -> IO ()
+renderGO go = do
+  let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
+      (Vector2 xcenter ycenter) = pos go
+      (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
+  GL.preservingMatrix $ do
+    GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
+    GL.renderPrimitive (GL.TriangleStrip) $ do
+      GL.vertex (GL.Vertex2 xmin ymax)
+      GL.vertex (GL.Vertex2 xmin ymin)
+      GL.vertex (GL.Vertex2 xmax ymax)
+      GL.vertex (GL.Vertex2 xmax ymin)
+
+process = mapM_ procEvent
+
+procEvent (Resize w h) = do
+  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
+  GL.matrixMode $= GL.Projection
+  GL.loadIdentity
+  GL.ortho 0 1 0 1 (-1) 1
+  GL.matrixMode $= GL.Modelview 0
+procEvent _ = return ()
+
+translate = mapMaybe translate'
+
+translate' (KeyDown KEY_LEFT) = Just MoveLeft
+translate' (KeyDown KEY_RIGHT) = Just MoveRight
+translate' (KeyUp KEY_LEFT) = Just StopLeft
+translate' (KeyUp KEY_RIGHT) = Just StopRight
+translate' _ = Nothing
+
+exitRequested = any (== (KeyDown KEY_ESC))
+
+f2d :: Float -> GL.GLdouble
+f2d = realToFrac
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs
new file mode 100644
index 0000000..b048bbc
--- /dev/null
+++ b/Demos/Pong/Pong.hs
@@ -0,0 +1,142 @@
+module Pong
+  ( GameEvent (..),
+    GameObject,
+    newWorld,
+    stepWorld,
+    aabb,
+  )
+where
+
+import Data.Monoid (mconcat)
+import GHC.Float (double2Float)
+import Spear.Math.AABB
+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
+  = MoveLeft
+  | MoveRight
+  | StopLeft
+  | StopRight
+  deriving (Eq, Ord)
+
+-- Game objects
+
+data GameObject = GameObject
+  { aabb :: AABB2,
+    obj :: Obj2,
+    gostep :: Step [GameObject] [GameEvent] GameObject GameObject
+  }
+
+instance Spatial2 GameObject where
+  getObj2 = obj
+  setObj2 s o = s {obj = o}
+
+stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
+stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
+
+update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
+update elapsed dt evts gos go =
+  let (go', s') = runStep (gostep go) elapsed dt gos evts go
+   in go' {gostep = s'}
+
+ballBox, padBox :: AABB2
+ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
+padBox = AABB2 (-padSize) padSize
+
+obj2 = obj2FromVectors unitx2 unity2
+
+newWorld =
+  [ GameObject ballBox (obj2 initialBallPos) $ stepBall ballVelocity,
+    GameObject padBox (obj2 initialEnemyPos) stepEnemy,
+    GameObject padBox (obj2 initialPlayerPos) stepPlayer
+  ]
+
+-- Ball steppers
+
+stepBall vel = collideBall vel .> moveBall
+
+collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
+collideBall vel = step $ \_ dt gos _ ball ->
+  let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
+      collideCol = x pmin < 0 || x pmax > 1
+      collideRow = y pmin < 0 || y pmax > 1 || any (collide ball) (tail gos)
+      negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v
+      negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v
+      vel' = negx . negy $ vel
+      delta = dt -- A small delta to apply when collision occurs.
+      adjustX = if collideCol then scale delta (vec2 (x vel) 0) else vec2 0 0
+      adjustY = if collideRow then scale delta (vec2 0 (y vel)) else vec2 0 0
+   in ((vel' + adjustX + adjustY, ball), collideBall vel')
+
+collide go1 go2 =
+  let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
+        aabb go1 `aabbAdd` pos go1
+      (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
+        aabb go2 `aabbAdd` pos go2
+   in not $
+        xmax1 < xmin2
+          || xmin1 > xmax2
+          || ymax1 < ymin2
+          || ymin1 > ymax2
+
+aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)
+
+moveBall :: Step s e (Vector2, GameObject) GameObject
+moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)
+
+-- Enemy stepper
+
+stepEnemy = movePad
+
+movePad :: Step s e GameObject GameObject
+movePad = step $ \elapsed _ _ _ pad ->
+  let p = vec2 px 0.9
+      px =
+        double2Float (sin elapsed * 0.5 + 0.5)
+          * (1 - 2 * x padSize)
+          + x padSize
+   in (setPos p pad, movePad)
+
+-- Player stepper
+
+stepPlayer = sfold moveGO .> clamp
+
+moveGO =
+  mconcat
+    [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0),
+      switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0)
+    ]
+
+moveGO' :: Vector2 -> Step s e GameObject GameObject
+moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)
+
+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
+        | x < a = a
+        | x > b = b
+        | otherwise = x
+      (Vector2 s _) = padSize
+   in setPos p' go
diff --git a/Demos/Pong/Setup.hs b/Demos/Pong/Setup.hs
new file mode 100644
index 0000000..e8ef27d
--- /dev/null
+++ b/Demos/Pong/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
diff --git a/Spear.cabal b/Spear.cabal
index 81ca38a..824f352 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -117,7 +117,7 @@ library
     ghc-prof-options: -O2 -fprof-auto -fprof-cafs
 
 executable pong
-  hs-source-dirs:      demos/pong
+  hs-source-dirs:      Demos/Pong
   main-is:             Main.hs
   other-modules:       Pong
   build-depends:       base, Spear, OpenGL
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs
deleted file mode 100644
index a9dfcdd..0000000
--- a/demos/pong/Main.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-module Main where
-
-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
-import Spear.Math.Vector
-import Spear.Window
-
-data GameState = GameState
-  { window :: Window,
-    world :: [GameObject]
-  }
-
-main =
-  withWindow (900, 600) (2, 0) (Just "Pong") initGame $
-    loop step
-
-initGame :: Window -> Game () GameState
-initGame window = do
-  gameIO $ do
-    GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0
-    GL.matrixMode $= GL.Modelview 0
-    GL.loadIdentity
-  return $ GameState window newWorld
-
-step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
-step elapsed dt inputEvents = do
-  gs <- getGameState
-  gameIO . process $ inputEvents
-  let events = translate inputEvents
-  modifyGameState $ \gs ->
-    gs
-      { world = stepWorld elapsed dt events (world gs)
-      }
-  getGameState >>= \gs -> gameIO . render $ world gs
-  return (not $ exitRequested inputEvents)
-
-render world = do
-  GL.clear [GL.ColorBuffer]
-  mapM_ renderGO world
-
-renderGO :: GameObject -> IO ()
-renderGO go = do
-  let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
-      (Vector2 xcenter ycenter) = pos go
-      (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
-  GL.preservingMatrix $ do
-    GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
-    GL.renderPrimitive (GL.TriangleStrip) $ do
-      GL.vertex (GL.Vertex2 xmin ymax)
-      GL.vertex (GL.Vertex2 xmin ymin)
-      GL.vertex (GL.Vertex2 xmax ymax)
-      GL.vertex (GL.Vertex2 xmax ymin)
-
-process = mapM_ procEvent
-
-procEvent (Resize w h) = do
-  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
-  GL.matrixMode $= GL.Projection
-  GL.loadIdentity
-  GL.ortho 0 1 0 1 (-1) 1
-  GL.matrixMode $= GL.Modelview 0
-procEvent _ = return ()
-
-translate = mapMaybe translate'
-
-translate' (KeyDown KEY_LEFT) = Just MoveLeft
-translate' (KeyDown KEY_RIGHT) = Just MoveRight
-translate' (KeyUp KEY_LEFT) = Just StopLeft
-translate' (KeyUp KEY_RIGHT) = Just StopRight
-translate' _ = Nothing
-
-exitRequested = any (== (KeyDown KEY_ESC))
-
-f2d :: Float -> GL.GLdouble
-f2d = realToFrac
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs
deleted file mode 100644
index accc75d..0000000
--- a/demos/pong/Pong.hs
+++ /dev/null
@@ -1,141 +0,0 @@
-module Pong
-  ( GameEvent (..),
-    GameObject,
-    newWorld,
-    stepWorld,
-    aabb,
-  )
-where
-
-import Data.Monoid (mconcat)
-import GHC.Float (double2Float)
-import Spear.Math.AABB
-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
-  = MoveLeft
-  | MoveRight
-  | StopLeft
-  | StopRight
-  deriving (Eq, Ord)
-
--- Game objects
-
-data GameObject = GameObject
-  { aabb :: AABB2,
-    obj :: Obj2,
-    gostep :: Step [GameObject] [GameEvent] GameObject GameObject
-  }
-
-instance Spatial2 GameObject where
-  getObj2 = obj
-  setObj2 s o = s {obj = o}
-
-stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
-stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
-
-update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
-update elapsed dt evts gos go =
-  let (go', s') = runStep (gostep go) elapsed dt gos evts go
-   in go' {gostep = s'}
-
-ballBox, padBox :: AABB2
-ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = ballSize
-padBox = AABB2 (- padSize) padSize
-
-obj2 = obj2FromVectors unitx2 unity2
-
-newWorld =
-  [ GameObject ballBox (obj2 initialBallPos) $ stepBall ballVelocity,
-    GameObject padBox (obj2 initialEnemyPos) stepEnemy,
-    GameObject padBox (obj2 initialPlayerPos) stepPlayer
-  ]
-
--- Ball steppers
-
-stepBall vel = collideBall vel .> moveBall
-
-collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
-collideBall vel = step $ \_ dt gos _ ball ->
-  let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
-      collideCol = x pmin < 0 || x pmax > 1
-      collideRow = y pmin < 0 || y pmax > 1 || any (collide ball) (tail gos)
-      negx v@(Vector2 x y) = if collideCol then vec2 (- x) y else v
-      negy v@(Vector2 x y) = if collideRow then vec2 x (- y) else v
-      vel' = negx . negy $ vel
-      delta = dt -- A small delta to apply when collision occurs.
-      adjustX = if collideCol then scale delta (vec2 (x vel) 0) else vec2 0 0
-      adjustY = if collideRow then scale delta (vec2 0 (y vel)) else vec2 0 0
-   in ((vel' + adjustX + adjustY, ball), collideBall vel')
-
-collide go1 go2 =
-  let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
-        aabb go1 `aabbAdd` pos go1
-      (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
-        aabb go2 `aabbAdd` pos go2
-   in not $
-        xmax1 < xmin2 || xmin1 > xmax2
-          || ymax1 < ymin2
-          || ymin1 > ymax2
-
-aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)
-
-moveBall :: Step s e (Vector2, GameObject) GameObject
-moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)
-
--- Enemy stepper
-
-stepEnemy = movePad
-
-movePad :: Step s e GameObject GameObject
-movePad = step $ \elapsed _ _ _ pad ->
-  let p = vec2 px 0.9
-      px =
-        double2Float (sin elapsed * 0.5 + 0.5)
-          * (1 - 2 * x padSize)
-          + x padSize
-   in (setPos p pad, movePad)
-
--- Player stepper
-
-stepPlayer = sfold moveGO .> clamp
-
-moveGO =
-  mconcat
-    [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (- playerSpeed) 0),
-      switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0)
-    ]
-
-moveGO' :: Vector2 -> Step s e GameObject GameObject
-moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)
-
-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
-        | x < a = a
-        | x > b = b
-        | otherwise = x
-      (Vector2 s _) = padSize
-   in setPos p' go
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs
deleted file mode 100644
index e8ef27d..0000000
--- a/demos/pong/Setup.hs
+++ /dev/null
@@ -1,3 +0,0 @@
-import Distribution.Simple
-
-main = defaultMain
-- 
cgit v1.2.3