vulkan-tutorial/src/Mesh.hs

193 lines
5.5 KiB
Haskell

{-# 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)