diff --git a/rpg/package.yaml b/rpg/package.yaml index 57dbdc7..a991fa9 100644 --- a/rpg/package.yaml +++ b/rpg/package.yaml @@ -32,6 +32,8 @@ dependencies: - linear - extra - vector +- mtl +- unordered-containers language: GHC2021 default-extensions: @@ -60,7 +62,7 @@ library: executables: rpg-exe: main: Main.hs - source-dirs: app + source-dirs: rpg ghc-options: - -threaded - -rtsopts diff --git a/rpg/pong/Main.hs b/rpg/pong/Main.hs index 996b26e..b582bef 100644 --- a/rpg/pong/Main.hs +++ b/rpg/pong/Main.hs @@ -1,6 +1,6 @@ module Main where -import Pong +import Executables.Pong main :: IO () main = pongGame diff --git a/rpg/rpg.cabal b/rpg/rpg.cabal index 3abff03..5aff25a 100644 --- a/rpg/rpg.cabal +++ b/rpg/rpg.cabal @@ -41,8 +41,8 @@ library Effectful.State.Static.Local.Lens Engine Executables.Minkowski - Lib - Pong + Executables.Pong + Executables.RPG System.Physics System.Renderer World @@ -72,7 +72,9 @@ library , h-raylib , lens , linear + , mtl , text + , unordered-containers , vector default-language: GHC2021 @@ -104,8 +106,10 @@ executable minkowski , h-raylib , lens , linear + , mtl , rpg , text + , unordered-containers , vector default-language: GHC2021 @@ -137,8 +141,10 @@ executable pong , h-raylib , lens , linear + , mtl , rpg , text + , unordered-containers , vector default-language: GHC2021 @@ -149,7 +155,7 @@ executable rpg-exe autogen-modules: Paths_rpg hs-source-dirs: - app + rpg default-extensions: OverloadedStrings DuplicateRecordFields @@ -170,8 +176,10 @@ executable rpg-exe , h-raylib , lens , linear + , mtl , rpg , text + , unordered-containers , vector default-language: GHC2021 @@ -204,7 +212,9 @@ test-suite rpg-test , h-raylib , lens , linear + , mtl , rpg , text + , unordered-containers , vector default-language: GHC2021 diff --git a/rpg/app/Main.hs b/rpg/rpg/Main.hs similarity index 60% rename from rpg/app/Main.hs rename to rpg/rpg/Main.hs index 8652d37..4997a8b 100644 --- a/rpg/app/Main.hs +++ b/rpg/rpg/Main.hs @@ -1,5 +1,5 @@ module Main where -import Lib +import Executables.RPG main = runGame diff --git a/rpg/src/Component/Body.hs b/rpg/src/Component/Body.hs index 6c25feb..ddd34f5 100644 --- a/rpg/src/Component/Body.hs +++ b/rpg/src/Component/Body.hs @@ -1,16 +1,21 @@ {-# LANGUAGE TypeFamilies #-} -module Component.Body (BodyComponent(..), previousPosition) where -import Apecs.Effectful -import Linear.V2 -import Control.Lens +module Component.Body (BodyComponent (..), bounciness, friction, immovable) where -data BodyComponent - = Body - { previousPosition :: V2 Float +import Apecs.Effectful +import Control.Lens +import Linear.V2 + +data BodyComponent = Body + { bounciness :: Float + , friction :: Float + , immovable :: Bool } - deriving Show + deriving (Show) instance Component BodyComponent where type Storage BodyComponent = Map BodyComponent makeLensesFor - [ ("previousPosition", "previousPosition") - ] ''BodyComponent + [ ("bounciness", "bounciness") + , ("friction", "friction") + , ("immovable", "immovable") + ] + ''BodyComponent diff --git a/rpg/src/Component/Position.hs b/rpg/src/Component/Position.hs index 4a5e50d..1205b55 100644 --- a/rpg/src/Component/Position.hs +++ b/rpg/src/Component/Position.hs @@ -1,15 +1,15 @@ {-# LANGUAGE TypeFamilies #-} -module Component.Position (PositionComponent(..), position) where +module Component.Position (PositionComponent (..), position) where +import Apecs.Core import Apecs.Effectful -import Linear.V2 import Control.Lens +import Linear.V2 -newtype PositionComponent - = Position +newtype PositionComponent = Position { position :: V2 Float } - deriving Show + deriving (Show) instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent makeLensesFor [("position", "position")] ''PositionComponent diff --git a/rpg/src/Effectful/Raylib.hs b/rpg/src/Effectful/Raylib.hs index 6fab8b3..038b7e6 100644 --- a/rpg/src/Effectful/Raylib.hs +++ b/rpg/src/Effectful/Raylib.hs @@ -11,6 +11,7 @@ module Effectful.Raylib ( getScreenToWorld2D, isMouseButtonPressed, isMouseButtonReleased, + getFPS, clearBackground, runDraw2D, measureText, @@ -44,6 +45,7 @@ data Raylib :: Effect where GetScreenToWorld2D :: V2 Int -> RL.Camera2D -> Raylib (Eff es) (V2 Float) IsMouseButtonPressed :: RL.MouseButton -> Raylib (Eff es) Bool IsMouseButtonReleased :: RL.MouseButton -> Raylib (Eff es) Bool + GetFPS :: Raylib (Eff es) Int type instance DispatchOf Raylib = Dynamic data RaylibDraw :: Effect where @@ -85,6 +87,9 @@ isMouseButtonPressed mouseButton = send (IsMouseButtonPressed mouseButton) isMouseButtonReleased :: (HasCallStack, Raylib :> es) => RL.MouseButton -> Eff es Bool isMouseButtonReleased mouseButton = send (IsMouseButtonReleased mouseButton) +getFPS :: (HasCallStack, Raylib :> es) => Eff es Int +getFPS = send GetFPS + clearBackground :: (HasCallStack, RaylibDraw :> es) => RL.Color -> Eff es () clearBackground color = send (ClearBackground color) @@ -121,6 +126,7 @@ runRaylibWindow width height name effect = do <&> \(RL.Vector2 x y) -> V2 x y IsMouseButtonPressed mouseButton -> liftIO $ RL.isMouseButtonPressed mouseButton IsMouseButtonReleased mouseButton -> liftIO $ RL.isMouseButtonReleased mouseButton + GetFPS -> liftIO RL.getFPS liftIO $ RL.closeWindow window where diff --git a/rpg/src/Engine.hs b/rpg/src/Engine.hs index 70260f6..11df470 100644 --- a/rpg/src/Engine.hs +++ b/rpg/src/Engine.hs @@ -115,6 +115,8 @@ startEngine = do color <- readVal @backgroundColor @RL.Color clearBackground color + getFPS >>= unsafeEff_ . print + render @w renderOrigins @w renderBoundingBoxes @w diff --git a/rpg/src/Executables/Minkowski.hs b/rpg/src/Executables/Minkowski.hs index 569b947..0978aa6 100644 --- a/rpg/src/Executables/Minkowski.hs +++ b/rpg/src/Executables/Minkowski.hs @@ -67,6 +67,7 @@ runGameState action = do AE.newEntity @World ( Position $ V2 0 0 , Box RL.green (0, 0) (1, 1) + , Body 0.0 0.0 False , AABB (V2 1 1) (V2 0 0) ) @@ -74,6 +75,7 @@ runGameState action = do AE.newEntity @World ( Position $ V2 2 0 , Box RL.green (0, 0) (1, 1) + , Body 0.0 0.0 False , AABB (V2 1 1) (V2 0 0) ) @@ -151,7 +153,7 @@ runEngine = interpret \env eff -> Position bpos <- AE.get @World @PositionComponent box' let offset = pos - bpos let (mpos, maabb) = aabbFromBounds (minkowskiDifference box1' box2') (V2 0 0) - -- liftIO $ print (Velocity (offset ^. _x) (offset ^. _y)) + AE.set @World minkowski' (mpos, maabb) AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y)) Nothing -> pure () diff --git a/rpg/src/Pong.hs b/rpg/src/Executables/Pong.hs similarity index 68% rename from rpg/src/Pong.hs rename to rpg/src/Executables/Pong.hs index f2cfb26..9c90a4a 100644 --- a/rpg/src/Pong.hs +++ b/rpg/src/Executables/Pong.hs @@ -1,6 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module Pong (pongGame) where +module Executables.Pong (pongGame) where import Apecs.Effectful qualified as AE import Common hiding (playerMovement) @@ -8,6 +8,7 @@ import Control.Lens hiding ((%=), (.=)) import Control.Monad.Extra import Data.Text qualified as T import Effectful +import Effectful.Dispatch.Static import Effectful.Raylib import Effectful.Reader.Static import Effectful.State.Static.Local @@ -66,7 +67,7 @@ playerMovement :: forall w es . ( Raylib :> es , AE.Get w PositionComponent - , AE.Set w PositionComponent + , AE.Set w VelocityComponent , AE.ECS w :> es , Reader GameConfig :> es ) @@ -75,89 +76,15 @@ playerMovement -> Eff es AE.Entity -> Eff es () playerMovement (up, upSpeed) (down, downSpeed) entity = do - playArea <- asks @GameConfig (\c -> c.playArea) - isKeyDown up - >>= flip - when - (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) (\(Position p) -> clampPosition playArea . Position $ V2 (p ^. _x) (p ^. _y + downSpeed))) - where - clampPosition - :: Int - -> PositionComponent - -> PositionComponent - 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 + entity' <- entity -ballMovement - :: forall es - . ( AE.ECS World :> es - ) - => 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 top bottom = do - player1' <- player1 - player2' <- player2 - ball' <- ball - top' <- top - bottom' <- bottom - - ballVelocity <- ball >>= AE.get @World - - ballMovement' - ball' - player1' - player2' - bottom' - top' - ballVelocity - >>= AE.set @World ball' - where - invertYVelocity - :: VelocityComponent - -> VelocityComponent - invertYVelocity (Velocity (V2 x y)) = Velocity $ V2 x (-y) - - invertXVelocity - :: VelocityComponent - -> VelocityComponent - invertXVelocity (Velocity (V2 x y)) = Velocity $ V2 (-x) y - - ballMovement' - :: AE.Entity - -> AE.Entity - -> AE.Entity - -> AE.Entity - -> AE.Entity - -> VelocityComponent - -> Eff es VelocityComponent - 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 $ V2 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 - pure ret + down <- isKeyDown down + up <- isKeyDown up + AE.set @w entity' $ + case (down, up) of + (True, False) -> Velocity $ V2 0 downSpeed + (False, True) -> Velocity $ V2 0 upSpeed + (_, _) -> Velocity $ V2 0 0 ballRespawn :: ( AE.ECS World :> es @@ -207,6 +134,7 @@ initialise = do , Position $ V2 (-10) 0 , Box RL.white (0, 0) (0.5, 2) , AABB (V2 0.5 2) (V2 0 0) + , Body 0.0 0.0 False ) player1 .= player1Entity @@ -216,6 +144,7 @@ initialise = do , Position $ V2 10 0 , Box RL.white (0, 0) (0.5, 2) , AABB (V2 0.5 2) (V2 0 0) + , Body 0.0 0.0 False ) player2 .= player2Entity @@ -225,7 +154,7 @@ initialise = do , Velocity $ V2 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) + , Body 1.0 0.0 False ) ball .= ballEntity @@ -249,12 +178,14 @@ initialise = do ( 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) + , Body 0.0 0.0 True ) 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) + , Body 0.0 0.0 True ) topBorder .= topEntity bottomBorder .= bottomEntity @@ -317,11 +248,11 @@ pongGame = do (gets @GameState (\s -> s.ball)) collisionAABB @World - applyVelocity @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) + -- 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 -> @@ -329,6 +260,7 @@ pongGame = do dims <- gets @GameState (\s -> (s.dimX, s.dimY)) camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims + getFPS >>= unsafeEff_ . print runDraw . runDraw2D camera $ do clearBackground RL.gray diff --git a/rpg/src/Lib.hs b/rpg/src/Executables/RPG.hs similarity index 69% rename from rpg/src/Lib.hs rename to rpg/src/Executables/RPG.hs index 848f1be..cc6d7f0 100644 --- a/rpg/src/Lib.hs +++ b/rpg/src/Executables/RPG.hs @@ -13,7 +13,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Lib ( +module Executables.RPG ( runGame, ) where @@ -25,27 +25,24 @@ import Component.Player import Component.Position import Control.Lens hiding ((.=)) import Control.Monad.Extra -import Data.Text (Text) import Data.Text qualified as T import Effectful import Effectful.Accessor import Effectful.Dispatch.Dynamic +import Effectful.Dispatch.Static import Effectful.Raylib import Effectful.Reader.Dynamic import Effectful.State.Static.Local import Effectful.State.Static.Local.Lens import Engine -import GHC.Float import Linear.V2 import Raylib.Core qualified as RL -import Raylib.Core.Shapes qualified as RL -import Raylib.Core.Text qualified as RL import Raylib.Types qualified as RL import Raylib.Util.Colors qualified as RL -import System.Physics -import System.Renderer import World +type LocalWorld = World + data GameConfig = GameConfig { } @@ -70,55 +67,56 @@ makeLensesFor ''GameState spawnPlayer - :: (AE.ECS World :> es) + :: (AE.ECS LocalWorld :> es) => RL.Color -> Eff es AE.Entity spawnPlayer color = - AE.newEntity @World + AE.newEntity @LocalWorld ( Player , Position $ V2 0 2 , Camera 10 (0, 0) , AABB (V2 0.8 0.8) (V2 0 0) - , Body (V2 0 2) + , Body 0.0 0.0 False , Box color (0, 0) (0.8, 0.8) ) movePlayer - :: (AE.ECS World :> es) + :: (AE.ECS LocalWorld :> es) => Eff es AE.Entity -> (Float, Float) -> Eff es () movePlayer eff (x, y) = do entity <- eff - AE.set @World @VelocityComponent entity (Velocity $ V2 x y) + AE.set @LocalWorld @VelocityComponent entity (Velocity $ V2 x y) -- AE.modify @World @PositionComponent @PositionComponent entity (\(Position p) -> Position $ V2 (p ^. _x + x) (p ^. _y + y)) spawnBox - :: (AE.ECS World :> es, Raylib :> es) + :: (AE.ECS LocalWorld :> es, Raylib :> es) => (Float, Float) -> RL.Color -> (Float, Float) -> Eff es AE.Entity spawnBox (posx, posy) color size = do entity <- - AE.newEntity @World + AE.newEntity @LocalWorld ( Box color (0, 0) size , Position $ V2 posx posy + , Body 0.0 0.0 True , AABB (V2 1 1) (V2 0 0) ) font <- getFontDefault - AE.set @World entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow) + AE.set @LocalWorld entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow) pure entity initialise :: ( Raylib :> es , State GameState :> es - , AE.ECS World :> es + , AE.ECS LocalWorld :> es ) => Eff es () initialise = do - setTargetFPS 60 + setTargetFPS 240 player <- spawnPlayer RL.blue playerEntity .= player @@ -131,6 +129,25 @@ initialise = do _ <- spawnBox (3, 1) RL.gray (1, 1) _ <- spawnBox (3, -1) RL.gray (1, 1) _ <- spawnBox (3, -3) RL.gray (1, 1) + AE.newEntity_ @LocalWorld + ( Box RL.blue (0, 0) (1, 1) + , Position $ V2 (-3) 0 + , Body 0.5 0.0 False + , AABB (V2 1 1) (V2 0 0) + ) + AE.newEntity_ @LocalWorld + ( Box RL.blue (0, 0) (1, 1) + , Position $ V2 (-5) 0 + , Body 0.5 0.0 False + , AABB (V2 1 1) (V2 0 0) + ) + + forM_ [(-3) .. 3] \i -> do + spawnBox (-7, i) RL.gray (1, 1) + spawnBox (7, i) RL.gray (1, 1) + forM_ [(-7) .. 7] \i -> do + spawnBox (i, 4) RL.gray (1, 1) + spawnBox (i, -4) RL.gray (1, 1) boxes .= [] @@ -138,9 +155,13 @@ initialise = do data RPGEngine = RPGEngine +data TagComponent a = Tag a + deriving (Show) +instance AE.Component (TagComponent a) where type Storage (TagComponent a) = AE.Map (TagComponent a) + runEngine :: forall es - . ( AE.ECS World :> es + . ( AE.ECS LocalWorld :> es , Raylib :> es , State GameState :> es ) @@ -150,7 +171,11 @@ runEngine = interpret \_ eff -> case eff of EngineInput -> do playerEntity <- gets @GameState (\s -> s.playerEntity) - playerMovement @World + -- AE.modify @LocalWorld @(Maybe (TagComponent Int)) @(TagComponent Int) playerEntity \case + -- Just (Tag n) -> Tag (n + 1) + -- Nothing -> Tag 0 + -- AE.get @LocalWorld @(TagComponent Int) playerEntity >>= unsafeEff_ . print + playerMovement @LocalWorld playerEntity ( RL.KeyA , RL.KeyD @@ -161,11 +186,12 @@ runEngine = interpret \_ eff -> 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})) + isKeyDown RL.KeyKpAdd >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1})) + isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1})) pure () EnginePhysics -> pure () - EngineRendering unlift -> pure () + EngineRendering unlift -> do + 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) @@ -192,11 +218,11 @@ runGame = do . runRaylibWindow gameState.dimX gameState.dimY "App" . runReads @"config.camera" @RL.Camera2D do dims <- gets @GameState (\s -> (s.dimX, s.dimY)) - getCamera @World (gets @GameState (\s -> s.cameraEntity)) dims + getCamera @LocalWorld (gets @GameState (\s -> s.cameraEntity)) dims . runReads @"config.backgroundColor" @RL.Color (pure RL.white) . runEngine $ initialise >> whileM do - startEngine @"config.camera" @"config.backgroundColor" @World + startEngine @"config.camera" @"config.backgroundColor" @LocalWorld not <$> windowShouldClose pure () diff --git a/rpg/src/System/Physics.hs b/rpg/src/System/Physics.hs index 18da8b2..e03f379 100644 --- a/rpg/src/System/Physics.hs +++ b/rpg/src/System/Physics.hs @@ -115,7 +115,6 @@ applyVelocity' = do iterations <- get @Int put @Int $ iterations - 1 - when (entity == 0) $ unsafeEff_ $ print (tangent, velocity1', tangent `dot` velocity1') pure (iterations /= 0 && unVelocity newVelocity /= pure 0 && remainingTime > 0) clampDown :: Float -> Float @@ -142,26 +141,28 @@ applyVelocity'' . ( AE.Get w PositionComponent , AE.Get w VelocityComponent , AE.Get w AABBComponent + , AE.Set w BodyComponent , AE.Set w PositionComponent , AE.ECS w :> es ) => Eff es () applyVelocity'' = do - allEntities <- AE.cfold @w @(AE.Entity, PositionComponent, AABBComponent) (\acc (a, _, _) -> a : acc) [] + allEntities <- AE.cfold @w @(AE.Entity, PositionComponent, AABBComponent, BodyComponent) (\acc (a, _, _, _) -> a : acc) [] let pairs xs = [(x, y) | (x : ys) <- tails (nub xs), y <- ys] entityPairings = pairs allEntities evalState (1.0 :: Float) . evalState (1000 :: Int) . whileM $ do + remainingTime <- get @Float fractions <- forM entityPairings \(entity1, entity2) -> do - (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity1 - (position2, velocity2, aabb2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity2 + (position1, velocity1, aabb1, body1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent, BodyComponent) entity1 + (position2, velocity2, aabb2, body2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent, BodyComponent) entity2 let Velocity velocity1' = fromMaybe (Velocity $ pure 0) velocity1 Velocity velocity2' = fromMaybe (Velocity $ pure 0) velocity2 pure - ( Just ((entity1, position1, velocity1, aabb1), (entity2, position2, velocity2, aabb2)) + ( Just ((entity1, position1, velocity1, aabb1, body1), (entity2, position2, velocity2, aabb2, body2)) , getCollidingVelocityRatio (position1, aabb1, Velocity velocity1') (position2, aabb2, Velocity velocity2') ) @@ -169,15 +170,17 @@ applyVelocity'' = do order (_, a) (_, b) = a `compare` b clampedFractions = map (_2 %~ clampDown) fractions fractions' = filter (not . isNaN . (^. _2)) clampedFractions - (info, minTime) = minimumBy order ((Nothing, 1.0) : fractions') + (info, minTime) = minimumBy order ((Nothing, remainingTime) : fractions') forM_ allEntities \entity1 -> do - (position1, velocity1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent) entity1 + (position1, velocity1, body1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, Maybe BodyComponent) entity1 let velocity1' = fromMaybe (Velocity $ pure 0) velocity1 - AE.set @w entity1 (Position $ position1.position + unVelocity velocity1' * pure (clampDown minTime)) + + unless (unVelocity velocity1' == pure 0 || maybe False (^. immovable) body1) $ + AE.set @w entity1 (Position $ position1.position + unVelocity velocity1' * pure (clampDown minTime)) case info of - Just ((entityA, positionA, velocityA, aabbA), (entityB, positionB, velocityB, aabbB)) -> do + Just ((entityA, positionA, velocityA, aabbA, bodyA), (entityB, positionB, velocityB, aabbB, bodyB)) -> do do let Velocity velocityA' = fromMaybe (Velocity $ pure 0) velocityA @@ -186,22 +189,20 @@ applyVelocity'' = do alongNormalA = velocityA' `dot` normal alongNormalB = velocityB' `dot` normal - bouncinessA = 1.0 - bouncinessB = 1.0 + bouncinessA = 1.0 + bodyA ^. bounciness + bouncinessB = 1.0 + bodyB ^. bounciness - frictionA = 1.0 - frictionB = 1.0 + frictionA = 1.0 + bodyA ^. friction + frictionB = 1.0 + bodyB ^. friction -- friction and bounce - newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA') * frictionA - newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB') * frictionB + newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA' + pure alongNormalB * normal * pure (2.0 - bouncinessB)) * pure frictionA + newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB' + pure alongNormalA * normal * pure (2.0 - bouncinessA)) * pure frictionB - AE.set @w entityA (Velocity newVelocityA') - AE.set @w entityB (Velocity newVelocityB') - pure () + unless (bodyA ^. immovable) $ AE.set @w entityA (Velocity newVelocityA') + unless (bodyB ^. immovable) $ AE.set @w entityB (Velocity newVelocityB') _ -> pure () - remainingTime <- get @Float put @Float $ remainingTime - minTime iterations <- get @Int @@ -295,10 +296,10 @@ collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do boundsB = aabbBounds (Position positionB) aabbB minDiff = minkowskiDifference (Position positionA, aabbA) (Position positionB, aabbB) - case ( minDiff.left <= 0 - , minDiff.right >= 0 - , minDiff.top <= 0 - , minDiff.bottom >= 0 + case ( minDiff.left <= 0.01 + , minDiff.right >= -0.01 + , minDiff.top >= -0.01 + , minDiff.bottom <= 0.01 ) of (True, True, True, True) -> let @@ -368,9 +369,9 @@ collisionAABB ) => Eff es () collisionAABB = - 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) -> + void $ AE.cmapM @w @(AE.Entity, PositionComponent, AABBComponent) @(CollisionComponent) + \(bodyEntity, bodyPosition, bodyAABB) -> do + colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) -> do pure $ if bodyEntity /= colliderEntity then case collides colliderEntity bodyPosition bodyAABB colliderPosition colliderAABB of @@ -390,10 +391,9 @@ resolveAABB => Eff es () resolveAABB = do void $ AE.cmapM @w @(PositionComponent, BodyComponent, CollisionComponent) @PositionComponent - \(Position position, Body previousPosition, collision) -> + \(Position position, Body _ _ _, 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 where diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index a28ae79..8c32f30 100644 --- a/rpg/src/System/Renderer.hs +++ b/rpg/src/System/Renderer.hs @@ -24,8 +24,9 @@ render = do \(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 () + -- 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 diff --git a/rpg/src/World.hs b/rpg/src/World.hs index db07a55..75009a5 100644 --- a/rpg/src/World.hs +++ b/rpg/src/World.hs @@ -1,41 +1,92 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FieldSelectors #-} -{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -module World - ( World - , initWorld - , module Component.Player - , module Component.Position - , module Component.Camera - , module Component.Box - , module Component.Velocity - , module Component.AABB - , module Component.Body - , module Component.Collision - , module Component.TextBox - ) where +module World ( + World, + -- GenericWorld (..), + initWorld, + module Component.Player, + module Component.Position, + module Component.Camera, + module Component.Box, + module Component.Velocity, + module Component.AABB, + module Component.Body, + module Component.Collision, + module Component.TextBox, +) where -import Component.Position -import Component.Player -import Component.Camera -import Component.Box -import Component.Velocity import Component.AABB import Component.Body +import Component.Box +import Component.Camera import Component.Collision +import Component.Player +import Component.Position import Component.TextBox +import Component.Velocity import Apecs -import qualified Apecs.Effectful as AE -import Apecs.Core import Apecs.Components -import Data.Vector.Unboxed +import Apecs.Core +import Apecs.Effectful qualified as AE import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader qualified as MTL +import Data.Functor +import Data.HashMap.Strict qualified as HSS +import Data.IORef +import Data.Vector.Unboxed +import GHC.TypeError +import Type.Reflection +import Unsafe.Coerce -makeWorld "World" [''PositionComponent, ''PlayerComponent, ''CameraComponent, ''BoxComponent, ''VelocityComponent, ''AABBComponent, ''BodyComponent, ''CollisionComponent, ''TextBoxComponent] +data SomeStorage = forall s. SomeStorage s -instance (MonadIO m, Monad m) => ExplMembers m EntityStore where +data GenericStorage = GenericStorage {unGenericStorage :: IORef (HSS.HashMap SomeTypeRep SomeStorage)} +type instance Elem GenericStorage = GenericComponent + +instance (MonadIO m) => ExplInit m GenericStorage where + explInit = liftIO $ GenericStorage <$> newIORef mempty + +data GenericComponent = GenericComponent +instance Component GenericComponent where type Storage GenericComponent = GenericStorage + +makeWorld + "World" + [ ''PositionComponent + , ''PlayerComponent + , ''CameraComponent + , ''BoxComponent + , ''VelocityComponent + , ''AABBComponent + , ''BodyComponent + , ''CollisionComponent + , ''TextBoxComponent + , ''GenericComponent + ] + +instance (Monad m) => ExplMembers m EntityStore where explMembers :: EntityStore -> m (Vector Int) explMembers _ = do pure $ generate 1000 id + +type family TypeEq a b where + TypeEq a a = TypeError (Text "You must add " :<>: ShowType GenericComponent :<>: Text " to the world") + TypeEq a b = False +type a /= b = TypeEq a b ~ False + +instance {-# OVERLAPS #-} (MonadIO m, Component c, Typeable c, c /= GenericComponent, Has w m GenericComponent, ExplInit m (Storage c)) => Has w m c where + getStore :: SystemT w m (Storage c) + getStore = do + genericStore <- getStore @w @m @GenericComponent >>= liftIO . readIORef . unGenericStorage + case genericStore HSS.!? someTypeRep (Proxy @c) of + Just (SomeStorage store) -> pure . unsafeCoerce $ store + Nothing -> do + newStorage <- lift (explInit @_ @(Storage c)) + let genericStore' = HSS.insert (someTypeRep (Proxy @c)) (SomeStorage newStorage) genericStore + getStore @w @m @GenericComponent >>= liftIO . flip writeIORef genericStore' . unGenericStorage + pure newStorage