keid-core 0.1.2.0 → 0.1.3.0

raw patch · 12 files changed

+646/−174 lines, 12 filesdep +serialisePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: serialise

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• keid-core.cabal +4/−1
• src/Engine/Vulkan/Types.hs +0/−10
• src/Render/Pass.hs +28/−0
• src/Render/Pass/Offscreen.hs +347/−0
• src/Render/Samplers.hs +8/−8
• src/Resource/Image.hs +83/−124
• src/Resource/Mesh/Codec.hs +56/−16
• src/Resource/Mesh/Types.hs +77/−0
• src/Resource/Model.hs +4/−1
• src/Resource/Texture.hs +3/−3
• src/Resource/Texture/Ktx1.hs +26/−11

@@ -1,5 +1,15 @@ # Changelog for keid-core +## 0.1.3.0++- Changed mesh codec to use `Serialise` class instead of `Storable`.+- Replaced RIO in resource loaders with constraints.+- Added `Render.Pass` base module and `Render.Pass.Offscreen`.+- `Resource.Image.AllocatedImage` got format and subresource information.+- Removed `Resource.Image.createColorResource`, `Resource.Image.createDepthResource`.+  * Added unified `Resource.Image.create` instead.+  * Function names shortened to match qulified import style.+ ## 0.1.2.0  - Added `Resource.Source` type to mix external and embedded byte sources.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.2.0+version:        0.1.3.0 synopsis:       Core parts of Keid engine. category:       Game Engine author:         IC Rainbow@@ -57,6 +57,8 @@       Render.Code       Render.Code.Noise       Render.Draw+      Render.Pass+      Render.Pass.Offscreen       Render.Samplers       Resource.Buffer       Resource.Collection@@ -157,6 +159,7 @@     , resourcet     , rio >=0.1.12.0     , rio-app+    , serialise     , tagged     , template-haskell     , text

@@ -58,16 +58,6 @@   getDevice             = getDevice . fst   getAllocator          = getAllocator . fst -instance (HasSwapchain context) => HasSwapchain (a, context) where-  getSurfaceExtent  = getSurfaceExtent . snd-  getSurfaceFormat  = getSurfaceFormat . snd-  getDepthFormat    = getDepthFormat . snd-  getMultisample    = getMultisample . snd-  getAnisotropy     = getAnisotropy . snd-  getSwapchainViews = getSwapchainViews . snd-  getMinImageCount  = getMinImageCount . snd-  getImageCount     = getImageCount . snd- -- TODO getPipelineCache :: {- HasVulkan ctx => -} ctx -> Vk.PipelineCache getPipelineCache _ctx = Vk.NULL_HANDLE

@@ -0,0 +1,28 @@+module Render.Pass+  ( usePass++  , beginInfo+  ) where++import RIO++import RIO.Vector.Partial ((!))+import Vulkan.Core10 qualified as Vk+import Vulkan.Zero (zero)++import Engine.Vulkan.Types (HasRenderPass(..))++usePass :: (MonadIO io, HasRenderPass a) => a -> Word32 -> Vk.CommandBuffer -> io r -> io r+usePass render imageIndex cb =+  Vk.cmdUseRenderPass+    cb+    (beginInfo render imageIndex)+    Vk.SUBPASS_CONTENTS_INLINE++beginInfo :: HasRenderPass a => a -> Word32 -> Vk.RenderPassBeginInfo '[]+beginInfo rp imageIndex = zero+  { Vk.renderPass  = getRenderPass rp+  , Vk.framebuffer = getFramebuffers rp ! fromIntegral imageIndex+  , Vk.renderArea  = getRenderArea rp+  , Vk.clearValues = getClearValues rp+  }

@@ -0,0 +1,347 @@+{-# LANGUAGE OverloadedLists #-}++module Render.Pass.Offscreen+  ( Settings(..)+  , allocate+  , Offscreen(..)+  , colorTexture+  , colorCube+  , depthTexture+  , depthCube+  ) 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.Core11.Promoted_From_VK_KHR_multiview qualified as Khr+import Vulkan.CStruct.Extends (pattern (:&), pattern (::&))+import Vulkan.Utils.Debug qualified as Debug+import Vulkan.Zero (zero)++import Engine.Types.RefCounted (RefCounted, newRefCounted, resourceTRefCount)+import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), RenderPass(..), MonadVulkan)+import Resource.Image (AllocatedImage)+import Resource.Image qualified as Image+import Resource.Texture (CubeMap, Flat, Texture(..))++{- XXX: Consider spec wrt. parameters and intended use!++https://www.khronos.org/registry/vulkan/specs/1.2-extensions/man/html/vkCmdBlitImage.html+-}+data Settings = Settings+  { sLabel       :: Text+  , sExtent      :: Vk.Extent2D+  , sFormat      :: Vk.Format+  , sDepthFormat :: Vk.Format+  , sLayers      :: Word32+  , sMultiView   :: Bool -- ^ Makes sense only for multiple layers.+  , sSamples     :: Vk.SampleCountFlagBits -- ^ Multisample prevents mipmapping and cubes.+  , sMipMap      :: Bool+  }+  deriving (Eq, Show)++data Offscreen = Offscreen+  { oRenderPass  :: Vk.RenderPass+  , oExtent      :: Vk.Extent2D+  , oColor       :: AllocatedImage+  , oDepth       :: AllocatedImage+  , oLayers      :: Word32+  , oMipLevels   :: Word32++  , oFrameBuffer :: Vk.Framebuffer+  , oRenderArea  :: Vk.Rect2D+  , oClear       :: Vector Vk.ClearValue+  , oRelease     :: RefCounted+  }++instance HasRenderPass Offscreen where+  getRenderPass   = oRenderPass+  getFramebuffers = Vector.replicate 10 . oFrameBuffer+  getClearValues  = oClear+  getRenderArea   = oRenderArea++instance RenderPass Offscreen where+  allocateRenderpass_ = error "Don't allocate Offscreen via class"+  updateRenderpass    = error "Don't recreate Offscreen on resize"++  refcountRenderpass = resourceTRefCount . oRelease++colorTexture :: Offscreen -> Texture Flat+colorTexture Offscreen{..} = Texture+  { tFormat         = Image.aiFormat oColor+  , tMipLevels      = oMipLevels+  , tLayers         = oLayers+  , tAllocatedImage = oColor+  }++colorCube :: Offscreen -> Texture CubeMap+colorCube Offscreen{..} = Texture+  { tFormat         = Image.aiFormat oColor+  , tMipLevels      = oMipLevels+  , tLayers         = oLayers -- TODO: get from type param+  , tAllocatedImage = oColor+  }++depthTexture :: Offscreen -> Texture Flat+depthTexture Offscreen{..} = Texture+  { tFormat         = Image.aiFormat oDepth+  , tMipLevels      = oMipLevels+  , tLayers         = oLayers+  , tAllocatedImage = oDepth+  }++depthCube :: Offscreen -> Texture CubeMap+depthCube Offscreen{..} = Texture+  { tFormat         = Image.aiFormat oDepth+  , tMipLevels      = oMipLevels+  , tLayers         = oLayers -- TODO: get from type param+  , tAllocatedImage = oDepth+  }++allocate+  :: ( Resource.MonadResource m+     , MonadVulkan env m+     , HasLogFunc env+     )+  => Settings+  -> m Offscreen+allocate settings@Settings{..} = do+  logDebug $ "Allocating Offscreen resources for " <> display sLabel++  (_rpKey, renderPass) <- allocateRenderPass settings++  (refcounted, color, depth, framebuffer) <- allocateFramebuffer settings renderPass++  pure Offscreen+    { oRenderPass  = renderPass+    , oRenderArea  = fullSurface+    , oExtent      = sExtent+    , oMipLevels   = 1+    , oLayers      = sLayers+    , oClear       = clear+    , oColor       = color+    , oDepth       = depth+    , oFrameBuffer = framebuffer+    , oRelease     = refcounted+    }+  where+    fullSurface = Vk.Rect2D+      { Vk.offset = zero+      , Vk.extent = sExtent+      }++    clear = Vector.fromList+      [ Vk.Color $ Vk.Float32 0 0 0 1+      , Vk.DepthStencil (Vk.ClearDepthStencilValue 1.0 0)+      ]++-- ** Render pass++allocateRenderPass+  :: ( MonadVulkan env m+     , Resource.MonadResource m+     )+  => Settings+  -> m (Resource.ReleaseKey, Vk.RenderPass)+allocateRenderPass settings = do+  device <- asks getDevice++  res <-+    if sMultiView settings then+      Vk.withRenderPass device createInfoMulti Nothing Resource.allocate+    else+      Vk.withRenderPass device createInfo Nothing Resource.allocate+  Debug.nameObject device (snd res) $ "Offscreen:" <> encodeUtf8 (sLabel settings)+  pure res+  where+    createInfo =+      zero+        { Vk.attachments  = Vector.fromList [color, depth]+        , Vk.subpasses    = Vector.fromList [subpass]+        , Vk.dependencies = deps+        }++    createInfoMulti =+      createInfo+        ::& Khr.RenderPassMultiviewCreateInfo+          { Khr.viewMasks        = [2 ^ sLayers settings - 1]+          , Khr.viewOffsets      = []+          , Khr.correlationMasks = [0]+          }+        :& ()++    color = zero+      { Vk.format         = sFormat settings+      , Vk.samples        = sSamples settings+      , Vk.initialLayout  = Vk.IMAGE_LAYOUT_UNDEFINED+      , Vk.finalLayout    = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL+      , Vk.loadOp         = Vk.ATTACHMENT_LOAD_OP_CLEAR+      , Vk.storeOp        = Vk.ATTACHMENT_STORE_OP_STORE+      , Vk.stencilLoadOp  = Vk.ATTACHMENT_LOAD_OP_DONT_CARE+      , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE+      }++    depth = zero+      { Vk.format         = sDepthFormat settings+      , Vk.samples        = sSamples settings+      , Vk.initialLayout  = Vk.IMAGE_LAYOUT_UNDEFINED+      , Vk.finalLayout    = Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL+      , Vk.loadOp         = Vk.ATTACHMENT_LOAD_OP_CLEAR+      , Vk.storeOp        = Vk.ATTACHMENT_STORE_OP_DONT_CARE+      , Vk.stencilLoadOp  = Vk.ATTACHMENT_LOAD_OP_DONT_CARE+      , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE+      }++    subpass = zero+      { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS+      , Vk.colorAttachments = Vector.singleton zero+          { Vk.attachment = 0+          , Vk.layout     = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL+          }+      , Vk.depthStencilAttachment = Just zero+          { Vk.attachment = 1+          , Vk.layout     = Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL+          }+      }++    {- BUG: Validation Error: [ SYNC-HAZARD-READ_AFTER_WRITE ]++      vkCmdDraw: Hazard READ_AFTER_WRITE for VkImageView 0x2c0a7b0[],+        in VkCommandBuffer 0x3297680[],+        and VkPipeline 0x3203390[Global.Render.EnvCube.Pipeline],+        VkDescriptorSet 0x3248050[],+        type: VK_DESCRIPTOR_TYPE_SAMPLED_IMAGE,+        imageLayout: VK_IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL,+        binding #3, index 5.+      Access info (+        usage: SYNC_FRAGMENT_SHADER_SHADER_STORAGE_READ,+        prior_usage: SYNC_COLOR_ATTACHMENT_OUTPUT_COLOR_ATTACHMENT_WRITE,+        write_barriers: 0,+        command: vkCmdBeginRenderPass,+        seq_no: 26,+        reset_no: 1+      ).+    -}+    deps =+      [ zero+          { Vk.dependencyFlags = Vk.DEPENDENCY_BY_REGION_BIT+          , Vk.srcSubpass      = Vk.SUBPASS_EXTERNAL+          , Vk.dstSubpass      = 0+          , Vk.srcStageMask    = Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT+          , Vk.dstStageMask    = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT .|. Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT+          , Vk.srcAccessMask   = Vk.ACCESS_SHADER_READ_BIT .|. Vk.ACCESS_SHADER_WRITE_BIT+          , Vk.dstAccessMask   = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT .|. Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT+          }+      , zero+          { Vk.dependencyFlags = Vk.DEPENDENCY_BY_REGION_BIT+          , Vk.srcSubpass      = 0+          , Vk.dstSubpass      = Vk.SUBPASS_EXTERNAL+          , Vk.srcStageMask    = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT .|. Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT+          , Vk.dstStageMask    = Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT+          , Vk.srcAccessMask   = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT .|. Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT+          , Vk.dstAccessMask   = Vk.ACCESS_SHADER_READ_BIT+          }+      ]++-- ** Framebuffer++type FramebufferOffscreen =+  ( RefCounted+  , Image.AllocatedImage+  , Image.AllocatedImage+  , Vk.Framebuffer+  )++allocateFramebuffer+  :: ( Resource.MonadResource m+     , MonadVulkan env m+     , HasLogFunc env+     )+  => Settings+  -> Vk.RenderPass+  -> m FramebufferOffscreen+allocateFramebuffer Settings{..} renderPass = do+  context <- ask+  let device = getDevice context+  let+    Vk.Extent2D{width, height} = sExtent+    mipLevels = extentMips sExtent++  (colorKey, color) <- Resource.allocate+    ( Image.create+        context+        (Just $ sLabel <> ".color")+        Vk.IMAGE_ASPECT_COLOR_BIT+        sExtent+        (if sMipMap then mipLevels else 1)+        sLayers+        sSamples+        sFormat+        (Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_SAMPLED_BIT)+    )+    (Image.destroy context)++  (depthKey, depth) <- Resource.allocate+    ( Image.create+        context+        (Just $ sLabel <> ".depth")+        Vk.IMAGE_ASPECT_DEPTH_BIT+        sExtent+        (if sMipMap then mipLevels else 1)+        sLayers+        sSamples+        sDepthFormat+        (Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_SAMPLED_BIT)+    )+    (Image.destroy context)++  let+    attachments = Vector.fromList+      [ Image.aiImageView color+      , Image.aiImageView depth+      ]++    {- XXX:+      If the render pass uses multiview, then layers must be one and each attachment+      requires a number of layers that is greater than the maximum bit index set in+      the view mask in the subpasses in which it is used.+    -}+    fbNumLayers =+      if sMultiView then+        1+      else+        sLayers++    fbCI = zero+      { Vk.renderPass  = renderPass+      , Vk.width       = width+      , Vk.height      = height+      , Vk.attachments = attachments+      , Vk.layers      = fbNumLayers+      }++  (framebufferKey, framebuffer) <- Vk.withFramebuffer device fbCI Nothing Resource.allocate+  Debug.nameObject device framebuffer $ encodeUtf8 sLabel <> ".FB"++  releaseDebug <- toIO $ logDebug "Releasing Offscreen resources"+  release <- newRefCounted do+    releaseDebug+    Resource.release colorKey+    Resource.release depthKey+    Resource.release framebufferKey++  pure (release, color, depth, framebuffer)++extentMips :: Num t => Vk.Extent2D -> t+extentMips Vk.Extent2D{width, height} = go 1 (min width height)+  where+    go levels = \case+      0 ->+        levels+      1 ->+        levels+      side ->+        go (levels + 1) (side `div` 2)

@@ -25,14 +25,14 @@ import Resource.Collection qualified as Collection  data Collection a = Collection-  { linearMipRepeat  :: a-  , linearMip        :: a-  , linearRepeat     :: a-  , linear           :: a-  , nearestMipRepeat :: a-  , nearestMip       :: a-  , nearestRepeat    :: a-  , nearest          :: a+  { linearMipRepeat  :: a -- 0+  , linearMip        :: a -- 1+  , linearRepeat     :: a -- 2+  , linear           :: a -- 3+  , nearestMipRepeat :: a -- 4+  , nearestMip       :: a -- 5+  , nearestRepeat    :: a -- 6+  , nearest          :: a -- 7   }   deriving stock (Show, Functor, Foldable, Traversable, Generic, Generic1)   deriving Applicative via (Co Collection)

@@ -1,4 +1,11 @@-module Resource.Image where+module Resource.Image+  ( AllocatedImage(..)+  , create+  , destroy+  , subresource+  , transitionLayout+  , copyBufferToImage+  ) where  import RIO @@ -11,137 +18,65 @@ import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA -import Engine.Vulkan.Types (HasVulkan(..), HasSwapchain(..), Queues(..))+import Engine.Vulkan.Types (HasVulkan(..), Queues(..)) import Resource.CommandBuffer (oneshot_)  data AllocatedImage = AllocatedImage-  { aiAllocation :: VMA.Allocation-  , aiImage      :: Vk.Image-  , aiImageView  :: Vk.ImageView+  { aiAllocation  :: VMA.Allocation+  , aiFormat      :: Vk.Format+  , aiImage       :: Vk.Image+  , aiImageView   :: Vk.ImageView+  , aiImageRange  :: Vk.ImageSubresourceRange   }   deriving (Show) -createColorResource+create   :: ( MonadIO io      , HasVulkan ctx-     , HasSwapchain ctx      )   => ctx+  -> Maybe Text+  -> Vk.ImageAspectFlags   -> Vk.Extent2D+  -> "mip levels" ::: Word32+  -> "stored layers" ::: Word32+  -> Vk.SampleCountFlagBits+  -> Vk.Format+  -> Vk.ImageUsageFlags   -> io AllocatedImage-createColorResource context Vk.Extent2D{width, height} = do+create context mlabel aspect Vk.Extent2D{width, height} mipLevels numLayers samples format usage = do   let     device    = getDevice context     allocator = getAllocator context-    format    = getSurfaceFormat context-    msaa      = getMultisample context    (image, allocation, _info) <- VMA.createImage     allocator-    (imageCI format msaa)-    imageAllocationCI-  Debug.nameObject device image "ColorResource.image"--  imageView <- Vk.createImageView-    device-    (imageViewCI image format)-    Nothing-  Debug.nameObject device image "ColorResource.view"--  pure AllocatedImage-    { aiAllocation = allocation-    , aiImage      = image-    , aiImageView  = imageView-    }-  where-    imageCI format msaa = zero-      { Vk.imageType     = Vk.IMAGE_TYPE_2D-      , Vk.format        = format-      , Vk.extent        = Vk.Extent3D width height 1-      , Vk.mipLevels     = 1-      , Vk.arrayLayers   = 1-      , Vk.tiling        = Vk.IMAGE_TILING_OPTIMAL-      , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED-      , Vk.usage         = Vk.IMAGE_USAGE_TRANSIENT_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT-      , Vk.sharingMode   = Vk.SHARING_MODE_EXCLUSIVE-      , Vk.samples       = msaa-      }--    imageAllocationCI = zero-      { VMA.usage         = VMA.MEMORY_USAGE_GPU_ONLY-      , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT-      }--    imageViewCI image format = zero-      { Vk.image            = image-      , Vk.viewType         = Vk.IMAGE_VIEW_TYPE_2D-      , Vk.format           = format-      , Vk.components       = zero-      , Vk.subresourceRange = subr-      }--    subr = zero-      { Vk.aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT-      , Vk.baseMipLevel   = 0-      , Vk.levelCount     = 1-      , Vk.baseArrayLayer = 0-      , Vk.layerCount     = 1-      }--createDepthResource-  :: ( MonadIO io-     , HasVulkan context-     , HasSwapchain context-     )-  => context-  -> Vk.Extent2D-  -> "shadowmap layers" ::: Maybe Word32-  -> io AllocatedImage-createDepthResource context Vk.Extent2D{width, height} depthLayers = do-  let-    device    = getDevice context-    allocator = getAllocator context--    depthFormat = getDepthFormat context-    msaa        = getMultisample context--    (samples, usage, numLayers) =-      case depthLayers of-        Nothing ->-          ( msaa-          , Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT-          , 1-          )-        Just nl ->-          ( Vk.SAMPLE_COUNT_1_BIT-          , Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|.-            Vk.IMAGE_USAGE_SAMPLED_BIT-          , nl-          )--  (image, allocation, _info) <- VMA.createImage-    allocator-    (imageCI depthFormat usage samples numLayers)+    imageCI     imageAllocationCI-  Debug.nameObject device image "DepthResource.image"+  for_ mlabel \label ->+    Debug.nameObject device image $ encodeUtf8 label <> ".label"    imageView <- Vk.createImageView     device-    (imageViewCI depthFormat image numLayers)+    (imageViewCI image)     Nothing-  Debug.nameObject device image "DepthResource.view"+  for_ mlabel \label ->+    Debug.nameObject device image $ encodeUtf8 label <> ".view"    pure AllocatedImage     { aiAllocation = allocation+    , aiFormat     = format     , aiImage      = image     , aiImageView  = imageView+    , aiImageRange = subr     }   where-    imageCI format usage samples numLayers = zero+    imageCI = zero       { Vk.imageType     = Vk.IMAGE_TYPE_2D+      , Vk.flags         = createFlags       , Vk.format        = format       , Vk.extent        = Vk.Extent3D width height 1-      , Vk.mipLevels     = 1+      , Vk.mipLevels     = mipLevels       , Vk.arrayLayers   = numLayers       , Vk.tiling        = Vk.IMAGE_TILING_OPTIMAL       , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED@@ -155,54 +90,53 @@       , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT       } -    imageViewCI format image numLayers = zero+    imageViewCI image = zero       { Vk.image            = image       , Vk.viewType         = viewType       , Vk.format           = format       , Vk.components       = zero-      , Vk.subresourceRange = subr numLayers+      , Vk.subresourceRange = subr       }-      where-        viewType =-          if numLayers > 1 then-            Vk.IMAGE_VIEW_TYPE_2D_ARRAY-          else-            Vk.IMAGE_VIEW_TYPE_2D -    subr numLayers = zero-      { Vk.aspectMask     = Vk.IMAGE_ASPECT_DEPTH_BIT-      , Vk.baseMipLevel   = 0-      , Vk.levelCount     = 1-      , Vk.baseArrayLayer = 0-      , Vk.layerCount     = numLayers-      }+    (createFlags, viewType) =+      case numLayers of+        1 ->+          (zero, Vk.IMAGE_VIEW_TYPE_2D)+        6 ->+          (Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT, Vk.IMAGE_VIEW_TYPE_CUBE)+        _ ->+          (zero, Vk.IMAGE_VIEW_TYPE_2D_ARRAY) -destroyAllocatedImage+    subr = subresource aspect mipLevels numLayers++destroy   :: ( MonadIO io      , HasVulkan context      )   => context   -> AllocatedImage   -> io ()-destroyAllocatedImage context AllocatedImage{..} = do+destroy context AllocatedImage{..} = do   -- traceM "destroyAllocatedImage"   Vk.destroyImageView (getDevice context) aiImageView Nothing   VMA.destroyImage (getAllocator context) aiImage aiAllocation  -------------------------------------------- -transitionImageLayout-  :: (HasVulkan context)+transitionLayout+  :: ( HasVulkan context+     , MonadUnliftIO m+     )   => context   -> Queues Vk.CommandPool   -> Vk.Image   -> "mip levels" ::: Word32   -> "layer count" ::: Word32   -> Vk.Format-  -> ("old" ::: Vk.ImageLayout)-  -> ("new" ::: Vk.ImageLayout)-  -> RIO env ()-transitionImageLayout ctx pool image mipLevels layerCount format old new =+  -> "old" ::: Vk.ImageLayout+  -> "new" ::: Vk.ImageLayout+  -> m ()+transitionLayout ctx pool image mipLevels layerCount format old new =   case (old, new) of     (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) ->       oneshot_ ctx pool qTransfer \buf ->@@ -269,6 +203,27 @@       , Vk.subresourceRange    = subresource aspectMask mipLevels layerCount       } +-- imageBarrier cb oldLayout newLayout aspectMask srcStage srcMask dstStage dstMask image mipLevels layerCount =+--   Vk.cmdPipelineBarrier+--     cb+--     srcStage+--     dstStage+--     zero+--     mempty+--     mempty+--     (Vector.singleton barrier)+--   where+--     barrier = SomeStruct zero+--       { Vk.srcAccessMask       = srcMask+--       , Vk.dstAccessMask       = dstMask+--       , Vk.oldLayout           = oldLayout+--       , Vk.newLayout           = newLayout+--       , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+--       , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+--       , Vk.image               = image+--       , Vk.subresourceRange    = subresource aspectMask mipLevels layerCount+--       }+ subresource   :: Vk.ImageAspectFlags   -> "mip levels" ::: Word32@@ -283,7 +238,11 @@   }  copyBufferToImage-  :: (HasVulkan context, Foldable t, Integral deviceSize)+  :: ( HasVulkan context+     , Foldable t+     , Integral deviceSize+     , MonadUnliftIO m+     )   => context   -> Queues Vk.CommandPool   -> Vk.Buffer@@ -291,7 +250,7 @@   -> "base extent" ::: Vk.Extent3D   -> "mip offsets" ::: t deviceSize   -> "layer count" ::: Word32-  -> RIO env ()+  -> m () copyBufferToImage ctx pool src dst Vk.Extent3D{..} mipOffsets layerCount =   oneshot_ ctx pool qTransfer \cmd ->     Vk.cmdCopyBufferToImage cmd src dst Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $

@@ -3,6 +3,7 @@ import RIO  import Codec.Compression.Zstd qualified as Zstd+import Codec.Serialise qualified as CBOR import Crypto.Hash.MD5 qualified as MD5 import Data.Binary.Get (runGet) import Data.Binary.Get qualified as Get@@ -10,6 +11,7 @@ import Data.Binary.Put qualified as Put import Data.ByteString.Internal qualified as BSI import Data.ByteString.Unsafe (unsafePackCStringLen)+import Data.Typeable (typeRep, typeRepTyCon) import Data.Vector qualified as Vector import Data.Vector.Generic qualified as Generic import Data.Vector.Storable qualified as Storable@@ -21,16 +23,15 @@ import UnliftIO.Resource (MonadResource) import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk-import Data.Typeable -import Engine.Vulkan.Types (HasVulkan, Queues)+import Engine.Vulkan.Types (MonadVulkan, Queues) import Resource.Buffer qualified as Buffer import Resource.Model qualified as Model  -- * Format meta  pattern VER_BREAKS :: Word8-pattern VER_BREAKS = 2+pattern VER_BREAKS = 3  pattern VER_TWEAKS :: Word8 pattern VER_TWEAKS = 0@@ -45,7 +46,7 @@      , Generic.Vector vn nodes      , Storable attrs      , Storable nodes-     , Storable meta+     , CBOR.Serialise meta      , HasLogFunc env      )   => FilePath@@ -68,7 +69,7 @@   (nodDigest, nodCompressed) <- encodeItems nodes   logDebug $ "Node digest: " <> displayShow nodDigest -  (metDigest, metCompressed) <- encodeItems $ Storable.singleton meta+  let (metSize, metDigest, metCompressed) = encodeCBOR meta   logDebug $ "Meta digest: " <> displayShow metDigest    withFile fp WriteMode \out -> do@@ -102,7 +103,7 @@       Put.putWord32le . fromIntegral $ ByteString.length nodCompressed        -- 0x30 + 4 + 4-      Put.putWord32le . fromIntegral $ Foreign.sizeOf (error "sizeOf" :: meta)+      Put.putWord32le $ fromIntegral metSize       Put.putWord32le . fromIntegral $ ByteString.length metCompressed        -- 0x38 + 4 + 4@@ -155,21 +156,30 @@       !zBuf = Zstd.compress Zstd.maxCLevel buf     pure (bufHash, zBuf) +encodeCBOR :: CBOR.Serialise a => a -> (Int, ByteString, ByteString)+encodeCBOR stuff =+  ( ByteString.length buf+  , MD5.hash buf+  , Zstd.compress Zstd.maxCLevel buf+  )+  where+    buf = BSL.toStrict (CBOR.serialise stuff)+ -- * Decoding  loadIndexed   :: ( Storable attrs      , Storable nodes-     , Storable meta+     , CBOR.Serialise meta      , Show meta      , Typeable nodes-     , HasVulkan env      , HasLogFunc env-     , MonadResource (RIO env)+     , MonadResource m+     , MonadVulkan env m      )   => Queues Vk.CommandPool   -> FilePath-  -> RIO env+  -> m     ( Resource.ReleaseKey     , (meta, Storable.Vector nodes, Model.Indexed 'Buffer.Staged Vec3.Packed attrs)     )@@ -185,15 +195,17 @@   pure (key, (meta, nodes, indexed))  loadBlobs-  :: forall attrs env nodes meta+  :: forall attrs env nodes meta m   .  ( Storable attrs-     , Storable meta+     , CBOR.Serialise meta      , Storable nodes      , Typeable nodes      , HasLogFunc env+     , MonadReader env m+     , MonadIO m      )   => FilePath-  -> RIO env+  -> m     ( meta     , Storable.Vector nodes     , ( Storable.Vector Vec3.Packed@@ -233,7 +245,7 @@        sizeOfMeta <- fmap fromIntegral Get.getWord32le       lenMeta    <- fmap fromIntegral Get.getWord32le-      guardEq "Meta size" (Foreign.sizeOf (error "sizeOf" :: meta)) sizeOfMeta+      -- guardEq "Meta size" (Foreign.sizeOf (error "sizeOf" :: meta)) sizeOfMeta        _reserved32 <- Get.getWord32le       _reserved32 <- Get.getWord32le@@ -267,10 +279,11 @@       indices   <- decodeItems "Indices"    indDigest (Just numIndices)   zIndices       attrs     <- decodeItems "Attributes" attDigest (Just numPositions) zAttrs       nodes     <- decodeItems "Nodes"      nodDigest Nothing             zNodes-      meta      <- decodeItems "Metadata"   metDigest (Just 1)            zMetas -      pure (verTweaks, Storable.head meta, nodes, (positions, indices, attrs))+      meta      <- decodeCBOR  "Metadata"   metDigest sizeOfMeta          zMetas +      pure (verTweaks, meta, nodes, (positions, indices, attrs))+   let (verTweaks, meta, nodes, blobs) = runGet getter blob    when (verTweaks /= VER_TWEAKS) $@@ -324,6 +337,33 @@       pure items   where     itemSize = Foreign.sizeOf @item undefined++decodeCBOR+  :: ( CBOR.Serialise a+     , MonadFail m+     )+  => String+  -> ByteString+  -> Int+  -> ByteString+  -> m a+decodeCBOR label digest expectedSize zBytes =+  case Zstd.decompress zBytes of+    Zstd.Error err ->+      fail $ label <> ": zstd error (" <> err <> ")"+    Zstd.Skip ->+      fail $ label <> ": empty zstd"+    Zstd.Decompress bytes -> do+      guardEq (label <> " size") expectedSize (ByteString.length bytes)+      guardEq (label <> " hash") digest (MD5.hash bytes)+      case CBOR.deserialiseOrFail (BSL.fromStrict bytes) of+        Right value ->+          pure value+        Left (CBOR.DeserialiseFailure _off err) ->+          fail $ unlines+            [ label <> " deserialise failure:"+            , err+            ]  -- * Utils 

@@ -23,17 +23,27 @@   , sizeAa    , HasRange(..)++  , encodeStorable+  , decodeStorable   ) where  import RIO +import Codec.Serialise qualified as CBOR+import Codec.Serialise.Decoding qualified as CBOR (Decoder, decodeBytes)+import Codec.Serialise.Encoding qualified as CBOR (Encoding) import Control.Foldl qualified as L+import Data.ByteString.Unsafe qualified as BS+import Data.Typeable (typeRep, typeRepTyCon) import Foreign (Storable(..), castPtr)+import Foreign qualified import Foreign.Storable.Generic (GStorable) import Geomancy (Transform(..), Vec2, Vec4, withVec3) import Geomancy.Mat4 qualified as Mat4 import Geomancy.Vec3 qualified as Vec3 import RIO.Vector.Storable qualified as Storable+import System.IO.Unsafe (unsafePerformIO) import Vulkan.Zero (Zero(..))  import Resource.Model (IndexRange(..))@@ -74,6 +84,8 @@     pokeElemOff (castPtr ptr) 1 aaY     pokeElemOff (castPtr ptr) 2 aaZ +instance (CBOR.Serialise a) => CBOR.Serialise (AxisAligned a)+ -- * Whole-scene metadata  data Meta = Meta@@ -106,6 +118,27 @@       Mat4.toListRowMajor (mTransformBB b)     ] +instance CBOR.Serialise Meta where+  encode Meta{..} = mconcat+    [ CBOR.encode    mOpaqueIndices+    , CBOR.encode    mBlendedIndices+    , CBOR.encode    mOpaqueNodes+    , CBOR.encode    mBlendedNodes+    , encodeStorable mBoundingSphere+    , encodeStorable mTransformBB+    , CBOR.encode    mMeasurements+    ]++  decode = do+    mOpaqueIndices  <- CBOR.decode+    mBlendedIndices <- CBOR.decode+    mOpaqueNodes    <- CBOR.decode+    mBlendedNodes   <- CBOR.decode+    mBoundingSphere <- decodeStorable+    mTransformBB    <- decodeStorable+    mMeasurements   <- CBOR.decode+    pure Meta{..}+ -- * Scene parts  data NodeGroup@@ -223,6 +256,8 @@     pokeByteOff ptr  8 mMean     pokeByteOff ptr 12 mStd +instance CBOR.Serialise Measurements+ {-# INLINEABLE middleAa #-} middleAa :: AxisAligned Measurements -> AxisAligned Float middleAa = fmap middle@@ -303,3 +338,45 @@   adjustRange tn@TexturedNode{tnNode} newFirstIndex = tn     { tnNode = adjustRange tnNode newFirstIndex     }++-- | CBOR.encode helper for storable types (vectors, etc.)+{-# NOINLINE encodeStorable #-}+encodeStorable :: forall a . Storable a => a -> CBOR.Encoding+encodeStorable x = unsafePerformIO do+  ptr <- Foreign.malloc @a+  poke ptr x+  buf <- BS.unsafePackMallocCStringLen+    ( Foreign.castPtr ptr+    , Foreign.sizeOf (undefined :: a)+    )+  pure $ CBOR.encode buf++-- | CBOR.decode helper for storable types (vectors, etc.)+decodeStorable :: forall a s . (Storable a, Typeable a) => CBOR.Decoder s a+decodeStorable = do+  buf <- CBOR.decodeBytes+  case fromBuf buf of+    Left err ->+      fail err+    Right !res ->+      pure res+  where+    expected =+      Foreign.sizeOf (undefined :: a)++    {-# NOINLINE fromBuf #-}+    fromBuf :: ByteString -> Either String a+    fromBuf buf =+      unsafePerformIO $+        BS.unsafeUseAsCStringLen buf \(ptr, len) ->+          if len == expected then do+            !res <- Foreign.peek (Foreign.castPtr ptr)+            pure $ Right res+          else+            pure . Left $ mconcat+              [ "Storable size mismatch for "+              , show (typeRepTyCon . typeRep $ Proxy @a)+              , " (expected: ", show expected+              , ", got: ", show len+              , ")"+              ]

@@ -2,6 +2,7 @@  import RIO +import Codec.Serialise qualified as CBOR import Data.List qualified as List import Data.Vector.Storable qualified as Storable import Foreign (Storable(..))@@ -65,7 +66,9 @@   { irFirstIndex :: Word32   , irIndexCount :: Word32   }-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic)++instance CBOR.Serialise IndexRange  instance Storable IndexRange where   alignment ~_ = 4

@@ -40,7 +40,7 @@  import Engine.Vulkan.Types (HasVulkan(getDevice), MonadVulkan, Queues) import Resource.Collection qualified as Collection-import Resource.Image (AllocatedImage(..), destroyAllocatedImage, subresource)+import Resource.Image (AllocatedImage(..)) import Resource.Image qualified as Image  data TextureError@@ -128,7 +128,7 @@  destroy :: (MonadIO io, HasVulkan context) => context -> Texture a -> io () destroy context Texture{tAllocatedImage} =-  destroyAllocatedImage context tAllocatedImage+  Image.destroy context tAllocatedImage  createImageView   :: (MonadIO io, HasVulkan context)@@ -156,7 +156,7 @@         Vk.IMAGE_VIEW_TYPE_2D      colorRange =-      subresource Vk.IMAGE_ASPECT_COLOR_BIT mipLevels arrayLayers+      Image.subresource Vk.IMAGE_ASPECT_COLOR_BIT mipLevels arrayLayers  imageCI :: Vk.Format -> Vk.Extent3D -> Word32 -> Word32 -> Vk.ImageCreateInfo '[] imageCI format extent mipLevels arrayLayers = zero

@@ -16,8 +16,7 @@ import Vulkan.Utils.FromGL qualified as FromGL import VulkanMemoryAllocator qualified as VMA -import Engine.Types (StageRIO)-import Engine.Vulkan.Types (HasVulkan(..), Queues)+import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues) import Resource.Image (AllocatedImage(..)) import Resource.Image qualified as Image import Resource.Source (Source(..))@@ -26,19 +25,29 @@ import Resource.Texture qualified as Texture  load-  :: (TextureLayers a, Typeable a, HasCallStack)+  :: ( TextureLayers a+     , MonadVulkan env m+     , MonadThrow m+     , HasLogFunc env+     , Typeable a+     , HasCallStack+     )   => Queues Vk.CommandPool   -> Source-  -> StageRIO st (Texture a)+  -> m (Texture a) load pool source =   withFrozenCallStack $     Source.load (loadBytes pool) source  loadBytes-  :: TextureLayers a+  :: ( TextureLayers a+     , MonadVulkan env m+     , MonadThrow m+     , HasLogFunc env+     )   => Queues Vk.CommandPool   -> ByteString-  -> StageRIO st (Texture a)+  -> m (Texture a) loadBytes pool bytes = do   case Ktx1.fromByteString bytes of     Left (offset, err) -> do@@ -48,11 +57,15 @@       loadKtx1 pool ktx1  loadKtx1-  :: forall a st-  .  (TextureLayers a)+  :: forall a m env+  .  ( TextureLayers a+     , MonadVulkan env m+     , MonadThrow m+     , HasLogFunc env+     )   => Queues Vk.CommandPool   -> Ktx1.Ktx-  -> StageRIO st (Texture a)+  -> m (Texture a) loadKtx1 pool Ktx1.Ktx{header, images=ktxImages} = do   context <- ask   let vma = getAllocator context@@ -122,7 +135,7 @@     (Texture.imageCI format extent mipLevels numLayers)     Texture.imageAllocationCI -  Image.transitionImageLayout+  Image.transitionLayout     context     pool     image@@ -185,7 +198,7 @@    -- XXX: staging buffer is gone -  Image.transitionImageLayout+  Image.transitionLayout     context     pool     image@@ -205,8 +218,10 @@   let     allocatedImage = AllocatedImage       { aiAllocation = allocation+      , aiFormat     = format       , aiImage      = image       , aiImageView  = imageView+      , aiImageRange = Image.subresource Vk.IMAGE_ASPECT_COLOR_BIT mipLevels numLayers       }   pure Texture     { tFormat         = format