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 | 81 ------------------------------ demos/pong/Pong.hs | 141 ---------------------------------------------------- demos/pong/Setup.hs | 3 -- 3 files changed, 225 deletions(-) delete mode 100644 demos/pong/Main.hs delete mode 100644 demos/pong/Pong.hs delete mode 100644 demos/pong/Setup.hs (limited to 'demos') 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