diff --git a/README.md b/README.md index 6479b3c..67f58c3 100644 --- a/README.md +++ b/README.md @@ -188,3 +188,42 @@ truly awful, painful experience. The assets folder is copied to the bundle, so all resources should be in assets +## ghengin-core + +What `ghengin-core` does and does not: + +- Does not implement a game-loop, nor a time step strategy +- Does not implement a scene-graph +- Nor (game) object positioning in terms of so-called "world coordinates" +- Does not provide a camera +- Does not manage game objects/entities in any way (no ECS, no FRP, actually, no concept of game object whatsover) +- Does not have a UI abstraction, but will allow renderpasses to be managed in such a way that one can add outside of Core, e.g., a dear-imgui render pass +- Has an (editable) Render Queue with the render packets (meshes + properties + material properties + pipeline with shader) that are rendered every frame +- Can express all of the above things it "does not" do with the existing concepts and combinators +- Handles double-buffering (eventually configurable?) semantics for the 'render' function, i.e. blocks after drawing a second frame + - Actually, it's the renderer implementation that handles this + +## Add-ons + +These add-ons exist as separate packages, and are all included in `ghengin`, the +batteries included engine. These also attempt to be somewhat independent from +ghengin-core when possible. + +- `ghengin-scene-graph`, which defines a scene-graph and world coordinate space + with objects related in a hieararchy with properties defined relative to + their parents (i.e. a scene, in its usual meaning) +- `ghengin-camera`, a camera object, shader, and update function (i.e. a camera, in its usual meaning) +- `ghengin-models`, to load and render 3D models +- `ghengin-lighting`, that provides lighting functions/models like the Blinn-Phong model +- `ghengin-dearimgui`, for UIs based on ghengin + +## Ghengin + +`ghengin` provides game-development abstractions on top of `ghengin-core`, and +is more developer friendly in the sense that it *does not* require linear types + +## Other design ideas + +- The `render/draw` function takes an action which "draws" things, which, + depending on the implementation, either batches the drawcall or actually + makes the draw call. diff --git a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs index 2d89707..4f044ba 100644 --- a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs +++ b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Log.hs @@ -15,6 +15,8 @@ import Ghengin.Core.Prelude as G import System.Log.FastLogger import qualified Prelude (take) +import Control.Functor.Linear as Linear + #ifdef THINGS_ARE_GOING_THAT_BAD -- In that case we always flush and use BS.putStr import qualified Data.ByteString as BS @@ -32,6 +34,10 @@ class MonadIO m => HasLogger m where -- HasLogger for all MonadTrans over a HasLogger m. withLevelUp :: m a ⊸ m a +instance (MonadIO m, HasLogger m) => HasLogger (StateT s m) where + getLogger = lift getLogger + withLevelUp (StateT m) = StateT $ \s -> withLevelUp (m s) + -- | Returns a new logger and an IO cleanup action newLogger :: MonadIO m => LogType -> m (Ur Logger, IO ()) {-# INLINE newLogger #-} diff --git a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Prelude.hs b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Prelude.hs index ab443a4..86f3cfa 100644 --- a/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Prelude.hs +++ b/ghengin-core-indep/ghengin-core-indep/Ghengin/Core/Prelude.hs @@ -180,4 +180,7 @@ l2vec = Unsafe.toLinear V.fromList vec2l :: V.Vector a ⊸ [a] vec2l = Unsafe.toLinear V.toList +--- More orphans +instance MonadIO m => MonadIO (StateT s m) where + liftIO io = StateT $ \s -> (,s) <$> liftIO io diff --git a/ghengin-core/ghengin-core.cabal b/ghengin-core/ghengin-core.cabal index 1cc01a6..b29e10b 100644 --- a/ghengin-core/ghengin-core.cabal +++ b/ghengin-core/ghengin-core.cabal @@ -92,16 +92,17 @@ library Ghengin.Core.Render.Property, Ghengin.Core.Render.Packet, Ghengin.Core.Render.Queue, - Ghengin.Core.Render, + Ghengin.Core.Render - Ghengin.Core.Renderer - signatures: Ghengin.Core.Renderer.Kernel, + signatures: Ghengin.Core.Renderer, + Ghengin.Core.Renderer.Kernel, Ghengin.Core.Renderer.DescriptorSet, Ghengin.Core.Renderer.Buffer, Ghengin.Core.Renderer.Pipeline, Ghengin.Core.Renderer.RenderPass, Ghengin.Core.Renderer.Texture, Ghengin.Core.Renderer.Sampler, + Ghengin.Core.Renderer.Command hs-source-dirs: ghengin-core @@ -113,6 +114,7 @@ library reference-counting, containers, + mtl, vector, gl-block, @@ -120,3 +122,31 @@ library ghengin-core-indep, linear-utils +executable planets-core + main-is: Main.hs + default-extensions: UnicodeSyntax + build-depends: + base >=4.17.0.0, + -- Can't depend on this without instancing it because of backpack + ghengin-core, + ghengin-vulkan, + ghengin-core-indep, + mtl, vector, hsnoise, containers, random, linear-base, + derive-storable + + ghc-options: -dcmm-lint -dstg-lint -dasm-lint -g2 -rtsopts -debug + cpp-options: -DDEBUG + + hs-source-dirs: planets-core + mixins: ghengin-core + requires ( Ghengin.Core.Renderer.Kernel as Ghengin.Vulkan.Renderer.Kernel + , Ghengin.Core.Renderer.DescriptorSet as Ghengin.Vulkan.Renderer.DescriptorSet + , Ghengin.Core.Renderer.Buffer as Ghengin.Vulkan.Renderer.Buffer + , Ghengin.Core.Renderer.Pipeline as Ghengin.Vulkan.Renderer.Pipeline + , Ghengin.Core.Renderer.RenderPass as Ghengin.Vulkan.Renderer.RenderPass + , Ghengin.Core.Renderer.Texture as Ghengin.Vulkan.Renderer.Texture + , Ghengin.Core.Renderer.Sampler as Ghengin.Vulkan.Renderer.Sampler + , Ghengin.Core.Renderer.Command as Ghengin.Vulkan.Renderer.Command + , Ghengin.Core.Renderer as Ghengin.Vulkan.Renderer + ) + default-language: GHC2021 diff --git a/ghengin-core/ghengin-core/Ghengin/Core.hs b/ghengin-core/ghengin-core/Ghengin/Core.hs index cab2f8d..3a63812 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core.hs +++ b/ghengin-core/ghengin-core/Ghengin/Core.hs @@ -1,8 +1,316 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} {-| The entry module for ghengin-core, which defines the surface level of Core with -which one expresses more high-level game-engine and rendering abstractions. +which one expresses more high-level game-engine and rendering abstractions, like Cameras. -} module Ghengin.Core where -newtype Core α = Core () +import Ghengin.Core.Prelude +import Ghengin.Core.Log +import qualified Data.V.Linear as V + +import Control.Functor.Linear as Linear +import qualified Data.Functor.Linear as Data +import Control.Monad.IO.Class.Linear as Linear + +import Ghengin.Core.Render.Queue +import Ghengin.Core.Renderer.Pipeline +import Ghengin.Core.Renderer.RenderPass +import Ghengin.Core.Renderer.Kernel +import Ghengin.Core.Renderer +import Ghengin.Core.Render + +import Ghengin.Core.Render.Packet +import Ghengin.Core.Mesh +import Ghengin.Core.Render.Property +import Ghengin.Core.Material + +import Ghengin.Core.Type.Utils (nat) + +import qualified Data.Linear.Alias as Alias + + +import qualified Vulkan as Vk + +import qualified Data.Linear.Alias.Unsafe as Unsafe.Alias +import qualified Unsafe.Linear as Unsafe + +data CoreState + = CoreState { frameCounter :: {-# UNPACK #-} !Int + , renderQueue :: RenderQueue () + -- ^ The unit type parameter is data attached to each item in the + -- render queue, we could eventually use it for something relevant. + } +newtype Core α = Core (StateT CoreState Renderer α) + deriving (Functor, Data.Functor, Applicative, Data.Applicative, Monad, MonadIO, HasLogger) + +runCore :: Core a ⊸ IO a +runCore (Core st) + = runRenderer $ Linear.do + (a, CoreState i rq) <- runStateT st (CoreState 0 mempty) + flip evalStateT () $ traverseRenderQueue @(StateT () Renderer) @Renderer rq + (\pipeline _ -> Linear.do + -- lift $ destroyRenderPipeline p -- ROMES:TODO: + -- How do I return things if I am to destroy them??? likely make that + -- function yet more contrived. or simpler--really, we just need that + -- the thing is consumed in the function, hence the linear argument + -- (but if it is to be returned we must know, to enforce linearity? we'll see...) + return pipeline + ) + (\p mat -> Linear.do + -- lift $ freeMaterial m -- ROMES:TODO: + return (p, mat) + ) + (\p mesh () -> Linear.do + -- lift $ freeMesh m -- ROMES:TODO: + return (p, mesh) + ) + (pure ()) + () <- pure (consume i) + return a + + + +render :: Core () +render = Core $ StateT $ \CoreState{..} -> enterD "render" $ do + + -- ROMES:TODO: This might cause flickering once every frame overflow due to ... overflows? + -- Need to consider what happens if it overflows. For now, good enough, it's + -- unlikely the frame count overflows, with 60 frames per second the game + -- would have to run for years to overflow a 64 bit integer + let frameIndex = frameCounter `mod` (nat @MAX_FRAMES_IN_FLIGHT_T) + + -- Some required variables + -- TODO: instead, use defaults and provide functions to change viewport and scissor + -- if so desired + Ur extent <- getRenderExtent + let viewport = viewport' extent + scissor = scissor' extent + + {- + Here's a rundown of the draw function for each frame in flight: + + ∀ pipeline ∈ registeredPipelines do + bind global descriptor set at set #0 + + ∀ material ∈ pipeline.registeredMaterials do + bind material descriptor set at set #1 + + ∀ object that uses material do + + bind object descriptor set at set #2 + bind object model (vertex buffer) + draw object + + This makes the descriptor set #0 bound once per pipeline + the descriptor set #1 bound once per material + the descriptor set #2 bound once per object + + The data bound globally for the pipeline must be compatible with the descriptor set #0 layout + All materials bound in a certain pipeline must be compatible with the descriptor set #1 layout + All object data bound in a certain pipeline must be compatible with descriptor set #2 layout + All object's vertex buffers bound in a certain pipeline must be compatible with the vertex input of that pipeline + + In practice, the code doesn't look exactly like this. We bind the + descriptor sets and pipelines linearly because the ordering of the render + queue ensures that the GPU state changes will be minimized and hence the + iteration will actually look a bit like the described above + -} + + withCurrentFramePresent frameIndex $ \cmdBuffer currentImage -> enterD "closure passed to withCurrentFramePresent" $ Linear.do + + cmdBuffer' <- recordCommand cmdBuffer $ Linear.do + + -- Now, render the renderable entities from the render queue in the given order. + -- If everything works as expected, if we blindly bind the descriptor sets as + -- they come, we should bind the pipeline once and each material once. + traverseRenderQueue @(CommandM Renderer) @(RenderPassCmdM Renderer) + renderQueue + -- Whenever we have a new pipeline, start its renderpass (lifting RenderPassCmd to Command) + (\pipeline next -> enterD "Traverse: pipeline" Linear.do + + {- + We'll likely want to do some pre-processing of user-defined render passes, + but let's keep it simple and working for now. + -} + + Ur rp' <- pure $ unsafeGetRenderPass pipeline + let rp = Unsafe.Alias.get rp' -- nice and unsafe + renderPassCmd currentImage rp extent $ Linear.do + + + -- then + + + logT "Binding pipeline" + Ur graphicsPipeline <- pure $ completelyUnsafeGraphicsPipeline pipeline + + -- The render pass for this pipeline has been bound already. Later on the render pass might not be necessarily coupled to the pipeline + -- Bind the pipeline + gppp' <- bindGraphicsPipeline graphicsPipeline + setViewport viewport + setScissor scissor + + lift (descriptors pipeline) >>= \case-- TODO: Fix frames in flight... here it migth be crrect actylly, descriptor sets are shared, only one frame is being drawn at the time despite the double buffering + (dset, rmap, pipeline') -> Linear.do + + -- These render properties are necessarily compatible with this + -- pipeline in the set #0, so the 'descriptorSetBinding' buffer + -- will always be valid to write with the corresponding + -- material binding + (rmap', pipeline'') <- lift $ Alias.useM rmap (\rmap' -> writePropertiesToResources rmap' pipeline') + + -- Bind descriptor set #0 + (dset', pLayout) <- Alias.useM dset (Unsafe.toLinear $ \dset' -> Linear.do + (pLayout', vkdset) <- + bindGraphicsDescriptorSet graphicsPipeline 0 dset' + pure (Unsafe.toLinear (\_ -> dset') vkdset, pLayout') --forget vulkan dset + ) + + -- Dangerous!! Could be forgetting values that need to be + -- reference-counted forgotten, or otherwise references become + -- obsolete. These values are probably shared before being + -- returned from 'descriptors' T_T. + -- OK, I made it less bad, now I'm only forgetting stuff I got unsafely... + -- And the pipeline T_T + Unsafe.toLinearN @3 (\_ _ _ -> pure ()) pipeline'' pLayout gppp' -- The pipeline is still in the Apecs store. Really, these functions should have no Unsafes and in that case all would be right (e.g. the resource passed to this function would have to be freed in this function, guaranteeing that it is reference counted or something?.... + + lift $ Linear.do + Alias.forget dset' + Alias.forget rmap' + + -- finally, call the other actions in the renderpass cmd: + next + + pure pipeline + ) + (\pipeline material -> enterD "Material changed" Linear.do + + logT "Binding material..." + Ur graphicsPipeline <- pure $ completelyUnsafeGraphicsPipeline pipeline + + lift (descriptors material) >>= \case + (dset,rmap,material') -> Linear.do + + -- These materials are necessarily compatible with this pipeline in + -- the set #1, so the 'descriptorSetBinding' buffer will always be + -- valid to write with the corresponding material binding + (rmap', material'') <- lift $ Alias.useM rmap (\rmap' -> writePropertiesToResources rmap' material') + + -- static bindings will have to choose a different dset + -- Bind descriptor set #1 + (dset', pLayout) <- Alias.useM dset (Unsafe.toLinear $ \dset' -> Linear.do + (pLayout', vkdset) <- + bindGraphicsDescriptorSet graphicsPipeline 1 dset' + pure (Unsafe.toLinear (\_ -> dset') vkdset, pLayout') --forget vulkan dset + ) + + Unsafe.toLinearN @2 (\_ _ -> pure ()) material'' pLayout -- The material still in the Apecs store. Really, these functions should have no Unsafes and in that case all would be right (e.g. the resource passed to this function would have to be freed in this function, guaranteeing that it is reference counted or something?.... + + lift $ Linear.do + Alias.forget dset' + Alias.forget rmap' + + pure (pipeline, material) + ) + -- We used to have (\(SomePipeline pipeline) (Some mesh) (ModelMatrix mm _) -> enterD "Mesh changed" Linear.do + (\pipeline mesh () -> enterD "Mesh changed" Linear.do + + logT "Drawing mesh" + Ur graphicsPipeline <- pure $ completelyUnsafeGraphicsPipeline pipeline + + -- TODO: Bind descriptor set #2 + + -- TODO: No more push constants, for now!!!! + -- pLayout <- pushConstants graphicsPipeline._pipelineLayout Vk.SHADER_STAGE_VERTEX_BIT mm + + mesh' <- renderMesh mesh + + pure (pipeline, mesh') + ) + ( + {- + We'll likely want to do some post-processing of user-defined + render passes, but let's keep it simple and working for now. We'll + get back to a clean dear-imgui add-on to ghengin-core later. + -} + + -- Draw UI (TODO: Special render pass...?) + -- liftSystemIO IM.getDrawData >>= IM.renderDrawData + return () + ) + + pure ((), cmdBuffer') + + where + -- The region of the framebuffer that the output will be rendered to. We + -- render from (0,0) to (width, height) i.e. the whole framebuffer + -- Defines a transformation from image to framebuffer + viewport' extent = Vk.Viewport { x = 0.0 + , y = 0.0 + , width = fromIntegral $ extent.width + , height = fromIntegral $ extent.height + , minDepth = 0 + , maxDepth = 1 + } + + -- Defines the region in which pixels will actually be stored. Any pixels + -- outside of the scissor will be discarded. We keep it as the whole viewport + scissor' extent = Vk.Rect2D (Vk.Offset2D 0 0) extent + +-- | Write a property value to its corresponding resource. +-- +-- (1) For each property binding, update the property +-- (1.1) If it's dynamic, write the mapped buffer +-- (1.2) If it's static, do nothing because the buffer is already written +-- (1.3) If it's a texture, do nothing because the texture is written only once and has already been bound +-- +-- (2) The written resource must be updated in the corresponding descriptor set which must be bound (This is done in the render function) +-- +-- The important logic is done by 'writeProperty', this function simply iterates over the properties to write them +-- +-- The render property bindings function should be created from a compatible pipeline +writePropertiesToResources :: ∀ φ α ω. HasProperties φ => ResourceMap ⊸ φ α ⊸ Renderer (ResourceMap, φ α) +writePropertiesToResources rmap' fi + = enterD "writePropertiesToResources" + Linear.do (pbs, fi') <- properties fi + logT "Going on rmap'" + (rmap'', pbs') <- go rmap' 0 pbs + logT "Forgetting property bindings" + Alias.forget pbs' + pure (rmap'', fi') + + where + go :: ∀ β. ResourceMap ⊸ Int -> PropertyBindings β ⊸ Renderer (ResourceMap, PropertyBindings β) + go rmap n = \case + GHNil -> pure (rmap, GHNil) + binding :## as -> Linear.do + (res, rmap'') <- getDescriptorResource rmap n + (res', binding') <- writeProperty res binding -- TODO: We don't want to fetch the binding so often. Each propety could have its ID and fetch it if required + Alias.forget res' -- gotten from rmap, def. not the last ref + (rmap''', bs) <- go rmap'' (n+1) as + pure (rmap''', binding':##bs) + + +renderMesh :: MonadIO m => Mesh a ⊸ RenderPassCmdM m (Mesh a) +renderMesh = \case + SimpleMesh vb -> SimpleMesh <$> drawVertexBuffer vb + IndexedMesh vb ib -> uncurry IndexedMesh <$> drawVertexBufferIndexed vb ib + +-- completely unsafe things, todo:fix + +completelyUnsafeGraphicsPipeline :: ∀ α info. RenderPipeline info α ⊸ Ur (RendererPipeline Graphics) +completelyUnsafeGraphicsPipeline = Unsafe.toLinear $ \x -> Ur (get' x) -- just unsafe... + where + get' :: ∀ b. RenderPipeline info b -> (RendererPipeline Graphics) + get' (RenderPipeline rpg _ _ _) = rpg + get' (RenderProperty _ rp) = get' rp + +unsafeGetRenderPass :: ∀ α info. RenderPipeline info α ⊸ Ur (Alias RenderPass) +unsafeGetRenderPass = Unsafe.toLinear $ \x -> Ur (get' x) + where + get' :: ∀ b. RenderPipeline info b -> Alias RenderPass + get' (RenderPipeline _ rp _ _) = rp + get' (RenderProperty _ rp) = get' rp diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Render.hs b/ghengin-core/ghengin-core/Ghengin/Core/Render.hs index c3b734d..9e8e37f 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core/Render.hs +++ b/ghengin-core/ghengin-core/Ghengin/Core/Render.hs @@ -1,6 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} module Ghengin.Core.Render where -import Ghengin.Core.Renderer +import qualified Data.IntMap.Linear as IM +import Ghengin.Core.Log +import Prelude.Linear +import Control.Functor.Linear as Linear + +import Ghengin.Core.Renderer.Buffer +import Ghengin.Core.Renderer.Kernel +import Ghengin.Core.Renderer.DescriptorSet + +import qualified Data.Linear.Alias as Alias -- Backend agnostic rendering functions? + +-- I don't know yet what the purpose of this module is. + +-- I don't know where exactly to put this, so put it here for now +getDescriptorResource :: ResourceMap ⊸ Int -> Renderer (DescriptorResource, ResourceMap) +getDescriptorResource resourcemap i = enterD "getUniformBuffer" $ + IM.lookupM i resourcemap >>= \case + (Just x, rmap1) -> pure (x, rmap1) + (Nothing, rmap1) -> Linear.do + Alias.forget rmap1 + error $ "Expecting a uniform descriptor resource at binding " <> show i <> " but found nothing!" diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs b/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs index f47decb..9db88f5 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs +++ b/ghengin-core/ghengin-core/Ghengin/Core/Render/Property.hs @@ -15,6 +15,7 @@ module Ghengin.Core.Render.Property import Ghengin.Core.Prelude as Linear import Foreign.Storable (Storable(sizeOf)) import Ghengin.Core.Renderer +import Ghengin.Core.Render import Ghengin.Core.Renderer.Texture import Ghengin.Core.Type.Utils import qualified Data.Linear.Alias as Alias diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs b/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs index 001dbe0..0b195c6 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs +++ b/ghengin-core/ghengin-core/Ghengin/Core/Render/Queue.hs @@ -98,7 +98,7 @@ instance Monoid (RenderQueue α) where traverseRenderQueue :: (Linear.Monad μ, Linear.Monad μ') => RenderQueue α -- ^ The render queue ⊸ (∀ π bs. RenderPipeline π bs ⊸ μ' () -> μ (RenderPipeline π bs)) -- ^ The initial context lifting from m to m' for the inner functions - -- -> (Some2 Pipeline ⊸ μ' SomePipeline) -- ^ The pipeline changed (nothing should be rendered) (return the pipeline fetched) + -- ????what was this -> (Some2 Pipeline ⊸ μ' SomePipeline) -- ^ The pipeline changed (nothing should be rendered) (return the pipeline fetched) -> (∀ π bs ms. RenderPipeline π bs ⊸ Material ms ⊸ μ' (RenderPipeline π bs, Material ms)) -- ^ The material changed (nothing should be rendered) -> (∀ π bs τs. RenderPipeline π bs ⊸ Mesh τs ⊸ α ⊸ μ' (RenderPipeline π bs, Mesh τs)) -- ^ The mesh to render -> μ' () -- ^ A command at the end of each render pass diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hs b/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hs deleted file mode 100644 index 479cfe6..0000000 --- a/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Ghengin.Core.Renderer - ( module Ghengin.Core.Renderer.DescriptorSet - , module Ghengin.Core.Renderer.Buffer - , module Ghengin.Core.Renderer.Kernel - , module Ghengin.Core.Renderer - ) where - -import qualified Data.IntMap.Linear as IM -import Ghengin.Core.Log -import Prelude.Linear - -import Control.Functor.Linear as Linear - -import Ghengin.Core.Renderer.Buffer -import Ghengin.Core.Renderer.Kernel -import Ghengin.Core.Renderer.DescriptorSet - -import qualified Data.Linear.Alias as Alias - -getDescriptorResource :: ResourceMap ⊸ Int -> Renderer (DescriptorResource, ResourceMap) -getDescriptorResource resourcemap i = enterD "getUniformBuffer" $ - IM.lookupM i resourcemap >>= \case - (Just x, rmap1) -> pure (x, rmap1) - (Nothing, rmap1) -> Linear.do - Alias.forget rmap1 - error $ "Expecting a uniform descriptor resource at binding " <> show i <> " but found nothing!" diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hsig b/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hsig new file mode 100644 index 0000000..52f786b --- /dev/null +++ b/ghengin-core/ghengin-core/Ghengin/Core/Renderer.hsig @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +signature Ghengin.Core.Renderer + ( module Ghengin.Core.Renderer.DescriptorSet + , module Ghengin.Core.Renderer.Buffer + , module Ghengin.Core.Renderer.Command + , module Ghengin.Core.Renderer.Kernel + , module Ghengin.Core.Renderer + ) + where + +import qualified Data.IntMap.Linear as IM +import Ghengin.Core.Log +import Prelude.Linear + +import Control.Functor.Linear as Linear +import System.IO.Linear as Linear +import Control.Monad.IO.Class.Linear as Linear + +import Ghengin.Core.Renderer.Buffer +import Ghengin.Core.Renderer.Kernel +import Ghengin.Core.Renderer.DescriptorSet +import Ghengin.Core.Renderer.Command + +import qualified Data.Linear.Alias as Alias + +runRenderer :: Renderer a ⊸ Linear.IO a + +-- extremely contrived? not anymore (at least no longer using the transformer thing, since we no longer mix render packets with things like the ECS system s.t. this function had to be run in ECS context)! +withCurrentFramePresent :: Int -- ^ Current frame index + -> ( CommandBuffer + ⊸ Int -- ^ Current image index + -> Renderer (a, CommandBuffer) + ) + ⊸ Renderer a + diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Renderer/Command.hsig b/ghengin-core/ghengin-core/Ghengin/Core/Renderer/Command.hsig new file mode 100644 index 0000000..ad03722 --- /dev/null +++ b/ghengin-core/ghengin-core/Ghengin/Core/Renderer/Command.hsig @@ -0,0 +1,58 @@ +signature Ghengin.Core.Renderer.Command where + +import Ghengin.Core.Prelude +import Ghengin.Core.Log +import Control.Monad.IO.Class.Linear +import qualified Data.Functor.Linear as Data + +import Ghengin.Core.Renderer.Pipeline +import Ghengin.Core.Renderer.Buffer +import Ghengin.Core.Renderer.DescriptorSet +import Ghengin.Core.Renderer.RenderPass + +import qualified Vulkan as Vk + +type RenderPassCmd m = RenderPassCmdM m () +type Command m = CommandM m () + +data RenderPassCmdM m a +data CommandM m a + +data CommandBuffer + +instance Applicative m => Applicative (CommandM m) +instance Data.Applicative m => Data.Applicative (CommandM m) +instance Monad m => Monad (CommandM m) +instance MonadIO m => MonadIO (CommandM m) +instance HasLogger m => HasLogger (CommandM m) +instance MonadTrans CommandM + +instance Applicative m => Applicative (RenderPassCmdM m) +instance Data.Applicative m => Data.Applicative (RenderPassCmdM m) +instance Monad m => Monad (RenderPassCmdM m) +instance MonadIO m => MonadIO (RenderPassCmdM m) +instance HasLogger m => HasLogger (RenderPassCmdM m) +instance MonadTrans RenderPassCmdM + +-- the command buffer comes from the leaky +recordCommand :: MonadIO m => CommandBuffer ⊸ Command m ⊸ m CommandBuffer + +-- TODO: Cleanup the API + +drawVertexBuffer :: MonadIO m => VertexBuffer ⊸ RenderPassCmdM m VertexBuffer +drawVertexBufferIndexed :: MonadIO m => VertexBuffer ⊸ Index32Buffer ⊸ RenderPassCmdM m (VertexBuffer, Index32Buffer) + +bindGraphicsPipeline :: MonadIO m => RendererPipeline Graphics ⊸ RenderPassCmdM m (RendererPipeline Graphics) + +bindGraphicsDescriptorSet :: MonadIO m + => RendererPipeline Graphics + ⊸ Word32 -- ^ Set index at which to bind the descriptor set + -> DescriptorSet ⊸ RenderPassCmdM m (RendererPipeline Graphics, DescriptorSet) + +-- leaky, fixme. +setViewport :: MonadIO m => Vk.Viewport -> RenderPassCmd m +setScissor :: MonadIO m => Vk.Rect2D -> RenderPassCmd m + +renderPassCmd :: MonadIO m + => Int -- ^ needs a good explanation... + -> RenderPass -> Vk.Extent2D -> RenderPassCmdM m a -> CommandM m a diff --git a/ghengin-core/ghengin-core/Ghengin/Core/Renderer/Kernel.hsig b/ghengin-core/ghengin-core/Ghengin/Core/Renderer/Kernel.hsig index eef21bf..f08066b 100644 --- a/ghengin-core/ghengin-core/Ghengin/Core/Renderer/Kernel.hsig +++ b/ghengin-core/ghengin-core/Ghengin/Core/Renderer/Kernel.hsig @@ -3,6 +3,7 @@ signature Ghengin.Core.Renderer.Kernel where import GHC.TypeNats import Prelude.Linear import Control.Functor.Linear as Linear +import qualified Data.Functor.Linear as Data import Control.Monad.IO.Class.Linear as Linear import qualified System.IO.Linear @@ -20,6 +21,8 @@ newtype Renderer a type Alias = Alias.Alias Renderer -- These could all be shared accross backends :) +instance Data.Functor Renderer +instance Data.Applicative Renderer instance Linear.Functor Renderer instance Linear.Applicative Renderer instance Linear.Monad Renderer diff --git a/ghengin-core/planets-core/Main.hs b/ghengin-core/planets-core/Main.hs new file mode 100644 index 0000000..3de1c19 --- /dev/null +++ b/ghengin-core/planets-core/Main.hs @@ -0,0 +1,27 @@ +{-| + +The planets-core demo: + +A planet (render packet) is defined through a mesh, material, and pipeline, +which in turn are made up of multiple things, as represented in the following picture. + +┌─────────────┐┌─────────────┐┌────────────┐┌──────┐┌───────────┐ +│Position (DP)││Colormap (TP)││Min Max (SP)││Shader││Camera (DP)│ +└┬────────────┘└┬────────────┘└┬───────────┘└┬─────┘└┬──────────┘ +┌▽───┐┌─────────▽──────────────▽┐┌───────────▽───────▽┐ +│Mesh││Material ││Pipeline │ +└┬───┘└┬────────────────────────┘└┬───────────────────┘ +┌▽─────▽──────────────────────────▽┐ +│Planet (RenderPacket) │ +└──────────────────────────────────┘ + +The function `newPlanet` handles the creation of planet render packets. + +The main function + +-} +module Main where + +main :: IO () +main = runCore + diff --git a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs index f80cec8..2948ee0 100644 --- a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs +++ b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer.hs @@ -55,7 +55,7 @@ import qualified System.IO.Linear as Linear -- ROMES: Eventually thikn about bracketing again, but for linear types to work simply get rid of it -- ROMES:TODO: Make runRenderer an hsig in Ghengin.Core.Renderer -runRenderer :: Renderer a -> Linear.IO a +runRenderer :: Renderer a ⊸ Linear.IO a runRenderer r = Linear.do -- Initialisation @@ -135,17 +135,17 @@ runRenderer r = Linear.do -- N is 'MAX_FRAMES_IN_FLIGHT' -- -- TODO: Figure out mismatch between current image index and current image frame. -withCurrentFramePresent :: (MonadTrans t, MonadIO (t (Renderer))) - -- => ( ∀ α. Renderer α -> t (Renderer ext) α ) -- ^ A lift function - => Int -- ^ Current frame index +-- +-- I don't think we need the `t` transformer any longer! +withCurrentFramePresent :: Int -- ^ Current frame index -> ( Vk.CommandBuffer ⊸ Int -- ^ Current image index - -> t (Renderer) (a, Vk.CommandBuffer) + -> Renderer (a, Vk.CommandBuffer) ) - ⊸ t (Renderer) a + ⊸ Renderer a withCurrentFramePresent currentFrameIndex action = Linear.do - Ur unsafeCurrentFrame <- lift $ renderer $ Unsafe.toLinear $ \renv -> pure (Ur (case renv._frames of (VI.V vec) -> vec V.! currentFrameIndex),renv) + Ur unsafeCurrentFrame <- renderer $ Unsafe.toLinear $ \renv -> pure (Ur (case renv._frames of (VI.V vec) -> vec V.! currentFrameIndex),renv) -- These are all unsafe too let cmdBuffer = unsafeCurrentFrame._commandBuffer @@ -158,12 +158,12 @@ withCurrentFramePresent currentFrameIndex action = Linear.do -- Record a command buffer which draws the scene onto that image -- Submit the recorded command buffer -- Present the swap chain image - lift $ unsafeUseDevice (\device -> do + unsafeUseDevice (\device -> do Vk.waitForFences device [inFlightFence] True maxBound Vk.resetFences device [inFlightFence] ) - (Ur i, imageAvailableSem') <- lift $ acquireNextImage imageAvailableSem + (Ur i, imageAvailableSem') <- acquireNextImage imageAvailableSem liftSystemIO $ Vk.resetCommandBuffer cmdBuffer zero @@ -171,9 +171,9 @@ withCurrentFramePresent currentFrameIndex action = Linear.do -- Finally, submit and present (cmdBuffer'',imageAvailableSem'', renderFinishedSem', inFlightFence') - <- lift $ submitGraphicsQueue cmdBuffer' imageAvailableSem' renderFinishedSem inFlightFence + <- submitGraphicsQueue cmdBuffer' imageAvailableSem' renderFinishedSem inFlightFence - renderFinishedSem'' <- lift $ presentPresentQueue renderFinishedSem' i + renderFinishedSem'' <- presentPresentQueue renderFinishedSem' i -- Forget these as they're in the renderer environment still, remember we got them unsafely in the first place... Unsafe.toLinearN @4 (\_ _ _ _ -> pure ()) cmdBuffer'' imageAvailableSem'' renderFinishedSem'' inFlightFence' diff --git a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/Command.hs b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/Command.hs index 8b74b79..fab20a9 100644 --- a/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/Command.hs +++ b/ghengin-vulkan/ghengin-vulkan/Ghengin/Vulkan/Renderer/Command.hs @@ -20,6 +20,7 @@ module Ghengin.Vulkan.Renderer.Command , RenderPassCmd , CommandM , RenderPassCmdM + , CommandBuffer -- for backpack, re-export Vulkan's definition , recordCommand , recordCommandOneShot , renderPassCmd @@ -74,6 +75,7 @@ import qualified Vulkan.Zero as Vk import qualified Vulkan as Vk import Ghengin.Vulkan.Renderer.Device +import Ghengin.Vulkan.Renderer.Command import Ghengin.Core.Type.Utils (w32) import Ghengin.Core.Log @@ -239,7 +241,7 @@ recordCommandOneShot = Unsafe.toLinear2 \buf (Command cmds) -> Linear.do {-# INLINE recordCommandOneShot #-} -- | Make a render pass part a command blueprint that can be further composed with other commands -renderPassCmd :: Linear.MonadIO m => Vk.RenderPass -> Vk.Framebuffer -> Vk.Extent2D -> RenderPassCmd m -> Command m +renderPassCmd :: Linear.MonadIO m => Vk.RenderPass -> Vk.Framebuffer -> Vk.Extent2D -> RenderPassCmdM m a -> CommandM m a renderPassCmd rpass frameBuffer renderAreaExtent (RenderPassCmd rpcmds) = Command $ ReaderT \buf -> Linear.do let renderPassInfo = Vk.RenderPassBeginInfo { next = () @@ -256,9 +258,9 @@ renderPassCmd rpass frameBuffer renderAreaExtent (RenderPassCmd rpcmds) = Comman Linear.liftSystemIO $ Vk.cmdEndRenderPass buf {-# INLINE renderPassCmd #-} -bindGraphicsPipeline :: Linear.MonadIO m => Vk.Pipeline ⊸ RenderPassCmdM m Vk.Pipeline -bindGraphicsPipeline pp = unsafeRenderPassCmd pp (\buf -> Vk.cmdBindPipeline buf Vk.PIPELINE_BIND_POINT_GRAPHICS) -{-# INLINE bindGraphicsPipeline #-} +bindGraphicsPipeline' :: Linear.MonadIO m => Vk.Pipeline ⊸ RenderPassCmdM m Vk.Pipeline +bindGraphicsPipeline' pp = unsafeRenderPassCmd pp (\buf -> Vk.cmdBindPipeline buf Vk.PIPELINE_BIND_POINT_GRAPHICS) +{-# INLINE bindGraphicsPipeline' #-} bindComputePipeline :: Linear.MonadIO m => Vk.Pipeline -> RenderPassCmdM m Vk.Pipeline bindComputePipeline pp = unsafeRenderPassCmd pp (\buf -> Vk.cmdBindPipeline buf Vk.PIPELINE_BIND_POINT_COMPUTE) @@ -276,8 +278,8 @@ setScissor :: Linear.MonadIO m => Vk.Rect2D -> RenderPassCmd m setScissor scissor = unsafeRenderPassCmd_ (\buf -> Vk.cmdSetScissor buf 0 [scissor]) {-# INLINE setScissor #-} -bindVertexBuffers :: Linear.MonadIO m => Word32 -> Vector Vk.Buffer ⊸ Vector Vk.DeviceSize -> RenderPassCmdM m (Vector Vk.Buffer) -bindVertexBuffers i bufs offsets = unsafeRenderPassCmd bufs (\cmdbuf bufs' -> Vk.cmdBindVertexBuffers cmdbuf i bufs' offsets) +bindVertexBuffers :: Linear.MonadIO m => Word32 -> V.V n Vk.Buffer ⊸ V.V n Vk.DeviceSize -> RenderPassCmdM m (V.V n Vk.Buffer) +bindVertexBuffers i bufs (VI.V offsets) = unsafeRenderPassCmd bufs (\cmdbuf (VI.V bufs') -> Vk.cmdBindVertexBuffers cmdbuf i bufs' offsets) {-# INLINE bindVertexBuffers #-} bindIndex32Buffer :: Linear.MonadIO m @@ -307,12 +309,13 @@ pushConstants pipelineLayout stageFlags values = unsafeRenderPassCmd pipelineLay Vk.cmdPushConstants buf piplayout stageFlags 0 (fromIntegral $ sizeOf values) (castPtr ptr) {-# INLINE pushConstants #-} -bindGraphicsDescriptorSet :: Linear.MonadIO m +bindGraphicsDescriptorSet' :: Linear.MonadIO m => Vk.PipelineLayout ⊸ Word32 -- ^ Set index at which to bind the descriptor set -> Vk.DescriptorSet ⊸ RenderPassCmdM m (Vk.PipelineLayout, Vk.DescriptorSet) -bindGraphicsDescriptorSet pipelay ix dset = +bindGraphicsDescriptorSet' pipelay ix dset = unsafeRenderPassCmd (pipelay,dset) (\buf (pip',dset') -> Vk.cmdBindDescriptorSets buf Vk.PIPELINE_BIND_POINT_GRAPHICS pip' ix [dset'] []) -- offsets array not used +{-# INLINE bindGraphicsDescriptorSet' #-} -- | Lift a function that uses a command buffer to a Command -- Get back to this: not trivial with linearity. Probably unsafe will have to be called outside @@ -438,6 +441,45 @@ transitionImageLayout = Unsafe.toLinear $ \img format srcLayout dstLayout -> , img ) +----- More for the .hsig interface ------- + +-- While I don't know the best place to keep this, I keep it here: +-- +-- Ultimately, I think it will be about a good abstraction for issuing/batching +-- draw call. + + +drawVertexBuffer :: MonadIO m => VertexBuffer ⊸ RenderPassCmdM m VertexBuffer +drawVertexBuffer (VertexBuffer (DeviceLocalBuffer buf mem) nverts) = Linear.do + let offsets = V.make 0 + buffers' <- bindVertexBuffers 0 (V.make buf) offsets + draw nverts + pure (VertexBuffer (DeviceLocalBuffer (V.elim id buffers') mem) nverts) + +drawVertexBufferIndexed :: MonadIO m => VertexBuffer ⊸ Index32Buffer ⊸ RenderPassCmdM m (VertexBuffer, Index32Buffer) +drawVertexBufferIndexed (VertexBuffer (DeviceLocalBuffer vbuf mem) nverts) (Index32Buffer (DeviceLocalBuffer ibuf imem) nixs) = Linear.do + let offsets = V.make 0 + buffers' <- bindVertexBuffers 0 (V.make vbuf) offsets + ibuf' <- bindIndex32Buffer ibuf 0 + drawIndexed nixs + pure ( VertexBuffer (DeviceLocalBuffer (V.elim id buffers') mem) nverts + , Index32Buffer (DeviceLocalBuffer ibuf' imem) nixs + ) + +bindGraphicsPipeline :: Linear.MonadIO m => RendererPipeline Graphics ⊸ RenderPassCmdM m GraphicsPipeline +bindGraphicsPipeline pp = bindGraphicsPipeline' pp._pipeline +{-# INLINE bindGraphicsPipeline #-} + +bindGraphicsDescriptorSet :: Linear.MonadIO m + => RendererPipeline Graphics + ⊸ Word32 -- ^ Set index at which to bind the descriptor set + -> DescriptorSet ⊸ RenderPassCmdM m (RendererPipeline Graphics, DescriptorSet) +bindGraphicsDescriptorSet pipelay ix dset = bindGraphicsDescriptorSet' pipelay._pipelineLayout ix dset._descriptorSet +{-# INLINE bindGraphicsDescriptorSet #-} + +renderPassCmd :: Linear.MonadIO m => Int -- ^ needs a good explanation... + -> RenderPass -> Vk.Extent2D -> RenderPassCmd m -> Command m +renderPassCmd currentImage = Unsafe.toLinear \rpass renderAreaExtent rpcmds -> renderPassCmd' rpass._renderPass (rpass._framebuffers V.! currentImage) renderAreaExtent rpcmds ----- Linear Unsafe Utils @@ -457,3 +499,5 @@ unsafeRenderPassCmd = Unsafe.toLinear \a f -> (RenderPassCmd $ ReaderT \buf -> a unsafeRenderPassCmd_ :: Linear.MonadIO m => (Vk.CommandBuffer -> IO ()) -> RenderPassCmd m unsafeRenderPassCmd_ = Unsafe.toLinear \f -> (RenderPassCmd $ ReaderT \buf -> Linear.liftSystemIO (f buf)) +-- ghengin-vulkan can't yet depend on ghengin-core because of backpack bugs +-- (TODO: Report that ghc bug) diff --git a/ghengin/ghengin.cabal b/ghengin/ghengin.cabal index 311a7fa..50f9ef5 100644 --- a/ghengin/ghengin.cabal +++ b/ghengin/ghengin.cabal @@ -213,6 +213,8 @@ library , Ghengin.Core.Renderer.RenderPass as Ghengin.Vulkan.Renderer.RenderPass , Ghengin.Core.Renderer.Texture as Ghengin.Vulkan.Renderer.Texture , Ghengin.Core.Renderer.Sampler as Ghengin.Vulkan.Renderer.Sampler + , Ghengin.Core.Renderer.Command as Ghengin.Vulkan.Renderer.Command + , Ghengin.Core.Renderer as Ghengin.Vulkan.Renderer ) -- Directories containing source files. @@ -286,6 +288,8 @@ executable planets , Ghengin.Core.Renderer.RenderPass as Ghengin.Vulkan.Renderer.RenderPass , Ghengin.Core.Renderer.Texture as Ghengin.Vulkan.Renderer.Texture , Ghengin.Core.Renderer.Sampler as Ghengin.Vulkan.Renderer.Sampler + , Ghengin.Core.Renderer.Command as Ghengin.Vulkan.Renderer.Command + , Ghengin.Core.Renderer as Ghengin.Vulkan.Renderer ) -- Base language which the package is written in.