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

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

  , allocate
  , allocateEmpty

  , updateSet0Ds

  , mkBindings

  -- TODO: extract to typeclass magic
  , vertexPos
  , instanceTransform

  , 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.ByteString.Char8 qualified as BS8
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.Utils.Debug qualified as Debug
import Vulkan.Zero (Zero(..))

import Engine.Types (StageRIO)
import Engine.Vulkan.DescSets (Bound, Extend, extendDS, withBoundDescriptorSets0)
import Engine.Vulkan.Pipeline (Pipeline)
import Engine.Vulkan.Pipeline qualified as Pipeline
import Engine.Vulkan.Types (DsBindings, 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.DescriptorSet qualified as DescriptorSet
import Resource.Image qualified as Image
import Resource.Texture qualified as Texture

-- * 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
showList :: [Scene] -> ShowS
$cshowList :: [Scene] -> ShowS
show :: Scene -> String
$cshow :: Scene -> String
showsPrec :: Int -> Scene -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep Scene x -> Scene
$cfrom :: forall x. Scene -> Rep Scene x
Generic)

instance GStorable Scene

emptyScene :: Scene
emptyScene :: Scene
emptyScene = Scene :: Transform
-> Transform
-> Transform
-> Transform
-> Vec3
-> Vec3
-> Vec4
-> Vec4
-> Int32
-> Word32
-> Scene
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 DsBindings
mkBindings :: samplers Sampler
-> textures a -> cubemaps b -> Word32 -> Tagged Scene DsBindings
mkBindings samplers Sampler
samplers textures a
textures cubemaps b
cubes Word32
shadows = DsBindings -> Tagged Scene DsBindings
forall k (s :: k) b. b -> Tagged s b
Tagged
  [ (DescriptorSetLayoutBinding
set0bind0,          DescriptorBindingFlagBits
forall a. Zero a => a
zero)
  , (samplers Sampler -> DescriptorSetLayoutBinding
forall (samplers :: * -> *).
Foldable samplers =>
samplers Sampler -> DescriptorSetLayoutBinding
set0bind1 samplers Sampler
samplers, DescriptorBindingFlagBits
forall a. Zero a => a
zero)
  , (textures a -> DescriptorSetLayoutBinding
forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind2 textures a
textures, DescriptorBindingFlagBits
partialBinding)
  , (cubemaps b -> DescriptorSetLayoutBinding
forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind3 cubemaps b
cubes,    DescriptorBindingFlagBits
partialBinding)
  , (DescriptorSetLayoutBinding
set0bind4,          DescriptorBindingFlagBits
forall a. Zero a => a
zero)
  , (Word32 -> DescriptorSetLayoutBinding
set0bind5 Word32
shadows,  DescriptorBindingFlagBits
partialBinding)
  , (DescriptorSetLayoutBinding
set0bind6,          DescriptorBindingFlagBits
forall a. Zero a => a
zero)
  ]
  where
    partialBinding :: DescriptorBindingFlagBits
partialBinding =
      DescriptorBindingFlagBits
Vk12.DESCRIPTOR_BINDING_PARTIALLY_BOUND_BIT

    _partialVariable :: DescriptorBindingFlagBits
_partialVariable =
      DescriptorBindingFlagBits
partialBinding DescriptorBindingFlagBits
-> DescriptorBindingFlagBits -> DescriptorBindingFlagBits
forall a. Bits a => a -> a -> a
.|.
      DescriptorBindingFlagBits
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 = DescriptorSetLayoutBinding :: Word32
-> DescriptorType
-> Word32
-> ShaderStageFlags
-> Vector Sampler
-> DescriptorSetLayoutBinding
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 :: samplers Sampler -> DescriptorSetLayoutBinding
set0bind1 samplers Sampler
samplers = DescriptorSetLayoutBinding :: Word32
-> DescriptorType
-> Word32
-> ShaderStageFlags
-> Vector Sampler
-> DescriptorSetLayoutBinding
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 :: textures a -> DescriptorSetLayoutBinding
set0bind2 textures a
textures = DescriptorSetLayoutBinding :: Word32
-> DescriptorType
-> Word32
-> ShaderStageFlags
-> Vector Sampler
-> DescriptorSetLayoutBinding
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 (t :: * -> *) a. Foldable t => t a -> Int
length Collection Source
BaseTexture.sources
    textureCount :: Int
textureCount = textures a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length textures a
textures

set0bind3
  :: Foldable cubes
  => cubes a
  -> Vk.DescriptorSetLayoutBinding
set0bind3 :: cubes a -> DescriptorSetLayoutBinding
set0bind3 cubes a
cubes = DescriptorSetLayoutBinding :: Word32
-> DescriptorType
-> Word32
-> ShaderStageFlags
-> Vector Sampler
-> DescriptorSetLayoutBinding
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 (t :: * -> *) a. Foldable t => t a -> Int
length Collection Source
BaseCubeMap.sources
    cubeCount :: Int
cubeCount = cubes a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length cubes a
cubes

set0bind4 :: Vk.DescriptorSetLayoutBinding
set0bind4 :: DescriptorSetLayoutBinding
set0bind4 = DescriptorSetLayoutBinding :: Word32
-> DescriptorType
-> Word32
-> ShaderStageFlags
-> Vector Sampler
-> DescriptorSetLayoutBinding
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 = DescriptorSetLayoutBinding :: Word32
-> DescriptorType
-> Word32
-> ShaderStageFlags
-> Vector Sampler
-> DescriptorSetLayoutBinding
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 = DescriptorSetLayoutBinding :: Word32
-> DescriptorType
-> Word32
-> ShaderStageFlags
-> Vector Sampler
-> DescriptorSetLayoutBinding
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
  }

vertexPos :: (Vk.VertexInputRate, [Vk.Format])
vertexPos :: (VertexInputRate, [Format])
vertexPos =
  ( VertexInputRate
Vk.VERTEX_INPUT_RATE_VERTEX
  , [ Format
Vk.FORMAT_R32G32B32_SFLOAT -- vPosition :: vec3
    ]
  )

instanceTransform :: (Vk.VertexInputRate, [Vk.Format])
instanceTransform :: (VertexInputRate, [Format])
instanceTransform =
  ( VertexInputRate
Vk.VERTEX_INPUT_RATE_INSTANCE
  , [ Format
Vk.FORMAT_R32G32B32A32_SFLOAT -- iModel :: mat4
    , Format
Vk.FORMAT_R32G32B32A32_SFLOAT
    , Format
Vk.FORMAT_R32G32B32A32_SFLOAT
    , Format
Vk.FORMAT_R32G32B32A32_SFLOAT
    ]
  )

-- * Setup

allocate
  :: (Traversable textures, Traversable cubes)
  => 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 (StageRIO st) (FrameResource '[Scene])
allocate :: Tagged '[Scene] DescriptorSetLayout
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO st) (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
  App GlobalHandles st
context <- (App GlobalHandles st -> App GlobalHandles st)
-> ResourceT (StageRIO st) (App GlobalHandles st)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles st -> App GlobalHandles st
forall a. a -> a
id

  (ReleaseKey
_dpKey, DescriptorPool
descPool) <- Word32
-> TypeMap Word32
-> ResourceT (StageRIO st) (ReleaseKey, DescriptorPool)
forall (m :: * -> *) env.
(MonadResource m, MonadReader env m, HasVulkan env) =>
Word32 -> TypeMap Word32 -> m (ReleaseKey, DescriptorPool)
DescriptorSet.allocatePool Word32
1 TypeMap Word32
dpSizes

  let
    set0dsCI :: DescriptorSetAllocateInfo '[]
set0dsCI = DescriptorSetAllocateInfo '[]
forall a. Zero a => a
zero
      { $sel:descriptorPool:DescriptorSetAllocateInfo :: DescriptorPool
Vk.descriptorPool = DescriptorPool
descPool
      , $sel:setLayouts:DescriptorSetAllocateInfo :: Vector DescriptorSetLayout
Vk.setLayouts     = DescriptorSetLayout -> Vector DescriptorSetLayout
forall a. a -> Vector a
Vector.singleton DescriptorSetLayout
set0layout
      }
  Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet)
descSets <- (("descriptorSets" ::: Vector DescriptorSet)
 -> Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet))
-> ResourceT
     (StageRIO st) ("descriptorSets" ::: Vector DescriptorSet)
-> ResourceT
     (StageRIO st)
     (Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b. b -> Tagged '[Scene] b
forall k (s :: k) b. b -> Tagged s b
Tagged @'[Scene]) (ResourceT
   (StageRIO st) ("descriptorSets" ::: Vector DescriptorSet)
 -> ResourceT
      (StageRIO st)
      (Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet)))
-> ResourceT
     (StageRIO st) ("descriptorSets" ::: Vector DescriptorSet)
-> ResourceT
     (StageRIO st)
     (Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet))
forall a b. (a -> b) -> a -> b
$
    Device
-> DescriptorSetAllocateInfo '[]
-> ResourceT
     (StageRIO st) ("descriptorSets" ::: Vector DescriptorSet)
forall (a :: [*]) (io :: * -> *).
(Extendss DescriptorSetAllocateInfo a, PokeChain a, MonadIO io) =>
Device
-> DescriptorSetAllocateInfo a
-> io ("descriptorSets" ::: Vector DescriptorSet)
Vk.allocateDescriptorSets (App GlobalHandles st -> Device
forall a. HasVulkan a => a -> Device
getDevice App GlobalHandles st
context) DescriptorSetAllocateInfo '[]
set0dsCI

  (ReleaseKey
_, Allocated 'Coherent Scene
sceneData) <- IO (Allocated 'Coherent Scene)
-> (Allocated 'Coherent Scene -> IO ())
-> ResourceT (StageRIO st) (ReleaseKey, Allocated 'Coherent Scene)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
ResourceT.allocate
    (App GlobalHandles st
-> BufferUsageFlagBits
-> Int
-> Vector Scene
-> IO (Allocated 'Coherent Scene)
forall a context (io :: * -> *).
(Storable a, HasVulkan context, MonadUnliftIO io) =>
context
-> BufferUsageFlagBits
-> Int
-> Vector a
-> io (Allocated 'Coherent a)
Buffer.createCoherent App GlobalHandles st
context BufferUsageFlagBits
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT Int
1 (Vector Scene -> IO (Allocated 'Coherent Scene))
-> Vector Scene -> IO (Allocated 'Coherent Scene)
forall a b. (a -> b) -> a -> b
$ Scene -> Vector Scene
forall a. Storable a => a -> Vector a
VectorS.singleton Scene
emptyScene)
    (App GlobalHandles st -> Allocated 'Coherent Scene -> IO ()
forall (io :: * -> *) context (s :: Store) a.
(MonadUnliftIO io, HasVulkan context) =>
context -> Allocated s a -> io ()
Buffer.destroy App GlobalHandles st
context)

  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 (StageRIO st) b)
-> ResourceT (StageRIO st) (Vector b)
ifor = ((Int -> a -> ResourceT (StageRIO st) b)
 -> Vector a -> ResourceT (StageRIO st) (Vector b))
-> Vector a
-> (Int -> a -> ResourceT (StageRIO st) b)
-> ResourceT (StageRIO st) (Vector b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> a -> ResourceT (StageRIO st) b)
-> Vector a -> ResourceT (StageRIO st) (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 (StageRIO st) (Sampler, ImageView))
-> ResourceT (StageRIO st) (Vector (Sampler, ImageView))
forall a b.
Vector a
-> (Int -> a -> ResourceT (StageRIO st) b)
-> ResourceT (StageRIO st) (Vector b)
ifor "shadow maps" ::: Vector ImageView
shadowViews \Int
ix ImageView
depthView -> do
    (ReleaseKey
_, Sampler
shadowSampler) <- Device
-> SamplerCreateInfo '[]
-> Maybe AllocationCallbacks
-> (IO Sampler
    -> (Sampler -> IO ())
    -> ResourceT (StageRIO st) (ReleaseKey, Sampler))
-> ResourceT (StageRIO st) (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 (App GlobalHandles st -> Device
forall a. HasVulkan a => a -> Device
getDevice App GlobalHandles st
context) SamplerCreateInfo '[]
shadowCI Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO Sampler
-> (Sampler -> IO ())
-> ResourceT (StageRIO st) (ReleaseKey, Sampler)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
ResourceT.allocate
    Device -> Sampler -> ByteString -> ResourceT (StageRIO st) ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject (App GlobalHandles st -> Device
forall a. HasVulkan a => a -> Device
getDevice App GlobalHandles st
context) Sampler
shadowSampler (ByteString -> ResourceT (StageRIO st) ())
-> ByteString -> ResourceT (StageRIO st) ()
forall a b. (a -> b) -> a -> b
$
      ByteString
"ShadowSampler." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (Int -> String
forall a. Show a => a -> String
show Int
ix)
    pure (Sampler
shadowSampler, ImageView
depthView)

  App GlobalHandles st
-> Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> Vector (Sampler, ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO st) ()
forall context (textures :: * -> *) (cubes :: * -> *) st.
(HasVulkan context, Traversable textures, Traversable cubes) =>
context
-> Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> Vector (Sampler, ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO st) ()
updateSet0Ds App GlobalHandles st
context Tagged '[Scene] ("descriptorSets" ::: 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
scene <- Scene -> ResourceT (StageRIO st) (ObserverIO Scene)
forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO Scene
emptyScene

  pure $ Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> ObserverIO Scene
-> FrameResource '[Scene]
forall (ds :: [*]).
Tagged ds ("descriptorSets" ::: Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> ObserverIO Scene
-> FrameResource ds
FrameResource Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet)
descSets Allocated 'Coherent Scene
sceneData ObserverIO Scene
scene

dpSizes :: DescriptorSet.TypeMap Word32
dpSizes :: TypeMap 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
  :: Tagged '[Scene] Vk.DescriptorSetLayout
  -> ResourceT (StageRIO st) (FrameResource '[Scene])
allocateEmpty :: Tagged '[Scene] DescriptorSetLayout
-> ResourceT (StageRIO st) (FrameResource '[Scene])
allocateEmpty Tagged '[Scene] DescriptorSetLayout
taggedLayout = Tagged '[Scene] DescriptorSetLayout
-> [Texture Flat]
-> [Texture CubeMap]
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO st) (FrameResource '[Scene])
forall (textures :: * -> *) (cubes :: * -> *) st.
(Traversable textures, Traversable cubes) =>
Tagged '[Scene] DescriptorSetLayout
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO st) (FrameResource '[Scene])
allocate Tagged '[Scene] DescriptorSetLayout
taggedLayout [] [] 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)
  => 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)
  -> ResourceT (StageRIO st) ()
updateSet0Ds :: context
-> Tagged '[Scene] ("descriptorSets" ::: Vector DescriptorSet)
-> Allocated 'Coherent Scene
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> Vector (Sampler, ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO st) ()
updateSet0Ds context
context (Tagged "descriptorSets" ::: 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
-> ("descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet))
-> ("descriptorCopies" ::: Vector CopyDescriptorSet)
-> ResourceT (StageRIO st) ()
forall (io :: * -> *).
MonadIO io =>
Device
-> ("descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet))
-> ("descriptorCopies" ::: Vector CopyDescriptorSet)
-> io ()
Vk.updateDescriptorSets (context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context) "descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet)
writeSets "descriptorCopies" ::: 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 ("descriptorSets" ::: Vector DescriptorSet) -> Maybe DescriptorSet
forall (m :: * -> *) a. Monad m => Vector a -> m a
Vector.headM "descriptorSets" ::: 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 = DescriptorBufferInfo :: Buffer -> DeviceSize -> DeviceSize -> DescriptorBufferInfo
Vk.DescriptorBufferInfo
          { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.buffer = Allocated 'Coherent Scene -> Buffer
forall (s :: Store) a. 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 DescriptorImageInfo :: Sampler -> ImageView -> ImageLayout -> DescriptorImageInfo
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 a. Texture a -> 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 DescriptorImageInfo :: Sampler -> ImageView -> ImageLayout -> DescriptorImageInfo
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 a. Texture a -> AllocatedImage
Texture.tAllocatedImage Texture CubeMap
cube
            , $sel:imageLayout:DescriptorImageInfo :: ImageLayout
imageLayout = ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
            }

    writeSet0b4M :: [SomeStruct WriteDescriptorSet]
writeSet0b4M =
      case Maybe (Allocated 'Coherent Sun)
lightsData of
        Maybe (Allocated 'Coherent Sun)
Nothing ->
          [SomeStruct WriteDescriptorSet]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Allocated 'Coherent Sun
someLights ->
          SomeStruct WriteDescriptorSet -> [SomeStruct WriteDescriptorSet]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeStruct WriteDescriptorSet -> [SomeStruct WriteDescriptorSet])
-> SomeStruct WriteDescriptorSet -> [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 = DescriptorBufferInfo :: Buffer -> DeviceSize -> DeviceSize -> DescriptorBufferInfo
Vk.DescriptorBufferInfo
              { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.buffer = Allocated 'Coherent Sun -> Buffer
forall (s :: Store) a. 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 (f :: * -> *) a. Applicative f => a -> f a
pure DescriptorImageInfo :: Sampler -> ImageView -> ImageLayout -> DescriptorImageInfo
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 :: [SomeStruct WriteDescriptorSet]
writeSet0b6M =
      case Maybe (Allocated 'Coherent Material)
materialsData of
        Maybe (Allocated 'Coherent Material)
Nothing ->
          [SomeStruct WriteDescriptorSet]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Allocated 'Coherent Material
someMaterials ->
          SomeStruct WriteDescriptorSet -> [SomeStruct WriteDescriptorSet]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeStruct WriteDescriptorSet -> [SomeStruct WriteDescriptorSet])
-> SomeStruct WriteDescriptorSet -> [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 = DescriptorBufferInfo :: Buffer -> DeviceSize -> DeviceSize -> DescriptorBufferInfo
Vk.DescriptorBufferInfo
              { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.buffer = Allocated 'Coherent Material -> Buffer
forall (s :: Store) a. 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 :: "descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet)
writeSets = [SomeStruct WriteDescriptorSet]
-> "descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet)
forall a. [a] -> Vector a
Vector.fromList ([SomeStruct WriteDescriptorSet]
 -> "descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet))
-> [SomeStruct WriteDescriptorSet]
-> "descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet)
forall a b. (a -> b) -> a -> b
$ [[SomeStruct WriteDescriptorSet]]
-> [SomeStruct WriteDescriptorSet]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ SomeStruct WriteDescriptorSet -> [SomeStruct WriteDescriptorSet]
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 -> [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 -> [SomeStruct WriteDescriptorSet]
forall (f :: * -> *) a a.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Texture CubeMap)
linearCubes SomeStruct WriteDescriptorSet
writeSet0b3
      , [SomeStruct WriteDescriptorSet]
writeSet0b4M
      , Vector (Sampler, ImageView)
-> SomeStruct WriteDescriptorSet -> [SomeStruct WriteDescriptorSet]
forall (f :: * -> *) a a.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Sampler, ImageView)
shadowMaps SomeStruct WriteDescriptorSet
writeSet0b5
      , [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 (f :: * -> *) a. Applicative f => a -> f a
pure a
writer

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

-- * Frame data

data FrameResource (ds :: [Type]) = FrameResource
  { FrameResource ds
-> Tagged ds ("descriptorSets" ::: Vector DescriptorSet)
frDescSets :: Tagged ds (Vector Vk.DescriptorSet)
  , FrameResource ds -> Allocated 'Coherent Scene
frBuffer   :: Buffer
  , 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 :: Process -> FrameResource ds -> m ()
observe Process
process FrameResource{Allocated 'Coherent Scene
frBuffer :: Allocated 'Coherent Scene
$sel:frBuffer:FrameResource :: forall (ds :: [*]). FrameResource ds -> Allocated 'Coherent Scene
frBuffer, ObserverIO Scene
frObserver :: ObserverIO Scene
$sel:frObserver:FrameResource :: forall (ds :: [*]). FrameResource ds -> 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 a (io :: * -> *).
(Storable a, MonadUnliftIO io) =>
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 :: FrameResource ds
-> Pipeline ds vertices instances
-> CommandBuffer
-> Bound ds Void Void m b
-> m b
withBoundSet0 FrameResource{Tagged ds ("descriptorSets" ::: Vector DescriptorSet)
frDescSets :: Tagged ds ("descriptorSets" ::: Vector DescriptorSet)
$sel:frDescSets:FrameResource :: forall (ds :: [*]).
FrameResource ds
-> Tagged ds ("descriptorSets" ::: Vector DescriptorSet)
frDescSets} Pipeline ds vertices instances
refPipeline CommandBuffer
cb Bound ds Void Void m b
action =
  CommandBuffer
-> PipelineBindPoint
-> Tagged ds PipelineLayout
-> Tagged ds ("descriptorSets" ::: Vector DescriptorSet)
-> Bound ds Void Void m b
-> m b
forall (m :: * -> *) (dsl :: [*]) b.
MonadIO m =>
CommandBuffer
-> PipelineBindPoint
-> Tagged dsl PipelineLayout
-> Tagged dsl ("descriptorSets" ::: 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 (dsl :: [*]) vertices instances.
Pipeline dsl vertices instances -> Tagged dsl PipelineLayout
Pipeline.pLayout Pipeline ds vertices instances
refPipeline)
    Tagged ds ("descriptorSets" ::: Vector DescriptorSet)
frDescSets
    Bound ds Void Void m b
action