diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for keid-resource-gltf + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright IC Rainbow (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# Keid Engine - glTF resource diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keid-resource-gltf.cabal b/keid-resource-gltf.cabal new file mode 100644 --- /dev/null +++ b/keid-resource-gltf.cabal @@ -0,0 +1,104 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: keid-resource-gltf +version: 0.1.0.0 +synopsis: GLTF loader for Keid engine. +category: Game Engine +author: IC Rainbow +maintainer: keid@aenor.ru +copyright: 2021 IC Rainbow +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/keid/engine + +library + exposed-modules: + Resource.Gltf.Load + Resource.Gltf.Model + Resource.Gltf.Scene + other-modules: + Paths_keid_resource_gltf + hs-source-dirs: + src + default-extensions: + NoImplicitPrelude + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstrainedClassMethods + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumDecimals + NumericUnderscores + OverloadedStrings + PatternSynonyms + PostfixOperators + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UnicodeSyntax + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , derive-storable + , derive-storable-plugin + , geomancy + , gltf-codec + , keid-core + , rio >=0.1.12.0 + , rio-app + , vulkan + default-language: Haskell2010 diff --git a/src/Resource/Gltf/Load.hs b/src/Resource/Gltf/Load.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Gltf/Load.hs @@ -0,0 +1,341 @@ +module Resource.Gltf.Load + ( loadMeshPrimitives + + , loadGlb + , loadGlbChunks + + , loadGltf + + , loadUri + ) where + +import RIO + +import Codec.GLB qualified as GLB +import Codec.GlTF qualified as GlTF +import Codec.GlTF.Accessor qualified as Accessor +import Codec.GlTF.Buffer qualified as Buffer +import Codec.GlTF.BufferView qualified as BufferView +import Codec.GlTF.Material qualified as Material +import Codec.GlTF.Mesh qualified as Mesh +import Codec.GlTF.Root qualified as Root +import Codec.GlTF.URI qualified as URI +import Data.ByteString.Unsafe qualified as ByteString +import Foreign qualified +import Geomancy (Vec2, Vec4, vec3, withVec4) +import Geomancy.Vec3 qualified as Vec3 +import RIO.ByteString qualified as ByteString +import RIO.FilePath (takeDirectory, takeExtensions, ()) +import RIO.HashMap qualified as HashMap +import RIO.List qualified as List +import RIO.Vector qualified as Vector + +import Resource.Compressed.Zstd qualified as Zstd +import Resource.Gltf.Model (MeshPrimitive, Stuff(..), VertexAttrs(..)) + +loadGlb :: FilePath -> IO (Either String (ByteString, Root.GlTF)) +loadGlb sceneFile = + loadGlbChunks sceneFile >>= \case + Right chunks -> + case Vector.toList chunks of + [] -> + pure . Left $ "No chunks in GLB file " <> show sceneFile + [_root] -> + pure . Left $ "No data chunk in GLB file " <> show sceneFile + gltf : buffer : _rest -> + pure $ + fmap (GLB.chunkData buffer,) $ + GlTF.fromChunk gltf + Left err -> + pure $ Left err + +loadGlbChunks :: FilePath -> IO (Either String (Vector GLB.Chunk)) +loadGlbChunks sceneFile = + Zstd.fromFileWith (pure . GLB.fromByteString) GLB.fromFile sceneFile >>= \case + Right glb -> + pure $ Right (GLB.chunks glb) + Left (_offset, err) -> + pure $ Left err + +loadGltf :: FilePath -> IO (Either String Root.GlTF) +loadGltf = + Zstd.fromFileWith (pure . GlTF.fromByteString) GlTF.fromFile + +loadUri :: FilePath -> FilePath -> IO (Either a ByteString) +loadUri sceneFile uri = + fmap Right . Zstd.fromFileWith pure ByteString.readFile $ + takeDirectory sceneFile uri + +-- XXX: OTOH, it may be better to unfold scene first 🤔 +loadMeshPrimitives + :: HasLogFunc env + => Bool + -> Bool + -> FilePath + -> RIO env + ( Root.GlTF + , Vector (Vector MeshPrimitive) + ) +loadMeshPrimitives reverseIndices addBacksides fp = do + logInfo $ "Loading scene from " <> fromString fp + + (glbData, root) <- liftIO $ + if takeExtensions fp `elem` [".glb", ".glb.zst"] then + loadGlb fp >>= \case + Left err -> + throwString $ "GLB load error: " <> err + Right (buffer, root) -> + pure (Just buffer, root) + else + loadGltf fp >>= \case + Left err -> + throwString $ "glTF load error: " <> err + Right root -> + pure (Nothing, root) + + buffers <- case Root.buffers root of + Nothing -> + pure mempty + Just buffers -> + for buffers \case + Buffer.Buffer{uri=Nothing} -> + case glbData of + Nothing -> + throwString $ "Empty buffer URI in " <> show fp -- XXX: not loading GLB, are we? + Just bs -> + pure bs + Buffer.Buffer{uri=Just path} -> + liftIO (URI.loadURI (loadUri fp) path) >>= \case + Left err -> + throwString $ "Buffer load failed for " <> show path <> ": " <> err + Right bs -> + pure bs + let + getBuffer bix = + case buffers Vector.!? Buffer.unBufferIx bix of + Nothing -> + throwString $ show bix <> " not present in " <> show fp + Just buffer -> + pure buffer + + getAccessor <- case Root.accessors root of + Nothing -> + throwString $ "No accessors in " <> fp + Just accessors -> + pure \aix -> + case accessors Vector.!? Accessor.unAccessorIx aix of + Nothing -> + throwString $ show aix <> " not present in " <> show fp + Just accessor -> + pure accessor + + getBufferView <- case Root.bufferViews root of + Nothing -> + throwString $ "No buffer views in " <> fp + Just bufferViews -> + pure \bvix -> + case bufferViews Vector.!? BufferView.unBufferViewIx bvix of + Nothing -> + throwString $ show bvix <> " not present in " <> show fp + Just bufferView -> + pure bufferView + + let materials = fromMaybe mempty $ Root.materials root + + meshPrimitives <- case Root.meshes root of + Nothing -> + throwString $ "No meshes in " <> fp + Just meshes -> + for (Vector.zip (Vector.fromList [0 :: Int ..]) meshes) \(_meshIx, mesh) -> do + for (Vector.zip (Vector.fromList [0 :: Int ..]) (Mesh.primitives mesh)) \(_primIx, prim) -> do + -- traceShowM + -- ( "mesh" + -- , _meshIx, Mesh.name mesh + -- , "primitive" + -- , _primIx + -- ) + case Mesh.mode prim of + Mesh.TRIANGLES -> + pure () + mode -> + throwString $ "Can't load anything but TRIANGLES, got " <> show mode + + indicesCCW <- case Mesh.indices prim of + Nothing -> + throwString "No indices for mesh primitive" + Just aix -> do + -- accessBuffer @Word16 getAccessor getBufferView getBuffer Accessor.SCALAR Accessor.UNSIGNED_SHORT aix + indices <- catch + (fmap Right $ accessBuffer @Word32 getAccessor getBufferView getBuffer Accessor.SCALAR Accessor.UNSIGNED_INT aix) + (\UnexpectedComponentType{} -> + fmap Left $ accessBuffer @Word16 getAccessor getBufferView getBuffer Accessor.SCALAR Accessor.UNSIGNED_SHORT aix + ) + case indices of + Right word32s -> + pure word32s + Left word16s -> + pure $ fmap fromIntegral word16s + + (material, indices) <- case Mesh.material prim of + Nothing -> + pure (Nothing, indicesCCW) + Just (Material.MaterialIx mix) -> + case materials Vector.!? mix of + Nothing -> + throwString "No material for index" + Just mat@Material.Material{doubleSided} -> do + pure + ( Just (mix, mat) + , if doubleSided && addBacksides then + indicesCCW <> reverse indicesCCW + else + if reverseIndices then + reverse indicesCCW + else + indicesCCW + ) + + -- for (HashMap.toList $ Mesh.attributes prim) \(attr, aix) -> + -- traceShowM (attr, aix) + + -- let attrKeys = HashMap.keys $ Mesh.attributes prim + -- logDebug $ "Mesh attributes: " <> displayShow attrKeys + + positions <- case HashMap.lookup "POSITION" (Mesh.attributes prim) of + Nothing -> + -- XXX: huh? + throwString $ "Mesh primitive without POSITION attribute" + Just aix -> + accessBuffer @Vec3.Packed getAccessor getBufferView getBuffer Accessor.VEC3 Accessor.FLOAT aix + -- logDebug $ "POSITION (" <> display (length positions) <> ") " <> displayShow (take 10 $ fmap Vec3.unPacked positions) + + -- traceShowM + -- ( ( meshIx + -- , primIx + -- ) + -- , length positions + -- , ( length indices + -- , minimum indices + -- , maximum indices + -- ) + -- ) + + normals <- case HashMap.lookup "NORMAL" (Mesh.attributes prim) of + Nothing -> do + logWarn "Mesh primitive without NORMAL attribute" + pure $ take (length positions) $ List.repeat (Vec3.Packed 0) + Just aix -> + accessBuffer @Vec3.Packed getAccessor getBufferView getBuffer Accessor.VEC3 Accessor.FLOAT aix + -- logDebug $ "NORMAL (" <> display (length normals) <> ") " <> displayShow (take 10 normals) + + texCoords0 <- case HashMap.lookup "TEXCOORD_0" (Mesh.attributes prim) of + Nothing -> do + logDebug "Mesh primitive without TEXCOORD_0 attribute" + pure $ take (length positions) $ List.repeat 0 + Just aix -> + accessBuffer @Vec2 getAccessor getBufferView getBuffer Accessor.VEC2 Accessor.FLOAT aix + -- logDebug $ "TEXCOORD_0 (" <> display (length texCoords0) <> ") " <> displayShow (take 10 texCoords0) + + tangents <- case HashMap.lookup "TANGENT" (Mesh.attributes prim) of + Just aix -> + accessBuffer @Vec4 getAccessor getBufferView getBuffer Accessor.VEC4 Accessor.FLOAT aix + Nothing -> do + -- logDebug "Mesh primitive without TANGENT attribute" + pure $ take (length positions) $ List.repeat 0 + -- logDebug $ "TANGENT (" <> display (length tangents) <> ") " <> displayShow (take 10 tangents) + + let + attrs = do + (tc0, norm, tangent') <- List.zip3 texCoords0 normals tangents + let + tangent = + withVec4 tangent' \tx ty tz _handedness -> + Vec3.Packed $ vec3 tx ty tz + pure VertexAttrs + { vaTexCoord = tc0 + , vaNormal = norm + , vaTangent = tangent + } + pure + ( material + , Stuff + { sPositions = Vector.fromList positions + , sAttrs = Vector.fromList attrs + , sIndices = Vector.fromList indices + } + ) + + pure (root, meshPrimitives) + +accessBuffer + :: forall a env . (Storable a) + => (Accessor.AccessorIx -> RIO env Accessor.Accessor) + -> (BufferView.BufferViewIx -> RIO env BufferView.BufferView) + -> (Buffer.BufferIx -> RIO env ByteString) + -> Accessor.AttributeType + -> Accessor.ComponentType + -> Accessor.AccessorIx + -> RIO env [a] +accessBuffer getAccessor getBufferView getBuffer expectAttribute expectComponent aix = do + Accessor.Accessor{bufferView, byteOffset=accOffset, componentType, count, type'} <- getAccessor aix + + bv@BufferView.BufferView{byteOffset=bufOffset, byteLength} <- case bufferView of + Nothing -> + throwString $ "No bufferView for index accessor " <> show aix + Just bvix -> + getBufferView bvix + + buffer <- getBuffer (BufferView.buffer bv) + + unexpected (UnexpectedAttributeType aix) expectAttribute type' + unexpected (UnexpectedComponentType aix) expectComponent componentType + let strideSize = Foreign.sizeOf (error "strideSize.sizeOf" :: a) + case BufferView.byteStride bv of + Nothing -> + pure () + Just stride + | stride == strideSize -> + pure () + Just stride -> + unexpected (UnexpectedBufferViewStride aix) strideSize stride + + let bytes = ByteString.take byteLength $ ByteString.drop (accOffset + bufOffset) buffer + liftIO . ByteString.unsafeUseAsCString bytes $ + Foreign.peekArray count . Foreign.castPtr + +unexpected + :: (Eq e, Exception exception) + => (e -> e -> exception) + -> e + -> e + -> RIO env () +unexpected cons expected got = + unless (expected == got) $ + throwM $ cons expected got + +data UnexpectedAttributeType = UnexpectedAttributeType + { uatAccessor :: Accessor.AccessorIx + , uatExpected :: Accessor.AttributeType + , uatGot :: Accessor.AttributeType + } + deriving (Eq, Ord, Show) + +instance Exception UnexpectedAttributeType + +data UnexpectedComponentType = UnexpectedComponentType + { uctAccessor :: Accessor.AccessorIx + , uctExpected :: Accessor.ComponentType + , uctGot :: Accessor.ComponentType + } + deriving (Eq, Ord, Show) + +instance Exception UnexpectedComponentType + +data UnexpectedBufferViewStride = UnexpectedBufferViewStride + { ubvsAccessor :: Accessor.AccessorIx + , ubvsExpected :: Int + , ubvsGot :: Int + } + deriving (Eq, Ord, Show) + +instance Exception UnexpectedBufferViewStride diff --git a/src/Resource/Gltf/Model.hs b/src/Resource/Gltf/Model.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Gltf/Model.hs @@ -0,0 +1,122 @@ +module Resource.Gltf.Model + ( Mesh + , MeshPrimitive + + , Stuff(..) + , mergeStuff + , unzipStuff + + , StuffLike + , mergeStuffLike + + , VertexAttrs(..) + ) where + +import RIO + +import Codec.GlTF.Material qualified as GlTF (Material) +import Foreign qualified +import Data.Semigroup (Semigroup(..)) +import Geomancy (Vec2) +import Geomancy.Vec3 qualified as Vec3 +import RIO.List qualified as List +import RIO.Vector qualified as Vector + +type Mesh = Vector MeshPrimitive + +type MeshPrimitive = (Maybe (Int, GlTF.Material), Stuff) + +data Stuff = Stuff + { sPositions :: Vector Vec3.Packed + , sIndices :: Vector Word32 + , sAttrs :: Vector VertexAttrs + } + deriving (Eq, Show, Generic) + +instance Semigroup Stuff where + {-# INLINE (<>) #-} + a <> b = mergeStuff [a, b] + + {-# INLINE sconcat #-} + sconcat = mergeStuff + +instance Monoid Stuff where + mempty = Stuff + { sPositions = mempty + , sIndices = mempty + , sAttrs = mempty + } + + {-# INLINE mconcat #-} + mconcat = mergeStuff + +mergeStuff :: Foldable t => t Stuff -> Stuff +mergeStuff source = Stuff + { sPositions = Vector.concat allPositions + , sIndices = Vector.concat offsetIndices + , sAttrs = Vector.concat allAttrs + } + where + (allPositions, allAttrs, numPositions, allIndices) = unzipStuff source + + offsetIndices = List.zipWith applyOffset chunkOffsets allIndices + where + applyOffset off = fmap (+ off) + + chunkOffsets = List.scanl' (+) 0 numPositions + +unzipStuff + :: Foldable t + => t Stuff + -> ( [Vector Vec3.Packed] + , [Vector VertexAttrs] + , [Word32] + , [Vector Word32] + ) +unzipStuff source = List.unzip4 do + Stuff{..} <- toList source + pure + ( sPositions + , sAttrs + , fromIntegral $ Vector.length sPositions {- sic! -} + , sIndices + ) + +type StuffLike attrs = (Vector Vec3.Packed, Vector Word32, Vector attrs) + +mergeStuffLike :: Foldable t => t (StuffLike attrs) -> (StuffLike attrs) +mergeStuffLike source = + ( Vector.concat allPositions + , Vector.concat offsetIndices + , Vector.concat allAttrs + ) + where + (allPositions, allIndices, allAttrs) = List.unzip3 (toList source) + + offsetIndices = List.zipWith applyOffset chunkOffsets allIndices + where + applyOffset off = fmap (+ fromIntegral off) + + chunkOffsets = List.scanl' (+) 0 $ map Vector.length allPositions + +data VertexAttrs = VertexAttrs + { vaTexCoord :: Vec2 + , vaNormal :: Vec3.Packed + , vaTangent :: Vec3.Packed + } deriving (Eq, Ord, Show) + +instance Storable VertexAttrs where + alignment ~_ = 16 + + sizeOf ~_ = 8 + 12 + 12 + + peek ptr = do + vaTexCoord <- Foreign.peekByteOff ptr 0 -- +8 + vaNormal <- Foreign.peekByteOff ptr 8 -- +12 + vaTangent <- Foreign.peekByteOff ptr 20 -- +12 + pure VertexAttrs{..} + + poke ptr VertexAttrs{..} = do + Foreign.pokeByteOff ptr 0 vaTexCoord + Foreign.pokeByteOff ptr 8 vaNormal + Foreign.pokeByteOff ptr 20 vaTangent diff --git a/src/Resource/Gltf/Scene.hs b/src/Resource/Gltf/Scene.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Gltf/Scene.hs @@ -0,0 +1,268 @@ +module Resource.Gltf.Scene where + +import RIO + +import Codec.GlTF qualified as GlTF +import Codec.GlTF.Mesh qualified as GlTF (MeshIx(..)) +import Codec.GlTF.Node qualified as GlTF (Node, NodeIx(..)) +import Codec.GlTF.Node qualified as Node +import Codec.GlTF.Root qualified as Root +import Codec.GlTF.Scene qualified as Scene +import Data.Coerce (coerce) +import Data.Tree (Tree) +import Data.Tree qualified as Tree +import Geomancy (Transform(..), quaternion) +import Geomancy.Mat4 qualified as Mat4 +import Geomancy.Transform qualified as Transform +import Geomancy.Vec3 qualified as Vec3 +import RIO.Vector qualified as Vector + +import Resource.Gltf.Model (Mesh, MeshPrimitive, Stuff(..), VertexAttrs(..)) + +unfoldSceneM + :: HasLogFunc env + => Int + -> Transform + -> Root.GlTF + -> Vector Mesh + -> RIO env (Tree SceneNode) +unfoldSceneM materialOffset initialTransform root allMeshes = do + (allNodes, initialNodes) <- getRootNodes root + meshes <- unfoldNodesM allMeshes allNodes (toList initialNodes) + pure Tree.Node + { rootLabel = SceneNode + { snOrigin = 0 + , snPrimitives = Nothing + , snNode = emptyNode + } + , subForest = + map (toSceneNode materialOffset initialTransform) meshes + } + +{-# INLINEABLE toSceneNode #-} +toSceneNode + :: Int + -> Transform + -> Tree (Maybe (Vector MeshPrimitive), GlTF.Node) + -> Tree SceneNode +toSceneNode materialOffset initialTransform = + fmap (injectTransforms materialOffset) . + collectTransforms initialTransform + +getRootNodes :: HasLogFunc env => GlTF.GlTF -> RIO env (Vector Node.Node, Vector Node.NodeIx) +getRootNodes root = do + rootNodes <- case Root.scenes root of + Nothing -> do + logWarn "No scenes" + pure Nothing + Just scenes -> + case Vector.toList scenes of + [] -> do + logWarn "Empty scene vector" + pure Nothing + [one] -> + pure $ Scene.nodes one + pick : _rest -> do + logWarn $ mconcat + [ "Picking first scene among " + , display (Vector.length scenes) + ] + pure $ Scene.nodes pick + + allNodes <- case Root.nodes root of + Nothing -> + throwString "TODO: fallback to raw meshes" + Just nodes -> do + pure nodes + + case rootNodes of + Nothing -> + throwString "TODO: fallback for lack of scene" + Just start -> do + pure (allNodes, start) + +emptyNode :: Node.Node +emptyNode = Node.Node + { camera = Nothing + , children = Nothing + , skin = Nothing + , matrix = Nothing + , mesh = Nothing + , rotation = Nothing + , scale = Nothing + , translation = Nothing + , weights = Nothing + , name = Nothing + , extensions = Nothing + , extras = Nothing + } + +data LookupError + = NodeNotFound Int + | MeshNotFound Int + deriving (Eq, Ord, Show) + +instance Exception LookupError + +injectTransforms + :: Int + -> ( Maybe (Vector MeshPrimitive) + , Transform + , GlTF.Node + ) + -> SceneNode +injectTransforms materialOffset (mmesh, transform, snNode) = SceneNode{..} + where + snOrigin = Vec3.Packed $ Transform.apply 0 transform + + snPrimitives = fmap (Vector.map $ bimap adjustMaterial adjustNode) mmesh + + adjustMaterial = fmap \(materialId, gltfMaterial) -> + ( materialId + materialOffset + , gltfMaterial + ) + + adjustNode Stuff{..} = Stuff + { sPositions = fmap applyTransform sPositions + , sAttrs = fmap applyAttrTransform sAttrs + , sIndices = sIndices + } + where + applyTransform pos = + coerce $ Transform.apply (coerce pos) transform + + applyTransformDir dir = + coerce $ Vec3.normalize $ Transform.apply (coerce dir) (Transform transformDir) + where + transformDir = Mat4.transpose . Mat4.inverse $ + Mat4.pointwise (unTransform transform) nullifyTranslation (*) + + applyAttrTransform va = va + { vaNormal = applyTransformDir (vaNormal va) + , vaTangent = applyTransformDir (vaTangent va) + } + +collectTransforms + :: Transform + -> Tree (Maybe (Vector MeshPrimitive), GlTF.Node) + -> Tree (Maybe (Vector MeshPrimitive), Transform, GlTF.Node) +collectTransforms initial root = Tree.unfoldTree go (initial, root) + where + go (parent, Tree.Node{rootLabel=(mmesh, node), subForest}) = + let + collected = localTransform node <> parent + in + ( (mmesh, collected, node) + , map (collected,) subForest + ) + +-- | Build node tree and shed lookup errors as exception. +unfoldNodesM + :: MonadThrow m + => Vector Mesh + -> Vector GlTF.Node + -> [GlTF.NodeIx] + -> m [Tree (Maybe (Vector MeshPrimitive), GlTF.Node)] +unfoldNodesM allMeshes allNodes = + either throwM pure . traverse (inflateNode allMeshes allNodes) + +-- | Combine lookup operations for nodes and meshes. +inflateNode + :: Vector Mesh + -> Vector GlTF.Node + -> GlTF.NodeIx + -> Either LookupError (Tree (Maybe (Vector MeshPrimitive), GlTF.Node)) +inflateNode allMeshes allNodes startNode = + for (unfoldNode allNodes startNode) \getNode -> do + node <- getNode + mesh <- getMesh allMeshes node + pure (mesh, node) + +unfoldNode + :: Vector GlTF.Node + -> GlTF.NodeIx + -> Tree (Either LookupError GlTF.Node) +unfoldNode allNodes = Tree.unfoldTree fetch + where + fetch (GlTF.NodeIx ix) = + case allNodes Vector.!? ix of + Nothing -> + ( Left $ NodeNotFound ix + , [] + ) + Just node -> + ( Right node + , maybe [] toList $ Node.children node + ) + +getMesh + :: Vector mesh + -> GlTF.Node + -> Either LookupError (Maybe mesh) +getMesh allMeshes node = + case Node.mesh node of + Nothing -> + Right Nothing + Just (GlTF.MeshIx ix) -> + case allMeshes Vector.!? ix of + Nothing -> + Left $ MeshNotFound ix + Just mesh -> + Right (Just mesh) + +localTransform :: Node.Node -> Transform +localTransform node = mconcat + [ nodeMatrix + , nodeScale, nodeRotate, nodeTranslate + ] + where + nodeScale = case Node.scale node of + Nothing -> + mempty + Just (sx, sy, sz) -> + Transform.scale3 sx sy sz + + nodeTranslate = + case Node.translation node of + Nothing -> + mempty + Just (tx, ty, tz) -> + Transform.translate tx ty tz + + nodeRotate = case Node.rotation node of + Nothing -> + mempty + Just (qx, qy, qz, qW) -> + Transform.rotateQ $ quaternion qW qx qy qz + + nodeMatrix = case Node.matrix node of + Nothing -> + mempty + Just (Node.NodeMatrix memoryBytes) -> + case Vector.toList memoryBytes of + [ x1, x2, x3, x4, + y1, y2, y3, y4, + z1, z2, z3, z4, + w1, w2, w3, w4 ] -> + Mat4.colMajor @Transform + x1 y1 z1 w1 + x2 y2 z2 w2 + x3 y3 z3 w3 + x4 y4 z4 w4 + _ -> + error "Node matrix isn't 16-element" + +nullifyTranslation :: Mat4.Mat4 +nullifyTranslation = + Mat4.rowMajor + 1 1 1 0 + 1 1 1 0 + 1 1 1 0 + 0 0 0 1 + +data SceneNode = SceneNode + { snOrigin :: ~Vec3.Packed + , snPrimitives :: Maybe (Vector MeshPrimitive) + , snNode :: GlTF.Node + } + deriving (Show)