fill ReadState

src/CommandBuffer.hs

@@ -1,11 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 module CommandBuffer where
 
+import qualified Control.Concurrent.STM as STM
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Reader
 import Control.Monad.Trans.Resource
+import qualified Data.Map.Strict as M
 import qualified Data.Vector as V
 import Foreign
 import Foreign.C.Types (CInt)
@@ -61,15 +65,13 @@ createCommandBuffer logicalDevice commandPool number = do
     replicateM number (Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo)
 
 recordCommandBuffer
-  :: (MonadResource m)
+  :: (MonadResource m, MonadReader ReadState m, MonadIO m)
   => Vk.CommandBuffer
   -> Vk.RenderPass
   -> Vk.Framebuffer
   -> V2 CInt
   -> Vk.Pipeline
   -> Vk.PipelineLayout
-  -> Maybe Mesh
-  -> Int
   -> m ()
 recordCommandBuffer
   commandBuffer
@@ -78,8 +80,6 @@ recordCommandBuffer
   (V2 width height)
   graphicsPipeline
   meshLayout
-  mesh
-  frameNumber
   = do
 
     let commandBufferBeginInfo = Vk.zero
@@ -131,20 +131,24 @@ recordCommandBuffer
     Vk.cmdSetViewport commandBuffer 0 (V.singleton viewport)
     Vk.cmdSetScissor commandBuffer 0 (V.singleton scissor)
 
-    liftIO $ maybe
+    renderObjects <- (liftIO . STM.atomically . STM.readTMVar) =<< asks renderables
-      (Vk.cmdDraw commandBuffer 3 1 0 0)
+    meshMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary
-      (\jmesh -> do
+    materialMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks materialLibrary
+
+    V.mapM_
+      (\(RenderObject meshID materialID modelMatrix) -> do
+
         let camPosition = V3 0 0 (-5)
             camCenter = V3 0 0 0
             camUp = V3 0 1 0
             view = lookAt camPosition camCenter camUp
             projection = perspective (pi/4) (800 / 600) 0.1 200
-            modelRot = axisAngle (V3 0 1 0) (fromIntegral frameNumber / (10 * pi))
+            pvm = projection !*! view !*! modelMatrix
-            model = mkTransformation modelRot (V3 0 0 0)
-            pvm = projection !*! view !*! model
             constants = MeshPushConstants (V4 0 0 0 0) (transpose pvm)
+            mesh = meshMap M.! meshID
+            material = materialMap M.! materialID
 
-        pointer <- castPtr <$> new constants
+        pointer <- liftIO (castPtr <$> new constants)
         Vk.cmdPushConstants
           commandBuffer
           meshLayout
@@ -156,12 +160,12 @@ recordCommandBuffer
         Vk.cmdBindVertexBuffers
           commandBuffer
           0
-          (V.fromList [ allocatedBuffer $ meshBuffer jmesh ])
+          (V.fromList [ allocatedBuffer $ meshBuffer mesh ])
           (V.fromList [ 0 ])
 
-        Vk.cmdDraw commandBuffer (fromIntegral $ V.length $ meshVertices jmesh) 1 0 0
+        Vk.cmdDraw commandBuffer (fromIntegral $ V.length $ meshVertices mesh) 1 0 0
         )
-      mesh
+      renderObjects
 
     Vk.cmdEndRenderPass commandBuffer
 

src/Draw.hs

@@ -1,9 +1,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Draw where
 
+import qualified Control.Concurrent.STM as STM
 import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Reader
 import Control.Monad.Trans.Resource
+import qualified Data.Map.Strict as M
 import qualified Data.Vector as V
 import qualified Vulkan.Core10 as Vk
 import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
@@ -16,11 +21,10 @@ import CommandBuffer
 import Types
 
 drawFrame
-  :: (MonadResource m, MonadFail m)
+  :: (MonadResource m, MonadFail m, MonadReader ReadState m)
   => EngineData
-  -> Int
   -> m ()
-drawFrame engineData frameNumber = do
+drawFrame engineData = do
 
   unless (all (V.length (engineCommandBuffers engineData) ==)
     [ V.length (engineCommandBuffers engineData)
@@ -51,16 +55,16 @@ drawFrame engineData frameNumber = do
   Vk.resetCommandBuffer
     (engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
 
+  matLibrary <- (liftIO . STM.atomically. STM.readTMVar) =<< asks materialLibrary
+
   -- liftIO $ putStrLn "recording command buffer"
   recordCommandBuffer
     (engineCommandBuffers engineData V.! fromIntegral index)
     (engineRenderPass engineData)
     (engineFramebuffers engineData V.! fromIntegral index)
     (engineWindowDimensions engineData)
-    (meshPipeline engineData V.! fromIntegral index)
+    (materialPipeline $  matLibrary M.! "defaultMesh")
     (meshPipelineLayout engineData)
-    (Just $ engineMesh engineData)
-    frameNumber
 
   let submitInfo = Vk.zero
         { Vk.waitSemaphores =

src/GraphicsPipeline.hs

@@ -1,15 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 module GraphicsPipeline where
 
 import Linear
-import Control.Monad (unless)
+import qualified Control.Concurrent.STM as STM
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader
 import Control.Monad.Trans.Resource
 import Data.Bits
 -- import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS
+import qualified Data.Map.Strict as M
 import qualified Data.Vector as V
 import Foreign (sizeOf)
 import Foreign.C.Types (CInt)
@@ -21,7 +23,6 @@ import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
 
 -- internal imports
 import Types
-import Mesh
 
 loadShader
   :: (MonadResource m)
@@ -194,24 +195,23 @@ createMultisampleStateCreateInfo =
     }
 
 createGraphicsPipelines
-  :: (MonadResource m)
+  :: (MonadResource m, MonadReader ReadState m)
   => Vk.Device
   -> Vk.RenderPass
   -> ShaderContainer
   -> V2 CInt
-  -> Int
   -> Vk.PipelineLayout
   -> Maybe Vk.PipelineDepthStencilStateCreateInfo
-  -> m (V.Vector Vk.Pipeline)
+  -> m ()
 createGraphicsPipelines
   logicalDevice
   renderPass
   shaderContainer
   (V2 width height)
-  number
   pipelineLayout
   depthState
   = do
+    meshLib <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary
     let pipelineStagesCreateInfos =
           V.fromList $ map Vk.SomeStruct
             ( maybe
@@ -242,7 +242,7 @@ createGraphicsPipelines
         pipelineDynamicStateCreateInfo = Vk.zero
           { Vk.dynamicStates = dynamicStates
           }
-        vertexDescription = getVertexDescription (V.head loadMeshes)
+        vertexDescription = getVertexDescription (V.head $ meshVertices $ meshLib M.! "mask")
         pipelineVertexInputCreateInfo = Vk.zero
           { Vk.vertexBindingDescriptions   = vidBindings vertexDescription
           , Vk.vertexAttributeDescriptions = vidAttributes vertexDescription
@@ -300,12 +300,12 @@ createGraphicsPipelines
           , Vk.basePipelineIndex  = -1
           }
 
-    snd <$> allocate
+    pipeline <- snd <$> allocate
       (do
         (result, pipelines) <- Vk.createGraphicsPipelines
           logicalDevice
           Vk.NULL_HANDLE
-          (V.replicate number (Vk.SomeStruct pipelineCreateInfo))
+          (V.singleton (Vk.SomeStruct pipelineCreateInfo))
           Nothing
         unless (result == Vk.SUCCESS) $
           error "createGraphicsPipelines: Failed creating pipelines"
@@ -319,6 +319,11 @@ createGraphicsPipelines
             )
           pipelines
         )
+    let material = Material (V.head pipeline) pipelineLayout
+    matLibraryTMVar <- asks materialLibrary
+    matLibrary <- liftIO $ STM.atomically $ STM.readTMVar matLibraryTMVar
+    let newMatLibrary = M.insert "defaultMesh" material matLibrary
+    void $ liftIO $ STM.atomically $ STM.swapTMVar matLibraryTMVar newMatLibrary
 
 createPipelineLayout
   :: MonadResource m

src/Init.hs

@@ -1,14 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Init where
 
+import qualified Control.Concurrent.STM as STM
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Reader
 import Control.Monad.Trans.Resource
+import qualified Data.Vector as V
 import qualified SDL hiding (V2)
 import qualified SDL.Video.Vulkan as SDL
 import Foreign.Ptr
+import Linear as L
 import qualified Vulkan.Core10 as Vk
 import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
 import qualified Vulkan.Extensions.VK_KHR_surface as Khr
@@ -77,8 +82,6 @@ initVulkan window = do
 
   allocator <- initAllocator vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance
 
-  maskMesh <- loadFromObj "./assets/cat_mask_cyberpunk.obj" allocator
-
   dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
   (swapchain, surfaceFormat, depthImageView, depthAllocatedImage) <-
     createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice allocator
@@ -88,15 +91,13 @@ initVulkan window = do
   renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat) Vk.FORMAT_D32_SFLOAT
   meshLayout <- createMeshPipelineLayout vulkanLogicalDevice
   let meshContainer = ShaderContainer (Just meshVertexShader) (Just meshFragmentShader)
-  meshPipelines <-
+  createGraphicsPipelines
-    createGraphicsPipelines
+    vulkanLogicalDevice
-      vulkanLogicalDevice
+    renderPass
-      renderPass
+    meshContainer
-      meshContainer
+    dimensions
-      dimensions
+    meshLayout
-      (length imageViews)
+    (Just (createDepthStencilStateCreateInfo True True Vk.COMPARE_OP_LESS_OR_EQUAL))
-      meshLayout
-      (Just (createDepthStencilStateCreateInfo True True Vk.COMPARE_OP_LESS_OR_EQUAL))
 
   frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews depthImageView dimensions
 
@@ -106,6 +107,10 @@ initVulkan window = do
   (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
     createSyncObjects vulkanLogicalDevice
 
+  loadMeshes allocator
+
+  initScene
+
   return $ EngineData
     window
     dimensions
@@ -117,14 +122,25 @@ initVulkan window = do
     commandBuffer
     frameBuffers
     meshLayout
-    meshPipelines
     renderPass
     inFlightFence
     imageAvailableSemaphore
     renderFinishedSemaphore
-    maskMesh
-    maskMesh
     allocator
     depthImageView
     depthAllocatedImage
     Vk.FORMAT_D32_SFLOAT
+
+initScene :: (MonadReader ReadState m, MonadIO m) => m ()
+initScene = do
+  let mask = RenderObject
+        { objectMesh     = "mask"
+        , objectMaterial = "defaultMesh"
+        , objectMatrix   = identity
+        }
+
+  renderableContainer <- asks renderables
+  renderableVector <- liftIO $ STM.atomically $ STM.readTMVar renderableContainer
+
+  void $ liftIO $ STM.atomically $ STM.swapTMVar renderableContainer $
+    renderableVector `V.snoc` mask

src/Main.hs

@@ -39,17 +39,14 @@ main = do
 
     -- create abort condition for upcoming lop
     quit <- liftIO $ STM.newTMVarIO True
-    frameContainer <- liftIO $ STM.newTMVarIO 0
 
     -- main loop
     whileM_
       (liftIO $ STM.atomically $ STM.readTMVar quit
         )
       ( do
-        frameNumber <- liftIO $ STM.atomically $ STM.takeTMVar frameContainer
-        liftIO $ STM.atomically $ STM.putTMVar frameContainer (succ frameNumber)
         -- draw
-        drawFrame engineData frameNumber
+        drawFrame engineData
         -- poll events
         evs <- liftIO SDL.pollEvents
         -- flip abort condition on window close

src/Types.hs

@@ -34,13 +34,10 @@ data EngineData = EngineData
   , engineCommandBuffers          :: V.Vector Vk.CommandBuffer
   , engineFramebuffers            :: V.Vector Vk.Framebuffer
   , meshPipelineLayout            :: Vk.PipelineLayout
-  , meshPipeline                  :: V.Vector Vk.Pipeline
   , engineRenderPass              :: Vk.RenderPass
   , engineInFlightFence           :: Vk.Fence
   , engineImageAvailableSemaphore :: Vk.Semaphore
   , engineRenderFinishedSemaphore :: Vk.Semaphore
-  , engineMesh                    :: Mesh
-  , engineExternalMesh            :: Mesh
   , engineAllocator               :: VMA.Allocator
   , engineDepthImageView          :: Vk.ImageView
   , engineDepthImage              :: AllocatedImage