{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}

{-# LANGUAGE OverloadedLists #-}

module Render.DescSets.Set0
  ( Scene(..)
  , emptyScene

  , allocate
  , allocateEmpty

  , updateSet0Ds

  , mkBindings

  , FrameResource(..)
  , extendResourceDS

  , Buffer
  , Process
  , observe

  , withBoundSet0
  ) where

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Resource qualified as ResourceT
import Data.Bits ((.|.))
import Data.Kind (Type)
import Data.Tagged (Tagged(..))
import Data.Vector qualified as Vector
import Data.Vector.Storable qualified as VectorS
import Foreign.Storable.Generic (GStorable)
import Geomancy (Vec3, Vec4, vec3)
import Geomancy.Transform (Transform)
import Vulkan.Core10 qualified as Vk
import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12
import Vulkan.CStruct.Extends (SomeStruct(..))
import Vulkan.NamedType ((:::))
import Vulkan.Zero (Zero(..))

import Engine.Vulkan.DescSets (Bound, Extend, extendDS, withBoundDescriptorSets0)
import Engine.Vulkan.Pipeline (Pipeline)
import Engine.Vulkan.Pipeline qualified as Pipeline
import Engine.Vulkan.Types (DsLayoutBindings, MonadVulkan, HasVulkan(..))
import Engine.Worker qualified as Worker
import Global.Resource.CubeMap.Base qualified as BaseCubeMap
import Global.Resource.Texture.Base qualified as BaseTexture
import Render.DescSets.Sun (Sun)
import Render.Lit.Material (Material)
import Resource.Buffer qualified as Buffer
import Resource.Collection qualified as Collection
import Resource.Image qualified as Image
import Resource.Region qualified as Region
import Resource.Texture qualified as Texture
import Resource.Vulkan.DescriptorPool qualified as DescriptorPool
import Resource.Vulkan.Named qualified as Named

-- * Set0 data

data Scene = Scene
  { Scene -> Transform
sceneProjection    :: Transform
  , Scene -> Transform
sceneInvProjection :: Transform

  , Scene -> Transform
sceneView          :: Transform
  , Scene -> Transform
sceneInvView       :: Transform
  , Scene -> Vec3
sceneViewPos       :: Vec3 -- XXX: gets extra padding
  , Scene -> Vec3
sceneViewDir       :: Vec3 -- XXX: gets extra padding

  , Scene -> Vec4
sceneTweaks        :: Vec4 -- ^ 4 debug tweaks bound to Kontrol

  , Scene -> Vec4
sceneFog           :: Vec4 -- XXX: RGB color + scatter factor β
  , Scene -> Int32
sceneEnvCube       :: Int32
  , Scene -> Word32
sceneNumLights     :: Word32
  }
  deriving (Int -> Scene -> ShowS
[Scene] -> ShowS
Scene -> String
(Int -> Scene -> ShowS)
-> (Scene -> String) -> ([Scene] -> ShowS) -> Show Scene
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scene -> ShowS
showsPrec :: Int -> Scene -> ShowS
$cshow :: Scene -> String
show :: Scene -> String
$cshowList :: [Scene] -> ShowS
showList :: [Scene] -> ShowS
Show, (forall x. Scene -> Rep Scene x)
-> (forall x. Rep Scene x -> Scene) -> Generic Scene
forall x. Rep Scene x -> Scene
forall x. Scene -> Rep Scene x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Scene -> Rep Scene x
from :: forall x. Scene -> Rep Scene x
$cto :: forall x. Rep Scene x -> Scene
to :: forall x. Rep Scene x -> Scene
Generic)

instance GStorable Scene

emptyScene :: Scene
emptyScene :: Scene
emptyScene = Scene
  { $sel:sceneProjection:Scene :: Transform
sceneProjection    = Transform
forall a. Monoid a => a
mempty
  , $sel:sceneInvProjection:Scene :: Transform
sceneInvProjection = Transform
forall a. Monoid a => a
mempty

  , $sel:sceneView:Scene :: Transform
sceneView          = Transform
forall a. Monoid a => a
mempty
  , $sel:sceneInvView:Scene :: Transform
sceneInvView       = Transform
forall a. Monoid a => a
mempty
  , $sel:sceneViewPos:Scene :: Vec3
sceneViewPos       = Float -> Float -> Float -> Vec3
vec3 Float
0 Float
0 Float
0
  , $sel:sceneViewDir:Scene :: Vec3
sceneViewDir       = Float -> Float -> Float -> Vec3
vec3 Float
0 Float
0 Float
1

  , $sel:sceneFog:Scene :: Vec4
sceneFog           = Vec4
0
  , $sel:sceneEnvCube:Scene :: Int32
sceneEnvCube       = Int32
forall a. Bounded a => a
minBound
  , $sel:sceneNumLights:Scene :: Word32
sceneNumLights     = Word32
0

  , $sel:sceneTweaks:Scene :: Vec4
sceneTweaks        = Vec4
0
  }

-- * Common descriptor set

mkBindings
  :: ( Foldable samplers
     , Foldable textures
     , Foldable cubemaps
     )
  => samplers Vk.Sampler
  -> textures a
  -> cubemaps b
  -> Word32
  -> Tagged Scene DsLayoutBindings
mkBindings :: forall (samplers :: * -> *) (textures :: * -> *)
       (cubemaps :: * -> *) a b.
(Foldable samplers, Foldable textures, Foldable cubemaps) =>
samplers Sampler
-> textures a
-> cubemaps b
-> Word32
-> Tagged Scene DsLayoutBindings
mkBindings samplers Sampler
samplers textures a
textures cubemaps b
cubes Word32
shadows = DsLayoutBindings -> Tagged Scene DsLayoutBindings
forall {k} (s :: k) b. b -> Tagged s b
Tagged
  [ (DescriptorSetLayoutBinding
set0bind0,          DescriptorBindingFlags
forall a. Zero a => a
zero)
  , (samplers Sampler -> DescriptorSetLayoutBinding
forall (samplers :: * -> *).
Foldable samplers =>
samplers Sampler -> DescriptorSetLayoutBinding
set0bind1 samplers Sampler
samplers, DescriptorBindingFlags
forall a. Zero a => a
zero)
  , (textures a -> DescriptorSetLayoutBinding
forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind2 textures a
textures, DescriptorBindingFlags
partialBinding)
  , (cubemaps b -> DescriptorSetLayoutBinding
forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind3 cubemaps b
cubes,    DescriptorBindingFlags
partialBinding)
  , (DescriptorSetLayoutBinding
set0bind4,          DescriptorBindingFlags
forall a. Zero a => a
zero)
  , (Word32 -> DescriptorSetLayoutBinding
set0bind5 Word32
shadows,  DescriptorBindingFlags
partialBinding)
  , (DescriptorSetLayoutBinding
set0bind6,          DescriptorBindingFlags
forall a. Zero a => a
zero)
  ]
  where
    partialBinding :: DescriptorBindingFlags
partialBinding =
      DescriptorBindingFlags
Vk12.DESCRIPTOR_BINDING_PARTIALLY_BOUND_BIT

    _partialVariable :: DescriptorBindingFlags
_partialVariable =
      DescriptorBindingFlags
partialBinding DescriptorBindingFlags
-> DescriptorBindingFlags -> DescriptorBindingFlags
forall a. Bits a => a -> a -> a
.|.
      DescriptorBindingFlags
Vk12.DESCRIPTOR_BINDING_VARIABLE_DESCRIPTOR_COUNT_BIT
      {-
        VUID-VkDescriptorSetLayoutBindingFlagsCreateInfo-pBindingFlags-03004(ERROR / SPEC):
          msgNum: 222246202 - Validation Error:
          [ VUID-VkDescriptorSetLayoutBindingFlagsCreateInfo-pBindingFlags-03004 ]
          Object 0: handle = 0x157ea80, type = VK_OBJECT_TYPE_DEVICE;
          | MessageID = 0xd3f353a
          | Invalid flags for VkDescriptorSetLayoutBinding entry 2 The Vulkan spec states:
              If an element of pBindingFlags includes VK_DESCRIPTOR_BINDING_VARIABLE_DESCRIPTOR_COUNT_BIT,
              then all other elements of VkDescriptorSetLayoutCreateInfo::pBindings must have
              a smaller value of binding
              (https://vulkan.lunarg.com/doc/view/1.2.162.1~rc2/linux/1.2-extensions/vkspec.html#VUID-VkDescriptorSetLayoutBindingFlagsCreateInfo-pBindingFlags-03004)
      -}

set0bind0 :: Vk.DescriptorSetLayoutBinding
set0bind0 :: DescriptorSetLayoutBinding
set0bind0 = Vk.DescriptorSetLayoutBinding
  { $sel:binding:DescriptorSetLayoutBinding :: Word32
binding           = Word32
0
  , $sel:descriptorType:DescriptorSetLayoutBinding :: DescriptorType
descriptorType    = DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
  , $sel:descriptorCount:DescriptorSetLayoutBinding :: Word32
descriptorCount   = Word32
1
  , $sel:stageFlags:DescriptorSetLayoutBinding :: ShaderStageFlags
stageFlags        = ShaderStageFlags
Vk.SHADER_STAGE_ALL
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = Vector Sampler
forall a. Monoid a => a
mempty
  }

set0bind1
  :: Foldable samplers
  => samplers Vk.Sampler
  -> Vk.DescriptorSetLayoutBinding
set0bind1 :: forall (samplers :: * -> *).
Foldable samplers =>
samplers Sampler -> DescriptorSetLayoutBinding
set0bind1 samplers Sampler
samplers = Vk.DescriptorSetLayoutBinding
  { $sel:binding:DescriptorSetLayoutBinding :: Word32
Vk.binding           = Word32
1
  , $sel:stageFlags:DescriptorSetLayoutBinding :: ShaderStageFlags
Vk.stageFlags        = ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
  , $sel:descriptorType:DescriptorSetLayoutBinding :: DescriptorType
Vk.descriptorType    = DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLER
  , $sel:descriptorCount:DescriptorSetLayoutBinding :: Word32
Vk.descriptorCount   = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector Sampler -> Int
forall a. Vector a -> Int
Vector.length Vector Sampler
linearSamplers
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
Vk.immutableSamplers = Vector Sampler
linearSamplers
  }
  where
    linearSamplers :: Vector Sampler
linearSamplers = samplers Sampler -> Vector Sampler
forall (collection :: * -> *) a.
Foldable collection =>
collection a -> Vector a
Collection.toVector samplers Sampler
samplers

set0bind2
  :: Foldable textures
  => textures a
  -> Vk.DescriptorSetLayoutBinding
set0bind2 :: forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind2 textures a
textures = Vk.DescriptorSetLayoutBinding
  { $sel:binding:DescriptorSetLayoutBinding :: Word32
binding           = Word32
2
  , $sel:descriptorType:DescriptorSetLayoutBinding :: DescriptorType
descriptorType    = DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE
  , $sel:descriptorCount:DescriptorSetLayoutBinding :: Word32
descriptorCount   = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
baseTextures Int
textureCount
  , $sel:stageFlags:DescriptorSetLayoutBinding :: ShaderStageFlags
stageFlags        = ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = Vector Sampler
forall a. Monoid a => a
mempty
  }
  where
    baseTextures :: Int
baseTextures = Collection Source -> Int
forall a. Collection a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Collection Source
BaseTexture.sources
    textureCount :: Int
textureCount = textures a -> Int
forall a. textures a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length textures a
textures

set0bind3
  :: Foldable cubes
  => cubes a
  -> Vk.DescriptorSetLayoutBinding
set0bind3 :: forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind3 cubes a
cubes = Vk.DescriptorSetLayoutBinding
  { $sel:binding:DescriptorSetLayoutBinding :: Word32
binding           = Word32
3
  , $sel:descriptorType:DescriptorSetLayoutBinding :: DescriptorType
descriptorType    = DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE
  , $sel:descriptorCount:DescriptorSetLayoutBinding :: Word32
descriptorCount   = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
baseCubes Int
cubeCount
  , $sel:stageFlags:DescriptorSetLayoutBinding :: ShaderStageFlags
stageFlags        = ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = Vector Sampler
forall a. Monoid a => a
mempty
  }
  where
    baseCubes :: Int
baseCubes = Collection Source -> Int
forall a. Collection a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Collection Source
BaseCubeMap.sources
    cubeCount :: Int
cubeCount = cubes a -> Int
forall a. cubes a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length cubes a
cubes

set0bind4 :: Vk.DescriptorSetLayoutBinding
set0bind4 :: DescriptorSetLayoutBinding
set0bind4 = Vk.DescriptorSetLayoutBinding
  { $sel:binding:DescriptorSetLayoutBinding :: Word32
binding           = Word32
4
  , $sel:descriptorType:DescriptorSetLayoutBinding :: DescriptorType
descriptorType    = DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
  , $sel:stageFlags:DescriptorSetLayoutBinding :: ShaderStageFlags
stageFlags        = ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
  , $sel:descriptorCount:DescriptorSetLayoutBinding :: Word32
descriptorCount   = Word32
1
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = Vector Sampler
forall a. Monoid a => a
mempty
  }

set0bind5 :: Word32 -> Vk.DescriptorSetLayoutBinding
set0bind5 :: Word32 -> DescriptorSetLayoutBinding
set0bind5 Word32
shadows = Vk.DescriptorSetLayoutBinding
  { $sel:binding:DescriptorSetLayoutBinding :: Word32
binding           = Word32
5
  , $sel:descriptorType:DescriptorSetLayoutBinding :: DescriptorType
descriptorType    = DescriptorType
Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
  , $sel:stageFlags:DescriptorSetLayoutBinding :: ShaderStageFlags
stageFlags        = ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
  , $sel:descriptorCount:DescriptorSetLayoutBinding :: Word32
descriptorCount   = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 Word32
shadows
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = Vector Sampler
forall a. Monoid a => a
mempty
  }

set0bind6 :: Vk.DescriptorSetLayoutBinding
set0bind6 :: DescriptorSetLayoutBinding
set0bind6 = Vk.DescriptorSetLayoutBinding
  { $sel:binding:DescriptorSetLayoutBinding :: Word32
binding           = Word32
6
  , $sel:descriptorType:DescriptorSetLayoutBinding :: DescriptorType
descriptorType    = DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
  , $sel:stageFlags:DescriptorSetLayoutBinding :: ShaderStageFlags
stageFlags        = ShaderStageFlags
Vk.SHADER_STAGE_FRAGMENT_BIT
  , $sel:descriptorCount:DescriptorSetLayoutBinding :: Word32
descriptorCount   = Word32
1
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = Vector Sampler
forall a. Monoid a => a
mempty
  }

-- * Setup

allocate
  :: ( Traversable textures
     , Traversable cubes
     , MonadVulkan env m
     , ResourceT.MonadResource m
     )
  => Tagged '[Scene] Vk.DescriptorSetLayout
  -> textures (Texture.Texture Texture.Flat)
  -> cubes (Texture.Texture Texture.CubeMap)
  -> Maybe (Buffer.Allocated 'Buffer.Coherent Sun)
  -> "shadow maps" ::: Vector Vk.ImageView
  -> Maybe (Buffer.Allocated 'Buffer.Coherent Material)
  -> ResourceT m (FrameResource '[Scene])
allocate :: forall (textures :: * -> *) (cubes :: * -> *) env (m :: * -> *).
(Traversable textures, Traversable cubes, MonadVulkan env m,
 MonadResource m) =>
Tagged '[Scene] DescriptorSetLayout
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT m (FrameResource '[Scene])
allocate (Tagged DescriptorSetLayout
set0layout) textures (Texture Flat)
textures cubes (Texture CubeMap)
cubes Maybe (Allocated 'Coherent Sun)
lightsData "shadow maps" ::: Vector ImageView
shadowViews Maybe (Allocated 'Coherent Material)
materialsData = do
  DescriptorPool
descPool <- m (ReleaseKey, DescriptorPool) -> ResourceT m DescriptorPool
forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local (m (ReleaseKey, DescriptorPool) -> ResourceT m DescriptorPool)
-> m (ReleaseKey, DescriptorPool) -> ResourceT m DescriptorPool
forall a b. (a -> b) -> a -> b
$
    Maybe Text
-> Word32
-> [(DescriptorType, Word32)]
-> m (ReleaseKey, DescriptorPool)
forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Maybe Text
-> Word32
-> [(DescriptorType, Word32)]
-> m (ReleaseKey, DescriptorPool)
DescriptorPool.allocate (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Basic") Word32
1 [(DescriptorType, Word32)]
dpSizes

  Vector DescriptorSet
descSets <- DescriptorPool
-> Maybe Text
-> Vector DescriptorSetLayout
-> ResourceT m (Vector DescriptorSet)
forall env (m :: * -> *).
MonadVulkan env m =>
DescriptorPool
-> Maybe Text
-> Vector DescriptorSetLayout
-> m (Vector DescriptorSet)
DescriptorPool.allocateSetsFrom DescriptorPool
descPool (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Basic") [Item (Vector DescriptorSetLayout)
DescriptorSetLayout
set0layout]

  Allocated 'Coherent Scene
sceneData <- m (ReleaseKey, Allocated 'Coherent Scene)
-> ResourceT m (Allocated 'Coherent Scene)
forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local (m (ReleaseKey, Allocated 'Coherent Scene)
 -> ResourceT m (Allocated 'Coherent Scene))
-> m (ReleaseKey, Allocated 'Coherent Scene)
-> ResourceT m (Allocated 'Coherent Scene)
forall a b. (a -> b) -> a -> b
$
    Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector Scene
-> m (ReleaseKey, Allocated 'Coherent Scene)
forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (ReleaseKey, Allocated 'Coherent a)
Buffer.allocateCoherent
    (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Basic.Data")
    BufferUsageFlagBits
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT
    Int
1
    [Item (Vector Scene)
Scene
emptyScene]

  let
    -- TODO: must be checked against depth format and TILING_OPTIMAL
    -- shadowFilter = Vk.FILTER_NEAREST
    shadowFilter :: Filter
shadowFilter = Filter
Vk.FILTER_LINEAR

    shadowCI :: SamplerCreateInfo '[]
shadowCI = SamplerCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:addressModeU:SamplerCreateInfo :: SamplerAddressMode
Vk.addressModeU  = SamplerAddressMode
Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE
      , $sel:addressModeV:SamplerCreateInfo :: SamplerAddressMode
Vk.addressModeV  = SamplerAddressMode
Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE
      , $sel:addressModeW:SamplerCreateInfo :: SamplerAddressMode
Vk.addressModeW  = SamplerAddressMode
Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_EDGE
      , $sel:borderColor:SamplerCreateInfo :: BorderColor
Vk.borderColor   = BorderColor
Vk.BORDER_COLOR_FLOAT_OPAQUE_WHITE
      , $sel:magFilter:SamplerCreateInfo :: Filter
Vk.magFilter     = Filter
shadowFilter
      , $sel:minFilter:SamplerCreateInfo :: Filter
Vk.minFilter     = Filter
shadowFilter
      , $sel:compareEnable:SamplerCreateInfo :: Bool
Vk.compareEnable = Bool
True
      , $sel:compareOp:SamplerCreateInfo :: CompareOp
Vk.compareOp     = CompareOp
Vk.COMPARE_OP_LESS
      }

  let ifor :: Vector a -> (Int -> a -> ResourceT m b) -> ResourceT m (Vector b)
ifor = ((Int -> a -> ResourceT m b) -> Vector a -> ResourceT m (Vector b))
-> Vector a
-> (Int -> a -> ResourceT m b)
-> ResourceT m (Vector b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> a -> ResourceT m b) -> Vector a -> ResourceT m (Vector b)
forall (m :: * -> *) a b.
Monad m =>
(Int -> a -> m b) -> Vector a -> m (Vector b)
Vector.imapM
  Vector (Sampler, ImageView)
shadowMaps <- ("shadow maps" ::: Vector ImageView)
-> (Int -> ImageView -> ResourceT m (Sampler, ImageView))
-> ResourceT m (Vector (Sampler, ImageView))
forall {a} {b}.
Vector a -> (Int -> a -> ResourceT m b) -> ResourceT m (Vector b)
ifor "shadow maps" ::: Vector ImageView
shadowViews \Int
ix ImageView
depthView -> do
    Sampler
shadowSampler <- m (ReleaseKey, Sampler) -> ResourceT m Sampler
forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local do
      Device
device <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
      Device
-> SamplerCreateInfo '[]
-> Maybe AllocationCallbacks
-> (IO Sampler -> (Sampler -> IO ()) -> m (ReleaseKey, Sampler))
-> m (ReleaseKey, Sampler)
forall (a :: [*]) (io :: * -> *) r.
(Extendss SamplerCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SamplerCreateInfo a
-> Maybe AllocationCallbacks
-> (io Sampler -> (Sampler -> io ()) -> r)
-> r
Vk.withSampler Device
device SamplerCreateInfo '[]
shadowCI Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO Sampler -> (Sampler -> IO ()) -> m (ReleaseKey, Sampler)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
ResourceT.allocate
    Sampler -> Text -> ResourceT m ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object Sampler
shadowSampler (Text -> ResourceT m ()) -> Text -> ResourceT m ()
forall a b. (a -> b) -> a -> b
$
      Text
"Basic.ShadowSampler." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
ix)
    pure (Sampler
shadowSampler, ImageView
depthView)

  env
context <- ResourceT m env
forall r (m :: * -> *). MonadReader r m => m r
ask
  env
-> Tagged '[Scene] (Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> Vector (Sampler, ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT m ()
forall context (textures :: * -> *) (cubes :: * -> *)
       (m :: * -> *).
(HasVulkan context, Traversable textures, Traversable cubes,
 MonadIO m) =>
context
-> Tagged '[Scene] (Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> Vector (Sampler, ImageView)
-> Maybe (Allocated 'Coherent Material)
-> m ()
updateSet0Ds
    env
context
    (Vector DescriptorSet -> Tagged '[Scene] (Vector DescriptorSet)
forall {k} (s :: k) b. b -> Tagged s b
Tagged Vector DescriptorSet
descSets)
    Allocated 'Coherent Scene
sceneData
    textures (Texture Flat)
textures
    cubes (Texture CubeMap)
cubes
    Maybe (Allocated 'Coherent Sun)
lightsData
    Vector (Sampler, ImageView)
shadowMaps
    Maybe (Allocated 'Coherent Material)
materialsData

  ObserverIO Scene
observer <- Scene -> ResourceT m (ObserverIO Scene)
forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO Scene
emptyScene

  pure FrameResource
    { $sel:frDescSets:FrameResource :: Tagged '[Scene] (Vector DescriptorSet)
frDescSets = Vector DescriptorSet -> Tagged '[Scene] (Vector DescriptorSet)
forall {k} (s :: k) b. b -> Tagged s b
Tagged Vector DescriptorSet
descSets
    , $sel:frBuffer:FrameResource :: Allocated 'Coherent Scene
frBuffer = Allocated 'Coherent Scene
sceneData
    , $sel:frObserver:FrameResource :: ObserverIO Scene
frObserver = ObserverIO Scene
observer
    }

dpSizes :: [(Vk.DescriptorType, Word32)]
dpSizes :: [(DescriptorType, Word32)]
dpSizes =
  [ ( DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
    , Word32
uniformBuffers
    )
  , ( DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE
    , Word32
sampledImages
    )
  , ( DescriptorType
Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
    , Word32
sampledImages Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
shadowMaps
    )
  , ( DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLER
    , Word32
staticSamplers
    )
  ]
  where
    uniformBuffers :: Word32
uniformBuffers = Word32
3    -- 1 scene + 1 light array + 1 material array
    sampledImages :: Word32
sampledImages  = Word32
128  -- max dynamic textures and cubemaps
    staticSamplers :: Word32
staticSamplers = Word32
8    -- immutable samplers
    shadowMaps :: Word32
shadowMaps     = Word32
2    -- max shadowmaps

-- | Minimal viable 'Scene' without textures and lighting.
allocateEmpty
  :: ( MonadVulkan env m
     , ResourceT.MonadResource m
     )
  => Tagged '[Scene] Vk.DescriptorSetLayout
  -> ResourceT m (FrameResource '[Scene])
allocateEmpty :: forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Tagged '[Scene] DescriptorSetLayout
-> ResourceT m (FrameResource '[Scene])
allocateEmpty Tagged '[Scene] DescriptorSetLayout
taggedLayout =
  Tagged '[Scene] DescriptorSetLayout
-> Maybe (Texture Flat)
-> Maybe (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT m (FrameResource '[Scene])
forall (textures :: * -> *) (cubes :: * -> *) env (m :: * -> *).
(Traversable textures, Traversable cubes, MonadVulkan env m,
 MonadResource m) =>
Tagged '[Scene] DescriptorSetLayout
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT m (FrameResource '[Scene])
allocate Tagged '[Scene] DescriptorSetLayout
taggedLayout Maybe (Texture Flat)
forall a. Maybe a
Nothing Maybe (Texture CubeMap)
forall a. Maybe a
Nothing Maybe (Allocated 'Coherent Sun)
forall a. Maybe a
Nothing "shadow maps" ::: Vector ImageView
forall a. Monoid a => a
mempty Maybe (Allocated 'Coherent Material)
forall a. Maybe a
Nothing

updateSet0Ds
  :: ( HasVulkan context
     , Traversable textures
     , Traversable cubes
     , MonadIO m
     )
  => context
  -> Tagged '[Scene] (Vector Vk.DescriptorSet)
  -> Buffer.Allocated 'Buffer.Coherent Scene
  -> textures (Texture.Texture Texture.Flat)
  -> cubes (Texture.Texture Texture.CubeMap)
  -> Maybe (Buffer.Allocated 'Buffer.Coherent Sun)
  -> Vector (Vk.Sampler, Vk.ImageView)
  -> Maybe (Buffer.Allocated 'Buffer.Coherent Material)
  -> m ()
updateSet0Ds :: forall context (textures :: * -> *) (cubes :: * -> *)
       (m :: * -> *).
(HasVulkan context, Traversable textures, Traversable cubes,
 MonadIO m) =>
context
-> Tagged '[Scene] (Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> Vector (Sampler, ImageView)
-> Maybe (Allocated 'Coherent Material)
-> m ()
updateSet0Ds context
context (Tagged Vector DescriptorSet
ds) Allocated 'Coherent Scene
sceneData textures (Texture Flat)
textures cubes (Texture CubeMap)
cubes Maybe (Allocated 'Coherent Sun)
lightsData Vector (Sampler, ImageView)
shadowMaps Maybe (Allocated 'Coherent Material)
materialsData =
  Device
-> Vector (SomeStruct WriteDescriptorSet)
-> Vector CopyDescriptorSet
-> m ()
forall (io :: * -> *).
MonadIO io =>
Device
-> Vector (SomeStruct WriteDescriptorSet)
-> Vector CopyDescriptorSet
-> io ()
Vk.updateDescriptorSets (context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context) Vector (SomeStruct WriteDescriptorSet)
writeSets Vector CopyDescriptorSet
forall a. Monoid a => a
mempty

  where
    linearTextures :: Vector (Texture Flat)
linearTextures = textures (Texture Flat) -> Vector (Texture Flat)
forall (collection :: * -> *) a.
Foldable collection =>
collection a -> Vector a
Collection.toVector textures (Texture Flat)
textures
    linearCubes :: Vector (Texture CubeMap)
linearCubes = cubes (Texture CubeMap) -> Vector (Texture CubeMap)
forall (collection :: * -> *) a.
Foldable collection =>
collection a -> Vector a
Collection.toVector cubes (Texture CubeMap)
cubes

    destSet0 :: DescriptorSet
destSet0 = case Vector DescriptorSet -> Maybe DescriptorSet
forall (m :: * -> *) a. Monad m => Vector a -> m a
Vector.headM Vector DescriptorSet
ds of
      Maybe DescriptorSet
Nothing ->
        String -> DescriptorSet
forall a. HasCallStack => String -> a
error String
"assert: descriptor sets promised to contain [Scene]"
      Just DescriptorSet
one ->
        DescriptorSet
one

    writeSet0b0 :: SomeStruct WriteDescriptorSet
writeSet0b0 = WriteDescriptorSet '[] -> SomeStruct WriteDescriptorSet
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct WriteDescriptorSet '[]
forall a. Zero a => a
zero
      { $sel:dstSet:WriteDescriptorSet :: DescriptorSet
Vk.dstSet          = DescriptorSet
destSet0
      , $sel:dstBinding:WriteDescriptorSet :: Word32
Vk.dstBinding      = Word32
0
      , $sel:dstArrayElement:WriteDescriptorSet :: Word32
Vk.dstArrayElement = Word32
0
      , $sel:descriptorCount:WriteDescriptorSet :: Word32
Vk.descriptorCount = Word32
1
      , $sel:descriptorType:WriteDescriptorSet :: DescriptorType
Vk.descriptorType  = DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
      , $sel:bufferInfo:WriteDescriptorSet :: Vector DescriptorBufferInfo
Vk.bufferInfo      = DescriptorBufferInfo -> Vector DescriptorBufferInfo
forall a. a -> Vector a
Vector.singleton DescriptorBufferInfo
set0bind0I
      }
      where
        set0bind0I :: DescriptorBufferInfo
set0bind0I = Vk.DescriptorBufferInfo
          { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.buffer = Allocated 'Coherent Scene -> Buffer
forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
Buffer.aBuffer Allocated 'Coherent Scene
sceneData
          , $sel:offset:DescriptorBufferInfo :: DeviceSize
Vk.offset = DeviceSize
0
          , $sel:range:DescriptorBufferInfo :: DeviceSize
Vk.range  = DeviceSize
Vk.WHOLE_SIZE
          }

    writeSet0b2 :: SomeStruct WriteDescriptorSet
writeSet0b2 = WriteDescriptorSet '[] -> SomeStruct WriteDescriptorSet
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct WriteDescriptorSet '[]
forall a. Zero a => a
zero
      { $sel:dstSet:WriteDescriptorSet :: DescriptorSet
Vk.dstSet          = DescriptorSet
destSet0
      , $sel:dstBinding:WriteDescriptorSet :: Word32
Vk.dstBinding      = Word32
2
      , $sel:descriptorType:WriteDescriptorSet :: DescriptorType
Vk.descriptorType  = DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE
      , $sel:dstArrayElement:WriteDescriptorSet :: Word32
Vk.dstArrayElement = Word32
0
      , $sel:descriptorCount:WriteDescriptorSet :: Word32
Vk.descriptorCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector (Texture Flat) -> Int
forall a. Vector a -> Int
Vector.length Vector (Texture Flat)
linearTextures
      , $sel:imageInfo:WriteDescriptorSet :: Vector DescriptorImageInfo
Vk.imageInfo       = Vector DescriptorImageInfo
textureInfos
      }
      where
        textureInfos :: Vector DescriptorImageInfo
textureInfos = do
          Texture Flat
texture <- Vector (Texture Flat)
linearTextures
          pure Vk.DescriptorImageInfo
            { $sel:sampler:DescriptorImageInfo :: Sampler
sampler     = Sampler
forall a. Zero a => a
zero
            , $sel:imageView:DescriptorImageInfo :: ImageView
imageView   = AllocatedImage -> ImageView
Image.aiImageView (AllocatedImage -> ImageView) -> AllocatedImage -> ImageView
forall a b. (a -> b) -> a -> b
$ Texture Flat -> AllocatedImage
forall {k} (tag :: k). Texture tag -> AllocatedImage
Texture.tAllocatedImage Texture Flat
texture
            , $sel:imageLayout:DescriptorImageInfo :: ImageLayout
imageLayout = ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
            }

    writeSet0b3 :: SomeStruct WriteDescriptorSet
writeSet0b3 = WriteDescriptorSet '[] -> SomeStruct WriteDescriptorSet
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct WriteDescriptorSet '[]
forall a. Zero a => a
zero
      { $sel:dstSet:WriteDescriptorSet :: DescriptorSet
Vk.dstSet          = DescriptorSet
destSet0
      , $sel:dstBinding:WriteDescriptorSet :: Word32
Vk.dstBinding      = Word32
3
      , $sel:descriptorType:WriteDescriptorSet :: DescriptorType
Vk.descriptorType  = DescriptorType
Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE
      , $sel:dstArrayElement:WriteDescriptorSet :: Word32
Vk.dstArrayElement = Word32
0
      , $sel:descriptorCount:WriteDescriptorSet :: Word32
Vk.descriptorCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector (Texture CubeMap) -> Int
forall a. Vector a -> Int
Vector.length Vector (Texture CubeMap)
linearCubes
      , $sel:imageInfo:WriteDescriptorSet :: Vector DescriptorImageInfo
Vk.imageInfo       = Vector DescriptorImageInfo
cubeInfos
      }
      where
        cubeInfos :: Vector DescriptorImageInfo
cubeInfos = do
          Texture CubeMap
cube <- Vector (Texture CubeMap)
linearCubes
          pure Vk.DescriptorImageInfo
            { $sel:sampler:DescriptorImageInfo :: Sampler
sampler     = Sampler
forall a. Zero a => a
zero
            , $sel:imageView:DescriptorImageInfo :: ImageView
imageView   = AllocatedImage -> ImageView
Image.aiImageView (AllocatedImage -> ImageView) -> AllocatedImage -> ImageView
forall a b. (a -> b) -> a -> b
$ Texture CubeMap -> AllocatedImage
forall {k} (tag :: k). Texture tag -> AllocatedImage
Texture.tAllocatedImage Texture CubeMap
cube
            , $sel:imageLayout:DescriptorImageInfo :: ImageLayout
imageLayout = ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
            }

    writeSet0b4M :: Vector (SomeStruct WriteDescriptorSet)
writeSet0b4M =
      case Maybe (Allocated 'Coherent Sun)
lightsData of
        Maybe (Allocated 'Coherent Sun)
Nothing ->
          Vector (SomeStruct WriteDescriptorSet)
forall a. Vector a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Allocated 'Coherent Sun
someLights ->
          SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeStruct WriteDescriptorSet
 -> Vector (SomeStruct WriteDescriptorSet))
-> SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall a b. (a -> b) -> a -> b
$ WriteDescriptorSet '[] -> SomeStruct WriteDescriptorSet
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct WriteDescriptorSet '[]
forall a. Zero a => a
zero
            { $sel:dstSet:WriteDescriptorSet :: DescriptorSet
Vk.dstSet          = DescriptorSet
destSet0
            , $sel:dstBinding:WriteDescriptorSet :: Word32
Vk.dstBinding      = Word32
4
            , $sel:dstArrayElement:WriteDescriptorSet :: Word32
Vk.dstArrayElement = Word32
0
            , $sel:descriptorCount:WriteDescriptorSet :: Word32
Vk.descriptorCount = Word32
1
            , $sel:descriptorType:WriteDescriptorSet :: DescriptorType
Vk.descriptorType  = DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
            , $sel:bufferInfo:WriteDescriptorSet :: Vector DescriptorBufferInfo
Vk.bufferInfo      = DescriptorBufferInfo -> Vector DescriptorBufferInfo
forall a. a -> Vector a
Vector.singleton DescriptorBufferInfo
set0bind4I
            }
          where
            set0bind4I :: DescriptorBufferInfo
set0bind4I = Vk.DescriptorBufferInfo
              { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.buffer = Allocated 'Coherent Sun -> Buffer
forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
Buffer.aBuffer Allocated 'Coherent Sun
someLights
              , $sel:offset:DescriptorBufferInfo :: DeviceSize
Vk.offset = DeviceSize
0
              , $sel:range:DescriptorBufferInfo :: DeviceSize
Vk.range  = DeviceSize
Vk.WHOLE_SIZE
              }

    writeSet0b5 :: SomeStruct WriteDescriptorSet
writeSet0b5 = WriteDescriptorSet '[] -> SomeStruct WriteDescriptorSet
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct WriteDescriptorSet '[]
forall a. Zero a => a
zero
      { $sel:dstSet:WriteDescriptorSet :: DescriptorSet
Vk.dstSet          = DescriptorSet
destSet0
      , $sel:dstBinding:WriteDescriptorSet :: Word32
Vk.dstBinding      = Word32
5
      , $sel:descriptorType:WriteDescriptorSet :: DescriptorType
Vk.descriptorType  = DescriptorType
Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
      , $sel:dstArrayElement:WriteDescriptorSet :: Word32
Vk.dstArrayElement = Word32
0
      , $sel:descriptorCount:WriteDescriptorSet :: Word32
Vk.descriptorCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector (Sampler, ImageView) -> Int
forall a. Vector a -> Int
Vector.length Vector (Sampler, ImageView)
shadowMaps
      , $sel:imageInfo:WriteDescriptorSet :: Vector DescriptorImageInfo
Vk.imageInfo       = Vector DescriptorImageInfo
shadowInfos
      }
      where
        shadowInfos :: Vector DescriptorImageInfo
shadowInfos = do
          (Sampler
shadowSampler, ImageView
shadowImageView) <- Vector (Sampler, ImageView)
shadowMaps
          DescriptorImageInfo -> Vector DescriptorImageInfo
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vk.DescriptorImageInfo
            { $sel:sampler:DescriptorImageInfo :: Sampler
sampler     = Sampler
shadowSampler
            , $sel:imageView:DescriptorImageInfo :: ImageView
imageView   = ImageView
shadowImageView
            , $sel:imageLayout:DescriptorImageInfo :: ImageLayout
imageLayout = ImageLayout
Vk.IMAGE_LAYOUT_DEPTH_STENCIL_READ_ONLY_OPTIMAL
            }

    writeSet0b6M :: Vector (SomeStruct WriteDescriptorSet)
writeSet0b6M =
      case Maybe (Allocated 'Coherent Material)
materialsData of
        Maybe (Allocated 'Coherent Material)
Nothing ->
          Vector (SomeStruct WriteDescriptorSet)
forall a. Vector a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Allocated 'Coherent Material
someMaterials ->
          SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeStruct WriteDescriptorSet
 -> Vector (SomeStruct WriteDescriptorSet))
-> SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall a b. (a -> b) -> a -> b
$ WriteDescriptorSet '[] -> SomeStruct WriteDescriptorSet
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct WriteDescriptorSet '[]
forall a. Zero a => a
zero
            { $sel:dstSet:WriteDescriptorSet :: DescriptorSet
Vk.dstSet          = DescriptorSet
destSet0
            , $sel:dstBinding:WriteDescriptorSet :: Word32
Vk.dstBinding      = Word32
6
            , $sel:dstArrayElement:WriteDescriptorSet :: Word32
Vk.dstArrayElement = Word32
0
            , $sel:descriptorCount:WriteDescriptorSet :: Word32
Vk.descriptorCount = Word32
1
            , $sel:descriptorType:WriteDescriptorSet :: DescriptorType
Vk.descriptorType  = DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
            , $sel:bufferInfo:WriteDescriptorSet :: Vector DescriptorBufferInfo
Vk.bufferInfo      = DescriptorBufferInfo -> Vector DescriptorBufferInfo
forall a. a -> Vector a
Vector.singleton DescriptorBufferInfo
set0bind6I
            }
          where
            set0bind6I :: DescriptorBufferInfo
set0bind6I = Vk.DescriptorBufferInfo
              { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.buffer = Allocated 'Coherent Material -> Buffer
forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
Buffer.aBuffer Allocated 'Coherent Material
someMaterials
              , $sel:offset:DescriptorBufferInfo :: DeviceSize
Vk.offset = DeviceSize
0
              , $sel:range:DescriptorBufferInfo :: DeviceSize
Vk.range  = DeviceSize
Vk.WHOLE_SIZE
              }

    writeSets :: Vector (SomeStruct WriteDescriptorSet)
writeSets = [Vector (SomeStruct WriteDescriptorSet)]
-> Vector (SomeStruct WriteDescriptorSet)
forall a. [Vector a] -> Vector a
Vector.concat
      [ SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeStruct WriteDescriptorSet
writeSet0b0
      -- XXX: binding 1 is immutable samplers, baked into layout.
      , Vector (Texture Flat)
-> SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall {f :: * -> *} {a} {a}.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Texture Flat)
linearTextures SomeStruct WriteDescriptorSet
writeSet0b2
      , Vector (Texture CubeMap)
-> SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall {f :: * -> *} {a} {a}.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Texture CubeMap)
linearCubes SomeStruct WriteDescriptorSet
writeSet0b3
      , Item [Vector (SomeStruct WriteDescriptorSet)]
Vector (SomeStruct WriteDescriptorSet)
writeSet0b4M
      , Vector (Sampler, ImageView)
-> SomeStruct WriteDescriptorSet
-> Vector (SomeStruct WriteDescriptorSet)
forall {f :: * -> *} {a} {a}.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Sampler, ImageView)
shadowMaps SomeStruct WriteDescriptorSet
writeSet0b5
      , Item [Vector (SomeStruct WriteDescriptorSet)]
Vector (SomeStruct WriteDescriptorSet)
writeSet0b6M
      ]
      where
        skipEmpty :: Vector a -> a -> f a
skipEmpty Vector a
items a
writer
          | Vector a -> Bool
forall a. Vector a -> Bool
Vector.null Vector a
items = f a
forall a. Monoid a => a
mempty
          | Bool
otherwise = a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
writer

extendResourceDS
  :: FrameResource ds
  -> Tagged ext Vk.DescriptorSet
  -> FrameResource (Extend ds ext)
extendResourceDS :: forall (ds :: [*]) ext.
FrameResource ds
-> Tagged ext DescriptorSet -> FrameResource (Extend ds ext)
extendResourceDS FrameResource{ObserverIO Scene
Tagged ds (Vector DescriptorSet)
Allocated 'Coherent Scene
$sel:frDescSets:FrameResource :: forall (ds :: [*]).
FrameResource ds -> Tagged ds (Vector DescriptorSet)
$sel:frBuffer:FrameResource :: forall (ds :: [*]). FrameResource ds -> Allocated 'Coherent Scene
$sel:frObserver:FrameResource :: forall (ds :: [*]). FrameResource ds -> ObserverIO Scene
frDescSets :: Tagged ds (Vector DescriptorSet)
frBuffer :: Allocated 'Coherent Scene
frObserver :: ObserverIO Scene
..} Tagged ext DescriptorSet
ext = FrameResource
  { $sel:frDescSets:FrameResource :: Tagged (Extend ds ext) (Vector DescriptorSet)
frDescSets = Tagged ds (Vector DescriptorSet)
-> Tagged ext DescriptorSet
-> Tagged (Extend ds ext) (Vector DescriptorSet)
forall (as :: [*]) b.
Tagged as (Vector DescriptorSet)
-> Tagged b DescriptorSet
-> Tagged (Extend as b) (Vector DescriptorSet)
extendDS Tagged ds (Vector DescriptorSet)
frDescSets Tagged ext DescriptorSet
ext
  , ObserverIO Scene
Allocated 'Coherent Scene
$sel:frBuffer:FrameResource :: Allocated 'Coherent Scene
$sel:frObserver:FrameResource :: ObserverIO Scene
frBuffer :: Allocated 'Coherent Scene
frObserver :: ObserverIO Scene
..
  }

-- * Frame data

data FrameResource (ds :: [Type]) = FrameResource
  { forall (ds :: [*]).
FrameResource ds -> Tagged ds (Vector DescriptorSet)
frDescSets :: Tagged ds (Vector Vk.DescriptorSet)
  , forall (ds :: [*]). FrameResource ds -> Allocated 'Coherent Scene
frBuffer   :: Buffer
  , forall (ds :: [*]). FrameResource ds -> ObserverIO Scene
frObserver :: Worker.ObserverIO Scene
  }

type Buffer = Buffer.Allocated 'Buffer.Coherent Scene

-- | A process that will assemble 'Scene' values.
type Process = Worker.Merge Scene

observe
  :: (MonadUnliftIO m) -- TODO: compatible '[Scene]
  => Process -> FrameResource ds -> m ()
observe :: forall (m :: * -> *) (ds :: [*]).
MonadUnliftIO m =>
Process -> FrameResource ds -> m ()
observe Process
process FrameResource{Allocated 'Coherent Scene
$sel:frBuffer:FrameResource :: forall (ds :: [*]). FrameResource ds -> Allocated 'Coherent Scene
frBuffer :: Allocated 'Coherent Scene
frBuffer, ObserverIO Scene
$sel:frObserver:FrameResource :: forall (ds :: [*]). FrameResource ds -> ObserverIO Scene
frObserver :: ObserverIO Scene
frObserver}=
  Process
-> ObserverIO Scene
-> (Scene -> GetOutput Process -> m Scene)
-> m ()
forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m ()
Worker.observeIO_ Process
process ObserverIO Scene
frObserver \Scene
_old GetOutput Process
new -> do
    Allocated 'Coherent Scene
_same <- Vector Scene
-> Allocated 'Coherent Scene -> m (Allocated 'Coherent Scene)
forall (io :: * -> *) a.
(MonadUnliftIO io, Storable a) =>
Vector a -> Allocated 'Coherent a -> io (Allocated 'Coherent a)
Buffer.updateCoherent (Scene -> Vector Scene
forall a. Storable a => a -> Vector a
VectorS.singleton GetOutput Process
Scene
new) Allocated 'Coherent Scene
frBuffer
    pure GetOutput Process
Scene
new

-- * Rendering

withBoundSet0
  :: MonadIO m
  => FrameResource ds
  -> Pipeline ds vertices instances
  -> Vk.CommandBuffer
  -> Bound ds Void Void m b
  -> m b
withBoundSet0 :: forall {k} {k1} (m :: * -> *) (ds :: [*]) (vertices :: k)
       (instances :: k1) b.
MonadIO m =>
FrameResource ds
-> Pipeline ds vertices instances
-> CommandBuffer
-> Bound ds Void Void m b
-> m b
withBoundSet0 FrameResource{Tagged ds (Vector DescriptorSet)
$sel:frDescSets:FrameResource :: forall (ds :: [*]).
FrameResource ds -> Tagged ds (Vector DescriptorSet)
frDescSets :: Tagged ds (Vector DescriptorSet)
frDescSets} Pipeline ds vertices instances
refPipeline CommandBuffer
cb =
  CommandBuffer
-> PipelineBindPoint
-> Tagged ds PipelineLayout
-> Tagged ds (Vector DescriptorSet)
-> Bound ds Void Void m b
-> m b
forall (m :: * -> *) (dsl :: [*]) b.
MonadIO m =>
CommandBuffer
-> PipelineBindPoint
-> Tagged dsl PipelineLayout
-> Tagged dsl (Vector DescriptorSet)
-> Bound dsl Void Void m b
-> m b
withBoundDescriptorSets0
    CommandBuffer
cb
    PipelineBindPoint
Vk.PIPELINE_BIND_POINT_GRAPHICS
    (Pipeline ds vertices instances -> Tagged ds PipelineLayout
forall {k1} {k2} (dsl :: [*]) (vertices :: k1) (instances :: k2).
Pipeline dsl vertices instances -> Tagged dsl PipelineLayout
Pipeline.pLayout Pipeline ds vertices instances
refPipeline)
    Tagged ds (Vector DescriptorSet)
frDescSets