{-# LANGUAGE AllowAmbiguousTypes #-}

module Resource.Texture
  ( Texture(..)
  , destroy

  , TextureError(..)
    -- * Texture types
  , Flat
  , CubeMap
  , ArrayOf
  , TextureLayers(..)

    -- * Utilities
  , allocateCollectionWith
  , allocateTextureWith
  , debugNameCollection
  , TextureLoader

  , createImageView
  , imageCI
  , imageAllocationCI
  , stageBufferCI
  , stageAllocationCI
  ) where

import RIO

import Data.Bits ((.|.))
import Data.List qualified as List
import GHC.Stack (withFrozenCallStack)
import GHC.TypeLits (Nat, KnownNat, natVal)
import RIO.FilePath (takeBaseName)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))
import Vulkan.Utils.Debug qualified as Debug
import Vulkan.Zero (zero)
import VulkanMemoryAllocator qualified as VMA

import Engine.Vulkan.Types (HasVulkan(getDevice), MonadVulkan, Queues)
import Resource.Collection qualified as Collection
import Resource.Image (AllocatedImage(..))
import Resource.Image qualified as Image

data TextureError
  = LoadError Int64 Text
  | LayerError Word32 Word32
  | MipLevelsError Word32 Int
  | ArrayError Word32 Word32
  deriving (TextureError -> TextureError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextureError -> TextureError -> Bool
$c/= :: TextureError -> TextureError -> Bool
== :: TextureError -> TextureError -> Bool
$c== :: TextureError -> TextureError -> Bool
Eq, Eq TextureError
TextureError -> TextureError -> Bool
TextureError -> TextureError -> Ordering
TextureError -> TextureError -> TextureError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TextureError -> TextureError -> TextureError
$cmin :: TextureError -> TextureError -> TextureError
max :: TextureError -> TextureError -> TextureError
$cmax :: TextureError -> TextureError -> TextureError
>= :: TextureError -> TextureError -> Bool
$c>= :: TextureError -> TextureError -> Bool
> :: TextureError -> TextureError -> Bool
$c> :: TextureError -> TextureError -> Bool
<= :: TextureError -> TextureError -> Bool
$c<= :: TextureError -> TextureError -> Bool
< :: TextureError -> TextureError -> Bool
$c< :: TextureError -> TextureError -> Bool
compare :: TextureError -> TextureError -> Ordering
$ccompare :: TextureError -> TextureError -> Ordering
Ord, Int -> TextureError -> ShowS
[TextureError] -> ShowS
TextureError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextureError] -> ShowS
$cshowList :: [TextureError] -> ShowS
show :: TextureError -> String
$cshow :: TextureError -> String
showsPrec :: Int -> TextureError -> ShowS
$cshowsPrec :: Int -> TextureError -> ShowS
Show)

instance Exception TextureError

data Texture a = Texture
  { forall a. Texture a -> Format
tFormat         :: Vk.Format
  , forall a. Texture a -> Word32
tMipLevels      :: Word32
  , forall a. Texture a -> Word32
tLayers         :: Word32 -- ^ Actual number of layers, up to @ArrayOf a@
  , forall a. Texture a -> AllocatedImage
tAllocatedImage :: AllocatedImage
  }
  deriving (Int -> Texture a -> ShowS
forall a. Int -> Texture a -> ShowS
forall a. [Texture a] -> ShowS
forall a. Texture a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Texture a] -> ShowS
$cshowList :: forall a. [Texture a] -> ShowS
show :: Texture a -> String
$cshow :: forall a. Texture a -> String
showsPrec :: Int -> Texture a -> ShowS
$cshowsPrec :: forall a. Int -> Texture a -> ShowS
Show)

data CubeMap
data Flat
data ArrayOf (layers :: Nat)

-- | Number of expected texture layers to load from resource.
class TextureLayers a where
  textureLayers :: Word32

instance TextureLayers CubeMap where
  textureLayers :: Word32
textureLayers = Word32
6

instance TextureLayers Flat where
  textureLayers :: Word32
textureLayers = Word32
1

instance KnownNat n => TextureLayers (ArrayOf n) where
  textureLayers :: Word32
textureLayers = forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)

type TextureLoader m layers = Vk.Format -> Queues Vk.CommandPool -> FilePath -> m (Texture layers)

type TextureLoaderAction src m layers = src -> m (Texture layers)

-- * Allocation wrappers

allocateCollectionWith
  :: (Resource.MonadResource m, MonadVulkan env m, Traversable t)
  => TextureLoaderAction src m layers
  -> t src
  -> m (Resource.ReleaseKey, t (Texture layers))
allocateCollectionWith :: forall (m :: * -> *) env (t :: * -> *) src layers.
(MonadResource m, MonadVulkan env m, Traversable t) =>
TextureLoaderAction src m layers
-> t src -> m (ReleaseKey, t (Texture layers))
allocateCollectionWith TextureLoaderAction src m layers
action t src
collection = do
  t (ReleaseKey, Texture layers)
res <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) env src layers.
(MonadResource m, MonadVulkan env m) =>
TextureLoaderAction src m layers
-> src -> m (ReleaseKey, Texture layers)
allocateTextureWith TextureLoaderAction src m layers
action) t src
collection
  ReleaseKey
key <- forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) t (ReleaseKey, Texture layers)
res
  pure (ReleaseKey
key, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd t (ReleaseKey, Texture layers)
res)

allocateTextureWith
  :: (Resource.MonadResource m, MonadVulkan env m)
  => TextureLoaderAction src m layers
  -> src
  -> m (Resource.ReleaseKey, Texture layers)
allocateTextureWith :: forall (m :: * -> *) env src layers.
(MonadResource m, MonadVulkan env m) =>
TextureLoaderAction src m layers
-> src -> m (ReleaseKey, Texture layers)
allocateTextureWith TextureLoaderAction src m layers
action src
path = do
  env
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Texture layers)
createTexture <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall a b. (a -> b) -> a -> b
$ TextureLoaderAction src m layers
action src
path
  forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate IO (Texture layers)
createTexture (forall (io :: * -> *) context a.
(MonadIO io, HasVulkan context) =>
context -> Texture a -> io ()
destroy env
context)

debugNameCollection
  :: ( Traversable t
     , MonadVulkan env m
     , HasLogFunc env
     , HasCallStack
     )
  => t (Texture layers)
  -> t FilePath
  -> m ()
debugNameCollection :: forall (t :: * -> *) env (m :: * -> *) layers.
(Traversable t, MonadVulkan env m, HasLogFunc env, HasCallStack) =>
t (Texture layers) -> t String -> m ()
debugNameCollection t (Texture layers)
textures t String
paths = do
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [((Nat, String), Texture layers)]
names \((Nat
ix, String
path), Texture{AllocatedImage
tAllocatedImage :: AllocatedImage
$sel:tAllocatedImage:Texture :: forall a. Texture a -> AllocatedImage
tAllocatedImage}) -> do
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow (Nat
ix, String
path)
    forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device (AllocatedImage -> Image
Image.aiImage AllocatedImage
tAllocatedImage) forall a b. (a -> b) -> a -> b
$
      forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show @Natural Nat
ix forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> ShowS
takeBaseName String
path
  where
    names :: [((Nat, String), Texture layers)]
names = forall a b. [a] -> [b] -> [(a, b)]
List.zip
      (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) ix a.
(Traversable t, Num ix) =>
t a -> t (ix, a)
Collection.enumerate t String
paths)
      (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Texture layers)
textures)

-- * Implementation

destroy :: (MonadIO io, HasVulkan context) => context -> Texture a -> io ()
destroy :: forall (io :: * -> *) context a.
(MonadIO io, HasVulkan context) =>
context -> Texture a -> io ()
destroy context
context Texture{AllocatedImage
tAllocatedImage :: AllocatedImage
$sel:tAllocatedImage:Texture :: forall a. Texture a -> AllocatedImage
tAllocatedImage} =
  forall (io :: * -> *) context.
(MonadIO io, HasVulkan context) =>
context -> AllocatedImage -> io ()
Image.destroy context
context AllocatedImage
tAllocatedImage

createImageView
  :: (MonadIO io, HasVulkan context)
  => context
  -> Vk.Image
  -> Vk.Format
  -> "mip levels" ::: Word32
  -> "array layers" ::: Word32
  -> io Vk.ImageView
createImageView :: forall (io :: * -> *) context.
(MonadIO io, HasVulkan context) =>
context -> Image -> Format -> Word32 -> Word32 -> io ImageView
createImageView context
context Image
image Format
format Word32
mipLevels Word32
arrayLayers =
  forall (a :: [*]) (io :: * -> *).
(Extendss ImageViewCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ImageViewCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
Vk.createImageView (forall a. HasVulkan a => a -> Device
getDevice context
context) ImageViewCreateInfo '[]
imageViewCI forall a. Maybe a
Nothing
  where
    imageViewCI :: ImageViewCreateInfo '[]
imageViewCI = forall a. Zero a => a
zero
      { $sel:image:ImageViewCreateInfo :: Image
Vk.image            = Image
image
      , $sel:viewType:ImageViewCreateInfo :: ImageViewType
Vk.viewType         = ImageViewType
viewType
      , $sel:format:ImageViewCreateInfo :: Format
Vk.format           = Format
format
      , $sel:components:ImageViewCreateInfo :: ComponentMapping
Vk.components       = forall a. Zero a => a
zero
      , $sel:subresourceRange:ImageViewCreateInfo :: ImageSubresourceRange
Vk.subresourceRange = ImageSubresourceRange
colorRange
      }

    viewType :: ImageViewType
viewType =
      if Word32
arrayLayers forall a. Eq a => a -> a -> Bool
== Word32
6 then
        ImageViewType
Vk.IMAGE_VIEW_TYPE_CUBE
      else
        ImageViewType
Vk.IMAGE_VIEW_TYPE_2D

    colorRange :: ImageSubresourceRange
colorRange =
      ImageAspectFlags -> Word32 -> Word32 -> ImageSubresourceRange
Image.subresource ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT Word32
mipLevels Word32
arrayLayers

imageCI :: Vk.Format -> Vk.Extent3D -> Word32 -> Word32 -> Vk.ImageCreateInfo '[]
imageCI :: Format -> Extent3D -> Word32 -> Word32 -> ImageCreateInfo '[]
imageCI Format
format Extent3D
extent Word32
mipLevels Word32
arrayLayers = forall a. Zero a => a
zero
  { $sel:flags:ImageCreateInfo :: ImageCreateFlagBits
Vk.flags         = ImageCreateFlagBits
flags
  , $sel:imageType:ImageCreateInfo :: ImageType
Vk.imageType     = ImageType
Vk.IMAGE_TYPE_2D
  , $sel:format:ImageCreateInfo :: Format
Vk.format        = Format
format
  , $sel:extent:ImageCreateInfo :: Extent3D
Vk.extent        = Extent3D
extent
  , $sel:mipLevels:ImageCreateInfo :: Word32
Vk.mipLevels     = Word32
mipLevels
  , $sel:arrayLayers:ImageCreateInfo :: Word32
Vk.arrayLayers   = if Bool
isCube then Word32
6 else Word32
arrayLayers
  , $sel:tiling:ImageCreateInfo :: ImageTiling
Vk.tiling        = ImageTiling
Vk.IMAGE_TILING_OPTIMAL
  , $sel:initialLayout:ImageCreateInfo :: ImageLayout
Vk.initialLayout = ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
  , $sel:usage:ImageCreateInfo :: ImageUsageFlags
Vk.usage         = ImageUsageFlags
usage
  , $sel:sharingMode:ImageCreateInfo :: SharingMode
Vk.sharingMode   = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
  , $sel:samples:ImageCreateInfo :: SampleCountFlagBits
Vk.samples       = SampleCountFlagBits
Vk.SAMPLE_COUNT_1_BIT -- XXX: no multisampling here
  }
  where
    isCube :: Bool
isCube =
      Word32
arrayLayers forall a. Eq a => a -> a -> Bool
== Word32
6

    usage :: ImageUsageFlags
usage =
      ImageUsageFlags
Vk.IMAGE_USAGE_SAMPLED_BIT forall a. Bits a => a -> a -> a
.|.  -- Sampler
      ImageUsageFlags
Vk.IMAGE_USAGE_TRANSFER_DST_BIT -- Staging

    flags :: ImageCreateFlagBits
flags =
      if Bool
isCube then
        ImageCreateFlagBits
Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT
      else
        forall a. Zero a => a
zero

imageAllocationCI :: VMA.AllocationCreateInfo
imageAllocationCI :: AllocationCreateInfo
imageAllocationCI = forall a. Zero a => a
zero
  { $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage         = MemoryUsage
VMA.MEMORY_USAGE_GPU_ONLY
  , $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlags
VMA.requiredFlags = MemoryPropertyFlags
Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
  }

stageBufferCI :: Integral a => a -> Vk.BufferCreateInfo '[]
stageBufferCI :: forall a. Integral a => a -> BufferCreateInfo '[]
stageBufferCI a
pixelBytes = forall a. Zero a => a
zero
  { $sel:size:BufferCreateInfo :: DeviceSize
Vk.size        = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
pixelBytes
  , $sel:usage:BufferCreateInfo :: BufferUsageFlags
Vk.usage       = BufferUsageFlags
Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
  , $sel:sharingMode:BufferCreateInfo :: SharingMode
Vk.sharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
  }

stageAllocationCI :: VMA.AllocationCreateInfo
stageAllocationCI :: AllocationCreateInfo
stageAllocationCI = forall a. Zero a => a
zero
  { $sel:flags:AllocationCreateInfo :: AllocationCreateFlags
VMA.flags         = AllocationCreateFlags
VMA.ALLOCATION_CREATE_MAPPED_BIT
  , $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage         = MemoryUsage
VMA.MEMORY_USAGE_CPU_TO_GPU
  , $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlags
VMA.requiredFlags = MemoryPropertyFlags
Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT
  }