{-# 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 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 import Memory import Types import Mesh initEngine :: (MonadResource m, MonadFail m) => 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 ) -- initialize vúlkan data structures initVulkan window initVulkan :: (MonadResource m, MonadFail m) => SDL.Window -> m 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 allocator <- initAllocator vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance mesh <- uploadMesh loadMeshes allocator maskMesh <- loadFromObj "./assets/cat_mask_scaled.obj" allocator dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window (swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice 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" meshVertexShader <- loadShader vulkanLogicalDevice "shadersrc/mesh.vert" "vert" meshFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow.frag" "frag" renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat) pipelineLayout <- createPipelineLayout vulkanLogicalDevice meshLayout <- createMeshPipelineLayout vulkanLogicalDevice let redContainer = ShaderContainer (Just redVertexShader) (Just redFragmentShader) rainbowContainer = ShaderContainer (Just rainbowVertexShader) (Just rainbowFragmentShader) meshContainer = ShaderContainer (Just meshVertexShader) (Just meshFragmentShader) redPipelines <- createGraphicsPipelines vulkanLogicalDevice renderPass redContainer dimensions (length imageViews) pipelineLayout rainbowPipelines <- createGraphicsPipelines vulkanLogicalDevice renderPass rainbowContainer dimensions (length imageViews) pipelineLayout meshPipelines <- createGraphicsPipelines vulkanLogicalDevice renderPass meshContainer dimensions (length imageViews) meshLayout frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions (commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool (length frameBuffers) (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <- createSyncObjects vulkanLogicalDevice return $ EngineData window dimensions vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance swapchain graphicsQueue commandBuffer frameBuffers meshLayout redPipelines rainbowPipelines meshPipelines renderPass inFlightFence imageAvailableSemaphore renderFinishedSemaphore maskMesh maskMesh allocator