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