Pong using proper AABB collision

Signed-off-by: magic_rb <richard@brezak.sk>

rpg/package.yaml

@@ -26,8 +26,11 @@ dependencies:
 - bytestring
 - text
 - lens
+- apecs
 - apecs-effectful
+- linear
 - extra
+- vector
 language: GHC2021
 default-extensions:
   - OverloadedStrings

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

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)

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)

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

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
+    c <- getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims
-    liftIO $ print c
-    runDraw . runDraw2D c $ do
 
+    runDraw . runDraw2D c $ do
       clearBackground RL.rayWhite
-      -- drawText "Congrats! You created your first window!" 190 200 20 RL.lightGray
+
-      render
+      render @World
-      drawRectangle 0 0 1 1 RL.lightGray
+      renderOrigins @World
-      drawRectangle 2 0 1 1 RL.lightGray
+      renderBoundingBoxes @World
       not <$> windowShouldClose
 
   pure ()

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
+  :: forall w es .
-     , AE.ECS World :> 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
+ballMovement playArea player1 player2 ball top bottom = do
-  ballEntity <- ball
+  playArea' <- playArea
-  playArea <- asks @GameConfig (\c -> c.playArea)
+  player1' <- player1
-  player1Position <- player1 >>= AE.get @World
+  player2' <- player2
-  player2Position <- player2 >>= AE.get @World
+  ball' <- ball
-  ballPosition <- AE.get @World ballEntity
+  top' <- top
-  ballVelocity <- AE.get @World ballEntity
+  bottom' <- bottom
 
-  let newVelocity = ballMovement'
+  ballVelocity <- ball >>= AE.get @World
-        playArea
-        player1Position
-        player2Position
-        (ballPosition, ballVelocity)
 
-  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
+      :: ( AE.ECS World :> es
-      -> PositionComponent
+         )
-      -> PositionComponent
+      => Int
-      -> (PositionComponent, VelocityComponent)
+      -> AE.Entity
+      -> AE.Entity
+      -> AE.Entity
+      -> AE.Entity
+      -> AE.Entity
       -> VelocityComponent
-    ballMovement' playArea player1 player2 (ballPosition, ballVelocity)
+      -> Eff es VelocityComponent
-      | ballPosition.y + 0.25 > int2Float playArea / 2 = invertYVelocity ballVelocity
+    ballMovement' playArea player1 player2 ball bottom top ballVelocity = do
-      | ballPosition.y - 0.25 < int2Float playArea / 2 * (-1) = invertYVelocity ballVelocity
+      player1Collision <- collidesEntities @World (pure player1) (pure ball)
-      | 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
+      player2Collision <- collidesEntities @World (pure player2) (pure ball)
-      | 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
+      bottomCollision <- collidesEntities @World (pure bottom) (pure ball)
-      | otherwise = ballVelocity
+      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
+      (gets @GameState (\s -> s.score)) >>= liftIO . print
-      renderOrigins
+
+      render @World
+      -- renderOrigins @World
+      -- renderBoundingBoxes @World
     not <$> windowShouldClose

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 ()

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)
+  AE.cmapM_ @w @(PositionComponent, BoxComponent)
-    \(pos, Box color offset size) -> drawRectangle (pos.x + fst offset) (pos.y + snd offset) (fst size) (snd size) color
+    \(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

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)