vulkan-tutorial/src/Devices.hs

140 lines
4.2 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Devices where
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import Linear
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
pickPhysicalDevice
:: (MonadResource m)
=> Vk.Instance
-> m Vk.PhysicalDevice
pickPhysicalDevice vkInstance = do
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
2022-07-11 03:21:57 +00:00
devicesWithPropsAndFeatures <- V.mapM
(\device -> do
devProps <- Vk.getPhysicalDeviceProperties device
2022-07-11 03:21:57 +00:00
devFeatures <- Vk.getPhysicalDeviceFeatures device
return (device, devProps, devFeatures)
)
physDevices
let discretePhysDevices = V.filter
2022-07-11 03:21:57 +00:00
(\(_, _, devFeatures) ->
-- Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
Vk.geometryShader devFeatures
)
devicesWithPropsAndFeatures
(maxMemdiscretePhysDevice, props,_ ) = V.foldl
2022-07-11 03:21:57 +00:00
(\acc@(_, devProp1, _) ndev@(_, devProp2, _) ->
let dimension = Vk.maxImageDimension2D . Vk.limits
in
if dimension devProp1 < dimension devProp2
then ndev
else acc
)
(V.head discretePhysDevices)
discretePhysDevices
liftIO $ do
print ("picked the following device:" :: String)
print (Vk.deviceName props)
return maxMemdiscretePhysDevice
createLogicalDevice
:: (MonadResource m)
=> Vk.PhysicalDevice
-> Vk.SurfaceKHR
-> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
createLogicalDevice physDevice surface = do
let priorities = V.singleton 1
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
queueCreateInfo = Vk.zero
{ Vk.queueFamilyIndex = 0
, Vk.queuePriorities = priorities
}
deviceCreateInfo = Vk.zero
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
, Vk.enabledExtensionNames = extensionNames
}
(_, logDevice) <- allocate
(Vk.createDevice physDevice deviceCreateInfo Nothing)
(\logDevice -> do
print ("destroying logical device" :: String)
Vk.destroyDevice logDevice Nothing
)
(result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface
unless (result == Vk.SUCCESS) $
error "Failed retrieving surface image formats"
return (logDevice, formats)
createSwapchain
:: (MonadResource m)
=> Vk.SurfaceKHR
-> V.Vector Vk.SurfaceFormatKHR
-> V2 CInt
-> Vk.Device
-> m Vk.SwapchainKHR
createSwapchain surface surfaceFormats windowDimension logicalDevice = do
liftIO $ do
print ("available formats:" :: String)
print surfaceFormats
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_OPAQUE_BIT_KHR
, Vk.clipped = True
}
snd <$> allocate
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
(\swapchain -> do
print ("destroying Swapchain" :: String)
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
)
getImageViewHandles
:: (MonadResource m)
=> Vk.SwapchainKHR
-> Vk.Device
-> m (V.Vector Vk.ImageView)
getImageViewHandles swapchain logicalDevice = do
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
when (result /= Vk.SUCCESS) $
error "getImageHandles: Failed acquiring images from swapchain"
imageViews <- V.mapM
(\image -> do
let createInfo = Vk.zero
{ Vk.image = image
, Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
}
return ()
)
V.empty
error "getImageHandles: Not yet implemented"