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.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(..))
import Engine.Worker qualified as Worker
import Engine.StageSwitch (newStageSwitchVar)

setup
  :: ( HasLogFunc env
     , MonadResource (RIO env)
     )
  => Options -> RIO env (GlobalHandles, Maybe SwapchainResources)
setup :: Options -> RIO env (GlobalHandles, Maybe SwapchainResources)
setup Options
opts = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Options -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Options
opts

  ([InstanceRequirement]
windowReqs, Window
ghWindow) <- Bool
-> Natural
-> SizePicker
-> Text
-> RIO env ([InstanceRequirement], Window)
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Bool
-> Natural
-> SizePicker
-> Text
-> m ([InstanceRequirement], Window)
Window.allocate
    (Options -> Bool
optionsFullscreen Options
opts)
    (Options -> Natural
optionsDisplay Options
opts)
    SizePicker
Window.pickLargest
    Text
"Keid Engine"

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating instance"
  Instance
ghInstance <- [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo '[]
-> RIO env Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements
    (InstanceRequirement
deviceProps InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: InstanceRequirement
debugUtils InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
: [InstanceRequirement]
windowReqs)
    [InstanceRequirement]
forall a. Monoid a => a
mempty
    InstanceCreateInfo '[]
forall a. Zero a => a
zero

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating surface"
  (ReleaseKey
_surfaceKey, SurfaceKHR
ghSurface) <- Window -> Instance -> RIO env (ReleaseKey, SurfaceKHR)
forall (m :: * -> *).
MonadResource m =>
Window -> Instance -> m (ReleaseKey, SurfaceKHR)
Window.allocateSurface Window
ghWindow Instance
ghInstance

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating physical device"
  (PhysicalDeviceInfo
ghPhysicalDeviceInfo, PhysicalDevice
ghPhysicalDevice) <- Instance
-> SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> RIO env (PhysicalDeviceInfo, PhysicalDevice)
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadThrow m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Instance
-> SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> m (PhysicalDeviceInfo, PhysicalDevice)
allocatePhysical
    Instance
ghInstance
    SurfaceKHR
ghSurface
    PhysicalDeviceInfo -> Word64
pdiTotalMemory

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating logical device"
  Device
ghDevice <- PhysicalDeviceInfo -> PhysicalDevice -> RIO env Device
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
PhysicalDeviceInfo -> PhysicalDevice -> m Device
allocateLogical PhysicalDeviceInfo
ghPhysicalDeviceInfo PhysicalDevice
ghPhysicalDevice

  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating VMA"
  let
    allocatorCI :: VMA.AllocatorCreateInfo
    allocatorCI :: AllocatorCreateInfo
allocatorCI = AllocatorCreateInfo
forall a. Zero a => a
zero
      { $sel:physicalDevice:AllocatorCreateInfo :: Ptr PhysicalDevice_T
VMA.physicalDevice = PhysicalDevice -> Ptr PhysicalDevice_T
Vk.physicalDeviceHandle PhysicalDevice
ghPhysicalDevice
      , $sel:device:AllocatorCreateInfo :: Ptr Device_T
VMA.device         = Device -> Ptr Device_T
Vk.deviceHandle Device
ghDevice
      , $sel:instance':AllocatorCreateInfo :: Ptr Instance_T
VMA.instance'      = Instance -> Ptr Instance_T
Vk.instanceHandle Instance
ghInstance
      }
  (ReleaseKey
_vmaKey, Allocator
ghAllocator) <- AllocatorCreateInfo
-> (IO Allocator
    -> (Allocator -> IO ()) -> RIO env (ReleaseKey, Allocator))
-> RIO env (ReleaseKey, Allocator)
forall (io :: * -> *) r.
MonadIO io =>
AllocatorCreateInfo
-> (io Allocator -> (Allocator -> io ()) -> r) -> r
VMA.withAllocator AllocatorCreateInfo
allocatorCI IO Allocator
-> (Allocator -> IO ()) -> RIO env (ReleaseKey, Allocator)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  RIO env () -> RIO env (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Releasing VMA") RIO env (IO ())
-> (IO () -> RIO env ReleaseKey) -> RIO env ReleaseKey
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> RIO env ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register

  Queues (QueueFamilyIndex, Queue)
ghQueues <- IO (Queues (QueueFamilyIndex, Queue))
-> RIO env (Queues (QueueFamilyIndex, Queue))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Queues (QueueFamilyIndex, Queue))
 -> RIO env (Queues (QueueFamilyIndex, Queue)))
-> IO (Queues (QueueFamilyIndex, Queue))
-> RIO env (Queues (QueueFamilyIndex, Queue))
forall a b. (a -> b) -> a -> b
$ PhysicalDeviceInfo
-> Device -> IO (Queues (QueueFamilyIndex, Queue))
pdiGetQueues PhysicalDeviceInfo
ghPhysicalDeviceInfo Device
ghDevice
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Got command queues: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Queues Word32 -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (((QueueFamilyIndex, Queue) -> Word32)
-> Queues (QueueFamilyIndex, Queue) -> Queues Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QueueFamilyIndex -> Word32
unQueueFamilyIndex (QueueFamilyIndex -> Word32)
-> ((QueueFamilyIndex, Queue) -> QueueFamilyIndex)
-> (QueueFamilyIndex, Queue)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueueFamilyIndex, Queue) -> QueueFamilyIndex
forall a b. (a, b) -> a
fst) Queues (QueueFamilyIndex, Queue)
ghQueues)

  Extent2D
screen <- IO Extent2D -> RIO env Extent2D
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Extent2D -> RIO env Extent2D)
-> IO Extent2D -> RIO env Extent2D
forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
ghWindow
  (ReleaseKey
_screenKey, Cell ProjectionInput Projection
ghScreenP) <- RIO env (Cell ProjectionInput Projection)
-> RIO env (ReleaseKey, Cell ProjectionInput Projection)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO env (Cell ProjectionInput Projection)
 -> RIO env (ReleaseKey, Cell ProjectionInput Projection))
-> RIO env (Cell ProjectionInput Projection)
-> RIO env (ReleaseKey, Cell ProjectionInput Projection)
forall a b. (a -> b) -> a -> b
$
    (ProjectionInput -> Projection)
-> ProjectionInput -> RIO env (Cell ProjectionInput Projection)
forall (m :: * -> *) input output.
MonadUnliftIO m =>
(input -> output) -> input -> m (Cell input output)
Worker.spawnCell ProjectionInput -> Projection
Camera.mkProjection ProjectionInput :: Float -> Extent2D -> ProjectionInput
Camera.ProjectionInput
      { $sel:projectionFovRads:ProjectionInput :: Float
projectionFovRads = Float
τ Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
4
      , $sel:projectionScreen:ProjectionInput :: Extent2D
projectionScreen  = Extent2D
screen
      }

  StageSwitchVar
ghStageSwitch <- RIO env StageSwitchVar
forall (m :: * -> *). MonadIO m => m StageSwitchVar
newStageSwitchVar

  pure (GlobalHandles :: Window
-> SurfaceKHR
-> Instance
-> PhysicalDevice
-> PhysicalDeviceInfo
-> Device
-> Allocator
-> Queues (QueueFamilyIndex, Queue)
-> Cell ProjectionInput Projection
-> StageSwitchVar
-> GlobalHandles
GlobalHandles{StageSwitchVar
Window
Device
Instance
PhysicalDevice
SurfaceKHR
Allocator
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
Cell ProjectionInput Projection
$sel:ghStageSwitch:GlobalHandles :: StageSwitchVar
$sel:ghScreenP:GlobalHandles :: Cell ProjectionInput Projection
$sel:ghQueues:GlobalHandles :: Queues (QueueFamilyIndex, Queue)
$sel:ghAllocator:GlobalHandles :: Allocator
$sel:ghDevice:GlobalHandles :: Device
$sel:ghPhysicalDeviceInfo:GlobalHandles :: PhysicalDeviceInfo
$sel:ghPhysicalDevice:GlobalHandles :: PhysicalDevice
$sel:ghInstance:GlobalHandles :: Instance
$sel:ghSurface:GlobalHandles :: SurfaceKHR
$sel:ghWindow:GlobalHandles :: Window
ghStageSwitch :: StageSwitchVar
ghScreenP :: Cell ProjectionInput Projection
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghAllocator :: Allocator
ghDevice :: Device
ghPhysicalDevice :: PhysicalDevice
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghSurface :: SurfaceKHR
ghInstance :: Instance
ghWindow :: Window
..}, Maybe SwapchainResources
forall a. Maybe a
Nothing)

deviceProps :: InstanceRequirement
deviceProps :: InstanceRequirement
deviceProps = Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement
RequireInstanceExtension
  Maybe ByteString
forall a. Maybe a
Nothing
  ByteString
forall a. (Eq a, IsString a) => a
Khr.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME
  Word32
forall a. Bounded a => a
minBound

debugUtils :: InstanceRequirement
debugUtils :: InstanceRequirement
debugUtils = Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement
RequireInstanceExtension
  Maybe ByteString
forall a. Maybe a
Nothing
  ByteString
forall a. (Eq a, IsString a) => a
Ext.EXT_DEBUG_UTILS_EXTENSION_NAME
  Word32
forall a. Bounded a => a
minBound

τ :: Float
τ :: Float
τ = Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi