From 19c8af10ce82b36148d2de9cd00090791539fb89 Mon Sep 17 00:00:00 2001 From: magic_rb Date: Sun, 29 Oct 2023 14:30:54 +0100 Subject: [PATCH] Random stuff, preparing for Minkowski difference physics Signed-off-by: magic_rb --- rpg/rpg.cabal | 4 + rpg/src/Common.hs | 34 +++- rpg/src/Component/AABB.hs | 2 +- rpg/src/Component/Body.hs | 10 +- rpg/src/Component/Collision.hs | 25 +++ rpg/src/Component/Position.hs | 9 +- rpg/src/Component/TextBox.hs | 20 +++ rpg/src/Effectful/Raylib.hs | 27 ++- rpg/src/Effectful/Reader/Static/State.hs | 25 +++ rpg/src/Engine.hs | 63 +++++++ rpg/src/Lib.hs | 84 ++++++--- rpg/src/Pong.hs | 207 +++++++++++++++-------- rpg/src/System/Physics.hs | 126 ++++++++++---- rpg/src/System/Renderer.hs | 36 +++- rpg/src/World.hs | 12 +- 15 files changed, 529 insertions(+), 155 deletions(-) create mode 100644 rpg/src/Component/Collision.hs create mode 100644 rpg/src/Component/TextBox.hs create mode 100644 rpg/src/Effectful/Reader/Static/State.hs create mode 100644 rpg/src/Engine.hs diff --git a/rpg/rpg.cabal b/rpg/rpg.cabal index 371c3cf..7e637fd 100644 --- a/rpg/rpg.cabal +++ b/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 diff --git a/rpg/src/Common.hs b/rpg/src/Common.hs index 3b0894e..b1da88a 100644 --- a/rpg/src/Common.hs +++ b/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)) diff --git a/rpg/src/Component/AABB.hs b/rpg/src/Component/AABB.hs index 6fb5c23..657aa80 100644 --- a/rpg/src/Component/AABB.hs +++ b/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) diff --git a/rpg/src/Component/Body.hs b/rpg/src/Component/Body.hs index eb69bad..6c25feb 100644 --- a/rpg/src/Component/Body.hs +++ b/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 diff --git a/rpg/src/Component/Collision.hs b/rpg/src/Component/Collision.hs new file mode 100644 index 0000000..2dbc912 --- /dev/null +++ b/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 diff --git a/rpg/src/Component/Position.hs b/rpg/src/Component/Position.hs index f8d5397..ff1e329 100644 --- a/rpg/src/Component/Position.hs +++ b/rpg/src/Component/Position.hs @@ -3,12 +3,9 @@ module Component.Position (PositionComponent(..)) where import Apecs.Effectful +import Linear.V2 -data PositionComponent - = Position - { x :: Float - , y :: Float - } +newtype PositionComponent + = Position (V2 Float) deriving Show instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent - diff --git a/rpg/src/Component/TextBox.hs b/rpg/src/Component/TextBox.hs new file mode 100644 index 0000000..d8c7095 --- /dev/null +++ b/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 diff --git a/rpg/src/Effectful/Raylib.hs b/rpg/src/Effectful/Raylib.hs index 198c3b3..cdbf237 100644 --- a/rpg/src/Effectful/Raylib.hs +++ b/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 () -drawText text posX posY fontSize color = send (DrawText text posX posY fontSize color) +measureText :: (HasCallStack, RaylibDraw2D :> es) => RL.Font -> Text -> Float -> Float -> Eff es (V2 Float) +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 diff --git a/rpg/src/Effectful/Reader/Static/State.hs b/rpg/src/Effectful/Reader/Static/State.hs new file mode 100644 index 0000000..cca1a5d --- /dev/null +++ b/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 diff --git a/rpg/src/Engine.hs b/rpg/src/Engine.hs new file mode 100644 index 0000000..5348dc7 --- /dev/null +++ b/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 + diff --git a/rpg/src/Lib.hs b/rpg/src/Lib.hs index 7d24cdf..e9809f1 100644 --- a/rpg/src/Lib.hs +++ b/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 @PositionComponent @PositionComponent entity (\p -> Position (p.x + x) (p.y + y)) + AE.modify @World @() @VelocityComponent entity (\() -> Velocity x 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)) - -- box2 <- AE.newEntity @World (Box RL.gray (0,0) (1,1), Position 2 0, AABB (V2 1 1) (V2 0 0)) - boxes .= [box1--, box2 - ] + _ <- spawnBox (0, 0) RL.gray (1, 1) + _ <- spawnBox (2, 0) RL.gray (1, 1) + _ <- 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)) - 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) - 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 + runEngine @World RPGEngine + not <$> windowShouldClose pure () diff --git a/rpg/src/Pong.hs b/rpg/src/Pong.hs index c0f50e8..183cee6 100644 --- a/rpg/src/Pong.hs +++ b/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) - | y > int2Float playArea / 2 - 1 = Position x (int2Float playArea / 2 - 1) - | y < int2Float playArea / 2 * (-1) + 1 = Position x (int2Float playArea / 2 * (-1) + 1) - | otherwise = Position x y + clampPosition playArea (Position position) + | position ^. _y > int2Float playArea / 2 - 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 - 1) + | position ^. _y < int2Float playArea / 2 * (-1) + 1 = Position $ V2 (position ^. _x) (int2Float playArea / 2 * (-1) + 1) + | 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 - playArea' <- playArea +ballMovement player1 player2 ball top bottom = do 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' - playArea' - player1' - player2' - ball' - bottom' - top' - ballVelocity - - ball >>= \ballEntity -> AE.set @World ballEntity newVelocity + ballMovement' + ball' + player1' + player2' + bottom' + top' + ballVelocity >>= AE.set @World ball' 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 - ) - => Int - -> AE.Entity + :: AE.Entity -> AE.Entity -> AE.Entity -> AE.Entity -> AE.Entity -> VelocityComponent -> 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) + ballMovement' ball player1 player2 bottom top ballVelocity = do + player1c <- getEntityCollision @World ball player1 + player2c <- getEntityCollision @World ball player2 + bottomC <- testEntityCollision @World ball bottom + 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') - goal2Collision <- collidesEntities @World (pure goal2') (pure ball') + goal1c <- testEntityCollision @World ball' goal1' + 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 - | goal2Collision = (score . _2) %= (+) 1 >> respawn + | goal1c = (score . _1) %= (+) 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)) - goal2Entity <- AE.newEntity @World (Position (int2Float playArea / 2 + 1) 0, AABB (V2 0.1 (int2Float playArea)) (V2 0 0)) + goal1Entity <- 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) + ) + 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)) - bottomEntity <- AE.newEntity @World (Position 0 (int2Float playArea / 2), AABB (V2 (int2Float playArea + 2) 0.1) (V2 0 0)) + topEntity <- AE.newEntity @World + ( 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 - -- renderBoundingBoxes @World + renderOrigins @World + renderBoundingBoxes @World not <$> windowShouldClose diff --git a/rpg/src/System/Physics.hs b/rpg/src/System/Physics.hs index 029c2d9..6b290f7 100644 --- a/rpg/src/System/Physics.hs +++ b/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 -collides positionA aabbA positionB aabbB = do + -> PositionComponent -> AABBComponent + -> Maybe Collider +collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do -- V4 x -x y -y - let boundsA = aabbBounds positionA aabbA - boundsB = aabbBounds positionB aabbB + let boundsA = aabbBounds (Position positionA) aabbA + boundsB = aabbBounds (Position 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 + 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) -> + 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 AABBComponent + ( AE.Get w CollisionComponent , AE.ECS w :> es ) - => Eff es AE.Entity - -> Eff es AE.Entity + => AE.Entity + -> 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 +testEntityCollision a b = getEntityCollision @w a b <&> \case Just _ -> True ; Nothing -> False +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) - \(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 () + void $ AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent) @(CollisionComponent) + \(bodyEntity, bodyPosition, _, bodyAABB) -> do + colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) -> + pure $ if bodyEntity /= colliderEntity then + case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of + Just collider -> collider : acc + 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 diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index c7a72ee..b69a945 100644 --- a/rpg/src/System/Renderer.hs +++ b/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 >> - drawLine (pos.x + 0.1) (pos.y - 0.1) (pos.x - 0.1) (pos.y + 0.1) RL.red + \(Position (V2 x y)) -> + 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 . diff --git a/rpg/src/World.hs b/rpg/src/World.hs index a336714..db07a55 100644 --- a/rpg/src/World.hs +++ b/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