module Mischief.Render.Texture where

import Codec.Picture qualified as P
import Codec.Picture.Extra (scaleBilinear)
import Control.Applicative.Singletons
import Control.Monad.IO.Class
import Data.Default (Default (def))
import Data.Maybe.Singletons (SMaybe (SJust))
import Data.Singletons
import Data.Vector.Storable (Vector)
import Data.Vector.Storable qualified as VS
import Foreign (Bits ((.|.)), Ptr, Word32, Word8, castPtr, nullPtr, with)
import Foreign.C.ConstPtr (ConstPtr (..))
import GHC.TypeLits
import Mischief.Assets
import Mischief.Assets.Image
import Mischief.ECS
import Mischief.Render.Core
import Mischief.Render.TextureFormat
import Mischief.WGPU
import Mischief.WGPU.Opaque
import Mischief.WGPU.Types.Enums
import Mischief.WGPU.Types.General

data Texture = Texture {Texture -> Ptr WGPUTexture
texture :: Ptr WGPUTexture, Texture -> TextureDescriptor
desc :: TextureDescriptor}

data SwappableTexture = SwappableTexture {SwappableTexture -> Ptr WGPUTexture
currentTexture :: Ptr WGPUTexture, SwappableTexture -> Ptr WGPUTexture
otherTexture :: Ptr WGPUTexture, SwappableTexture -> TextureDescriptor
desc :: TextureDescriptor}

extractTexture :: SwappableTexture -> Texture
extractTexture :: SwappableTexture -> Texture
extractTexture SwappableTexture {Ptr WGPUTexture
currentTexture :: SwappableTexture -> Ptr WGPUTexture
currentTexture :: Ptr WGPUTexture
currentTexture, TextureDescriptor
desc :: SwappableTexture -> TextureDescriptor
desc :: TextureDescriptor
desc} = Ptr WGPUTexture -> TextureDescriptor -> Texture
Texture Ptr WGPUTexture
currentTexture TextureDescriptor
desc

swapTexture :: SwappableTexture -> (SwappableTexture, Texture)
swapTexture :: SwappableTexture -> (SwappableTexture, Texture)
swapTexture SwappableTexture {Ptr WGPUTexture
currentTexture :: SwappableTexture -> Ptr WGPUTexture
currentTexture :: Ptr WGPUTexture
currentTexture, Ptr WGPUTexture
otherTexture :: SwappableTexture -> Ptr WGPUTexture
otherTexture :: Ptr WGPUTexture
otherTexture, TextureDescriptor
desc :: SwappableTexture -> TextureDescriptor
desc :: TextureDescriptor
desc} = (SwappableTexture {currentTexture :: Ptr WGPUTexture
currentTexture = Ptr WGPUTexture
otherTexture, otherTexture :: Ptr WGPUTexture
otherTexture = Ptr WGPUTexture
currentTexture, TextureDescriptor
desc :: TextureDescriptor
desc :: TextureDescriptor
desc}, Ptr WGPUTexture -> TextureDescriptor -> Texture
Texture Ptr WGPUTexture
currentTexture TextureDescriptor
desc)

newtype TextureView = TextureView (Ptr WGPUTextureView)

data TextureDescriptor = TextureDescriptor
  { TextureDescriptor -> Int
width :: Int,
    TextureDescriptor -> Int
height :: Int,
    TextureDescriptor -> Int
depth :: Int,
    TextureDescriptor -> String
label :: String,
    TextureDescriptor -> Int
mipLevels :: Int,
    TextureDescriptor -> Int
samples :: Int,
    TextureDescriptor -> TextureFormat
format :: TextureFormat,
    TextureDescriptor -> [TextureUsage]
usages :: [TextureUsage]
  }
  deriving (Int -> TextureDescriptor -> ShowS
[TextureDescriptor] -> ShowS
TextureDescriptor -> String
(Int -> TextureDescriptor -> ShowS)
-> (TextureDescriptor -> String)
-> ([TextureDescriptor] -> ShowS)
-> Show TextureDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextureDescriptor -> ShowS
showsPrec :: Int -> TextureDescriptor -> ShowS
$cshow :: TextureDescriptor -> String
show :: TextureDescriptor -> String
$cshowList :: [TextureDescriptor] -> ShowS
showList :: [TextureDescriptor] -> ShowS
Show)

instance Default TextureDescriptor where
  def :: TextureDescriptor
def = TextureDescriptor
textureDescriptor

textureDescriptor :: TextureDescriptor
textureDescriptor :: TextureDescriptor
textureDescriptor =
  TextureDescriptor
    { width :: Int
width = Int
1,
      height :: Int
height = Int
1,
      depth :: Int
depth = Int
1,
      label :: String
label = String
"texture",
      mipLevels :: Int
mipLevels = Int
1,
      samples :: Int
samples = Int
1,
      format :: TextureFormat
format = TextureFormat
RGBA8UnormSrgb,
      usages :: [TextureUsage]
usages = [TextureUsage
TextureUsageTextureBinding, TextureUsage
TextureUsageCopyDst, TextureUsage
TextureUsageRenderAttachment]
    }

data TextureUsage
  = TextureUsageNone
  | TextureUsageCopySrc
  | TextureUsageCopyDst
  | TextureUsageTextureBinding
  | TextureUsageStorageBinding
  | TextureUsageRenderAttachment
  | TextureUsageTransientAttachment
  deriving (Int -> TextureUsage -> ShowS
[TextureUsage] -> ShowS
TextureUsage -> String
(Int -> TextureUsage -> ShowS)
-> (TextureUsage -> String)
-> ([TextureUsage] -> ShowS)
-> Show TextureUsage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextureUsage -> ShowS
showsPrec :: Int -> TextureUsage -> ShowS
$cshow :: TextureUsage -> String
show :: TextureUsage -> String
$cshowList :: [TextureUsage] -> ShowS
showList :: [TextureUsage] -> ShowS
Show)

usageBits :: TextureUsage -> WGPUTextureUsage
usageBits :: TextureUsage -> WGPUTextureUsage
usageBits TextureUsage
TextureUsageNone = WGPUTextureUsage
wGPUTextureUsage_None
usageBits TextureUsage
TextureUsageCopySrc = WGPUTextureUsage
wGPUTextureUsage_CopySrc
usageBits TextureUsage
TextureUsageCopyDst = WGPUTextureUsage
wGPUTextureUsage_CopyDst
usageBits TextureUsage
TextureUsageTextureBinding = WGPUTextureUsage
wGPUTextureUsage_TextureBinding
usageBits TextureUsage
TextureUsageStorageBinding = WGPUTextureUsage
wGPUTextureUsage_StorageBinding
usageBits TextureUsage
TextureUsageRenderAttachment = WGPUTextureUsage
wGPUTextureUsage_RenderAttachment
usageBits TextureUsage
TextureUsageTransientAttachment = WGPUTextureUsage
wGPUTextureUsage_TransientAttachment

processUsages :: [TextureUsage] -> WGPUTextureUsage
processUsages :: [TextureUsage] -> WGPUTextureUsage
processUsages = (TextureUsage -> WGPUTextureUsage -> WGPUTextureUsage)
-> WGPUTextureUsage -> [TextureUsage] -> WGPUTextureUsage
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (WGPUTextureUsage -> WGPUTextureUsage -> WGPUTextureUsage
forall a. Bits a => a -> a -> a
(.|.) (WGPUTextureUsage -> WGPUTextureUsage -> WGPUTextureUsage)
-> (TextureUsage -> WGPUTextureUsage)
-> TextureUsage
-> WGPUTextureUsage
-> WGPUTextureUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextureUsage -> WGPUTextureUsage
usageBits) (WGPUFlags -> WGPUTextureUsage
WGPUTextureUsage (Word64 -> WGPUFlags
WGPUFlags Word64
0))

createSwappableTexture :: RenderDevice -> TextureDescriptor -> IO SwappableTexture
createSwappableTexture :: RenderDevice -> TextureDescriptor -> IO SwappableTexture
createSwappableTexture RenderDevice
device TextureDescriptor
desc = do
  a <- RenderDevice -> TextureDescriptor -> IO (Ptr WGPUTexture)
createTexture' RenderDevice
device TextureDescriptor
desc
  b <- createTexture' device desc
  pure $ SwappableTexture a b desc

createTexture :: RenderDevice -> TextureDescriptor -> IO Texture
createTexture :: RenderDevice -> TextureDescriptor -> IO Texture
createTexture RenderDevice
device TextureDescriptor
desc = (Ptr WGPUTexture -> TextureDescriptor -> Texture
`Texture` TextureDescriptor
desc) (Ptr WGPUTexture -> Texture) -> IO (Ptr WGPUTexture) -> IO Texture
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RenderDevice -> TextureDescriptor -> IO (Ptr WGPUTexture)
createTexture' RenderDevice
device TextureDescriptor
desc

createTexture' :: RenderDevice -> TextureDescriptor -> IO (Ptr WGPUTexture)
createTexture' :: RenderDevice -> TextureDescriptor -> IO (Ptr WGPUTexture)
createTexture' (RenderDevice Ptr WGPUDevice
device) TextureDescriptor
descriptor = IO (Ptr WGPUTexture) -> IO (Ptr WGPUTexture)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr WGPUTexture) -> IO (Ptr WGPUTexture))
-> IO (Ptr WGPUTexture) -> IO (Ptr WGPUTexture)
forall a b. (a -> b) -> a -> b
$ do
  let TextureDescriptor {Int
width :: TextureDescriptor -> Int
width :: Int
width, Int
height :: TextureDescriptor -> Int
height :: Int
height, Int
depth :: TextureDescriptor -> Int
depth :: Int
depth, String
label :: TextureDescriptor -> String
label :: String
label, Int
mipLevels :: TextureDescriptor -> Int
mipLevels :: Int
mipLevels, Int
samples :: TextureDescriptor -> Int
samples :: Int
samples, TextureFormat
format :: TextureDescriptor -> TextureFormat
format :: TextureFormat
format, [TextureUsage]
usages :: TextureDescriptor -> [TextureUsage]
usages :: [TextureUsage]
usages} = TextureDescriptor
descriptor
  String
-> (WGPUStringView -> IO (Ptr WGPUTexture)) -> IO (Ptr WGPUTexture)
forall a. String -> (WGPUStringView -> IO a) -> IO a
withWGPUString String
label ((WGPUStringView -> IO (Ptr WGPUTexture)) -> IO (Ptr WGPUTexture))
-> (WGPUStringView -> IO (Ptr WGPUTexture)) -> IO (Ptr WGPUTexture)
forall a b. (a -> b) -> a -> b
$ \WGPUStringView
label -> do
    let desc :: WGPUTextureDescriptor
desc =
          WGPUTextureDescriptor
            { size :: WGPUExtent3D
size = Word32 -> Word32 -> Word32 -> WGPUExtent3D
WGPUExtent3D (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
depth),
              WGPUStringView
label :: WGPUStringView
label :: WGPUStringView
label,
              mipLevelCount :: Word32
mipLevelCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mipLevels,
              sampleCount :: Word32
sampleCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
samples,
              dimension :: WGPUTextureDimension
dimension = WGPUTextureDimension
wGPUTextureDimension_2D,
              format :: WGPUTextureFormat
format = TextureFormat -> WGPUTextureFormat
toWGPUFormat TextureFormat
format,
              usage :: WGPUTextureUsage
usage = [TextureUsage] -> WGPUTextureUsage
processUsages [TextureUsage]
usages,
              nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr,
              viewFormatCount :: CSize
viewFormatCount = CSize
0,
              viewFormats :: ConstPtr WGPUTextureFormat
viewFormats = Ptr WGPUTextureFormat -> ConstPtr WGPUTextureFormat
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUTextureFormat
forall a. Ptr a
nullPtr
            }

    WGPUTextureDescriptor
-> (Ptr WGPUTextureDescriptor -> IO (Ptr WGPUTexture))
-> IO (Ptr WGPUTexture)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPUTextureDescriptor
desc (Ptr WGPUDevice
-> ConstPtr WGPUTextureDescriptor -> IO (Ptr WGPUTexture)
wgpuDeviceCreateTexture Ptr WGPUDevice
device (ConstPtr WGPUTextureDescriptor -> IO (Ptr WGPUTexture))
-> (Ptr WGPUTextureDescriptor -> ConstPtr WGPUTextureDescriptor)
-> Ptr WGPUTextureDescriptor
-> IO (Ptr WGPUTexture)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr WGPUTextureDescriptor -> ConstPtr WGPUTextureDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr)

getDimension :: (Int, Int, Int) -> WGPUTextureDimension
getDimension :: (Int, Int, Int) -> WGPUTextureDimension
getDimension (Int
_, Int
1, Int
1) = WGPUTextureDimension
wGPUTextureDimension_1D
getDimension (Int
_, Int
_, Int
1) = WGPUTextureDimension
wGPUTextureDimension_2D
getDimension (Int
_, Int
_, Int
_) = WGPUTextureDimension
wGPUTextureDimension_3D

uploadImage :: RenderQueue -> Image -> Texture -> IO ()
uploadImage :: RenderQueue -> Image -> Texture -> IO ()
uploadImage (RenderQueue Ptr WGPUQueue
queue) (Image DynamicImage
image) (Texture {Ptr WGPUTexture
texture :: Texture -> Ptr WGPUTexture
texture :: Ptr WGPUTexture
texture, desc :: Texture -> TextureDescriptor
desc = TextureDescriptor {Int
width :: TextureDescriptor -> Int
width :: Int
width, Int
height :: TextureDescriptor -> Int
height :: Int
height}}) = do
  let (P.Image Int
w Int
h Vector (PixelBaseComponent PixelRGBA8)
bytes) = Int -> Int -> Image PixelRGBA8 -> Image PixelRGBA8
forall a.
(Pixel a, Bounded (PixelBaseComponent a),
 Integral (PixelBaseComponent a)) =>
Int -> Int -> Image a -> Image a
scaleBilinear Int
width Int
height (DynamicImage -> Image PixelRGBA8
P.convertRGBA8 DynamicImage
image)

  let extent :: WGPUExtent3D
extent = Word32 -> Word32 -> Word32 -> WGPUExtent3D
WGPUExtent3D (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h) Word32
1
  let copyInfo :: WGPUTexelCopyTextureInfo
copyInfo =
        WGPUTexelCopyTextureInfo
          { Ptr WGPUTexture
texture :: Ptr WGPUTexture
texture :: Ptr WGPUTexture
texture,
            mipLevel :: Word32
mipLevel = Word32
0,
            origin :: WGPUOrigin3D
origin = Word32 -> Word32 -> Word32 -> WGPUOrigin3D
WGPUOrigin3D Word32
0 Word32
0 Word32
0,
            aspect :: WGPUTextureAspect
aspect = WGPUTextureAspect
wGPUTextureAspect_All
          }

  let layout :: WGPUTexelCopyBufferLayout
layout =
        WGPUTexelCopyBufferLayout
          { offset :: Word64
offset = Word64
0,
            bytesPerRow :: Word32
bytesPerRow = Word32
4 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w,
            rowsPerImage :: Word32
rowsPerImage = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
          }

  Vector Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VS.unsafeWith Vector Word8
Vector (PixelBaseComponent PixelRGBA8)
bytes ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pixelPtr -> do
    WGPUExtent3D -> (Ptr WGPUExtent3D -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPUExtent3D
extent ((Ptr WGPUExtent3D -> IO ()) -> IO ())
-> (Ptr WGPUExtent3D -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr WGPUExtent3D
extent -> do
      WGPUTexelCopyTextureInfo
-> (Ptr WGPUTexelCopyTextureInfo -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPUTexelCopyTextureInfo
copyInfo ((Ptr WGPUTexelCopyTextureInfo -> IO ()) -> IO ())
-> (Ptr WGPUTexelCopyTextureInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr WGPUTexelCopyTextureInfo
copyInfo -> do
        WGPUTexelCopyBufferLayout
-> (Ptr WGPUTexelCopyBufferLayout -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPUTexelCopyBufferLayout
layout ((Ptr WGPUTexelCopyBufferLayout -> IO ()) -> IO ())
-> (Ptr WGPUTexelCopyBufferLayout -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr WGPUTexelCopyBufferLayout
layout -> do
          Ptr WGPUQueue
-> ConstPtr WGPUTexelCopyTextureInfo
-> ConstPtr Void
-> CSize
-> ConstPtr WGPUTexelCopyBufferLayout
-> ConstPtr WGPUExtent3D
-> IO ()
wgpuQueueWriteTexture Ptr WGPUQueue
queue (Ptr WGPUTexelCopyTextureInfo -> ConstPtr WGPUTexelCopyTextureInfo
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUTexelCopyTextureInfo
copyInfo) (Ptr Void -> ConstPtr Void
forall a. Ptr a -> ConstPtr a
ConstPtr (Ptr Void -> ConstPtr Void) -> Ptr Void -> ConstPtr Void
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Void
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
pixelPtr) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CSize) -> Int -> CSize
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> Int
forall a. Storable a => Vector a -> Int
VS.length Vector Word8
Vector (PixelBaseComponent PixelRGBA8)
bytes) (Ptr WGPUTexelCopyBufferLayout -> ConstPtr WGPUTexelCopyBufferLayout
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUTexelCopyBufferLayout
layout) (Ptr WGPUExtent3D -> ConstPtr WGPUExtent3D
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUExtent3D
extent)

createTextureForImage :: RenderDevice -> Image -> IO Texture
createTextureForImage :: RenderDevice -> Image -> IO Texture
createTextureForImage RenderDevice
device (Image DynamicImage
image) = do
  let (P.Image Int
w Int
h Vector (PixelBaseComponent PixelRGBA8)
_) = DynamicImage -> Image PixelRGBA8
P.convertRGBA8 DynamicImage
image
  RenderDevice -> TextureDescriptor -> IO Texture
createTexture
    RenderDevice
device
    TextureDescriptor
      { width :: Int
width = Int
w,
        height :: Int
height = Int
h,
        depth :: Int
depth = Int
1,
        label :: String
label = String
"texture",
        mipLevels :: Int
mipLevels = Int
1,
        samples :: Int
samples = Int
1,
        format :: TextureFormat
format = TextureFormat
RGBA8UnormSrgb,
        usages :: [TextureUsage]
usages = [TextureUsage
TextureUsageTextureBinding, TextureUsage
TextureUsageCopyDst]
      }

createView :: Texture -> System TextureView
createView :: Texture -> System TextureView
createView Texture {Ptr WGPUTexture
texture :: Texture -> Ptr WGPUTexture
texture :: Ptr WGPUTexture
texture} = IO TextureView -> System TextureView
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TextureView -> System TextureView)
-> IO TextureView -> System TextureView
forall a b. (a -> b) -> a -> b
$ Ptr WGPUTextureView -> TextureView
TextureView (Ptr WGPUTextureView -> TextureView)
-> IO (Ptr WGPUTextureView) -> IO TextureView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr WGPUTexture
-> ConstPtr WGPUTextureViewDescriptor -> IO (Ptr WGPUTextureView)
wgpuTextureCreateView Ptr WGPUTexture
texture (Ptr WGPUTextureViewDescriptor -> ConstPtr WGPUTextureViewDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUTextureViewDescriptor
forall a. Ptr a
nullPtr)