Compare commits

..

No commits in common. "main" and "resourcetify" have entirely different histories.

42 changed files with 105 additions and 35450 deletions

1
.envrc
View file

@ -1 +0,0 @@
use flake

1
.gitattributes vendored
View file

@ -1 +0,0 @@
assets/ filter=lfs diff=lfs merge=lfs -text

1
.gitignore vendored
View file

@ -1,3 +1,4 @@
.direnv/
.envrc
dist-newstyle/
extern/

View file

@ -5,5 +5,3 @@ as clean as possible to help future me or others understand it.
Useful learning material:
* [Vulkan Lecture Series](https://www.youtube.com/playlist?list=PLmIqTlJ6KsE1Jx5HV4sd2jOe3V1KMHHgn)
* [Vulkan Tutorial](https://vulkan-tutorial.com)
* [Vulkan Guide](https://vkguide.dev)

File diff suppressed because it is too large Load diff

View file

@ -1,13 +0,0 @@
# 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

File diff suppressed because it is too large Load diff

File diff suppressed because it is too large Load diff

Binary file not shown.

Before

Width:  |  Height:  |  Size: 167 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 32 MiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 4 MiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 4 MiB

View file

@ -1,12 +0,0 @@
{
"dictionaries": ["custom-words"],
"dictionaryDefinitions": [
{
"name": "custom-words",
"path": "./project-words.txt",
"addWords": true
}
]
}

View file

@ -1,60 +0,0 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1694529238,
"narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1699181587,
"narHash": "sha256-v35mUUgVU2ituIHPNHifpjl5uiYQYyLrpaMtz8X8Ums=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "197629b470f184a47b2a5716312d25b09454bbf8",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

View file

@ -1,55 +0,0 @@
{
description = "A game stub written in Haskell";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs";
flake-utils.url = "github:numtide/flake-utils";
};
outputs = { self, nixpkgs, flake-utils }:
flake-utils.lib.eachDefaultSystem (system:
let
pkgs = nixpkgs.legacyPackages.${system};
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 (pkgs.haskell.lib.markUnbroken pkg);
packageName = "vulkan-tutorial";
in rec {
packages.default = haskellPackages.vulkan-tutorial;
devShells.default = haskellPackages.shellFor {
packages = p: [ p.vulkan-tutorial ];
withHoogle = true;
buildInputs = (with haskellPackages; [
haskell-language-server
ghcid
cabal-install
(jailbreakUnbreak wavefront)
]) ++ (with pkgs; [
shaderc
vulkan-loader
vulkan-validation-layers
renderdoc
]);
VK_LAYER_PATH="${pkgs.vulkan-validation-layers}/share/vulkan/explicit_layer.d";
SDL_VULKAN_LIBRARY="${pkgs.vulkan-loader}/lib/libvulkan.so";
};
});
}

View file

@ -1,39 +0,0 @@
cmds
concat
fmap
foldl
framebuffer
Framebuffer
Framebuffers
GLSL
Imageview
Keysym
KHRONOS
Memdiscrete
multisample
Multisample
ndev
rasterization
Rasterization
rasterizer
SFLOAT
Shaderc
shadersrc
SRGB
Struct
subpass
Subpass
SUBPASS
subpasses
subresource
Subresource
succ
swapchain
Swapchain
SWAPCHAIN
swapchains
TEXEL
unmap
viewports
vulkan
Vulkan

View file

@ -1,26 +0,0 @@
#version 450
layout (location = 0) in vec3 vPosition;
layout (location = 1) in vec3 vNormal;
layout (location = 2) in vec4 vColor;
layout (location = 0) out vec4 outColor;
layout(set = 0, binding = 0) uniform CameraBuffer{
mat4 view;
mat4 proj;
mat4 viewproj;
} cameraData;
//push constants block
layout( push_constant ) uniform constants
{
vec4 data;
mat4 render_matrix;
} PushConstants;
void main()
{
mat4 transformMatrix = (cameraData.viewproj * PushConstants.render_matrix);
gl_Position = transformMatrix * vec4(vPosition, 1.0f);
outColor = vColor;
}

View file

@ -1,9 +0,0 @@
#version 450
layout(location = 0) in vec4 fragColor;
layout(location = 0) out vec4 outColor;
void main() {
outColor = fragColor;
}

View file

@ -1,20 +0,0 @@
#version 450
layout(location = 0) out vec4 fragColor;
vec2 positions[3] = vec2[](
vec2(0.0, -0.5),
vec2(0.5, 0.5),
vec2(-0.5, 0.5)
);
vec4 colors[3] = vec4[](
vec4(1.0, 0.0, 0.0, 1.0),
vec4(0.0, 1.0, 0.0, 1.0),
vec4(0.0, 0.0, 1.0, 1.0)
);
void main() {
gl_Position = vec4(positions[gl_VertexIndex], 0.0, 1.0);
fragColor = colors[gl_VertexIndex];
}

View file

@ -1,21 +0,0 @@
#version 450
// shader input
layout(location = 0) in vec4 fragColor;
// output write
layout(location = 0) out vec4 outColor;
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;
void main() {
outColor = vec4(fragColor.xyz + sceneData.ambientColor.xyz, 1.0f);
//outColor = fragColor;
//outColor = sceneData.ambientColor;
}

View file

@ -1,11 +0,0 @@
//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);
}

View file

@ -1,15 +0,0 @@
//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);
}

View file

@ -1,24 +0,0 @@
//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);
}

View file

@ -1,40 +0,0 @@
#version 460
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;
mat4 proj;
mat4 viewproj;
} cameraData;
struct ObjectData{
mat4 model;
};
//all object matrices
layout(std140,set = 1, binding = 0) readonly buffer ObjectBuffer{
ObjectData objects[];
} objectBuffer;
//push constants block
layout( push_constant ) uniform constants
{
vec4 data;
mat4 render_matrix;
} PushConstants;
void main()
{
mat4 modelMatrix = objectBuffer.objects[gl_BaseInstance].model;
mat4 transformMatrix = (cameraData.viewproj * modelMatrix);
gl_Position = transformMatrix * vec4(vPosition, 1.0f);
outColor = vColor;
texCoord = vTexCoord;
}

View file

@ -3,16 +3,5 @@
let
vulkanTutorial = pkgs.haskellPackages.callCabal2nix "vulkan-tutorial" (gitignore ./.) {};
gitignore = src: pkgs.nix-gitignore.gitignoreSource [] src;
hpkgs = pkgs.haskellPackages.override {
overrides = final: prev: {
vulkanTutorial = vulkanTutorial;
};
};
in
hpkgs.shellFor {
packages = p: [
p.vulkanTutorial
];
buildInputs =
vulkanTutorial.buildInputs ++ [ pkgs.shaderc ];
}
vulkanTutorial.env

View file

@ -1,393 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module CommandBuffer where
import qualified Control.Concurrent.STM as STM
import Control.Monad
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 Foreign hiding (void)
import Foreign.C.Types (CInt)
import Linear
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified VulkanMemoryAllocator as VMA
-- internal imports
import Types
import Memory
import Util
import Mesh (compactDraws)
frameOverlap :: Int
frameOverlap = 2
maxObjects :: Int
maxObjects = 10000
createFrames
:: (MonadResource m, MonadFail m)
=> Vk.Device
-> VMA.Allocator
-> Vk.DescriptorPool
-> Vk.DescriptorSetLayout
-> Vk.DescriptorSetLayout
-> Word32
-> m (V.Vector FrameData, Vk.Queue)
createFrames
logicalDevice
allocator
descriptorPool
setLayout
objectSetLayout
queueFamilyIndex
= do
let poolCreateInfo = Vk.zero
{ Vk.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT
, Vk.queueFamilyIndex = queueFamilyIndex
} :: Vk.CommandPoolCreateInfo
graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0
frames <- V.mapM
(\_ -> do
commandPool <- snd <$>
Vk.withCommandPool logicalDevice poolCreateInfo Nothing allocate
let commandBufferAllocationInfo = Vk.zero
{ Vk.commandPool = commandPool
, Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY
, Vk.commandBufferCount = 1
}
(_, commandBuffer) <- Vk.withCommandBuffers logicalDevice commandBufferAllocationInfo allocate
let semaphoreCreateInfo = Vk.zero
fenceCreateInfo = Vk.zero
{ Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT
} :: Vk.FenceCreateInfo '[]
[presentSemaphore, renderSemaphore] <- replicateM 2
(snd <$>
Vk.withSemaphore logicalDevice semaphoreCreateInfo Nothing allocate
)
renderFence <- snd <$>
Vk.withFence logicalDevice fenceCreateInfo Nothing allocate
cameraBuffer <- createAllocatedBuffer
allocator
(sizeOf (GPUCameraData identity identity identity))
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT
VMA.MEMORY_USAGE_CPU_TO_GPU
sceneBuffer <- createAllocatedBuffer
allocator
(sizeOf undefinedGPUSceneData * frameOverlap)
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT
VMA.MEMORY_USAGE_CPU_TO_GPU
objectBuffer <- createAllocatedBuffer
allocator
(sizeOf undefinedGPUObjectData * maxObjects)
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
}
objectSetAllocInfo = Vk.zero
{ Vk.descriptorPool = descriptorPool
, Vk.setLayouts = V.singleton objectSetLayout
}
globalDescriptor <- Vk.allocateDescriptorSets logicalDevice allocationInfo
objectDescriptor <- Vk.allocateDescriptorSets logicalDevice objectSetAllocInfo
let cameraInfo = Vk.zero
{ Vk.buffer = allocatedBuffer cameraBuffer
, Vk.offset = 0
, Vk.range = fromIntegral $ sizeOf (undefined :: GPUCameraData)
} :: Vk.DescriptorBufferInfo
sceneInfo = Vk.zero
{ Vk.buffer = allocatedBuffer sceneBuffer
, Vk.offset = 0
-- , Vk.offset = padUniformBufferSize (fromIntegral $ sizeOf undefinedGPUSceneData) deviceProperties * fromIntegral index
, Vk.range = fromIntegral $ sizeOf undefinedGPUSceneData
} :: Vk.DescriptorBufferInfo
objectInfo = Vk.zero
{ Vk.buffer = allocatedBuffer objectBuffer
, Vk.offset = 0
, Vk.range = fromIntegral $ sizeOf undefinedGPUObjectData * maxObjects
} :: Vk.DescriptorBufferInfo
cameraWrite = writeDescriptorBuffer
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
(V.head globalDescriptor)
cameraInfo
0
sceneWrite = writeDescriptorBuffer
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
(V.head globalDescriptor)
sceneInfo
1
objectWrite = writeDescriptorBuffer
Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER
(V.head objectDescriptor)
objectInfo
0
setWrites = V.fromList
[ cameraWrite
, sceneWrite
, objectWrite
]
Vk.updateDescriptorSets logicalDevice setWrites V.empty
return FrameData
{ framePresentSemaphore = presentSemaphore
, frameRenderSemaphore = renderSemaphore
, frameRenderFence = renderFence
, frameCommandPool = commandPool
, frameMainCommandBuffer = V.head commandBuffer
, frameCameraBuffer = cameraBuffer
, frameSceneBuffer = sceneBuffer
, frameObjectBuffer = objectBuffer
, frameIndirectBuffer = indirectBuffer
, frameGlobalDescriptor = V.head globalDescriptor
, frameObjectDescriptor = V.head objectDescriptor
}
)
(V.fromList [1 .. frameOverlap])
return (frames, graphicsQueue)
recordCommandBuffer
:: (MonadResource m, MonadReader ReadState m, MonadIO m)
=> VMA.Allocator
-> Vk.CommandBuffer
-> Vk.RenderPass
-> Vk.Framebuffer
-> V2 CInt
-> Vk.Pipeline
-> FrameData
-> m ()
recordCommandBuffer
allocator
commandBuffer
renderPass
frameBuffer
dimensions@(V2 width height)
graphicsPipeline
frame
= do
let commandBufferBeginInfo = Vk.zero
{ Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
, Vk.inheritanceInfo = Nothing
}
Vk.useCommandBuffer commandBuffer commandBufferBeginInfo $ do
let renderPassInfo = Vk.zero
{ Vk.renderPass = renderPass
, Vk.framebuffer = frameBuffer
, Vk.renderArea = Vk.Rect2D
{ offset = Vk.Offset2D
{ Vk.x = 0
, Vk.y = 0
}
, extent = Vk.Extent2D
{ Vk.width = fromIntegral width
, Vk.height = fromIntegral height
}
}
, Vk.clearValues = V.fromList
[ Vk.Color (Vk.Float32 0 0 0 1)
, Vk.DepthStencil (Vk.ClearDepthStencilValue 1 0)
]
}
Vk.cmdUseRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE $ do
liftIO $
prepareRecording dimensions commandBuffer graphicsPipeline
renderObjects <- (liftIO . STM.atomically . STM.readTMVar) =<< asks renderables
meshMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary
materialMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks materialLibrary
let draws = compactDraws meshMap materialMap renderObjects
drawCommands = V.map
(\(i, RenderObject mesh _ _) ->
Vk.DrawIndirectCommand
{ vertexCount = fromIntegral (V.length $ meshVertices $ meshMap M.! mesh)
, firstVertex = 0
, instanceCount = 1
, firstInstance = i
}
)
(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)
Vk.cmdBindDescriptorSets
commandBuffer
Vk.PIPELINE_BIND_POINT_GRAPHICS
(materialPipelineLayout material)
0
(V.singleton $ frameGlobalDescriptor frame)
V.empty
Vk.cmdBindDescriptorSets
commandBuffer
Vk.PIPELINE_BIND_POINT_GRAPHICS
(materialPipelineLayout material)
1
(V.singleton $ frameObjectDescriptor frame)
V.empty
Vk.cmdBindVertexBuffers
commandBuffer
0
(V.fromList [ allocatedBuffer $ meshBuffer mesh ])
(V.fromList [ 0 ])
let indirectOffset = fromIntegral $
first * fromIntegral ( sizeOf (undefined :: Vk.DrawIndirectCommand))
drawStride = fromIntegral $ sizeOf (undefined :: Vk.DrawIndirectCommand)
Vk.cmdDrawIndirect
commandBuffer
(allocatedBuffer $ frameIndirectBuffer frame)
indirectOffset
count
drawStride
)
draws
prepareRecording
:: V2 CInt
-> Vk.CommandBuffer
-> Vk.Pipeline
-> IO ()
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 = fromIntegral height
, Vk.width = fromIntegral width
, Vk.height = - fromIntegral height
, Vk.minDepth = 0
, Vk.maxDepth = 1
}
scissor = Vk.Rect2D
{ Vk.offset = Vk.Offset2D
{ Vk.x = 0
, Vk.y = 0
}
, Vk.extent = Vk.Extent2D
{ Vk.width = fromIntegral width
, Vk.height = fromIntegral height
}
}
Vk.cmdSetViewport commandBuffer 0 (V.singleton viewport)
Vk.cmdSetScissor commandBuffer 0 (V.singleton scissor)
pokeData
:: (MonadResource m, MonadReader ReadState m, MonadIO m)
=> FrameData
-> Int
-> GPUSceneData
-> GPUCameraData
-> m ()
pokeData frame frameNumber sceneParameters cameraParameters = do
renderObjects <- (liftIO . STM.atomically . STM.readTMVar) =<< asks renderables
let scenePointer = VMA.mappedData (bufferInfo $ frameSceneBuffer frame)
memoryPointer = VMA.mappedData (bufferInfo $ frameCameraBuffer frame)
objectPointer = VMA.mappedData (bufferInfo $ frameObjectBuffer frame)
framed = fromIntegral frameNumber / 120
ambient = normalize $ V4 (sin framed) 0 (cos framed) 1
-- ambient = V4 1 0 1 1
ambientParams = sceneParameters
{ ambientColor = ambient
}
V.mapM_
(\(index, obj) -> do
let modelMatrix = GPUObjectData (objectMatrix obj)
liftIO $ poke
(castPtr objectPointer `plusPtr` (index * sizeOf (undefined :: GPUObjectData)))
modelMatrix
)
(V.zip
(V.fromList [0 ..])
renderObjects
)
liftIO $ do
poke
(castPtr scenePointer)
ambientParams
poke
(castPtr memoryPointer)
cameraParameters

View file

@ -1,27 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Devices where
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Data.Maybe (fromMaybe, isNothing)
import Data.Bits
import Foreign
import Foreign.C.Types (CInt)
import Linear
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified VulkanMemoryAllocator as VMA
-- internal imports
import Image
import Types
pickPhysicalDevice
:: (MonadResource m)
@ -40,7 +30,7 @@ pickPhysicalDevice vkInstance = do
let discretePhysDevices = V.filter
(\(_, _, devFeatures) ->
-- Vk.deviceType devProps == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
-- Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
Vk.geometryShader devFeatures
)
devicesWithPropsAndFeatures
@ -56,75 +46,40 @@ pickPhysicalDevice vkInstance = do
discretePhysDevices
liftIO $ do
putStrLn "picked the following device:"
print ("picked the following device:" :: String)
print (Vk.deviceName props)
return maxMemdiscretePhysDevice
getQueueFamily
:: (MonadResource m)
=> Vk.PhysicalDevice
-> Vk.QueueFlagBits
-> m Word32
getQueueFamily physicalDevice distinctBit = do
queueFamilyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties physicalDevice
liftIO $ do
putStrLn "There are currently following queue families available"
print queueFamilyProperties
let queueFamily = V.foldl
(\acc (index, qFamily) ->
if Vk.queueFlags qFamily .&. distinctBit /= zeroBits && isNothing acc
then Just index
else acc
)
Nothing
(V.zip (V.fromList [0..]) queueFamilyProperties)
return $ fromMaybe
(error "getQueueFamilies: The requested queueFamily doesn't seem to exist")
queueFamily
createLogicalDevice
:: (MonadResource m)
=> Vk.PhysicalDevice
-> Vk.SurfaceKHR
-> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR, Word32)
-> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
createLogicalDevice physDevice surface = do
graphicsQueueFamily <- getQueueFamily physDevice Vk.QUEUE_GRAPHICS_BIT
let priorities = V.singleton 1
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
queueCreateInfo = Vk.zero
{ Vk.queueFamilyIndex = graphicsQueueFamily
{ Vk.queueFamilyIndex = 0
, Vk.queuePriorities = priorities
}
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
} :: Vk.PhysicalDeviceShaderDrawParametersFeatures
(_, logDevice) <-
Vk.withDevice
physDevice
(deviceCreateInfo Vk.::& shaderDrawParametersFeatures Vk.:& ())
Nothing
allocate
(_, logDevice) <- allocate
(Vk.createDevice physDevice deviceCreateInfo Nothing)
(\logDevice -> do
print ("destroying logical device" :: String)
Vk.destroyDevice logDevice Nothing
)
(result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface
unless (result == Vk.SUCCESS) $
error "createLogicalDevice: Failed retrieving surface image formats"
error "Failed retrieving surface image formats"
return (logDevice, formats, graphicsQueueFamily)
return (logDevice, formats)
createSwapchain
:: (MonadResource m)
@ -132,21 +87,20 @@ createSwapchain
-> V.Vector Vk.SurfaceFormatKHR
-> V2 CInt
-> Vk.Device
-> VMA.Allocator
-> m (Vk.SwapchainKHR, Vk.SurfaceFormatKHR, Vk.ImageView, AllocatedImage)
createSwapchain surface surfaceFormats windowDimension logicalDevice allocator = do
-> m (Vk.SwapchainKHR, Vk.SurfaceFormatKHR)
createSwapchain surface surfaceFormats windowDimension logicalDevice = do
liftIO $ do
putStrLn "available formats:"
print ("available formats:" :: String)
print surfaceFormats
(surfaceFormat, colorSpace) <-
if
V.any
(\a ->
a.format ==
(Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) a ==
Vk.FORMAT_B8G8R8A8_SRGB
&& a.colorSpace ==
&& (Vk.colorSpace :: Vk.SurfaceFormatKHR -> Vk.ColorSpaceKHR) a ==
Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR)
surfaceFormats
then
@ -155,7 +109,7 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator =
error ("createSwapchain: No suitable surface formats available" :: String)
liftIO $ do
putStrLn "picking following format and color space:"
print ("picking following format and color space:" :: String)
print (surfaceFormat, colorSpace)
let createInfo = Vk.zero
@ -167,42 +121,20 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator =
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
, Vk.imageArrayLayers = 1
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
, Vk.presentMode = Vk.PRESENT_MODE_FIFO_KHR
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
, Vk.clipped = True
}
swapchain <- snd <$>
Vk.withSwapchainKHR logicalDevice createInfo Nothing allocate
swapchain <- snd <$> allocate
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
(\swapchain -> do
print ("destroying swapchain" :: String)
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
)
let depthImageExtent =
(\(V2 w h) -> Vk.Extent3D (fromIntegral w) (fromIntegral h) 1)
windowDimension
let depthImageInfo = imageCreate
Vk.FORMAT_D32_SFLOAT
depthImageExtent
Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT
let depthImageAllocationInfo = Vk.zero
{ VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
, VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
(depthImage, depthAllocation, _) <- snd <$>
VMA.withImage allocator depthImageInfo depthImageAllocationInfo allocate
let allocatedImage = AllocatedImage depthImage depthAllocation
depthImageView = imageviewCreate
(image allocatedImage)
Vk.FORMAT_D32_SFLOAT
Vk.IMAGE_ASPECT_DEPTH_BIT
depthImageview <- snd <$>
Vk.withImageView logicalDevice depthImageView Nothing allocate
return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace, depthImageview, allocatedImage)
return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace)
getImageViewHandles
:: (MonadResource m)
@ -215,15 +147,12 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do
when (result /= Vk.SUCCESS) $
error "getImageHandles: Failed acquiring images from swapchain"
liftIO $
putStrLn ("number of images: " <> show (V.length handles))
V.mapM
(\tmpImage -> do
(\image -> do
let createInfo = Vk.zero
{ Vk.image = tmpImage
{ Vk.image = image
, Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
, Vk.format = surfaceFormat.format
, Vk.format = (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) surfaceFormat
, Vk.components = Vk.ComponentMapping
{ Vk.r = Vk.COMPONENT_SWIZZLE_IDENTITY
, Vk.g = Vk.COMPONENT_SWIZZLE_IDENTITY
@ -238,7 +167,11 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do
, layerCount = 1
}
}
snd <$>
Vk.withImageView logicalDevice createInfo Nothing allocate
snd <$> allocate
(Vk.createImageView logicalDevice createInfo Nothing)
(\imageView -> do
print ("destrying image view" :: String)
Vk.destroyImageView logicalDevice imageView Nothing
)
)
handles

View file

@ -1,117 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Draw where
import qualified Control.Concurrent.STM as STM
import Control.Monad
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 Linear
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import CommandBuffer
import Types
import Util (getFrame)
drawFrame
:: (MonadResource m, MonadFail m, MonadReader ReadState m)
=> EngineData
-> Int
-> m ()
drawFrame engineData frameNumber = do
let frame = getFrame engineData frameNumber
void $ Vk.waitForFences
(engineLogicalDevice engineData)
(V.singleton $ frameRenderFence frame)
True
maxBound
Vk.resetFences (engineLogicalDevice engineData) (V.singleton $ frameRenderFence frame)
(imageResult, index) <-
Khr.acquireNextImageKHR
(engineLogicalDevice engineData)
(engineSwapchain engineData)
maxBound
(frameRenderSemaphore frame)
Vk.NULL_HANDLE
unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain"
Vk.resetCommandBuffer
(frameMainCommandBuffer frame) (Vk.CommandBufferResetFlagBits 0)
matLibrary <- (liftIO . STM.atomically. STM.readTMVar) =<< asks materialLibrary
let (V2 width height) = engineWindowDimensions engineData
camPosition = V3
(-10 * sin (fromIntegral frameNumber / 90))
2
(-10 * cos (fromIntegral frameNumber / 90))
camCenter = V3 0 0 0
camUp = V3 0 1 0
camView = lookAt camPosition camCenter camUp
camProjection = perspective
(pi/4)
(fromIntegral width / fromIntegral height)
0.1
200
cameraData = GPUCameraData
{ view = camView
, projection = camProjection
, viewProjection = camProjection !*! camView
}
pokeData
frame
frameNumber
(engineSceneParameters engineData)
cameraData
recordCommandBuffer
(engineData.engineAllocator)
(frameMainCommandBuffer frame)
(engineRenderPass engineData)
(engineFramebuffers engineData V.! fromIntegral index)
(engineWindowDimensions engineData)
(materialPipeline $ matLibrary M.! "defaultMesh")
frame
let submitInfo = Vk.zero
{ Vk.waitSemaphores =
V.singleton $ frameRenderSemaphore frame
, Vk.waitDstStageMask =
V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.commandBuffers =
V.singleton (Vk.commandBufferHandle $ frameMainCommandBuffer frame)
, Vk.signalSemaphores =
V.singleton $ framePresentSemaphore frame
}
Vk.queueSubmit
(engineQueue engineData)
(V.singleton (Vk.SomeStruct submitInfo))
(frameRenderFence frame)
let presentInfo = Vk.zero
{ Khr.waitSemaphores = V.singleton $ framePresentSemaphore frame
, Khr.swapchains = V.singleton $ engineSwapchain engineData
, Khr.imageIndices = V.singleton index
}
presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo
unless (presentResult == Vk.SUCCESS) $
error "drawFrame: presentation failed"

View file

@ -1,44 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Framebuffers where
import Linear
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
createFramebuffer
:: (MonadResource m)
=> Vk.Device
-> Vk.RenderPass
-> V.Vector Vk.ImageView
-> Vk.ImageView
-> V2 CInt
-> m (V.Vector Vk.Framebuffer)
createFramebuffer
logicalDevice
renderPass
swapchainImageViews
depthImageView
(V2 swapchainWidth swapchainHeight)
= do
let framebufferCreateInfo = Vk.zero
{ Vk.renderPass = renderPass
, Vk.width = fromIntegral swapchainWidth
, Vk.height = fromIntegral swapchainHeight
, Vk.layers = 1
}
V.mapM
(\imageView -> do
let createInfo = framebufferCreateInfo
{ Vk.attachments = V.fromList [ imageView, depthImageView ]
} :: Vk.FramebufferCreateInfo '[]
snd <$> Vk.withFramebuffer logicalDevice createInfo Nothing allocate
)
swapchainImageViews

View file

@ -1,332 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module GraphicsPipeline where
import Linear
import qualified Control.Concurrent.STM as STM
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bits
-- import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
import Foreign (sizeOf)
import Foreign.C.Types (CInt)
import qualified Vulkan as VK
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
-- internal imports
import Types
loadShader
:: (MonadResource m)
=> Vk.Device
-> FilePath
-> String
-> m Vk.ShaderModule
loadShader logicalDevice shaderPath stage = do
shaderSource <- liftIO $ BS.readFile shaderPath
(warnings, eShader) <- Vk.compileShader Nothing Nothing stage (BS.unpack shaderSource)
unless (null warnings) $ liftIO $ do
putStrLn "loadShader: Shader compilation warnings:"
print warnings
shader <- either
(\errors -> do
error ("loadShader: Compilation errors:" <> "\n" <> show errors)
)
return
eShader
let createInfo = Vk.zero
{ Vk.code = shader
}
snd <$>
Vk.withShaderModule logicalDevice createInfo Nothing allocate
createRenderPass
:: (MonadResource m)
=> Vk.Device
-> Vk.Format
-> Vk.Format
-> m Vk.RenderPass
createRenderPass
logicalDevice
swapchainImageFormat
depthFormat
= do
let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription)
{ Vk.format = swapchainImageFormat
, Vk.samples = Vk.SAMPLE_COUNT_1_BIT
, Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
, Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE
, Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE
, Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
, Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED
, Vk.finalLayout = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR
}
colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference)
{ Vk.attachment = 0
, Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
}
depthAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription)
{ Vk.flags = bit 0
, Vk.format = depthFormat
, Vk.samples = Vk.SAMPLE_COUNT_1_BIT
, Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
, Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE
, Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR
, Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE
, Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED
, Vk.finalLayout = Vk.IMAGE_LAYOUT_DEPTH_READ_ONLY_STENCIL_ATTACHMENT_OPTIMAL
}
depthAttachmentReference = (Vk.zero :: Vk.AttachmentReference)
{ Vk.attachment = 1
, Vk.layout = Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL
}
subpassDescriptor = (Vk.zero :: Vk.SubpassDescription)
{ Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS
, Vk.colorAttachments = V.singleton colorAttachmentReference
, Vk.depthStencilAttachment = Just depthAttachmentReference
}
subpassDependency = Vk.zero
{ Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
, Vk.dstSubpass = 0
, Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.srcAccessMask = Vk.ACCESS_MEMORY_READ_BIT
, Vk.dstAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
}
subpassDepthDependency = Vk.zero
{ Vk.srcSubpass = Vk.SUBPASS_EXTERNAL
, Vk.dstSubpass = 0
, Vk.srcStageMask =
Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT
, Vk.srcAccessMask = Vk.ACCESS_MEMORY_READ_BIT
, Vk.dstStageMask =
Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT
, Vk.dstAccessMask = Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT
}
renderPassCreateInfo = Vk.zero
{ Vk.attachments = V.fromList [ colorAttachmentDescription, depthAttachmentDescription ]
, Vk.subpasses = V.singleton subpassDescriptor
, Vk.dependencies = V.fromList [ subpassDependency, subpassDepthDependency ]
} :: Vk.RenderPassCreateInfo '[]
snd <$>
Vk.withRenderPass logicalDevice renderPassCreateInfo Nothing allocate
createShaderStageCreateInfo
:: Vk.ShaderStageFlagBits
-> Vk.ShaderModule
-> Vk.PipelineShaderStageCreateInfo '[]
createShaderStageCreateInfo stageBit shaderModule =
Vk.zero
{ Vk.stage = stageBit
, Vk.module' = shaderModule
, Vk.name = "main"
}
createVertexInputAssemblyStateCreateInfo
:: Vk.PrimitiveTopology
-> Vk.PipelineInputAssemblyStateCreateInfo
createVertexInputAssemblyStateCreateInfo topology =
Vk.zero
{ Vk.topology = topology
, Vk.primitiveRestartEnable = False
}
createRasterizationStateCreateInfo
:: Vk.PolygonMode
-> Vk.SomeStruct Vk.PipelineRasterizationStateCreateInfo
createRasterizationStateCreateInfo mode =
Vk.SomeStruct $ Vk.zero
{ Vk.depthClampEnable = False
, Vk.rasterizerDiscardEnable = False
, Vk.polygonMode = mode
, Vk.lineWidth = 1
, Vk.cullMode = Vk.CULL_MODE_NONE
, Vk.frontFace = Vk.FRONT_FACE_CLOCKWISE
, Vk.depthBiasEnable = False
, Vk.depthBiasConstantFactor = 0
, Vk.depthBiasClamp = 0
, Vk.depthBiasSlopeFactor = 0
}
createDepthStencilStateCreateInfo
:: Bool
-> Bool
-> Vk.CompareOp
-> Vk.PipelineDepthStencilStateCreateInfo
createDepthStencilStateCreateInfo depthTest depthWrite compareOperation =
Vk.zero
{ Vk.depthTestEnable = depthTest
, Vk.depthWriteEnable = depthWrite
, Vk.depthCompareOp = compareOperation
, Vk.depthBoundsTestEnable = False
, Vk.minDepthBounds = 0
, Vk.maxDepthBounds = 1
, Vk.stencilTestEnable = False
}
createMultisampleStateCreateInfo
:: Vk.SomeStruct Vk.PipelineMultisampleStateCreateInfo
createMultisampleStateCreateInfo =
Vk.SomeStruct $ Vk.zero
{ Vk.sampleShadingEnable = False
, Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT
}
createGraphicsPipelines
:: (MonadResource m, MonadReader ReadState m)
=> Vk.Device
-> Vk.RenderPass
-> ShaderContainer
-> V2 CInt
-> Vk.PipelineLayout
-> Maybe Vk.PipelineDepthStencilStateCreateInfo
-> String
-> m ()
createGraphicsPipelines
logicalDevice
renderPass
shaderContainer
(V2 width height)
pipelineLayout
depthState
materialName
= do
meshLib <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary
let pipelineStagesCreateInfos =
V.fromList $ map Vk.SomeStruct
( maybe
[]
(\shader ->
[ createShaderStageCreateInfo
Vk.SHADER_STAGE_VERTEX_BIT
shader
]
)
(containedVertexShader shaderContainer)
++
maybe
[]
(\shader ->
[ createShaderStageCreateInfo
Vk.SHADER_STAGE_FRAGMENT_BIT
shader
]
)
(containedFragmentShader shaderContainer)
)
dynamicStates =
V.fromList
[ Vk.DYNAMIC_STATE_VIEWPORT
, Vk.DYNAMIC_STATE_SCISSOR
]
pipelineDynamicStateCreateInfo = Vk.zero
{ Vk.dynamicStates = dynamicStates
}
vertexDescription = getVertexDescription (V.head $ meshVertices $ meshLib M.! "mask")
pipelineVertexInputCreateInfo = Vk.zero
{ Vk.vertexBindingDescriptions = vidBindings vertexDescription
, Vk.vertexAttributeDescriptions = vidAttributes vertexDescription
}
viewport = Vk.Viewport
{ Vk.x = 0
, Vk.y = 0
, Vk.width = fromIntegral width
, Vk.height = fromIntegral height
, Vk.minDepth = 0
, Vk.maxDepth = 1
}
scissor = Vk.Rect2D
{ Vk.offset = Vk.Offset2D 0 0
, Vk.extent = Vk.Extent2D (fromIntegral width) (fromIntegral height)
}
pipelineViewportStateCreateInfo = Vk.zero
{ Vk.viewports = V.singleton viewport
, Vk.scissors = V.singleton scissor
}
colorBlendAttachment = Vk.zero
{ Vk.colorWriteMask =
Vk.COLOR_COMPONENT_R_BIT .|.
Vk.COLOR_COMPONENT_G_BIT .|.
Vk.COLOR_COMPONENT_B_BIT .|.
Vk.COLOR_COMPONENT_A_BIT
, Vk.blendEnable = True
, Vk.srcColorBlendFactor = Vk.BLEND_FACTOR_ONE
, Vk.dstColorBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA
, Vk.colorBlendOp = Vk.BLEND_OP_ADD
, Vk.srcAlphaBlendFactor = Vk.BLEND_FACTOR_ONE
, Vk.dstAlphaBlendFactor = Vk.BLEND_FACTOR_ZERO
, Vk.alphaBlendOp = Vk.BLEND_OP_ADD
}
pipelineColorBlendStateCreateInfo = Vk.zero
{ Vk.logicOpEnable = False
, Vk.attachments = V.singleton colorBlendAttachment
}
pipelineCreateInfo = Vk.zero
{ Vk.stageCount = fromIntegral (V.length pipelineStagesCreateInfos)
, Vk.stages = pipelineStagesCreateInfos
, Vk.vertexInputState = Just $ Vk.SomeStruct pipelineVertexInputCreateInfo
, Vk.inputAssemblyState =
Just $ createVertexInputAssemblyStateCreateInfo VK.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST
, Vk.viewportState = Just $ Vk.SomeStruct pipelineViewportStateCreateInfo
, Vk.rasterizationState = Just $ createRasterizationStateCreateInfo Vk.POLYGON_MODE_FILL
, Vk.multisampleState = Just createMultisampleStateCreateInfo
, Vk.colorBlendState = Just $ Vk.SomeStruct pipelineColorBlendStateCreateInfo
, Vk.dynamicState = Just pipelineDynamicStateCreateInfo
, Vk.depthStencilState = depthState
, Vk.layout = pipelineLayout
, Vk.renderPass = renderPass
, Vk.subpass = 0
, Vk.basePipelineHandle = Vk.NULL_HANDLE
, Vk.basePipelineIndex = -1
}
pipeline <-
(do
(result, pipelines) <- snd <$> Vk.withGraphicsPipelines
logicalDevice
Vk.NULL_HANDLE
(V.singleton (Vk.SomeStruct pipelineCreateInfo))
Nothing
allocate
unless (result == Vk.SUCCESS) $
error "createGraphicsPipelines: Failed creating pipelines"
return pipelines
)
let material = Material Vk.NULL_HANDLE (V.head pipeline) pipelineLayout
matLibraryTMVar <- asks materialLibrary
matLibrary <- liftIO $ STM.atomically $ STM.readTMVar matLibraryTMVar
let newMatLibrary = M.insert materialName material matLibrary
void $ liftIO $ STM.atomically $ STM.swapTMVar matLibraryTMVar newMatLibrary
createMeshPipelineLayout
:: MonadResource m
=> Vk.Device
-> V.Vector Vk.DescriptorSetLayout
-> m Vk.PipelineLayout
createMeshPipelineLayout logicalDevice layouts = do
let pushConstantRange = Vk.zero
{ Vk.offset = 0
, Vk.size = fromIntegral (sizeOf undefinedMeshPushConstants)
, Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT
}
pipelineLayoutCreateInfo = Vk.zero
{ Vk.pushConstantRanges = V.singleton pushConstantRange
, Vk.setLayouts = layouts
}
snd <$>
Vk.withPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing allocate

View file

@ -1,47 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Image where
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
imageCreate
:: Vk.Format
-> Vk.Extent3D
-> Vk.ImageUsageFlags
-> Vk.ImageCreateInfo '[]
imageCreate format extent usageFlags =
let imageCreateInfo = Vk.zero
{ Vk.imageType = Vk.IMAGE_TYPE_2D
, Vk.format = format
, Vk.extent = extent
, Vk.mipLevels = 1
, Vk.arrayLayers = 1
, Vk.samples = Vk.SAMPLE_COUNT_1_BIT
, Vk.tiling = Vk.IMAGE_TILING_OPTIMAL
, Vk.usage = usageFlags
}
in imageCreateInfo
imageviewCreate
:: Vk.Image
-> Vk.Format
-> Vk.ImageAspectFlags
-> Vk.ImageViewCreateInfo '[]
imageviewCreate image format aspectFlags =
let imageviewCreateInfo = Vk.zero
{ Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
, Vk.image = image
, Vk.format = format
, Vk.subresourceRange = Vk.zero
{ Vk.baseMipLevel = 0
, Vk.levelCount = 1
, Vk.baseArrayLayer = 0
, Vk.layerCount = 1
, Vk.aspectMask = aspectFlags
}
}
in imageviewCreateInfo

View file

@ -1,58 +1,37 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Init where
import qualified Control.Concurrent.STM as STM
import Control.Exception
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 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
-- internal imports
import Instance
import Devices
import GraphicsPipeline
import Framebuffers
import Memory
import Types
import Mesh
import CommandBuffer
import Sync
import Textures
import Util
initEngine
:: Render EngineData
:: MonadResource m
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.ImageView)
initEngine = do
-- initialize SDL2 with all subsystems
void $ allocate_
SDL.initializeAll
(do
putStrLn "This is the end!"
print ("This is the end!" :: String)
SDL.quit
)
-- create a window configuration
let windowConfig = SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
, SDL.windowInitialSize = V2 1280 1024
}
-- load vulkan library
@ -61,285 +40,38 @@ initEngine = do
-- create the window
(_, window) <-
allocate
(do
eexcept <- try (SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
case eexcept of
Left err -> error $ "here's your exception: " <> show (err :: SDL.SDLException)
Right a -> return a
)
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
(\window -> do
liftIO $ putStrLn "destroying window"
liftIO $ print ("destroying window" :: String)
SDL.destroyWindow window
)
-- initialize vúlkan data structures
initVulkan window
-- create vulkan surface and vulkan instance from window
(surface, inst, swapchain, images) <- initVulkan window
return (window, inst, surface, swapchain, images)
initVulkan
:: SDL.Window
-> Render EngineData
:: MonadResource m
=> SDL.Window
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.ImageView)
initVulkan window = do
vulkanInstance <- createInstance window
(_, vulkanSurface) <- allocate
(Khr.SurfaceKHR <$>
(Vk.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
)
(\vulkanSurface -> do
putStrLn "destroying surface"
Khr.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
print ("destroying surface" :: String)
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats, queueIndex) <-
createLogicalDevice vulkanPhysicalDevice vulkanSurface
uploadContext <- initSyncStructures vulkanLogicalDevice queueIndex
(descriptorSetLayout1, descriptorSetLayout2, textureDescriptorSetLayout, descriptorPool) <-
initDescriptors vulkanLogicalDevice
allocator <- initAllocator vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance
(vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
(swapchain, surfaceFormat, depthImageView, depthAllocatedImage) <-
createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice allocator
(swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice
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
meshContainer
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
vulkanLogicalDevice
allocator
descriptorPool
descriptorSetLayout1
descriptorSetLayout2
queueIndex
loadMeshes allocator uploadContext queue vulkanLogicalDevice
loadImages allocator uploadContext queue vulkanLogicalDevice
initScene vulkanLogicalDevice descriptorPool textureDescriptorSetLayout
return $ EngineData
window
dimensions
vulkanPhysicalDevice
vulkanLogicalDevice
vulkanInstance
swapchain
queue
frameBuffers
renderPass
allocator
depthImageView
depthAllocatedImage
Vk.FORMAT_D32_SFLOAT
frames
descriptorSetLayout1
descriptorSetLayout2
textureDescriptorSetLayout
descriptorPool
(GPUSceneData
(V4 0 0 0 0)
(V4 0 0 0 0)
(V4 0 0 0 0)
(V4 0 0 0 0)
(V4 0 0 0 0)
)
uploadContext
initScene
:: (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 = "texturedMesh"
, objectMatrix = identity
}
triangles = V.concatMap
(\y ->
V.map
(\x ->
let
translationMatrix = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 x 0 y)
scaleMatrix = scaled (V4 0.2 0.2 0.2 1)
in
RenderObject
{ objectMesh = "triangle"
, objectMaterial = "defaultMesh"
, objectMatrix = translationMatrix !*! scaleMatrix
}
)
(V.fromList [-20 .. 20])
)
(V.fromList [-20 .. 20])
renderableContainer <- asks renderables
renderableVector <- liftIO $ STM.atomically $ STM.readTMVar renderableContainer
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.DescriptorSetLayout, Vk.DescriptorPool)
initDescriptors device = do
let cameraBind = descriptorsetLayoutBinding
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
Vk.SHADER_STAGE_VERTEX_BIT
0
sceneBind = descriptorsetLayoutBinding
Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER -- _DYNAMIC
Vk.SHADER_STAGE_FRAGMENT_BIT
1
objectBind = descriptorsetLayoutBinding
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
[ cameraBind
, sceneBind
]
}
setInfo2 = Vk.zero
{ 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.DESCRIPTOR_POOL_CREATE_FREE_DESCRIPTOR_SET_BIT
, Vk.maxSets = 10
, Vk.poolSizes = V.fromList
[ Vk.zero
{ Vk.type' = Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER
, Vk.descriptorCount = 10
}
, Vk.zero
{ Vk.type' = Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER_DYNAMIC
, Vk.descriptorCount = 10
}
, Vk.zero
{ Vk.type' = Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER
, Vk.descriptorCount = 10
}
, Vk.zero
{ Vk.type' = Vk.DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER
, Vk.descriptorCount = 10
}
]
}
(_, descriptorSetLayout1) <-
Vk.withDescriptorSetLayout device setInfo Nothing allocate
(_, descriptorSetLayout2) <-
Vk.withDescriptorSetLayout device setInfo2 Nothing allocate
(_, textureDescriptorSetLayout) <-
Vk.withDescriptorSetLayout device setInfo3 Nothing allocate
(_, descriptorPool) <-
Vk.withDescriptorPool device poolInfo Nothing allocate
return (descriptorSetLayout1, descriptorSetLayout2, textureDescriptorSetLayout, descriptorPool)
return (vulkanSurface, vulkanInstance, swapchain, imageViews)

View file

@ -14,12 +14,10 @@ import qualified Vulkan.Zero as Vk
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
createInstance window = do
windowExtensions <- liftIO $ fmap (
[ Vk.EXT_DEBUG_UTILS_EXTENSION_NAME
] ++) $
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
liftIO $ do
putStrLn "activating following extensions:"
print ("activating followinfg extensions:" :: String)
print windowExtensions
let createInfo = Vk.zero
{ Vk.applicationInfo = Just Vk.zero
@ -32,6 +30,11 @@ createInstance window = do
, Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation"
}
(_, inst) <- Vk.withInstance createInfo Nothing allocate
(_, inst) <- allocate
(Vk.createInstance createInfo Nothing)
(\inst -> do
print ("destroying instance" :: String)
Vk.destroyInstance inst Nothing
)
return inst

View file

@ -1,99 +1,48 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Main where
import qualified Control.Concurrent.STM as STM
import Control.Monad
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 Control.Concurrent.STM as STM
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import Init
import Draw (drawFrame)
import Types
main :: IO ()
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
main = runResourceT $ do
(window, inst, surface, swapchain, images) <- initEngine
SDL.showWindow $ engineWindow engineData
SDL.showWindow window
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
time <- liftIO $ STM.newTMVarIO =<< getCurrentTime
average <- liftIO $ STM.newTMVarIO 0
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
-- main loop
whileM_
(liftIO $ STM.atomically $ STM.readTMVar quit
)
( 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
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
void $ liftIO $ STM.atomically $ STM.swapTMVar quit False
_ -> return ()
)
evs
-- main loop
liftIO $ whileM_
(STM.atomically $ STM.readTMVar quit
)
fps <- liftIO $ STM.atomically $ STM.readTMVar average
liftIO $ hPutStr stdout $
"\n" <>
"Average FPS: " <> pack (show fps) <> "\n"
Vk.deviceWaitIdle $ engineLogicalDevice engineData
( do
-- poll events
evs <- SDL.pollEvents
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
void $ STM.atomically $ STM.swapTMVar quit False
_ -> return ()
)
evs
)
createBufferView
:: (MonadResource m)
@ -107,8 +56,12 @@ createBufferView logicalDevice = do
Vk.BUFFER_USAGE_UNIFORM_TEXEL_BUFFER_BIT
, Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE
}
buffer <- snd <$>
(Vk.withBuffer logicalDevice bufferCreateInfo Nothing allocate)
buffer <- snd <$> allocate
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing)
(\buffer -> do
print ("destroying buffer" :: String)
Vk.destroyBuffer logicalDevice buffer Nothing
)
let bufferViewCreateInfo = Vk.zero
{ Vk.buffer = buffer
@ -117,7 +70,12 @@ createBufferView logicalDevice = do
, Vk.range = Vk.WHOLE_SIZE
}
Vk.withBufferView logicalDevice bufferViewCreateInfo Nothing allocate
allocate
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
(\bufferView -> do
print ("destroying bufferView" :: String)
Vk.destroyBufferView logicalDevice bufferView Nothing
)
allocateMemory
:: (MonadResource m)
@ -128,8 +86,13 @@ allocateMemory logicalDevice buffer = do
memoryRequirements <- Vk.getBufferMemoryRequirements logicalDevice buffer
let memoryAllocateInfo = Vk.zero
{ Vk.allocationSize = memoryRequirements.size
{ Vk.allocationSize = (Vk.size :: Vk.MemoryRequirements -> Word64) memoryRequirements
, Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String)
}
Vk.withMemory logicalDevice memoryAllocateInfo Nothing allocate
allocate
(Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing)
(\memory -> do
print ("Freeing memory" :: String)
Vk.freeMemory logicalDevice memory Nothing
)

View file

@ -1,70 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Memory where
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits ((.|.))
import Foreign.Ptr
import qualified VulkanMemoryAllocator as VMA
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Dynamic as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import Types
initAllocator
:: (MonadResource m, MonadFail m)
=> Vk.PhysicalDevice
-> Vk.Device
-> Vk.Instance
-> m VMA.Allocator
initAllocator physicalDevice device instance' = do
let instanceProcAddr = castFunPtr $
Vk.pVkGetInstanceProcAddr (instance'.instanceCmds)
deviceProcAddr = castFunPtr $
Vk.pVkGetDeviceProcAddr (device.deviceCmds)
let allocatorInfo = Vk.zero
{ VMA.physicalDevice = Vk.physicalDeviceHandle physicalDevice
, VMA.device = Vk.deviceHandle device
, VMA.instance' = Vk.instanceHandle instance'
, VMA.vulkanFunctions = Just (Vk.zero
{ VMA.vkGetInstanceProcAddr = instanceProcAddr
, VMA.vkGetDeviceProcAddr = deviceProcAddr
} :: VMA.VulkanFunctions)
} :: VMA.AllocatorCreateInfo
(_, allocator) <- VMA.withAllocator allocatorInfo allocate
return allocator
createAllocatedBuffer
:: (MonadResource m, MonadIO m)
=> VMA.Allocator
-> Int
-> Vk.BufferUsageFlags
-> VMA.MemoryUsage
-> m AllocatedBuffer
createAllocatedBuffer allocator allocationSize usage memoryUsage = do
let bufferCreateInfo = Vk.zero
{ Vk.size = fromIntegral allocationSize
, Vk.usage = usage
}
vmaAllocationInfo = Vk.zero
{ VMA.usage = memoryUsage
, VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT
, VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT .|. Vk.MEMORY_PROPERTY_HOST_COHERENT_BIT
, VMA.preferredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
} :: VMA.AllocationCreateInfo
(_, (buffer, newAllocation, info)) <-
VMA.withBuffer allocator bufferCreateInfo vmaAllocationInfo allocate
return $ AllocatedBuffer buffer newAllocation info

View file

@ -1,226 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Mesh where
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
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 (V2(..), V3(..), V4(..))
import qualified VulkanMemoryAllocator as VMA
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import Types
import Sync
loadMeshes
:: (MonadReader ReadState m, MonadResource m, MonadFail m)
=> VMA.Allocator
-> UploadContext
-> Vk.Queue
-> Vk.Device
-> m ()
loadMeshes allocator uploadContext queue device = do
let triangle = V.fromList
[ Vertex (V3 0.5 0 0) (V3 0 0 0) (V4 0 1 0 1) (V2 0 0)
, Vertex (V3 (-0.5) 0 0) (V3 0 0 0) (V4 0 1 0 1) (V2 0 0)
, Vertex (V3 0 1 0) (V3 0 0 0) (V4 0 1 0 1) (V2 0 0)
]
triMesh <- uploadMesh triangle allocator uploadContext queue device
maskMesh <- loadFromObj
"./assets/models/jaeger.obj"
allocator
uploadContext
queue
device
meshLib <- asks meshLibrary
liftIO $ STM.atomically $ do
meshMap <- STM.readTMVar meshLib
let newMap =
M.insert "triangle" triMesh $
M.insert "mask" maskMesh meshMap
CM.void $ STM.swapTMVar meshLib newMap
uploadMesh
:: (MonadResource m, MonadFail m)
=> V.Vector Vertex
-> VMA.Allocator
-> UploadContext
-> Vk.Queue
-> Vk.Device
-> m Mesh
uploadMesh vertices allocator uploadContext queue device = do
let bufferSize = fromIntegral $ V.length vertices * sizeOf (undefined :: Vertex)
stagingBufferCrateInfo = Vk.zero
{ Vk.size = bufferSize
, Vk.usage = Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
}
stagingAllocationCreateInfo = Vk.zero
{ VMA.usage = VMA.MEMORY_USAGE_CPU_ONLY
} :: VMA.AllocationCreateInfo
(stagingReleaseKey, stagingBuffer) <- do
(releaseKey, (buffer, bAllocation, bInfo)) <-
VMA.withBuffer allocator stagingBufferCrateInfo stagingAllocationCreateInfo allocate
return (releaseKey, AllocatedBuffer
{ bufferInfo = bInfo
, bufferAllocation = bAllocation
, allocatedBuffer = buffer
})
(dataReleaseKey, dataPtr) <-
VMA.withMappedMemory allocator (bufferAllocation stagingBuffer) allocate
liftIO $ V.mapM_ (\(idx, vertex) ->
poke
(castPtr dataPtr `plusPtr` (idx * sizeOf vertex))
vertex
)
(V.zip
(V.fromList [0..])
vertices
)
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
loadFromObj
:: (MonadResource m, MonadFail m)
=> FilePath
-> VMA.Allocator
-> UploadContext
-> Vk.Queue
-> Vk.Device
-> m Mesh
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) (objTexCoords obj)
uploadMesh vertices vma uploadContext queue device
where
digestFaces
:: 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)
then
error "loadFromObj: Non-triangular face detected"
else
let newVertices = V.map
(\faceIndex ->
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 uv
)
(V.fromList [ fa, fb, fc ])
in
acc V.++ newVertices
)
V.empty
faces
faceIndexToPosition :: FaceIndex -> V.Vector Location -> V3 Float
faceIndexToPosition index locations =
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
)

View file

@ -1,75 +0,0 @@
{-# 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)

View file

@ -1,173 +0,0 @@
{-# 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

View file

@ -1,331 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
module Types where
import Control.Concurrent.STM.TMVar as STM
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 Foreign
import Foreign.C.Types (CInt)
import Linear
import qualified SDL
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified VulkanMemoryAllocator as VMA
data ShaderContainer = ShaderContainer
{ containedVertexShader :: Maybe Vk.ShaderModule
, containedFragmentShader :: Maybe Vk.ShaderModule
}
deriving (Show)
data EngineData = EngineData
{ engineWindow :: SDL.Window
, engineWindowDimensions :: V2 CInt
, enginePhysicalDevice :: Vk.PhysicalDevice
, engineLogicalDevice :: Vk.Device
, engineInstance :: Vk.Instance
, engineSwapchain :: Vk.SwapchainKHR
, engineQueue :: Vk.Queue
, engineFramebuffers :: V.Vector Vk.Framebuffer
, engineRenderPass :: Vk.RenderPass
, engineAllocator :: VMA.Allocator
, engineDepthImageView :: Vk.ImageView
, engineDepthImage :: AllocatedImage
, engineDepthFormat :: Vk.Format
, 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
, bufferAllocation :: VMA.Allocation
, bufferInfo :: VMA.AllocationInfo
}
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, Eq)
instance Storable Vertex where
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)
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 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
class VertexInputDescribable v where
getVertexDescription :: v -> VertexInputDescription
instance VertexInputDescribable Vertex where
getVertexDescription v =
let mainBinding = Vk.zero
{ Vk.binding = 0
, Vk.stride = fromIntegral (sizeOf v)
, Vk.inputRate = Vk.VERTEX_INPUT_RATE_VERTEX
} :: Vk.VertexInputBindingDescription
positionAttribute = Vk.zero
{ Vk.binding = 0
, Vk.location = 0
, Vk.format = Vk.FORMAT_R32G32B32_SFLOAT
, Vk.offset = 0
} :: Vk.VertexInputAttributeDescription
normalAttribute = Vk.zero
{ Vk.binding = 0
, Vk.location = 1
, Vk.format = Vk.FORMAT_R32G32B32_SFLOAT
, Vk.offset = fromIntegral (sizeOf (vertexPosition v))
} :: Vk.VertexInputAttributeDescription
colorAttribute = Vk.zero
{ Vk.binding = 0
, Vk.location = 2
, 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 ]
, vidAttributes = V.fromList
[ positionAttribute
, normalAttribute
, colorAttribute
, uvAttribute
]
}
data VertexInputDescription = VertexInputDescription
{ vidBindings :: V.Vector Vk.VertexInputBindingDescription
, vidAttributes :: V.Vector Vk.VertexInputAttributeDescription
}
deriving (Show)
data Mesh = Mesh
{ meshVertices :: V.Vector Vertex
, meshBuffer :: AllocatedBuffer
}
deriving (Show, Eq)
data MeshPushConstants = MeshPushConstants
{ meshPushData :: V4 Float
, meshRenderMatrix :: M44 Float
}
deriving (Show)
undefinedMeshPushConstants :: MeshPushConstants
undefinedMeshPushConstants = MeshPushConstants (V4 0 0 0 0) identity
instance Storable MeshPushConstants where
sizeOf _ = sizeOf (V4 0 0 0 0 :: V4 Float) + sizeOf (identity :: M44 Float)
peek ptr = do
dat <- peek (castPtr ptr)
mat <- peek (castPtr (ptr `plusPtr` sizeOf dat))
return (MeshPushConstants dat mat)
poke ptr (MeshPushConstants dat mat) = do
poke (castPtr ptr) dat
poke (castPtr $ ptr `plusPtr` sizeOf dat) mat
alignment _ = 0
data AllocatedImage = AllocatedImage
{ image :: Vk.Image
, allocation :: VMA.Allocation
}
deriving (Show)
data Material = Material
{ materialTextureSet :: Vk.DescriptorSet
, materialPipeline :: Vk.Pipeline
, materialPipelineLayout :: Vk.PipelineLayout
}
deriving (Show, Eq)
data RenderObject = RenderObject
{ objectMesh :: String
, objectMaterial :: String
, objectMatrix :: M44 Float
}
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)
type RenderInner rd m = ReaderT rd m
type Render a = RenderReader ReadState ResIO a
runRender :: ReadState -> Render a -> IO a
runRender rd actions = runResourceT $ flip runReaderT rd $ runRenderInner actions
data FrameData = FrameData
{ framePresentSemaphore :: Vk.Semaphore
, frameRenderSemaphore :: Vk.Semaphore
, frameRenderFence :: Vk.Fence
, frameCommandPool :: Vk.CommandPool
, frameMainCommandBuffer :: Vk.CommandBuffer
, frameCameraBuffer :: AllocatedBuffer
, frameSceneBuffer :: AllocatedBuffer
, frameObjectBuffer :: AllocatedBuffer
, frameIndirectBuffer :: AllocatedBuffer
, frameGlobalDescriptor :: Vk.DescriptorSet
, frameObjectDescriptor :: Vk.DescriptorSet
}
deriving (Show)
newtype GPUObjectData = GPUObjectData
{ objectModelMatrix :: M44 Float
}
undefinedGPUObjectData :: GPUObjectData
undefinedGPUObjectData = GPUObjectData identity
instance Storable GPUObjectData where
sizeOf (GPUObjectData _) = sizeOf (identity :: M44 Float)
alignment _ = 0
peek ptr = do
GPUObjectData <$> peek (castPtr ptr)
poke ptr (GPUObjectData modelMatrix) =
poke (castPtr ptr) $ transpose modelMatrix
data GPUCameraData = GPUCameraData
{ view :: M44 Float
, projection :: M44 Float
, viewProjection :: M44 Float
}
instance Storable GPUCameraData where
sizeOf _ =
3 * sizeOf (undefined :: M44 Float)
alignment _ = 0
peek ptr = do
v <- peek (castPtr ptr)
p <- peek (castPtr ptr `plusPtr` sizeOf v)
vp <- peek (castPtr ptr `plusPtr` sizeOf v `plusPtr` sizeOf p)
return $ GPUCameraData v p vp
poke ptr (GPUCameraData pview pprojection pviewProjection) = do
poke (castPtr ptr) $ transpose pview
poke (castPtr ptr `plusPtr` sizeOf pview) $ transpose pprojection
poke (castPtr ptr `plusPtr` sizeOf pview `plusPtr` sizeOf pprojection) $
transpose pviewProjection
data GPUSceneData = GPUSceneData
{ fogColor :: V4 Float
, fogDistance :: V4 Float
, ambientColor :: V4 Float
, sunDirection :: V4 Float
, sunColor :: V4 Float
}
deriving (Show)
undefinedGPUSceneData :: GPUSceneData
undefinedGPUSceneData = GPUSceneData
(V4 0 0 0 0)
(V4 0 0 0 0)
(V4 0 0 0 0)
(V4 0 0 0 0)
(V4 0 0 0 0)
instance Storable GPUSceneData where
sizeOf _ =
5 * sizeOf (V4 0 0 0 0 :: V4 Float)
alignment _ = 0
peek ptr = do
fogCol <- peek (castPtr ptr)
fogDst <- peek (castPtr $ ptr `plusPtr` sizeOf fogCol)
ambCol <- peek (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDst))
sunDir <- peek (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDst + sizeOf ambCol))
sunCol <- peek (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDst + sizeOf ambCol + sizeOf sunDir))
return $ GPUSceneData fogCol fogDst ambCol sunDir sunCol
poke ptr (GPUSceneData fogCol fogDist ambCol sunDir sunCol) = do
poke (castPtr ptr) fogCol
poke (castPtr $ ptr `plusPtr` sizeOf fogCol) fogDist
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
}

View file

@ -1,110 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Util where
import Data.Bits
import qualified Data.Vector as V
import Data.Word (Word32)
import qualified Vulkan as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import Types
getFrame :: EngineData -> Int -> FrameData
getFrame engineData frame =
let frameVector = engineFrames engineData
in
frameVector V.! (frame `mod` V.length frameVector)
padUniformBufferSize
:: Vk.DeviceSize
-> Vk.PhysicalDeviceProperties
-> Vk.DeviceSize
padUniformBufferSize origSize gpuProperties =
let minUBOAlignment = Vk.minUniformBufferOffsetAlignment $ Vk.limits gpuProperties
result =
if minUBOAlignment > 0
then (origSize + minUBOAlignment - 1) .&. complement (minUBOAlignment - 1)
else origSize
in
-- trace ("padding result: " <> show result) result
result
descriptorsetLayoutBinding
:: Vk.DescriptorType
-> Vk.ShaderStageFlags
-> Word32
-> Vk.DescriptorSetLayoutBinding
descriptorsetLayoutBinding type' stageFlags binding =
Vk.zero
{ Vk.binding = binding
, Vk.descriptorCount = 1
, Vk.descriptorType = type'
, Vk.immutableSamplers = V.empty
, Vk.stageFlags = stageFlags
}
writeDescriptorBuffer
:: Vk.DescriptorType
-> Vk.DescriptorSet
-> Vk.DescriptorBufferInfo
-> Word32
-> Vk.SomeStruct Vk.WriteDescriptorSet
writeDescriptorBuffer type' dstSet dBufferInfo binding = Vk.SomeStruct $
Vk.zero
{ Vk.dstBinding = binding
, Vk.dstSet = dstSet
, Vk.descriptorCount = 1
, 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
}

View file

@ -1,46 +0,0 @@
{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()
'';
})

View file

@ -18,7 +18,6 @@ maintainer: nek0@nek0.eu
-- copyright:
category: Game
extra-source-files: CHANGELOG.md
, shadersrc/*
executable vulkan-tutorial
main-is: Main.hs
@ -27,37 +26,22 @@ executable vulkan-tutorial
other-modules: Init
Instance
Devices
GraphicsPipeline
Framebuffers
CommandBuffer
Draw
Memory
Mesh
Image
Sync
Textures
Types
Util
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
build-depends: base
build-depends: base >=4.14.3.0
, sdl2
, vulkan
, vulkan-utils
, VulkanMemoryAllocator
, wavefront
, linear
, monad-loops
, stm
, time
, bytestring
, text
, vector
, resourcet
, mtl
, containers
, JuicyPixels
, transformers
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall