{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-} module Mesh where import Codec.Wavefront import Control.Monad.IO.Class import Control.Monad.Trans.Resource 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 loadMeshes :: V.Vector Vertex loadMeshes = 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) ] uploadMesh :: (MonadResource m, MonadFail m) => V.Vector Vertex -> VMA.Allocator -> m Mesh uploadMesh vertices allocator = do let bufferCreateInfo = Vk.zero { Vk.size = fromIntegral $ V.length vertices * sizeOf (Vertex (V3 0 0 0) (V3 0 0 0 ) (V4 0 0 0 0)) , Vk.usage = Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT } allocationCreateInfo = Vk.zero { VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU } :: VMA.AllocationCreateInfo (_, mesh) <- allocate (do (buffer, allocation, _) <- VMA.createBuffer allocator bufferCreateInfo allocationCreateInfo return (Mesh vertices (AllocatedBuffer buffer allocation)) ) (\(Mesh _ (AllocatedBuffer buffer allocation)) -> do putStrLn "destroying mesh" VMA.destroyBuffer allocator buffer allocation ) (dataReleaseKey, dataPtr) <- allocate (VMA.mapMemory allocator (bufferAllocation $ meshBuffer mesh)) (\_ -> VMA.unmapMemory allocator (bufferAllocation $ meshBuffer mesh)) liftIO $ mapM_ (\(idx, vertex) -> poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex ) (zip [0..] (V.toList vertices)) release dataReleaseKey return mesh loadFromObj :: (MonadResource m, MonadFail m) => FilePath -> VMA.Allocator -> m Mesh loadFromObj filepath vma = 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 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