Revert "Non effectful renderer"

This reverts commit afe32a1b0d.
2024-11-22 07:44:20 +01:00 · 2024-01-26 23:13:12 +01:00 · 2024-01-26 23:13:12 +01:00 · c29607e1c3
parent afe32a1b0d
commit c29607e1c3
6 changed files with 151 additions and 143 deletions
--- 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))
--- 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
--- 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)
--- 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
--- 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 ()
--- 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