2020s update

5 files changed, 124 insertions, 115 deletions

diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs
index d0664b7..3563c30 100644
--- a/demos/pong/Main.hs
+++ b/demos/pong/Main.hs
@@ -1,79 +1,82 @@
 module Main where
 
+import Data.Maybe (mapMaybe)
+import Graphics.Rendering.OpenGL.GL (($=))
+import qualified Graphics.Rendering.OpenGL.GL as GL
 import Pong
-
+import Spear.Game
 import Spear.Math.AABB
 import Spear.Math.Spatial2
 import Spear.Math.Vector
-import Spear.Game
 import Spear.Window
 
-import Data.Maybe (mapMaybe)
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import Graphics.Rendering.OpenGL.GL (($=))
-
 data GameState = GameState
-     { wnd     :: Window
-     , world   :: [GameObject]
-     }
+  { window :: Window,
+    world :: [GameObject]
+  }
 
-main = run
-     $ withWindow (640,480) [] Window (2,0) (Just "Pong") initGame
-     $ loop (Just 30) step
+main =
+  withWindow (900, 600) (2, 0) (Just "Pong") initGame $
+    loop step
 
-initGame wnd = do
-         gameIO $ do
-                GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0
-                GL.matrixMode $= GL.Modelview 0
-                GL.loadIdentity
-         return $ GameState wnd newWorld
+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 -> Game GameState Bool
 step elapsed dt = do
-     gs <- getGameState
-     evts <- events (wnd gs)
-     gameIO . process $ evts
-     let evts' = translate evts
-     modifyGameState $ \ gs -> gs
-                     { world = stepWorld elapsed dt evts' (world gs) }
-     getGameState >>= \gs -> gameIO . render $ world gs
-     return (not $ exitRequested evts)
+  --gameIO $ putStrLn "Tick"
+  gs <- getGameState
+  evts <- events (window gs)
+  gameIO . process $ evts
+  let evts' = translate evts
+  modifyGameState $ \gs ->
+    gs
+      { world = stepWorld elapsed dt evts' (world gs)
+      }
+  getGameState >>= \gs -> gameIO . render $ world gs
+  return (not $ exitRequested evts)
 
 render world = do
-       GL.clear [GL.ColorBuffer]
-       mapM_ renderGO world
-       swapBuffers
+  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)
+  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
+  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_LEFT) = Just MoveLeft
 translate' (KeyDown KEY_RIGHT) = Just MoveRight
-translate' (KeyUp   KEY_LEFT)  = Just StopLeft
-translate' (KeyUp   KEY_RIGHT) = Just StopRight
+translate' (KeyUp KEY_LEFT) = Just StopLeft
+translate' (KeyUp KEY_RIGHT) = Just StopRight
 translate' _ = Nothing
 
-exitRequested = any (==(KeyDown KEY_ESC))
+exitRequested = any (== (KeyDown KEY_ESC))
 
 f2d :: Float -> GL.GLdouble
 f2d = realToFrac
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs
index 1761823..232c69a 100644
--- a/demos/pong/Pong.hs
+++ b/demos/pong/Pong.hs
@@ -1,66 +1,64 @@
 module Pong
-(
-    GameEvent(..)
-,   GameObject
-,   newWorld
-,   stepWorld
-,   aabb
-)
+  ( 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
 
-import Data.Monoid (mconcat)
-import GHC.Float (double2Float)
-
 -- Game events
 
 data GameEvent
-     = MoveLeft
-     | MoveRight
-     | StopLeft
-     | StopRight
-     deriving (Eq, Ord)
+  = MoveLeft
+  | MoveRight
+  | StopLeft
+  | StopRight
+  deriving (Eq, Ord)
 
 -- Game objects
 
 data GameObject = GameObject
-     { aabb   :: AABB2
-     , obj    :: Obj2
-     , gostep :: Step [GameObject] [GameEvent] GameObject GameObject
-     }
+  { aabb :: AABB2,
+    obj :: Obj2,
+    gostep :: Step [GameObject] [GameEvent] GameObject GameObject
+  }
 
 instance Spatial2 GameObject where
-         getObj2 = obj
-         setObj2 s o = s { obj = o }
+  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' }
+  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
+ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01
 
 padSize = vec2 0.05 0.02
 
-padBox = AABB2 (-padSize) padSize
+padBox = AABB2 (- padSize) padSize
 
 obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
 
 ballVelocity = Vector2 0.3 0.3
 
 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 0.5 0.5) $ stepBall ballVelocity,
+    GameObject padBox (obj2 0.5 0.9) stepEnemy,
+    GameObject padBox (obj2 0.5 0.1) stepPlayer
+  ]
 
 -- Ball steppers
 
@@ -68,27 +66,30 @@ stepBall vel = collideBall vel .> moveBall
 
 collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
 collideBall vel = step $ \_ _ 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
-            in ((vel', ball), collideBall vel')
+  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
+   in ((vel', 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
+  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)
+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)
+moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)
 
 -- Enemy stepper
 
@@ -96,32 +97,34 @@ 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)
+  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 (-1) 0)
-       , switch StopRight sid MoveRight (moveGO' $ vec2 1 0)
-       ]
+moveGO =
+  mconcat
+    [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0),
+      switch StopRight sid MoveRight (moveGO' $ vec2 1 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 = if x < a then a else if x > b then b else x
-          (Vector2 s _) = padSize
-      in setPos p' 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
+      (Vector2 s _) = padSize
+   in setPos p' go
 
-toDir True MoveLeft  = vec2 (-1) 0
+toDir True MoveLeft = vec2 (-1) 0
 toDir True MoveRight = vec2 1 0
-toDir _ _ = vec2 0 0
\ No newline at end of file
+toDir _ _ = vec2 0 0
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs
index 9a994af..e8ef27d 100644
--- a/demos/pong/Setup.hs
+++ b/demos/pong/Setup.hs
@@ -1,2 +1,3 @@
 import Distribution.Simple
+
 main = defaultMain
diff --git a/demos/pong/cabal.project b/demos/pong/cabal.project
new file mode 100644
index 0000000..3dc1fca
--- /dev/null
+++ b/demos/pong/cabal.project
@@ -0,0 +1,2 @@
+packages: .
+          ../../
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal
index bebedb9..23ada51 100644
--- a/demos/pong/pong.cabal
+++ b/demos/pong/pong.cabal
@@ -1,15 +1,15 @@
--- Initial pong.cabal generated by cabal init.  For further documentation, 
+-- Initial pong.cabal generated by cabal init.  For further documentation,
 -- see http://haskell.org/cabal/users-guide/
 
 name:                pong
 version:             0.1.0.0
 synopsis:            A pong clone
--- description:         
+-- description:
 license:             BSD3
 license-file:        LICENSE
 author:              Marc Sunet
--- maintainer:          
--- copyright:           
+-- maintainer:
+-- copyright:
 category:            Game
 build-type:          Simple
 cabal-version:       >=1.8
@@ -17,5 +17,5 @@ cabal-version:       >=1.8
 executable pong
   -- hs-source-dirs:      src
   main-is:             Main.hs
-  -- other-modules:       
-  build-depends:       base ==4.6.*, Spear, OpenGL
+  -- other-modules:
+  build-depends:       base, Spear, OpenGL