Setup.hs

module Engine.Setup where

import RIO

import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Extensions.VK_EXT_debug_utils qualified as Ext
import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 qualified as Khr
import Vulkan.Extensions.VK_KHR_surface qualified as Khr
import Vulkan.Requirement (InstanceRequirement(..))
import Vulkan.Utils.Initialization (createInstanceFromRequirements)
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Vulkan.Zero (zero)
import VulkanMemoryAllocator qualified as VMA

import Engine.Camera qualified as Camera
import Engine.Setup.Device (allocatePhysical, allocateLogical)
import Engine.Setup.Window qualified as Window
import Engine.Types (GlobalHandles(..))
import Engine.Types.Options (Options(..))
import Engine.Vulkan.Swapchain (SwapchainResources)
import Engine.Vulkan.Types (PhysicalDeviceInfo(..), Queues)
import Engine.Worker qualified as Worker
import Engine.StageSwitch (newStageSwitchVar)

setup
  :: ( HasLogFunc env
     , MonadResource (RIO env)
     )
  => Options -> RIO env (GlobalHandles, Maybe SwapchainResources)
setup opts = do
  logDebug $ displayShow opts

  (windowReqs, ghWindow) <- Window.allocate
    (optionsFullscreen opts)
    (optionsDisplay opts)
    Window.pickLargest
    "Keid Engine"

  logDebug "Creating instance"
  ghInstance <- createInstanceFromRequirements
    (deviceProps : debugUtils : windowReqs)
    mempty
    zero

  logDebug "Creating surface"
  (_surfaceKey, ghSurface) <- Window.allocateSurface ghWindow ghInstance

  logDebug "Creating physical device"
  (ghPhysicalDeviceInfo, ghPhysicalDevice) <- allocatePhysical
    ghInstance
    (Just ghSurface)
    pdiTotalMemory

  logDebug "Creating logical device"
  ghDevice <- allocateLogical ghPhysicalDeviceInfo ghPhysicalDevice

  logDebug "Creating VMA"
  let
    allocatorCI :: VMA.AllocatorCreateInfo
    allocatorCI = zero
      { VMA.physicalDevice = Vk.physicalDeviceHandle ghPhysicalDevice
      , VMA.device         = Vk.deviceHandle ghDevice
      , VMA.instance'      = Vk.instanceHandle ghInstance
      }
  (_vmaKey, ghAllocator) <- VMA.withAllocator allocatorCI Resource.allocate
  toIO (logDebug "Releasing VMA") >>= Resource.register

  ghQueues <- liftIO $ pdiGetQueues ghPhysicalDeviceInfo ghDevice
  logDebug $ "Got command queues: " <> displayShow (fmap (unQueueFamilyIndex . fst) ghQueues)

  screen <- liftIO $ Window.getExtent2D ghWindow
  (_screenKey, ghScreenP) <- Worker.registered $
    Worker.spawnCell Camera.mkProjection Camera.ProjectionInput
      { projectionFovRads = τ / 4
      , projectionScreen  = screen
      }

  ghStageSwitch <- newStageSwitchVar

  pure (GlobalHandles{..}, Nothing)

setupHeadless
  :: ( HasLogFunc env
     , MonadResource (RIO env)
     )
  => Options
  -> RIO env Headless
setupHeadless opts = do
  logDebug $ displayShow opts

  logDebug "Creating instance"
  ghInstance <- createInstanceFromRequirements
    (deviceProps : debugUtils : headlessReqs)
    mempty
    zero

  logDebug "Creating physical device"
  (ghPhysicalDeviceInfo, ghPhysicalDevice) <- allocatePhysical
    ghInstance
    Nothing
    pdiTotalMemory

  logDebug "Creating logical device"
  ghDevice <- allocateLogical ghPhysicalDeviceInfo ghPhysicalDevice

  logDebug "Creating VMA"
  let
    allocatorCI :: VMA.AllocatorCreateInfo
    allocatorCI = zero
      { VMA.physicalDevice = Vk.physicalDeviceHandle ghPhysicalDevice
      , VMA.device         = Vk.deviceHandle ghDevice
      , VMA.instance'      = Vk.instanceHandle ghInstance
      }
  (_vmaKey, ghAllocator) <- VMA.withAllocator allocatorCI Resource.allocate
  toIO (logDebug "Releasing VMA") >>= Resource.register

  ghQueues <- liftIO $ pdiGetQueues ghPhysicalDeviceInfo ghDevice
  logDebug $ "Got command queues: " <> displayShow (fmap (unQueueFamilyIndex . fst) ghQueues)

  pure (ghInstance, ghPhysicalDeviceInfo, ghPhysicalDevice, ghDevice, ghAllocator, ghQueues)

type Headless =
  ( Vk.Instance
  , PhysicalDeviceInfo
  , Vk.PhysicalDevice
  , Vk.Device
  , VMA.Allocator
  , Queues (QueueFamilyIndex, Vk.Queue)
  )

deviceProps :: InstanceRequirement
deviceProps = RequireInstanceExtension
  Nothing
  Khr.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME
  minBound

debugUtils :: InstanceRequirement
debugUtils = RequireInstanceExtension
  Nothing
  Ext.EXT_DEBUG_UTILS_EXTENSION_NAME
  minBound

headlessReqs :: [InstanceRequirement]
headlessReqs =
  [ RequireInstanceExtension
      Nothing
      Khr.KHR_SURFACE_EXTENSION_NAME
      minBound
  ]

τ :: Float
τ = 2 * pi