vulkan-tutorial/src/Types.hs
2023-05-14 18:50:02 +02:00

298 lines
8.8 KiB
Haskell

{-# 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
, engineDescriptorPool :: Vk.DescriptorPool
, engineSceneParameters :: GPUSceneData
, engineUploadContext :: UploadContext
}
deriving (Show)
data AllocatedBuffer = AllocatedBuffer
{ allocatedBuffer :: Vk.Buffer
, bufferAllocation :: VMA.Allocation
, bufferInfo :: VMA.AllocationInfo
}
deriving (Show)
data Vertex = Vertex
{ vertexPosition :: V3 Float
, vertexNormal :: V3 Float
, vertexColor :: V4 Float
}
deriving (Show)
instance Storable Vertex where
sizeOf _ = sizeOf (undefined :: V3 Float) * 2 + sizeOf (undefined :: V4 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
poke ptr (Vertex position normal color) = do
let castedV3Ptr = castPtr ptr
pokeElemOff castedV3Ptr 0 position
pokeElemOff castedV3Ptr 1 normal
poke (castPtr (ptr `plusPtr` sizeOf position `plusPtr` sizeOf normal)) color
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
in
VertexInputDescription
{ vidBindings = V.fromList [ mainBinding ]
, vidAttributes = V.fromList
[ positionAttribute
, normalAttribute
, colorAttribute
]
}
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)
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
{ materialPipeline :: Vk.Pipeline
, materialPipelineLayout :: Vk.PipelineLayout
}
deriving (Show)
data RenderObject = RenderObject
{ objectMesh :: String
, objectMaterial :: String
, objectMatrix :: M44 Float
}
deriving (Show)
data ReadState = ReadState
{ renderables :: STM.TMVar (V.Vector RenderObject)
, meshLibrary :: STM.TMVar (M.Map String Mesh)
, materialLibrary :: STM.TMVar (M.Map String Material)
}
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
, 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)