creating image views complete

This commit is contained in:
nek0 2022-07-11 14:01:04 +02:00
parent afd7f8da37
commit 200b28ac31
3 changed files with 63 additions and 43 deletions

View file

@ -87,53 +87,91 @@ createSwapchain
-> V.Vector Vk.SurfaceFormatKHR -> V.Vector Vk.SurfaceFormatKHR
-> V2 CInt -> V2 CInt
-> Vk.Device -> Vk.Device
-> m Vk.SwapchainKHR -> m (Vk.SwapchainKHR, Vk.SurfaceFormatKHR)
createSwapchain surface surfaceFormats windowDimension logicalDevice = do createSwapchain surface surfaceFormats windowDimension logicalDevice = do
liftIO $ do liftIO $ do
print ("available formats:" :: String) print ("available formats:" :: String)
print surfaceFormats 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 let createInfo = Vk.zero
{ Vk.surface = surface { Vk.surface = surface
, Vk.minImageCount = 4 , Vk.minImageCount = 4
, Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB , Vk.imageFormat = surfaceFormat
, Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR , Vk.imageColorSpace = colorSpace
, Vk.imageExtent = , Vk.imageExtent =
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension (\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
, Vk.imageArrayLayers = 1 , Vk.imageArrayLayers = 1
, 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_OPAQUE_BIT_KHR , Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
, Vk.clipped = True , Vk.clipped = True
} }
snd <$> allocate swapchain <- snd <$> allocate
(Vk.createSwapchainKHR logicalDevice createInfo Nothing) (Vk.createSwapchainKHR logicalDevice createInfo Nothing)
(\swapchain -> do (\swapchain -> do
print ("destroying Swapchain" :: String) print ("destroying swapchain" :: String)
Vk.destroySwapchainKHR logicalDevice swapchain Nothing Vk.destroySwapchainKHR logicalDevice swapchain Nothing
) )
return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace)
getImageViewHandles getImageViewHandles
:: (MonadResource m) :: (MonadResource m)
=> Vk.SwapchainKHR => Vk.SwapchainKHR
-> Vk.SurfaceFormatKHR
-> Vk.Device -> Vk.Device
-> m (V.Vector Vk.ImageView) -> m (V.Vector Vk.ImageView)
getImageViewHandles swapchain logicalDevice = do getImageViewHandles swapchain surfaceFormat 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"
imageViews <- V.mapM V.mapM
(\image -> do (\image -> do
let createInfo = Vk.zero let createInfo = Vk.zero
{ Vk.image = image { Vk.image = image
, Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D , 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 handles
error "getImageHandles: Not yet implemented"

View file

@ -4,22 +4,13 @@
module Init where module Init where
import Control.Monad import Control.Monad
import Control.Monad.Loops
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Word
import qualified SDL hiding (V2) import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM
import Foreign.C.Types (CInt)
import Foreign.Ptr import Foreign.Ptr
import Linear
import qualified Vulkan as Vk import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
-- internal imports -- internal imports
@ -72,7 +63,7 @@ initVulkan window = do
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
) )
(\vulkanSurface -> do (\vulkanSurface -> do
print ("destroying Surface" :: String) print ("destroying surface" :: String)
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
) )
@ -80,7 +71,7 @@ initVulkan window = do
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
swapchain <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice (swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
images <- getImageViewHandles swapchain vulkanLogicalDevice imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
return (vulkanSurface, vulkanInstance, swapchain, images) return (vulkanSurface, vulkanInstance, swapchain, imageViews)

View file

@ -8,24 +8,15 @@ import Control.Monad.Loops
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Bits import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.Vector as V
import Data.Word import Data.Word
import qualified SDL hiding (V2) import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM 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 as Vk
import qualified Vulkan.Zero as Vk import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
-- internal imports -- internal imports
import Init import Init
import Devices
import Instance
main :: IO () main :: IO ()
main = runResourceT $ do main = runResourceT $ do