{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-} module Devices where import Control.Monad 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 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 } 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 ) return logDevice createSwapchain :: (MonadResource m) => Vk.SurfaceKHR -> 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) (\swapchain -> do print ("destroying Swapchain" :: String) Vk.destroySwapchainKHR logicalDevice swapchain Nothing ) 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