diff --git a/src/Devices.hs b/src/Devices.hs index 4ee20aa..e4be9b6 100644 --- a/src/Devices.hs +++ b/src/Devices.hs @@ -87,53 +87,91 @@ createSwapchain -> V.Vector Vk.SurfaceFormatKHR -> V2 CInt -> Vk.Device - -> m Vk.SwapchainKHR + -> m (Vk.SwapchainKHR, Vk.SurfaceFormatKHR) createSwapchain surface surfaceFormats windowDimension logicalDevice = do liftIO $ do print ("available formats:" :: String) print surfaceFormats + (surfaceFormat, colorSpace) <- + if + V.any + (\a -> + (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) a == + Vk.FORMAT_B8G8R8A8_SRGB + && (Vk.colorSpace :: Vk.SurfaceFormatKHR -> Vk.ColorSpaceKHR) a == + Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR) + surfaceFormats + then + return (Vk.FORMAT_B8G8R8A8_SRGB, Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR) + else + error ("createSwapchain: No suitable surface formats available" :: String) + + liftIO $ do + print ("picking following format and color space:" :: String) + print (surfaceFormat, colorSpace) + 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 = + { Vk.surface = surface + , Vk.minImageCount = 4 + , Vk.imageFormat = surfaceFormat + , Vk.imageColorSpace = colorSpace + , 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 + , 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 + swapchain <- snd <$> allocate (Vk.createSwapchainKHR logicalDevice createInfo Nothing) (\swapchain -> do - print ("destroying Swapchain" :: String) + print ("destroying swapchain" :: String) Vk.destroySwapchainKHR logicalDevice swapchain Nothing ) + return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace) + getImageViewHandles :: (MonadResource m) => Vk.SwapchainKHR + -> Vk.SurfaceFormatKHR -> Vk.Device -> m (V.Vector Vk.ImageView) -getImageViewHandles swapchain logicalDevice = do +getImageViewHandles swapchain surfaceFormat logicalDevice = do (result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain when (result /= Vk.SUCCESS) $ error "getImageHandles: Failed acquiring images from swapchain" - imageViews <- V.mapM + V.mapM (\image -> do let createInfo = Vk.zero - { Vk.image = image - , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + { Vk.image = image + , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + , Vk.format = (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) surfaceFormat + , Vk.components = Vk.ComponentMapping + { Vk.r = Vk.COMPONENT_SWIZZLE_IDENTITY + , Vk.g = Vk.COMPONENT_SWIZZLE_IDENTITY + , Vk.b = Vk.COMPONENT_SWIZZLE_IDENTITY + , Vk.a = Vk.COMPONENT_SWIZZLE_IDENTITY + } + , Vk.subresourceRange = Vk.ImageSubresourceRange + { aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , baseMipLevel = 0 + , levelCount = 1 + , baseArrayLayer = 0 + , layerCount = 1 + } } - return () + snd <$> allocate + (Vk.createImageView logicalDevice createInfo Nothing) + (\imageView -> do + print ("destrying image view" :: String) + Vk.destroyImageView logicalDevice imageView Nothing + ) ) - V.empty - - error "getImageHandles: Not yet implemented" + handles diff --git a/src/Init.hs b/src/Init.hs index f0aa3a7..2ae5f27 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -4,22 +4,13 @@ module Init where import Control.Monad -import Control.Monad.Loops import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import Data.Bits -import qualified Data.ByteString as BS import qualified Data.Vector as V -import Data.Word import qualified SDL hiding (V2) import qualified SDL.Video.Vulkan as SDL -import qualified Control.Concurrent.STM as STM -import Foreign.C.Types (CInt) import Foreign.Ptr -import Linear import qualified Vulkan as Vk -import qualified Vulkan.Zero as Vk -import qualified Vulkan.CStruct.Extends as Vk -- internal imports @@ -72,7 +63,7 @@ initVulkan window = do SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) ) (\vulkanSurface -> do - print ("destroying Surface" :: String) + print ("destroying surface" :: String) Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing ) @@ -80,7 +71,7 @@ initVulkan window = do (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window - swapchain <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice - images <- getImageViewHandles swapchain vulkanLogicalDevice + (swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice + imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice - return (vulkanSurface, vulkanInstance, swapchain, images) + return (vulkanSurface, vulkanInstance, swapchain, imageViews) diff --git a/src/Main.hs b/src/Main.hs index 2bd3ec4..d9c39fc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,24 +8,15 @@ import Control.Monad.Loops import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Bits -import qualified Data.ByteString as BS -import qualified Data.Vector as V import Data.Word import qualified SDL hiding (V2) -import qualified SDL.Video.Vulkan as SDL import qualified Control.Concurrent.STM as STM -import Foreign.C.Types (CInt) -import Foreign.Ptr -import Linear import qualified Vulkan as Vk import qualified Vulkan.Zero as Vk -import qualified Vulkan.CStruct.Extends as Vk -- internal imports import Init -import Devices -import Instance main :: IO () main = runResourceT $ do