105 fps +-

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

flake.nix

@@ -41,6 +41,7 @@
                     hPkgs.ghc
                     hPkgs.implicit-hie
                     hPkgs.haskell-language-server
+                    hPkgs.profiterole
                     SDL2
                     SDL2_image
                     libtiff

rpg/cbits/raylib_batch.c

@@ -0,0 +1,7 @@
+#include "raylib_batch.h"
+
+void draw_rectangles_batch(const rectangle_info_t* rectangles, size_t count) {
+  for (size_t i = 0; i < count; i++) {
+    DrawRectangleV(rectangles[i].position, rectangles[i].size, rectangles[i].color);
+  }
+}

rpg/cbits/raylib_batch.h

@@ -0,0 +1,10 @@
+#include <raylib.h>
+#include <stddef.h>
+
+typedef struct rectangle_info {
+  Vector2 position;
+  Vector2 size;
+  Color color;
+} rectangle_info_t;
+
+void draw_rectangles_batch(const rectangle_info_t* rectangles, size_t count);

rpg/package.yaml

@@ -38,6 +38,8 @@ dependencies:
 - containers
 - GLFW-b
 - OpenGL
+- derive-storable
+- derive-storable-plugin
 
 language: GHC2021
 default-extensions:
@@ -62,6 +64,8 @@ ghc-options:
 
 library:
   source-dirs: src
+  c-sources: cbits/*.c
+  include-dirs: cbits
 
 executables:
   rpg-exe:

rpg/rpg.cabal

@@ -65,6 +65,10 @@ library
       TemplateHaskell
       LambdaCase
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+  include-dirs:
+      cbits
+  c-sources:
+      cbits/raylib_batch.c
   build-depends:
       GLFW-b
     , OpenGL
@@ -73,6 +77,8 @@ library
     , base >=4.7 && <5
     , bytestring
     , containers
+    , derive-storable
+    , derive-storable-plugin
     , effectful
     , effectful-core
     , extra
@@ -111,6 +117,8 @@ executable minkowski
     , base >=4.7 && <5
     , bytestring
     , containers
+    , derive-storable
+    , derive-storable-plugin
     , effectful
     , effectful-core
     , extra
@@ -150,6 +158,8 @@ executable pong
     , base >=4.7 && <5
     , bytestring
     , containers
+    , derive-storable
+    , derive-storable-plugin
     , effectful
     , effectful-core
     , extra
@@ -189,6 +199,8 @@ executable rpg-exe
     , base >=4.7 && <5
     , bytestring
     , containers
+    , derive-storable
+    , derive-storable-plugin
     , effectful
     , effectful-core
     , extra
@@ -229,6 +241,8 @@ test-suite rpg-test
     , base >=4.7 && <5
     , bytestring
     , containers
+    , derive-storable
+    , derive-storable-plugin
     , effectful
     , effectful-core
     , extra

rpg/rpg/Main.hs

@@ -2,4 +2,4 @@ module Main where
 
 import Executables.RPG
 
-main = runGame
+main = main'

rpg/src/Common.hs

@@ -5,11 +5,11 @@ module Common (getCamera, playerMovement) where
 import Apecs.Effectful qualified as AE
 import Control.Lens
 import Effectful
-import Effectful.Raylib
 import GHC.Float
 import Linear (normalize)
 import Linear.V2
 import Raylib.Types qualified as RL
+import System.Renderer
 import World
 
 getCamera
@@ -36,9 +36,9 @@ getCamera eff (dimX, dimY) = do
 
 playerMovement
   :: forall w es
-   . ( Raylib :> es
+   . ( AE.ECS w :> es
-     , AE.ECS w :> es
      , AE.Get w VelocityComponent
+     , Renderer :> es
      )
   => AE.Entity
   -> ( RL.KeyboardKey

rpg/src/Effectful/Raylib.hs

@@ -108,11 +108,11 @@ drawRectangle posX posY width height color = send (DrawRectangle posX posY width
 drawLine :: (HasCallStack, RaylibDraw2D :> es) => Float -> Float -> Float -> Float -> RL.Color -> Eff es ()
 drawLine posX posY endX endY color = send (DrawLine posX posY endX endY color)
 
-runRaylibWindow :: (IOE :> es) => Int -> Int -> Text -> Eff (Raylib : es) () -> Eff es ()
+runRaylibWindow :: (IOE :> es) => Int -> Int -> Text -> Eff (Raylib : es) a -> Eff es a
 runRaylibWindow width height name effect = do
   window <- liftIO $ RL.initWindow width height (T.unpack name)
 
-  interpret' effect $ \env eff -> localSeqUnlift env \unlift ->
+  res <- interpret' effect $ \env eff -> localSeqUnlift env \unlift ->
     case eff of
       WindowShouldClose -> liftIO RL.windowShouldClose
       GetFontDefault -> liftIO RL.getFontDefault
@@ -129,6 +129,7 @@ runRaylibWindow width height name effect = do
       GetFPS -> liftIO RL.getFPS
 
   liftIO $ RL.closeWindow window
+  pure res
  where
   runRaylibDrawing :: (IOE :> es) => Eff (RaylibDraw : es) a -> Eff es a
   runRaylibDrawing effect' = do

rpg/src/Engine.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Engine (Engine (..), engineInput, enginePhysics, engineRendering, initialEngine, EngineConstraint, startEngine) where
+module Engine (Game (..), EngineConstraint, startEngine) where
 
 import Apecs.Effectful qualified as AE
 import Data.Kind
@@ -12,33 +12,32 @@ import Effectful.Accessor
 import Effectful.Dispatch.Dynamic
 import Effectful.Dispatch.Static
 import Effectful.Internal.Monad
-import Effectful.Raylib
+import Effectful.Raylib hiding (drawLine)
 import GHC.Exts
+import Linear.V2
 import Raylib.Types qualified as RL
+import Raylib.Util.Colors qualified as RL
 import System.Physics
 import System.Renderer
 import World
 
-data EngineOps es = EngineOps
+data Game :: Effect where
-  { input :: Eff es ()
+  GameInput :: Game (Eff es) ()
-  , physics :: Eff es ()
+  GamePhysics :: Game (Eff es) ()
-  , rendering :: Eff es ()
+  GameRendering :: (SharedSuffix es2 es, RaylibDraw :> es2, RaylibDraw2D :> es2) => (forall r. Eff es2 r -> Eff es r) -> Game (Eff es) ()
-  }
+type instance DispatchOf Game = Dynamic
 
-data Engine :: Effect where
+data Engine :: Effect
-  EngineInput :: Engine (Eff es) ()
+type instance DispatchOf Engine = Static WithSideEffects
-  EnginePhysics :: Engine (Eff es) ()
-  EngineRendering :: (SharedSuffix es2 es, RaylibDraw :> es2, RaylibDraw2D :> es2) => (forall r. Eff es2 r -> Eff es r) -> Engine (Eff es) ()
-type instance DispatchOf Engine = Dynamic
 
-engineInput :: (HasCallStack, Engine :> es) => Eff es ()
+gameInput :: (HasCallStack, Game :> es) => Eff es ()
-engineInput = send EngineInput
+gameInput = send GameInput
 
-enginePhysics :: (HasCallStack, Engine :> es) => Eff es ()
+gamePhysics :: (HasCallStack, Game :> es) => Eff es ()
-enginePhysics = send EnginePhysics
+gamePhysics = send GamePhysics
 
-engineRendering :: forall es. (HasCallStack, Engine :> es, SharedSuffix es es, RaylibDraw :> es, RaylibDraw2D :> es) => Eff es ()
+gameRendering :: forall es. (HasCallStack, Game :> es, SharedSuffix es es, RaylibDraw :> es, RaylibDraw2D :> es) => Eff es ()
-engineRendering = unsafeEff $ \env -> (`unEff` env) $ localSeqUnlift @_ @es (LocalEnv env) (\unlift -> send $ EngineRendering unlift)
+gameRendering = unsafeEff $ \env -> (`unEff` env) $ localSeqUnlift @_ @es (LocalEnv env) (\unlift -> send $ GameRendering unlift)
 
 class EngineConstraints where
   type EngineConstraint (camera :: Symbol) (backgroundColor :: Symbol) (es :: [Effect]) (w :: Type) :: Constraint
@@ -55,41 +54,10 @@ instance EngineConstraints where
       , Reads camera RL.Camera2D :> es
       , Reads backgroundColor RL.Color :> es
       , IOE :> es
-      , Raylib :> es
+      , Renderer :> es
       , AE.ECS w :> es
       )
 
-initialEngine
-  :: forall (es :: [Effect])
-   . EngineOps es
-initialEngine =
-  EngineOps
-    { input = pure ()
-    , physics = pure ()
-    , rendering = pure ()
-    }
-
--- inlineBracket
---     (consEnv e dummyRelinker es0)
---     unconsEnv
---     (\es -> unEff m es)
-
-injectEngine :: forall xs ys. (Subset xs ys) => EngineOps xs -> EngineOps ys
-injectEngine engine =
-  EngineOps
-    { input = inject engine.input
-    , physics = inject engine.physics
-    , rendering = inject engine.rendering
-    }
-
-raiseEngine :: forall e es. EngineOps es -> EngineOps (e : es)
-raiseEngine engine =
-  EngineOps
-    { input = raise engine.input
-    , physics = raise engine.physics
-    , rendering = raise engine.rendering
-    }
-
 startEngine
   :: forall
     (camera :: Symbol)
@@ -97,29 +65,37 @@ startEngine
     (w :: Type)
     es
    . ( EngineConstraint camera backgroundColor es w
-     , Engine :> es
+     , Game :> es
      )
   => Eff es ()
 startEngine = do
-  engineInput
+  gameInput
   applyVelocity'' @w
 
   -- collisionAABB @w
   -- resolveAABB @w
 
-  enginePhysics
+  gamePhysics
 
   c <- readVal @camera @RL.Camera2D
-
-  runDraw . runDraw2D c $ do
   color <- readVal @backgroundColor @RL.Color
-    clearBackground color
 
-    getFPS >>= unsafeEff_ . print
+  beginFrame c color
+
+  -- getFPS >>= unsafeEff_ . print
+
+  AE.cmapM_ @w @(PositionComponent, BoxComponent)
+    drawSprite
+  -- AE.cmapM_
+  --   @w
+  --   @PositionComponent
+  --   \(Position (V2 x y)) ->
+  --     drawLine (V2 (x - 0.1) (y - 0.1)) (V2 (x + 0.1) (y + 0.1)) RL.red
+  --       >> drawLine (V2 (x + 0.1) (y - 0.1)) (V2 (x - 0.1) (y + 0.1)) RL.red
+
+  endFrame
 
-    render @w
-    -- renderOrigins @w
 -- renderBoundingBoxes @w
 -- renderCollision @w
 
-    engineRendering
+-- gameRendering

rpg/src/Executables/Minkowski.hs

@@ -13,8 +13,8 @@ import Data.Maybe (isJust)
 import Effectful
 import Effectful.Accessor
 import Effectful.Dispatch.Dynamic
-import Effectful.Raylib
+import Effectful.Raylib hiding (windowShouldClose)
-import Effectful.Raylib qualified as RL
+import Effectful.Raylib qualified as RL hiding (windowShouldClose)
 import Effectful.Reader.Static
 import Effectful.State.Static.Local
 import Effectful.State.Static.Local.Lens
@@ -24,6 +24,7 @@ import Linear.V2 (V2 (..), _x, _y)
 import Raylib.Types qualified as RL
 import Raylib.Util.Colors qualified as RL
 import System.Physics
+import System.Renderer
 import World
 
 data GameState = GameState
@@ -115,50 +116,51 @@ readsCamera = do
     (pure camera)
     windowDimensions
 
-runEngine :: forall es. (IOE :> es, AE.ECS World :> es, State GameState :> es, Raylib :> es) => Eff (Engine : es) () -> Eff es ()
+runGame :: forall es. (IOE :> es, AE.ECS World :> es, State GameState :> es, Renderer :> es) => Eff (Game : es) () -> Eff es ()
-runEngine = interpret \env eff ->
+runGame = interpret \env eff ->
   case eff of
-    EngineInput -> do
+    GameInput -> do
       camera <- readsCamera
-      pos <- getMousePosition >>= \pos -> getScreenToWorld2D pos camera
+      pure ()
+    -- pos <- getMousePosition >>= \pos -> getScreenToWorld2D pos camera
 
-      isMouseButtonPressed RL.MouseButtonLeft >>= \case
+    -- isMouseButtonPressed RL.MouseButtonLeft >>= \case
-        True -> do
+    --   True -> do
-          AE.cfold @World @(AE.Entity, PositionComponent, AABBComponent)
+    --     AE.cfold @World @(AE.Entity, PositionComponent, AABBComponent)
-            (\acc (entity, position, aabb) -> (pointCollides pos position aabb <&> (,entity)) : acc)
+    --       (\acc (entity, position, aabb) -> (pointCollides pos position aabb <&> (,entity)) : acc)
-            []
+    --       []
-            <&> filter isJust
+    --       <&> filter isJust
-            >>= \case
+    --       >>= \case
-              Just (offset, entity) : _ -> selectedBox .= Just (offset, entity)
+    --         Just (offset, entity) : _ -> selectedBox .= Just (offset, entity)
-              _ -> pure ()
+    --         _ -> pure ()
-        False -> pure ()
+    --   False -> pure ()
-      isMouseButtonReleased RL.MouseButtonLeft >>= \case
+    -- isMouseButtonReleased RL.MouseButtonLeft >>= \case
-        True -> do
+    --   True -> do
-          selectedBox' <- gets @GameState \s -> s.selectedBox
+    --     selectedBox' <- gets @GameState \s -> s.selectedBox
-          case selectedBox' of
+    --     case selectedBox' of
-            Just (_, boxEntity) ->
+    --       Just (_, boxEntity) ->
-              AE.set @World @VelocityComponent boxEntity (Velocity $ V2 0 0)
+    --         AE.set @World @VelocityComponent boxEntity (Velocity $ V2 0 0)
-            Nothing -> pure ()
+    --       Nothing -> pure ()
-          selectedBox .= Nothing
+    --     selectedBox .= Nothing
-        False -> pure ()
+    --   False -> pure ()
 
-      box <- gets @GameState \s -> s.selectedBox
+    -- box <- gets @GameState \s -> s.selectedBox
-      (box1, box2) <- gets @GameState \s -> s.boxes
+    -- (box1, box2) <- gets @GameState \s -> s.boxes
-      box1' <- AE.get @World @(PositionComponent, AABBComponent) box1
+    -- box1' <- AE.get @World @(PositionComponent, AABBComponent) box1
-      box2' <- AE.get @World @(PositionComponent, AABBComponent) box2
+    -- box2' <- AE.get @World @(PositionComponent, AABBComponent) box2
-      minkowski' <- gets @GameState \s -> s.minkowski
+    -- minkowski' <- gets @GameState \s -> s.minkowski
 
-      case box of
+    -- case box of
-        Just (_, box') -> do
+    --   Just (_, box') -> do
-          Position bpos <- AE.get @World @PositionComponent box'
+    --     Position bpos <- AE.get @World @PositionComponent box'
-          let offset = pos - bpos
+    --     let offset = pos - bpos
-          let (mpos, maabb) = aabbFromBounds (minkowskiDifference box1' box2') (V2 0 0)
+    --     let (mpos, maabb) = aabbFromBounds (minkowskiDifference box1' box2') (V2 0 0)
 
-          AE.set @World minkowski' (mpos, maabb)
+    --     AE.set @World minkowski' (mpos, maabb)
-          AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y))
+    --     AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y))
-        Nothing -> pure ()
+    --   Nothing -> pure ()
-    EnginePhysics -> pure ()
+    GamePhysics -> pure ()
-    EngineRendering unlift' -> do
+    GameRendering unlift' -> do
       (box1, box2) <- gets @GameState \s -> s.boxes
       box1Position <- AE.get @World @PositionComponent box1
       (box2Position, box2AABB) <- AE.get @World @(PositionComponent, AABBComponent) box2
@@ -181,10 +183,12 @@ runEngine = interpret \env eff ->
       pure ()
 
 initialize
-  :: (Raylib :> es)
+  :: (Renderer :> es)
   => Eff es ()
 initialize = do
-  setTargetFPS 60
+  pure ()
+
+-- setTargetFPS 60
 
 main' :: IO ()
 main' = do
@@ -193,8 +197,8 @@ main' = do
     . runGameState
     . runGameConfig
     $ gets @GameState (\s -> (s ^. windowDimensions . _x, s ^. windowDimensions . _y)) >>= \(dimX, dimY) ->
-      runRaylibWindow dimX dimY "App"
+      runRaylibRenderer dimX dimY "App"
-        . runEngine
+        . runGame
         $ initialize >> whileM do
           engineEnv $ startEngine @"state.camera" @"config.backgroundColor" @World
           not <$> windowShouldClose

rpg/src/Executables/Pong.hs

@@ -9,7 +9,7 @@ import Control.Monad.Extra
 import Data.Text qualified as T
 import Effectful
 import Effectful.Dispatch.Static
-import Effectful.Raylib
+import Effectful.Raylib hiding (isKeyDown, windowShouldClose)
 import Effectful.Reader.Static
 import Effectful.State.Static.Local
 import Effectful.State.Static.Local.Lens
@@ -65,7 +65,7 @@ makeLensesFor
 
 playerMovement
   :: forall w es
-   . ( Raylib :> es
+   . ( Renderer :> es
      , AE.Get w PositionComponent
      , AE.Set w VelocityComponent
      , AE.ECS w :> es
@@ -111,14 +111,14 @@ ballRespawn goal1 goal2 ball = do
   ret
 
 initialise
-  :: ( Raylib :> es
+  :: ( Renderer :> es
      , State GameState :> es
      , Reader GameConfig :> es
      , AE.ECS World :> es
      )
   => Eff es ()
 initialise = do
-  setTargetFPS 60
+  -- setTargetFPS 60
   playArea <- asks @GameConfig (\s -> s.playArea)
 
   cameraEntity <-
@@ -202,14 +202,14 @@ initialise = do
   topBorder .= topEntity
   bottomBorder .= bottomEntity
 
-  font <- getFontDefault
+  -- font <- getFontDefault
-  separatorEntity <-
+  -- separatorEntity <-
-    AE.newEntity @World
+  --   AE.newEntity @World
-      ( Position $ V2 0 0
+  --     ( Position $ V2 0 0
-      , Box RL.darkGray (0, 0) (0.1, int2Float playArea)
+  --     , Box RL.darkGray (0, 0) (0.1, int2Float playArea)
-      , TextBox font "" 3 0.1 RL.darkGray
+  --     , TextBox font "" 3 0.1 RL.darkGray
-      )
+  --     )
-  separator .= separatorEntity
+  -- separator .= separatorEntity
 
   pure ()
 
@@ -235,7 +235,7 @@ pongGame = do
           { playArea = 20
           }
   -- RL.setTraceLogLevel RL.LogWarning
-  runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibWindow gameState.dimX gameState.dimY "App" $
+  runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibRenderer gameState.dimX gameState.dimY "App" $
     initialise >> whileM do
       playerMovement @World
         (RL.KeyW, -0.2)
@@ -267,18 +267,18 @@ pongGame = do
       --   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 ->
+      -- gets @GameState (\s -> s.separator) >>= flip (AE.modify @World @TextBoxComponent) \textBox ->
-        textBox{text = T.pack $ show score'}
+      --   textBox{text = T.pack $ show score'}
 
       dims <- gets @GameState (\s -> (s.dimX, s.dimY))
       camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims
-      getFPS >>= unsafeEff_ . print
+      -- getFPS >>= unsafeEff_ . print
-      runDraw . runDraw2D camera $ do
+      beginFrame camera RL.white
-        clearBackground RL.gray
+      AE.cmapM_ @World @(PositionComponent, BoxComponent) drawSprite
 
       -- (gets @GameState (\s -> s.score)) >>= liftIO . print
 
-        render @World
+      -- render @World
-        renderOrigins @World
+      -- renderOrigins @World
-        renderBoundingBoxes @World
+      -- renderBoundingBoxes @World
       not <$> windowShouldClose

rpg/src/Executables/RPG.hs

@@ -14,7 +14,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Executables.RPG (
-  runGame,
+  main',
 ) where
 
 import Apecs.Effectful qualified as AE
@@ -30,7 +30,7 @@ import Effectful
 import Effectful.Accessor
 import Effectful.Dispatch.Dynamic
 import Effectful.Dispatch.Static
-import Effectful.Raylib
+import Effectful.Raylib hiding (isKeyDown, windowShouldClose)
 import Effectful.Reader.Dynamic
 import Effectful.State.Static.Local
 import Effectful.State.Static.Local.Lens
@@ -38,9 +38,9 @@ import Engine
 import GHC.Float (float2Int, floorFloat)
 import Linear.V2
 import Noise.Perlin
-import Raylib.Core qualified as RL
 import Raylib.Types qualified as RL
 import Raylib.Util.Colors qualified as RL
+import System.Renderer
 import World
 
 type LocalWorld = World
@@ -83,7 +83,7 @@ spawnPlayer color =
     )
 
 spawnBox
-  :: (AE.ECS LocalWorld :> es, Raylib :> es)
+  :: (AE.ECS LocalWorld :> es)
   => (Float, Float)
   -> RL.Color
   -> (Float, Float)
@@ -96,18 +96,17 @@ spawnBox (posx, posy) color size = do
       , Body 0.0 0.0 True
       , AABB (V2 1 1) (V2 0 0)
       )
-  font <- getFontDefault
+  -- font <- getFontDefault
-  AE.set @LocalWorld 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
-     , State GameState :> es
      , AE.ECS LocalWorld :> es
      )
   => Eff es ()
 initialise = do
-  setTargetFPS 60
+  -- setTargetFPS 60
 
   forM_ [-32 .. 32] \x -> do
     forM_ [-32 .. 32] \y -> do
@@ -152,17 +151,17 @@ initialise = do
 
   pure ()
 
-runEngine
+runGame
   :: forall es
    . ( AE.ECS LocalWorld :> es
-     , Raylib :> es
+     , Renderer :> es
      , State GameState :> es
      )
-  => Eff (Engine : es) ()
+  => Eff (Game : es) ()
   -> Eff es ()
-runEngine = interpret \_ eff ->
+runGame = interpret \_ eff ->
   case eff of
-    EngineInput -> do
+    GameInput -> do
       playerEntity <- gets @GameState (\s -> s.playerEntity)
       -- AE.modify @LocalWorld @(Maybe (TagComponent Int)) @(TagComponent Int) playerEntity \case
       --   Just (Tag n) -> Tag (n + 1)
@@ -182,15 +181,15 @@ runEngine = interpret \_ eff ->
       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 ()
+    GamePhysics -> pure ()
-    EngineRendering _ -> do
+    GameRendering _ -> 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)
 
-runGame :: IO ()
+main' :: IO ()
-runGame = do
+main' = do
   let gameConfig =
         GameConfig
           {
@@ -207,17 +206,17 @@ runGame = do
 
   print $ perlin 0 0
 
-  RL.setTraceLogLevel RL.LogWarning
+  -- RL.setTraceLogLevel RL.LogWarning
   runEff
     . AE.runECS initWorld
     . evalState gameState
     . runReader gameConfig
-    . runRaylibWindow gameState.dimX gameState.dimY "App"
+    . runRaylibRenderer gameState.dimX gameState.dimY "App"
     . runReads @"config.camera" @RL.Camera2D do
       dims <- gets @GameState (\s -> (s.dimX, s.dimY))
       getCamera @LocalWorld (gets @GameState (\s -> s.cameraEntity)) dims
     . runReads @"config.backgroundColor" @RL.Color (pure RL.white)
-    . runEngine
+    . runGame
     $ initialise >> whileM do
       startEngine @"config.camera" @"config.backgroundColor" @LocalWorld
       not <$> windowShouldClose

rpg/src/System/Renderer.hs

@@ -1,84 +1,178 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v1 #-}
+{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-}
 
-module System.Renderer (render, renderOrigins, renderBoundingBoxes, renderCollision) where
+module System.Renderer (Renderer (..), runRaylibRenderer, beginFrame, drawSprite, drawLine, isKeyDown, windowShouldClose, endFrame) where
 
 import Apecs.Effectful qualified as AE
 import Control.Lens
 import Control.Monad
+import Control.Monad.Primitive (PrimState)
+import Data.IORef
+import Data.Text (Text)
+import Data.Vector.Storable qualified as VS hiding (unsafeToForeignPtr)
+import Data.Vector.Storable.Mutable qualified as VS
 import Effectful
-import Effectful.Raylib
+import Effectful.Dispatch.Dynamic
+import Effectful.Raylib hiding (drawLine, isKeyDown, windowShouldClose)
+import Effectful.State.Static.Local
+import Foreign (Storable, withForeignPtr)
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Storable.Generic
+import GHC.Generics (Generic)
 import Linear.V2 (V2 (..), _x, _y)
+import Raylib.Core qualified as RL
+import Raylib.Core.Shapes qualified as RL
+import Raylib.Types qualified as RL
 import Raylib.Util.Colors qualified as RL
 import World
 
-render
+data Renderer :: Effect where
-  :: forall w es
+  BeginFrame :: RL.Camera2D -> RL.Color -> Renderer (Eff es) ()
-   . ( AE.Get w PositionComponent
+  DrawSprite :: (PositionComponent, BoxComponent) -> Renderer (Eff es) ()
-     , AE.Get w BoxComponent
+  DrawLine :: V2 Float -> V2 Float -> RL.Color -> Renderer (Eff es) ()
-     , AE.Get w TextBoxComponent
+  WindowShouldClose :: Renderer (Eff es) Bool
-     , AE.ECS w :> es
+  IsKeyDown :: RL.KeyboardKey -> Renderer (Eff es) Bool
-     , RaylibDraw2D :> es
+  EndFrame :: Renderer (Eff es) ()
-     )
+type instance DispatchOf Renderer = Dynamic
-  => Eff es ()
-render = do
-  AE.cmapM_ @w @(PositionComponent, BoxComponent)
-    \(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
-      -- let size = V2 0 0
-      -- drawText font text (V2 (position ^. _x - size ^. _y / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
-      pure ()
 
-renderCollision
+beginFrame :: (HasCallStack, Renderer :> es) => RL.Camera2D -> RL.Color -> Eff es ()
-  :: forall w es
+beginFrame camera color = send (BeginFrame camera color)
-   . ( AE.Get w PositionComponent
-     , AE.Get w CollisionComponent
-     , AE.Get w BoxComponent
-     , AE.ECS w :> es
-     , RaylibDraw2D :> es
-     )
-  => Eff es ()
-renderCollision =
-  AE.cmapM_ @w @(PositionComponent, CollisionComponent, BoxComponent)
-    \(Position (V2 x y), Collision colliders, _) ->
-      forM_
-        colliders
-        ( \(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
-            drawLine x y (x + offsetX) (y + offsetY) RL.green
-            drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 + overlapX / 2) (y + offsetY / 2 + overlapY / 2) RL.yellow
-            drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 - overlapX / 2) (y + offsetY / 2 - overlapY / 2) RL.orange
-        )
 
-renderOrigins
+drawSprite :: (HasCallStack, Renderer :> es) => (PositionComponent, BoxComponent) -> Eff es ()
-  :: forall w es
+drawSprite d = send (DrawSprite d)
-   . ( AE.Get w PositionComponent
-     , AE.ECS w :> es
-     , RaylibDraw2D :> es
-     )
-  => Eff es ()
-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
 
-renderBoundingBoxes
+drawLine :: (HasCallStack, Renderer :> es) => V2 Float -> V2 Float -> RL.Color -> Eff es ()
-  :: forall w es
+drawLine start end color = send (DrawLine start end color)
-   . ( AE.Get w PositionComponent
+
-     , AE.Get w AABBComponent
+windowShouldClose :: (HasCallStack, Renderer :> es) => Eff es Bool
-     , RaylibDraw2D :> es
+windowShouldClose = send WindowShouldClose
-     , AE.ECS w :> es
+
+isKeyDown :: (HasCallStack, Renderer :> es) => RL.KeyboardKey -> Eff es Bool
+isKeyDown key = send (IsKeyDown key)
+
+endFrame :: (HasCallStack, Renderer :> es) => Eff es ()
+endFrame = send EndFrame
+
+data RectangleInfo = RectangleInfo {position :: V2 Float, size :: V2 Float, color :: RL.Color}
+  deriving (Generic, GStorable)
+
+foreign import capi safe "raylib_batch.h" draw_rectangles_batch :: Ptr RectangleInfo -> CSize -> IO ()
+
+runRaylibRenderer :: (IOE :> es) => Int -> Int -> Text -> Eff (Renderer : es) a -> Eff es a
+runRaylibRenderer dimX dimY title go = do
+  vectorRef <- liftIO $ VS.new @_ @RectangleInfo 4279 >>= newIORef
+  indexRef <-
+    liftIO $
+      newIORef
+        (0 :: Int)
+  reinterpret
+    (runRaylibWindow dimX dimY title)
+    ( \_ -> \case
+        BeginFrame camera color -> do
+          liftIO $ RL.getFPS >>= liftIO . print
+          liftIO $ writeIORef indexRef 0
+          liftIO $ RL.beginDrawing
+          liftIO $ RL.clearBackground color
+          liftIO $ RL.beginMode2D camera
+        DrawSprite (Position position, Box{color, offset, size}) -> do
+          vector <- liftIO $ readIORef vectorRef
+          index <- liftIO $ readIORef indexRef
+          liftIO $ VS.write vector index (RectangleInfo position (V2 (size ^. _1) (size ^. _2)) color)
+          liftIO $ writeIORef indexRef (index + 1)
+         where
+          -- liftIO $ RL.drawRectangleV rlPosition rlSize color
+
+          rlPosition = RL.Vector2 (position ^. _x + fst offset - (size ^. _1) / 2) (position ^. _y + snd offset - size ^. _2 / 2)
+          rlSize = RL.Vector2 (size ^. _1) (size ^. _2)
+        DrawLine start end color ->
+          liftIO $ RL.drawLineV (RL.Vector2 (start ^. _x) (start ^. _y)) (RL.Vector2 (end ^. _x) (end ^. _y)) color
+        WindowShouldClose -> liftIO RL.windowShouldClose
+        IsKeyDown key -> liftIO $ RL.isKeyDown key
+        EndFrame -> do
+          vector <- liftIO $ readIORef vectorRef
+          index <- liftIO $ readIORef indexRef
+          let (fptr, offset, length) = (VS.unsafeToForeignPtr vector)
+          liftIO $ withForeignPtr fptr \ptr -> draw_rectangles_batch (plusPtr ptr offset) (fromIntegral length)
+          liftIO RL.endMode2D
+          liftIO RL.endDrawing
     )
-  => Eff es ()
+    go
-renderBoundingBoxes =
+
-  AE.cmapM_ @w @(PositionComponent, AABBComponent)
+-- render
-    \(pos, aabb) -> do
+--   :: forall w es
-      let (AABBBounds left right top bottom) = aabbBounds pos aabb
+--    . ( AE.Get w PositionComponent
-      drawLine right bottom right top RL.red
+--      , AE.Get w BoxComponent
-      drawLine right top left top RL.red
+--      , AE.Get w TextBoxComponent
-      drawLine left top left bottom RL.red
+--      , AE.ECS w :> es
-      drawLine left bottom right bottom RL.red
+--      , RaylibDraw2D :> es
-      drawLine right bottom left top RL.red
+--      )
-      drawLine left bottom right top RL.red
+--   => Eff es ()
+-- render = do
+--   AE.cmapM_ @w @(PositionComponent, BoxComponent)
+--     \(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
+--       -- let size = V2 0 0
+--       -- drawText font text (V2 (position ^. _x - size ^. _y / 2) (position ^. _y - size ^. _y / 2)) fontSize spacing color
+--       pure ()
+
+-- renderCollision
+--   :: forall w es
+--    . ( AE.Get w PositionComponent
+--      , AE.Get w CollisionComponent
+--      , AE.Get w BoxComponent
+--      , AE.ECS w :> es
+--      , RaylibDraw2D :> es
+--      )
+--   => Eff es ()
+-- renderCollision =
+--   AE.cmapM_ @w @(PositionComponent, CollisionComponent, BoxComponent)
+--     \(Position (V2 x y), Collision colliders, _) ->
+--       forM_
+--         colliders
+--         ( \(Collider _ (V2 overlapX overlapY) (V2 offsetX offsetY) _) -> do
+--             drawLine x y (x + offsetX) (y + offsetY) RL.green
+--             drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 + overlapX / 2) (y + offsetY / 2 + overlapY / 2) RL.yellow
+--             drawLine (x + offsetX / 2) (y + offsetY / 2) (x + offsetX / 2 - overlapX / 2) (y + offsetY / 2 - overlapY / 2) RL.orange
+--         )
+
+-- renderOrigins
+--   :: forall w es
+--    . ( AE.Get w PositionComponent
+--      , AE.ECS w :> es
+--      , RaylibDraw2D :> es
+--      )
+--   => Eff es ()
+-- 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
+
+-- renderBoundingBoxes
+--   :: forall w es
+--    . ( AE.Get w PositionComponent
+--      , AE.Get w AABBComponent
+--      , RaylibDraw2D :> es
+--      , AE.ECS w :> es
+--      )
+--   => Eff es ()
+-- renderBoundingBoxes =
+--   AE.cmapM_ @w @(PositionComponent, AABBComponent)
+--     \(pos, aabb) -> do
+--       let (AABBBounds left right top bottom) = aabbBounds pos aabb
+--       drawLine right bottom right top RL.red
+--       drawLine right top left top RL.red
+--       drawLine left top left bottom RL.red
+--       drawLine left bottom right bottom RL.red
+--       drawLine right bottom left top RL.red
+--       drawLine left bottom right top RL.red

stack.yaml

@@ -48,6 +48,7 @@ extra-deps:
   - lens-5.2.2@sha256:e01d5732173645b80f23a189a0f7e1f5cd0b2286de0ce20baf941cbf5c3b8435,15158
   - effectful-2.2.2.0@sha256:1d5682727c2d5ebd83f7a7ae0ef809369422ccd37d4157ae7e2084f2a1cf6cfd,6044
   - effectful-core-2.2.2.2@sha256:ebbf61f024a08c7bb5e569b1c6856c0ca92687d6a5ff01d24d28567948c402fc,3477
+  - derive-storable-plugin-0.2.3.7@sha256:f82b5cc67d7affbb41040d3a5812e6a587894e232e7a5d5ccb33103836e51fa6,2868
 
 # Override default flag values for local packages and extra-deps
 flags:

stack.yaml.lock

@@ -47,6 +47,13 @@ packages:
       size: 1918
   original:
     hackage: effectful-core-2.2.2.2@sha256:ebbf61f024a08c7bb5e569b1c6856c0ca92687d6a5ff01d24d28567948c402fc,3477
+- completed:
+    hackage: derive-storable-plugin-0.2.3.7@sha256:f82b5cc67d7affbb41040d3a5812e6a587894e232e7a5d5ccb33103836e51fa6,2868
+    pantry-tree:
+      sha256: b11fd39df181394cc3cb37d4cc43149ef776ab2c079413c84ad59f3904ff557f
+      size: 1411
+  original:
+    hackage: derive-storable-plugin-0.2.3.7@sha256:f82b5cc67d7affbb41040d3a5812e6a587894e232e7a5d5ccb33103836e51fa6,2868
 snapshots:
 - completed:
     sha256: 93137bc0122de394fa2c43e933971b2996cd7dc600989b721ad971810b9a2f3f