implement textures which crash initialization

flake.lock

@@ -20,11 +20,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1682786779,
-        "narHash": "sha256-m7QFzPS/CE8hbkbIVK4UStihAQMtczr0vSpOgETOM1g=",
+        "lastModified": 1684120848,
+        "narHash": "sha256-gIwJ5ac1FwZEkCRwjY+gLwgD4G1Bw3Xtr2jr2XihMPo=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "08e4dc3a907a6dfec8bb3bbf1540d8abbffea22b",
+        "rev": "0cb867999eec4085e1c9ca61c09b72261fa63bb4",
         "type": "github"
       },
       "original": {

src/CommandBuffer.hs

@@ -20,8 +20,6 @@ import qualified VulkanMemoryAllocator as VMA
 
 -- internal imports
 
-import Devices
-import Sync
 import Types
 import Memory
 import Util
@@ -34,16 +32,21 @@ maxObjects = 10000
 
 createFrames
   :: (MonadResource m, MonadFail m)
-  => Vk.PhysicalDevice
-  -> Vk.Device
+  => Vk.Device
   -> VMA.Allocator
   -> Vk.DescriptorPool
   -> Vk.DescriptorSetLayout
   -> Vk.DescriptorSetLayout
+  -> Word32
   -> m (V.Vector FrameData, Vk.Queue)
-createFrames physicalDevice logicalDevice allocator descriptorPool setLayout objectSetLayout = do
-
-  queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
+createFrames
+  logicalDevice
+  allocator
+  descriptorPool
+  setLayout
+  objectSetLayout
+  queueFamilyIndex
+  = do
 
   let poolCreateInfo = Vk.zero
         { Vk.flags            = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT

src/Devices.hs

@@ -90,7 +90,7 @@ createLogicalDevice
   :: (MonadResource m)
   => Vk.PhysicalDevice
   -> Vk.SurfaceKHR
-  -> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
+  -> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR, Word32)
 createLogicalDevice physDevice surface = do
 
   graphicsQueueFamily <- getQueueFamily physDevice Vk.QUEUE_GRAPHICS_BIT
@@ -120,7 +120,7 @@ createLogicalDevice physDevice surface = do
   unless (result == Vk.SUCCESS) $
     error "createLogicalDevice: Failed retrieving surface image formats"
 
-  return (logDevice, formats)
+  return (logDevice, formats, graphicsQueueFamily)
 
 createSwapchain
   :: (MonadResource m)

src/Init.hs

@@ -31,6 +31,7 @@ import Types
 import Mesh
 import CommandBuffer
 import Sync
+import Textures
 import Util
 
 initEngine
@@ -88,9 +89,10 @@ initVulkan window = do
       )
 
   vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-  (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
+  (vulkanLogicalDevice, surfaceFormats, queueIndex) <-
+    createLogicalDevice vulkanPhysicalDevice vulkanSurface
 
-  uploadContext <- initSyncStructures vulkanPhysicalDevice vulkanLogicalDevice
+  uploadContext <- initSyncStructures vulkanLogicalDevice queueIndex
 
   (descriptorSetLayout1, descriptorSetLayout2, descriptorPool) <- initDescriptors vulkanLogicalDevice
 
@@ -123,15 +125,17 @@ initVulkan window = do
 
   (frames, queue) <-
     createFrames
-      vulkanPhysicalDevice
       vulkanLogicalDevice
       allocator
       descriptorPool
       descriptorSetLayout1
       descriptorSetLayout2
+      queueIndex
 
   loadMeshes allocator uploadContext queue vulkanLogicalDevice
 
+  loadImages allocator uploadContext queue vulkanLogicalDevice
+
   initScene
 
   return $ EngineData

src/Main.hs

@@ -28,11 +28,13 @@ main = do
   renderablesContainer <- STM.newTMVarIO (V.empty)
   meshMap <- STM.newTMVarIO (M.empty)
   materialMap <- STM.newTMVarIO (M.empty)
+  textureMap <- STM.newTMVarIO (M.empty)
   frameNumber <- STM.newTMVarIO 0
   let initState = ReadState
         { renderables     = renderablesContainer
         , meshLibrary     = meshMap
         , materialLibrary = materialMap
+        , textureLibrary  = textureMap
         }
   runRender initState $ do
     engineData <- initEngine

src/Sync.hs

@@ -7,30 +7,28 @@ module Sync where
 import Control.Monad.Trans.Resource
 import Data.Bits (bit)
 import qualified Data.Vector as V
+import Data.Word
 import qualified Vulkan as Vk
 import qualified Vulkan.Zero as Vk
 
 -- internal imports
 
 import Control.Monad.Reader
-import Devices
 import Types
 import Util
 
 initSyncStructures
   :: (MonadResource m)
-  => Vk.PhysicalDevice
-  -> Vk.Device
+  => Vk.Device
+  -> Word32
   -> m UploadContext
-initSyncStructures physicalDevice logicalDevice = do
+initSyncStructures logicalDevice queueFamilyIndex = do
 
   let fenceCreateInfo = Vk.zero
 
   syncFence <- snd <$>
     Vk.withFence logicalDevice fenceCreateInfo Nothing allocate
 
-  queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
-
   let uploadCommandPoolCreateInfo = Vk.zero
         { Vk.queueFamilyIndex = queueFamilyIndex
         } :: Vk.CommandPoolCreateInfo

src/Textures.hs

@@ -6,10 +6,12 @@ module Textures where
 
 import qualified Codec.Picture as P
 import Control.Monad.IO.Class
+import Control.Monad.Reader
 import Control.Monad.Trans.Resource
+import qualified Data.Map.Strict as M
 import qualified Data.Vector as V
-import qualified Data.Vector.Storable as VS
-import Foreign
+import Foreign hiding (void)
+import qualified Control.Concurrent.STM as STM
 import qualified Vulkan as Vk
 import qualified Vulkan.CStruct.Extends as Vk
 import qualified Vulkan.Zero as Vk
@@ -20,13 +22,17 @@ import qualified VulkanMemoryAllocator as VMA
 import Types
 import Memory
 import Sync
+import Image
 
 loadImageFromFile
   :: (MonadResource m, MonadIO m)
-  => EngineData
+  => VMA.Allocator
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
   -> FilePath
   -> m AllocatedImage
-loadImageFromFile engineData file = do
+loadImageFromFile allocator uploadContext queue device file = do
 
   pixels <- liftIO $ either error P.convertRGBA8 <$> P.readImage file
 
@@ -37,7 +43,7 @@ loadImageFromFile engineData file = do
 
   stagingBuffer <-
     createAllocatedBuffer
-    (engineAllocator engineData)
+    allocator
     imageSize
     Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
     VMA.MEMORY_USAGE_CPU_ONLY
@@ -70,12 +76,12 @@ loadImageFromFile engineData file = do
         } :: VMA.AllocationCreateInfo
 
   (newImage, allocation, _) <- snd <$>
-    VMA.withImage (engineAllocator engineData) dImgCreateInfo dImgAllocCreateInfo allocate
+    VMA.withImage allocator dImgCreateInfo dImgAllocCreateInfo allocate
 
   immediateSubmit
-    (engineUploadContext engineData)
-    (engineQueue engineData)
-    (engineLogicalDevice engineData)
+    uploadContext
+    queue
+    device
     (\cmd -> do
       let range = Vk.zero
             { Vk.aspectMask     = Vk.IMAGE_ASPECT_COLOR_BIT
@@ -145,3 +151,32 @@ loadImageFromFile engineData file = do
     { image = newImage
     , allocation = allocation
     }
+
+loadImages
+  :: (MonadResource m, MonadReader ReadState m)
+  => VMA.Allocator
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
+  -> m ()
+loadImages allocator uploadContext queue device = do
+
+  loadedImage <- loadImageFromFile allocator uploadContext queue device "assets/textures/bricks.png"
+
+  let imageInfo = imageviewCreate (image loadedImage) Vk.FORMAT_R8G8B8A8_SRGB Vk.IMAGE_ASPECT_COLOR_BIT
+
+  imageView <- snd <$> Vk.withImageView device imageInfo Nothing allocate
+
+  let texture = Texture
+        { textureImage     = loadedImage
+        , textureImageView = imageView
+        }
+
+  textureLib <- asks textureLibrary
+
+  void $ liftIO $ STM.atomically $ do
+    texMap <- STM.readTMVar textureLib
+
+    let newMap = M.insert "bricks" texture texMap
+
+    STM.swapTMVar textureLib newMap

src/Types.hs

@@ -173,10 +173,16 @@ data RenderObject = RenderObject
   }
   deriving (Show)
 
+data Texture = Texture
+  { textureImage     :: AllocatedImage
+  , textureImageView :: Vk.ImageView
+  }
+
 data ReadState = ReadState
   { renderables     :: STM.TMVar (V.Vector RenderObject)
   , meshLibrary     :: STM.TMVar (M.Map String Mesh)
   , materialLibrary :: STM.TMVar (M.Map String Material)
+  , textureLibrary  :: STM.TMVar (M.Map String Texture)
   }
 
 newtype RenderReader rd m a = RenderReader