vulkan-tutorial/src/Main.hs

233 lines
6.9 KiB
Haskell
Raw Normal View History

2022-01-14 07:59:38 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
2022-01-18 05:25:58 +00:00
{-# LANGUAGE RecordWildCards #-}
2022-01-14 07:59:38 +00:00
module Main where
import Control.Monad
import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.ByteString as BS
import qualified Data.Vector as V
import Data.Word
2022-07-10 17:31:44 +00:00
import qualified SDL hiding (V2)
2022-01-14 07:59:38 +00:00
import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM
2022-07-10 17:31:44 +00:00
import Foreign.C.Types (CInt)
2022-01-14 07:59:38 +00:00
import Foreign.Ptr
2022-07-10 17:31:44 +00:00
import Linear
2022-01-14 07:59:38 +00:00
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
2022-07-10 17:31:44 +00:00
import qualified Vulkan.CStruct.Extends as Vk
2022-01-14 07:59:38 +00:00
myApiVersion :: Word32
2022-07-10 17:31:44 +00:00
myApiVersion = Vk.API_VERSION_1_3
2022-01-14 07:59:38 +00:00
main :: IO ()
main = runResourceT $ do
2022-07-10 17:31:44 +00:00
(window, inst, surface, swapchain, images) <- initEngine
2022-01-14 07:59:38 +00:00
SDL.showWindow window
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
-- main loop
liftIO $ whileM_
(STM.atomically $ STM.readTMVar quit
)
( do
-- poll events
evs <- SDL.pollEvents
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
void $ STM.atomically $ STM.swapTMVar quit False
_ -> return ()
)
evs
)
2022-07-10 17:31:44 +00:00
initEngine
:: MonadResource m
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image)
2022-01-14 07:59:38 +00:00
initEngine = do
-- initialize SDL2 with all subsystems
2022-07-10 18:08:12 +00:00
void $ allocate_
SDL.initializeAll
(do
print ("This is the end!" :: String)
SDL.quit
)
2022-01-14 07:59:38 +00:00
-- create a window configuration
let windowConfig = SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
}
-- load vulkan library
SDL.vkLoadLibrary Nothing
-- create the window
2022-07-10 17:31:44 +00:00
(_, window) <-
allocate
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
(\window -> do
liftIO $ print ("destroying window" :: String)
SDL.destroyWindow window
)
2022-01-14 07:59:38 +00:00
2022-07-10 17:31:44 +00:00
-- create vulkan surface and vulkan instance from window
(surface, inst, swapchain, images) <- initVulkan window
return (window, inst, surface, swapchain, images)
2022-01-14 07:59:38 +00:00
2022-07-10 17:31:44 +00:00
initVulkan
:: MonadResource m
=> SDL.Window
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image)
2022-01-14 07:59:38 +00:00
initVulkan window = do
vulkanInstance <- createInstance window
2022-01-18 05:25:58 +00:00
2022-07-10 17:31:44 +00:00
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
2022-01-17 20:52:39 +00:00
2022-07-10 17:31:44 +00:00
(_, vulkanSurface) <- allocate
(Vk.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
)
(\vulkanSurface -> do
print ("destroying Surface" :: String)
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
2022-01-18 05:25:58 +00:00
2022-07-10 17:31:44 +00:00
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice
images <- getImageHandles swapchain vulkanLogicalDevice
2022-01-14 07:59:38 +00:00
2022-07-10 17:31:44 +00:00
return (vulkanSurface, vulkanInstance, swapchain, images)
2022-01-14 07:59:38 +00:00
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
createInstance window = do
2022-07-10 17:31:44 +00:00
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
2022-01-14 07:59:38 +00:00
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
2022-07-10 17:31:44 +00:00
liftIO $ do
2022-07-10 18:08:12 +00:00
print ("activating followinfg extensions:" :: String)
2022-07-10 17:31:44 +00:00
print windowExtensions
2022-01-14 07:59:38 +00:00
let createInfo = Vk.zero
{ Vk.applicationInfo = Just Vk.zero
{ Vk.applicationName = Nothing
, Vk.apiVersion = myApiVersion
}
2022-07-10 17:31:44 +00:00
-- enable debug util extension for debugging purposes
, Vk.enabledExtensionNames = V.fromList windowExtensions
-- enable validation layer for debugging purposes
, Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation"
2022-01-14 07:59:38 +00:00
}
2022-01-18 05:25:58 +00:00
2022-07-10 17:31:44 +00:00
(_, inst) <- allocate
(Vk.createInstance createInfo Nothing)
2022-07-10 18:08:12 +00:00
(\inst -> do
print ("destroying instance" :: String)
Vk.destroyInstance inst Nothing
)
2022-01-18 05:25:58 +00:00
2022-07-10 17:31:44 +00:00
return inst
2022-01-18 05:25:58 +00:00
2022-07-10 17:31:44 +00:00
pickPhysicalDevice
:: (MonadResource m)
=> Vk.Instance
-> m Vk.PhysicalDevice
pickPhysicalDevice vkInstance = do
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
devicesWithProps <- V.mapM
(\device -> do
devProps <- Vk.getPhysicalDeviceProperties device
return (device, devProps)
)
physDevices
let discretePhysDevices = V.filter
(\(_, devProp) -> Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU)
devicesWithProps
maxMemdiscretePhysDevice = fst $ V.foldl
(\acc@(_, devProp1) ndev@(_, devProp2) ->
let dimension = Vk.maxImageDimension2D . Vk.limits
in
if dimension devProp1 < dimension devProp2
then ndev
else acc
)
(V.head discretePhysDevices)
discretePhysDevices
return maxMemdiscretePhysDevice
createLogicalDevice
:: (MonadResource m)
=> Vk.PhysicalDevice
-> m Vk.Device
createLogicalDevice physDevice = do
let priorities = V.singleton 1
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
queueCreateInfo = Vk.zero
{ Vk.queueFamilyIndex = 0
, Vk.queuePriorities = priorities
}
2022-01-18 05:25:58 +00:00
deviceCreateInfo = Vk.zero
2022-07-10 17:31:44 +00:00
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
, Vk.enabledExtensionNames = extensionNames
2022-01-18 05:25:58 +00:00
}
2022-07-10 17:31:44 +00:00
(_, logDevice) <- allocate
(Vk.createDevice physDevice deviceCreateInfo Nothing)
(\logDevice -> do
print ("destroying logical device" :: String)
Vk.destroyDevice logDevice Nothing
)
return logDevice
createSwapchain
:: (MonadResource m)
2022-01-18 05:25:58 +00:00
=> Vk.SurfaceKHR
2022-07-10 17:31:44 +00:00
-> V2 CInt
-> Vk.Device
-> m Vk.SwapchainKHR
createSwapchain surface windowDimension logicalDevice = do
let createInfo = Vk.zero
{ Vk.surface = surface
, Vk.minImageCount = 4
, Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB
, Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR
, Vk.imageExtent =
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
, Vk.imageArrayLayers = 1
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR
}
snd <$> allocate
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
2022-07-10 18:08:12 +00:00
(\swapchain -> do
print ("destroying Swapchain" :: String)
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
)
2022-07-10 17:31:44 +00:00
getImageHandles
:: (MonadResource m)
=> Vk.SwapchainKHR
-> Vk.Device
-> m (V.Vector Vk.Image)
getImageHandles swapchain logicalDevice = do
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
when (result /= Vk.SUCCESS) $
error "getImageHandles: Failed acquiring images from swapchain"
return handles