vulkan-tutorial/src/GraphicsPipeline.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module GraphicsPipeline 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.ByteString.Char8 as BS
import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk

-- internal imports
import Types
import qualified Vulkan as VK
import qualified Vulkan.CStruct.Extends as VK

loadShader
  :: (MonadResource m)
  => Vk.Device
  -> FilePath
  -> String
  -> m Vk.ShaderModule
loadShader logicalDevice shaderPath stage = do
  shaderSource <- liftIO $ BS.readFile shaderPath

  (warnings, eShader) <- Vk.compileShader Nothing Nothing stage (BS.unpack shaderSource)
  unless (null warnings) $ liftIO $ do
    putStrLn "loadShader: Shader compilation warnings:"
    print warnings
  shader <- either
    (\errors -> do
      error ("loadShader: Compilation errors:" <> "\n" <> show errors)
      )
    return
    eShader


  let createInfo = Vk.zero
        { Vk.code = shader
        }

  snd <$> allocate
    (Vk.createShaderModule logicalDevice createInfo Nothing)
    (\shaderModule -> do
      putStrLn "destroying shader module"
      Vk.destroyShaderModule logicalDevice shaderModule Nothing
      )

createRenderPass
  :: (MonadResource m)
  => Vk.Device
  -> Vk.Format
  -> m Vk.RenderPass
createRenderPass
  logicalDevice
  swapchainImageFormat
  = do



    let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription)
          { Vk.format         = swapchainImageFormat
          , Vk.samples        = Vk.SAMPLE_COUNT_1_BIT
          , Vk.loadOp         = Vk.ATTACHMENT_LOAD_OP_CLEAR
          , Vk.storeOp        = Vk.ATTACHMENT_STORE_OP_STORE
          , Vk.stencilLoadOp  = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
          , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
          , Vk.initialLayout  = Vk.IMAGE_LAYOUT_UNDEFINED
          , Vk.finalLayout    = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
          }
        colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference)
          { Vk.attachment = 0
          , Vk.layout     = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
          }
        subpassDescriptor = (Vk.zero :: Vk.SubpassDescription)
          { 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.dstStageMask  = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
          , Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
          , Vk.dstAccessMask =
            Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
          }
        renderPassCreateInfo = Vk.zero
          { Vk.attachments  = V.singleton colorAttachmentDescription
          , Vk.subpasses    = V.singleton subpassDescriptor
          , Vk.dependencies = V.singleton subpassDependency
          } :: Vk.RenderPassCreateInfo '[]

    snd <$> allocate
      (Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing)
      (\renderPass -> do
        putStrLn "destroying render pass"
        Vk.destroyRenderPass logicalDevice renderPass Nothing
        )

createShaderStageCreateInfo
  :: Vk.ShaderStageFlagBits
  -> Vk.ShaderModule
  -> Vk.PipelineShaderStageCreateInfo '[]
createShaderStageCreateInfo stageBit shaderModule =
  Vk.zero
    { Vk.stage   = stageBit
    , Vk.module' = shaderModule
    , Vk.name    = "main"
    }

createVertexInputAssemblyStateCreateInfo
  :: Vk.PrimitiveTopology
  -> Vk.PipelineInputAssemblyStateCreateInfo
createVertexInputAssemblyStateCreateInfo topology =
  Vk.zero
    { Vk.topology               = topology
    , Vk.primitiveRestartEnable = False
    }

createRasterizationStateCreateInfo
  :: Vk.PolygonMode
  -> VK.SomeStruct Vk.PipelineRasterizationStateCreateInfo
createRasterizationStateCreateInfo mode =
  Vk.SomeStruct $ Vk.zero
    { Vk.depthClampEnable        = False
    , Vk.rasterizerDiscardEnable = False
    , Vk.polygonMode             = mode
    , Vk.lineWidth               = 1
    , Vk.cullMode                = Vk.CULL_MODE_NONE
    , Vk.frontFace               = Vk.FRONT_FACE_CLOCKWISE
    , Vk.depthBiasEnable         = False
    , Vk.depthBiasConstantFactor = 0
    , Vk.depthBiasClamp          = 0
    , Vk.depthBiasSlopeFactor    = 0
    }

createMultisampleStateCreateInfo
  :: Vk.SomeStruct Vk.PipelineMultisampleStateCreateInfo
createMultisampleStateCreateInfo =
  Vk.SomeStruct $ Vk.zero
    { Vk.sampleShadingEnable  = False
    , Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT
    }

createGraphicsPipelines
  :: (MonadResource m)
  => Vk.Device
  -> Vk.RenderPass
  -> ShaderContainer
  -> V2 CInt
  -> Int
  -> Vk.PipelineLayout
  -> m (V.Vector Vk.Pipeline)
createGraphicsPipelines
  logicalDevice
  renderPass
  shaderContainer
  (V2 width height)
  number
  pipelineLayout
  = do
    let pipelineStagesCreateInfos =
          V.fromList $ map Vk.SomeStruct
            [ createShaderStageCreateInfo
              Vk.SHADER_STAGE_VERTEX_BIT
              (containedVertexShader shaderContainer)
            , createShaderStageCreateInfo
              Vk.SHADER_STAGE_FRAGMENT_BIT
              (containedFragmentShader shaderContainer)
            ]
        dynamicStates =
          V.fromList
            [ Vk.DYNAMIC_STATE_VIEWPORT
            , Vk.DYNAMIC_STATE_SCISSOR
            ]
        pipelineDynamicStateCreateInfo = Vk.zero
          { Vk.dynamicStates = dynamicStates
          }
        pipelineVertexInputCreateInfo = Vk.zero
          { Vk.vertexBindingDescriptions   = V.empty -- Fill me?
          , Vk.vertexAttributeDescriptions = V.empty -- Fill me?
          }
        viewport = Vk.Viewport
          { Vk.x        = 0
          , Vk.y        = 0
          , Vk.width    = fromIntegral width
          , Vk.height   = fromIntegral height
          , Vk.minDepth = 0
          , Vk.maxDepth = 1
          }
        scissor = Vk.Rect2D
          { Vk.offset = Vk.Offset2D 0 0
          , Vk.extent = Vk.Extent2D (fromIntegral width) (fromIntegral height)
          }
        pipelineViewportStateCreateInfo = Vk.zero
          { Vk.viewports = V.singleton viewport
          , Vk.scissors  = V.singleton scissor
          }
        colorBlendAttachment = Vk.zero
          { Vk.colorWriteMask      =
            Vk.COLOR_COMPONENT_R_BIT .|.
            Vk.COLOR_COMPONENT_G_BIT .|.
            Vk.COLOR_COMPONENT_B_BIT .|.
            Vk.COLOR_COMPONENT_A_BIT
          , Vk.blendEnable         = True
          , Vk.srcColorBlendFactor = Vk.BLEND_FACTOR_ONE
          , Vk.dstColorBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA
          , Vk.colorBlendOp        = Vk.BLEND_OP_ADD
          , Vk.srcAlphaBlendFactor = Vk.BLEND_FACTOR_ONE
          , Vk.dstAlphaBlendFactor = Vk.BLEND_FACTOR_ZERO
          , Vk.alphaBlendOp        = Vk.BLEND_OP_ADD
          }
        pipelineColorBlendStateCreateInfo = Vk.zero
          { Vk.logicOpEnable = False
          , Vk.attachments = V.singleton colorBlendAttachment
          }
        pipelineCreateInfo = Vk.zero
          { Vk.stageCount         = 2
          , Vk.stages             = pipelineStagesCreateInfos
          , Vk.vertexInputState   = Just $ Vk.SomeStruct pipelineVertexInputCreateInfo
          , Vk.inputAssemblyState =
            Just $ createVertexInputAssemblyStateCreateInfo VK.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST
          , Vk.viewportState      = Just $ Vk.SomeStruct pipelineViewportStateCreateInfo
          , Vk.rasterizationState = Just $ createRasterizationStateCreateInfo Vk.POLYGON_MODE_FILL
          , Vk.multisampleState   = Just $ createMultisampleStateCreateInfo
          , Vk.colorBlendState    = Just $ Vk.SomeStruct pipelineColorBlendStateCreateInfo
          , Vk.dynamicState       = Just pipelineDynamicStateCreateInfo
          , Vk.layout             = pipelineLayout
          , Vk.renderPass         = renderPass
          , Vk.subpass            = 0
          , Vk.basePipelineHandle = Vk.NULL_HANDLE
          , Vk.basePipelineIndex  = -1
          }

    snd <$> allocate
      (do
        (result, pipelines) <- Vk.createGraphicsPipelines
          logicalDevice
          Vk.NULL_HANDLE
          (V.replicate number (Vk.SomeStruct pipelineCreateInfo))
          Nothing
        unless (result == Vk.SUCCESS) $
          error "createGraphicsPiepelines: Failed creating pipelines"
        return pipelines
        )
      (\pipelines -> do
        V.mapM_
          (\pipeline -> do
            putStrLn "destroying pipeline"
            Vk.destroyPipeline logicalDevice pipeline Nothing
            )
          pipelines
        )

createPipelineLayout
  :: MonadResource m
  => Vk.Device
  -> m Vk.PipelineLayout
createPipelineLayout logicalDevice = do
  let pipelineLayoutCreateInfo = Vk.zero

  snd <$> allocate
    (Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing)
    (\pipelineLayout -> do
      putStrLn "destroying pipeline layout"
      Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing
      )