Stuff&Things

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

flake.nix

@@ -53,6 +53,7 @@
                     xorg.libXi
                     xorg.libXext
                     xorg.libXdmcp
+                    xorg.libXxf86vm
                     libglvnd
                     httplz
                     ((raylib.override { includeEverything = true; }).overrideAttrs (old: {

rpg/package.yaml

@@ -32,6 +32,12 @@ dependencies:
 - linear
 - extra
 - vector
+- mtl
+- unordered-containers
+- primitive
+- containers
+- GLFW-b
+- OpenGL
 
 language: GHC2021
 default-extensions:
@@ -60,7 +66,7 @@ library:
 executables:
   rpg-exe:
     main:                Main.hs
-    source-dirs:         app
+    source-dirs:         rpg
     ghc-options:
     - -threaded
     - -rtsopts

rpg/pong/Main.hs

@@ -1,6 +1,6 @@
 module Main where
 
-import Pong
+import Executables.Pong
 
 main :: IO ()
 main = pongGame

rpg/rpg.cabal

@@ -41,8 +41,12 @@ library
       Effectful.State.Static.Local.Lens
       Engine
       Executables.Minkowski
-      Lib
+      Executables.Pong
-      Pong
+      Executables.RPG
+      Noise.Perlin
+      Signals
+      Stores.SparseSet
+      System.OpenGLRenderer
       System.Physics
       System.Renderer
       World
@@ -62,17 +66,23 @@ library
       LambdaCase
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
   build-depends:
-      apecs
+      GLFW-b
+    , OpenGL
+    , apecs
     , apecs-effectful
     , base >=4.7 && <5
     , bytestring
+    , containers
     , effectful
     , effectful-core
     , extra
     , h-raylib
     , lens
     , linear
+    , mtl
+    , primitive
     , text
+    , unordered-containers
     , vector
   default-language: GHC2021
 
@@ -94,18 +104,24 @@ executable minkowski
       LambdaCase
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      apecs
+      GLFW-b
+    , OpenGL
+    , apecs
     , apecs-effectful
     , base >=4.7 && <5
     , bytestring
+    , containers
     , effectful
     , effectful-core
     , extra
     , h-raylib
     , lens
     , linear
+    , mtl
+    , primitive
     , rpg
     , text
+    , unordered-containers
     , vector
   default-language: GHC2021
 
@@ -127,18 +143,24 @@ executable pong
       LambdaCase
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      apecs
+      GLFW-b
+    , OpenGL
+    , apecs
     , apecs-effectful
     , base >=4.7 && <5
     , bytestring
+    , containers
     , effectful
     , effectful-core
     , extra
     , h-raylib
     , lens
     , linear
+    , mtl
+    , primitive
     , rpg
     , text
+    , unordered-containers
     , vector
   default-language: GHC2021
 
@@ -149,7 +171,7 @@ executable rpg-exe
   autogen-modules:
       Paths_rpg
   hs-source-dirs:
-      app
+      rpg
   default-extensions:
       OverloadedStrings
       DuplicateRecordFields
@@ -160,18 +182,24 @@ executable rpg-exe
       LambdaCase
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      apecs
+      GLFW-b
+    , OpenGL
+    , apecs
     , apecs-effectful
     , base >=4.7 && <5
     , bytestring
+    , containers
     , effectful
     , effectful-core
     , extra
     , h-raylib
     , lens
     , linear
+    , mtl
+    , primitive
     , rpg
     , text
+    , unordered-containers
     , vector
   default-language: GHC2021
 
@@ -194,17 +222,23 @@ test-suite rpg-test
       LambdaCase
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      apecs
+      GLFW-b
+    , OpenGL
+    , apecs
     , apecs-effectful
     , base >=4.7 && <5
     , bytestring
+    , containers
     , effectful
     , effectful-core
     , extra
     , h-raylib
     , lens
     , linear
+    , mtl
+    , primitive
     , rpg
     , text
+    , unordered-containers
     , vector
   default-language: GHC2021

rpg/rpg/Main.hs

@@ -1,5 +1,5 @@
 module Main where
 
-import Lib
+import Executables.RPG
 
 main = runGame

rpg/src/Component/Body.hs

@@ -1,16 +1,21 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Component.Body (BodyComponent(..), previousPosition) where
+module Component.Body (BodyComponent (..), bounciness, friction, immovable) where
-import Apecs.Effectful
-import Linear.V2
-import Control.Lens
 
-data BodyComponent
+import Apecs.Effectful
-  = Body
+import Control.Lens
-  { previousPosition :: V2 Float
+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")
+  [ ("bounciness", "bounciness")
-  ] ''BodyComponent
+  , ("friction", "friction")
+  , ("immovable", "immovable")
+  ]
+  ''BodyComponent

rpg/src/Component/Position.hs

@@ -1,15 +1,21 @@
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Component.Position (PositionComponent(..), position) where
+module Component.Position (PositionComponent (..), position) where
 
-import Apecs.Effectful
+import Apecs.Core
-import Linear.V2
 import Control.Lens
+import Foreign.Storable
+import Linear.V2
+import Stores.SparseSet
 
-newtype PositionComponent
+newtype PositionComponent = Position
-  = Position
   { position :: V2 Float
   }
-  deriving Show
+  deriving (Show)
-instance Component PositionComponent where type Storage PositionComponent = Map PositionComponent
+  deriving newtype (Storable)
+instance Component PositionComponent where type Storage PositionComponent = SparseSet IO PositionComponent
 makeLensesFor [("position", "position")] ''PositionComponent
+
+instance ComponentDefault PositionComponent where
+  componentDefault = Position (V2 0 0)

rpg/src/Component/Velocity.hs

@@ -1,13 +1,20 @@
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Component.Velocity (VelocityComponent (..), unVelocity) where
 
 import Apecs.Effectful
+import Foreign.Storable
 import Linear.V2
+import Stores.SparseSet
 
 newtype VelocityComponent = Velocity (V2 Float)
   deriving (Show, Num)
-instance Component VelocityComponent where type Storage VelocityComponent = Map VelocityComponent
+  deriving newtype (Storable)
+instance Component VelocityComponent where type Storage VelocityComponent = SparseSet IO VelocityComponent
 
 unVelocity :: VelocityComponent -> V2 Float
 unVelocity (Velocity v) = v
+
+instance ComponentDefault VelocityComponent where
+  componentDefault = Velocity (V2 0 0)

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

rpg/src/Engine.hs

@@ -104,8 +104,8 @@ startEngine = do
   engineInput
   applyVelocity'' @w
 
-  collisionAABB @w
+  -- collisionAABB @w
-  resolveAABB @w
+  -- resolveAABB @w
 
   enginePhysics
 
@@ -115,9 +115,11 @@ startEngine = do
     color <- readVal @backgroundColor @RL.Color
     clearBackground color
 
+    getFPS >>= unsafeEff_ . print
+
     render @w
-    renderOrigins @w
+    -- renderOrigins @w
-    renderBoundingBoxes @w
+    -- renderBoundingBoxes @w
-    renderCollision @w
+    -- renderCollision @w
 
     engineRendering

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

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)
+  entity' <- entity
-  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
 
-ballMovement
+  down <- isKeyDown down
-  :: forall es
+  up <- isKeyDown up
-   . ( AE.ECS World :> es
+  AE.set @w entity' $
-     )
+    case (down, up) of
-  => Eff es AE.Entity
+      (True, False) -> Velocity $ V2 0 downSpeed
-  -> Eff es AE.Entity
+      (False, True) -> Velocity $ V2 0 upSpeed
-  -> Eff es AE.Entity
+      (_, _) -> Velocity $ V2 0 0
-  -> 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
 
 ballRespawn
   :: ( AE.ECS World :> es
@@ -207,6 +134,11 @@ initialise = do
       , Position $ V2 (-10) 0
       , Box RL.white (0, 0) (0.5, 2)
       , AABB (V2 0.5 2) (V2 0 0)
+      , Body
+          { bounciness = 0.0
+          , friction = 0.0
+          , immovable = False
+          }
       )
   player1 .= player1Entity
 
@@ -216,6 +148,11 @@ initialise = do
       , Position $ V2 10 0
       , Box RL.white (0, 0) (0.5, 2)
       , AABB (V2 0.5 2) (V2 0 0)
+      , Body
+          { bounciness = 0.0
+          , friction = 0.0
+          , immovable = False
+          }
       )
   player2 .= player2Entity
 
@@ -225,7 +162,11 @@ 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
+          { bounciness = 1.0
+          , friction = 0.0
+          , immovable = False
+          }
       )
   ball .= ballEntity
 
@@ -249,12 +190,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 +260,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) ->
+      -- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) ->
-        when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position)
+      --   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 +272,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
 

rpg/src/Executables/RPG.hs

@@ -13,7 +13,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Lib (
+module Executables.RPG (
   runGame,
 ) where
 
@@ -25,27 +25,26 @@ 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 GHC.Float (float2Int, floorFloat)
 import Linear.V2
+import Noise.Perlin
 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,56 +69,54 @@ 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)
-  => 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.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
 
+  forM_ [-32 .. 32] \x -> do
+    forM_ [-32 .. 32] \y -> do
+      let height = floorFloat $ (perlin (x / 5) (y / 5) * 0.5 + 0.5) * 255
+      AE.newEntity_ @LocalWorld
+        ( Box (RL.Color height height height 255) (0, 0) (1, 1)
+        , Position $ V2 x y
+        )
+
   player <- spawnPlayer RL.blue
   playerEntity .= player
   cameraEntity .= player
@@ -131,16 +128,33 @@ 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
+    void $ spawnBox (-7, i) RL.gray (1, 1)
+    spawnBox (7, i) RL.gray (1, 1)
+  forM_ [(-7) .. 7] \i -> do
+    void $ spawnBox (i, 4) RL.gray (1, 1)
+    spawnBox (i, -4) RL.gray (1, 1)
 
   boxes .= []
 
   pure ()
 
-data RPGEngine = RPGEngine
-
 runEngine
   :: forall es
-   . ( AE.ECS World :> es
+   . ( AE.ECS LocalWorld :> es
      , Raylib :> es
      , State GameState :> es
      )
@@ -150,7 +164,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 +179,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.KeyKpAdd >>= flip when (AE.modify @LocalWorld @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.KeyKpSubtract >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1}))
       pure ()
     EnginePhysics -> pure ()
-    EngineRendering unlift -> pure ()
+    EngineRendering _ -> 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)
@@ -182,8 +201,12 @@ runGame = do
           , dimY = 450
           , playerEntity = undefined
           , cameraEntity = undefined
+          , camera = undefined
+          , boxes = undefined
           }
 
+  print $ perlin 0 0
+
   RL.setTraceLogLevel RL.LogWarning
   runEff
     . AE.runECS initWorld
@@ -192,11 +215,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 ()

rpg/src/Noise/Perlin.hs

@@ -0,0 +1,70 @@
+module Noise.Perlin (perlin) where
+
+import Control.Lens
+import Control.Monad.State
+import Data.Bits
+import Debug.Trace
+import Foreign (Storable (..))
+import Foreign.C.Types
+import GHC.Float
+import Linear.V2
+
+-- https://adrianb.io/2014/08/09/perlinnoise.html retry with that?
+
+interpolate :: Float -> Float -> Float -> Float
+interpolate a0 a1 weight = (a1 - a0) * weight + a0
+
+randomGradient :: Int -> Int -> V2 Float
+randomGradient iX iY = v
+ where
+  w :: CUInt
+  w = fromIntegral $ 8 * sizeOf (undefined :: CUInt)
+  s = w `div` 2
+
+  _a :: forall s t a b. (Field1 s t a b) => Lens s t a b
+  _a = _1
+  _b :: forall s t a b. (Field2 s t a b) => Lens s t a b
+  _b = _2
+  deltaWS = w - s
+  (a, b) :: (CUInt, CUInt) = flip execState (fromIntegral iX, fromIntegral iY) $ do
+    _a *= 3284157443
+    (a, _) <- get
+    _b ^= (a .<<. fromIntegral s) .|. (a .>>. fromIntegral deltaWS)
+    _b *= 1911520717
+    (_, b) <- get
+    _a ^= (b .<<. fromIntegral s) .|. (b .>>. fromIntegral deltaWS)
+    _a *= 2048419325
+
+  random = fromIntegral a * (3.14159265 / (fromIntegral . complement $ (complement (0 :: CUInt) `shiftR` 1)))
+  v = V2 (cos random) (sin random)
+
+dotGridGradient :: Int -> Int -> Float -> Float -> Float
+dotGridGradient iX iY x y = dx * gradient ^. _x + dy * gradient ^. _y
+ where
+  gradient = randomGradient iX iY
+
+  dx = x - fromIntegral iX
+  dy = y - fromIntegral iY
+
+perlin :: Float -> Float -> Float
+perlin x y = value
+ where
+  x0 = floorFloat x
+  x1 = x0 + 1
+  y0 = floorFloat y
+  y1 = y0 + 1
+
+  sx = traceShowId $ x - fromIntegral x0
+  sy = traceShowId $ y - fromIntegral y0
+
+  ix0 = interpolate n0 n1 sx
+   where
+    n0 = dotGridGradient x0 y0 x y
+    n1 = dotGridGradient x1 y0 x y
+
+  ix1 = interpolate n0 n1 sx
+   where
+    n0 = dotGridGradient x0 y1 x y
+    n1 = dotGridGradient x1 y1 x y
+
+  value = interpolate ix0 ix1 sy

rpg/src/Signals.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Signals () where
+
+import Apecs.Effectful qualified as AE
+import Effectful
+
+class Signal s
+
+-- signal :: forall s es w. (AE.Set w s, AE.ECS w :> es, Signals :> es) => AE.Entity -> s -> Eff es ()
+-- signal entity sig = do
+--   AE.set @w entity sig

rpg/src/Stores/SparseSet.hs

@@ -0,0 +1,185 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Stores.SparseSet (SparseSet, ComponentDefault (..), empty, exists, insert, remove, elements, members, unsafeElements, unsafeMembers, toPairs) where
+
+import Apecs.Core
+import Control.Lens hiding (elements)
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Primitive
+import Data.STRef
+import Data.Typeable (Typeable, typeRep)
+import Data.Vector qualified as V
+import Data.Vector.Generic qualified as VG
+import Data.Vector.Storable qualified as VS hiding (replicate, take)
+import Data.Vector.Storable.Mutable qualified as VS
+import Data.Vector.Unboxed qualified as VU hiding (replicate, take)
+import Data.Vector.Unboxed.Mutable qualified as VU
+import Foreign.Storable
+import Prelude hiding (lookup)
+
+type SparseSet' s a = (VU.MVector s Int, VU.MVector s Int, VS.MVector s a, Int, Int)
+newtype SparseSet m a = SparseSet (STRef (PrimState m) (SparseSet' (PrimState m) a))
+
+ssSparse :: Lens' (SparseSet' s a) (VU.MVector s Int)
+ssSparse = _1
+ssDenseIndex :: Lens' (SparseSet' s a) (VU.MVector s Int)
+ssDenseIndex = _2
+ssDense :: Lens' (SparseSet' s a) (VS.MVector s a)
+ssDense = _3
+ssN :: Lens' (SparseSet' s a) Int
+ssN = _4
+ssMax :: Lens' (SparseSet' s a) Int
+ssMax = _5
+
+empty :: (PrimMonad m, Storable a) => a -> Int -> m (SparseSet m a)
+empty defaultValue size = do
+  sparseVector <- VU.replicate size 0
+  denseIndex <- VU.replicate size 0
+  denseStorableVector <- VS.replicate size defaultValue
+
+  stToPrim (newSTRef (sparseVector, denseIndex, denseStorableVector, 0, size)) <&> SparseSet
+
+-- | Handle the 'Left' constructor of the returned 'Either'
+onLeft
+  :: forall x m a
+   . ()
+  => (Monad m)
+  => (x -> m a)
+  -> m (Either x a)
+  -> m a
+onLeft g f = f >>= either g pure
+
+checkBounds :: (Monad m) => Int -> Int -> ExceptT () m ()
+checkBounds maxN idx = unless (idx >= 0 && idx <= maxN) (throwError ())
+
+exists :: (PrimMonad m) => SparseSet m a -> Int -> m Bool
+exists (SparseSet sparseSet') idx = onLeft (const $ pure False) $ runExceptT do
+  sparseSet <- stToPrim $ readSTRef sparseSet'
+
+  checkBounds (sparseSet ^. ssMax) idx
+
+  denseIndex <- VU.read (sparseSet ^. ssSparse) idx
+  sparseIndex <- VU.read (sparseSet ^. ssDenseIndex) denseIndex
+
+  pure $ denseIndex < (sparseSet ^. ssN) && sparseIndex == idx
+
+lookup :: (Storable a, PrimMonad m) => SparseSet m a -> Int -> m (Maybe a)
+lookup (SparseSet sparseSet') idx =
+  exists (SparseSet sparseSet') idx
+    >>= \case
+      False -> pure Nothing
+      True -> do
+        sparseSet <- stToPrim $ readSTRef sparseSet'
+
+        denseIndex <- VU.read (sparseSet ^. ssSparse) idx
+        VS.read (sparseSet ^. ssDense) denseIndex <&> Just
+
+insert :: (Storable a, PrimMonad m) => SparseSet m a -> Int -> a -> m ()
+insert (SparseSet sparseSet') idx value = do
+  sparseSet <- stToPrim $ readSTRef sparseSet'
+
+  -- expand instead
+  -- checkBounds (sparseSet ^. ssMax) idx
+  when (idx >= sparseSet ^. ssMax) (error "SparseSet expansion not implemented")
+
+  exists (SparseSet sparseSet') idx >>= \case
+    True -> do
+      denseIndex <- VU.read (sparseSet ^. ssSparse) idx
+      VS.write (sparseSet ^. ssDense) denseIndex value
+    False -> do
+      VS.write (sparseSet ^. ssDense) (sparseSet ^. ssN) value
+      VU.write (sparseSet ^. ssDenseIndex) (sparseSet ^. ssN) idx
+      VU.write (sparseSet ^. ssSparse) idx (sparseSet ^. ssN)
+
+      stToPrim $ writeSTRef sparseSet' (sparseSet & ssN %~ (+ 1))
+
+remove :: (Storable a, PrimMonad m) => SparseSet m a -> Int -> m ()
+remove (SparseSet sparseSet') idx = do
+  sparseSet <- stToPrim $ readSTRef sparseSet'
+
+  exists (SparseSet sparseSet') idx >>= \case
+    False -> pure ()
+    True -> do
+      let n = (sparseSet ^. ssN) - 1
+
+      denseIndex <- VU.read (sparseSet ^. ssSparse) n
+      sparseIndex <- VU.read (sparseSet ^. ssDenseIndex) n
+      item <- VS.read (sparseSet ^. ssDense) denseIndex
+
+      VS.write (sparseSet ^. ssDense) denseIndex item
+      VU.write (sparseSet ^. ssDenseIndex) denseIndex sparseIndex
+      VU.write (sparseSet ^. ssSparse) sparseIndex denseIndex
+
+      stToPrim $ writeSTRef sparseSet' (sparseSet & ssN .~ n)
+
+elements :: (Storable a, PrimMonad m) => SparseSet m a -> m (VS.Vector a)
+elements (SparseSet sparseSet') = do
+  sparseSet <- stToPrim $ readSTRef sparseSet'
+
+  VS.freeze (VS.take (sparseSet ^. ssN) (sparseSet ^. ssDense))
+
+unsafeElements :: (Storable a, PrimMonad m) => SparseSet m a -> m (VS.Vector a)
+unsafeElements (SparseSet sparseSet') = do
+  sparseSet <- stToPrim $ readSTRef sparseSet'
+
+  VS.unsafeFreeze (VS.take (sparseSet ^. ssN) (sparseSet ^. ssDense))
+
+members :: (PrimMonad m) => SparseSet m a -> m (VU.Vector Int)
+members (SparseSet sparseSet') = do
+  sparseSet <- stToPrim $ readSTRef sparseSet'
+
+  VU.freeze (VU.take (sparseSet ^. ssN) (sparseSet ^. ssDenseIndex))
+
+unsafeMembers :: (PrimMonad m) => SparseSet m a -> m (VU.Vector Int)
+unsafeMembers (SparseSet sparseSet') = do
+  sparseSet <- stToPrim $ readSTRef sparseSet'
+
+  VU.unsafeFreeze (VU.take (sparseSet ^. ssN) (sparseSet ^. ssDenseIndex))
+
+toPairs :: (Storable a, PrimMonad m) => SparseSet m a -> m (V.Vector (Int, a))
+toPairs sparseSet' = do
+  membersVector <- members sparseSet'
+  elementsVector <- elements sparseSet'
+
+  pure $ VG.zip (VG.convert membersVector) (VG.convert elementsVector)
+
+type instance Elem (SparseSet m c) = c
+
+class (Component c) => ComponentDefault c where
+  componentDefault :: c
+
+instance (PrimMonad m, ComponentDefault a, Storable a) => ExplInit m (SparseSet m a) where
+  explInit :: m (SparseSet m a)
+  explInit = empty componentDefault 5000
+
+{- FOURMOLU_DISABLE -}
+instance (PrimMonad m, Typeable a, Storable a) => ExplGet m (SparseSet m a) where
+  {-# INLINE explGet #-}
+  explGet :: SparseSet m a -> Int -> m (Elem (SparseSet m a))
+  explGet sparseSet ety =
+    lookup sparseSet ety >>= \case
+      Just a -> pure a
+      notFound -> error $ unwords
+        [ "Reading non-existent StorableSet component"
+        , show (typeRep notFound)
+        ]
+  {-# INLINE explExists #-}
+  explExists :: SparseSet m a -> Int -> m Bool
+  explExists = exists
+{- FOURMOLU_ENABLE -}
+
+instance (PrimMonad m, Storable a) => ExplSet m (SparseSet m a) where
+  {-# INLINE explSet #-}
+  explSet :: SparseSet m a -> Int -> Elem (SparseSet m a) -> m ()
+  explSet = insert
+
+instance (PrimMonad m, Storable a) => ExplDestroy m (SparseSet m a) where
+  {-# INLINE explDestroy #-}
+  explDestroy :: SparseSet m a -> Int -> m ()
+  explDestroy = remove
+
+instance (PrimMonad m) => ExplMembers m (SparseSet m a) where
+  explMembers :: SparseSet m a -> m (VU.Vector Int)
+  {-# INLINE explMembers #-}
+  explMembers = unsafeMembers

rpg/src/System/OpenGLRenderer.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module System.OpenGLRenderer where
+
+import Apecs.Effectful qualified as AE
+import Effectful
+import World
+
+render
+  :: forall w es
+   . ( AE.Get w PositionComponent
+     , AE.Get w BoxComponent
+     , AE.Get w TextBoxComponent
+     , AE.ECS w :> es
+     , IOE :> es
+     )
+  => Eff es ()
+render = do
+  pure ()

rpg/src/System/Physics.hs

@@ -21,6 +21,7 @@ import Apecs qualified
 import Apecs.Components (EntityStore)
 import Apecs.Components qualified as AE (EntityStore)
 import Apecs.Core qualified
+import Apecs.Core qualified as Apecs
 import Apecs.Effectful qualified as AE
 import Control.Lens
 import Control.Monad.Extra
@@ -30,6 +31,7 @@ import Data.Maybe (catMaybes, fromMaybe, isJust)
 import Debug.Trace qualified as Debug
 import Effectful
 import Effectful.Dispatch.Static (unsafeEff_)
+import Effectful.Internal.Monad (getStaticRep)
 import Effectful.Raylib
 import Effectful.State.Static.Local (evalState, get, modify, put)
 import Linear
@@ -76,7 +78,7 @@ applyVelocity' = do
       []
       <&> pairs
 
-  forM_ entities \(entity, entities') -> evalState (1.0 :: Float) . evalState (1000 :: Int) $ whileM do
+  forM_ entities \(entity, entities') -> evalState (1.0 :: Float) . evalState (100 :: Int) $ whileM do
     (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity
     let Velocity velocity1' = fromMaybe (Velocity $ pure 0) velocity1
 
@@ -115,7 +117,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 +143,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
+  evalState (1.0 :: Float) . evalState (16 :: Int) . whileM $ do
+    remainingTime <- get @Float
     fractions <- forM entityPairings \(entity1, entity2) -> do
-      (position1, velocity1, aabb1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity1
+      (position1, velocity1, aabb1, body1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent, BodyComponent) entity1
-      (position2, velocity2, aabb2) <- AE.get @w @(PositionComponent, Maybe VelocityComponent, AABBComponent) entity2
+      (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 +172,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
+    AE.cmap @w @(PositionComponent, AABBComponent, Maybe BodyComponent, Maybe VelocityComponent) @PositionComponent \(position1, _, body1, velocity1) ->
-      (position1, velocity1) <- AE.get @w @(PositionComponent, Maybe VelocityComponent) entity1
       let
         velocity1' = fromMaybe (Velocity $ pure 0) velocity1
-      AE.set @w entity1 (Position $ position1.position + unVelocity velocity1' * pure (clampDown minTime))
+       in
+        if unVelocity velocity1' == pure 0 || maybe False (^. immovable) body1
+          then position1
+          else 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 +191,20 @@ applyVelocity'' = do
             alongNormalA = velocityA' `dot` normal
             alongNormalB = velocityB' `dot` normal
 
-            bouncinessA = 1.0
+            bouncinessA = 1.0 + bodyA ^. bounciness
-            bouncinessB = 1.0
+            bouncinessB = 1.0 + bodyB ^. bounciness
 
-            frictionA = 1.0
+            frictionA = 1.0 + bodyA ^. friction
-            frictionB = 1.0
+            frictionB = 1.0 + bodyB ^. friction
 
             -- friction and bounce
-            newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA') * frictionA
+            newVelocityA' = (pure (-alongNormalA) * normal * pure bouncinessA + velocityA' + pure alongNormalB * normal * pure (2.0 - bouncinessB)) * pure frictionA
-            newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB') * frictionB
+            newVelocityB' = (pure (-alongNormalB) * normal * pure bouncinessB + velocityB' + pure alongNormalA * normal * pure (2.0 - bouncinessA)) * pure frictionB
 
-          AE.set @w entityA (Velocity newVelocityA')
+          unless (bodyA ^. immovable) $ AE.set @w entityA (Velocity newVelocityA')
-          AE.set @w entityB (Velocity newVelocityB')
+          unless (bodyB ^. immovable) $ AE.set @w entityB (Velocity newVelocityB')
-          pure ()
       _ -> pure ()
 
-    remainingTime <- get @Float
     put @Float $ remainingTime - minTime
 
     iterations <- get @Int
@@ -295,10 +298,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
+  case ( minDiff.left <= 0.01
-       , minDiff.right >= 0
+       , minDiff.right >= -0.01
-       , minDiff.top <= 0
+       , minDiff.top >= -0.01
-       , minDiff.bottom >= 0
+       , minDiff.bottom <= 0.01
        ) of
     (True, True, True, True) ->
       let
@@ -308,8 +311,6 @@ collides bEntity (Position positionA) aabbA (Position positionB) aabbB = do
         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
@@ -368,9 +369,9 @@ collisionAABB
      )
   => Eff es ()
 collisionAABB =
-  void $ AE.cmapM @w @(AE.Entity, PositionComponent, BodyComponent, AABBComponent) @(CollisionComponent)
+  void $ AE.cmapM @w @(AE.Entity, PositionComponent, AABBComponent) @(CollisionComponent)
-    \(bodyEntity, bodyPosition, _, bodyAABB) -> do
+    \(bodyEntity, bodyPosition, bodyAABB) -> do
-      colliders <- flip (AE.cfoldM @w @(AE.Entity, PositionComponent, AABBComponent)) [] \acc (colliderEntity, colliderPosition, colliderAABB) ->
+      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

rpg/src/System/Renderer.hs

@@ -1,55 +1,59 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+
 module System.Renderer (render, renderOrigins, renderBoundingBoxes, renderCollision) where
 
-import Effectful
+import Apecs.Effectful qualified as AE
-import qualified Apecs.Effectful as AE
-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
+import Effectful
+import Effectful.Raylib
+import Linear.V2 (V2 (..), _x, _y)
+import Raylib.Util.Colors qualified as RL
+import World
 
 render
-  :: forall w es .
+  :: forall w es
-     ( AE.Get w PositionComponent
+   . ( AE.Get w PositionComponent
      , AE.Get w BoxComponent
      , AE.Get w TextBoxComponent
      , AE.ECS w :> es
-     , RaylibDraw2D :> es )
+     , RaylibDraw2D :> es
+     )
   => Eff es ()
 render = do
   AE.cmapM_ @w @(PositionComponent, BoxComponent)
-    \(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
+    \(Position (V2 x y), Box color offset (dx, dy)) ->
+      drawRectangle (x + fst offset - dx / 2) (y + snd offset - dy / 2) dx dy color
   AE.cmapM_ @w @(PositionComponent, TextBoxComponent)
     \(Position position, TextBox font text fontSize spacing color) -> do
-      size <- measureText font text fontSize spacing
+      -- size <- measureText font text fontSize spacing
-      drawText font text (V2 (position ^. _x - size ^. _x / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
+      -- let size = V2 0 0
-  pure ()
+      -- drawText font text (V2 (position ^. _x - size ^. _y / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
+      pure ()
 
 renderCollision
-  :: forall w es .
+  :: forall w es
-  ( AE.Get w PositionComponent
+   . ( AE.Get w PositionComponent
-  , AE.Get w CollisionComponent
+     , AE.Get w CollisionComponent
-  , AE.Get w BoxComponent
+     , AE.Get w BoxComponent
-  , AE.ECS w :> es
+     , AE.ECS w :> es
-  , RaylibDraw2D :> es
+     , RaylibDraw2D :> es
-  )
+     )
   => Eff es ()
 renderCollision =
   AE.cmapM_ @w @(PositionComponent, CollisionComponent, BoxComponent)
     \(Position (V2 x y), Collision colliders, _) ->
-      forM_ colliders
+      forM_
-      (\(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
+        colliders
-          drawLine x y (x + offsetX) (y + offsetY) RL.green
+        ( \(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
-          drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 + overlapX / 2) (y + offsetY / 2 + overlapY / 2) RL.yellow
+            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.orange
+            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 .
+  :: forall w es
-     ( AE.Get w PositionComponent
+   . ( AE.Get w PositionComponent
      , AE.ECS w :> es
      , RaylibDraw2D :> es
      )
@@ -57,16 +61,16 @@ renderOrigins
 renderOrigins = do
   AE.cmapM_ @w @PositionComponent
     \(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
-      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 .
+  :: forall w es
-  ( AE.Get w PositionComponent
+   . ( AE.Get w PositionComponent
-  , AE.Get w AABBComponent
+     , AE.Get w AABBComponent
-  , RaylibDraw2D :> es
+     , RaylibDraw2D :> es
-  , AE.ECS w :> es
+     , AE.ECS w :> es
-  )
+     )
   => Eff es ()
 renderBoundingBoxes =
   AE.cmapM_ @w @(PositionComponent, AABBComponent)

rpg/src/World.hs

@@ -1,41 +1,95 @@
-{-# 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
+module World (
-  ( World
+  World,
-  , initWorld
+  -- GenericWorld (..),
-  , module Component.Player
+  initWorld,
-  , module Component.Position
+  module Component.Player,
-  , module Component.Camera
+  module Component.Position,
-  , module Component.Box
+  module Component.Camera,
-  , module Component.Velocity
+  module Component.Box,
-  , module Component.AABB
+  module Component.Velocity,
-  , module Component.Body
+  module Component.AABB,
-  , module Component.Collision
+  module Component.Body,
-  , module Component.TextBox
+  module Component.Collision,
-  ) where
+  module Component.TextBox,
+  TypeEq,
+  type (/=),
+) 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
+newtype 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
+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
+    pure $ generate 5000 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
+    liftIO $ print "going generic"
+    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