Merge pull request #14 from mrehayden1/feature/animations

sgillespie · web-flow · commit 3ad3e9cd53f4 · 2024-05-09T21:45:02.000-04:00
Animation support.
diff --git a/src/Text/GLTF/Loader/Gltf.hs b/src/Text/GLTF/Loader/Gltf.hs
@@ -2,6 +2,10 @@ module Text.GLTF.Loader.Gltf
   ( -- * Data constructors
     Gltf (..),
     Asset (..),
+    Animation (..),
+    Channel (..),
+    ChannelSamplerInterpolation (..),
+    ChannelSamplerOutput (..),
     Image (..),
     MagFilter (..),
     MinFilter (..),
@@ -106,6 +110,7 @@ import RIO
 -- | The root data type for a glTF asset
 data Gltf = Gltf
   { gltfAsset :: Asset,
+    gltfAnimations :: Vector Animation,
     gltfImages :: Vector Image,
     gltfMaterials :: Vector Material,
     gltfMeshes :: Vector Mesh,
@@ -129,6 +134,16 @@ data Asset = Asset
   }
   deriving (Eq, Show)
 
+-- | Keyframe animations for tranforming and morphing scene nodes
+data Animation = Animation
+  { -- | Defines the animation keyframes for up to one of each from translation
+    -- , rotation, scale and morph weights.
+    animationChannels :: Vector Channel,
+    -- | The user-defined name of this object.
+    animationName :: Maybe Text
+  }
+  deriving (Eq, Show)
+
 -- | Image data used to create a texture.
 data Image = Image
   { -- | The binary data of the image
@@ -320,6 +335,32 @@ data TextureInfo = TextureInfo
   }
   deriving (Eq, Show)
 
+data Channel = Channel
+  { -- | The target node to apply this channel of the animation to.
+    channelTargetNode :: Maybe Int,
+    -- | The interpolation to use for inputs between each animation keyframe
+    -- sample.
+    channelSamplerInterpolation :: ChannelSamplerInterpolation,
+    -- | The timestamps of each of the animation's keyframes.
+    channelSamplerInputs :: Vector Float,
+    -- | The values representing the animated property of each keyframe.
+    channelSamplerOutputs :: ChannelSamplerOutput
+  }
+  deriving (Eq, Show)
+
+data ChannelSamplerOutput
+  = MorphTargetWeights (Vector Float)
+  | Rotation (Vector (Quaternion Float))
+  | Scale (Vector (V3 Float))
+  | Translation (Vector (V3 Float))
+  deriving (Eq, Show)
+
+data ChannelSamplerInterpolation
+  = CubicSpline
+  | Linear
+  | Step
+  deriving (Eq, Show)
+
 -- | Reference to a normal map texture
 data NormalTextureInfo = NormalTextureInfo
   { -- | The index of the texture.
diff --git a/src/Text/GLTF/Loader/Internal/Adapter.hs b/src/Text/GLTF/Loader/Internal/Adapter.hs
@@ -8,6 +8,7 @@ module Text.GLTF.Loader.Internal.Adapter
     runAdapter,
     adaptGltf,
     adaptAsset,
+    adaptAnimations,
     adaptImages,
     adaptMaterials,
     adaptMeshes,
@@ -33,6 +34,7 @@ import Text.GLTF.Loader.Internal.MonadAdapter
 
 import qualified Codec.GlTF as GlTF
 import qualified Codec.GlTF.Asset as Asset
+import qualified Codec.GlTF.Animation as Animation
 import qualified Codec.GlTF.Image as Image
 import qualified Codec.GlTF.Material as Material
 import qualified Codec.GlTF.Mesh as Mesh
@@ -77,12 +79,14 @@ adaptGltf :: Adapter Gltf
 adaptGltf = do
   GlTF.GlTF{..} <- getGltf
 
+  gltfAnimations <- adaptAnimations animations
   gltfImages <- adaptImages images
   gltfMeshes <- adaptMeshes meshes
 
   return
     $ Gltf
       { gltfAsset = adaptAsset asset,
+        gltfAnimations = gltfAnimations,
         gltfImages = gltfImages,
         gltfMaterials = adaptMaterials materials,
         gltfMeshes = gltfMeshes,
@@ -101,6 +105,51 @@ adaptAsset Asset.Asset{..} =
       assetMinVersion = minVersion
     }
 
+adaptAnimations
+  :: Maybe (Vector Animation.Animation)
+  -> Adapter (Vector Animation)
+adaptAnimations = maybe (return mempty) (mapM adaptAnimation)
+
+adaptAnimation :: Animation.Animation -> Adapter Animation
+adaptAnimation Animation.Animation{..} = do
+  gltfChannels <- mapM (adaptAnimationChannel samplers) channels
+  return
+    $ Animation
+      { animationChannels = gltfChannels,
+        animationName = name
+      }
+
+adaptAnimationChannel
+  :: Vector Animation.AnimationSampler
+  -> Animation.AnimationChannel
+  -> Adapter Channel
+adaptAnimationChannel samplers Animation.AnimationChannel{..} = do
+  gltf <- getGltf
+  buffers <- getBuffers
+  let Animation.AnimationSampler{ input, interpolation, output } =
+        samplers ! Animation.unAnimationSamplerIx sampler
+      Animation.AnimationChannelTarget{ node, path } = target
+      outputs = case path of
+        Animation.ROTATION -> Rotation $ animationSamplerRotationOutputs gltf buffers output
+        Animation.SCALE -> Scale $ animationSamplerScaleOutputs gltf buffers output
+        Animation.TRANSLATION -> Translation $ animationSamplerTranslationOutputs gltf buffers output
+        Animation.WEIGHTS -> MorphTargetWeights $ animationSamplerWeightsOutputs gltf buffers output
+        _ -> error $ "Invalid Channel path: " <> show path
+  return
+    $ Channel
+      { channelTargetNode = fmap Node.unNodeIx node,
+        channelSamplerInterpolation = adaptInterpolation interpolation,
+        channelSamplerInputs = animationSamplerInputs gltf buffers input,
+        channelSamplerOutputs = outputs
+      }
+
+adaptInterpolation :: Animation.AnimationSamplerInterpolation -> ChannelSamplerInterpolation
+adaptInterpolation Animation.CUBICSPLINE = CubicSpline
+adaptInterpolation Animation.LINEAR = Linear
+adaptInterpolation Animation.STEP = Step
+adaptInterpolation (Animation.AnimationSamplerInterpolation interpolation) =
+  error $ "Invalid ChannelSamplerInterpolation: " <> show interpolation
+
 adaptImages :: Maybe (Vector Image.Image) -> Adapter (Vector Image)
 adaptImages codecImages = do
   imageData <- getImages
diff --git a/src/Text/GLTF/Loader/Internal/BufferAccessor.hs b/src/Text/GLTF/Loader/Internal/BufferAccessor.hs
@@ -7,6 +7,11 @@ module Text.GLTF.Loader.Internal.BufferAccessor
     loadImages,
 
     -- * Deserializing Accessors
+    animationSamplerInputs,
+    animationSamplerRotationOutputs,
+    animationSamplerScaleOutputs,
+    animationSamplerTranslationOutputs,
+    animationSamplerWeightsOutputs,
     vertexIndices,
     vertexPositions,
     vertexNormals,
@@ -88,6 +93,35 @@ loadImages GlTF{images = images} basePath = do
     let fallbackImageData = return $ maybe NoImageData ImageBufferView bufferView
     maybe fallbackImageData (fmap ImageData . loadUri' basePath) uri
 
+animationSamplerInputs :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector Float
+animationSamplerInputs = readBufferWithGet (getScalar getFloat)
+
+animationSamplerRotationOutputs :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (Quaternion Float)
+animationSamplerRotationOutputs gltf buffers' accessorId =
+  fromMaybe (error "Invalid animation sampler output component type.") $ do
+    buffer@BufferAccessor{componentType = componentType} <-
+      bufferAccessor gltf buffers' accessorId
+
+    case componentType of
+      FLOAT -> Just . readFromBuffer (Proxy @(Quaternion Float)) (getQuaternion getFloat) $ buffer
+      _ -> Nothing
+
+animationSamplerScaleOutputs :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V3 Float)
+animationSamplerScaleOutputs = readBufferWithGet (getVec3 getFloat)
+
+animationSamplerTranslationOutputs :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V3 Float)
+animationSamplerTranslationOutputs = readBufferWithGet (getVec3 getFloat)
+
+animationSamplerWeightsOutputs :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector Float
+animationSamplerWeightsOutputs gltf buffers' accessorId =
+  fromMaybe (error "Invalid animation sampler output component type.") $ do
+    buffer@BufferAccessor{componentType = componentType} <-
+      bufferAccessor gltf buffers' accessorId
+
+    case componentType of
+      FLOAT -> Just . readFromBuffer (Proxy @Float) (getScalar getFloat) $ buffer
+      _ -> Nothing
+
 -- | Decode vertex indices
 vertexIndices :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector Word32
 vertexIndices gltf buffers' accessorId =
diff --git a/src/Text/GLTF/Loader/Internal/Decoders.hs b/src/Text/GLTF/Loader/Internal/Decoders.hs
@@ -18,6 +18,7 @@ module Text.GLTF.Loader.Internal.Decoders
     getMat2,
     getMat3,
     getMat4,
+    getQuaternion,
 
     -- * GLTF Component Type decoders
     getByte,
@@ -121,6 +122,14 @@ getMat4 getter =
 
 {- FOURMOLU_DISABLE -}
 
+-- | Quaternion binary decoder
+getQuaternion :: Get a -> Get (Vector (Quaternion a))
+getQuaternion getter = getVector $ do
+  v3 <- V3 <$> getter <*> getter <*> getter
+  Quaternion
+    <$> getter
+    <*> pure v3
+
 -- | Byte binary decoder
 getByte :: Get Int8
 getByte = getInt8
