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 :: forall env.
HasLogFunc env =>
Int -> Transform -> GlTF -> Vector Mesh -> RIO env (Tree SceneNode)
unfoldSceneM Int
materialOffset Transform
initialTransform GlTF
root Vector Mesh
allMeshes = do
  (Vector Node
allNodes, Vector NodeIx
initialNodes) <- GlTF -> RIO env (Vector Node, Vector NodeIx)
forall env.
HasLogFunc env =>
GlTF -> RIO env (Vector Node, Vector NodeIx)
getRootNodes GlTF
root
  [Tree (Maybe Mesh, Node)]
meshes <- Vector Mesh
-> Vector Node -> [NodeIx] -> RIO env [Tree (Maybe Mesh, Node)]
forall (m :: * -> *).
MonadThrow m =>
Vector Mesh
-> Vector Node -> [NodeIx] -> m [Tree (Maybe Mesh, Node)]
unfoldNodesM Vector Mesh
allMeshes Vector Node
allNodes (Vector NodeIx -> [NodeIx]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector NodeIx
initialNodes)
  pure Tree.Node
    { rootLabel :: SceneNode
rootLabel = SceneNode
        { $sel:snOrigin:SceneNode :: Packed
snOrigin     = Packed
0
        , $sel:snPrimitives:SceneNode :: Maybe Mesh
snPrimitives = Maybe Mesh
forall a. Maybe a
Nothing
        , $sel:snNode:SceneNode :: Node
snNode       = Node
emptyNode
        }
    , subForest :: [Tree SceneNode]
subForest =
        (Tree (Maybe Mesh, Node) -> Tree SceneNode)
-> [Tree (Maybe Mesh, Node)] -> [Tree SceneNode]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Transform -> Tree (Maybe Mesh, Node) -> Tree SceneNode
toSceneNode Int
materialOffset Transform
initialTransform) [Tree (Maybe Mesh, Node)]
meshes
    }

{-# INLINEABLE toSceneNode #-}
toSceneNode
  :: Int
  -> Transform
  -> Tree (Maybe (Vector MeshPrimitive), GlTF.Node)
  -> Tree SceneNode
toSceneNode :: Int -> Transform -> Tree (Maybe Mesh, Node) -> Tree SceneNode
toSceneNode Int
materialOffset Transform
initialTransform =
  ((Maybe Mesh, Transform, Node) -> SceneNode)
-> Tree (Maybe Mesh, Transform, Node) -> Tree SceneNode
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> (Maybe Mesh, Transform, Node) -> SceneNode
injectTransforms Int
materialOffset) (Tree (Maybe Mesh, Transform, Node) -> Tree SceneNode)
-> (Tree (Maybe Mesh, Node) -> Tree (Maybe Mesh, Transform, Node))
-> Tree (Maybe Mesh, Node)
-> Tree SceneNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Transform
-> Tree (Maybe Mesh, Node) -> Tree (Maybe Mesh, Transform, Node)
collectTransforms Transform
initialTransform

getRootNodes :: HasLogFunc env => GlTF.GlTF -> RIO env (Vector Node.Node, Vector Node.NodeIx)
getRootNodes :: forall env.
HasLogFunc env =>
GlTF -> RIO env (Vector Node, Vector NodeIx)
getRootNodes GlTF
root = do
  Maybe (Vector NodeIx)
rootNodes <- case GlTF -> Maybe (Vector Scene)
Root.scenes GlTF
root of
    Maybe (Vector Scene)
Nothing -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"No scenes"
      pure Maybe (Vector NodeIx)
forall a. Maybe a
Nothing
    Just Vector Scene
scenes ->
      case Vector Scene -> [Scene]
forall (v :: * -> *) a. Vector v a => v a -> [a]
Vector.toList Vector Scene
scenes of
        [] -> do
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Empty scene vector"
          pure Maybe (Vector NodeIx)
forall a. Maybe a
Nothing
        [Scene
one] ->
          Maybe (Vector NodeIx) -> RIO env (Maybe (Vector NodeIx))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Vector NodeIx) -> RIO env (Maybe (Vector NodeIx)))
-> Maybe (Vector NodeIx) -> RIO env (Maybe (Vector NodeIx))
forall a b. (a -> b) -> a -> b
$ Scene -> Maybe (Vector NodeIx)
Scene.nodes Scene
one
        Scene
pick : [Scene]
_rest -> do
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Utf8Builder
"Picking first scene among "
            , Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Vector Scene -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
Vector.length Vector Scene
scenes)
            ]
          pure $ Scene -> Maybe (Vector NodeIx)
Scene.nodes Scene
pick

  Vector Node
allNodes <- case GlTF -> Maybe (Vector Node)
Root.nodes GlTF
root of
    Maybe (Vector Node)
Nothing ->
      String -> RIO env (Vector Node)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"TODO: fallback to raw meshes"
    Just Vector Node
nodes -> do
      Vector Node -> RIO env (Vector Node)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector Node
nodes

  case Maybe (Vector NodeIx)
rootNodes of
    Maybe (Vector NodeIx)
Nothing ->
      String -> RIO env (Vector Node, Vector NodeIx)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"TODO: fallback for lack of scene"
    Just Vector NodeIx
start -> do
      (Vector Node, Vector NodeIx)
-> RIO env (Vector Node, Vector NodeIx)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Node
allNodes, Vector NodeIx
start)

emptyNode :: Node.Node
emptyNode :: Node
emptyNode = Node.Node
  { $sel:camera:Node :: Maybe CameraIx
camera      = Maybe CameraIx
forall a. Maybe a
Nothing
  , $sel:children:Node :: Maybe (Vector NodeIx)
children    = Maybe (Vector NodeIx)
forall a. Maybe a
Nothing
  , $sel:skin:Node :: Maybe SkinIx
skin        = Maybe SkinIx
forall a. Maybe a
Nothing
  , $sel:matrix:Node :: Maybe NodeMatrix
matrix      = Maybe NodeMatrix
forall a. Maybe a
Nothing
  , $sel:mesh:Node :: Maybe MeshIx
mesh        = Maybe MeshIx
forall a. Maybe a
Nothing
  , $sel:rotation:Node :: Maybe (Float, Float, Float, Float)
rotation    = Maybe (Float, Float, Float, Float)
forall a. Maybe a
Nothing
  , $sel:scale:Node :: Maybe (Float, Float, Float)
scale       = Maybe (Float, Float, Float)
forall a. Maybe a
Nothing
  , $sel:translation:Node :: Maybe (Float, Float, Float)
translation = Maybe (Float, Float, Float)
forall a. Maybe a
Nothing
  , $sel:weights:Node :: Maybe (Vector Float)
weights     = Maybe (Vector Float)
forall a. Maybe a
Nothing
  , $sel:name:Node :: Maybe Text
name        = Maybe Text
forall a. Maybe a
Nothing
  , $sel:extensions:Node :: Maybe Object
extensions  = Maybe Object
forall a. Maybe a
Nothing
  , $sel:extras:Node :: Maybe Value
extras      = Maybe Value
forall a. Maybe a
Nothing
  }

data LookupError
  = NodeNotFound Int
  | MeshNotFound Int
  deriving (LookupError -> LookupError -> Bool
(LookupError -> LookupError -> Bool)
-> (LookupError -> LookupError -> Bool) -> Eq LookupError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LookupError -> LookupError -> Bool
== :: LookupError -> LookupError -> Bool
$c/= :: LookupError -> LookupError -> Bool
/= :: LookupError -> LookupError -> Bool
Eq, Eq LookupError
Eq LookupError
-> (LookupError -> LookupError -> Ordering)
-> (LookupError -> LookupError -> Bool)
-> (LookupError -> LookupError -> Bool)
-> (LookupError -> LookupError -> Bool)
-> (LookupError -> LookupError -> Bool)
-> (LookupError -> LookupError -> LookupError)
-> (LookupError -> LookupError -> LookupError)
-> Ord LookupError
LookupError -> LookupError -> Bool
LookupError -> LookupError -> Ordering
LookupError -> LookupError -> LookupError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LookupError -> LookupError -> Ordering
compare :: LookupError -> LookupError -> Ordering
$c< :: LookupError -> LookupError -> Bool
< :: LookupError -> LookupError -> Bool
$c<= :: LookupError -> LookupError -> Bool
<= :: LookupError -> LookupError -> Bool
$c> :: LookupError -> LookupError -> Bool
> :: LookupError -> LookupError -> Bool
$c>= :: LookupError -> LookupError -> Bool
>= :: LookupError -> LookupError -> Bool
$cmax :: LookupError -> LookupError -> LookupError
max :: LookupError -> LookupError -> LookupError
$cmin :: LookupError -> LookupError -> LookupError
min :: LookupError -> LookupError -> LookupError
Ord, Int -> LookupError -> ShowS
[LookupError] -> ShowS
LookupError -> String
(Int -> LookupError -> ShowS)
-> (LookupError -> String)
-> ([LookupError] -> ShowS)
-> Show LookupError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LookupError -> ShowS
showsPrec :: Int -> LookupError -> ShowS
$cshow :: LookupError -> String
show :: LookupError -> String
$cshowList :: [LookupError] -> ShowS
showList :: [LookupError] -> ShowS
Show)

instance Exception LookupError

injectTransforms
  :: Int
  -> ( Maybe (Vector MeshPrimitive)
     , Transform
     , GlTF.Node
     )
  -> SceneNode
injectTransforms :: Int -> (Maybe Mesh, Transform, Node) -> SceneNode
injectTransforms Int
materialOffset (Maybe Mesh
mmesh, Transform
transform, Node
snNode) = SceneNode{Maybe Mesh
Packed
Node
$sel:snOrigin:SceneNode :: Packed
$sel:snPrimitives:SceneNode :: Maybe Mesh
$sel:snNode:SceneNode :: Node
snNode :: Node
snOrigin :: Packed
snPrimitives :: Maybe Mesh
..}
  where
    snOrigin :: Packed
snOrigin = Vec3 -> Packed
Vec3.Packed (Vec3 -> Packed) -> Vec3 -> Packed
forall a b. (a -> b) -> a -> b
$ Vec3 -> Transform -> Vec3
Transform.apply Vec3
0 Transform
transform

    snPrimitives :: Maybe Mesh
snPrimitives = (Mesh -> Mesh) -> Maybe Mesh -> Maybe Mesh
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Maybe (Int, Material), Stuff) -> (Maybe (Int, Material), Stuff))
-> Mesh -> Mesh
forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
Vector.map (((Maybe (Int, Material), Stuff) -> (Maybe (Int, Material), Stuff))
 -> Mesh -> Mesh)
-> ((Maybe (Int, Material), Stuff)
    -> (Maybe (Int, Material), Stuff))
-> Mesh
-> Mesh
forall a b. (a -> b) -> a -> b
$ (Maybe (Int, Material) -> Maybe (Int, Material))
-> (Stuff -> Stuff)
-> (Maybe (Int, Material), Stuff)
-> (Maybe (Int, Material), Stuff)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Maybe (Int, Material) -> Maybe (Int, Material)
adjustMaterial Stuff -> Stuff
adjustNode) Maybe Mesh
mmesh

    adjustMaterial :: Maybe (Int, Material) -> Maybe (Int, Material)
adjustMaterial = ((Int, Material) -> (Int, Material))
-> Maybe (Int, Material) -> Maybe (Int, Material)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \(Int
materialId, Material
gltfMaterial) ->
      ( Int
materialId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
materialOffset
      , Material
gltfMaterial
      )

    adjustNode :: Stuff -> Stuff
adjustNode Stuff{Vector Word32
Vector Packed
Vector VertexAttrs
sPositions :: Vector Packed
sIndices :: Vector Word32
sAttrs :: Vector VertexAttrs
$sel:sPositions:Stuff :: Stuff -> Vector Packed
$sel:sIndices:Stuff :: Stuff -> Vector Word32
$sel:sAttrs:Stuff :: Stuff -> Vector VertexAttrs
..} = Stuff
      { $sel:sPositions:Stuff :: Vector Packed
sPositions = (Packed -> Packed) -> Vector Packed -> Vector Packed
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Packed -> Packed
applyTransform Vector Packed
sPositions
      , $sel:sAttrs:Stuff :: Vector VertexAttrs
sAttrs     = (VertexAttrs -> VertexAttrs)
-> Vector VertexAttrs -> Vector VertexAttrs
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VertexAttrs -> VertexAttrs
applyAttrTransform Vector VertexAttrs
sAttrs
      , $sel:sIndices:Stuff :: Vector Word32
sIndices   = Vector Word32
sIndices
      }
      where
        applyTransform :: Packed -> Packed
applyTransform Packed
pos =
          Vec3 -> Packed
forall a b. Coercible a b => a -> b
coerce (Vec3 -> Packed) -> Vec3 -> Packed
forall a b. (a -> b) -> a -> b
$ Vec3 -> Transform -> Vec3
Transform.apply (Packed -> Vec3
forall a b. Coercible a b => a -> b
coerce Packed
pos) Transform
transform

        applyTransformDir :: Packed -> Packed
applyTransformDir Packed
dir =
          Vec3 -> Packed
forall a b. Coercible a b => a -> b
coerce (Vec3 -> Packed) -> Vec3 -> Packed
forall a b. (a -> b) -> a -> b
$ Vec3 -> Vec3
Vec3.normalize (Vec3 -> Vec3) -> Vec3 -> Vec3
forall a b. (a -> b) -> a -> b
$ Vec3 -> Transform -> Vec3
Transform.apply (Packed -> Vec3
forall a b. Coercible a b => a -> b
coerce Packed
dir) (Mat4 -> Transform
Transform Mat4
transformDir)
          where
          transformDir :: Mat4
transformDir = Mat4 -> Mat4
Mat4.transpose (Mat4 -> Mat4) -> (Mat4 -> Mat4) -> Mat4 -> Mat4
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mat4 -> Mat4
forall a. (Coercible Mat4 a, Coercible Mat4 a) => a -> a
Mat4.inverse (Mat4 -> Mat4) -> Mat4 -> Mat4
forall a b. (a -> b) -> a -> b
$
            Mat4 -> Mat4 -> (Float -> Float -> Float) -> Mat4
Mat4.pointwise (Transform -> Mat4
unTransform Transform
transform) Mat4
nullifyTranslation Float -> Float -> Float
forall a. Num a => a -> a -> a
(*)

        applyAttrTransform :: VertexAttrs -> VertexAttrs
applyAttrTransform VertexAttrs
va = VertexAttrs
va
          { $sel:vaNormal:VertexAttrs :: Packed
vaNormal  = Packed -> Packed
applyTransformDir (VertexAttrs -> Packed
vaNormal VertexAttrs
va)
          , $sel:vaTangent:VertexAttrs :: Packed
vaTangent = Packed -> Packed
applyTransformDir (VertexAttrs -> Packed
vaTangent VertexAttrs
va)
          }

collectTransforms
  :: Transform
  -> Tree (Maybe (Vector MeshPrimitive), GlTF.Node)
  -> Tree (Maybe (Vector MeshPrimitive), Transform, GlTF.Node)
collectTransforms :: Transform
-> Tree (Maybe Mesh, Node) -> Tree (Maybe Mesh, Transform, Node)
collectTransforms Transform
initial Tree (Maybe Mesh, Node)
root = ((Transform, Tree (Maybe Mesh, Node))
 -> ((Maybe Mesh, Transform, Node),
     [(Transform, Tree (Maybe Mesh, Node))]))
-> (Transform, Tree (Maybe Mesh, Node))
-> Tree (Maybe Mesh, Transform, Node)
forall b a. (b -> (a, [b])) -> b -> Tree a
Tree.unfoldTree (Transform, Tree (Maybe Mesh, Node))
-> ((Maybe Mesh, Transform, Node),
    [(Transform, Tree (Maybe Mesh, Node))])
forall {a}.
(Transform, Tree (a, Node))
-> ((a, Transform, Node), [(Transform, Tree (a, Node))])
go (Transform
initial, Tree (Maybe Mesh, Node)
root)
  where
    go :: (Transform, Tree (a, Node))
-> ((a, Transform, Node), [(Transform, Tree (a, Node))])
go (Transform
parent, Tree.Node{rootLabel :: forall a. Tree a -> a
rootLabel=(a
mmesh, Node
node), [Tree (a, Node)]
subForest :: forall a. Tree a -> [Tree a]
subForest :: [Tree (a, Node)]
subForest}) =
      let
        collected :: Transform
collected = Node -> Transform
localTransform Node
node Transform -> Transform -> Transform
forall a. Semigroup a => a -> a -> a
<> Transform
parent
      in
        ( (a
mmesh, Transform
collected, Node
node)
        , (Tree (a, Node) -> (Transform, Tree (a, Node)))
-> [Tree (a, Node)] -> [(Transform, Tree (a, Node))]
forall a b. (a -> b) -> [a] -> [b]
map (Transform
collected,) [Tree (a, Node)]
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 :: forall (m :: * -> *).
MonadThrow m =>
Vector Mesh
-> Vector Node -> [NodeIx] -> m [Tree (Maybe Mesh, Node)]
unfoldNodesM Vector Mesh
allMeshes Vector Node
allNodes =
  (LookupError -> m [Tree (Maybe Mesh, Node)])
-> ([Tree (Maybe Mesh, Node)] -> m [Tree (Maybe Mesh, Node)])
-> Either LookupError [Tree (Maybe Mesh, Node)]
-> m [Tree (Maybe Mesh, Node)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LookupError -> m [Tree (Maybe Mesh, Node)]
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM [Tree (Maybe Mesh, Node)] -> m [Tree (Maybe Mesh, Node)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LookupError [Tree (Maybe Mesh, Node)]
 -> m [Tree (Maybe Mesh, Node)])
-> ([NodeIx] -> Either LookupError [Tree (Maybe Mesh, Node)])
-> [NodeIx]
-> m [Tree (Maybe Mesh, Node)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeIx -> Either LookupError (Tree (Maybe Mesh, Node)))
-> [NodeIx] -> Either LookupError [Tree (Maybe Mesh, Node)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Vector Mesh
-> Vector Node
-> NodeIx
-> Either LookupError (Tree (Maybe Mesh, Node))
inflateNode Vector Mesh
allMeshes Vector Node
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 :: Vector Mesh
-> Vector Node
-> NodeIx
-> Either LookupError (Tree (Maybe Mesh, Node))
inflateNode Vector Mesh
allMeshes Vector Node
allNodes NodeIx
startNode =
  Tree (Either LookupError Node)
-> (Either LookupError Node
    -> Either LookupError (Maybe Mesh, Node))
-> Either LookupError (Tree (Maybe Mesh, Node))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Vector Node -> NodeIx -> Tree (Either LookupError Node)
unfoldNode Vector Node
allNodes NodeIx
startNode) \Either LookupError Node
getNode -> do
    Node
node <- Either LookupError Node
getNode
    Maybe Mesh
mesh <- Vector Mesh -> Node -> Either LookupError (Maybe Mesh)
forall mesh. Vector mesh -> Node -> Either LookupError (Maybe mesh)
getMesh Vector Mesh
allMeshes Node
node
    pure (Maybe Mesh
mesh, Node
node)

unfoldNode
  :: Vector GlTF.Node
  -> GlTF.NodeIx
  -> Tree (Either LookupError GlTF.Node)
unfoldNode :: Vector Node -> NodeIx -> Tree (Either LookupError Node)
unfoldNode Vector Node
allNodes = (NodeIx -> (Either LookupError Node, [NodeIx]))
-> NodeIx -> Tree (Either LookupError Node)
forall b a. (b -> (a, [b])) -> b -> Tree a
Tree.unfoldTree NodeIx -> (Either LookupError Node, [NodeIx])
fetch
  where
    fetch :: NodeIx -> (Either LookupError Node, [NodeIx])
fetch (GlTF.NodeIx Int
ix) =
      case Vector Node
allNodes Vector Node -> Int -> Maybe Node
forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? Int
ix of
        Maybe Node
Nothing ->
          ( LookupError -> Either LookupError Node
forall a b. a -> Either a b
Left (LookupError -> Either LookupError Node)
-> LookupError -> Either LookupError Node
forall a b. (a -> b) -> a -> b
$ Int -> LookupError
NodeNotFound Int
ix
          , []
          )
        Just Node
node ->
          ( Node -> Either LookupError Node
forall a b. b -> Either a b
Right Node
node
          , [NodeIx]
-> (Vector NodeIx -> [NodeIx]) -> Maybe (Vector NodeIx) -> [NodeIx]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Vector NodeIx -> [NodeIx]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (Vector NodeIx) -> [NodeIx])
-> Maybe (Vector NodeIx) -> [NodeIx]
forall a b. (a -> b) -> a -> b
$ Node -> Maybe (Vector NodeIx)
Node.children Node
node
          )

getMesh
  :: Vector mesh
  -> GlTF.Node
  -> Either LookupError (Maybe mesh)
getMesh :: forall mesh. Vector mesh -> Node -> Either LookupError (Maybe mesh)
getMesh Vector mesh
allMeshes Node
node =
  case Node -> Maybe MeshIx
Node.mesh Node
node of
    Maybe MeshIx
Nothing ->
      Maybe mesh -> Either LookupError (Maybe mesh)
forall a b. b -> Either a b
Right Maybe mesh
forall a. Maybe a
Nothing
    Just (GlTF.MeshIx Int
ix) ->
      case Vector mesh
allMeshes Vector mesh -> Int -> Maybe mesh
forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? Int
ix of
        Maybe mesh
Nothing ->
          LookupError -> Either LookupError (Maybe mesh)
forall a b. a -> Either a b
Left (LookupError -> Either LookupError (Maybe mesh))
-> LookupError -> Either LookupError (Maybe mesh)
forall a b. (a -> b) -> a -> b
$ Int -> LookupError
MeshNotFound Int
ix
        Just mesh
mesh ->
          Maybe mesh -> Either LookupError (Maybe mesh)
forall a b. b -> Either a b
Right (mesh -> Maybe mesh
forall a. a -> Maybe a
Just mesh
mesh)

localTransform :: Node.Node -> Transform
localTransform :: Node -> Transform
localTransform Node
node = [Transform] -> Transform
forall a. Monoid a => [a] -> a
mconcat
  [ Transform
nodeMatrix
  , Transform
nodeScale, Transform
nodeRotate, Transform
nodeTranslate
  ]
  where
    nodeScale :: Transform
nodeScale = case Node -> Maybe (Float, Float, Float)
Node.scale Node
node of
      Maybe (Float, Float, Float)
Nothing ->
        Transform
forall a. Monoid a => a
mempty
      Just (Float
sx, Float
sy, Float
sz) ->
        Float -> Float -> Float -> Transform
Transform.scale3 Float
sx Float
sy Float
sz

    nodeTranslate :: Transform
nodeTranslate =
      case Node -> Maybe (Float, Float, Float)
Node.translation Node
node of
        Maybe (Float, Float, Float)
Nothing ->
          Transform
forall a. Monoid a => a
mempty
        Just (Float
tx, Float
ty, Float
tz) ->
          Float -> Float -> Float -> Transform
Transform.translate Float
tx Float
ty Float
tz

    nodeRotate :: Transform
nodeRotate = case Node -> Maybe (Float, Float, Float, Float)
Node.rotation Node
node of
      Maybe (Float, Float, Float, Float)
Nothing ->
        Transform
forall a. Monoid a => a
mempty
      Just (Float
qx, Float
qy, Float
qz, Float
qW) ->
        Quaternion -> Transform
Transform.rotateQ (Quaternion -> Transform) -> Quaternion -> Transform
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Float -> Quaternion
quaternion Float
qW Float
qx Float
qy Float
qz

    nodeMatrix :: Transform
nodeMatrix = case Node -> Maybe NodeMatrix
Node.matrix Node
node of
      Maybe NodeMatrix
Nothing ->
        Transform
forall a. Monoid a => a
mempty
      Just (Node.NodeMatrix Vector Float
memoryBytes) ->
        case Vector Float -> [Float]
forall (v :: * -> *) a. Vector v a => v a -> [a]
Vector.toList Vector Float
memoryBytes of
          [ Float
x1, Float
x2, Float
x3, Float
x4,
            Float
y1, Float
y2, Float
y3, Float
y4,
            Float
z1, Float
z2, Float
z3, Float
z4,
            Float
w1, Float
w2, Float
w3, Float
w4 ] ->
              forall a.
Coercible Mat4 a =>
Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> a
Mat4.colMajor @Transform
                Float
x1 Float
y1 Float
z1 Float
w1
                Float
x2 Float
y2 Float
z2 Float
w2
                Float
x3 Float
y3 Float
z3 Float
w3
                Float
x4 Float
y4 Float
z4 Float
w4
          [Float]
_ ->
            String -> Transform
forall a. HasCallStack => String -> a
error String
"Node matrix isn't 16-element"

nullifyTranslation :: Mat4.Mat4
nullifyTranslation :: Mat4
nullifyTranslation =
  Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Mat4
forall a.
Coercible Mat4 a =>
Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> a
Mat4.rowMajor
    Float
1 Float
1 Float
1 Float
0
    Float
1 Float
1 Float
1 Float
0
    Float
1 Float
1 Float
1 Float
0
    Float
0 Float
0 Float
0 Float
1

data SceneNode = SceneNode
  { SceneNode -> Packed
snOrigin     :: ~Vec3.Packed
  , SceneNode -> Maybe Mesh
snPrimitives :: Maybe (Vector MeshPrimitive)
  , SceneNode -> Node
snNode       :: GlTF.Node
  }
  deriving (Int -> SceneNode -> ShowS
[SceneNode] -> ShowS
SceneNode -> String
(Int -> SceneNode -> ShowS)
-> (SceneNode -> String)
-> ([SceneNode] -> ShowS)
-> Show SceneNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SceneNode -> ShowS
showsPrec :: Int -> SceneNode -> ShowS
$cshow :: SceneNode -> String
show :: SceneNode -> String
$cshowList :: [SceneNode] -> ShowS
showList :: [SceneNode] -> ShowS
Show)