Pre optimization

Signed-off-by: magic_rb <richard@brezak.sk>
2024-11-21 23:34:21 +01:00 · 2024-01-03 22:40:30 +01:00 · 2024-01-03 22:40:30 +01:00 · 5d53c2aa90
parent e485fe4a7b
commit 5d53c2aa90
14 changed files with 226 additions and 189 deletions
--- 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
--- 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
--- 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
--- a/rpg/rpg/Main.hs
+++ b/rpg/rpg/Main.hs
@ -1,5 +1,5 @@
 module Main where

-import Lib
+import Executables.RPG

 main = runGame
--- 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
--- 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
--- 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
--- 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
--- 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 ()
--- a/rpg/src/Executables/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

--- a/rpg/src/Executables/RPG.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 ()
--- 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
--- 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
--- 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