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

module Render.DescSets.Sun
  ( Sun(..)
  , createSet0Ds
  , set0

  , pattern MAX_VIEWS
  ) where

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Resource qualified as ResourceT
import Data.Tagged (Tagged(..))
import Data.Vector qualified as Vector
import Data.Vector.Storable qualified as VectorS
import Foreign.Storable.Generic (GStorable)
import Geomancy (Vec4, vec4)
import Geomancy.Transform (Transform)
import Vulkan.Core10 qualified as Vk
import Vulkan.CStruct.Extends (SomeStruct(..))
import Vulkan.Utils.Debug qualified as Debug
import Vulkan.Zero (Zero(..))

import Engine.Types (StageRIO)
import Engine.Vulkan.DescSets ()
import Engine.Vulkan.Types (DsBindings, HasVulkan(..))
import Resource.Buffer qualified as Buffer
import Resource.DescriptorSet qualified as DescriptorSet

-- * Set0 data

-- | Maximum "guaranteed" amount for multiview passes
pattern MAX_VIEWS :: Int
pattern $bMAX_VIEWS :: Int
$mMAX_VIEWS :: forall r. Int -> (Void# -> r) -> (Void# -> r) -> r
MAX_VIEWS = 6

data Sun = Sun
  { Sun -> Transform
sunViewProjection :: Transform
  , Sun -> Vec4
sunShadow         :: Vec4 -- offsetx, offsety, index, size -- XXX: only index is used
  , Sun -> Vec4
sunPosition       :: Vec4 -- XXX: alpha available for stuff
  , Sun -> Vec4
sunDirection      :: Vec4 -- XXX: alpha available for stuff
  , Sun -> Vec4
sunColor          :: Vec4 -- XXX: RGB premultiplied, alpha is available for stuff
  }
  deriving (Int -> Sun -> ShowS
[Sun] -> ShowS
Sun -> String
(Int -> Sun -> ShowS)
-> (Sun -> String) -> ([Sun] -> ShowS) -> Show Sun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sun] -> ShowS
$cshowList :: [Sun] -> ShowS
show :: Sun -> String
$cshow :: Sun -> String
showsPrec :: Int -> Sun -> ShowS
$cshowsPrec :: Int -> Sun -> ShowS
Show, (forall x. Sun -> Rep Sun x)
-> (forall x. Rep Sun x -> Sun) -> Generic Sun
forall x. Rep Sun x -> Sun
forall x. Sun -> Rep Sun x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Sun x -> Sun
$cfrom :: forall x. Sun -> Rep Sun x
Generic)

instance GStorable Sun

instance Zero Sun where
  zero :: Sun
zero = Sun :: Transform -> Vec4 -> Vec4 -> Vec4 -> Vec4 -> Sun
Sun
    { $sel:sunViewProjection:Sun :: Transform
sunViewProjection = Transform
forall a. Monoid a => a
mempty
    , $sel:sunShadow:Sun :: Vec4
sunShadow         = Vec4
0
    , $sel:sunPosition:Sun :: Vec4
sunPosition       = Vec4
0
    , $sel:sunDirection:Sun :: Vec4
sunDirection      = Float -> Float -> Float -> Float -> Vec4
vec4 Float
0 Float
1 Float
0 Float
0
    , $sel:sunColor:Sun :: Vec4
sunColor          = Vec4
0
    }

-- * Shadow casting descriptor set

set0
  :: Tagged Sun DsBindings
set0 :: Tagged Sun DsBindings
set0 = DsBindings -> Tagged Sun DsBindings
forall k (s :: k) b. b -> Tagged s b
Tagged
  [ (DescriptorSetLayoutBinding
set0bind0, DescriptorBindingFlags
forall a. Zero a => a
zero)
  ]

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_VERTEX_BIT
  , $sel:immutableSamplers:DescriptorSetLayoutBinding :: Vector Sampler
immutableSamplers = Vector Sampler
forall a. Monoid a => a
mempty
  }

-- * Setup

createSet0Ds
  :: Tagged '[Sun] Vk.DescriptorSetLayout
  -> ResourceT (StageRIO st)
      ( Tagged '[Sun] (Vector Vk.DescriptorSet)
      , Buffer.Allocated 'Buffer.Coherent Sun
      )
createSet0Ds :: Tagged '[Sun] DescriptorSetLayout
-> ResourceT
     (StageRIO st)
     (Tagged '[Sun] (Vector DescriptorSet), Allocated 'Coherent Sun)
createSet0Ds (Tagged DescriptorSetLayout
set0layout) = 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 '[Sun] (Vector DescriptorSet)
descSets <- (Vector DescriptorSet -> Tagged '[Sun] (Vector DescriptorSet))
-> ResourceT (StageRIO st) (Vector DescriptorSet)
-> ResourceT (StageRIO st) (Tagged '[Sun] (Vector DescriptorSet))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b. b -> Tagged '[Sun] b
forall k (s :: k) b. b -> Tagged s b
Tagged @'[Sun]) (ResourceT (StageRIO st) (Vector DescriptorSet)
 -> ResourceT (StageRIO st) (Tagged '[Sun] (Vector DescriptorSet)))
-> ResourceT (StageRIO st) (Vector DescriptorSet)
-> ResourceT (StageRIO st) (Tagged '[Sun] (Vector DescriptorSet))
forall a b. (a -> b) -> a -> b
$
    Device
-> DescriptorSetAllocateInfo '[]
-> ResourceT (StageRIO st) (Vector DescriptorSet)
forall (a :: [*]) (io :: * -> *).
(Extendss DescriptorSetAllocateInfo a, PokeChain a, MonadIO io) =>
Device -> DescriptorSetAllocateInfo a -> io (Vector DescriptorSet)
Vk.allocateDescriptorSets (App GlobalHandles st -> Device
forall a. HasVulkan a => a -> Device
getDevice App GlobalHandles st
context) DescriptorSetAllocateInfo '[]
set0dsCI

  let
    initialSuns :: Vector Sun
initialSuns = Int -> Sun -> Vector Sun
forall a. Storable a => Int -> a -> Vector a
VectorS.replicate Int
MAX_VIEWS Sun
forall a. Zero a => a
zero
  (ReleaseKey
_, Allocated 'Coherent Sun
sunData) <- IO (Allocated 'Coherent Sun)
-> (Allocated 'Coherent Sun -> IO ())
-> ResourceT (StageRIO st) (ReleaseKey, Allocated 'Coherent Sun)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
ResourceT.allocate
    (App GlobalHandles st
-> BufferUsageFlagBits
-> Int
-> Vector Sun
-> IO (Allocated 'Coherent Sun)
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
MAX_VIEWS Vector Sun
initialSuns)
    (App GlobalHandles st -> Maybe (Allocated 'Coherent Sun) -> IO ()
forall (io :: * -> *) context (t :: * -> *) (s :: Store) a.
(MonadUnliftIO io, HasVulkan context, Foldable t) =>
context -> t (Allocated s a) -> io ()
Buffer.destroyAll App GlobalHandles st
context (Maybe (Allocated 'Coherent Sun) -> IO ())
-> (Allocated 'Coherent Sun -> Maybe (Allocated 'Coherent Sun))
-> Allocated 'Coherent Sun
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocated 'Coherent Sun -> Maybe (Allocated 'Coherent Sun)
forall a. a -> Maybe a
Just)

  Tagged '[Sun] (Vector DescriptorSet)
-> Allocated 'Coherent Sun -> ResourceT (StageRIO st) ()
forall st.
Tagged '[Sun] (Vector DescriptorSet)
-> Allocated 'Coherent Sun -> ResourceT (StageRIO st) ()
updateSet0Ds Tagged '[Sun] (Vector DescriptorSet)
descSets Allocated 'Coherent Sun
sunData

  let device :: Device
device = App GlobalHandles st -> Device
forall a. HasVulkan a => a -> Device
getDevice App GlobalHandles st
context
  Device
-> DescriptorPool -> ByteString -> ResourceT (StageRIO st) ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device DescriptorPool
descPool ByteString
"Sun.Pool"
  Vector DescriptorSet
-> (DescriptorSet -> ResourceT (StageRIO st) ())
-> ResourceT (StageRIO st) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Tagged '[Sun] (Vector DescriptorSet) -> Vector DescriptorSet
forall k (s :: k) b. Tagged s b -> b
unTagged Tagged '[Sun] (Vector DescriptorSet)
descSets) \DescriptorSet
ds ->
    Device -> DescriptorSet -> ByteString -> ResourceT (StageRIO st) ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device DescriptorSet
ds ByteString
"Sun.DS"
  Device -> Buffer -> ByteString -> ResourceT (StageRIO st) ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device (Allocated 'Coherent Sun -> Buffer
forall (s :: Store) a. Allocated s a -> Buffer
Buffer.aBuffer Allocated 'Coherent Sun
sunData) ByteString
"Sun.Data"

  pure (Tagged '[Sun] (Vector DescriptorSet)
descSets, Allocated 'Coherent Sun
sunData)

dpSizes :: DescriptorSet.TypeMap Word32
dpSizes :: TypeMap Word32
dpSizes =
  [ ( DescriptorType
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
    , Word32
uniformBuffers
    )
  -- XXX: may be required to fetch textures for shadows from texture-masked models
  -- , ( Vk.DESCRIPTOR_TYPE_SAMPLED_IMAGE
  --   , sampledImages
  --   )
  -- , ( Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
  --   , sampledImages + shadowMaps
  --   )
  -- , ( Vk.DESCRIPTOR_TYPE_SAMPLER
  --   , staticSamplers
  --   )
  ]
  where
    uniformBuffers :: Word32
uniformBuffers = Word32
2    -- 1 scene + 1 light array
    -- sampledImages  = 128  -- max dynamic textures and cubemaps
    -- staticSamplers = 8    -- immutable samplers
    -- shadowMaps     = 2    -- max shadowmaps

updateSet0Ds
  :: Tagged '[Sun] (Vector Vk.DescriptorSet)
  -> Buffer.Allocated 'Buffer.Coherent Sun
  -> ResourceT (StageRIO st) ()
updateSet0Ds :: Tagged '[Sun] (Vector DescriptorSet)
-> Allocated 'Coherent Sun -> ResourceT (StageRIO st) ()
updateSet0Ds (Tagged Vector DescriptorSet
ds) Buffer.Allocated{Buffer
aBuffer :: Buffer
$sel:aBuffer:Allocated :: forall (s :: Store) a. Allocated s a -> Buffer
aBuffer} = 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
  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 (App GlobalHandles st -> Device
forall a. HasVulkan a => a -> Device
getDevice App GlobalHandles st
context) "descriptorWrites" ::: Vector (SomeStruct WriteDescriptorSet)
writeSets "descriptorCopies" ::: Vector CopyDescriptorSet
forall a. Monoid a => a
mempty

  where
    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 [Sun]"
      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 = Buffer
aBuffer
          , $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.singleton SomeStruct WriteDescriptorSet
writeSet0b0