trying to make implementation a little more flexible

This commit is contained in:
nek0 2022-07-11 13:14:59 +02:00
parent 836012beea
commit 1ad7f8fbb4
2 changed files with 45 additions and 17 deletions

View file

@ -4,6 +4,7 @@
module Devices where module Devices where
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import qualified Data.Vector as V import qualified Data.Vector as V
import Foreign.C.Types (CInt) import Foreign.C.Types (CInt)
@ -33,7 +34,7 @@ pickPhysicalDevice vkInstance = do
Vk.geometryShader devFeatures Vk.geometryShader devFeatures
) )
devicesWithPropsAndFeatures devicesWithPropsAndFeatures
maxMemdiscretePhysDevice = (\(x, _, _) -> x) $ V.foldl (maxMemdiscretePhysDevice, props,_ ) = V.foldl
(\acc@(_, devProp1, _) ndev@(_, devProp2, _) -> (\acc@(_, devProp1, _) ndev@(_, devProp2, _) ->
let dimension = Vk.maxImageDimension2D . Vk.limits let dimension = Vk.maxImageDimension2D . Vk.limits
in in
@ -44,13 +45,18 @@ pickPhysicalDevice vkInstance = do
(V.head discretePhysDevices) (V.head discretePhysDevices)
discretePhysDevices discretePhysDevices
liftIO $ do
print ("picked the following device:" :: String)
print (Vk.deviceName props)
return maxMemdiscretePhysDevice return maxMemdiscretePhysDevice
createLogicalDevice createLogicalDevice
:: (MonadResource m) :: (MonadResource m)
=> Vk.PhysicalDevice => Vk.PhysicalDevice
-> m Vk.Device -> Vk.SurfaceKHR
createLogicalDevice physDevice = do -> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
createLogicalDevice physDevice surface = do
let priorities = V.singleton 1 let priorities = V.singleton 1
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
queueCreateInfo = Vk.zero queueCreateInfo = Vk.zero
@ -69,15 +75,25 @@ createLogicalDevice physDevice = do
Vk.destroyDevice logDevice Nothing Vk.destroyDevice logDevice Nothing
) )
return logDevice (result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface
unless (result == Vk.SUCCESS) $
error "Failed retrieving surface image formats"
return (logDevice, formats)
createSwapchain createSwapchain
:: (MonadResource m) :: (MonadResource m)
=> Vk.SurfaceKHR => Vk.SurfaceKHR
-> V.Vector Vk.SurfaceFormatKHR
-> V2 CInt -> V2 CInt
-> Vk.Device -> Vk.Device
-> m Vk.SwapchainKHR -> m Vk.SwapchainKHR
createSwapchain surface windowDimension logicalDevice = do createSwapchain surface surfaceFormats windowDimension logicalDevice = do
liftIO $ do
print ("available formats:" :: String)
print surfaceFormats
let createInfo = Vk.zero let createInfo = Vk.zero
{ Vk.surface = surface { Vk.surface = surface
, Vk.minImageCount = 4 , Vk.minImageCount = 4
@ -89,7 +105,8 @@ createSwapchain surface windowDimension logicalDevice = do
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT , Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR , Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR , Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR , Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
, Vk.clipped = True
} }
snd <$> allocate snd <$> allocate
@ -99,13 +116,24 @@ createSwapchain surface windowDimension logicalDevice = do
Vk.destroySwapchainKHR logicalDevice swapchain Nothing Vk.destroySwapchainKHR logicalDevice swapchain Nothing
) )
getImageHandles getImageViewHandles
:: (MonadResource m) :: (MonadResource m)
=> Vk.SwapchainKHR => Vk.SwapchainKHR
-> Vk.Device -> Vk.Device
-> m (V.Vector Vk.Image) -> m (V.Vector Vk.ImageView)
getImageHandles swapchain logicalDevice = do getImageViewHandles swapchain logicalDevice = do
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain (result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
when (result /= Vk.SUCCESS) $ when (result /= Vk.SUCCESS) $
error "getImageHandles: Failed acquiring images from swapchain" error "getImageHandles: Failed acquiring images from swapchain"
return handles
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"

View file

@ -28,7 +28,7 @@ import Devices
initEngine initEngine
:: MonadResource m :: MonadResource m
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image) => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.ImageView)
initEngine = do initEngine = do
-- initialize SDL2 with all subsystems -- initialize SDL2 with all subsystems
void $ allocate_ void $ allocate_
@ -62,14 +62,11 @@ initEngine = do
initVulkan initVulkan
:: MonadResource m :: MonadResource m
=> SDL.Window => SDL.Window
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image) -> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.ImageView)
initVulkan window = do initVulkan window = do
vulkanInstance <- createInstance window vulkanInstance <- createInstance window
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
(_, vulkanSurface) <- allocate (_, vulkanSurface) <- allocate
(Vk.SurfaceKHR <$> (Vk.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
@ -79,8 +76,11 @@ initVulkan window = do
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
) )
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice swapchain <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
images <- getImageHandles swapchain vulkanLogicalDevice images <- getImageViewHandles swapchain vulkanLogicalDevice
return (vulkanSurface, vulkanInstance, swapchain, images) return (vulkanSurface, vulkanInstance, swapchain, images)