vulkan-tutorial/src/Main.hs

192 lines
5.5 KiB
Haskell
Raw Normal View History

2022-01-14 07:59:38 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Main where
import Control.Monad
import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Maybe
import Data.Bits
import qualified Data.ByteString as BS
2022-01-17 20:52:39 +00:00
import Data.Maybe
2022-01-14 07:59:38 +00:00
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Word
import Data.List as L
import Linear
import qualified SDL
import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM
import Data.Foldable
import Foreign.Ptr
import qualified Vulkan as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Extensions as Vk
import qualified Vulkan.Requirement as Vk
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Core11 as Vk
import qualified Vulkan.Core12 as Vk
import qualified Vulkan.Utils.Initialization as Vk
import qualified Vulkan.Utils.QueueAssignment as Vk
import qualified Vulkan.Utils.Requirements as Vk
import qualified Vulkan.Zero as Vk
2022-01-17 20:52:39 +00:00
import qualified Vulkan as SDL
2022-01-14 07:59:38 +00:00
myApiVersion :: Word32
myApiVersion = Vk.API_VERSION_1_2
main :: IO ()
main = runResourceT $ do
window <- initEngine
SDL.showWindow window
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
-- main loop
liftIO $ whileM_
(STM.atomically $ STM.readTMVar quit
)
( do
-- poll events
evs <- SDL.pollEvents
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
void $ STM.atomically $ STM.swapTMVar quit False
_ -> return ()
)
evs
)
quitEngine window
initEngine :: MonadResource m => m SDL.Window
initEngine = do
-- initialize SDL2 with all subsystems
SDL.initializeAll
-- create a window configuration
let windowConfig = SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
}
-- load vulkan library
SDL.vkLoadLibrary Nothing
-- create the window
window <- SDL.createWindow "Vulkan window" windowConfig
2022-01-17 20:52:39 +00:00
surface <- initVulkan window
2022-01-14 07:59:38 +00:00
return window
2022-01-17 20:52:39 +00:00
initVulkan :: MonadResource m => SDL.Window -> m SDL.VkSurfaceKHR
2022-01-14 07:59:38 +00:00
initVulkan window = do
vulkanInstance <- createInstance window
2022-01-17 20:52:39 +00:00
-- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
2022-01-14 07:59:38 +00:00
2022-01-17 20:52:39 +00:00
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
2022-01-14 07:59:38 +00:00
2022-01-17 20:52:39 +00:00
quitEngine :: MonadResource m => SDL.Window -> Vk.Instance -> > m ()
quitEngine inst surface window = liftIO $ do
-- destroy instance
Vk.destroySurfaceKHR inst surface Nothing
2022-01-14 07:59:38 +00:00
-- destroy window
SDL.destroyWindow window
-- quit SDL
SDL.quit
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
createInstance window = do
windowExtensions <- liftIO $
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
let createInfo = Vk.zero
{ Vk.applicationInfo = Just Vk.zero
{ Vk.applicationName = Nothing
, Vk.apiVersion = myApiVersion
}
}
requirements =
(\n -> Vk.RequireInstanceExtension Nothing n minBound) <$>
( Vk.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME
: windowExtensions
)
Vk.createInstanceFromRequirements requirements [] createInfo
pickPhysicalDevice :: MonadResource m => Vk.Instance -> m Vk.PhysicalDevice
pickPhysicalDevice inst = do
(_, devices) <- Vk.enumeratePhysicalDevices inst
when (V.null devices) (error "Failed to find GPUs with Vulkan support")
mDevice <- V.foldM
(\acc dev -> do
suitability <- isDeviceSuitable dev
if suitability && isNothing acc
then
return (Just dev)
else
return acc
)
Nothing
devices
return $ fromMaybe
(error "Failed to find suitable GPU")
mDevice
isDeviceSuitable :: MonadResource m => Vk.PhysicalDevice -> m Bool
isDeviceSuitable device = do
props <- Vk.getPhysicalDeviceProperties device
features <- Vk.getPhysicalDeviceFeatures device
2022-01-17 20:52:39 +00:00
queues <- isJust <$> findQueueFamilies device
2022-01-14 07:59:38 +00:00
return
( Vk.deviceType props == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
2022-01-17 20:52:39 +00:00
Vk.geometryShader features &&
queues
2022-01-14 07:59:38 +00:00
)
2022-01-17 20:52:39 +00:00
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
--