From 2972b5b048b0f69ab1cfa7a769a77d58bcb0ed51 Mon Sep 17 00:00:00 2001 From: magic_rb Date: Fri, 26 Jan 2024 20:17:53 +0100 Subject: [PATCH] 105 fps +- Signed-off-by: magic_rb --- flake.nix | 1 + rpg/cbits/raylib_batch.c | 7 + rpg/cbits/raylib_batch.h | 10 ++ rpg/package.yaml | 4 + rpg/rpg.cabal | 14 ++ rpg/rpg/Main.hs | 2 +- rpg/src/Common.hs | 6 +- rpg/src/Effectful/Raylib.hs | 5 +- rpg/src/Engine.hs | 100 +++++-------- rpg/src/Executables/Minkowski.hs | 92 ++++++------ rpg/src/Executables/Pong.hs | 44 +++--- rpg/src/Executables/RPG.hs | 41 +++--- rpg/src/System/Renderer.hs | 234 ++++++++++++++++++++++--------- stack.yaml | 1 + stack.yaml.lock | 7 + 15 files changed, 343 insertions(+), 225 deletions(-) create mode 100644 rpg/cbits/raylib_batch.c create mode 100644 rpg/cbits/raylib_batch.h diff --git a/flake.nix b/flake.nix index 8ed7eee..d0ad3ce 100644 --- a/flake.nix +++ b/flake.nix @@ -41,6 +41,7 @@ hPkgs.ghc hPkgs.implicit-hie hPkgs.haskell-language-server + hPkgs.profiterole SDL2 SDL2_image libtiff diff --git a/rpg/cbits/raylib_batch.c b/rpg/cbits/raylib_batch.c new file mode 100644 index 0000000..71e76a4 --- /dev/null +++ b/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); + } +} diff --git a/rpg/cbits/raylib_batch.h b/rpg/cbits/raylib_batch.h new file mode 100644 index 0000000..ef72e38 --- /dev/null +++ b/rpg/cbits/raylib_batch.h @@ -0,0 +1,10 @@ +#include +#include + +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); diff --git a/rpg/package.yaml b/rpg/package.yaml index 8730784..27f1211 100644 --- a/rpg/package.yaml +++ b/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: diff --git a/rpg/rpg.cabal b/rpg/rpg.cabal index 97a314d..b34d8ab 100644 --- a/rpg/rpg.cabal +++ b/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 diff --git a/rpg/rpg/Main.hs b/rpg/rpg/Main.hs index 4997a8b..a9ff212 100644 --- a/rpg/rpg/Main.hs +++ b/rpg/rpg/Main.hs @@ -2,4 +2,4 @@ module Main where import Executables.RPG -main = runGame +main = main' diff --git a/rpg/src/Common.hs b/rpg/src/Common.hs index d76f37a..6352d43 100644 --- a/rpg/src/Common.hs +++ b/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 diff --git a/rpg/src/Effectful/Raylib.hs b/rpg/src/Effectful/Raylib.hs index 038b7e6..0cba688 100644 --- a/rpg/src/Effectful/Raylib.hs +++ b/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 diff --git a/rpg/src/Engine.hs b/rpg/src/Engine.hs index 012cf5a..fe03bf1 100644 --- a/rpg/src/Engine.hs +++ b/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 - { input :: Eff es () - , physics :: Eff es () - , rendering :: Eff es () - } +data Game :: Effect where + GameInput :: Game (Eff es) () + GamePhysics :: Game (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 - EngineInput :: Engine (Eff es) () - 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 +data Engine :: Effect +type instance DispatchOf Engine = Static WithSideEffects -engineInput :: (HasCallStack, Engine :> es) => Eff es () -engineInput = send EngineInput +gameInput :: (HasCallStack, Game :> es) => Eff es () +gameInput = send GameInput -enginePhysics :: (HasCallStack, Engine :> es) => Eff es () -enginePhysics = send EnginePhysics +gamePhysics :: (HasCallStack, Game :> es) => Eff es () +gamePhysics = send GamePhysics -engineRendering :: forall es. (HasCallStack, Engine :> es, SharedSuffix es es, RaylibDraw :> es, RaylibDraw2D :> es) => Eff es () -engineRendering = unsafeEff $ \env -> (`unEff` env) $ localSeqUnlift @_ @es (LocalEnv env) (\unlift -> send $ EngineRendering unlift) +gameRendering :: forall es. (HasCallStack, Game :> es, SharedSuffix es es, RaylibDraw :> es, RaylibDraw2D :> es) => Eff es () +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 + color <- readVal @backgroundColor @RL.Color - runDraw . runDraw2D c $ do - color <- readVal @backgroundColor @RL.Color - clearBackground color + beginFrame c color - getFPS >>= unsafeEff_ . print + -- getFPS >>= unsafeEff_ . print - render @w - -- renderOrigins @w - -- renderBoundingBoxes @w - -- renderCollision @w + 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 - engineRendering + endFrame + +-- renderBoundingBoxes @w +-- renderCollision @w + +-- gameRendering diff --git a/rpg/src/Executables/Minkowski.hs b/rpg/src/Executables/Minkowski.hs index 0978aa6..d06b507 100644 --- a/rpg/src/Executables/Minkowski.hs +++ b/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 qualified as RL +import Effectful.Raylib hiding (windowShouldClose) +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 () -runEngine = interpret \env eff -> +runGame :: forall es. (IOE :> es, AE.ECS World :> es, State GameState :> es, Renderer :> es) => Eff (Game : es) () -> Eff es () +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 - True -> do - AE.cfold @World @(AE.Entity, PositionComponent, AABBComponent) - (\acc (entity, position, aabb) -> (pointCollides pos position aabb <&> (,entity)) : acc) - [] - <&> filter isJust - >>= \case - Just (offset, entity) : _ -> selectedBox .= Just (offset, entity) - _ -> pure () - False -> pure () - isMouseButtonReleased RL.MouseButtonLeft >>= \case - True -> do - selectedBox' <- gets @GameState \s -> s.selectedBox - case selectedBox' of - Just (_, boxEntity) -> - AE.set @World @VelocityComponent boxEntity (Velocity $ V2 0 0) - Nothing -> pure () - selectedBox .= Nothing - False -> pure () + -- isMouseButtonPressed RL.MouseButtonLeft >>= \case + -- True -> do + -- AE.cfold @World @(AE.Entity, PositionComponent, AABBComponent) + -- (\acc (entity, position, aabb) -> (pointCollides pos position aabb <&> (,entity)) : acc) + -- [] + -- <&> filter isJust + -- >>= \case + -- Just (offset, entity) : _ -> selectedBox .= Just (offset, entity) + -- _ -> pure () + -- False -> pure () + -- isMouseButtonReleased RL.MouseButtonLeft >>= \case + -- True -> do + -- selectedBox' <- gets @GameState \s -> s.selectedBox + -- case selectedBox' of + -- Just (_, boxEntity) -> + -- AE.set @World @VelocityComponent boxEntity (Velocity $ V2 0 0) + -- Nothing -> pure () + -- selectedBox .= Nothing + -- False -> pure () - box <- gets @GameState \s -> s.selectedBox - (box1, box2) <- gets @GameState \s -> s.boxes - box1' <- AE.get @World @(PositionComponent, AABBComponent) box1 - box2' <- AE.get @World @(PositionComponent, AABBComponent) box2 - minkowski' <- gets @GameState \s -> s.minkowski + -- box <- gets @GameState \s -> s.selectedBox + -- (box1, box2) <- gets @GameState \s -> s.boxes + -- box1' <- AE.get @World @(PositionComponent, AABBComponent) box1 + -- box2' <- AE.get @World @(PositionComponent, AABBComponent) box2 + -- minkowski' <- gets @GameState \s -> s.minkowski - case box of - Just (_, box') -> do - Position bpos <- AE.get @World @PositionComponent box' - let offset = pos - bpos - let (mpos, maabb) = aabbFromBounds (minkowskiDifference box1' box2') (V2 0 0) + -- case box of + -- Just (_, box') -> do + -- Position bpos <- AE.get @World @PositionComponent box' + -- let offset = pos - bpos + -- let (mpos, maabb) = aabbFromBounds (minkowskiDifference box1' box2') (V2 0 0) - AE.set @World minkowski' (mpos, maabb) - AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y)) - Nothing -> pure () - EnginePhysics -> pure () - EngineRendering unlift' -> do + -- AE.set @World minkowski' (mpos, maabb) + -- AE.set @World box' (Velocity $ V2 (offset ^. _x) (offset ^. _y)) + -- Nothing -> pure () + GamePhysics -> pure () + 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" - . runEngine + runRaylibRenderer dimX dimY "App" + . runGame $ initialize >> whileM do engineEnv $ startEngine @"state.camera" @"config.backgroundColor" @World not <$> windowShouldClose diff --git a/rpg/src/Executables/Pong.hs b/rpg/src/Executables/Pong.hs index 4177dc2..981b89d 100644 --- a/rpg/src/Executables/Pong.hs +++ b/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 - separatorEntity <- - AE.newEntity @World - ( Position $ V2 0 0 - , Box RL.darkGray (0, 0) (0.1, int2Float playArea) - , TextBox font "" 3 0.1 RL.darkGray - ) - separator .= separatorEntity + -- font <- getFontDefault + -- separatorEntity <- + -- AE.newEntity @World + -- ( Position $ V2 0 0 + -- , Box RL.darkGray (0, 0) (0.1, int2Float playArea) + -- , TextBox font "" 3 0.1 RL.darkGray + -- ) + -- separator .= separatorEntity pure () @@ -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 -> - textBox{text = T.pack $ show score'} + -- gets @GameState (\s -> s.separator) >>= flip (AE.modify @World @TextBoxComponent) \textBox -> + -- textBox{text = T.pack $ show score'} dims <- gets @GameState (\s -> (s.dimX, s.dimY)) camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims - getFPS >>= unsafeEff_ . print - runDraw . runDraw2D camera $ do - clearBackground RL.gray + -- getFPS >>= unsafeEff_ . print + beginFrame camera RL.white + AE.cmapM_ @World @(PositionComponent, BoxComponent) drawSprite - -- (gets @GameState (\s -> s.score)) >>= liftIO . print + -- (gets @GameState (\s -> s.score)) >>= liftIO . print - render @World - renderOrigins @World - renderBoundingBoxes @World + -- render @World + -- renderOrigins @World + -- renderBoundingBoxes @World not <$> windowShouldClose diff --git a/rpg/src/Executables/RPG.hs b/rpg/src/Executables/RPG.hs index 8a04903..4c77449 100644 --- a/rpg/src/Executables/RPG.hs +++ b/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 - AE.set @LocalWorld entity (TextBox font (T.pack $ show (AE.unEntity entity)) 0.3 0.1 RL.yellow) + -- font <- getFontDefault + -- 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 () - EngineRendering _ -> do + GamePhysics -> pure () + 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 () -runGame = do +main' :: IO () +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 diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index 7e63cd7..4291481 100644 --- a/rpg/src/System/Renderer.hs +++ b/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 - :: forall w es - . ( AE.Get w PositionComponent - , AE.Get w BoxComponent - , AE.Get w TextBoxComponent - , AE.ECS w :> es - , RaylibDraw2D :> es - ) - => Eff es () -render = do - AE.cmapM_ @w @(PositionComponent, BoxComponent) - \(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 () +data Renderer :: Effect where + BeginFrame :: RL.Camera2D -> RL.Color -> Renderer (Eff es) () + DrawSprite :: (PositionComponent, BoxComponent) -> Renderer (Eff es) () + DrawLine :: V2 Float -> V2 Float -> RL.Color -> Renderer (Eff es) () + WindowShouldClose :: Renderer (Eff es) Bool + IsKeyDown :: RL.KeyboardKey -> Renderer (Eff es) Bool + EndFrame :: Renderer (Eff es) () +type instance DispatchOf Renderer = Dynamic -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 - ) +beginFrame :: (HasCallStack, Renderer :> es) => RL.Camera2D -> RL.Color -> Eff es () +beginFrame camera color = send (BeginFrame camera color) -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 +drawSprite :: (HasCallStack, Renderer :> es) => (PositionComponent, BoxComponent) -> Eff es () +drawSprite d = send (DrawSprite d) -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 +drawLine :: (HasCallStack, Renderer :> es) => V2 Float -> V2 Float -> RL.Color -> Eff es () +drawLine start end color = send (DrawLine start end color) + +windowShouldClose :: (HasCallStack, Renderer :> es) => Eff es Bool +windowShouldClose = send WindowShouldClose + +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 + ) + go + +-- render +-- :: forall w es +-- . ( AE.Get w PositionComponent +-- , AE.Get w BoxComponent +-- , AE.Get w TextBoxComponent +-- , AE.ECS w :> es +-- , RaylibDraw2D :> es +-- ) +-- => Eff es () +-- render = do +-- AE.cmapM_ @w @(PositionComponent, BoxComponent) +-- \(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 diff --git a/stack.yaml b/stack.yaml index 8cd9b9a..f418dc6 100644 --- a/stack.yaml +++ b/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: diff --git a/stack.yaml.lock b/stack.yaml.lock index c414091..e8dbafb 100644 --- a/stack.yaml.lock +++ b/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