From ee69651f5aa4d21b91445c73fe2088fbbf5bea0d Mon Sep 17 00:00:00 2001 From: magic_rb Date: Thu, 12 Oct 2023 20:29:21 +0200 Subject: [PATCH] Pong using proper AABB collision Signed-off-by: magic_rb --- rpg/package.yaml | 3 + rpg/rpg.cabal | 22 ++++- rpg/src/Common.hs | 9 +- rpg/src/Component/AABB.hs | 26 ++++++ rpg/src/Component/Body.hs | 10 +++ rpg/src/Lib.hs | 30 ++++--- rpg/src/Pong.hs | 166 +++++++++++++++++++++++++++---------- rpg/src/System/Physics.hs | 71 +++++++++++++++- rpg/src/System/Renderer.hs | 40 +++++++-- rpg/src/World.hs | 18 +++- 10 files changed, 324 insertions(+), 71 deletions(-) create mode 100644 rpg/src/Component/AABB.hs create mode 100644 rpg/src/Component/Body.hs diff --git a/rpg/package.yaml b/rpg/package.yaml index 1101936..a091f70 100644 --- a/rpg/package.yaml +++ b/rpg/package.yaml @@ -26,8 +26,11 @@ dependencies: - bytestring - text - lens +- apecs - apecs-effectful +- linear - extra +- vector language: GHC2021 default-extensions: - OverloadedStrings diff --git a/rpg/rpg.cabal b/rpg/rpg.cabal index e8956d0..371c3cf 100644 --- a/rpg/rpg.cabal +++ b/rpg/rpg.cabal @@ -26,6 +26,8 @@ source-repository head library exposed-modules: Common + Component.AABB + Component.Body Component.Box Component.Camera Component.Player @@ -54,14 +56,17 @@ library LambdaCase ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - apecs-effectful + apecs + , apecs-effectful , base >=4.7 && <5 , bytestring , effectful , extra , h-raylib , lens + , linear , text + , vector default-language: GHC2021 executable pong @@ -82,15 +87,18 @@ executable pong LambdaCase ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - apecs-effectful + apecs + , apecs-effectful , base >=4.7 && <5 , bytestring , effectful , extra , h-raylib , lens + , linear , rpg , text + , vector default-language: GHC2021 executable rpg-exe @@ -111,15 +119,18 @@ executable rpg-exe LambdaCase ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - apecs-effectful + apecs + , apecs-effectful , base >=4.7 && <5 , bytestring , effectful , extra , h-raylib , lens + , linear , rpg , text + , vector default-language: GHC2021 test-suite rpg-test @@ -141,13 +152,16 @@ test-suite rpg-test LambdaCase ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - apecs-effectful + apecs + , apecs-effectful , base >=4.7 && <5 , bytestring , effectful , extra , h-raylib , lens + , linear , rpg , text + , vector default-language: GHC2021 diff --git a/rpg/src/Common.hs b/rpg/src/Common.hs index aad3d26..3b0894e 100644 --- a/rpg/src/Common.hs +++ b/rpg/src/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} module Common ( getCamera ) where import qualified Apecs.Effectful as AE @@ -7,13 +8,17 @@ import qualified Raylib.Types as RL import GHC.Float getCamera - :: ( AE.ECS World :> es ) + :: forall w es . + ( AE.Get w CameraComponent + , AE.Get w PositionComponent + , AE.ECS w :> es + ) => Eff es AE.Entity -> (Int, Int) -> Eff es RL.Camera2D getCamera eff (dimX, dimY) = do entity <- eff - (c, p) <- AE.get @World @(CameraComponent, PositionComponent) entity + (c, p) <- AE.get @w @(CameraComponent, PositionComponent) entity pure $ RL.Camera2D { RL.camera2D'offset = RL.Vector2 (int2Float dimX / 2) (int2Float dimY / 2) , RL.camera2D'target = RL.Vector2 (p.x + fst c.offset) (p.y + snd c.offset) diff --git a/rpg/src/Component/AABB.hs b/rpg/src/Component/AABB.hs new file mode 100644 index 0000000..6fb5c23 --- /dev/null +++ b/rpg/src/Component/AABB.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies #-} + +module Component.AABB + ( AABBComponent(..) + , aabbBounds + ) where + +import Apecs.Effectful +import Linear.V2 +import Linear.V4 +import Component.Position + +data AABBComponent + = AABB + { size :: V2 Float + , offset :: V2 Float + } + deriving Show +instance Component AABBComponent where type Storage AABBComponent = Map AABBComponent + +aabbBounds :: PositionComponent -> AABBComponent -> V4 Float +aabbBounds (Position posX posY) (AABB (V2 sizeX sizeY) (V2 offsetX offsetY)) = + V4 (posX + sizeX / 2 + offsetX) + (posX - sizeX / 2 + offsetX) + (posY + sizeY / 2 + offsetY) + (posY - sizeY / 2 + offsetY) diff --git a/rpg/src/Component/Body.hs b/rpg/src/Component/Body.hs new file mode 100644 index 0000000..eb69bad --- /dev/null +++ b/rpg/src/Component/Body.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} + +module Component.Body (BodyComponent(..)) where +import Apecs.Effectful + +data BodyComponent + = Body + { } + deriving Show +instance Component BodyComponent where type Storage BodyComponent = Map BodyComponent diff --git a/rpg/src/Lib.hs b/rpg/src/Lib.hs index 3d0e710..7d24cdf 100644 --- a/rpg/src/Lib.hs +++ b/rpg/src/Lib.hs @@ -39,6 +39,8 @@ import Effectful.State.Static.Local.Lens import Effectful.Raylib import System.Renderer import Common +import Linear.V2 +import System.Physics data GameConfig = GameConfig @@ -52,6 +54,7 @@ data GameState , camera :: RL.Camera2D , playerEntity :: AE.Entity , cameraEntity :: AE.Entity + , boxes :: [AE.Entity] } deriving Show makeLensesFor [ ("dimX", "dimX") @@ -59,13 +62,14 @@ makeLensesFor [ ("dimX", "dimX") , ("camera", "camera") , ("playerEntity", "playerEntity") , ("cameraEntity", "cameraEntity") + , ("boxes", "boxes") ] ''GameState spawnPlayer :: ( AE.ECS World :> es ) => RL.Color -> Eff es AE.Entity -spawnPlayer color = AE.newEntity @World (Player, Position 0 0, Camera 20 (0, 0), Box color (-0.5, -0.5) (1, 1)) +spawnPlayer color = AE.newEntity @World (Player, Position 0 2, Camera 10 (0, 0), AABB (V2 1 1) (V2 0 0), Body, Box color (0, 0) (1, 1)) movePlayer :: ( AE.ECS World :> es ) @@ -83,7 +87,7 @@ spawnBox -> RL.Color -> (Float, Float) -> Eff es AE.Entity -spawnBox (posx, posy) color size = AE.newEntity @World (Box color size (0, 0), Position posx posy) +spawnBox (posx, posy) color size = AE.newEntity @World (Box color size (0, 0), Position posx posy, AABB (V2 1 1) (V2 0 0)) initialise :: ( Raylib :> es @@ -97,6 +101,11 @@ initialise = do playerEntity .= player cameraEntity .= player + box1 <- AE.newEntity @World (Box RL.gray (0,0) (1,1), Position 0 0, AABB (V2 1 1) (V2 0 0)) + -- box2 <- AE.newEntity @World (Box RL.gray (0,0) (1,1), Position 2 0, AABB (V2 1 1) (V2 0 0)) + boxes .= [box1--, box2 + ] + pure () runGame :: IO () @@ -115,25 +124,26 @@ runGame = do RL.setTraceLogLevel RL.LogWarning runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do + collisionAABB @World + isKeyDown RL.KeyA >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (-0.1, 0)) isKeyDown RL.KeyD >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (0.1, 0)) isKeyDown RL.KeyS >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (0, 0.1)) isKeyDown RL.KeyW >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (0, -0.11)) - cameraEntity <- (gets @GameState (\s -> s.cameraEntity)) + cameraEntity <- gets @GameState (\s -> s.cameraEntity) isKeyDown RL.KeyKpAdd >>= flip when ( AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c { zoom = c.zoom + 1})) isKeyDown RL.KeyKpSubtract >>= flip when ( AE.modify @World @CameraComponent @CameraComponent cameraEntity (\c -> c { zoom = c.zoom - 1})) dims <- gets @GameState (\s -> (s.dimX, s.dimY)) - c <- getCamera (gets @GameState (\s -> s.cameraEntity)) dims - liftIO $ print c - runDraw . runDraw2D c $ do + c <- getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims + runDraw . runDraw2D c $ do clearBackground RL.rayWhite - -- drawText "Congrats! You created your first window!" 190 200 20 RL.lightGray - render - drawRectangle 0 0 1 1 RL.lightGray - drawRectangle 2 0 1 1 RL.lightGray + + render @World + renderOrigins @World + renderBoundingBoxes @World not <$> windowShouldClose pure () diff --git a/rpg/src/Pong.hs b/rpg/src/Pong.hs index 6a39d7d..c0f50e8 100644 --- a/rpg/src/Pong.hs +++ b/rpg/src/Pong.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} module Pong (pongGame) where import Effectful.State.Static.Local @@ -16,6 +17,7 @@ import Control.Lens hiding ((.=), (%=)) import System.Renderer import GHC.Float import System.Physics +import Linear.V2 data GameState = GameState @@ -25,9 +27,14 @@ data GameState , player1 :: AE.Entity , player2 :: AE.Entity , ball :: AE.Entity + , goal1 :: AE.Entity + , goal2 :: AE.Entity + , bottom :: AE.Entity + , top :: AE.Entity + , score :: (Int, Int) } deriving Show -makeLensesFor [("dimX", "dimX"), ("dimY", "dimY"), ("camera", "camera"), ("player1", "player1"), ("player2", "player2"), ("ball", "ball")] ''GameState +makeLensesFor [("dimX", "dimX"), ("dimY", "dimY"), ("camera", "camera"), ("player1", "player1"), ("player2", "player2"), ("ball", "ball"), ("goal1", "goal1"), ("goal2", "goal2"), ("bottom", "bottom"), ("top", "top"), ("score", "score")] ''GameState data GameConfig = GameConfig @@ -37,8 +44,11 @@ data GameConfig makeLensesFor [("playArea", "playArea")] ''GameConfig playerMovement - :: ( Raylib :> es - , AE.ECS World :> es + :: forall w es . + ( Raylib :> es + , AE.Get w PositionComponent + , AE.Set w PositionComponent + , AE.ECS w :> es , Reader GameConfig :> es ) => (RL.KeyboardKey, Float) @@ -48,9 +58,9 @@ playerMovement playerMovement (up, upSpeed) (down, downSpeed) entity = do playArea <- asks @GameConfig (\c -> c.playArea) isKeyDown up >>= flip when - (entity >>= flip (AE.modify @World @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + upSpeed))) + (entity >>= flip (AE.modify @w @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + upSpeed))) isKeyDown down >>= flip when - (entity >>= flip (AE.modify @World @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + downSpeed))) + (entity >>= flip (AE.modify @w @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + downSpeed))) where clampPosition :: Int @@ -62,73 +72,131 @@ playerMovement (up, upSpeed) (down, downSpeed) entity = do | otherwise = Position x y ballMovement - :: ( AE.ECS World :> es + :: forall es . + ( AE.ECS World :> es , Reader GameConfig :> es ) - => Eff es AE.Entity + => Eff es Int + -> Eff es AE.Entity + -> Eff es AE.Entity + -> Eff es AE.Entity -> Eff es AE.Entity -> Eff es AE.Entity -> Eff es () -ballMovement player1 player2 ball = do - ballEntity <- ball - playArea <- asks @GameConfig (\c -> c.playArea) - player1Position <- player1 >>= AE.get @World - player2Position <- player2 >>= AE.get @World - ballPosition <- AE.get @World ballEntity - ballVelocity <- AE.get @World ballEntity +ballMovement playArea player1 player2 ball top bottom = do + playArea' <- playArea + player1' <- player1 + player2' <- player2 + ball' <- ball + top' <- top + bottom' <- bottom - let newVelocity = ballMovement' - playArea - player1Position - player2Position - (ballPosition, ballVelocity) + ballVelocity <- ball >>= AE.get @World - AE.set @World ballEntity newVelocity + newVelocity <- ballMovement' + playArea' + player1' + player2' + ball' + bottom' + top' + ballVelocity + + ball >>= \ballEntity -> AE.set @World ballEntity newVelocity where invertYVelocity :: VelocityComponent -> VelocityComponent invertYVelocity (Velocity x y) = Velocity x (-y) + invertXVelocity :: VelocityComponent -> VelocityComponent invertXVelocity (Velocity x y) = Velocity (-x) y ballMovement' - :: Int - -> PositionComponent - -> PositionComponent - -> (PositionComponent, VelocityComponent) + :: ( AE.ECS World :> es + ) + => Int + -> AE.Entity + -> AE.Entity + -> AE.Entity + -> AE.Entity + -> AE.Entity -> VelocityComponent - ballMovement' playArea player1 player2 (ballPosition, ballVelocity) - | ballPosition.y + 0.25 > int2Float playArea / 2 = invertYVelocity ballVelocity - | ballPosition.y - 0.25 < int2Float playArea / 2 * (-1) = invertYVelocity ballVelocity - | ballPosition.x + 0.75 > player2.x && ballPosition.x + 0.5 < player2.x && ballPosition.y >= player2.y - 1.25 && ballPosition.y <= player2.y + 1.25 = invertXVelocity ballVelocity - | ballPosition.x - 0.75 < player1.x && ballPosition.x - 0.5 > player1.x && ballPosition.y >= player1.y - 1.25 && ballPosition.y <= player1.y + 1.25 = invertXVelocity ballVelocity - | otherwise = ballVelocity + -> Eff es VelocityComponent + ballMovement' playArea player1 player2 ball bottom top ballVelocity = do + player1Collision <- collidesEntities @World (pure player1) (pure ball) + player2Collision <- collidesEntities @World (pure player2) (pure ball) + bottomCollision <- collidesEntities @World (pure bottom) (pure ball) + topCollision <- collidesEntities @World (pure top) (pure ball) + + let ret + | player1Collision || player2Collision = invertXVelocity ballVelocity + | bottomCollision || topCollision = invertYVelocity ballVelocity + | otherwise = ballVelocity + + pure ret + + +ballRespawn + :: ( AE.ECS World :> es + , State GameState :> es + ) + => Eff es AE.Entity + -> Eff es AE.Entity + -> Eff es AE.Entity + -> Eff es () +ballRespawn goal1 goal2 ball = do + goal1' <- goal1 + ball' <- ball + goal2' <- goal2 + + goal1Collision <- collidesEntities @World (pure goal1') (pure ball') + goal2Collision <- collidesEntities @World (pure goal2') (pure ball') + + let + respawn = AE.set @World ball' (Position 0 0) + ret + | goal1Collision = (score . _1) %= (+) 1 >> respawn + | goal2Collision = (score . _2) %= (+) 1 >> respawn + | otherwise = pure () + ret initialise :: ( Raylib :> es , State GameState :> es + , Reader GameConfig :> es , AE.ECS World :> es ) => Eff es () initialise = do setTargetFPS 60 + playArea <- asks @GameConfig (\s -> s.playArea) - cameraEntity <- AE.newEntity @World (Camera 20 (0, 0), Position 0 0) + cameraEntity <- AE.newEntity @World (Camera playArea (0, 0), Position 0 0) camera .= cameraEntity - player1Entity <- AE.newEntity @World (Player, Position (-10) 0, Box RL.white (0, -1) (0.5, 2)) + player1Entity <- AE.newEntity @World (Player, Position (-10) 0, Box RL.white (0, 0) (0.5, 2), AABB (V2 0.5 2) (V2 0 0)) player1 .= player1Entity - player2Entity <- AE.newEntity @World (Player, Position 10 0, Box RL.white (-0.5, -1) (0.5, 2)) + player2Entity <- AE.newEntity @World (Player, Position 10 0, Box RL.white (0, 0) (0.5, 2), AABB (V2 0.5 2) (V2 0 0)) player2 .= player2Entity - ballEntity <- AE.newEntity @World (Position 0 0, Velocity 0.1 0.1, Box RL.white (-0.25, -0.25) (0.5, 0.5)) + ballEntity <- AE.newEntity @World (Position 0 0, Velocity 0.1 0.1, Box RL.white (0, 0) (0.5, 0.5), AABB (V2 0.5 0.5) (V2 0 0)) ball .= ballEntity + goal1Entity <- AE.newEntity @World (Position (int2Float (-playArea) / 2 - 1) 0, AABB (V2 0.1 (int2Float playArea)) (V2 0 0)) + goal2Entity <- AE.newEntity @World (Position (int2Float playArea / 2 + 1) 0, AABB (V2 0.1 (int2Float playArea)) (V2 0 0)) + goal1 .= goal1Entity + goal2 .= goal2Entity + + topEntity <- AE.newEntity @World (Position 0 (int2Float (-playArea) / 2), AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)) + bottomEntity <- AE.newEntity @World (Position 0 (int2Float playArea / 2), AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)) + top .= topEntity + bottom .= bottomEntity + pure () pongGame :: IO () @@ -141,6 +209,11 @@ pongGame = do , player2 = undefined , camera = undefined , ball = undefined + , goal1 = undefined + , goal2 = undefined + , top = undefined + , bottom = undefined + , score = (0, 0) } gameConfig = GameConfig @@ -148,30 +221,39 @@ pongGame = do } -- RL.setTraceLogLevel RL.LogWarning runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $ initialise >> whileM do + ballRespawn + (gets @GameState (\s -> s.goal2)) + (gets @GameState (\s -> s.goal1)) + (gets @GameState (\s -> s.ball)) + ballMovement + (asks @GameConfig (\c -> c.playArea)) (gets @GameState (\s -> s.player1)) (gets @GameState (\s -> s.player2)) (gets @GameState (\s -> s.ball)) + (gets @GameState (\s -> s.bottom)) + (gets @GameState (\s -> s.top)) - applyVelocity + applyVelocity @World - playerMovement + playerMovement @World (RL.KeyW, -0.2) (RL.KeyS, 0.2) (gets @GameState (\s -> s.player1)) - playerMovement + playerMovement @World (RL.KeyUp, -0.2) (RL.KeyDown, 0.2) (gets @GameState (\s -> s.player2)) - (gets @GameState (\s -> s.ball)) >>= AE.get @World @(PositionComponent, VelocityComponent) >>= liftIO . print - dims <- gets @GameState (\s -> (s.dimX, s.dimY)) - camera <- getCamera (gets @GameState (\s -> s.camera)) dims + camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims runDraw . runDraw2D camera $ do clearBackground RL.gray - render - renderOrigins + (gets @GameState (\s -> s.score)) >>= liftIO . print + + render @World + -- renderOrigins @World + -- renderBoundingBoxes @World not <$> windowShouldClose diff --git a/rpg/src/System/Physics.hs b/rpg/src/System/Physics.hs index 6d03644..029c2d9 100644 --- a/rpg/src/System/Physics.hs +++ b/rpg/src/System/Physics.hs @@ -1,13 +1,78 @@ -module System.Physics (applyVelocity) where +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MonoLocalBinds #-} + +module System.Physics (applyVelocity, collides, collisionAABB, collidesEntities) where import World import qualified Apecs.Effectful as AE +import qualified Apecs.Components as AE (EntityStore) import Effectful +import Linear +import Control.Lens +import Effectful.Dispatch.Static (unsafeEff_) +import qualified Apecs +import qualified Apecs.Core +import Apecs.Components (EntityStore) +import Control.Monad.Extra applyVelocity - :: ( AE.ECS World :> es + :: forall w es . + ( AE.Get w PositionComponent + , AE.Get w VelocityComponent + , AE.Set w PositionComponent + , AE.ECS w :> es ) => Eff es () applyVelocity = do - AE.cmap @World @(PositionComponent, VelocityComponent) @_ + AE.cmap @w @(PositionComponent, VelocityComponent) @_ \(position, velocity) -> Position (position.x + velocity.x) (position.y + velocity.y) + +collides + :: PositionComponent -> AABBComponent + -> PositionComponent -> AABBComponent + -> Bool +collides positionA aabbA positionB aabbB = do + -- V4 x -x y -y + let boundsA = aabbBounds positionA aabbA + boundsB = aabbBounds positionB aabbB + + case (boundsA ^. _x > boundsB ^. _y, boundsB ^. _x > boundsA ^. _y, boundsA ^. _z > boundsB ^. _w, boundsB ^. _z > boundsA ^. _w) of + (True, True, True, True) -> True + _ -> False + +collidesEntities + :: forall w es . + ( AE.Get w PositionComponent + , AE.Get w AABBComponent + , AE.ECS w :> es ) + => Eff es AE.Entity + -> Eff es AE.Entity + -> Eff es Bool +collidesEntities a b = do + a' <- a + b' <- b + positionA <- AE.get @w a' + aabbA <- AE.get @w a' + positionB <- AE.get @w b' + aabbB <- AE.get @w b' + + pure $ collides positionA aabbA positionB aabbB + + +collisionAABB + :: forall w es . + ( AE.Get w PositionComponent + , AE.Get w VelocityComponent + , AE.Get w BodyComponent + , AE.Get w AABBComponent + , AE.ECS w :> es + ) + => Eff es () +collisionAABB = + AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent) + \(bodyEntity, bodyPosition, bodyBody, bodyAABB) -> + AE.cmapM @w @(AE.Entity, PositionComponent, AABBComponent) + \(colliderEntity, colliderPosition, colliderAABB) -> when (bodyEntity /= colliderEntity) do + let collision = collides bodyPosition bodyAABB colliderPosition colliderAABB + unsafeEff_ $ print collision + pure () diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index 0772a0f..c7a72ee 100644 --- a/rpg/src/System/Renderer.hs +++ b/rpg/src/System/Renderer.hs @@ -1,28 +1,52 @@ -module System.Renderer (render, renderOrigins) where +{-# LANGUAGE AllowAmbiguousTypes #-} +module System.Renderer (render, renderOrigins, renderBoundingBoxes) where import Effectful import qualified Apecs.Effectful as AE import World -import Component.Position -import Component.Box import Effectful.Raylib import qualified Raylib.Util.Colors as RL +import Linear.V4 render - :: ( AE.ECS World :> es + :: forall w es . + ( AE.Get w PositionComponent + , AE.Get w BoxComponent + , AE.ECS w :> es , RaylibDraw2D :> es ) => Eff es () render = do - AE.cmapM_ @World @(PositionComponent, BoxComponent) - \(pos, Box color offset size) -> drawRectangle (pos.x + fst offset) (pos.y + snd offset) (fst size) (snd size) color + AE.cmapM_ @w @(PositionComponent, BoxComponent) + \(pos, Box color offset size) -> drawRectangle (pos.x + fst offset - fst size / 2) (pos.y + snd offset - snd size / 2) (fst size) (snd size) color pure () renderOrigins - :: ( AE.ECS World :> es + :: forall w es . + ( AE.Get w PositionComponent + , AE.ECS w :> es , RaylibDraw2D :> es ) => Eff es () renderOrigins = do - AE.cmapM_ @World @PositionComponent + AE.cmapM_ @w @PositionComponent \pos -> drawLine (pos.x - 0.1) (pos.y - 0.1) (pos.x + 0.1) (pos.y + 0.1) RL.red >> drawLine (pos.x + 0.1) (pos.y - 0.1) (pos.x - 0.1) (pos.y + 0.1) RL.red + +renderBoundingBoxes + :: forall w es . + ( AE.Get w PositionComponent + , AE.Get w AABBComponent + , RaylibDraw2D :> es + , AE.ECS w :> es + ) + => Eff es () +renderBoundingBoxes = + AE.cmapM_ @w @(PositionComponent, AABBComponent) + \(pos, aabb) -> do + let (V4 x nx y ny) = aabbBounds pos aabb + drawLine x y x ny RL.red + drawLine x ny nx ny RL.red + drawLine nx ny nx y RL.red + drawLine nx y x y RL.red + drawLine x y nx ny RL.red + drawLine nx y x ny RL.red diff --git a/rpg/src/World.hs b/rpg/src/World.hs index 48e64d8..a336714 100644 --- a/rpg/src/World.hs +++ b/rpg/src/World.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FieldSelectors #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} module World ( World @@ -9,13 +10,26 @@ module World , module Component.Camera , module Component.Box , module Component.Velocity + , module Component.AABB + , module Component.Body ) where -import Apecs.Effectful import Component.Position import Component.Player import Component.Camera import Component.Box import Component.Velocity +import Component.AABB +import Component.Body +import Apecs +import qualified Apecs.Effectful as AE +import Apecs.Core +import Apecs.Components +import Data.Vector.Unboxed -makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent] +makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent, ''AABBComponent, ''BodyComponent] + +instance Monad m => ExplMembers m EntityStore where + explMembers :: EntityStore -> m (Vector Int) + explMembers _ = do + pure $ generate 10000 ((-) 1)