vulkan-tutorial/src/Main.hs

{-# 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
--