flake update

assets/models/jaeger.mtl

@@ -0,0 +1,13 @@
+# Blender MTL File: 'jaeger.blend'
+# Material Count: 1
+
+newmtl Material_jaeger.texture.tga
+Ns 92.156863
+Ka 1.000000 1.000000 1.000000
+Kd 0.512000 0.512000 0.512000
+Ks 0.500000 0.500000 0.500000
+Ke 0.000000 0.000000 0.000000
+Ni 1.000000
+d 1.000000
+illum 2
+map_Kd jaeger.texture.tga

flake.lock

@@ -5,11 +5,11 @@
         "systems": "systems"
       },
       "locked": {
-        "lastModified": 1681202837,
+        "lastModified": 1694529238,
-        "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=",
+        "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "cfacdce06f30d2b68473a46042957675eebb3401",
+        "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
         "type": "github"
       },
       "original": {
@@ -20,11 +20,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1682786779,
+        "lastModified": 1699181587,
-        "narHash": "sha256-m7QFzPS/CE8hbkbIVK4UStihAQMtczr0vSpOgETOM1g=",
+        "narHash": "sha256-v35mUUgVU2ituIHPNHifpjl5uiYQYyLrpaMtz8X8Ums=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "08e4dc3a907a6dfec8bb3bbf1540d8abbffea22b",
+        "rev": "197629b470f184a47b2a5716312d25b09454bbf8",
         "type": "github"
       },
       "original": {

flake.nix

@@ -11,28 +11,36 @@
       let
         pkgs = nixpkgs.legacyPackages.${system};
 
-        haskellPackages = pkgs.haskellPackages;
+        nixos-lib = import (nixpkgs + "/nixos/lib") {};
+
+        haskellPackages = pkgs.haskellPackages.override (old: {
+          overrides = final: prev: {
+            wavefront = jailbreakUnbreak prev.wavefront;
+            vulkan-tutorial = vulkan-tutorial;
+          };
+        });
+
+        vulkan-tutorial = # (ref:haskell-package-def)
+          haskellPackages.callCabal2nix packageName self {
+            # Dependency overrides go here
+            #wavefront = jailbreakUnbreak haskellPackages.wavefront;
+        };
 
         jailbreakUnbreak = pkg:
-          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
+          pkgs.haskell.lib.doJailbreak (pkgs.haskell.lib.markUnbroken pkg);
 
         packageName = "vulkan-tutorial";
       in rec {
-        packages.${packageName} = # (ref:haskell-package-def)
+        packages.default = haskellPackages.vulkan-tutorial;
-          haskellPackages.callCabal2nix packageName self rec {
-            # Dependency overrides go here
-            wavefront = jailbreakUnbreak haskellPackages.wavefront;
-          };
 
-        defaultPackage = self.packages.${system}.${packageName};
+        devShells.default = haskellPackages.shellFor {
-
+          packages = p: [ p.vulkan-tutorial ];
-        devShell = haskellPackages.shellFor {
-          packages = p: [ defaultPackage ];
           withHoogle = true;
           buildInputs = (with haskellPackages; [
             haskell-language-server
             ghcid
             cabal-install
+            (jailbreakUnbreak wavefront)
           ]) ++ (with pkgs; [
             shaderc
             vulkan-loader
@@ -42,21 +50,6 @@
           VK_LAYER_PATH="${pkgs.vulkan-validation-layers}/share/vulkan/explicit_layer.d";
           SDL_VULKAN_LIBRARY="${pkgs.vulkan-loader}/lib/libvulkan.so";
         };
-        #devShell = pkgs.mkShell {
-        #  buildInputs = with haskellPackages; [
-        #    haskell-language-server
-        #    ghcid
-        #    cabal-install
-        #  ];
-        #  nativeBuildInputs = with pkgs; [
-        #    pkg-config
-        #    SDL2
-        #    vulkan-validation-layers
-        #    vulkan-headers
-        #    vulkan-loader
-        #  ];
-        #  inputsFrom = builtins.attrValues self.packages.${system};
-        #};
     });
 }
 

shadersrc/textured_lit.frag

@@ -0,0 +1,24 @@
+//glsl version 4.5
+#version 450
+
+//shader input
+layout (location = 0) in vec4 inColor;
+layout (location = 1) in vec2 texCoord;
+//output write
+layout (location = 0) out vec4 outFragColor;
+
+layout(set = 0, binding = 1) uniform  SceneData{
+	vec4 fogColor; // w is for exponent
+	vec4 fogDistances; //x for min, y for max, zw unused.
+	vec4 ambientColor;
+	vec4 sunlightDirection; //w for sun power
+	vec4 sunlightColor;
+} sceneData;
+
+layout(set = 2, binding = 0) uniform sampler2D tex1;
+
+void main()
+{
+  vec3 color = texture(tex1, texCoord).xyz;
+	outFragColor = vec4(color, inColor.w);
+}

shadersrc/tri_mesh.vert

@@ -2,8 +2,10 @@
 layout (location = 0) in vec3 vPosition;
 layout (location = 1) in vec3 vNormal;
 layout (location = 2) in vec4 vColor;
+layout (location = 3) in vec2 vTexCoord;
 
 layout (location = 0) out vec4 outColor;
+layout (location = 1) out vec2 texCoord;
 
 layout(set = 0, binding = 0) uniform  CameraBuffer{
 	mat4 view;
@@ -34,4 +36,5 @@ void main()
 	mat4 transformMatrix = (cameraData.viewproj * modelMatrix);
 	gl_Position = transformMatrix * vec4(vPosition, 1.0f);
 	outColor = vColor;
+  texCoord = vTexCoord;
 }

src/CommandBuffer.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -20,10 +19,10 @@ import qualified VulkanMemoryAllocator as VMA
 
 -- internal imports
 
-import Devices
 import Types
 import Memory
 import Util
+import Mesh (compactDraws)
 
 frameOverlap :: Int
 frameOverlap = 2
@@ -33,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
+createFrames
-
+  logicalDevice
-  queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
+  allocator
+  descriptorPool
+  setLayout
+  objectSetLayout
+  queueFamilyIndex
+  = do
 
   let poolCreateInfo = Vk.zero
         { Vk.flags            = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT
@@ -55,7 +59,7 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj
     (\_ -> do
 
       commandPool <- snd <$>
-        (Vk.withCommandPool logicalDevice poolCreateInfo Nothing allocate)
+        Vk.withCommandPool logicalDevice poolCreateInfo Nothing allocate
 
       let commandBufferAllocationInfo = Vk.zero
             { Vk.commandPool        = commandPool
@@ -95,6 +99,15 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj
         Vk.BUFFER_USAGE_STORAGE_BUFFER_BIT
         VMA.MEMORY_USAGE_CPU_TO_GPU
 
+      indirectBuffer <- createAllocatedBuffer
+        allocator
+        (maxObjects * sizeOf (undefined :: Vk.DrawIndirectCommand))
+        (Vk.BUFFER_USAGE_TRANSFER_DST_BIT .|.
+          Vk.BUFFER_USAGE_STORAGE_BUFFER_BIT .|.
+          Vk.BUFFER_USAGE_INDIRECT_BUFFER_BIT
+          )
+        VMA.MEMORY_USAGE_CPU_TO_GPU
+
       let allocationInfo = Vk.zero
             { Vk.descriptorPool = descriptorPool
             , Vk.setLayouts     = V.singleton setLayout
@@ -156,6 +169,7 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj
         , frameCameraBuffer      = cameraBuffer
         , frameSceneBuffer       = sceneBuffer
         , frameObjectBuffer      = objectBuffer
+        , frameIndirectBuffer    = indirectBuffer
         , frameGlobalDescriptor  = V.head globalDescriptor
         , frameObjectDescriptor  = V.head objectDescriptor
         }
@@ -167,7 +181,8 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj
 
 recordCommandBuffer
   :: (MonadResource m, MonadReader ReadState m, MonadIO m)
-  => Vk.CommandBuffer
+  => VMA.Allocator
+  -> Vk.CommandBuffer
   -> Vk.RenderPass
   -> Vk.Framebuffer
   -> V2 CInt
@@ -175,6 +190,7 @@ recordCommandBuffer
   -> FrameData
   -> m ()
 recordCommandBuffer
+  allocator
   commandBuffer
   renderPass
   frameBuffer
@@ -216,18 +232,54 @@ recordCommandBuffer
 
         renderObjects <- (liftIO . STM.atomically . STM.readTMVar) =<< asks renderables
         meshMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary
-
-        V.mapM_
-          (\(index, RenderObject meshID materialID modelMatrix) -> do
-
         materialMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks materialLibrary
 
-            let constants = MeshPushConstants
+        let draws = compactDraws meshMap materialMap renderObjects
-                  { meshPushData     = V4 0 0 0 0
+            drawCommands = V.map
-                  , meshRenderMatrix = transpose modelMatrix
+              (\(i, RenderObject mesh _ _) ->
+                Vk.DrawIndirectCommand
+                  { vertexCount   = fromIntegral (V.length $ meshVertices $ meshMap M.! mesh)
+                  , firstVertex   = 0
+                  , instanceCount = 1
+                  , firstInstance = i
                   }
-                mesh = meshMap M.! meshID
+                )
-                material = materialMap M.! materialID
+              (V.zip
+                (V.fromList [0..])
+                renderObjects
+                )
+
+        (memRelease, memPtr) <- VMA.withMappedMemory
+          allocator
+          (bufferAllocation $ frameIndirectBuffer frame)
+          allocate
+
+        V.mapM_
+          (\(idx, command) -> liftIO $
+            poke
+              (castPtr memPtr `plusPtr` (idx * sizeOf command))
+              command
+          )
+          (V.zip
+            (V.fromList [0 ..])
+            drawCommands
+           )
+
+        release memRelease
+
+        V.mapM_
+          (\(IndirectBatch mesh material first count) -> do
+
+            when
+              (materialTextureSet material /= Vk.NULL_HANDLE)
+              (Vk.cmdBindDescriptorSets
+                commandBuffer
+                Vk.PIPELINE_BIND_POINT_GRAPHICS
+                (materialPipelineLayout material)
+                2
+                (V.singleton $ materialTextureSet material)
+                V.empty
+                )
 
             Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS (materialPipeline material)
 
@@ -247,28 +299,24 @@ recordCommandBuffer
               (V.singleton $ frameObjectDescriptor frame)
               V.empty
 
-            dataPointer <- liftIO (castPtr <$> new constants)
-
-            Vk.cmdPushConstants
-              commandBuffer
-              (materialPipelineLayout material)
-              Vk.SHADER_STAGE_VERTEX_BIT
-              0
-              (fromIntegral $ sizeOf constants)
-              dataPointer
-
             Vk.cmdBindVertexBuffers
               commandBuffer
               0
               (V.fromList [ allocatedBuffer $ meshBuffer mesh ])
               (V.fromList [ 0 ])
 
-            Vk.cmdDraw commandBuffer (fromIntegral $ V.length $ meshVertices mesh) 1 0 index
+            let indirectOffset = fromIntegral $
-            )
+                  first * fromIntegral ( sizeOf (undefined :: Vk.DrawIndirectCommand))
-          (V.zip
+                drawStride = fromIntegral $ sizeOf (undefined :: Vk.DrawIndirectCommand)
-            (V.fromList [0 ..])
+
-            renderObjects
+            Vk.cmdDrawIndirect
+              commandBuffer
+              (allocatedBuffer $ frameIndirectBuffer frame)
+              indirectOffset
+              count
+              drawStride
             )
+          draws
 
 prepareRecording
   :: V2 CInt
@@ -278,11 +326,12 @@ prepareRecording
 prepareRecording (V2 width height) commandBuffer graphicsPipeline = do
   Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS graphicsPipeline
 
+  -- Passing negative height and nonzero y origin to the viewport flips the models back in order
   let viewport = Vk.zero
         { Vk.x        = 0
-        , Vk.y        = 0
+        , Vk.y        = fromIntegral height
         , Vk.width    = fromIntegral width
-        , Vk.height   = fromIntegral height
+        , Vk.height   = - fromIntegral height
         , Vk.minDepth = 0
         , Vk.maxDepth = 1
         }
@@ -323,7 +372,7 @@ pokeData frame frameNumber sceneParameters cameraParameters = do
   V.mapM_
     (\(index, obj) -> do
 
-      let modelMatrix = GPUObjectData (transpose $ objectMatrix obj)
+      let modelMatrix = GPUObjectData (objectMatrix obj)
 
       liftIO $ poke
         (castPtr objectPointer `plusPtr` (index * sizeOf (undefined :: GPUObjectData)))

src/Devices.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 module Devices where
 
 import Control.Monad
@@ -38,7 +39,7 @@ pickPhysicalDevice vkInstance = do
     physDevices
 
   let discretePhysDevices = V.filter
-        (\(_, devProps, devFeatures) ->
+        (\(_, _, devFeatures) ->
           -- Vk.deviceType devProps == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
           Vk.geometryShader devFeatures
           )
@@ -90,7 +91,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
@@ -104,6 +105,9 @@ createLogicalDevice physDevice surface = do
       deviceCreateInfo = Vk.zero
         { Vk.queueCreateInfos      = V.singleton (Vk.SomeStruct queueCreateInfo)
         , Vk.enabledExtensionNames = extensionNames
+        , Vk.enabledFeatures       = Just (Vk.zero
+          { Vk.multiDrawIndirect = True
+          } :: Vk.PhysicalDeviceFeatures)
         }
       shaderDrawParametersFeatures = Vk.zero
         { Vk.shaderDrawParameters  = True
@@ -120,7 +124,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)
@@ -140,9 +144,9 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator =
     if
       V.any
         (\a ->
-          (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) a ==
+          a.format ==
             Vk.FORMAT_B8G8R8A8_SRGB
-          && (Vk.colorSpace :: Vk.SurfaceFormatKHR -> Vk.ColorSpaceKHR) a ==
+          && a.colorSpace ==
             Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR)
         surfaceFormats
     then
@@ -219,7 +223,7 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do
       let createInfo = Vk.zero
             { Vk.image            = tmpImage
             , Vk.viewType         = Vk.IMAGE_VIEW_TYPE_2D
-            , Vk.format           = (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) surfaceFormat
+            , Vk.format           = surfaceFormat.format
             , Vk.components       = Vk.ComponentMapping
               { Vk.r = Vk.COMPONENT_SWIZZLE_IDENTITY
               , Vk.g = Vk.COMPONENT_SWIZZLE_IDENTITY

src/Draw.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 module Draw where
 
 import qualified Control.Concurrent.STM as STM
@@ -57,7 +58,7 @@ drawFrame engineData frameNumber = do
   let (V2 width height) = engineWindowDimensions engineData
       camPosition = V3
         (-10 * sin (fromIntegral frameNumber / 90))
-        (-2)
+        2
         (-10 * cos (fromIntegral frameNumber / 90))
       camCenter = V3 0 0 0
       camUp = V3 0 1 0
@@ -68,9 +69,9 @@ drawFrame engineData frameNumber = do
         0.1
         200
       cameraData = GPUCameraData
-        { view           = transpose camView
+        { view           = camView
-        , projection     = transpose camProjection
+        , projection     = camProjection
-        , viewProjection = transpose $ camProjection !*! camView
+        , viewProjection = camProjection !*! camView
         }
 
   pokeData
@@ -80,6 +81,7 @@ drawFrame engineData frameNumber = do
     cameraData
 
   recordCommandBuffer
+    (engineData.engineAllocator)
     (frameMainCommandBuffer frame)
     (engineRenderPass engineData)
     (engineFramebuffers engineData V.! fromIntegral index)

src/GraphicsPipeline.hs

@@ -194,6 +194,7 @@ createGraphicsPipelines
   -> V2 CInt
   -> Vk.PipelineLayout
   -> Maybe Vk.PipelineDepthStencilStateCreateInfo
+  -> String
   -> m ()
 createGraphicsPipelines
   logicalDevice
@@ -202,6 +203,7 @@ createGraphicsPipelines
   (V2 width height)
   pipelineLayout
   depthState
+  materialName
   = do
     meshLib <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary
     let pipelineStagesCreateInfos =
@@ -304,10 +306,10 @@ createGraphicsPipelines
           error "createGraphicsPipelines: Failed creating pipelines"
         return pipelines
         )
-    let material = Material (V.head pipeline) pipelineLayout
+    let material = Material Vk.NULL_HANDLE (V.head pipeline) pipelineLayout
     matLibraryTMVar <- asks materialLibrary
     matLibrary <- liftIO $ STM.atomically $ STM.readTMVar matLibraryTMVar
-    let newMatLibrary = M.insert "defaultMesh" material matLibrary
+    let newMatLibrary = M.insert materialName material matLibrary
     void $ liftIO $ STM.atomically $ STM.swapTMVar matLibraryTMVar newMatLibrary
 
 createMeshPipelineLayout

src/Init.hs

@@ -10,12 +10,16 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Control.Monad.Trans.Resource
+import Data.Bits
+import qualified Data.Map.Strict as M
+import Data.Maybe
 import qualified Data.Vector as V
 import qualified SDL hiding (V2)
 import qualified SDL.Video.Vulkan as SDL
 import Foreign.Ptr
 import Linear as L
-import qualified Vulkan.Core10 as Vk
+import qualified Vulkan as Vk
+import qualified Vulkan.CStruct.Extends as Vk
 import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
 import qualified Vulkan.Extensions.VK_KHR_surface as Khr
 import qualified Vulkan.Zero as Vk
@@ -30,6 +34,8 @@ import Memory
 import Types
 import Mesh
 import CommandBuffer
+import Sync
+import Textures
 import Util
 
 initEngine
@@ -87,9 +93,13 @@ initVulkan window = do
       )
 
   vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-  (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
+  (vulkanLogicalDevice, surfaceFormats, queueIndex) <-
+    createLogicalDevice vulkanPhysicalDevice vulkanSurface
 
-  (descriptorSetLayout1, descriptorSetLayout2, descriptorPool) <- initDescriptors vulkanLogicalDevice
+  uploadContext <- initSyncStructures vulkanLogicalDevice queueIndex
+
+  (descriptorSetLayout1, descriptorSetLayout2, textureDescriptorSetLayout, descriptorPool) <-
+    initDescriptors vulkanLogicalDevice
 
   allocator <- initAllocator vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance
 
@@ -99,15 +109,26 @@ initVulkan window = do
   imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
   meshVertexShader <- loadShader vulkanLogicalDevice "shadersrc/tri_mesh.vert" "vert"
   meshFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow_lit.frag" "frag"
+  textureFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/textured_lit.frag" "frag"
   renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat) Vk.FORMAT_D32_SFLOAT
   meshLayout <- createMeshPipelineLayout
     vulkanLogicalDevice
     (V.fromList
       [ descriptorSetLayout1
       , descriptorSetLayout2
+      , textureDescriptorSetLayout
+      ]
+      )
+  textureLayout <- createMeshPipelineLayout
+    vulkanLogicalDevice
+    (V.fromList
+      [ descriptorSetLayout1
+      , descriptorSetLayout2
+      , textureDescriptorSetLayout
       ]
       )
   let meshContainer = ShaderContainer (Just meshVertexShader) (Just meshFragmentShader)
+      textureContainer = ShaderContainer (Just meshVertexShader) (Just textureFragmentShader)
   createGraphicsPipelines
     vulkanLogicalDevice
     renderPass
@@ -115,14 +136,32 @@ initVulkan window = do
     dimensions
     meshLayout
     (Just (createDepthStencilStateCreateInfo True True Vk.COMPARE_OP_LESS_OR_EQUAL))
+    "defaultMesh"
+  createGraphicsPipelines
+    vulkanLogicalDevice
+    renderPass
+    textureContainer
+    dimensions
+    textureLayout
+    (Just (createDepthStencilStateCreateInfo True True Vk.COMPARE_OP_LESS_OR_EQUAL))
+    "texturedMesh"
 
   frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews depthImageView dimensions
 
-  (frames, queue) <- createFrames vulkanPhysicalDevice vulkanLogicalDevice allocator descriptorPool descriptorSetLayout1 descriptorSetLayout2
+  (frames, queue) <-
+    createFrames
+      vulkanLogicalDevice
+      allocator
+      descriptorPool
+      descriptorSetLayout1
+      descriptorSetLayout2
+      queueIndex
 
-  loadMeshes allocator
+  loadMeshes allocator uploadContext queue vulkanLogicalDevice
 
-  initScene
+  loadImages allocator uploadContext queue vulkanLogicalDevice
+
+  initScene vulkanLogicalDevice descriptorPool textureDescriptorSetLayout
 
   return $ EngineData
     window
@@ -141,6 +180,7 @@ initVulkan window = do
     frames
     descriptorSetLayout1
     descriptorSetLayout2
+    textureDescriptorSetLayout
     descriptorPool
     (GPUSceneData
       (V4 0 0 0 0)
@@ -149,13 +189,19 @@ initVulkan window = do
       (V4 0 0 0 0)
       (V4 0 0 0 0)
       )
+    uploadContext
 
 
-initScene :: (MonadReader ReadState m, MonadIO m) => m ()
+initScene
-initScene = do
+  :: (MonadReader ReadState m, MonadIO m, MonadResource m)
+  => Vk.Device
+  -> Vk.DescriptorPool
+  -> Vk.DescriptorSetLayout
+  -> m ()
+initScene device descriptorPool texturedSetLayout = do
   let catMask = RenderObject
         { objectMesh     = "mask"
-        , objectMaterial = "defaultMesh"
+        , objectMaterial = "texturedMesh"
         , objectMatrix   = identity
         }
       triangles = V.concatMap
@@ -182,10 +228,51 @@ initScene = do
   void $ liftIO $ STM.atomically $ STM.swapTMVar renderableContainer $
     (renderableVector `V.snoc` catMask) V.++ triangles
 
+  let samplerInfo = samplerCreateInfo Vk.FILTER_NEAREST Vk.SAMPLER_ADDRESS_MODE_REPEAT
+  blockySampler <- snd <$> Vk.withSampler device samplerInfo Nothing allocate
+
+  matLibraryContainer <- asks materialLibrary
+  texturedMaterial <- do
+    matLibrary <- liftIO $ STM.atomically $ STM.readTMVar matLibraryContainer
+    return (fromMaybe (error "not texturedMesh") $ matLibrary M.!? "texturedMesh")
+
+  let allocInfo = Vk.zero
+        { Vk.descriptorPool = descriptorPool
+        , Vk.setLayouts     = V.singleton texturedSetLayout
+        }
+
+  texturedDescriptorSet <- V.head . snd <$> Vk.withDescriptorSets device allocInfo allocate
+
+  liftIO $ do
+    matLibrary <- STM.atomically $ STM.readTMVar matLibraryContainer
+    let material = texturedMaterial
+          { materialTextureSet = texturedDescriptorSet
+          }
+        newMatLibrary = M.insert "texturedMesh" material matLibrary
+    void $ STM.atomically $ STM.swapTMVar matLibraryContainer newMatLibrary
+
+  textureContainer <- asks textureLibrary
+  texture <- do
+    texLibrary <- liftIO $ STM.atomically $ STM.readTMVar textureContainer
+    return $ fromMaybe (error "no marksman texture found") $ texLibrary M.!? "marksman"
+
+  let imageBufferInfo = Vk.zero
+        { Vk.sampler = blockySampler
+        , Vk.imageView = textureImageView texture
+        , Vk.imageLayout = Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
+        }
+      texture1 = V.singleton $ Vk.SomeStruct $ writeDescriptorImage
+        Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
+        texturedDescriptorSet
+        imageBufferInfo
+        0
+
+  Vk.updateDescriptorSets device texture1 V.empty
+
 initDescriptors
   :: (MonadResource m)
   => Vk.Device
-  -> m (Vk.DescriptorSetLayout, Vk.DescriptorSetLayout, Vk.DescriptorPool)
+  -> m (Vk.DescriptorSetLayout, Vk.DescriptorSetLayout, Vk.DescriptorSetLayout, Vk.DescriptorPool)
 initDescriptors device = do
   let cameraBind = descriptorsetLayoutBinding
         Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
@@ -199,6 +286,10 @@ initDescriptors device = do
         Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER
         Vk.SHADER_STAGE_VERTEX_BIT
         0
+      textureBind = descriptorsetLayoutBinding
+        Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
+        Vk.SHADER_STAGE_FRAGMENT_BIT
+        0
       setInfo = Vk.zero
         { Vk.flags = Vk.DESCRIPTOR_SET_LAYOUT_CREATE_UPDATE_AFTER_BIND_POOL_BIT
         , Vk.bindings = V.fromList
@@ -210,8 +301,14 @@ initDescriptors device = do
         { Vk.flags = Vk.DESCRIPTOR_SET_LAYOUT_CREATE_UPDATE_AFTER_BIND_POOL_BIT
         , Vk.bindings = V.singleton objectBind
         }
+      setInfo3 = Vk.zero
+        { Vk.flags = Vk.DESCRIPTOR_SET_LAYOUT_CREATE_UPDATE_AFTER_BIND_POOL_BIT
+        , Vk.bindings = V.singleton textureBind
+        }
       poolInfo = Vk.zero
-        { Vk.flags     = Vk.DESCRIPTOR_POOL_CREATE_UPDATE_AFTER_BIND_BIT
+        { Vk.flags     =
+            Vk.DESCRIPTOR_POOL_CREATE_UPDATE_AFTER_BIND_BIT .|.
+            Vk.DESCRIPTOR_POOL_CREATE_FREE_DESCRIPTOR_SET_BIT
         , Vk.maxSets   = 10
         , Vk.poolSizes = V.fromList
           [ Vk.zero
@@ -226,6 +323,10 @@ initDescriptors device = do
             { Vk.type'           = Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER
             , Vk.descriptorCount = 10
             }
+          , Vk.zero
+            { Vk.type'           = Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
+            , Vk.descriptorCount = 10
+            }
           ]
         }
 
@@ -235,7 +336,10 @@ initDescriptors device = do
   (_, descriptorSetLayout2) <-
     Vk.withDescriptorSetLayout device setInfo2 Nothing allocate
 
+  (_, textureDescriptorSetLayout) <-
+    Vk.withDescriptorSetLayout device setInfo3 Nothing allocate
+
   (_, descriptorPool) <-
     Vk.withDescriptorPool device poolInfo Nothing allocate
 
-  return (descriptorSetLayout1, descriptorSetLayout2, descriptorPool)
+  return (descriptorSetLayout1, descriptorSetLayout2, textureDescriptorSetLayout, descriptorPool)

src/Main.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 module Main where
 
 import qualified Control.Concurrent.STM as STM
@@ -9,10 +11,12 @@ import Control.Monad.Loops
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Resource
 import Data.Bits
+import Data.ByteString.Char8
 import qualified Data.Map.Strict as M
+import Data.Time.Clock
 import qualified Data.Vector as V
-import Data.Word
 import qualified SDL hiding (V2)
+import System.IO (stdout)
 import System.Mem
 import qualified Vulkan as Vk
 import qualified Vulkan.Zero as Vk
@@ -28,11 +32,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
@@ -41,6 +47,8 @@ main = do
 
     -- create abort condition for upcoming lop
     quit <- liftIO $ STM.newTMVarIO True
+    time <- liftIO $ STM.newTMVarIO =<< getCurrentTime
+    average <- liftIO $ STM.newTMVarIO 0
 
     -- main loop
     whileM_
@@ -48,11 +56,24 @@ main = do
         )
       ( do
         liftIO performMajorGC
+        now <- liftIO getCurrentTime
+        before <- liftIO $ STM.atomically $ STM.swapTMVar time now
+        let timeDiff = diffUTCTime now before
+            fps = recip $ nominalDiffTimeToSeconds timeDiff
+        liftIO $ hPutStr stdout $ pack $ "Current FPS: " <> show (floor fps) <> "  \r"
         number <- liftIO $ STM.atomically $ do
           number <- STM.readTMVar frameNumber
+          if number == 0 then
+            void $ STM.swapTMVar average fps
+          else do
+            oldAverage <- STM.readTMVar average
+            let newAverage = (oldAverage * fromIntegral number + fps) / frameCount
+                frameCount = fromIntegral number + 1
+            void $ STM.swapTMVar average newAverage
           void $ STM.swapTMVar frameNumber (succ number)
           return number
         -- draw
+        -- liftIO $ putStr $ show (recip $ nominalDiffTimeToSeconds timeDiff) <> "\r"
         drawFrame engineData number
         -- poll events
         evs <- liftIO SDL.pollEvents
@@ -66,6 +87,12 @@ main = do
           evs
       )
 
+    fps <- liftIO $ STM.atomically $ STM.readTMVar average
+
+    liftIO $ hPutStr stdout $
+      "\n" <>
+      "Average FPS: " <> pack (show fps) <> "\n"
+
     Vk.deviceWaitIdle $ engineLogicalDevice engineData
 
 createBufferView
@@ -101,7 +128,7 @@ allocateMemory logicalDevice buffer = do
   memoryRequirements <- Vk.getBufferMemoryRequirements logicalDevice buffer
 
   let memoryAllocateInfo = Vk.zero
-        { Vk.allocationSize  = (Vk.size :: Vk.MemoryRequirements -> Word64) memoryRequirements
+        { Vk.allocationSize  = memoryRequirements.size
         , Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String)
         }
 

src/Memory.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
 module Memory where
 
 import Control.Monad.IO.Class
@@ -27,9 +28,9 @@ initAllocator
   -> m VMA.Allocator
 initAllocator physicalDevice device instance' = do
   let instanceProcAddr = castFunPtr $
-        Vk.pVkGetInstanceProcAddr ((Vk.instanceCmds :: Vk.Instance -> Vk.InstanceCmds) instance')
+        Vk.pVkGetInstanceProcAddr (instance'.instanceCmds)
       deviceProcAddr = castFunPtr $
-        Vk.pVkGetDeviceProcAddr ((Vk.deviceCmds :: Vk.Device -> Vk.DeviceCmds) device)
+        Vk.pVkGetDeviceProcAddr (device.deviceCmds)
   let allocatorInfo = Vk.zero
         { VMA.physicalDevice  = Vk.physicalDeviceHandle physicalDevice
         , VMA.device          = Vk.deviceHandle device

src/Mesh.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Mesh where
 
 import Codec.Wavefront
@@ -8,15 +9,16 @@ import Codec.Wavefront
 import qualified Control.Concurrent.STM as STM
 import qualified Control.Monad as CM (void)
 import Control.Monad.IO.Class
-import Control.Monad.Reader (asks)
+import Control.Monad.Reader
 import Control.Monad.Trans.Resource
 
 import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
 import qualified Data.Vector as V
 
 import Foreign
 
-import Linear (V3(..), V4(..))
+import Linear (V2(..), V3(..), V4(..))
 
 import qualified VulkanMemoryAllocator as VMA
 import qualified Vulkan.Core10 as Vk
@@ -25,19 +27,29 @@ import qualified Vulkan.Zero as Vk
 -- internal imports
 
 import Types
+import Sync
 
 loadMeshes
-  :: VMA.Allocator
+  :: (MonadReader ReadState m, MonadResource m, MonadFail m)
-  -> Render ()
+  => VMA.Allocator
-loadMeshes allocator = do
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
+  -> m ()
+loadMeshes allocator uploadContext queue device = do
   let triangle = V.fromList
-        [ Vertex (V3 0.5 0.5 0)    (V3 0 0 0) (V4 0 1 0 1)
+        [ Vertex (V3 0.5 0 0)    (V3 0 0 0) (V4 0 1 0 1) (V2 0 0)
-        , Vertex (V3 (-0.5) 0.5 0) (V3 0 0 0) (V4 0 1 0 1)
+        , Vertex (V3 (-0.5) 0 0) (V3 0 0 0) (V4 0 1 0 1) (V2 0 0)
-        , Vertex (V3 0 (-0.5) 0)   (V3 0 0 0) (V4 0 1 0 1)
+        , Vertex (V3 0 1 0)   (V3 0 0 0) (V4 0 1 0 1) (V2 0 0)
         ]
 
-  triMesh <- uploadMesh triangle allocator
+  triMesh <- uploadMesh triangle allocator uploadContext queue device
-  maskMesh <- loadFromObj "./assets/cat_mask_cyberpunk.obj" allocator
+  maskMesh <- loadFromObj
+    "./assets/models/jaeger.obj"
+    allocator
+    uploadContext
+    queue
+    device
 
   meshLib <- asks meshLibrary
 
@@ -52,30 +64,75 @@ uploadMesh
   :: (MonadResource m, MonadFail m)
   => V.Vector Vertex
   -> VMA.Allocator
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
   -> m Mesh
-uploadMesh vertices allocator = do
+uploadMesh vertices allocator uploadContext queue device = do
-  let bufferCreateInfo = Vk.zero
+
-        { Vk.size  = fromIntegral $
+  let bufferSize = fromIntegral $ V.length vertices * sizeOf (undefined :: Vertex)
-          V.length vertices * sizeOf (Vertex (V3 0 0 0) (V3 0 0 0 ) (V4 0 0 0 0))
+      stagingBufferCrateInfo = Vk.zero
-        , Vk.usage = Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT
+        { Vk.size  = bufferSize
+        , Vk.usage = Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
         }
-      allocationCreateInfo = Vk.zero
+      stagingAllocationCreateInfo = Vk.zero
-        { VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
+        { VMA.usage = VMA.MEMORY_USAGE_CPU_ONLY
         } :: VMA.AllocationCreateInfo
-  mesh <- do
+
-      (buffer, bAllocation, bInfo) <- snd <$>
+  (stagingReleaseKey, stagingBuffer) <- do
-        VMA.withBuffer allocator bufferCreateInfo allocationCreateInfo allocate
+    (releaseKey, (buffer, bAllocation, bInfo)) <-
-      return (Mesh vertices (AllocatedBuffer buffer bAllocation bInfo))
+      VMA.withBuffer allocator stagingBufferCrateInfo stagingAllocationCreateInfo allocate
+    return (releaseKey, AllocatedBuffer
+      { bufferInfo = bInfo
+      , bufferAllocation = bAllocation
+      , allocatedBuffer = buffer
+      })
 
   (dataReleaseKey, dataPtr) <-
-    VMA.withMappedMemory allocator (bufferAllocation $ meshBuffer mesh) allocate
+    VMA.withMappedMemory allocator (bufferAllocation stagingBuffer) allocate
 
-  liftIO $ mapM_ (\(idx, vertex) ->
+  liftIO $ V.mapM_ (\(idx, vertex) ->
-    poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex
+    poke
+      (castPtr dataPtr `plusPtr` (idx * sizeOf vertex))
+      vertex
+    )
+    (V.zip
+      (V.fromList [0..])
+      vertices
       )
-    (zip [0..] (V.toList vertices))
 
-  release dataReleaseKey
+  liftIO $ release dataReleaseKey
+
+  let vertexBufferCreateInfo = Vk.zero
+        { Vk.size = bufferSize
+        , Vk.usage = Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT .|. Vk.BUFFER_USAGE_TRANSFER_DST_BIT
+        }
+      allocationCreateInfo = Vk.zero
+        { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
+        } :: VMA.AllocationCreateInfo
+
+  mesh <- do
+    (buffer, bAllocation, bInfo) <- snd <$>
+      VMA.withBuffer allocator vertexBufferCreateInfo allocationCreateInfo allocate
+    return $ Mesh
+      { meshVertices = vertices
+      , meshBuffer = AllocatedBuffer
+        { bufferInfo = bInfo
+        , bufferAllocation = bAllocation
+        , allocatedBuffer = buffer
+        }
+      }
+
+  immediateSubmit uploadContext queue device$ \cmd -> do
+    let copy = V.singleton $ Vk.BufferCopy
+          { size = bufferSize
+          , dstOffset = 0
+          , srcOffset = 0
+          }
+
+    Vk.cmdCopyBuffer cmd (allocatedBuffer stagingBuffer) (allocatedBuffer $ meshBuffer mesh) copy
+
+  release stagingReleaseKey
 
   return mesh
 
@@ -83,18 +140,22 @@ loadFromObj
   :: (MonadResource m, MonadFail m)
   => FilePath
   -> VMA.Allocator
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
   -> m Mesh
-loadFromObj filepath vma = do
+loadFromObj filepath vma uploadContext queue device = do
   eitherObj <- liftIO $ fromFile filepath
   case eitherObj of
     Left err ->
       error ("loadFromObj:  loading mesh data: " <> err)
     Right obj -> do
-      let vertices = digestFaces (objFaces obj) (objLocations obj)
+      let vertices = digestFaces (objFaces obj) (objLocations obj) (objTexCoords obj)
-      uploadMesh vertices vma
+      uploadMesh vertices vma uploadContext queue device
   where
-    digestFaces :: V.Vector (Element Face) -> V.Vector Location -> V.Vector Vertex
+    digestFaces
-    digestFaces faces locations =
+      :: V.Vector (Element Face) -> V.Vector Location -> V.Vector TexCoord -> V.Vector Vertex
+    digestFaces faces locations texCoords =
       V.foldl
         (\acc (Element _ _ _ _ (Face fa fb fc others)) ->
           if not (null others)
@@ -106,8 +167,9 @@ loadFromObj filepath vma = do
                     let position = faceIndexToPosition faceIndex locations
                         normal   = V3 0 0 0
                         color    = V4 1 1 0 1
+                        uv       = faceIndexToUV faceIndex texCoords
                     in
-                      Vertex position normal color
+                      Vertex position normal color uv
                     )
                   (V.fromList [ fa, fb, fc ])
             in
@@ -120,3 +182,45 @@ loadFromObj filepath vma = do
       let Location x y z _ = locations V.! (faceLocIndex index - 1)
       in
         V3 x y z
+    faceIndexToUV :: FaceIndex -> V.Vector TexCoord -> V2 Float
+    faceIndexToUV index texCoords =
+      let TexCoord r s _ =
+            texCoords V.!
+              (fromMaybe (error "no UV coordinates present") (faceTexCoordIndex index) - 1)
+      in
+        -- flip V coordinate of UVs to fix display
+        V2 r (-s)
+
+compactDraws
+  :: M.Map String Mesh
+  -> M.Map String Material
+  -> V.Vector RenderObject
+  -> V.Vector IndirectBatch
+compactDraws meshLib materialLib objects =
+
+  V.foldl
+    (\acc (index, RenderObject mesh material _) ->
+
+      let newDraw = IndirectBatch
+            { batchMesh     = meshLib M.! mesh
+            , batchMaterial = materialLib M.! material
+            , batchFirst    = index
+            , batchCount    = 1
+            }
+          sameMesh = not (V.null acc) && (meshLib M.! mesh == batchMesh (V.last acc))
+          sameMaterial = not (V.null acc) && (materialLib M.! material == batchMaterial (V.last acc))
+
+      in
+        if sameMesh && sameMaterial
+        then
+          V.init acc `V.snoc` ((V.last acc)
+            { batchCount = batchCount (V.last acc) + 1
+            })
+        else
+          acc `V.snoc` newDraw
+      )
+    V.empty
+    (V.zip
+      (V.fromList [0..])
+      objects
+      )

src/Sync.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+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 Types
+import Util
+
+initSyncStructures
+  :: (MonadResource m)
+  => Vk.Device
+  -> Word32
+  -> m UploadContext
+initSyncStructures logicalDevice queueFamilyIndex = do
+
+  let fenceCreateInfo = Vk.zero
+
+  syncFence <- snd <$>
+    Vk.withFence logicalDevice fenceCreateInfo Nothing allocate
+
+  let uploadCommandPoolCreateInfo = Vk.zero
+        { Vk.queueFamilyIndex = queueFamilyIndex
+        } :: Vk.CommandPoolCreateInfo
+
+  syncCommandPool <- snd <$>
+    Vk.withCommandPool logicalDevice uploadCommandPoolCreateInfo Nothing allocate
+
+  let cmdBufAllocInfo = Vk.zero
+        { Vk.commandPool        = syncCommandPool
+        , Vk.commandBufferCount = 1
+        }
+
+  syncCommandBuffer <- V.head . snd <$> Vk.withCommandBuffers logicalDevice cmdBufAllocInfo allocate
+
+  return $ UploadContext
+    { uploadFence = syncFence
+    , uploadCommandBuffer = syncCommandBuffer
+    , uploadCommandPool = syncCommandPool
+    }
+
+immediateSubmit
+  :: (MonadIO m)
+  => UploadContext
+  -> Vk.Queue
+  -> Vk.Device
+  -> (Vk.CommandBuffer -> m ())
+  -> m ()
+immediateSubmit uploadContext queue device func = do
+
+  let cmdBegin = beginCommandBuffer Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
+
+  Vk.useCommandBuffer
+    (uploadCommandBuffer uploadContext)
+    cmdBegin
+    (func (uploadCommandBuffer uploadContext))
+
+  let submitInfo = createSubmitInfo (uploadCommandBuffer uploadContext)
+
+  Vk.queueSubmit queue submitInfo (uploadFence uploadContext)
+
+  void $ Vk.waitForFences device (V.singleton $ uploadFence uploadContext) True maxBound
+  Vk.resetFences device (V.singleton $ uploadFence uploadContext)
+
+  Vk.resetCommandPool device (uploadCommandPool uploadContext) (bit 0)

src/Textures.hs

@@ -0,0 +1,173 @@
+{-# 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.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 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
+import qualified VulkanMemoryAllocator as VMA
+
+-- internal imports
+
+import Types
+import Memory
+import Sync
+import Image
+
+loadImageFromFile
+  :: (MonadResource m, MonadIO m)
+  => VMA.Allocator
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
+  -> FilePath
+  -> m AllocatedImage
+loadImageFromFile allocator uploadContext queue device 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
+    allocator
+    imageSize
+    Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
+    VMA.MEMORY_USAGE_CPU_ONLY
+
+  let dataPtr = VMA.mappedData (bufferInfo stagingBuffer)
+
+  liftIO $ pokeArray (castPtr dataPtr) (VS.toList $ P.imageData pixels)
+
+  let imageExtent = Vk.Extent3D
+        { width  = fromIntegral texWidth
+        , height = fromIntegral texHeight
+        , depth  = 1
+        }
+      dImgAllocCreateInfo = Vk.zero
+        { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
+        } :: VMA.AllocationCreateInfo
+      dImgCreateInfo = imageCreate
+        imageFormat
+        imageExtent
+        (Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT)
+
+  (newImage, newAllocation, _) <- snd <$>
+    VMA.withImage allocator dImgCreateInfo dImgAllocCreateInfo allocate
+
+  immediateSubmit
+    uploadContext
+    queue
+    device
+    (\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 = newAllocation
+    }
+
+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/jaeger.texture.tga"
+
+  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 "marksman" texture texMap
+
+    STM.swapTMVar textureLib newMap

src/Types.hs

@@ -40,9 +40,12 @@ data EngineData = EngineData
   , engineFrames                 :: V.Vector FrameData
   , engineGlobalSetLayout        :: Vk.DescriptorSetLayout
   , engineObjectSetLayout        :: Vk.DescriptorSetLayout
+  , engineSingleTextureSetLayout :: Vk.DescriptorSetLayout
   , engineDescriptorPool         :: Vk.DescriptorPool
   , engineSceneParameters        :: GPUSceneData
+  , engineUploadContext          :: UploadContext
   } 
+  deriving (Show)
 
 data AllocatedBuffer = AllocatedBuffer
   { allocatedBuffer  :: Vk.Buffer
@@ -51,28 +54,38 @@ data AllocatedBuffer = AllocatedBuffer
   }
   deriving (Show)
 
+instance Eq AllocatedBuffer where
+
+  (AllocatedBuffer buf1 _ _) == (AllocatedBuffer buf2 _ _) = buf1 == buf2
+
 data Vertex = Vertex
   { vertexPosition :: V3 Float
   , vertexNormal   :: V3 Float
   , vertexColor    :: V4 Float
+  , vertexUV       :: V2 Float
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 instance Storable Vertex where
 
-  sizeOf (Vertex position normal color) = sizeOf position + sizeOf normal + sizeOf color
+  sizeOf _ =
+    sizeOf (undefined :: V3 Float) * 2 +
+    sizeOf (undefined :: V4 Float) +
+    sizeOf (undefined :: V2 Float)
 
   peek ptr = do
     pos <- peek (castPtr ptr)
     nor <- peek (castPtr ptr `plusPtr` sizeOf pos)
     col <- peek (castPtr ptr `plusPtr` sizeOf pos `plusPtr` sizeOf nor)
-    return $ Vertex pos nor col
+    uv <- peek (castPtr ptr `plusPtr` sizeOf pos `plusPtr` sizeOf nor `plusPtr` sizeOf col)
+    return $ Vertex pos nor col uv
 
-  poke ptr (Vertex position normal color) = do
+  poke ptr (Vertex position normal color uv) = do
     let castedV3Ptr = castPtr ptr
     pokeElemOff castedV3Ptr 0 position
     pokeElemOff castedV3Ptr 1 normal
     poke (castPtr (ptr `plusPtr` sizeOf position `plusPtr` sizeOf normal)) color
+    poke (castPtr (ptr `plusPtr` sizeOf position `plusPtr` sizeOf normal `plusPtr` sizeOf color)) uv
 
   alignment _ = 0
 
@@ -106,6 +119,13 @@ instance VertexInputDescribable Vertex where
           , Vk.format   = Vk.FORMAT_R32G32B32A32_SFLOAT
           , Vk.offset   = fromIntegral (sizeOf (vertexPosition v) + sizeOf (vertexNormal v))
           } :: Vk.VertexInputAttributeDescription
+        uvAttribute = Vk.zero
+          { Vk.binding  = 0
+          , Vk.location = 3
+          , Vk.format   = Vk.FORMAT_R32G32_SFLOAT
+          , Vk.offset   = fromIntegral $
+            sizeOf (vertexPosition v) + sizeOf (vertexNormal v) + sizeOf (vertexColor v)
+          } :: Vk.VertexInputAttributeDescription
     in
       VertexInputDescription
         { vidBindings   = V.fromList [ mainBinding ]
@@ -113,6 +133,7 @@ instance VertexInputDescribable Vertex where
           [ positionAttribute
           , normalAttribute
           , colorAttribute
+          , uvAttribute
           ]
         }
 
@@ -126,7 +147,7 @@ data Mesh = Mesh
   { meshVertices :: V.Vector Vertex
   , meshBuffer   :: AllocatedBuffer
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 data MeshPushConstants = MeshPushConstants
   { meshPushData     :: V4 Float
@@ -159,10 +180,11 @@ data AllocatedImage = AllocatedImage
   deriving (Show)
 
 data Material = Material
-  { materialPipeline       :: Vk.Pipeline
+  { materialTextureSet     :: Vk.DescriptorSet
+  , materialPipeline       :: Vk.Pipeline
   , materialPipelineLayout :: Vk.PipelineLayout
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 data RenderObject = RenderObject
   { objectMesh     :: String
@@ -171,16 +193,23 @@ 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
   { runRenderInner :: RenderInner rd m a
   }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadReader rd, MonadResource, MonadFail)
+  deriving
+    (Functor, Applicative, Monad, MonadIO, MonadReader rd, MonadResource, MonadFail)
 
 type RenderInner rd m = ReaderT rd m
 
@@ -198,6 +227,7 @@ data FrameData = FrameData
   , frameCameraBuffer      :: AllocatedBuffer
   , frameSceneBuffer       :: AllocatedBuffer
   , frameObjectBuffer      :: AllocatedBuffer
+  , frameIndirectBuffer    :: AllocatedBuffer
   , frameGlobalDescriptor  :: Vk.DescriptorSet
   , frameObjectDescriptor  :: Vk.DescriptorSet
   }
@@ -220,7 +250,7 @@ instance Storable GPUObjectData where
     GPUObjectData <$> peek (castPtr ptr)
 
   poke ptr (GPUObjectData modelMatrix) =
-    poke (castPtr ptr) modelMatrix
+    poke (castPtr ptr) $ transpose modelMatrix
 
 data GPUCameraData = GPUCameraData
   { view           :: M44 Float
@@ -242,9 +272,10 @@ instance Storable GPUCameraData where
     return $ GPUCameraData v p vp
 
   poke ptr (GPUCameraData pview pprojection pviewProjection) = do
-    poke (castPtr ptr) pview
+    poke (castPtr ptr) $ transpose pview
-    poke (castPtr ptr `plusPtr` sizeOf pview) pprojection
+    poke (castPtr ptr `plusPtr` sizeOf pview) $ transpose pprojection
-    poke (castPtr ptr `plusPtr` sizeOf pview `plusPtr` sizeOf pprojection) pviewProjection
+    poke (castPtr ptr `plusPtr` sizeOf pview `plusPtr` sizeOf pprojection) $
+      transpose pviewProjection
 
 data GPUSceneData = GPUSceneData
   { fogColor     :: V4 Float
@@ -284,3 +315,17 @@ instance Storable GPUSceneData where
     poke (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDist)) ambCol
     poke (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDist + sizeOf ambCol)) sunDir
     poke (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDist + sizeOf ambCol + sizeOf sunDir)) sunCol
+
+data UploadContext = UploadContext
+  { uploadFence         :: Vk.Fence
+  , uploadCommandPool   :: Vk.CommandPool
+  , uploadCommandBuffer :: Vk.CommandBuffer
+  }
+  deriving (Show)
+
+data IndirectBatch = IndirectBatch
+  { batchMesh     :: Mesh
+  , batchMaterial :: Material
+  , batchFirst    :: Word32
+  , batchCount    :: Word32
+  }

src/Util.hs

@@ -64,3 +64,47 @@ writeDescriptorBuffer type' dstSet dBufferInfo binding = Vk.SomeStruct $
     , Vk.descriptorType  = type'
     , Vk.bufferInfo      = V.singleton dBufferInfo
     }
+
+beginCommandBuffer
+  :: Vk.CommandBufferUsageFlags
+  -> Vk.CommandBufferBeginInfo '[]
+beginCommandBuffer flags =
+  Vk.zero
+    { Vk.flags = flags
+    }
+
+createSubmitInfo
+  :: Vk.CommandBuffer
+  -> V.Vector (Vk.SomeStruct Vk.SubmitInfo)
+createSubmitInfo cmd = V.singleton $ Vk.SomeStruct $
+  Vk.zero
+    { Vk.commandBuffers = V.singleton (Vk.commandBufferHandle cmd)
+    }
+
+samplerCreateInfo
+  :: Vk.Filter
+  -> Vk.SamplerAddressMode
+  -> Vk.SamplerCreateInfo '[]
+samplerCreateInfo filters addressMode =
+  Vk.zero
+    { Vk.magFilter = filters
+    , Vk.minFilter = filters
+    , Vk.addressModeU = addressMode
+    , Vk.addressModeV = addressMode
+    , Vk.addressModeW = addressMode
+    }
+
+writeDescriptorImage
+  :: Vk.DescriptorType
+  -> Vk.DescriptorSet
+  -> Vk.DescriptorImageInfo
+  -> Word32
+  -> Vk.WriteDescriptorSet '[]
+writeDescriptorImage type' set imageInfo binding =
+  Vk.zero
+    { Vk.dstBinding = binding
+    , Vk.dstSet     = set
+    , Vk.descriptorCount = 1
+    , Vk.descriptorType  = type'
+    , Vk.imageInfo       = V.singleton imageInfo
+    }

test.nix

@@ -0,0 +1,46 @@
+{pkgs, vulkan-tutorial, ...}:
+pkgs.nixosTest ({
+  name = "test";
+  nodes = {
+    machine = { config, pkgs, ...}: {
+      environment = {
+        systemPackages = with pkgs; [
+          vulkan-tutorial
+          git
+          shaderc
+          vulkan-loader
+          vulkan-validation-layers
+        ];
+        sessionVariables = {
+          VK_LAYER_PATH="${pkgs.vulkan-validation-layers}/share/vulkan/explicit_layer.d";
+          SDL_VULKAN_LIBRARY="${pkgs.vulkan-loader}/lib/libvulkan.so";
+        };
+      };
+      hardware.opengl = {
+        enable = true;
+        driSupport = true;
+        driSupport32Bit = true;
+      };
+      services.xserver = {
+        enable = true;
+        displayManager.sddm.enable = true;
+        desktopManager.cinnamon.enable = true;
+      };
+      users.users.test = {
+        password = "test";
+        extraGroups = [
+          "wheel"
+        ];
+        isNormalUser = true;
+      };
+    };
+  };
+
+  skipLint = true;
+
+  testScript = ''
+    start_all()
+
+    machine.shell_interact()
+  '';
+})

vulkan-tutorial.cabal

@@ -34,12 +34,14 @@ executable vulkan-tutorial
                       Memory
                       Mesh
                       Image
+                      Sync
+                      Textures
                       Types
                       Util
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base >=4.14.3.0
+    build-depends:    base
                     , sdl2
                     , vulkan
                     , vulkan-utils
@@ -48,12 +50,14 @@ executable vulkan-tutorial
                     , linear
                     , monad-loops
                     , stm
+                    , time
                     , bytestring
                     , text
                     , vector
                     , resourcet
                     , mtl
                     , containers
+                    , JuicyPixels
     hs-source-dirs:   src
     default-language: Haskell2010
     ghc-options:      -Wall