{-# 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 import Data.Maybe 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 import qualified Vulkan as SDL 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 surface <- initVulkan window return window initVulkan :: MonadResource m => SDL.Window -> m SDL.VkSurfaceKHR initVulkan window = do vulkanInstance <- createInstance window -- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance -- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) quitEngine :: MonadResource m => SDL.Window -> Vk.Instance -> > m () quitEngine inst surface window = liftIO $ do -- destroy instance Vk.destroySurfaceKHR inst surface Nothing -- 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 queues <- isJust <$> findQueueFamilies device return ( Vk.deviceType props == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU && 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 --