From 1f9434b06c8d259056ac86fba2f0c0d5597601bb Mon Sep 17 00:00:00 2001
From: nek0 <nek0@nek0.eu>
Date: Sun, 14 May 2023 18:50:02 +0200
Subject: [PATCH] init textures

---
 src/Textures.hs       | 147 ++++++++++++++++++++++++++++++++++++++++++
 src/Types.hs          |   1 +
 vulkan-tutorial.cabal |   2 +
 3 files changed, 150 insertions(+)
 create mode 100644 src/Textures.hs

diff --git a/src/Textures.hs b/src/Textures.hs
new file mode 100644
index 0000000..16bc336
--- /dev/null
+++ b/src/Textures.hs
@@ -0,0 +1,147 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Textures where
+
+import qualified Codec.Picture as P
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource
+import qualified Data.Vector as V
+import qualified Data.Vector.Storable as VS
+import Foreign
+import qualified Vulkan as Vk
+import qualified Vulkan.CStruct.Extends as Vk
+import qualified Vulkan.Zero as Vk
+import qualified VulkanMemoryAllocator as VMA
+
+-- internal imports
+
+import Types
+import Memory
+import Sync
+
+loadImageFromFile
+  :: (MonadResource m, MonadIO m)
+  => EngineData
+  -> FilePath
+  -> m AllocatedImage
+loadImageFromFile engineData file = do
+
+  pixels <- liftIO $ either error P.convertRGBA8 <$> P.readImage file
+
+  let texWidth = P.imageWidth pixels
+      texHeight = P.imageHeight pixels
+      imageSize = 4 * texWidth * texHeight
+      imageFormat = Vk.FORMAT_R8G8B8A8_SRGB
+
+  stagingBuffer <-
+    createAllocatedBuffer
+    (engineAllocator engineData)
+    imageSize
+    Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
+    VMA.MEMORY_USAGE_CPU_ONLY
+
+  let dataPtr = VMA.mappedData (bufferInfo stagingBuffer)
+
+  liftIO $ V.mapM_
+    (\(idx, px) ->
+      poke
+        (castPtr dataPtr `plusPtr` (idx * sizeOf px))
+        px
+      )
+    (V.zip
+      (V.fromList [0..])
+      (V.convert $ P.imageData pixels)
+    )
+
+  let imageExtent = Vk.Extent3D
+        { width  = fromIntegral $ texWidth
+        , height = fromIntegral $ texHeight
+        , depth  = 1
+        }
+      dImgCreateInfo = Vk.zero
+        { Vk.format = imageFormat
+        , Vk.usage  = Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT
+        , Vk.extent = imageExtent
+        }
+      dImgAllocCreateInfo = Vk.zero
+        { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
+        } :: VMA.AllocationCreateInfo
+
+  (newImage, allocation, _) <- snd <$>
+    VMA.withImage (engineAllocator engineData) dImgCreateInfo dImgAllocCreateInfo allocate
+
+  immediateSubmit
+    (engineUploadContext engineData)
+    (engineQueue engineData)
+    (engineLogicalDevice engineData)
+    (\cmd -> do
+      let range = Vk.zero
+            { Vk.aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT
+            , Vk.baseMipLevel   = 0
+            , Vk.levelCount     = 1
+            , Vk.baseArrayLayer = 0
+            , Vk.layerCount     = 1
+            }
+          imageBarrierToTransfer = V.singleton $ Vk.SomeStruct (Vk.zero
+            { Vk.oldLayout        = Vk.IMAGE_LAYOUT_UNDEFINED
+            , Vk.newLayout        = Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
+            , Vk.image            = newImage
+            , Vk.subresourceRange = range
+            , Vk.srcAccessMask    = bit 0
+            , Vk.dstAccessMask    = Vk.ACCESS_TRANSFER_WRITE_BIT
+            } :: Vk.ImageMemoryBarrier '[])
+
+      Vk.cmdPipelineBarrier
+        cmd
+        Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT
+        Vk.PIPELINE_STAGE_TRANSFER_BIT
+        (bit 0)
+        V.empty
+        V.empty
+        imageBarrierToTransfer
+
+      let copyRegion = V.singleton (Vk.zero
+            { Vk.bufferOffset      = 0
+            , Vk.bufferRowLength   = 0
+            , Vk.bufferImageHeight = 0
+            , Vk.imageExtent       = imageExtent
+            , Vk.imageSubresource  = Vk.zero
+              { Vk.aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT
+              , Vk.mipLevel       = 0
+              , Vk.baseArrayLayer = 0
+              , Vk.layerCount     = 1
+              } :: Vk.ImageSubresourceLayers
+            } :: Vk.BufferImageCopy)
+
+      Vk.cmdCopyBufferToImage
+        cmd
+        (allocatedBuffer stagingBuffer)
+        newImage
+        Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
+        copyRegion
+
+      let imageBarrierToReadable = V.singleton $ Vk.SomeStruct (Vk.zero
+            { Vk.oldLayout = Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
+            , Vk.newLayout = Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
+            , Vk.image            = newImage
+            , Vk.subresourceRange = range
+            , Vk.srcAccessMask = Vk.ACCESS_TRANSFER_WRITE_BIT
+            , Vk.dstAccessMask = Vk.ACCESS_SHADER_READ_BIT
+            } :: Vk.ImageMemoryBarrier '[])
+
+      Vk.cmdPipelineBarrier
+        cmd
+        Vk.PIPELINE_STAGE_TRANSFER_BIT
+        Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT
+        (bit 0)
+        V.empty
+        V.empty
+        imageBarrierToReadable
+      )
+
+  return $ AllocatedImage
+    { image = newImage
+    , allocation = allocation
+    }
diff --git a/src/Types.hs b/src/Types.hs
index 8c3637e..15e068c 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -44,6 +44,7 @@ data EngineData = EngineData
   , engineSceneParameters  :: GPUSceneData
   , engineUploadContext    :: UploadContext
   } 
+  deriving (Show)
 
 data AllocatedBuffer = AllocatedBuffer
   { allocatedBuffer  :: Vk.Buffer
diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal
index 6134990..b0c1026 100644
--- a/vulkan-tutorial.cabal
+++ b/vulkan-tutorial.cabal
@@ -35,6 +35,7 @@ executable vulkan-tutorial
                       Mesh
                       Image
                       Sync
+                      Textures
                       Types
                       Util
 
@@ -55,6 +56,7 @@ executable vulkan-tutorial
                     , resourcet
                     , mtl
                     , containers
+                    , JuicyPixels
     hs-source-dirs:   src
     default-language: Haskell2010
     ghc-options:      -Wall