From d20e822e806afe67c8e255a645061638b75d3546 Mon Sep 17 00:00:00 2001 From: 3gg <3gg@shellblade.net> Date: Sat, 4 Jan 2025 16:26:25 -0800 Subject: Add balls demo. --- Demos/Balls/Main.hs | 177 ++++++++++++++++++++++++++++++++++++++++++++++++++++ Spear.cabal | 9 ++- 2 files changed, 185 insertions(+), 1 deletion(-) create mode 100644 Demos/Balls/Main.hs diff --git a/Demos/Balls/Main.hs b/Demos/Balls/Main.hs new file mode 100644 index 0000000..2e759bc --- /dev/null +++ b/Demos/Balls/Main.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +--{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Main where + +import Spear.App +import Spear.Game +import Spear.Math.AABB +import qualified Spear.Math.Matrix3 as Matrix3 +import qualified Spear.Math.Matrix4 as Matrix4 +import Spear.Math.Spatial +import Spear.Math.Spatial2 +import Spear.Math.Vector +import Spear.Physics.Collision +--import Spear.Prelude +import Spear.Render.Core.Pipeline +import Spear.Render.Core.State +import Spear.Render.Immediate +import Spear.Sound.Sound +import Spear.Sound.State +import Spear.Window + +import Control.Monad (when) +import Spear.Math.Vector (Vector3) + + +ballSize = 0.01 +numBalls = 1000 + +data Ball = Ball + { ballPosition :: {-# UNPACK #-} !Vector2 + , ballVelocity :: {-# UNPACK #-} !Vector2 + } + +instance Positional Ball Vector2 where + setPosition p ball = ball { ballPosition = p } + position = ballPosition + translate v ball = ball { ballPosition = v + ballPosition ball } + +instance Bounded2 Ball where + boundingVolume ball = aabb2Volume $ translate (ballPosition ball) (AABB2 (-size) size) + where size = vec2 s s + s = ballSize / (2::Float) + +data World = World + { viewProjection :: Matrix4.Matrix4 + , balls :: [Ball] + } + +type GameState = AppState World + + +options = defaultAppOptions { title = "Balls" } + +app = App options initGame endGame step render resize + + +main :: IO () +main = runApp app + +initGame :: Game AppContext World +initGame = + let + world = zipWith Ball positions velocities + positions = (+vec2 0.5 0.5) . makePosition <$> numbers + makePosition i = radius * vec2 (sin (f*i)) (cos (f*i)) + velocities = makeVelocity <$> numbers + makeVelocity i = scale speed $ vec2 (sin (f*i)) (cos (f*i)) + numbers = [1..numBalls] + f = 2*pi / numBalls + radius = 0.05 + speed = 0.4 + in + return $ World Matrix4.id world + +endGame :: Game GameState () +endGame = return () + + +step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool +step elapsed dt inputEvents = do + modifyGameState $ \world -> world + { balls = moveBalls dt $ balls world + } + return (not $ exitRequested inputEvents) + +exitRequested = elem (KeyDown KEY_ESC) + +moveBalls :: Elapsed -> [Ball] -> [Ball] +moveBalls dt = (bounceBall dt . moveBall dt <$>) + +moveBall :: Elapsed -> Ball -> Ball +moveBall dt ball = translate (scale (realToFrac dt) $ ballVelocity ball) ball + +bounceBall :: Elapsed -> Ball -> Ball +bounceBall dt ball = + let + (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball + sideCollision = x pmin < 0 || x pmax > 1 + backCollision = y pmin < 0 || y pmax > 1 + flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v + flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v + velocity = ballVelocity ball + velocity' + = flipX + . flipY + $ velocity + collision = velocity' /= velocity + -- Apply offset when collision occurs to avoid sticky collisions. + delta = if collision then 1 else 0 + dt' = realToFrac dt + in + ball + { ballPosition = ballPosition ball + scale (delta * dt') velocity' + , ballVelocity = velocity' + } + + +render :: Game GameState () +render = do + gameState <- getGameState + siblingGame $ do + immStart + immSetViewProjectionMatrix (viewProjection gameState) + -- Clear the background to a different colour than the playable area to make + -- the latter distinguishable. + setClearColour (0.2, 0.2, 0.2, 0.0) + clearBuffers [ColourBuffer] + render' $ balls gameState + immEnd + +render' :: [Ball] -> Game ImmRenderState () +render' balls = do + immLoadIdentity + renderBackground + -- Draw objects. + immSetColour (vec4 1.0 1.0 1.0 1.0) + mapM_ renderBall balls + +renderBackground :: Game ImmRenderState () +renderBackground = + let pmin = 0 :: Float + pmax = 1 :: Float + in do + immSetColour (vec4 0.0 0.25 0.41 1.0) + immDrawQuads2d [ + (vec2 pmin pmin + ,vec2 pmax pmin + ,vec2 pmax pmax + ,vec2 pmin pmax)] + +renderBall :: Ball -> Game ImmRenderState () +renderBall ball = + let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume ball + in + immDrawQuads2d [ + (vec2 xmin ymin + ,vec2 xmax ymin + ,vec2 xmax ymax + ,vec2 xmin ymax)] + + +resize :: WindowEvent -> Game GameState () +resize (ResizeEvent w h) = + let r = fromIntegral w / fromIntegral h + pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 + left = if r > 1 then -pad else 0 + right = if r > 1 then 1 + pad else 1 + bottom = if r > 1 then 0 else -pad + top = if r > 1 then 1 else 1 + pad + in do + setViewport 0 0 w h + modifyGameState $ \pong -> pong { + viewProjection = Matrix4.ortho left right bottom top (-1) 1 + } diff --git a/Spear.cabal b/Spear.cabal index 4193931..56eb302 100644 --- a/Spear.cabal +++ b/Spear.cabal @@ -143,6 +143,13 @@ executable pong hs-source-dirs: Demos/Pong main-is: Main.hs other-modules: Pong - build-depends: base, Spear, OpenGL + build-depends: base, Spear + ghc-options: -O2 + ghc-prof-options: -O2 -g -fprof-auto -fprof-cafs + +executable balls + hs-source-dirs: Demos/Balls + main-is: Main.hs + build-depends: base, Spear ghc-options: -O2 ghc-prof-options: -O2 -g -fprof-auto -fprof-cafs -- cgit v1.2.3