almost drawing, just fix shaders

src/CommandBuffer.hs

@@ -19,7 +19,7 @@ createCommandPool
   :: (MonadResource m)
   => Vk.PhysicalDevice
   -> Vk.Device
-  -> m Vk.CommandPool
+  -> m (Vk.CommandPool, Vk.Queue)
 createCommandPool physicalDevice logicalDevice = do
 
   queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
@@ -29,19 +29,23 @@ createCommandPool physicalDevice logicalDevice = do
         , Vk.queueFamilyIndex = queueFamilyIndex
         } :: Vk.CommandPoolCreateInfo
 
-  snd <$> allocate
+  graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0
+
+  commandPool <- snd <$> allocate
     (Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
     (\commandPool -> do
       putStrLn "destroying comman pool"
       Vk.destroyCommandPool logicalDevice commandPool Nothing
       )
 
+  return (commandPool, graphicsQueue)
+
 createCommandBuffer
   :: (MonadResource m)
-  => Vk.CommandPool
+  => Vk.Device
-  -> Vk.Device
+  -> Vk.CommandPool
   -> m (V.Vector Vk.CommandBuffer)
-createCommandBuffer commandPool logicalDevice = do
+createCommandBuffer logicalDevice commandPool = do
 
   let commandBufferAllocationInfo = Vk.zero
         { Vk.commandPool        = commandPool
@@ -123,6 +127,8 @@ createSyncObjects logicalDevice = do
 
   let semaphoreCreateInfo = Vk.zero
       fenceCreateInfo = Vk.zero
+        { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT
+        } :: Vk.FenceCreateInfo '[]
 
   [imageAvailableSemaphore, renderFinishedSemaphore] <- replicateM 2
     (snd <$> allocate
@@ -134,4 +140,4 @@ createSyncObjects logicalDevice = do
       )
   inFlightFence <- Vk.createFence logicalDevice fenceCreateInfo Nothing
 
-  return (imageAvailableSemaphore, renderFinishedSemaphore,inFlightFence)
+  return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence)

src/Draw.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+module Draw where
+
+import Control.Monad
+import Control.Monad.Trans.Resource
+import qualified Data.Vector as V
+import qualified Vulkan.Core10 as Vk
+import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
+import qualified Vulkan.CStruct.Extends as Vk
+import qualified Vulkan.Zero as Vk
+
+
+drawFrame
+  :: (MonadResource m)
+  => Vk.Device
+  -> Khr.SwapchainKHR
+  -> Vk.Queue
+  -> Vk.CommandBuffer
+  -> Vk.Fence
+  -> Vk.Semaphore
+  -> Vk.Semaphore
+  -> m ()
+drawFrame
+  logicalDevice
+  swapchain
+  graphicsQueue
+  commandBuffer
+  inFlightFence
+  imageAvailableSemaphore
+  renderFinishedSemaphore
+  = do
+
+    let fences = V.singleton inFlightFence
+
+    void $ Vk.waitForFences logicalDevice fences True maxBound
+    Vk.resetFences logicalDevice fences
+
+    (imageResult, index) <-
+      Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore inFlightFence
+
+    unless (imageResult == Vk.SUCCESS) $
+      error "drawFrame: Failed acquiring next image from swapchain"
+
+    Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0)
+
+    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.signalSemaphores = V.singleton renderFinishedSemaphore
+          }
+
+    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 index
+          }
+
+    presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo
+
+    unless (presentResult == Vk.SUCCESS) $
+      error "drawFrame: presentation failed"

src/Framebuffers.hs

@@ -4,26 +4,21 @@
 module Framebuffers where
 
 import Linear
-import Control.Monad (unless)
-import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource
-import Data.Bits
-import qualified Data.ByteString as BS
 import qualified Data.Vector as V
 import Foreign.C.Types (CInt)
 import qualified Vulkan as Vk
 import qualified Vulkan.Zero as Vk
-import qualified Vulkan.CStruct.Extends as Vk
 
 
 createFramebuffer
   :: (MonadResource m)
-  => Vk.RenderPass
+  => Vk.Device
+  -> Vk.RenderPass
   -> V.Vector Vk.ImageView
   -> V2 CInt
-  -> Vk.Device
   -> m Vk.Framebuffer
-createFramebuffer renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight) logicalDevice
+createFramebuffer logicalDevice renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight)
   = do
 
     let framebufferCreateInfo = Vk.zero

src/GraphicsPipeline.hs

@@ -11,7 +11,7 @@ import Data.Bits
 import qualified Data.ByteString as BS
 import qualified Data.Vector as V
 import Foreign.C.Types (CInt)
-import qualified Vulkan as Vk
+import qualified Vulkan.Core10 as Vk
 import qualified Vulkan.Zero as Vk
 import qualified Vulkan.CStruct.Extends as Vk
 
@@ -36,20 +36,20 @@ loadShader logicalDevice shaderPath = do
 
 createGraphicsPipelines
   :: (MonadResource m)
-  => Vk.ShaderModule
+  => Vk.Device
+  -> Vk.ShaderModule
   -> Vk.ShaderModule
   -> BS.ByteString
   -> V2 CInt
   -> Vk.Format
-  -> Vk.Device
+  -> m (V.Vector Vk.Pipeline, Vk.RenderPass)
-  -> m (V.Vector Vk.Pipeline)
 createGraphicsPipelines
+  logicalDevice
   vertexShaderModule
   fragmentShaderModule
   stageName
   (V2 width height)
   swapchainImageFormat
-  logicalDevice
   = do
 
     let vertexShaderStageCreateInfo = Vk.zero
@@ -160,10 +160,16 @@ createGraphicsPipelines
           { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
           , Vk.colorAttachments = V.singleton colorAttachmentReference
           }
+        subpassDependency = Vk.zero
+          { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
+          , Vk.dstSubpass = 0
+          , Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
+          , Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
+          }
         renderPassCreateInfo = Vk.zero
           { Vk.attachments  = V.singleton colorAttachmentDescription
           , Vk.subpasses    = V.singleton subpassDescriptor
-          , Vk.dependencies = V.empty
+          , Vk.dependencies = V.singleton subpassDependency
           } :: Vk.RenderPassCreateInfo '[]
 
     pipelineRenderPass <- snd <$> allocate
@@ -190,7 +196,7 @@ createGraphicsPipelines
           , Vk.basePipelineIndex  = -1
           }
 
-    snd <$> allocate
+    pipelines <- snd <$> allocate
       (do
         (result, pipelines) <- Vk.createGraphicsPipelines
           logicalDevice
@@ -209,3 +215,5 @@ createGraphicsPipelines
             )
           pipelines
         )
+
+    return (pipelines, pipelineRenderPass)

src/Init.hs

@@ -10,16 +10,30 @@ import qualified Data.Vector as V
 import qualified SDL hiding (V2)
 import qualified SDL.Video.Vulkan as SDL
 import Foreign.Ptr
-import qualified Vulkan as Vk
+import qualified Vulkan.Core10 as Vk
+import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
+import qualified Vulkan.Extensions.VK_KHR_surface as Khr
 
 -- internal imports
 
 import Instance
 import Devices
+import GraphicsPipeline
+import Framebuffers
+import CommandBuffer
 
 initEngine
-  :: MonadResource m
+  :: (MonadResource m, MonadFail m)
-  => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.ImageView)
+  => m
+    ( SDL.Window
+    , Vk.Device
+    , Khr.SwapchainKHR
+    , Vk.Queue
+    , V.Vector Vk.CommandBuffer
+    , Vk.Fence
+    , Vk.Semaphore
+    , Vk.Semaphore
+    )
 initEngine = do
   -- initialize SDL2 with all subsystems
   void $ allocate_
@@ -46,32 +60,68 @@ initEngine = do
         SDL.destroyWindow window
         )
 
-  -- create vulkan surface and vulkan instance from window
+  -- initialize viúlkan data structures
-  (surface, inst, swapchain, images) <- initVulkan window
+  initVulkan window
-  return (window, inst, surface, swapchain, images)
 
 initVulkan
-  :: MonadResource m
+  :: (MonadResource m, MonadFail m)
   => SDL.Window
-  -> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.ImageView)
+  -> m
+    ( SDL.Window
+    , Vk.Device
+    , Khr.SwapchainKHR
+    , Vk.Queue
+    , V.Vector Vk.CommandBuffer
+    , Vk.Fence
+    , Vk.Semaphore
+    , Vk.Semaphore
+    )
 initVulkan window = do
 
   vulkanInstance <- createInstance window
 
   (_, vulkanSurface) <- allocate
-    (Vk.SurfaceKHR <$>
+    (Khr.SurfaceKHR <$>
       SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
       )
     (\vulkanSurface -> do
       putStrLn "destroying surface"
-      Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
+      Khr.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
       )
 
   vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
   (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
 
   dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
-  (swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
+  (swapchain, surfaceFormat) <-
+    createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
   imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
+  vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert"
+  fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag"
+  (pipelines, renderPass) <-
+    createGraphicsPipelines
+      vulkanLogicalDevice
+      vertexShader
+      fragmentShader
+      "main"
+      dimensions
+      (Khr.format surfaceFormat)
 
-  return (vulkanSurface, vulkanInstance, swapchain, imageViews)
+  frameBuffer <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
+
+  (commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
+  commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool
+
+  (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
+    createSyncObjects vulkanLogicalDevice
+
+  return
+    ( window
+    , vulkanLogicalDevice
+    , swapchain
+    , graphicsQueue
+    , commandBuffer
+    , inFlightFence
+    , imageAvailableSemaphore
+    , renderFinishedSemaphore
+    )

src/Main.hs

@@ -8,6 +8,7 @@ import Control.Monad.Loops
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Resource
 import Data.Bits
+import qualified Data.Vector as V
 import Data.Word
 import qualified SDL hiding (V2)
 import qualified Control.Concurrent.STM as STM
@@ -17,10 +18,11 @@ import qualified Vulkan.Zero as Vk
 -- internal imports
 
 import Init
+import Draw (drawFrame)
 
 main :: IO ()
 main = runResourceT $ do
-  (window, inst, surface, swapchain, images) <- initEngine
+  (window, logicalDevice, swapchain, graphicsQueue, commandBuffer, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
 
   SDL.showWindow window
 
@@ -28,17 +30,26 @@ main = runResourceT $ do
   quit <- liftIO $ STM.newTMVarIO True
 
   -- main loop
-  liftIO $ whileM_
+  whileM_
-    (STM.atomically $ STM.readTMVar quit
+    (liftIO $ STM.atomically $ STM.readTMVar quit
       )
     ( do
+      -- draw
+      drawFrame
+        logicalDevice
+        swapchain
+        graphicsQueue
+        (V.head commandBuffer)
+        inFlightFence
+        imageAvailableSemaphore
+        renderFinishedSemaphore
       -- poll events
-      evs <- SDL.pollEvents
+      evs <- liftIO SDL.pollEvents
       -- flip abort condition on window close
       mapM_
         (\e -> case SDL.eventPayload e of
           SDL.WindowClosedEvent _ ->
-            void $ STM.atomically $ STM.swapTMVar quit False
+            void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
           _ -> return ()
           )
         evs

vulkan-tutorial.cabal

@@ -30,6 +30,7 @@ executable vulkan-tutorial
                       GraphicsPipeline
                       Framebuffers
                       CommandBuffer
+                      Draw
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions: