{-# 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 qualified Data.Vector as V import Foreign import Linear (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.5 0) (V3 0 0 0) (V4 0 1 0 1) , Vertex (V3 (-0.5) 0.5 0) (V3 0 0 0) (V4 0 1 0 1) , Vertex (V3 0 (-0.5) 0) (V3 0 0 0) (V4 0 1 0 1) ] triMesh <- uploadMesh triangle allocator uploadContext queue device maskMesh <- loadFromObj "./assets/models/cat_mask_cyberpunk.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) uploadMesh vertices vma uploadContext queue device where digestFaces :: V.Vector (Element Face) -> V.Vector Location -> V.Vector Vertex digestFaces faces locations = 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 in Vertex position normal color ) (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