fix multiple frames

src/CommandBuffer.hs

@@ -44,8 +44,9 @@ createCommandBuffer
   :: (MonadResource m)
   => Vk.Device
   -> Vk.CommandPool
+  -> Int
   -> m (V.Vector Vk.CommandBuffer)
-createCommandBuffer logicalDevice commandPool = do
+createCommandBuffer logicalDevice commandPool number = do
 
   let commandBufferAllocationInfo = Vk.zero
         { Vk.commandPool        = commandPool
@@ -53,7 +54,8 @@ createCommandBuffer logicalDevice commandPool = do
         , Vk.commandBufferCount = 1
         }
 
-  Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo
+  V.concat <$>
+    replicateM number (Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo)
 
 recordCommandBuffer
   :: (MonadResource m)

src/Devices.hs

@@ -179,6 +179,9 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do
   when (result /= Vk.SUCCESS) $
     error "getImageHandles: Failed acquiring images from swapchain"
 
+  liftIO $
+    putStrLn ("number of images: " <> show (V.length handles))
+
   V.mapM
     (\image -> do
       let createInfo = Vk.zero

src/Draw.hs

@@ -3,6 +3,7 @@
 module Draw where
 
 import Control.Monad
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource
 import qualified Data.Vector as V
 import Foreign.C.Types (CInt)
@@ -21,11 +22,11 @@ drawFrame
   => Vk.Device
   -> Khr.SwapchainKHR
   -> Vk.Queue
-  -> Vk.CommandBuffer
+  -> V.Vector Vk.CommandBuffer
   -> Vk.RenderPass
-  -> Vk.Framebuffer
+  -> V.Vector Vk.Framebuffer
   -> V2 CInt
-  -> Vk.Pipeline
+  -> V.Vector Vk.Pipeline
   -> Vk.Fence
   -> Vk.Semaphore
   -> Vk.Semaphore
@@ -34,16 +35,22 @@ drawFrame
   logicalDevice
   swapchain
   graphicsQueue
-  commandBuffer
+  commandBuffers
   renderPass
-  framebuffer
+  framebuffers
   dimensions
-  pipeline
+  pipelines
   inFlightFence
   imageAvailableSemaphore
   renderFinishedSemaphore
   = do
 
+    unless (all (V.length commandBuffers ==)
+      [V.length commandBuffers, V.length framebuffers, V.length pipelines]) $
+        error ("Numbers of elements mismatch: command buffers " <> show (V.length commandBuffers) <>
+          ", frame buffers " <> show (V.length framebuffers) <>
+          ", pipelines " <> show (V.length pipelines))
+
     let fences = V.singleton inFlightFence
 
     void $ Vk.waitForFences logicalDevice fences True maxBound
@@ -55,25 +62,34 @@ drawFrame
     unless (imageResult == Vk.SUCCESS) $
       error "drawFrame: Failed acquiring next image from swapchain"
 
-    Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0)
+    liftIO $ putStrLn "resetting command buffer"
+    Vk.resetCommandBuffer (commandBuffers V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
 
-    recordCommandBuffer commandBuffer renderPass framebuffer dimensions pipeline
+    liftIO $ putStrLn "recording command buffer"
+    recordCommandBuffer
+      (commandBuffers V.! fromIntegral index)
+      renderPass
+      (framebuffers V.! fromIntegral index)
+      dimensions
+      (pipelines V.! fromIntegral index)
 
     let submitInfo = Vk.zero
           { Vk.waitSemaphores = V.singleton imageAvailableSemaphore
           , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
-          , Vk.commandBuffers = V.singleton (Vk.commandBufferHandle commandBuffer)
+          , Vk.commandBuffers = V.singleton (Vk.commandBufferHandle $ commandBuffers V.! fromIntegral index)
           , Vk.signalSemaphores = V.singleton renderFinishedSemaphore
           }
 
+    liftIO $ putStrLn "submitting to queue"
     Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence
 
     let presentInfo = Vk.zero
           { Khr.waitSemaphores = V.singleton renderFinishedSemaphore
           , Khr.swapchains = V.singleton swapchain
-          , Khr.imageIndices = V.singleton 0
+          , Khr.imageIndices = V.singleton index
           }
 
+    liftIO $ putStrLn "presenting queue"
     presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo
 
     unless (presentResult == Vk.SUCCESS) $

src/Framebuffers.hs

@@ -17,21 +17,27 @@ createFramebuffer
   -> Vk.RenderPass
   -> V.Vector Vk.ImageView
   -> V2 CInt
-  -> m Vk.Framebuffer
+  -> m (V.Vector Vk.Framebuffer)
 createFramebuffer logicalDevice renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight)
   = do
 
     let framebufferCreateInfo = Vk.zero
           { Vk.renderPass = renderPass
-          , Vk.attachments = swapchainImageViews
           , Vk.width = fromIntegral swapchainWidth
           , Vk.height = fromIntegral swapcheinHeight
           , Vk.layers = 1
           }
 
-    snd <$> allocate
-      (Vk.createFramebuffer logicalDevice framebufferCreateInfo Nothing)
-      (\framebuffer -> do
-        putStrLn "destroying framebuffer"
-        Vk.destroyFramebuffer logicalDevice framebuffer Nothing
+    V.mapM
+      (\imageView -> do
+        let createInfo = framebufferCreateInfo
+              {  Vk.attachments = V.singleton imageView
+              } :: Vk.FramebufferCreateInfo '[]
+        snd <$> allocate
+          (Vk.createFramebuffer logicalDevice createInfo Nothing)
+          (\framebuffer -> do
+            putStrLn "destroying framebuffer"
+            Vk.destroyFramebuffer logicalDevice framebuffer Nothing
+            )
         )
+      swapchainImageViews

src/GraphicsPipeline.hs

@@ -57,6 +57,7 @@ createGraphicsPipelines
   -> BS.ByteString
   -> V2 CInt
   -> Vk.Format
+  -> Int
   -> m (V.Vector Vk.Pipeline, Vk.RenderPass)
 createGraphicsPipelines
   logicalDevice
@@ -65,6 +66,7 @@ createGraphicsPipelines
   stageName
   (V2 width height)
   swapchainImageFormat
+  number
   = do
 
     let vertexShaderStageCreateInfo = Vk.zero
@@ -185,7 +187,7 @@ createGraphicsPipelines
             Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
           }
         renderPassCreateInfo = Vk.zero
-          { Vk.attachments  = V.replicate 4 colorAttachmentDescription
+          { Vk.attachments  = V.singleton colorAttachmentDescription
           , Vk.subpasses    = V.singleton subpassDescriptor
           , Vk.dependencies = V.singleton subpassDependency
           } :: Vk.RenderPassCreateInfo '[]
@@ -219,7 +221,7 @@ createGraphicsPipelines
         (result, pipelines) <- Vk.createGraphicsPipelines
           logicalDevice
           Vk.NULL_HANDLE
-          (V.singleton (Vk.SomeStruct pipelineCreateInfo))
+          (V.replicate number (Vk.SomeStruct pipelineCreateInfo))
           Nothing
         unless (result == Vk.SUCCESS) $
           error "createGraphicsPiepelines: Failed creating pipelines"
@@ -233,5 +235,4 @@ createGraphicsPipelines
             )
           pipelines
         )
-
     return (pipelines, pipelineRenderPass)

src/Init.hs

@@ -33,7 +33,7 @@ initEngine
     , Khr.SwapchainKHR
     , Vk.Queue
     , V.Vector Vk.CommandBuffer
-    , Vk.Framebuffer
+    , V.Vector Vk.Framebuffer
     , V.Vector Vk.Pipeline
     , Vk.RenderPass
     , Vk.Fence
@@ -79,7 +79,7 @@ initVulkan
     , Khr.SwapchainKHR
     , Vk.Queue
     , V.Vector Vk.CommandBuffer
-    , Vk.Framebuffer
+    , V.Vector Vk.Framebuffer
     , V.Vector Vk.Pipeline
     , Vk.RenderPass
     , Vk.Fence
@@ -116,11 +116,12 @@ initVulkan window = do
       "main"
       dimensions
       (Khr.format surfaceFormat)
+      (length imageViews)
 
-  frameBuffer <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
+  frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
 
   (commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
-  commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool
+  commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool (length frameBuffers)
 
   (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
     createSyncObjects vulkanLogicalDevice
@@ -132,7 +133,7 @@ initVulkan window = do
     , swapchain
     , graphicsQueue
     , commandBuffer
-    , frameBuffer
+    , frameBuffers
     , pipelines
     , renderPass
     , inFlightFence

src/Main.hs

@@ -22,7 +22,7 @@ import Draw (drawFrame)
 
 main :: IO ()
 main = runResourceT $ do
-  (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffer, framebuffer, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
+  (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffers, framebuffers, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
 
   SDL.showWindow window
 
@@ -39,11 +39,11 @@ main = runResourceT $ do
         logicalDevice
         swapchain
         graphicsQueue
-        (V.head commandBuffer)
+        commandBuffers
         renderPass
-        framebuffer
+        framebuffers
         dimensions
-        (V.head pipelines)
+        pipelines
         inFlightFence
         imageAvailableSemaphore
         renderFinishedSemaphore