vulkan-tutorial/src/Init.hs
2023-01-16 01:10:23 +01:00

213 lines
6.4 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Init where
import qualified Control.Concurrent.STM as STM
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bits (Bits(bit))
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
import qualified Vulkan.Zero as Vk
import qualified VulkanMemoryAllocator as VMA
-- internal imports
import Instance
import Devices
import GraphicsPipeline
import Framebuffers
import Memory
import Types
import Mesh
import CommandBuffer
initEngine
:: Render EngineData
initEngine = do
-- initialize SDL2 with all subsystems
void $ allocate_
(SDL.initialize [ SDL.InitVideo ])
(do
putStrLn "This is the end!"
SDL.quit
)
-- create a window configuration
let windowConfig = SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
, SDL.windowInitialSize = V2 1280 1024
}
-- load vulkan library
SDL.vkLoadLibrary Nothing
-- create the window
(_, window) <-
allocate
(do
eexcept <- try (SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
case eexcept of
Left err -> error $ "here's your exception: " <> show (err :: SDL.SDLException)
Right a -> return a
)
(\window -> do
liftIO $ putStrLn "destroying window"
SDL.destroyWindow window
)
-- initialize vúlkan data structures
initVulkan window
initVulkan
:: SDL.Window
-> Render EngineData
initVulkan window = do
vulkanInstance <- createInstance window
(_, vulkanSurface) <- allocate
(Khr.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
)
(\vulkanSurface -> do
putStrLn "destroying surface"
Khr.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
(descriptorSetLayout, descriptorPool) <- initDescriptors vulkanLogicalDevice
allocator <- initAllocator vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
(swapchain, surfaceFormat, depthImageView, depthAllocatedImage) <-
createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice allocator
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
meshVertexShader <- loadShader vulkanLogicalDevice "shadersrc/mesh.vert" "vert"
meshFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow.frag" "frag"
renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat) Vk.FORMAT_D32_SFLOAT
meshLayout <- createMeshPipelineLayout vulkanLogicalDevice descriptorSetLayout
let meshContainer = ShaderContainer (Just meshVertexShader) (Just meshFragmentShader)
createGraphicsPipelines
vulkanLogicalDevice
renderPass
meshContainer
dimensions
meshLayout
(Just (createDepthStencilStateCreateInfo True True Vk.COMPARE_OP_LESS_OR_EQUAL))
frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews depthImageView dimensions
(frames, queue) <- createFrames vulkanPhysicalDevice vulkanLogicalDevice allocator descriptorPool descriptorSetLayout
loadMeshes allocator
initScene
return $ EngineData
window
dimensions
vulkanPhysicalDevice
vulkanLogicalDevice
vulkanInstance
swapchain
queue
frameBuffers
meshLayout
renderPass
allocator
depthImageView
depthAllocatedImage
Vk.FORMAT_D32_SFLOAT
frames
descriptorSetLayout
descriptorPool
initScene :: (MonadReader ReadState m, MonadIO m) => m ()
initScene = do
let mask = RenderObject
{ objectMesh = "mask"
, objectMaterial = "defaultMesh"
, objectMatrix = identity
}
triangles = V.concatMap
(\y ->
V.map
(\x ->
let
translationMatrix = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 x 0 y)
scaleMatrix = scaled (V4 0.2 0.2 0.2 1)
in
RenderObject
{ objectMesh = "triangle"
, objectMaterial = "defaultMesh"
, objectMatrix = translationMatrix !*! scaleMatrix
}
)
(V.fromList [-20 .. 20])
)
(V.fromList [-20 .. 20])
renderableContainer <- asks renderables
renderableVector <- liftIO $ STM.atomically $ STM.readTMVar renderableContainer
void $ liftIO $ STM.atomically $ STM.swapTMVar renderableContainer $
(renderableVector `V.snoc` mask) V.++ triangles
initDescriptors
:: (MonadResource m)
=> Vk.Device
-> m (Vk.DescriptorSetLayout, Vk.DescriptorPool)
initDescriptors device = do
let cameraBufferBinding = Vk.zero
{ Vk.binding = 0
, Vk.descriptorCount = 1
, Vk.descriptorType = Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
, Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT
}
setInfo = Vk.zero
{ Vk.flags = Vk.DESCRIPTOR_SET_LAYOUT_CREATE_UPDATE_AFTER_BIND_POOL_BIT
, Vk.bindings = V.singleton cameraBufferBinding
}
poolInfo = Vk.zero
{ Vk.flags = Vk.DESCRIPTOR_POOL_CREATE_UPDATE_AFTER_BIND_BIT
, Vk.maxSets = 10
, Vk.poolSizes = V.singleton
( Vk.zero
{ Vk.type' = Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
, Vk.descriptorCount = 1
}
)
}
(_, descriptorSetLayout) <- allocate
(Vk.createDescriptorSetLayout device setInfo Nothing)
(\descriptorLayout -> do
putStrLn "destroying descriptor layout"
Vk.destroyDescriptorSetLayout device descriptorLayout Nothing
)
(_, descriptorPool) <- allocate
(Vk.createDescriptorPool device poolInfo Nothing)
(\descriptorPoolInfo -> do
putStrLn "destroying descriptor pool"
Vk.destroyDescriptorPool device descriptorPoolInfo Nothing
)
return (descriptorSetLayout, descriptorPool)