successfully cerate a surface

This commit is contained in:
nek0 2022-01-17 21:52:39 +01:00
parent 2fa3e2a8d6
commit c2fc5e8a58
1 changed files with 50 additions and 9 deletions

View File

@ -11,7 +11,7 @@ import Control.Monad.Trans.Resource
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Bits import Data.Bits
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Maybe (isNothing, fromMaybe) import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Word import Data.Word
@ -33,6 +33,7 @@ import qualified Vulkan.Utils.Initialization as Vk
import qualified Vulkan.Utils.QueueAssignment as Vk import qualified Vulkan.Utils.QueueAssignment as Vk
import qualified Vulkan.Utils.Requirements as Vk import qualified Vulkan.Utils.Requirements as Vk
import qualified Vulkan.Zero as Vk import qualified Vulkan.Zero as Vk
import qualified Vulkan as SDL
myApiVersion :: Word32 myApiVersion :: Word32
myApiVersion = Vk.API_VERSION_1_2 myApiVersion = Vk.API_VERSION_1_2
@ -81,22 +82,25 @@ initEngine = do
-- create the window -- create the window
window <- SDL.createWindow "Vulkan window" windowConfig window <- SDL.createWindow "Vulkan window" windowConfig
initVulkan window surface <- initVulkan window
return window return window
initVulkan :: MonadResource m => SDL.Window -> m () initVulkan :: MonadResource m => SDL.Window -> m SDL.VkSurfaceKHR
initVulkan window = do initVulkan window = do
vulkanInstance <- createInstance window vulkanInstance <- createInstance window
vulkanDevice <- pickPhysicalDevice vulkanInstance -- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
liftIO $ print vulkanDevice -- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
return () SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
quitEngine :: MonadResource m => SDL.Window -> m () quitEngine :: MonadResource m => SDL.Window -> Vk.Instance -> > m ()
quitEngine window = liftIO $ do quitEngine inst surface window = liftIO $ do
-- destroy instance
Vk.destroySurfaceKHR inst surface Nothing
-- destroy window -- destroy window
SDL.destroyWindow window SDL.destroyWindow window
@ -143,8 +147,45 @@ isDeviceSuitable :: MonadResource m => Vk.PhysicalDevice -> m Bool
isDeviceSuitable device = do isDeviceSuitable device = do
props <- Vk.getPhysicalDeviceProperties device props <- Vk.getPhysicalDeviceProperties device
features <- Vk.getPhysicalDeviceFeatures device features <- Vk.getPhysicalDeviceFeatures device
queues <- isJust <$> findQueueFamilies device
return return
( Vk.deviceType props == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU && ( Vk.deviceType props == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
Vk.geometryShader features Vk.geometryShader features &&
queues
) )
findQueueFamilies :: MonadIO m => Vk.PhysicalDevice -> m (Maybe Word32)
findQueueFamilies device = do
familyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties device
return $ snd $ V.foldl
(\acc@(curInd, index) prop ->
let flags = Vk.queueFlags prop
in
( curInd + 1
, if (flags .&. Vk.QUEUE_GRAPHICS_BIT) == Vk.QueueFlagBits 0
then index
else Just curInd
)
)
(0, Nothing)
familyProperties
-- createLogicalDevice :: MonadResource m => Vk.PhysicalDevice -> m Vk.Device
-- createLogicalDevice device = do
-- queueFamilies <- liftIO $ Vk.getPhysicalDeviceQueueFamilyProperties device
-- index <- liftIO (fromJust <$> findQueueFamilies device)
-- let queueCreateInfo = Vk.zero
-- { Vk.queueFamilyIndex = index
-- , Vk.queuePriorities = V.singleton 1
-- }
-- deviceFeatures = Nothing
-- deviceCreateInfo = Vk.zero
-- { Vk.queueCreateInfos = V.singleton queueCreateInfo
-- , Vk.enabledFeatures = deviceFeatures
-- , Vk.enabledExtensionNames = V.empty
-- } :: Vk.DeviceCreateInfo '[]
-- Vk.createDevice device deviceCreateInfo Nothing
--