{-# 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 = 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 = forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount 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 <- forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Format -> m RenderPass
allocateRenderPass Format
format
  (RefCounted
refcounted, Vector Framebuffer
framebuffers) <- forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> m (RefCounted, a)
RefCounted.wrapped forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadResource m =>
ResourceT m a -> m (ReleaseKey, a)
Region.run do
    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"
    forall (m :: * -> *) env swapchain.
(MonadResource m, MonadVulkan env m, HasSwapchain swapchain) =>
swapchain -> RenderPass -> m (Vector Framebuffer)
allocateFramebufferSwapchain swapchain
swapchain RenderPass
renderPass

  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        = 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 = forall a. HasSwapchain a => a -> Format
getSurfaceFormat swapchain
swapchain

    fullSurface :: Rect2D
fullSurface = Vk.Rect2D
      { $sel:offset:Rect2D :: Offset2D
Vk.offset = forall a. Zero a => a
zero
      , $sel:extent:Rect2D :: Extent2D
Vk.extent = 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
release :: RefCounted
$sel:release:Compose :: Compose -> RefCounted
release, RenderPass
renderPass :: RenderPass
$sel:renderPass:Compose :: Compose -> RenderPass
renderPass} = do
  forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted RefCounted
release
  (RefCounted
refcounted, Vector Framebuffer
framebuffers) <- forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> m (RefCounted, a)
RefCounted.wrapped forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadResource m =>
ResourceT m a -> m (ReleaseKey, a)
Region.run do
    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 = forall a. Zero a => a
zero
      , $sel:extent:Rect2D :: Extent2D
Vk.extent = 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  (ReleaseKey
_key, RenderPass
rp) <- 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 forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
  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 = forall a. Zero a => a
zero
      { $sel:attachments:RenderPassCreateInfo :: Vector AttachmentDescription
Vk.attachments  = [AttachmentDescription
color]
      , $sel:subpasses:RenderPassCreateInfo :: Vector SubpassDescription
Vk.subpasses    = [SubpassDescription
subpass]
      , $sel:dependencies:RenderPassCreateInfo :: Vector SubpassDependency
Vk.dependencies = [SubpassDependency
colorDeps]
      }

    color :: AttachmentDescription
color = 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 = 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 = forall a. a -> Vector a
Vector.singleton 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 = 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 = 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 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 =
  forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m (Vector b)
Vector.iforM (forall a. HasSwapchain a => a -> Vector ImageView
getSwapchainViews swapchain
swapchain) \Int
ix ImageView
colorView -> do
    let
      fbCI :: FramebufferCreateInfo '[]
fbCI = 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 = [ImageView
colorView]
        , $sel:layers:FramebufferCreateInfo :: Word32
Vk.layers      = Word32
1
        }

    Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
    (ReleaseKey
_key, Framebuffer
fb) <- 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 forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
    forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device Framebuffer
fb forall a b. (a -> b) -> a -> b
$
      ByteString
"Compose.FB:" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show @Int Int
ix)
    pure Framebuffer
fb
  where
    Vk.Extent2D{Word32
$sel:width:Extent2D :: Extent2D -> Word32
width :: Word32
width, Word32
$sel:height:Extent2D :: Extent2D -> Word32
height :: Word32
height} = forall a. HasSwapchain a => a -> Extent2D
getSurfaceExtent swapchain
swapchain