vulkan-tutorial/src/Init.hs

155 lines
4.6 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Init where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL
import Foreign.Ptr
2022-07-14 05:02:10 +00:00
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
2022-07-14 05:02:10 +00:00
import GraphicsPipeline
import Framebuffers
import CommandBuffer
2022-12-01 12:17:13 +00:00
import Memory
2022-07-16 19:50:22 +00:00
import Types
2022-12-01 12:17:13 +00:00
import Mesh
initEngine
2022-07-14 05:02:10 +00:00
:: (MonadResource m, MonadFail m)
2022-07-16 19:50:22 +00:00
=> m EngineData
initEngine = do
-- initialize SDL2 with all subsystems
void $ allocate_
SDL.initializeAll
(do
putStrLn "This is the end!"
SDL.quit
)
-- create a window configuration
let windowConfig = SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
}
-- load vulkan library
SDL.vkLoadLibrary Nothing
-- create the window
(_, window) <-
allocate
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
(\window -> do
liftIO $ putStrLn "destroying window"
SDL.destroyWindow window
)
2022-12-02 15:58:43 +00:00
-- initialize vúlkan data structures
2022-07-14 05:02:10 +00:00
initVulkan window
2022-12-01 12:17:13 +00:00
initVulkan
2022-07-14 05:02:10 +00:00
:: (MonadResource m, MonadFail m)
=> SDL.Window
2022-07-16 19:50:22 +00:00
-> m EngineData
initVulkan window = do
vulkanInstance <- createInstance window
(_, vulkanSurface) <- allocate
2022-07-14 05:02:10 +00:00
(Khr.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
)
(\vulkanSurface -> do
putStrLn "destroying surface"
2022-07-14 05:02:10 +00:00
Khr.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
2022-12-01 12:17:13 +00:00
allocator <- initAllocator vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance
mesh <- uploadMesh loadMeshes allocator
2022-12-17 06:39:45 +00:00
maskMesh <- loadFromObj "./assets/cat_mask_scaled.obj" allocator
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
2022-07-14 05:02:10 +00:00
(swapchain, surfaceFormat) <-
createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
2022-07-11 12:01:04 +00:00
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
2022-10-26 14:52:55 +00:00
redVertexShader <- loadShader vulkanLogicalDevice "shadersrc/red.vert" "vert"
redFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/red.frag" "frag"
rainbowVertexShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow.vert" "vert"
rainbowFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow.frag" "frag"
2022-12-02 19:34:35 +00:00
meshVertexShader <- loadShader vulkanLogicalDevice "shadersrc/mesh.vert" "vert"
2022-12-03 07:42:00 +00:00
meshFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow.frag" "frag"
2022-07-16 19:50:22 +00:00
renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat)
pipelineLayout <- createPipelineLayout vulkanLogicalDevice
2022-12-11 08:02:17 +00:00
meshLayout <- createMeshPipelineLayout vulkanLogicalDevice
2022-12-02 19:02:01 +00:00
let redContainer = ShaderContainer (Just redVertexShader) (Just redFragmentShader)
2022-12-02 19:34:35 +00:00
rainbowContainer = ShaderContainer (Just rainbowVertexShader) (Just rainbowFragmentShader)
2022-12-03 07:42:00 +00:00
meshContainer = ShaderContainer (Just meshVertexShader) (Just meshFragmentShader)
2022-10-26 14:52:55 +00:00
redPipelines <-
2022-07-14 05:02:10 +00:00
createGraphicsPipelines
vulkanLogicalDevice
2022-07-16 19:50:22 +00:00
renderPass
2022-10-26 14:52:55 +00:00
redContainer
dimensions
(length imageViews)
pipelineLayout
rainbowPipelines <-
createGraphicsPipelines
vulkanLogicalDevice
renderPass
rainbowContainer
2022-07-14 05:02:10 +00:00
dimensions
2022-07-16 14:36:51 +00:00
(length imageViews)
2022-07-16 19:50:22 +00:00
pipelineLayout
2022-12-02 19:34:35 +00:00
meshPipelines <-
createGraphicsPipelines
vulkanLogicalDevice
renderPass
meshContainer
dimensions
(length imageViews)
2022-12-11 08:02:17 +00:00
meshLayout
2022-07-16 14:36:51 +00:00
frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
2022-07-14 05:02:10 +00:00
(commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
2022-07-16 14:36:51 +00:00
commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool (length frameBuffers)
2022-07-14 05:02:10 +00:00
(imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
createSyncObjects vulkanLogicalDevice
2022-07-16 19:50:22 +00:00
return $ EngineData
window
dimensions
2022-12-03 00:44:06 +00:00
vulkanPhysicalDevice
2022-07-16 19:50:22 +00:00
vulkanLogicalDevice
2022-12-03 00:44:06 +00:00
vulkanInstance
2022-07-16 19:50:22 +00:00
swapchain
graphicsQueue
commandBuffer
frameBuffers
2022-12-11 08:02:17 +00:00
meshLayout
2022-10-26 14:52:55 +00:00
redPipelines
rainbowPipelines
2022-12-02 19:34:35 +00:00
meshPipelines
2022-07-16 19:50:22 +00:00
renderPass
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
2022-12-17 06:39:45 +00:00
maskMesh
maskMesh
2022-12-03 00:44:06 +00:00
allocator