diff --git a/rpg/src/Common.hs b/rpg/src/Common.hs index b27bff1..6352d43 100644 --- a/rpg/src/Common.hs +++ b/rpg/src/Common.hs @@ -35,13 +35,12 @@ getCamera eff (dimX, dimY) = do } playerMovement - :: forall w es r + :: forall w es . ( AE.ECS w :> es , AE.Get w VelocityComponent - , Renderer (Eff es) r + , Renderer :> es ) - => r - -> AE.Entity + => AE.Entity -> ( RL.KeyboardKey , RL.KeyboardKey , RL.KeyboardKey @@ -49,14 +48,14 @@ playerMovement ) -> Float -> Eff es () -playerMovement renderer player (left, right, up, down) speed = do +playerMovement player (left, right, up, down) speed = do directions <- mapM (\tuple -> fst tuple <&> (,snd tuple)) - [ (isKeyDown renderer left, V2 (-1.0) 0) - , (isKeyDown renderer right, V2 1.0 0) - , (isKeyDown renderer down, V2 0 1.0) - , (isKeyDown renderer up, V2 0 (-1.0)) + [ (isKeyDown left, V2 (-1.0) 0) + , (isKeyDown right, V2 1.0 0) + , (isKeyDown down, V2 0 1.0) + , (isKeyDown up, V2 0 (-1.0)) ] let movement = foldl (+) (V2 0 0) $ map snd $ filter fst directions AE.set @w @VelocityComponent player (Velocity (normalize movement * pure speed)) diff --git a/rpg/src/Engine.hs b/rpg/src/Engine.hs index 7fa5c53..fe03bf1 100644 --- a/rpg/src/Engine.hs +++ b/rpg/src/Engine.hs @@ -54,6 +54,7 @@ instance EngineConstraints where , Reads camera RL.Camera2D :> es , Reads backgroundColor RL.Color :> es , IOE :> es + , Renderer :> es , AE.ECS w :> es ) @@ -63,14 +64,11 @@ startEngine (backgroundColor :: Symbol) (w :: Type) es - r . ( EngineConstraint camera backgroundColor es w , Game :> es - , Renderer (Eff es) r ) - => r - -> Eff es () -startEngine renderer = do + => Eff es () +startEngine = do gameInput applyVelocity'' @w @@ -82,12 +80,12 @@ startEngine renderer = do c <- readVal @camera @RL.Camera2D color <- readVal @backgroundColor @RL.Color - beginFrame renderer c color + beginFrame c color -- getFPS >>= unsafeEff_ . print AE.cmapM_ @w @(PositionComponent, BoxComponent) - (drawSprite renderer) + drawSprite -- AE.cmapM_ -- @w -- @PositionComponent @@ -95,7 +93,7 @@ startEngine renderer = do -- 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 renderer + endFrame -- renderBoundingBoxes @w -- renderCollision @w diff --git a/rpg/src/Executables/Minkowski.hs b/rpg/src/Executables/Minkowski.hs index 724b1b5..d06b507 100644 --- a/rpg/src/Executables/Minkowski.hs +++ b/rpg/src/Executables/Minkowski.hs @@ -116,7 +116,7 @@ readsCamera = do (pure camera) windowDimensions -runGame :: forall es. (IOE :> es, AE.ECS World :> es, State GameState :> es) => Eff (Game : es) () -> Eff es () +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 GameInput -> do @@ -183,7 +183,8 @@ runGame = interpret \env eff -> pure () initialize - :: Eff es () + :: (Renderer :> es) + => Eff es () initialize = do pure () @@ -196,11 +197,11 @@ main' = do . runGameState . runGameConfig $ gets @GameState (\s -> (s ^. windowDimensions . _x, s ^. windowDimensions . _y)) >>= \(dimX, dimY) -> - runGame $ - withRaylibRenderer dimX dimY "App" \renderer -> - initialize >> whileM do - engineEnv $ startEngine @"state.camera" @"config.backgroundColor" @World renderer - not <$> windowShouldClose renderer + runRaylibRenderer dimX dimY "App" + . runGame + $ initialize >> whileM do + engineEnv $ startEngine @"state.camera" @"config.backgroundColor" @World + not <$> windowShouldClose where readsBackgroundColor :: (Reader GameConfig :> es) diff --git a/rpg/src/Executables/Pong.hs b/rpg/src/Executables/Pong.hs index 753f9bf..981b89d 100644 --- a/rpg/src/Executables/Pong.hs +++ b/rpg/src/Executables/Pong.hs @@ -64,23 +64,22 @@ makeLensesFor ''GameConfig playerMovement - :: forall w es r - . ( Renderer (Eff es) r + :: forall w es + . ( Renderer :> es , AE.Get w PositionComponent , AE.Set w VelocityComponent , AE.ECS w :> es , Reader GameConfig :> es ) - => r - -> (RL.KeyboardKey, Float) + => (RL.KeyboardKey, Float) -> (RL.KeyboardKey, Float) -> Eff es AE.Entity -> Eff es () -playerMovement renderer (up, upSpeed) (down, downSpeed) entity = do +playerMovement (up, upSpeed) (down, downSpeed) entity = do entity' <- entity - down <- isKeyDown renderer down - up <- isKeyDown renderer up + down <- isKeyDown down + up <- isKeyDown up AE.set @w entity' $ case (down, up) of (True, False) -> Velocity $ V2 0 downSpeed @@ -112,14 +111,13 @@ ballRespawn goal1 goal2 ball = do ret initialise - :: ( State GameState :> es + :: ( Renderer :> es + , State GameState :> es , Reader GameConfig :> es , AE.ECS World :> es - , Renderer (Eff es) r ) - => r - -> Eff es () -initialise renderere = do + => Eff es () +initialise = do -- setTargetFPS 60 playArea <- asks @GameConfig (\s -> s.playArea) @@ -237,53 +235,50 @@ pongGame = do { playArea = 20 } -- RL.setTraceLogLevel RL.LogWarning - withRaylibRenderer gameState.dimX gameState.dimY "App" $ \renderer -> - runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig $ - initialise renderer >> whileM do - playerMovement @World - renderer - (RL.KeyW, -0.2) - (RL.KeyS, 0.2) - (gets @GameState (\s -> s.player1)) + runEff . AE.runECS initWorld . evalState gameState . runReader gameConfig . runRaylibRenderer gameState.dimX gameState.dimY "App" $ + initialise >> whileM do + playerMovement @World + (RL.KeyW, -0.2) + (RL.KeyS, 0.2) + (gets @GameState (\s -> s.player1)) - playerMovement @World - renderer - (RL.KeyUp, -0.2) - (RL.KeyDown, 0.2) - (gets @GameState (\s -> s.player2)) + playerMovement @World + (RL.KeyUp, -0.2) + (RL.KeyDown, 0.2) + (gets @GameState (\s -> s.player2)) - -- ballMovement - -- (gets @GameState (\s -> s.player1)) - -- (gets @GameState (\s -> s.player2)) - -- (gets @GameState (\s -> s.ball)) - -- (gets @GameState (\s -> s.bottom)) - -- (gets @GameState (\s -> s.top)) + -- ballMovement + -- (gets @GameState (\s -> s.player1)) + -- (gets @GameState (\s -> s.player2)) + -- (gets @GameState (\s -> s.ball)) + -- (gets @GameState (\s -> s.bottom)) + -- (gets @GameState (\s -> s.top)) - ballRespawn - (gets @GameState (\s -> s.goal2)) - (gets @GameState (\s -> s.goal1)) - (gets @GameState (\s -> s.ball)) + ballRespawn + (gets @GameState (\s -> s.goal2)) + (gets @GameState (\s -> s.goal1)) + (gets @GameState (\s -> s.ball)) - collisionAABB @World - applyVelocity'' @World - resolveAABB @World + collisionAABB @World + applyVelocity'' @World + resolveAABB @World - -- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) -> - -- when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position) + -- AE.cmapM_ @World @(AE.Entity, PositionComponent, CollisionComponent) \(entity, position, collision) -> + -- when (collision.colliders /= []) $ liftIO $ print (show entity <> " with " <> show collision.colliders <> " at " <> show position) - score' <- gets @GameState (\s -> s.score) - -- gets @GameState (\s -> s.separator) >>= flip (AE.modify @World @TextBoxComponent) \textBox -> - -- textBox{text = T.pack $ show score'} + score' <- gets @GameState (\s -> s.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 - beginFrame renderer camera RL.white - AE.cmapM_ @World @(PositionComponent, BoxComponent) (drawSprite renderer) + dims <- gets @GameState (\s -> (s.dimX, s.dimY)) + camera <- getCamera @World (gets @GameState (\s -> s.camera)) dims + -- 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 - not <$> windowShouldClose renderer + -- render @World + -- renderOrigins @World + -- renderBoundingBoxes @World + not <$> windowShouldClose diff --git a/rpg/src/Executables/RPG.hs b/rpg/src/Executables/RPG.hs index f0819a4..4c77449 100644 --- a/rpg/src/Executables/RPG.hs +++ b/rpg/src/Executables/RPG.hs @@ -152,15 +152,14 @@ initialise = do pure () runGame - :: forall es r + :: forall es . ( AE.ECS LocalWorld :> es + , Renderer :> es , State GameState :> es - , Renderer (Eff es) r ) - => r - -> Eff (Game : es) () + => Eff (Game : es) () -> Eff es () -runGame renderer = interpret \_ eff -> +runGame = interpret \_ eff -> case eff of GameInput -> do playerEntity <- gets @GameState (\s -> s.playerEntity) @@ -169,7 +168,6 @@ runGame renderer = interpret \_ eff -> -- Nothing -> Tag 0 -- AE.get @LocalWorld @(TagComponent Int) playerEntity >>= unsafeEff_ . print playerMovement @LocalWorld - renderer playerEntity ( RL.KeyA , RL.KeyD @@ -180,8 +178,8 @@ runGame renderer = interpret \_ eff -> cameraEntity <- gets @GameState (\s -> s.cameraEntity) - isKeyDown renderer RL.KeyKpAdd >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1})) - isKeyDown renderer RL.KeyKpSubtract >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1})) + isKeyDown RL.KeyKpAdd >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom + 1})) + isKeyDown RL.KeyKpSubtract >>= flip when (AE.modify @LocalWorld @CameraComponent @CameraComponent cameraEntity (\c -> c{zoom = c.zoom - 1})) pure () GamePhysics -> pure () GameRendering _ -> do @@ -209,18 +207,18 @@ main' = do print $ perlin 0 0 -- RL.setTraceLogLevel RL.LogWarning - withRaylibRenderer gameState.dimX gameState.dimY "App" \renderer -> - runEff - . AE.runECS initWorld - . evalState gameState - . runReader gameConfig - . 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) - . runGame renderer - $ initialise >> whileM do - startEngine @"config.camera" @"config.backgroundColor" @LocalWorld renderer - not <$> windowShouldClose renderer + runEff + . AE.runECS initWorld + . evalState gameState + . runReader gameConfig + . 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) + . runGame + $ initialise >> whileM do + startEngine @"config.camera" @"config.backgroundColor" @LocalWorld + not <$> windowShouldClose pure () diff --git a/rpg/src/System/Renderer.hs b/rpg/src/System/Renderer.hs index 46fc501..4291481 100644 --- a/rpg/src/System/Renderer.hs +++ b/rpg/src/System/Renderer.hs @@ -7,15 +7,14 @@ {-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v1 #-} {-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} -module System.Renderer (Renderer (..), withRaylibRenderer, beginFrame, drawSprite, drawLine, isKeyDown, windowShouldClose, endFrame) 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 +import Control.Monad.Primitive (PrimState) import Data.IORef import Data.Text (Text) -import Data.Text qualified as T import Data.Vector.Storable qualified as VS hiding (unsafeToForeignPtr) import Data.Vector.Storable.Mutable qualified as VS import Effectful @@ -34,59 +33,77 @@ import Raylib.Types qualified as RL import Raylib.Util.Colors qualified as RL import World -class Renderer m a where - beginFrame :: a -> RL.Camera2D -> RL.Color -> m () - drawSprite :: a -> (PositionComponent, BoxComponent) -> m () - drawLine :: a -> V2 Float -> V2 Float -> RL.Color -> m () - windowShouldClose :: a -> m Bool - isKeyDown :: a -> RL.KeyboardKey -> m Bool - endFrame :: a -> m () +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 + +beginFrame :: (HasCallStack, Renderer :> es) => RL.Camera2D -> RL.Color -> Eff es () +beginFrame camera color = send (BeginFrame camera color) + +drawSprite :: (HasCallStack, Renderer :> es) => (PositionComponent, BoxComponent) -> Eff es () +drawSprite d = send (DrawSprite d) + +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 () -data RaylibRenderer = RaylibRenderer {indexRef :: IORef Int, vectorRef :: IORef (VS.MVector (PrimState IO) RectangleInfo)} - -withRaylibRenderer :: forall m a. (MonadIO m) => Int -> Int -> Text -> (RaylibRenderer -> m a) -> m a -withRaylibRenderer dimX dimY title go = do - winRes <- liftIO $ RL.initWindow dimX dimY (T.unpack title) - vectorRef <- liftIO (VS.new @_ @RectangleInfo 4279) >>= liftIO . newIORef +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) - go (RaylibRenderer indexRef vectorRef) + 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 -instance (MonadIO m) => Renderer m RaylibRenderer where - beginFrame (RaylibRenderer{indexRef}) camera color = do - liftIO $ RL.getFPS >>= liftIO . print - liftIO $ writeIORef indexRef 0 - liftIO $ RL.beginDrawing - liftIO $ RL.clearBackground color - liftIO $ RL.beginMode2D camera - drawSprite (RaylibRenderer{indexRef, vectorRef}) (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 (RaylibRenderer{}) 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 (RaylibRenderer{vectorRef, indexRef}) = 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 + 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