From 8f2ec33e8c15e523b2b60d3bfd8e6360313a0657 Mon Sep 17 00:00:00 2001 From: 3gg <3gg@shellblade.net> Date: Sat, 17 Sep 2022 17:46:27 -0700 Subject: 2020s update --- demos/pong/Main.hs | 99 +++++++++++++++++++------------------ demos/pong/Pong.hs | 125 ++++++++++++++++++++++++----------------------- demos/pong/Setup.hs | 1 + demos/pong/cabal.project | 2 + demos/pong/pong.cabal | 12 ++--- 5 files changed, 124 insertions(+), 115 deletions(-) create mode 100644 demos/pong/cabal.project (limited to 'demos/pong') 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 -- cgit v1.2.3