{-# 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
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. 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
  { $sel:sceneProjection:Scene :: Transform
sceneProjection    = forall a. Monoid a => a
mempty
  , $sel:sceneInvProjection:Scene :: Transform
sceneInvProjection = forall a. Monoid a => a
mempty

  , $sel:sceneView:Scene :: Transform
sceneView          = forall a. Monoid a => a
mempty
  , $sel:sceneInvView:Scene :: Transform
sceneInvView       = 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       = 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 = forall {k} (s :: k) b. b -> Tagged s b
Tagged
  [ (DescriptorSetLayoutBinding
set0bind0,          forall a. Zero a => a
zero)
  , (forall (samplers :: * -> *).
Foldable samplers =>
samplers Sampler -> DescriptorSetLayoutBinding
set0bind1 samplers Sampler
samplers, forall a. Zero a => a
zero)
  , (forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind2 textures a
textures, DescriptorBindingFlags
partialBinding)
  , (forall (textures :: * -> *) a.
Foldable textures =>
textures a -> DescriptorSetLayoutBinding
set0bind3 cubemaps b
cubes,    DescriptorBindingFlags
partialBinding)
  , (DescriptorSetLayoutBinding
set0bind4,          forall a. Zero a => a
zero)
  , (Word32 -> DescriptorSetLayoutBinding
set0bind5 Word32
shadows,  DescriptorBindingFlags
partialBinding)
  , (DescriptorSetLayoutBinding
set0bind6,          forall a. Zero a => a
zero)
  ]
  where
    partialBinding :: DescriptorBindingFlags
partialBinding =
      DescriptorBindingFlags
Vk12.DESCRIPTOR_BINDING_PARTIALLY_BOUND_BIT

    _partialVariable :: DescriptorBindingFlags
_partialVariable =
      DescriptorBindingFlags
partialBinding 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 = 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   = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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 = 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   = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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 = forall a. Monoid a => a
mempty
  }
  where
    baseTextures :: Int
baseTextures = forall (t :: * -> *) a. Foldable t => t a -> Int
length Collection Source
BaseTexture.sources
    textureCount :: Int
textureCount = 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   = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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 = forall a. Monoid a => a
mempty
  }
  where
    baseCubes :: Int
baseCubes = forall (t :: * -> *) a. Foldable t => t a -> Int
length Collection Source
BaseCubeMap.sources
    cubeCount :: Int
cubeCount = 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 = 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   = forall a. Ord a => a -> a -> a
max Word32
1 Word32
shadows
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = 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 = 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 <- forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Maybe Text
-> Word32
-> [(DescriptorType, Word32)]
-> m (ReleaseKey, DescriptorPool)
DescriptorPool.allocate (forall a. a -> Maybe a
Just Text
"Basic") Word32
1 [(DescriptorType, Word32)]
dpSizes

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

  Allocated 'Coherent Scene
sceneData <- forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (ReleaseKey, Allocated 'Coherent a)
Buffer.allocateCoherent
    (forall a. a -> Maybe a
Just Text
"Basic.Data")
    BufferUsageFlagBits
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT
    Int
1
    [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 = 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
Monad m =>
(Int -> a -> m b) -> Vector a -> m (Vector b)
Vector.imapM
  Vector (Sampler, ImageView)
shadowMaps <- 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 <- forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local do
      Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
      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 forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
ResourceT.allocate
    forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object Sampler
shadowSampler forall a b. (a -> b) -> a -> b
$
      Text
"Basic.ShadowSampler." forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Int
ix)
    pure (Sampler
shadowSampler, ImageView
depthView)

  env
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
  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
    (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 <- forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO Scene
emptyScene

  pure FrameResource
    { $sel:frDescSets:FrameResource :: Tagged '[Scene] (Vector DescriptorSet)
frDescSets = 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 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 =
  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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Monoid a => a
mempty 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 =
  forall (io :: * -> *).
MonadIO io =>
Device
-> Vector (SomeStruct WriteDescriptorSet)
-> ("descriptorCopies" ::: Vector CopyDescriptorSet)
-> io ()
Vk.updateDescriptorSets (forall a. HasVulkan a => a -> Device
getDevice context
context) Vector (SomeStruct WriteDescriptorSet)
writeSets forall a. Monoid a => a
mempty

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

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

    writeSet0b0 :: SomeStruct WriteDescriptorSet
writeSet0b0 = forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct 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      = forall a. a -> Vector a
Vector.singleton DescriptorBufferInfo
set0bind0I
      }
      where
        set0bind0I :: DescriptorBufferInfo
set0bind0I = Vk.DescriptorBufferInfo
          { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.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 = forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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     = forall a. Zero a => a
zero
            , $sel:imageView:DescriptorImageInfo :: ImageView
imageView   = AllocatedImage -> ImageView
Image.aiImageView forall a b. (a -> b) -> a -> b
$ forall tag. 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 = forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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     = forall a. Zero a => a
zero
            , $sel:imageView:DescriptorImageInfo :: ImageView
imageView   = AllocatedImage -> ImageView
Image.aiImageView forall a b. (a -> b) -> a -> b
$ forall tag. 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 ->
          forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Allocated 'Coherent Sun
someLights ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct 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      = forall a. a -> Vector a
Vector.singleton DescriptorBufferInfo
set0bind4I
            }
          where
            set0bind4I :: DescriptorBufferInfo
set0bind4I = Vk.DescriptorBufferInfo
              { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.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 = forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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
          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 ->
          forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just Allocated 'Coherent Material
someMaterials ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct 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      = forall a. a -> Vector a
Vector.singleton DescriptorBufferInfo
set0bind6I
            }
          where
            set0bind6I :: DescriptorBufferInfo
set0bind6I = Vk.DescriptorBufferInfo
              { $sel:buffer:DescriptorBufferInfo :: Buffer
Vk.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 :: Vector (SomeStruct WriteDescriptorSet)
writeSets = forall a. [Vector a] -> Vector a
Vector.concat
      [ forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeStruct WriteDescriptorSet
writeSet0b0
      -- XXX: binding 1 is immutable samplers, baked into layout.
      , forall {f :: * -> *} {a} {a}.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Texture Flat)
linearTextures SomeStruct WriteDescriptorSet
writeSet0b2
      , forall {f :: * -> *} {a} {a}.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Texture CubeMap)
linearCubes SomeStruct WriteDescriptorSet
writeSet0b3
      , Vector (SomeStruct WriteDescriptorSet)
writeSet0b4M
      , forall {f :: * -> *} {a} {a}.
(Monoid (f a), Applicative f) =>
Vector a -> a -> f a
skipEmpty Vector (Sampler, ImageView)
shadowMaps SomeStruct WriteDescriptorSet
writeSet0b5
      , Vector (SomeStruct WriteDescriptorSet)
writeSet0b6M
      ]
      where
        skipEmpty :: Vector a -> a -> f a
skipEmpty Vector a
items a
writer
          | forall a. Vector a -> Bool
Vector.null Vector a
items = forall a. Monoid a => a
mempty
          | Bool
otherwise = 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
frObserver :: ObserverIO Scene
frBuffer :: Allocated 'Coherent Scene
frDescSets :: Tagged ds (Vector DescriptorSet)
$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 (Vector DescriptorSet)
..} Tagged ext DescriptorSet
ext = FrameResource
  { $sel:frDescSets:FrameResource :: Tagged (Extend ds ext) (Vector DescriptorSet)
frDescSets = 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
frObserver :: ObserverIO Scene
frBuffer :: Allocated 'Coherent Scene
$sel:frObserver:FrameResource :: ObserverIO Scene
$sel:frBuffer:FrameResource :: Allocated 'Coherent 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
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}=
  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 <- forall (io :: * -> *) a.
(MonadUnliftIO io, Storable a) =>
Vector a -> Allocated 'Coherent a -> io (Allocated 'Coherent a)
Buffer.updateCoherent (forall a. Storable a => a -> Vector a
VectorS.singleton GetOutput Process
new) Allocated 'Coherent Scene
frBuffer
    pure GetOutput Process
new

-- * Rendering

withBoundSet0
  :: MonadIO m
  => FrameResource ds
  -> Pipeline ds vertices instances
  -> Vk.CommandBuffer
  -> Bound ds Void Void m b
  -> m b
withBoundSet0 :: forall (m :: * -> *) (ds :: [*]) vertices instances b.
MonadIO m =>
FrameResource ds
-> Pipeline ds vertices instances
-> CommandBuffer
-> Bound ds Void Void m b
-> m b
withBoundSet0 FrameResource{Tagged ds (Vector DescriptorSet)
frDescSets :: Tagged ds (Vector DescriptorSet)
$sel:frDescSets:FrameResource :: forall (ds :: [*]).
FrameResource ds -> Tagged ds (Vector DescriptorSet)
frDescSets} Pipeline ds vertices instances
refPipeline CommandBuffer
cb =
  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
    (forall (dsl :: [*]) vertices instances.
Pipeline dsl vertices instances -> Tagged dsl PipelineLayout
Pipeline.pLayout Pipeline ds vertices instances
refPipeline)
    Tagged ds (Vector DescriptorSet)
frDescSets