{-# LANGUAGE OverloadedLists #-}

module Render.Pass.Compose
  ( Compose(..)
  , allocate
  , update
  , usePass
  ) where

import RIO

import Control.Monad.Trans.Resource qualified as Resource
import Data.Bits ((.|.))
import Data.Vector qualified as Vector
import Vulkan.Core10 qualified as Vk
import Vulkan.Utils.Debug qualified as Debug
import Vulkan.Zero (zero)

import Engine.Types.RefCounted (RefCounted, releaseRefCounted, resourceTRefCount)
import Engine.Types.RefCounted qualified as RefCounted
import Engine.Vulkan.Types (HasSwapchain(..), HasRenderPass(..), MonadVulkan, RenderPass(..), getDevice)
import Render.Pass (usePass)
import Resource.Region qualified as Region

-- | Composition/postprocessing/presentation pass
--
-- Can be used to transfer images from "Render.Pass.Offscreen.Offscreen" passes and tonemapping.
--
-- Color attachments are derived from swapchain.
-- The pass optmized for image transfer: it has no depth attachment and does not clear.
-- Use image blitting that convers the whole area or a fullscreen shader.
data Compose = Compose
  { Compose -> RenderPass
renderPass   :: Vk.RenderPass
  , Compose -> Vector Framebuffer
frameBuffers :: Vector Vk.Framebuffer
  , Compose -> Rect2D
renderArea   :: Vk.Rect2D
  , Compose -> Vector ClearValue
clear        :: Vector Vk.ClearValue
  , Compose -> RefCounted
release      :: RefCounted
  }

instance HasRenderPass Compose where
  getRenderPass :: Compose -> RenderPass
getRenderPass   = Compose -> RenderPass
renderPass
  getFramebuffers :: Compose -> Vector Framebuffer
getFramebuffers = Compose -> Vector Framebuffer
frameBuffers
  getClearValues :: Compose -> Vector ClearValue
getClearValues  = Compose -> Vector ClearValue
clear
  getRenderArea :: Compose -> Rect2D
getRenderArea   = Compose -> Rect2D
renderArea

instance RenderPass Compose where
  updateRenderpass :: forall env swapchain.
(HasLogFunc env, HasSwapchain swapchain, HasVulkan env,
 MonadResource (RIO env)) =>
swapchain -> Compose -> RIO env Compose
updateRenderpass = swapchain -> Compose -> RIO env Compose
forall (m :: * -> *) env swapchain.
(MonadResource m, MonadVulkan env m, HasSwapchain swapchain) =>
swapchain -> Compose -> m Compose
update
  refcountRenderpass :: forall env. MonadResource (RIO env) => Compose -> RIO env ()
refcountRenderpass = RefCounted -> RIO env ()
forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount (RefCounted -> RIO env ())
-> (Compose -> RefCounted) -> Compose -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose -> RefCounted
release

allocate
  :: ( Resource.MonadResource m
     , MonadVulkan env m
     , HasLogFunc env
     , HasSwapchain swapchain
     )
  => swapchain
  -> m Compose
allocate :: forall (m :: * -> *) env swapchain.
(MonadResource m, MonadVulkan env m, HasLogFunc env,
 HasSwapchain swapchain) =>
swapchain -> m Compose
allocate swapchain
swapchain = do
  RenderPass
renderPass <- Format -> m RenderPass
forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Format -> m RenderPass
allocateRenderPass Format
format
  (RefCounted
refcounted, Vector Framebuffer
framebuffers) <- m (ReleaseKey, Vector Framebuffer)
-> m (RefCounted, Vector Framebuffer)
forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> m (RefCounted, a)
RefCounted.wrapped (m (ReleaseKey, Vector Framebuffer)
 -> m (RefCounted, Vector Framebuffer))
-> m (ReleaseKey, Vector Framebuffer)
-> m (RefCounted, Vector Framebuffer)
forall a b. (a -> b) -> a -> b
$ ResourceT m (Vector Framebuffer)
-> m (ReleaseKey, Vector Framebuffer)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT m a -> m (ReleaseKey, a)
Region.run do
    Utf8Builder -> Utf8Builder -> ResourceT m ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 HasCallStack) =>
Utf8Builder -> Utf8Builder -> ResourceT m ()
Region.logDebug
      Utf8Builder
"Allocating Compose resources"
      Utf8Builder
"Releasing Compose resources"
    swapchain -> RenderPass -> ResourceT m (Vector Framebuffer)
forall (m :: * -> *) env swapchain.
(MonadResource m, MonadVulkan env m, HasSwapchain swapchain) =>
swapchain -> RenderPass -> m (Vector Framebuffer)
allocateFramebufferSwapchain swapchain
swapchain RenderPass
renderPass

  Compose -> m Compose
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Compose
    { $sel:renderPass:Compose :: RenderPass
renderPass   = RenderPass
renderPass
    , $sel:renderArea:Compose :: Rect2D
renderArea   = Rect2D
fullSurface
    , $sel:clear:Compose :: Vector ClearValue
clear        = Vector ClearValue
forall a. Monoid a => a
mempty
    , $sel:frameBuffers:Compose :: Vector Framebuffer
frameBuffers = Vector Framebuffer
framebuffers
    , $sel:release:Compose :: RefCounted
release      = RefCounted
refcounted
    }
  where
    format :: Format
format = swapchain -> Format
forall a. HasSwapchain a => a -> Format
getSurfaceFormat swapchain
swapchain

    fullSurface :: Rect2D
fullSurface = Vk.Rect2D
      { $sel:offset:Rect2D :: Offset2D
Vk.offset = Offset2D
forall a. Zero a => a
zero
      , $sel:extent:Rect2D :: Extent2D
Vk.extent = swapchain -> Extent2D
forall a. HasSwapchain a => a -> Extent2D
getSurfaceExtent swapchain
swapchain
      }

update
  :: ( Resource.MonadResource m
     , MonadVulkan env m
     , HasSwapchain swapchain
     )
  => swapchain
  -> Compose
  -> m Compose
update :: forall (m :: * -> *) env swapchain.
(MonadResource m, MonadVulkan env m, HasSwapchain swapchain) =>
swapchain -> Compose -> m Compose
update swapchain
swapchain old :: Compose
old@Compose{RefCounted
$sel:release:Compose :: Compose -> RefCounted
release :: RefCounted
release, RenderPass
$sel:renderPass:Compose :: Compose -> RenderPass
renderPass :: RenderPass
renderPass} = do
  RefCounted -> m ()
forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted RefCounted
release
  (RefCounted
refcounted, Vector Framebuffer
framebuffers) <- m (ReleaseKey, Vector Framebuffer)
-> m (RefCounted, Vector Framebuffer)
forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> m (RefCounted, a)
RefCounted.wrapped (m (ReleaseKey, Vector Framebuffer)
 -> m (RefCounted, Vector Framebuffer))
-> m (ReleaseKey, Vector Framebuffer)
-> m (RefCounted, Vector Framebuffer)
forall a b. (a -> b) -> a -> b
$ ResourceT m (Vector Framebuffer)
-> m (ReleaseKey, Vector Framebuffer)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT m a -> m (ReleaseKey, a)
Region.run do
    swapchain -> RenderPass -> ResourceT m (Vector Framebuffer)
forall (m :: * -> *) env swapchain.
(MonadResource m, MonadVulkan env m, HasSwapchain swapchain) =>
swapchain -> RenderPass -> m (Vector Framebuffer)
allocateFramebufferSwapchain swapchain
swapchain RenderPass
renderPass
  pure Compose
old
    { $sel:frameBuffers:Compose :: Vector Framebuffer
frameBuffers = Vector Framebuffer
framebuffers
    , $sel:release:Compose :: RefCounted
release      = RefCounted
refcounted
    , $sel:renderArea:Compose :: Rect2D
renderArea   = Rect2D
fullSurface
    }
  where
    fullSurface :: Rect2D
fullSurface = Vk.Rect2D
      { $sel:offset:Rect2D :: Offset2D
Vk.offset = Offset2D
forall a. Zero a => a
zero
      , $sel:extent:Rect2D :: Extent2D
Vk.extent = swapchain -> Extent2D
forall a. HasSwapchain a => a -> Extent2D
getSurfaceExtent swapchain
swapchain
      }

-- ** Render pass

allocateRenderPass
  :: ( MonadVulkan env m
     , Resource.MonadResource m
     )
  => Vk.Format
  -> m Vk.RenderPass
allocateRenderPass :: forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Format -> m RenderPass
allocateRenderPass Format
format = do
  Device
device <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
  (ReleaseKey
_key, RenderPass
rp) <- Device
-> RenderPassCreateInfo '[]
-> Maybe AllocationCallbacks
-> (IO RenderPass
    -> (RenderPass -> IO ()) -> m (ReleaseKey, RenderPass))
-> m (ReleaseKey, RenderPass)
forall (a :: [*]) (io :: * -> *) r.
(Extendss RenderPassCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> RenderPassCreateInfo a
-> Maybe AllocationCallbacks
-> (io RenderPass -> (RenderPass -> io ()) -> r)
-> r
Vk.withRenderPass Device
device RenderPassCreateInfo '[]
createInfo Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO RenderPass
-> (RenderPass -> IO ()) -> m (ReleaseKey, RenderPass)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  Device -> RenderPass -> ByteString -> m ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device RenderPass
rp ByteString
"Compose"
  pure RenderPass
rp
  where
    createInfo :: RenderPassCreateInfo '[]
createInfo = RenderPassCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:attachments:RenderPassCreateInfo :: Vector AttachmentDescription
Vk.attachments  = [Item (Vector AttachmentDescription)
AttachmentDescription
color]
      , $sel:subpasses:RenderPassCreateInfo :: Vector SubpassDescription
Vk.subpasses    = [Item (Vector SubpassDescription)
SubpassDescription
subpass]
      , $sel:dependencies:RenderPassCreateInfo :: Vector SubpassDependency
Vk.dependencies = [Item (Vector SubpassDependency)
SubpassDependency
colorDeps]
      }

    color :: AttachmentDescription
color = AttachmentDescription
forall a. Zero a => a
zero
      { $sel:format:AttachmentDescription :: Format
Vk.format      = Format
format
      , $sel:samples:AttachmentDescription :: SampleCountFlagBits
Vk.samples     = SampleCountFlagBits
Vk.SAMPLE_COUNT_1_BIT
      , $sel:loadOp:AttachmentDescription :: AttachmentLoadOp
Vk.loadOp      = AttachmentLoadOp
Vk.ATTACHMENT_LOAD_OP_DONT_CARE
      , $sel:finalLayout:AttachmentDescription :: ImageLayout
Vk.finalLayout = ImageLayout
Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
      }

    subpass :: SubpassDescription
subpass = SubpassDescription
forall a. Zero a => a
zero
      { $sel:pipelineBindPoint:SubpassDescription :: PipelineBindPoint
Vk.pipelineBindPoint =
          PipelineBindPoint
Vk.PIPELINE_BIND_POINT_GRAPHICS
      , $sel:colorAttachments:SubpassDescription :: Vector AttachmentReference
Vk.colorAttachments = AttachmentReference -> Vector AttachmentReference
forall a. a -> Vector a
Vector.singleton AttachmentReference
forall a. Zero a => a
zero
          { $sel:attachment:AttachmentReference :: Word32
Vk.attachment = Word32
0
          , $sel:layout:AttachmentReference :: ImageLayout
Vk.layout     = ImageLayout
Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
          }
      }

    colorDeps :: SubpassDependency
colorDeps = SubpassDependency
forall a. Zero a => a
zero
      { $sel:srcSubpass:SubpassDependency :: Word32
Vk.srcSubpass    = Word32
Vk.SUBPASS_EXTERNAL
      , $sel:dstSubpass:SubpassDependency :: Word32
Vk.dstSubpass    = Word32
0
      , $sel:srcStageMask:SubpassDependency :: PipelineStageFlags
Vk.srcStageMask  = PipelineStageFlags
colorOut
      , $sel:srcAccessMask:SubpassDependency :: AccessFlags
Vk.srcAccessMask = AccessFlags
forall a. Zero a => a
zero
      , $sel:dstStageMask:SubpassDependency :: PipelineStageFlags
Vk.dstStageMask  = PipelineStageFlags
colorOut
      , $sel:dstAccessMask:SubpassDependency :: AccessFlags
Vk.dstAccessMask = AccessFlags
colorRW
      }
      where
        colorOut :: PipelineStageFlags
colorOut =
          PipelineStageFlags
Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT

        colorRW :: AccessFlags
colorRW =
          AccessFlags
Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT AccessFlags -> AccessFlags -> AccessFlags
forall a. Bits a => a -> a -> a
.|.
          AccessFlags
Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT

-- ** Framebuffer

allocateFramebufferSwapchain
  :: ( Resource.MonadResource m
     , MonadVulkan env m
     , HasSwapchain swapchain
     )
  => swapchain
  -> Vk.RenderPass
  -> m (Vector Vk.Framebuffer)
allocateFramebufferSwapchain :: forall (m :: * -> *) env swapchain.
(MonadResource m, MonadVulkan env m, HasSwapchain swapchain) =>
swapchain -> RenderPass -> m (Vector Framebuffer)
allocateFramebufferSwapchain swapchain
swapchain RenderPass
renderPass =
  Vector ImageView
-> (Int -> ImageView -> m Framebuffer) -> m (Vector Framebuffer)
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m (Vector b)
Vector.iforM (swapchain -> Vector ImageView
forall a. HasSwapchain a => a -> Vector ImageView
getSwapchainViews swapchain
swapchain) \Int
ix ImageView
colorView -> do
    let
      fbCI :: FramebufferCreateInfo '[]
fbCI = FramebufferCreateInfo '[]
forall a. Zero a => a
zero
        { $sel:renderPass:FramebufferCreateInfo :: RenderPass
Vk.renderPass  = RenderPass
renderPass
        , $sel:width:FramebufferCreateInfo :: Word32
Vk.width       = Word32
width
        , $sel:height:FramebufferCreateInfo :: Word32
Vk.height      = Word32
height
        , $sel:attachments:FramebufferCreateInfo :: Vector ImageView
Vk.attachments = [Item (Vector ImageView)
ImageView
colorView]
        , $sel:layers:FramebufferCreateInfo :: Word32
Vk.layers      = Word32
1
        }

    Device
device <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
    (ReleaseKey
_key, Framebuffer
fb) <- Device
-> FramebufferCreateInfo '[]
-> Maybe AllocationCallbacks
-> (IO Framebuffer
    -> (Framebuffer -> IO ()) -> m (ReleaseKey, Framebuffer))
-> m (ReleaseKey, Framebuffer)
forall (a :: [*]) (io :: * -> *) r.
(Extendss FramebufferCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> FramebufferCreateInfo a
-> Maybe AllocationCallbacks
-> (io Framebuffer -> (Framebuffer -> io ()) -> r)
-> r
Vk.withFramebuffer Device
device FramebufferCreateInfo '[]
fbCI Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO Framebuffer
-> (Framebuffer -> IO ()) -> m (ReleaseKey, Framebuffer)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
    Device -> Framebuffer -> ByteString -> m ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device Framebuffer
fb (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$
      ByteString
"Compose.FB:" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show @Int Int
ix)
    pure Framebuffer
fb
  where
    Vk.Extent2D{Word32
width :: Word32
$sel:width:Extent2D :: Extent2D -> Word32
width, Word32
height :: Word32
$sel:height:Extent2D :: Extent2D -> Word32
height} = swapchain -> Extent2D
forall a. HasSwapchain a => a -> Extent2D
getSurfaceExtent swapchain
swapchain