keid-resource-gltf (empty) → 0.1.0.0
raw patch · 8 files changed
+871/−0 lines, 8 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, derive-storable, derive-storable-plugin, geomancy, gltf-codec, keid-core, rio, rio-app, vulkan
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- keid-resource-gltf.cabal +104/−0
- src/Resource/Gltf/Load.hs +341/−0
- src/Resource/Gltf/Model.hs +122/−0
- src/Resource/Gltf/Scene.hs +268/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for keid-resource-gltf++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# Keid Engine - glTF resource
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keid-resource-gltf.cabal view
@@ -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
+ src/Resource/Gltf/Load.hs view
@@ -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
+ src/Resource/Gltf/Model.hs view
@@ -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
+ src/Resource/Gltf/Scene.hs view
@@ -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)