add switchable shader

shadersrc/red.frag

@@ -0,0 +1,11 @@
+//glsl version 4.5
+#version 450
+
+//output write
+layout (location = 0) out vec4 outFragColor;
+
+void main()
+{
+	//return red
+	outFragColor = vec4(1.f,0.f,0.f,1.0f);
+}

shadersrc/red.vert

@@ -0,0 +1,15 @@
+//we will be using glsl version 4.5 syntax
+#version 450
+
+void main()
+{
+	//const array of positions for the triangle
+	const vec2 positions[3] = vec2[3](
+		vec2(0.5, 0.5),
+		vec2(-0.5, 0.5),
+		vec2(0.0, -0.5)
+	);
+
+	//output the position of each vertex
+	gl_Position = vec4(positions[gl_VertexIndex], 0.0, 1.0);
+}

src/Draw.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 module Draw where
 
+import qualified Control.Concurrent.STM as STM
 import Control.Monad
 import Control.Monad.Trans.Resource
 import qualified Data.Vector as V
@@ -14,22 +15,23 @@ import qualified Vulkan.Zero as Vk
 
 import CommandBuffer
 import Types
+import Control.Monad.IO.Class (MonadIO(liftIO))
 
 drawFrame
   :: (MonadResource m)
   => EngineData
+  -> STM.TMVar Bool
   -> m ()
-drawFrame engineData = do
+drawFrame engineData switch = do
 
   unless (all (V.length (engineCommandBuffers engineData) ==)
     [ V.length (engineCommandBuffers engineData)
     , V.length (engineFramebuffers engineData)
-    , V.length (enginePipelines engineData)
     ]) $
       error ("Numbers of elements mismatch: command buffers " <>
         show (V.length $ engineCommandBuffers engineData) <>
-        ", frame buffers " <> show (V.length $ engineFramebuffers engineData) <>
-        ", pipelines " <> show (V.length $ enginePipelines engineData))
+        ", frame buffers " <> show (V.length $ engineFramebuffers engineData)
+        )
 
   let fences = V.singleton $ engineInFlightFence engineData
 
@@ -51,13 +53,20 @@ drawFrame engineData = do
   Vk.resetCommandBuffer
     (engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
 
+  switchState <- liftIO $ STM.atomically $ STM.readTMVar switch
+
   -- liftIO $ putStrLn "recording command buffer"
   recordCommandBuffer
     (engineCommandBuffers engineData V.! fromIntegral index)
     (engineRenderPass engineData)
     (engineFramebuffers engineData V.! fromIntegral index)
     (engineWindowDimensions engineData)
-    (enginePipelines engineData V.! fromIntegral index)
+    (if switchState
+      then
+        redEnginePipelines engineData V.! fromIntegral index
+      else
+        rainbowEnginePipelines engineData V.! fromIntegral index
+      )
 
   let submitInfo = Vk.zero
         { Vk.waitSemaphores =

src/Init.hs

@@ -6,6 +6,7 @@ module Init where
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Resource
+import qualified Data.Vector as V
 import qualified SDL hiding (V2)
 import qualified SDL.Video.Vulkan as SDL
 import Foreign.Ptr
@@ -78,16 +79,27 @@ initVulkan window = do
   (swapchain, surfaceFormat) <-
     createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
   imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
-  vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert"
-  fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag"
+  redVertexShader <- loadShader vulkanLogicalDevice "shadersrc/red.vert" "vert"
+  redFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/red.frag" "frag"
+  rainbowVertexShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow.vert" "vert"
+  rainbowFragmentShader <- loadShader vulkanLogicalDevice "shadersrc/rainbow.frag" "frag"
   renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat)
   pipelineLayout <- createPipelineLayout vulkanLogicalDevice
-  let shaderContainer = ShaderContainer vertexShader fragmentShader
-  pipelines <-
+  let redContainer = ShaderContainer redVertexShader redFragmentShader
+  let rainbowContainer = ShaderContainer rainbowVertexShader rainbowFragmentShader
+  redPipelines <-
     createGraphicsPipelines
       vulkanLogicalDevice
       renderPass
-      shaderContainer
+      redContainer
+      dimensions
+      (length imageViews)
+      pipelineLayout
+  rainbowPipelines <-
+    createGraphicsPipelines
+      vulkanLogicalDevice
+      renderPass
+      rainbowContainer
       dimensions
       (length imageViews)
       pipelineLayout
@@ -108,7 +120,8 @@ initVulkan window = do
     graphicsQueue
     commandBuffer
     frameBuffers
-    pipelines
+    redPipelines
+    rainbowPipelines
     renderPass
     inFlightFence
     imageAvailableSemaphore

src/Main.hs

@@ -28,6 +28,7 @@ main = runResourceT $ do
 
   -- create abort condition for upcoming lop
   quit <- liftIO $ STM.newTMVarIO True
+  secondPipeline <- liftIO $ STM.newTMVarIO False
 
   -- main loop
   whileM_
@@ -35,7 +36,7 @@ main = runResourceT $ do
       )
     ( do
       -- draw
-      drawFrame engineData
+      drawFrame engineData secondPipeline
       -- poll events
       evs <- liftIO SDL.pollEvents
       -- flip abort condition on window close
@@ -43,6 +44,13 @@ main = runResourceT $ do
         (\e -> case SDL.eventPayload e of
           SDL.WindowClosedEvent _ ->
             void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
+          SDL.KeyboardEvent dat ->
+            case dat of
+              SDL.KeyboardEventData _ SDL.Released _ (SDL.Keysym _ SDL.KeycodeSpace _) ->
+                liftIO $ STM.atomically $ do
+                  state <- STM.readTMVar secondPipeline
+                  void $ STM.swapTMVar secondPipeline (not state)
+              _ -> return ()
           _ -> return ()
           )
         evs

src/Types.hs

@@ -20,7 +20,8 @@ data EngineData = EngineData
   , engineQueue                   :: Vk.Queue
   , engineCommandBuffers          :: V.Vector Vk.CommandBuffer
   , engineFramebuffers            :: V.Vector Vk.Framebuffer
-  , enginePipelines               :: V.Vector Vk.Pipeline
+  , redEnginePipelines            :: V.Vector Vk.Pipeline
+  , rainbowEnginePipelines        :: V.Vector Vk.Pipeline
   , engineRenderPass              :: Vk.RenderPass
   , engineInFlightFence           :: Vk.Fence
   , engineImageAvailableSemaphore :: Vk.Semaphore