Random stuff, preparing for Minkowski difference physics

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

rpg/rpg.cabal

@@ -30,11 +30,15 @@ library
       Component.Body
       Component.Box
       Component.Camera
+      Component.Collision
       Component.Player
       Component.Position
+      Component.TextBox
       Component.Velocity
       Effectful.Raylib
+      Effectful.Reader.Static.State
       Effectful.State.Static.Local.Lens
+      Engine
       Lib
       Pong
       System.Physics

rpg/src/Common.hs

@@ -1,11 +1,14 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-module Common ( getCamera ) where
+module Common ( getCamera, playerMovement ) where
 
 import qualified Apecs.Effectful as AE
 import World
 import Effectful
 import qualified Raylib.Types as RL
 import GHC.Float
+import Linear.V2
+import Control.Lens
+import Effectful.Raylib
 
 getCamera
   :: forall w es .
@@ -18,10 +21,35 @@ getCamera
   -> Eff es RL.Camera2D
 getCamera eff (dimX, dimY) = do
   entity <- eff
-  (c, p) <- AE.get @w @(CameraComponent, PositionComponent) entity
+  (c, Position (V2 x y)) <- 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)
+    , RL.camera2D'target = RL.Vector2 (x + fst c.offset) (y + snd c.offset)
     , RL.camera2D'rotation = 0.0
     , RL.camera2D'zoom = int2Float (min dimX dimY) / int2Float c.zoom
     }
+
+playerMovement
+  :: forall w es .
+     ( Raylib :> es
+     , AE.ECS w :> es
+     , AE.Get w VelocityComponent
+     )
+  => AE.Entity
+  -> ( RL.KeyboardKey
+     , RL.KeyboardKey
+     , RL.KeyboardKey
+     , RL.KeyboardKey
+     )
+  -> Float
+  -> Eff es ()
+playerMovement player (left, right, up, down) speed = do
+  directions <-
+    mapM (\tuple -> fst tuple <&> (, snd tuple))
+    [ ( isKeyDown left, V2 (-speed) 0 )
+    , ( isKeyDown right, V2 speed 0 )
+    , ( isKeyDown down, V2 0 speed )
+    , ( isKeyDown up, V2 0 (-speed) )
+    ]
+  let movement = foldl (+) (V2 0 0) $ map snd $ filter fst directions
+  AE.modify @w @() @VelocityComponent player (\() -> Velocity (movement ^. _x) (movement ^. _y))

rpg/src/Component/AABB.hs

@@ -19,7 +19,7 @@ data AABBComponent
 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)) =
+aabbBounds (Position (V2 posX posY)) (AABB (V2 sizeX sizeY) (V2 offsetX offsetY)) =
   V4 (posX + sizeX / 2 + offsetX)
      (posX - sizeX / 2 + offsetX)
      (posY + sizeY / 2 + offsetY)

rpg/src/Component/Body.hs

@@ -1,10 +1,16 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Component.Body (BodyComponent(..)) where
+module Component.Body (BodyComponent(..), previousPosition) where
 import Apecs.Effectful
+import Linear.V2
+import Control.Lens
 
 data BodyComponent
   = Body
-  { }
+  { previousPosition :: V2 Float
+  }
   deriving Show
 instance Component BodyComponent where type Storage BodyComponent = Map BodyComponent
+makeLensesFor
+  [ ("previousPosition", "previousPosition")
+  ] ''BodyComponent

rpg/src/Component/Collision.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Component.Collision
+  ( CollisionComponent(..)
+  , Collider(..)
+  ) where
+
+import qualified Apecs.Effectful as AE
+import Linear.V2
+
+data Collider
+  = Collider
+  { other :: AE.Entity
+  , overlap :: V2 Float
+  , offset :: V2 Float
+  , normal :: V2 Float
+  }
+  deriving (Eq, Show)
+
+data CollisionComponent
+  = Collision
+  { colliders :: [Collider]
+  }
+  deriving Show
+instance AE.Component CollisionComponent where type Storage CollisionComponent = AE.Map CollisionComponent

rpg/src/Component/Position.hs

@@ -3,12 +3,9 @@
 module Component.Position (PositionComponent(..)) where
 
 import Apecs.Effectful
+import Linear.V2
 
-data PositionComponent
+newtype PositionComponent
-  = Position
+  = Position (V2 Float)
-  { x :: Float
-  , y :: Float
-  }
   deriving Show
 instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent
-

rpg/src/Component/TextBox.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Component.TextBox
+  ( TextBoxComponent(..)
+  ) where
+
+import qualified Apecs.Effectful as AE
+import qualified Raylib.Types as RL
+import Data.Text (Text)
+
+data TextBoxComponent
+  = TextBox
+  { font :: RL.Font
+  , text :: Text
+  , fontSize :: Float
+  , spacing :: Float
+  , color :: RL.Color
+  }
+  deriving Show
+instance AE.Component TextBoxComponent where type Storage TextBoxComponent = AE.Map TextBoxComponent

rpg/src/Effectful/Raylib.hs

@@ -3,10 +3,12 @@
 module Effectful.Raylib
   ( setTargetFPS
   , windowShouldClose
+  , getFontDefault
   , isKeyDown
   , runDraw
   , clearBackground
   , runDraw2D
+  , measureText
   , drawText
   , drawRectangle
   , drawLine
@@ -24,11 +26,12 @@ import qualified Raylib.Core as RL
 import qualified Data.Text as T
 import qualified Raylib.Core.Text as RL
 import qualified Raylib.Core.Shapes as RL
-import GHC.Float
+import Linear (V2 (..))
 
 data Raylib :: Effect where
   SetTargetFPS :: Int -> Raylib (Eff es) ()
   WindowShouldClose :: Raylib (Eff es) Bool
+  GetFontDefault :: Raylib (Eff es) RL.Font
   IsKeyDown :: RL.KeyboardKey -> Raylib (Eff es) Bool
   RunDraw :: (IOE :> es) => Eff (RaylibDraw : es) a -> Raylib (Eff es) a
 type instance DispatchOf Raylib = Dynamic
@@ -39,7 +42,8 @@ data RaylibDraw :: Effect where
 type instance DispatchOf RaylibDraw = Dynamic
 
 data RaylibDraw2D :: Effect where
-  DrawText :: Text -> Int -> Int -> Int -> RL.Color -> RaylibDraw2D (Eff es) ()
+  MeasureText :: RL.Font -> Text -> Float -> Float -> RaylibDraw2D (Eff es) (V2 Float)
+  DrawText :: RL.Font -> Text -> V2 Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) ()
   DrawRectangle :: Float -> Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) ()
   DrawLine :: Float -> Float -> Float -> Float -> RL.Color -> RaylibDraw2D (Eff es) ()
 type instance DispatchOf RaylibDraw2D = Dynamic
@@ -50,6 +54,9 @@ setTargetFPS fps = send (SetTargetFPS fps)
 windowShouldClose :: (HasCallStack, Raylib :> es) => Eff es Bool
 windowShouldClose = send WindowShouldClose
 
+getFontDefault :: (HasCallStack, Raylib :> es) => Eff es RL.Font
+getFontDefault = send GetFontDefault
+
 isKeyDown :: (HasCallStack, Raylib :> es) => RL.KeyboardKey -> Eff es Bool
 isKeyDown key = send (IsKeyDown key)
 
@@ -62,8 +69,11 @@ clearBackground color = send (ClearBackground color)
 runDraw2D :: (HasCallStack, IOE :> es, RaylibDraw :> es) => RL.Camera2D -> Eff (RaylibDraw2D : es) a -> Eff es a
 runDraw2D camera effect = send (RunDraw2D camera effect)
 
-drawText :: (HasCallStack, RaylibDraw2D :> es) => Text -> Int -> Int -> Int -> RL.Color -> Eff es ()
+measureText :: (HasCallStack, RaylibDraw2D :> es) => RL.Font -> Text -> Float -> Float -> Eff es (V2 Float)
-drawText text posX posY fontSize color = send (DrawText text posX posY fontSize color)
+measureText font text fontSize spacing = send $ MeasureText font text fontSize spacing
+
+drawText :: (HasCallStack, RaylibDraw2D :> es) => RL.Font -> Text -> V2 Float -> Float -> Float -> RL.Color -> Eff es ()
+drawText font text position fontSize spacing color = send (DrawText font text position fontSize spacing color)
 
 drawRectangle :: (HasCallStack, RaylibDraw2D :> es) => Float -> Float -> Float -> Float -> RL.Color -> Eff es ()
 drawRectangle posX posY width height color = send (DrawRectangle posX posY width height color)
@@ -77,7 +87,8 @@ runRaylibWindow width height name effect = do
 
   interpret' effect $ \env eff -> localSeqUnlift env \unlift ->
     case eff of
-      WindowShouldClose -> liftIO $ RL.windowShouldClose
+      WindowShouldClose -> liftIO RL.windowShouldClose
+      GetFontDefault -> liftIO RL.getFontDefault
       SetTargetFPS fps -> liftIO $ RL.setTargetFPS fps
       IsKeyDown key -> liftIO $ RL.isKeyDown key
       RunDraw drawEffect -> unlift $ runRaylibDrawing drawEffect
@@ -99,7 +110,11 @@ runRaylibWindow width height name effect = do
        liftIO (RL.beginMode2D camera)
        res <- interpret' effect' $ \env eff -> localSeqUnlift env \unlift ->
          case eff of
-           DrawText text posX posY fontSize color -> liftIO $ RL.drawText (T.unpack text) posX posY fontSize color
+           MeasureText font text fontSize spacing -> do
+             RL.Vector2 x y <- liftIO $ RL.measureTextEx font (T.unpack text) fontSize spacing
+             pure (V2 x y)
+           DrawText font text (V2 posX posY) fontSize spacing color ->
+             liftIO $ RL.drawTextEx font (T.unpack text) (RL.Vector2 posX posY) fontSize spacing color
            DrawRectangle posX posY width height color -> liftIO $ RL.drawRectangleV (RL.Vector2 posX posY) (RL.Vector2 width height) color
            DrawLine startX startY endX endY color -> liftIO $ RL.drawLineV (RL.Vector2 startX startY) (RL.Vector2 endX endY) color
        liftIO RL.endMode2D

rpg/src/Effectful/Reader/Static/State.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Effectful.Reader.Static.State
+  ( Reads
+  , Effectful.Reader.Static.State.read
+  , Effectful.Reader.Static.State.reads
+  , readsM
+  ) where
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+
+data Reads r :: Effect where
+  Reads :: (r -> m a) -> (Reads r) m a
+type instance DispatchOf (Reads r) = Dynamic
+
+read :: (HasCallStack, Reads r :> es) => Eff es r
+read = send $ Reads pure
+
+reads :: (HasCallStack, Reads r :> es) => (r -> a) -> Eff es a
+reads reader = send $ Reads (pure . reader)
+
+readsM :: (HasCallStack, Reads r :> es) => (r -> Eff es a) -> Eff es a
+readsM reader = send $ Reads reader

rpg/src/Engine.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Engine ( Engine(..), runEngine ) where
+
+import Effectful
+import System.Physics
+import World
+import qualified Apecs.Effectful as AE
+import qualified Raylib.Types as RL
+import System.Renderer
+import Effectful.Raylib
+
+class Engine es a where
+  engineInput :: a -> Eff es ()
+  engineInput _ = pure ()
+  enginePhysics :: a -> Eff es ()
+  enginePhysics _ = pure ()
+  engineRendering :: a -> Eff es ()
+  engineRendering _ = pure ()
+  engineGetCamera :: a -> Eff es RL.Camera2D
+  engineClearColor :: a -> Eff es RL.Color
+
+runEngine
+  :: forall w es a .
+     ( Engine es a
+     , AE.Get w PositionComponent
+     , AE.Get w BodyComponent
+     , AE.Get w AABBComponent
+     , AE.Get w BoxComponent
+     , AE.Get w TextBoxComponent
+     , AE.Get w CollisionComponent
+     , AE.Get w VelocityComponent
+     , IOE :> es
+     , Raylib :> es
+     , AE.ECS w :> es
+     )
+  => a
+  -> Eff es ()
+runEngine engine = do
+  engineInput engine
+
+  applyVelocity @w
+
+  collisionAABB @w
+  resolveAABB @w
+
+  enginePhysics engine
+
+  c <- engineGetCamera engine
+
+  runDraw . runDraw2D c $ do
+    color <- inject $ engineClearColor engine
+    clearBackground color
+
+    inject $ engineRendering engine
+
+    render @w
+    renderOrigins @w
+    renderBoundingBoxes @w
+    renderCollision @w
+

rpg/src/Lib.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Lib
     ( runGame
@@ -41,6 +42,7 @@ import System.Renderer
 import Common
 import Linear.V2
 import System.Physics
+import Engine
 
 data GameConfig
   = GameConfig
@@ -69,7 +71,14 @@ spawnPlayer
   :: ( AE.ECS World :> es )
   => RL.Color
   -> Eff es AE.Entity
-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))
+spawnPlayer color = AE.newEntity @World
+  ( Player
+  , Position $ V2 0 2
+  , Camera 10 (0, 0)
+  , AABB (V2 1 1) (V2 0 0)
+  , Body (V2 0 2)
+  , Box color (0, 0) (1, 1)
+  )
 
 movePlayer
   :: ( AE.ECS World :> es )
@@ -78,8 +87,8 @@ movePlayer
   -> Eff es ()
 movePlayer eff (x, y) = do
   entity <- eff
-
+  AE.modify @World @() @VelocityComponent entity (\() -> Velocity x y)
-  AE.modify @World @PositionComponent @PositionComponent entity (\p -> Position (p.x + x) (p.y + y))
+  -- AE.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^.  _x + x) (p ^.  _y + y))
 
 spawnBox
   :: ( AE.ECS World :> es )
@@ -87,7 +96,11 @@ 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, AABB (V2 1 1) (V2 0 0))
+spawnBox (posx, posy) color size = AE.newEntity @World
+  ( Box color (0, 0) size
+  , Position $ V2 posx posy
+  , AABB (V2 1 1) (V2 0 0)
+  )
 
 initialise
   :: ( Raylib :> es
@@ -101,13 +114,46 @@ 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))
+  _ <- spawnBox (0, 0) RL.gray (1, 1)
-  -- box2 <- AE.newEntity @World (Box RL.gray (0,0) (1,1), Position 2 0, AABB (V2 1 1) (V2 0 0))
+  _ <- spawnBox (2, 0) RL.gray (1, 1)
-  boxes .= [box1--, box2
+  _ <- spawnBox (3, 0) RL.gray (1, 1)
-           ]
+  _ <- spawnBox (3, 1) RL.gray (1, 1)
+
+  boxes .= []
 
   pure ()
 
+data RPGEngine = RPGEngine
+
+instance ( Raylib :> es
+         , AE.ECS World :> es
+         , State GameState :> es
+         , IOE :> es
+         ) => Engine es RPGEngine where
+  engineInput engine = do
+    playerEntity <- gets @GameState (\s -> s.playerEntity)
+    playerMovement @World
+      playerEntity
+      ( RL.KeyA
+      , RL.KeyD
+      , RL.KeyW
+      , RL.KeyS
+      )
+      0.1
+
+    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}))
+    pure ()
+  enginePhysics _ = pure ()
+    -- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
+    --   when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
+  engineGetCamera engine = do
+    dims <- gets @GameState (\s -> (s.dimX, s.dimY))
+    getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims
+  engineClearColor _ = pure RL.white
+
 runGame :: IO ()
 runGame = do
   let gameConfig
@@ -124,26 +170,8 @@ 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))
+    runEngine @World RPGEngine
-    isKeyDown RL.KeyD >>= flip when (movePlayer (gets @GameState (\s -> s.playerEntity)) (0.1, 0))
+    not <$> windowShouldClose
-    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)
-    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 @World (gets @GameState (\s -> s.cameraEntity)) dims
-
-    runDraw . runDraw2D c $ do
-      clearBackground RL.rayWhite
-
-      render @World
-      renderOrigins @World
-      renderBoundingBoxes @World
-      not <$> windowShouldClose
 
   pure ()

rpg/src/Pong.hs

@@ -11,13 +11,15 @@ import Effectful.Raylib
 import Control.Monad.Extra
 import World
 import qualified Raylib.Util.Colors as RL
-import Common
+import Common hiding (playerMovement)
 import Effectful.State.Static.Local.Lens
 import Control.Lens hiding ((.=), (%=))
 import System.Renderer
 import GHC.Float
 import System.Physics
 import Linear.V2
+import qualified Linear as L
+import qualified Data.Text as T
 
 data GameState
   = GameState
@@ -31,17 +33,33 @@ data GameState
   , goal2 :: AE.Entity
   , bottom :: AE.Entity
   , top :: AE.Entity
+  , separator :: AE.Entity
   , score :: (Int, Int)
   }
   deriving Show
-makeLensesFor [("dimX", "dimX"), ("dimY", "dimY"), ("camera", "camera"), ("player1", "player1"), ("player2", "player2"), ("ball", "ball"), ("goal1", "goal1"), ("goal2", "goal2"), ("bottom", "bottom"), ("top", "top"), ("score", "score")] ''GameState
+makeLensesFor
+  [ ("dimX", "dimX")
+  , ("dimY", "dimY")
+  , ("camera", "camera")
+  , ("player1", "player1")
+  , ("player2", "player2")
+  , ("ball", "ball")
+  , ("goal1", "goal1")
+  , ("goal2", "goal2")
+  , ("bottom", "bottom")
+  , ("top", "top")
+  , ("separator", "separator")
+  , ("score", "score")
+  ] ''GameState
 
 data GameConfig
   = GameConfig
   { playArea :: Int
   }
   deriving Show
-makeLensesFor [("playArea", "playArea")] ''GameConfig
+makeLensesFor
+  [ ("playArea", "playArea")
+  ] ''GameConfig
 
 playerMovement
   :: forall w es .
@@ -58,33 +76,30 @@ playerMovement
 playerMovement (up, upSpeed) (down, downSpeed) entity = do
   playArea <- asks @GameConfig (\c -> c.playArea)
   isKeyDown up >>= flip when
-    (entity >>= flip (AE.modify @w @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + upSpeed)))
+    (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + upSpeed)))
   isKeyDown down >>= flip when
-    (entity >>= flip (AE.modify @w @PositionComponent) (\p -> clampPosition playArea $ Position p.x (p.y + downSpeed)))
+    (entity >>= flip (AE.modify @w @PositionComponent) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed)))
   where
     clampPosition
       :: Int
       -> PositionComponent
       -> PositionComponent
-    clampPosition playArea (Position x y)
+    clampPosition playArea (Position position)
-      | y > int2Float playArea / 2 - 1 = Position x (int2Float playArea / 2 - 1)
+      | position ^. _y > int2Float playArea / 2 - 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 - 1)
-      | y < int2Float playArea / 2 * (-1) + 1 = Position x (int2Float playArea / 2 * (-1) + 1)
+      | position ^. _y < int2Float playArea / 2 * (-1) + 1 =  Position $ V2 (position ^. _x) (int2Float playArea / 2 * (-1) + 1)
-      | otherwise = Position x y
+      | otherwise = Position position
 
 ballMovement
   :: forall es .
      ( AE.ECS World :> es
-     , Reader GameConfig :> es
      )
-  => 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 AE.Entity
   -> Eff es ()
-ballMovement playArea player1 player2 ball top bottom = do
+ballMovement player1 player2 ball top bottom = do
-  playArea' <- playArea
   player1' <- player1
   player2' <- player2
   ball' <- ball
@@ -93,16 +108,13 @@ ballMovement playArea player1 player2 ball top bottom = do
 
   ballVelocity <- ball >>= AE.get @World
 
-  newVelocity <- ballMovement'
+  ballMovement'
-        playArea'
+    ball'
-        player1'
+    player1'
-        player2'
+    player2'
-        ball'
+    bottom'
-        bottom'
+    top'
-        top'
+    ballVelocity >>= AE.set @World ball'
-        ballVelocity
-
-  ball >>= \ballEntity -> AE.set @World ballEntity newVelocity
 
   where
     invertYVelocity
@@ -116,26 +128,31 @@ ballMovement playArea player1 player2 ball top bottom = do
     invertXVelocity (Velocity x y) = Velocity (-x) y
 
     ballMovement'
-      :: ( AE.ECS World :> es
+      :: AE.Entity
-         )
-      => Int
-      -> AE.Entity
       -> AE.Entity
       -> AE.Entity
       -> AE.Entity
       -> AE.Entity
       -> VelocityComponent
       -> Eff es VelocityComponent
-    ballMovement' playArea player1 player2 ball bottom top ballVelocity = do
+    ballMovement' ball player1 player2 bottom top ballVelocity = do
-      player1Collision <- collidesEntities @World (pure player1) (pure ball)
+      player1c <- getEntityCollision @World ball player1
-      player2Collision <- collidesEntities @World (pure player2) (pure ball)
+      player2c <- getEntityCollision @World ball player2
-      bottomCollision <- collidesEntities @World (pure bottom) (pure ball)
+      bottomC <- testEntityCollision @World ball bottom
-      topCollision <- collidesEntities @World (pure top) (pure ball)
+      topC <- testEntityCollision @World ball top
+      let ret = case (player1c, player2c) of
+            -- (Just collider, _) -> bounce collider
+            -- (_, Just collider) -> bounce collider
+            _ | bottomC || topC -> invertYVelocity ballVelocity
+            _ -> ballVelocity
+          v2ToVelocity (V2 x y) = Velocity x y
+          bounce collider = ballVelocity -- newVelocity.x (abs newVelocity.y * cloor ballVelocity.y)
+            -- where newVelocity = v2ToVelocity $ L.normalize collider.offset * sqrt 0.02
+            --       cloor f
+            --         | f < 0 = -1
+            --         | f == 0 = 0
+            --         | otherwise = 1
 
-      let ret
-            | player1Collision || player2Collision = invertXVelocity ballVelocity
-            | bottomCollision || topCollision = invertYVelocity ballVelocity
-            | otherwise = ballVelocity
 
       pure ret
 
@@ -150,17 +167,17 @@ ballRespawn
   -> Eff es ()
 ballRespawn goal1 goal2 ball = do
   goal1' <- goal1
-  ball' <- ball
   goal2' <- goal2
+  ball' <- ball
 
-  goal1Collision <- collidesEntities @World (pure goal1') (pure ball')
+  goal1c <- testEntityCollision @World ball' goal1'
-  goal2Collision <- collidesEntities @World (pure goal2') (pure ball')
+  goal2c <- testEntityCollision @World ball' goal2'
 
   let
-    respawn = AE.set @World ball' (Position 0 0)
+    respawn = AE.set @World ball' (Position $ V2 0 0)
     ret
-      | goal1Collision = (score . _1) %= (+) 1 >> respawn
+      | goal1c = (score . _1) %= (+) 1 >> respawn
-      | goal2Collision = (score . _2) %= (+) 1 >> respawn
+      | goal2c = (score . _2) %= (+) 1 >> respawn
       | otherwise = pure ()
   ret
 
@@ -175,28 +192,71 @@ initialise = do
   setTargetFPS 60
   playArea <- asks @GameConfig (\s -> s.playArea)
 
-  cameraEntity <- AE.newEntity @World (Camera playArea (0, 0), Position 0 0)
+  cameraEntity <- AE.newEntity @World
+    ( Camera playArea (0, 0)
+    , Position $ V2 0 0
+    )
   camera .= cameraEntity
 
-  player1Entity <- AE.newEntity @World (Player, Position (-10) 0, Box RL.white (0, 0) (0.5, 2), AABB (V2 0.5 2) (V2 0 0))
+  player1Entity <- AE.newEntity @World
+    ( Player
+    , Position $ V2 (-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, 0) (0.5, 2), AABB (V2 0.5 2) (V2 0 0))
+  player2Entity <- AE.newEntity @World
+    (Player
+    , Position $ V2 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, 0) (0.5, 0.5), AABB (V2 0.5 0.5) (V2 0 0))
+  ballEntity <- AE.newEntity @World
+    ( Position $ V2 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)
+    , Body (V2 0 0)
+    )
   ball .= ballEntity
 
-  goal1Entity <- AE.newEntity @World (Position (int2Float (-playArea) / 2 - 1) 0, AABB (V2 0.1 (int2Float playArea)) (V2 0 0))
+  goal1Entity <- AE.newEntity @World
-  goal2Entity <- AE.newEntity @World (Position (int2Float playArea / 2 + 1) 0, AABB (V2 0.1 (int2Float playArea)) (V2 0 0))
+    ( Position $ V2 (int2Float (-playArea) / 2 - 1) 0
+    , AABB (V2 0.1 (int2Float playArea)) (V2 0 0)
+    , Box RL.red (0, 0) (0.1, int2Float playArea)
+    )
+  goal2Entity <- AE.newEntity @World
+    ( Position $ V2 (int2Float playArea / 2 + 1) 0
+    , AABB (V2 0.1 (int2Float playArea)) (V2 0 0)
+    , Box RL.red (0, 0) (0.1, int2Float playArea)
+    )
   goal1 .= goal1Entity
   goal2 .= goal2Entity
 
-  topEntity <- AE.newEntity @World (Position 0 (int2Float (-playArea) / 2), AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0))
+  topEntity <- AE.newEntity @World
-  bottomEntity <- AE.newEntity @World (Position 0 (int2Float playArea / 2), AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0))
+    ( Position $ V2 0 (int2Float (-playArea) / 2)
+    , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
+    , Box RL.blue (0, 0) (int2Float playArea + 2, 0.1)
+    )
+  bottomEntity <- AE.newEntity @World
+    ( Position $ V2 0 (int2Float playArea / 2)
+    , AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)
+    , Box RL.green (0, 0) (int2Float playArea + 2, 0.1)
+    )
   top .= topEntity
   bottom .= bottomEntity
 
+  font <- getFontDefault
+  separatorEntity <- AE.newEntity @World
+    ( Position $ V2 0 0
+    , Box RL.darkGray (0, 0) (0.1, int2Float playArea)
+    , TextBox font "" 3 0.1 RL.darkGray
+    )
+  separator .= separatorEntity
+
   pure ()
 
 pongGame :: IO ()
@@ -213,6 +273,7 @@ pongGame = do
         , goal2 = undefined
         , top = undefined
         , bottom = undefined
+        , separator = undefined
         , score = (0, 0)
         }
       gameConfig
@@ -221,21 +282,6 @@ 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 @World
-
     playerMovement @World
       (RL.KeyW, -0.2)
       (RL.KeyS, 0.2)
@@ -246,14 +292,37 @@ pongGame = do
       (RL.KeyDown, 0.2)
       (gets @GameState (\s -> s.player2))
 
+    -- ballMovement
+    --   (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))
+
+    ballRespawn
+      (gets @GameState (\s -> s.goal2))
+      (gets @GameState (\s -> s.goal1))
+      (gets @GameState (\s -> s.ball))
+
+    collisionAABB @World
+    applyVelocity @World
+    resolveAABB @World
+
+    AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
+      when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
+
+    score' <- gets @GameState (\s -> s.score)
+    gets @GameState (\s -> s.separator)>>= flip (AE.modify @World @TextBoxComponent) \textBox ->
+      textBox { text = T.pack $ show score' }
+
     dims <- gets @GameState (\s -> (s.dimX, s.dimY))
     camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims
     runDraw . runDraw2D camera $ do
       clearBackground RL.gray
 
-      (gets @GameState (\s -> s.score)) >>= liftIO . print
+      -- (gets @GameState (\s -> s.score)) >>= liftIO . print
 
       render @World
-      -- renderOrigins @World
+      renderOrigins @World
-      -- renderBoundingBoxes @World
+      renderBoundingBoxes @World
     not <$> windowShouldClose

rpg/src/System/Physics.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE MonoLocalBinds #-}
 
-module System.Physics (applyVelocity, collides, collisionAABB, collidesEntities) where
+module System.Physics (applyVelocity, testEntityCollision, getEntityCollision, collides, collisionAABB, resolveAABB) where
 
 import World
 import qualified Apecs.Effectful as AE
@@ -14,6 +13,7 @@ import qualified Apecs
 import qualified Apecs.Core
 import Apecs.Components (EntityStore)
 import Control.Monad.Extra
+import qualified Debug.Trace as Debut.Trace
 
 applyVelocity
   :: forall w es .
@@ -25,54 +25,114 @@ applyVelocity
   => Eff es ()
 applyVelocity = do
   AE.cmap @w @(PositionComponent, VelocityComponent) @_
-    \(position, velocity) -> Position (position.x + velocity.x) (position.y + velocity.y)
+    \(Position position, velocity) -> Position $ V2 (position ^. _x + velocity.x) (position ^. _y + velocity.y)
 
 collides
-  :: PositionComponent -> AABBComponent
+  :: AE.Entity
   -> PositionComponent -> AABBComponent
-  -> Bool
+  -> PositionComponent -> AABBComponent
-collides positionA aabbA positionB aabbB = do
+  -> Maybe Collider
+collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do
   -- V4 x -x y -y
-  let boundsA = aabbBounds positionA aabbA
+  let boundsA = aabbBounds (Position positionA) aabbA
-      boundsB = aabbBounds positionB aabbB
+      boundsB = aabbBounds (Position positionB) aabbB
 
-  case (boundsA ^. _x > boundsB ^. _y, boundsB ^. _x > boundsA ^. _y, boundsA ^. _z > boundsB ^. _w, boundsB ^. _z > boundsA ^. _w) of
+  case (boundsA ^. _y - boundsB ^. _x <= 0, boundsA ^. _x - boundsB ^. _y >= 0, boundsB ^. _w - boundsA ^. _z <= 0, boundsB ^. _z - boundsA ^. _w >= 0) of
-    (True, True, True, True) -> True
+    (True, True, True, True) ->
-    _ -> False
+      let
+        offsetX = (positionB ^. _x - positionA ^. _x)
+        offsetY = (positionB ^. _y - positionA ^. _y)
+        offset = V2 (positionB ^. _x - positionA ^. _x) (positionB ^. _y - positionA ^. _y)
+        normalize' num
+          | num < 0 = -1
+          | otherwise = 1
+        -- foo :: Float = ((fromIntegral :: Int -> Float) . floor $ (atan2 (offset ^. _x) (offset ^. _y) / 2 * pi * 4)) / 4 * 2 * pi
+        -- foo :: Float = 1.5 + (-1)^fromEnum (offsetY > 0) * (0.5 + (fromIntegral . fromEnum $ offsetX > 0))
+        foo = case compare (abs offsetX) (abs offsetY) of
+                LT -> V2 0 offsetY
+                GT -> V2 offsetX 0
+                EQ -> V2 offsetX 0
+      in
+        Just Collider
+        { other = bEntity
+        -- https://stackoverflow.com/questions/9324339/how-much-do-two-rectangles-overlap
+        , overlap = V2
+                    ((min (boundsA ^. _x) (boundsB ^. _x) - max (boundsA ^. _y) (boundsB ^. _y)) * normalize' offsetX)
+                    ((max (boundsA ^. _w) (boundsB ^. _w) - min (boundsA ^. _z) (boundsB ^. _z)) * normalize' offsetY)
+        , offset = offset
+        , normal = normalize foo
+        }
+    _ -> Nothing
 
-collidesEntities
+testEntityCollision
   :: forall w es .
-     ( AE.Get w PositionComponent
+     ( AE.Get w CollisionComponent
-     , AE.Get w AABBComponent
      , AE.ECS w :> es )
-  => Eff es AE.Entity
+  => AE.Entity
-  -> Eff es AE.Entity
+  -> AE.Entity
   -> Eff es Bool
-collidesEntities a b = do
+testEntityCollision a b = getEntityCollision @w a b <&> \case Just _ -> True ; Nothing -> False
-  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
 
+getEntityCollision
+  :: forall w es .
+     ( AE.Get w CollisionComponent
+     , AE.ECS w :> es )
+  => AE.Entity
+  -> AE.Entity
+  -> Eff es (Maybe Collider)
+getEntityCollision a b =
+  AE.tryGet @w @CollisionComponent a >>= \case
+    Just collision -> pure $ testEntityCollision' collision b
+    Nothing -> AE.tryGet @w @CollisionComponent b >>= \case
+      Just collision -> pure $ testEntityCollision' collision a
+      Nothing -> pure Nothing
+  where
+    testEntityCollision' :: CollisionComponent -> AE.Entity -> Maybe Collider
+    testEntityCollision' collision other =
+      foldl (\case Just j -> const $ Just j ; Nothing -> \x -> if x.other == other then Just x else Nothing) Nothing collision.colliders
 
 collisionAABB
   :: forall w es .
      ( AE.Get w PositionComponent
-     , AE.Get w VelocityComponent
      , AE.Get w BodyComponent
      , AE.Get w AABBComponent
+     , AE.Get w CollisionComponent
      , AE.ECS w :> es
      )
   => Eff es ()
 collisionAABB =
-  AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent)
+  void $ AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent) @(CollisionComponent)
-  \(bodyEntity, bodyPosition, bodyBody, bodyAABB) ->
+  \(bodyEntity, bodyPosition, _, bodyAABB) -> do
-    AE.cmapM @w @(AE.Entity, PositionComponent, AABBComponent)
+    colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) ->
-    \(colliderEntity, colliderPosition, colliderAABB) -> when (bodyEntity /= colliderEntity) do
+      pure $ if bodyEntity /= colliderEntity then
-      let collision = collides bodyPosition bodyAABB colliderPosition colliderAABB
+        case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of
-      unsafeEff_ $ print collision
+          Just collider -> collider : acc
-      pure ()
+          Nothing -> acc
+       else
+         acc
+    pure $ Collision { colliders = colliders }
+
+resolveAABB
+  :: forall w es .
+     ( AE.Get w PositionComponent
+     , AE.Get w BodyComponent
+     , AE.Get w CollisionComponent
+     , AE.ECS w :> es
+     , IOE :> es
+     )
+  => Eff es ()
+resolveAABB = do
+  void $ AE.cmapM @w @(PositionComponent, BodyComponent, CollisionComponent) @PositionComponent
+    \(Position position, Body previousPosition, collision) ->
+      case collision.colliders of
+        (_:_) -> do
+          -- liftIO . print $ foldl (\a c -> a - c.overlap) (head collision.colliders).overlap (tail collision.colliders)
+          pure $ Position position
+        _ -> pure $ Position position
+      -- pure . Position $ foldl resolve position collision.colliders
+    where resolve :: V2 Float -> Collider -> V2 Float
+          resolve position collider =
+            case collider.overlap of
+              V2 x y | abs x < abs y -> position & _x %~ flip (-) x
+              V2 x y | abs y < abs x -> position & _y %~ (+) y
+              V2 x _ -> position & _x %~ flip (-) x

rpg/src/System/Renderer.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-module System.Renderer (render, renderOrigins, renderBoundingBoxes) where
+module System.Renderer (render, renderOrigins, renderBoundingBoxes, renderCollision) where
 
 import Effectful
 import qualified Apecs.Effectful as AE
@@ -7,19 +7,46 @@ import World
 import Effectful.Raylib
 import qualified Raylib.Util.Colors as RL
 import Linear.V4
+import Linear.V2 (V2(..))
+import Control.Lens
+import Control.Monad
 
 render
   :: forall w es .
      ( AE.Get w PositionComponent
      , AE.Get w BoxComponent
+     , AE.Get w TextBoxComponent
      , AE.ECS w :> es
      , RaylibDraw2D :> es )
   => Eff es ()
 render = do
   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
+    \(Position (V2 x y), Box color offset size) -> drawRectangle (x + fst offset - fst size / 2) (y + snd offset - snd size / 2) (fst size) (snd size) color
+  AE.cmapM_ @w @(PositionComponent, TextBoxComponent)
+    \(Position position, TextBox font text fontSize spacing color) -> do
+      size <- measureText font text fontSize spacing
+      drawText font text (V2 (position ^. _x - size ^. _x / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
   pure ()
 
+renderCollision
+  :: forall w es .
+  ( AE.Get w PositionComponent
+  , AE.Get w CollisionComponent
+  , AE.Get w BoxComponent
+  , AE.ECS w :> es
+  , RaylibDraw2D :> es
+  )
+  => Eff es ()
+renderCollision =
+  AE.cmapM_ @w @(PositionComponent, CollisionComponent, BoxComponent)
+    \(Position (V2 x y), Collision colliders, _) ->
+      forM_ colliders
+      (\(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
+          drawLine x y (x + offsetX) (y + offsetY) RL.green
+          drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 + overlapX / 2) (y + offsetY / 2 + overlapY / 2) RL.yellow
+          drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 - overlapX / 2) (y + offsetY / 2 - overlapY / 2) RL.orange
+      )
+
 renderOrigins
   :: forall w es .
      ( AE.Get w PositionComponent
@@ -29,8 +56,9 @@ renderOrigins
   => Eff es ()
 renderOrigins = do
   AE.cmapM_ @w @PositionComponent
-    \pos -> drawLine (pos.x - 0.1) (pos.y - 0.1) (pos.x + 0.1) (pos.y + 0.1) RL.red >>
+    \(Position (V2 x y)) ->
-            drawLine (pos.x + 0.1) (pos.y - 0.1) (pos.x - 0.1) (pos.y + 0.1) RL.red
+      drawLine (x - 0.1) (y - 0.1) (x + 0.1) (y + 0.1) RL.red >>
+      drawLine (x + 0.1) (y - 0.1) (x - 0.1) (y + 0.1) RL.red
 
 renderBoundingBoxes
   :: forall w es .

rpg/src/World.hs

@@ -12,6 +12,8 @@ module World
   , module Component.Velocity
   , module Component.AABB
   , module Component.Body
+  , module Component.Collision
+  , module Component.TextBox
   ) where
 
 import Component.Position
@@ -21,15 +23,19 @@ import Component.Box
 import Component.Velocity
 import Component.AABB
 import Component.Body
+import Component.Collision
+import Component.TextBox
+
 import Apecs
 import qualified Apecs.Effectful as AE
 import Apecs.Core
 import Apecs.Components
 import Data.Vector.Unboxed
+import Control.Monad.IO.Class (MonadIO)
 
-makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent, ''AABBComponent, ''BodyComponent]
+makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent, ''AABBComponent, ''BodyComponent, ''CollisionComponent, ''TextBoxComponent]
 
-instance Monad m => ExplMembers m EntityStore where
+instance (MonadIO m, Monad m) => ExplMembers m EntityStore where
   explMembers :: EntityStore -> m (Vector Int)
   explMembers _ = do
-    pure $ generate 10000 ((-) 1)
+    pure $ generate 1000 id