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 :: String -> IO (Either String (ByteString, GlTF))
loadGlb String
sceneFile =
  String -> IO (Either String (Vector Chunk))
loadGlbChunks String
sceneFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right Vector Chunk
chunks ->
      case forall (v :: * -> *) a. Vector v a => v a -> [a]
Vector.toList Vector Chunk
chunks of
        [] ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"No chunks in GLB file " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
sceneFile
        [Chunk
_root] ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"No data chunk in GLB file " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
sceneFile
        Chunk
gltf : Chunk
buffer : [Chunk]
_rest ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Chunk -> ByteString
GLB.chunkData Chunk
buffer,) forall a b. (a -> b) -> a -> b
$
              Chunk -> Either String GlTF
GlTF.fromChunk Chunk
gltf
    Left String
err ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
err

loadGlbChunks :: FilePath -> IO (Either String (Vector GLB.Chunk))
loadGlbChunks :: String -> IO (Either String (Vector Chunk))
loadGlbChunks String
sceneFile =
  forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (String -> m b) -> String -> m b
Zstd.fromFileWith (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either (ByteOffset, String) GLB
GLB.fromByteString) String -> IO (Either (ByteOffset, String) GLB)
GLB.fromFile String
sceneFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right GLB
glb ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (GLB -> Vector Chunk
GLB.chunks GLB
glb)
    Left (ByteOffset
_offset, String
err) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
err

loadGltf :: FilePath -> IO (Either String Root.GlTF)
loadGltf :: String -> IO (Either String GlTF)
loadGltf =
  forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (String -> m b) -> String -> m b
Zstd.fromFileWith (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String GlTF
GlTF.fromByteString) String -> IO (Either String GlTF)
GlTF.fromFile

loadUri :: FilePath -> FilePath -> IO (Either a ByteString)
loadUri :: forall a. String -> String -> IO (Either a ByteString)
loadUri String
sceneFile String
uri =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (String -> m b) -> String -> m b
Zstd.fromFileWith forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). MonadIO m => String -> m ByteString
ByteString.readFile forall a b. (a -> b) -> a -> b
$
    String -> String
takeDirectory String
sceneFile String -> String -> String
</> String
uri

-- XXX: OTOH, it may be better to unfold scene first 🤔
loadMeshPrimitives
  :: ( MonadReader env m
     , HasLogFunc env
     , MonadThrow m
     , MonadUnliftIO m
     )
  => Bool
  -> Bool
  -> FilePath
  -> m
    ( Root.GlTF
    , Vector (Vector MeshPrimitive)
    )
loadMeshPrimitives :: forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, MonadThrow m,
 MonadUnliftIO m) =>
Bool -> Bool -> String -> m (GlTF, Vector (Vector MeshPrimitive))
loadMeshPrimitives Bool
reverseIndices Bool
addBacksides String
fp = do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading scene from " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
fp

  (Maybe ByteString
glbData, GlTF
root) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    if String -> String
takeExtensions String
fp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".glb", String
".glb.zst"] then
      String -> IO (Either String (ByteString, GlTF))
loadGlb String
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
err ->
          forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"GLB load error: " forall a. Semigroup a => a -> a -> a
<> String
err
        Right (ByteString
buffer, GlTF
root) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ByteString
buffer, GlTF
root)
    else
      String -> IO (Either String GlTF)
loadGltf String
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
err ->
          forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"glTF load error: " forall a. Semigroup a => a -> a -> a
<> String
err
        Right GlTF
root ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, GlTF
root)

  Vector ByteString
buffers <- case GlTF -> Maybe (Vector Buffer)
Root.buffers GlTF
root of
    Maybe (Vector Buffer)
Nothing ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
    Just Vector Buffer
buffers ->
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Vector Buffer
buffers \case
        Buffer.Buffer{$sel:uri:Buffer :: Buffer -> Maybe URI
uri=Maybe URI
Nothing} ->
          case Maybe ByteString
glbData of
            Maybe ByteString
Nothing ->
              forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"Empty buffer URI in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
fp -- XXX: not loading GLB, are we?
            Just ByteString
bs ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
        Buffer.Buffer{$sel:uri:Buffer :: Buffer -> Maybe URI
uri=Just URI
path} ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HasCallStack =>
(String -> IO (Either String ByteString))
-> URI -> IO (Either String ByteString)
URI.loadURI (forall a. String -> String -> IO (Either a ByteString)
loadUri String
fp) URI
path) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left String
err ->
              forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"Buffer load failed for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show URI
path forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
err
            Right ByteString
bs ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
  let
    getBuffer :: BufferIx -> m ByteString
getBuffer BufferIx
bix =
      case Vector ByteString
buffers forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? BufferIx -> Int
Buffer.unBufferIx BufferIx
bix of
        Maybe ByteString
Nothing ->
          forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show BufferIx
bix forall a. Semigroup a => a -> a -> a
<> String
" not present in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
fp
        Just ByteString
buffer ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
buffer

  AccessorIx -> m Accessor
getAccessor <- case GlTF -> Maybe (Vector Accessor)
Root.accessors GlTF
root of
    Maybe (Vector Accessor)
Nothing ->
      forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"No accessors in " forall a. Semigroup a => a -> a -> a
<> String
fp
    Just Vector Accessor
accessors ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure \AccessorIx
aix ->
        case Vector Accessor
accessors forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? AccessorIx -> Int
Accessor.unAccessorIx AccessorIx
aix of
          Maybe Accessor
Nothing ->
            forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show AccessorIx
aix forall a. Semigroup a => a -> a -> a
<> String
" not present in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
fp
          Just Accessor
accessor ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Accessor
accessor

  BufferViewIx -> m BufferView
getBufferView <- case GlTF -> Maybe (Vector BufferView)
Root.bufferViews GlTF
root of
    Maybe (Vector BufferView)
Nothing ->
      forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"No buffer views in " forall a. Semigroup a => a -> a -> a
<> String
fp
    Just Vector BufferView
bufferViews ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure \BufferViewIx
bvix ->
        case Vector BufferView
bufferViews forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? BufferViewIx -> Int
BufferView.unBufferViewIx BufferViewIx
bvix of
          Maybe BufferView
Nothing ->
            forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show BufferViewIx
bvix forall a. Semigroup a => a -> a -> a
<> String
" not present in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
fp
          Just BufferView
bufferView ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure BufferView
bufferView

  let materials :: Vector Material
materials = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ GlTF -> Maybe (Vector Material)
Root.materials GlTF
root

  Vector (Vector MeshPrimitive)
meshPrimitives <- case GlTF -> Maybe (Vector Mesh)
Root.meshes GlTF
root of
    Maybe (Vector Mesh)
Nothing ->
      forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"No meshes in " forall a. Semigroup a => a -> a -> a
<> String
fp
    Just Vector Mesh
meshes ->
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (v :: * -> *) a b.
(Vector v a, Vector v b, Vector v (a, b)) =>
v a -> v b -> v (a, b)
Vector.zip (forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [Int
0 :: Int ..]) Vector Mesh
meshes) \(Int
_meshIx, Mesh
mesh) -> do
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (v :: * -> *) a b.
(Vector v a, Vector v b, Vector v (a, b)) =>
v a -> v b -> v (a, b)
Vector.zip (forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [Int
0 :: Int ..]) (Mesh -> Vector MeshPrimitive
Mesh.primitives Mesh
mesh)) \(Int
_primIx, MeshPrimitive
prim) -> do
          -- traceShowM
          --   ( "mesh"
          --   , _meshIx, Mesh.name mesh
          --   , "primitive"
          --   , _primIx
          --   )
          case MeshPrimitive -> MeshPrimitiveMode
Mesh.mode MeshPrimitive
prim of
            MeshPrimitiveMode
Mesh.TRIANGLES ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            MeshPrimitiveMode
mode ->
              forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"Can't load anything but TRIANGLES, got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show MeshPrimitiveMode
mode

          [Word32]
indicesCCW <- case MeshPrimitive -> Maybe AccessorIx
Mesh.indices MeshPrimitive
prim of
            Maybe AccessorIx
Nothing ->
              forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No indices for mesh primitive"
            Just AccessorIx
aix -> do
              -- accessBuffer @Word16 getAccessor getBufferView getBuffer Accessor.SCALAR Accessor.UNSIGNED_SHORT aix
              Either [Word16] [Word32]
indices <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Word32 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.SCALAR ComponentType
Accessor.UNSIGNED_INT AccessorIx
aix)
                (\UnexpectedComponentType{} ->
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Word16 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.SCALAR ComponentType
Accessor.UNSIGNED_SHORT AccessorIx
aix
                )
              case Either [Word16] [Word32]
indices of
                Right [Word32]
word32s ->
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure [Word32]
word32s
                Left [Word16]
word16s ->
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word16]
word16s

          (Maybe (Int, Material)
material, [Word32]
indices) <- case MeshPrimitive -> Maybe MaterialIx
Mesh.material MeshPrimitive
prim of
            Maybe MaterialIx
Nothing ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, [Word32]
indicesCCW)
            Just (Material.MaterialIx Int
mix) ->
              case Vector Material
materials forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? Int
mix of
                Maybe Material
Nothing ->
                  forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No material for index"
                Just mat :: Material
mat@Material.Material{Bool
$sel:doubleSided:Material :: Material -> Bool
doubleSided :: Bool
doubleSided} -> do
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    ( forall a. a -> Maybe a
Just (Int
mix, Material
mat)
                    , if Bool
doubleSided Bool -> Bool -> Bool
&& Bool
addBacksides then
                        [Word32]
indicesCCW forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [a]
reverse [Word32]
indicesCCW
                      else
                        if Bool
reverseIndices then
                          forall a. [a] -> [a]
reverse [Word32]
indicesCCW
                        else
                          [Word32]
indicesCCW
                    )

          -- for (HashMap.toList $ Mesh.attributes prim) \(attr, aix) ->
          --   traceShowM (attr, aix)

          -- let attrKeys = HashMap.keys $ Mesh.attributes prim
          -- logDebug $ "Mesh attributes: " <> displayShow attrKeys

          [Packed]
positions <- case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"POSITION" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Maybe AccessorIx
Nothing ->
              -- XXX: huh?
              forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"Mesh primitive without POSITION attribute"
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec3.Packed AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC3 ComponentType
Accessor.FLOAT AccessorIx
aix
          -- logDebug $ "POSITION (" <> display (length positions) <> ") " <> displayShow (take 10 $ fmap Vec3.unPacked positions)

          -- traceShowM
          --   ( ( meshIx
          --     , primIx
          --     )
          --   , length positions
          --   , ( length indices
          --     , minimum indices
          --     , maximum indices
          --     )
          --   )

          [Packed]
normals <- case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"NORMAL" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Maybe AccessorIx
Nothing -> do
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Mesh primitive without NORMAL attribute"
              pure $ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Packed]
positions) forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
List.repeat (Vec3 -> Packed
Vec3.Packed Vec3
0)
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec3.Packed AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC3 ComponentType
Accessor.FLOAT AccessorIx
aix
          -- logDebug $ "NORMAL (" <> display (length normals) <> ") " <> displayShow (take 10 normals)

          [Vec2]
texCoords0 <- case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"TEXCOORD_0" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Maybe AccessorIx
Nothing -> do
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Mesh primitive without TEXCOORD_0 attribute"
              pure $ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Packed]
positions) forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
List.repeat Vec2
0
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec2 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC2 ComponentType
Accessor.FLOAT AccessorIx
aix
          -- logDebug $ "TEXCOORD_0 (" <> display (length texCoords0) <> ") " <> displayShow (take 10 texCoords0)

          [Vec4]
tangents <- case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"TANGENT" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec4 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC4 ComponentType
Accessor.FLOAT AccessorIx
aix
            Maybe AccessorIx
Nothing -> do
              -- logDebug "Mesh primitive without TANGENT attribute"
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Packed]
positions) forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
List.repeat Vec4
0
          -- logDebug $ "TANGENT (" <> display (length tangents) <> ") " <> displayShow (take 10 tangents)

          let
            attrs :: [VertexAttrs]
attrs = do
              (Vec2
tc0, Packed
norm, Vec4
tangent') <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
List.zip3 [Vec2]
texCoords0 [Packed]
normals [Vec4]
tangents
              let
                tangent :: Packed
tangent =
                  forall r. Vec4 -> (Float -> Float -> Float -> Float -> r) -> r
withVec4 Vec4
tangent' \Float
tx Float
ty Float
tz Float
_handedness ->
                    Vec3 -> Packed
Vec3.Packed forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Vec3
vec3 Float
tx Float
ty Float
tz
              forall (f :: * -> *) a. Applicative f => a -> f a
pure VertexAttrs
                { $sel:vaTexCoord:VertexAttrs :: Vec2
vaTexCoord = Vec2
tc0
                , $sel:vaNormal:VertexAttrs :: Packed
vaNormal   = Packed
norm
                , $sel:vaTangent:VertexAttrs :: Packed
vaTangent  = Packed
tangent
                }
          pure
            ( Maybe (Int, Material)
material
            , Stuff
                { $sel:sPositions:Stuff :: Vector Packed
sPositions = forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [Packed]
positions
                , $sel:sAttrs:Stuff :: Vector VertexAttrs
sAttrs     = forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [VertexAttrs]
attrs
                , $sel:sIndices:Stuff :: Vector Word32
sIndices   = forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [Word32]
indices
                }
            )

  pure (GlTF
root, Vector (Vector MeshPrimitive)
meshPrimitives)

accessBuffer
  :: forall a m
  .  ( MonadThrow m
     , MonadIO m
     , Storable a
     )
  => (Accessor.AccessorIx -> m Accessor.Accessor)
  -> (BufferView.BufferViewIx -> m BufferView.BufferView)
  -> (Buffer.BufferIx -> m ByteString)
  -> Accessor.AttributeType
  -> Accessor.ComponentType
  -> Accessor.AccessorIx
  -> m [a]
accessBuffer :: forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
expectAttribute ComponentType
expectComponent AccessorIx
aix = do
  Accessor.Accessor{Maybe BufferViewIx
$sel:bufferView:Accessor :: Accessor -> Maybe BufferViewIx
bufferView :: Maybe BufferViewIx
bufferView, $sel:byteOffset:Accessor :: Accessor -> Int
byteOffset=Int
accOffset, ComponentType
$sel:componentType:Accessor :: Accessor -> ComponentType
componentType :: ComponentType
componentType, Int
$sel:count:Accessor :: Accessor -> Int
count :: Int
count, AttributeType
$sel:type':Accessor :: Accessor -> AttributeType
type' :: AttributeType
type'} <- AccessorIx -> m Accessor
getAccessor AccessorIx
aix

  bv :: BufferView
bv@BufferView.BufferView{$sel:byteOffset:BufferView :: BufferView -> Int
byteOffset=Int
bufOffset, Int
$sel:byteLength:BufferView :: BufferView -> Int
byteLength :: Int
byteLength} <- case Maybe BufferViewIx
bufferView of
    Maybe BufferViewIx
Nothing ->
      forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"No bufferView for index accessor " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show AccessorIx
aix
    Just BufferViewIx
bvix ->
      BufferViewIx -> m BufferView
getBufferView BufferViewIx
bvix

  ByteString
buffer <- BufferIx -> m ByteString
getBuffer (BufferView -> BufferIx
BufferView.buffer BufferView
bv)

  forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected (AccessorIx
-> AttributeType -> AttributeType -> UnexpectedAttributeType
UnexpectedAttributeType AccessorIx
aix) AttributeType
expectAttribute AttributeType
type'
  forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected (AccessorIx
-> ComponentType -> ComponentType -> UnexpectedComponentType
UnexpectedComponentType AccessorIx
aix) ComponentType
expectComponent ComponentType
componentType
  let strideSize :: Int
strideSize = forall a. Storable a => a -> Int
Foreign.sizeOf (forall a. HasCallStack => String -> a
error String
"strideSize.sizeOf" :: a)
  case BufferView -> Maybe Int
BufferView.byteStride BufferView
bv of
    Maybe Int
Nothing ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Int
stride
      | Int
stride forall a. Eq a => a -> a -> Bool
== Int
strideSize ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Int
stride ->
      forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected (AccessorIx -> Int -> Int -> UnexpectedBufferViewStride
UnexpectedBufferViewStride AccessorIx
aix) Int
strideSize Int
stride

  let bytes :: ByteString
bytes = Int -> ByteString -> ByteString
ByteString.take Int
byteLength forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
ByteString.drop (Int
accOffset forall a. Num a => a -> a -> a
+ Int
bufOffset) ByteString
buffer
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.unsafeUseAsCString ByteString
bytes forall a b. (a -> b) -> a -> b
$
    forall a. Storable a => Int -> Ptr a -> IO [a]
Foreign.peekArray Int
count forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
Foreign.castPtr

unexpected
  :: (Eq e, Exception exception, MonadThrow m)
  => (e -> e -> exception)
  -> e
  -> e
  -> m ()
unexpected :: forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected e -> e -> exception
cons e
expected e
got =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (e
expected forall a. Eq a => a -> a -> Bool
== e
got) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ e -> e -> exception
cons e
expected e
got

data UnexpectedAttributeType = UnexpectedAttributeType
  { UnexpectedAttributeType -> AccessorIx
uatAccessor :: Accessor.AccessorIx
  , UnexpectedAttributeType -> AttributeType
uatExpected :: Accessor.AttributeType
  , UnexpectedAttributeType -> AttributeType
uatGot      :: Accessor.AttributeType
  }
  deriving (UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c/= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
== :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c== :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
Eq, Eq UnexpectedAttributeType
UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
UnexpectedAttributeType -> UnexpectedAttributeType -> Ordering
UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
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
min :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
$cmin :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
max :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
$cmax :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
>= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c>= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
> :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c> :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
<= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c<= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
< :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c< :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
compare :: UnexpectedAttributeType -> UnexpectedAttributeType -> Ordering
$ccompare :: UnexpectedAttributeType -> UnexpectedAttributeType -> Ordering
Ord, Int -> UnexpectedAttributeType -> String -> String
[UnexpectedAttributeType] -> String -> String
UnexpectedAttributeType -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UnexpectedAttributeType] -> String -> String
$cshowList :: [UnexpectedAttributeType] -> String -> String
show :: UnexpectedAttributeType -> String
$cshow :: UnexpectedAttributeType -> String
showsPrec :: Int -> UnexpectedAttributeType -> String -> String
$cshowsPrec :: Int -> UnexpectedAttributeType -> String -> String
Show)

instance Exception UnexpectedAttributeType

data UnexpectedComponentType = UnexpectedComponentType
  { UnexpectedComponentType -> AccessorIx
uctAccessor :: Accessor.AccessorIx
  , UnexpectedComponentType -> ComponentType
uctExpected :: Accessor.ComponentType
  , UnexpectedComponentType -> ComponentType
uctGot      :: Accessor.ComponentType
  }
  deriving (UnexpectedComponentType -> UnexpectedComponentType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c/= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
== :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c== :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
Eq, Eq UnexpectedComponentType
UnexpectedComponentType -> UnexpectedComponentType -> Bool
UnexpectedComponentType -> UnexpectedComponentType -> Ordering
UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
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
min :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
$cmin :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
max :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
$cmax :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
>= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c>= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
> :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c> :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
<= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c<= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
< :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c< :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
compare :: UnexpectedComponentType -> UnexpectedComponentType -> Ordering
$ccompare :: UnexpectedComponentType -> UnexpectedComponentType -> Ordering
Ord, Int -> UnexpectedComponentType -> String -> String
[UnexpectedComponentType] -> String -> String
UnexpectedComponentType -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UnexpectedComponentType] -> String -> String
$cshowList :: [UnexpectedComponentType] -> String -> String
show :: UnexpectedComponentType -> String
$cshow :: UnexpectedComponentType -> String
showsPrec :: Int -> UnexpectedComponentType -> String -> String
$cshowsPrec :: Int -> UnexpectedComponentType -> String -> String
Show)

instance Exception UnexpectedComponentType

data UnexpectedBufferViewStride = UnexpectedBufferViewStride
  { UnexpectedBufferViewStride -> AccessorIx
ubvsAccessor :: Accessor.AccessorIx
  , UnexpectedBufferViewStride -> Int
ubvsExpected :: Int
  , UnexpectedBufferViewStride -> Int
ubvsGot      :: Int
  }
  deriving (UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c/= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
== :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c== :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
Eq, Eq UnexpectedBufferViewStride
UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> Ordering
UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
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
min :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
$cmin :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
max :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
$cmax :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
>= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c>= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
> :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c> :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
<= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c<= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
< :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c< :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
compare :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> Ordering
$ccompare :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> Ordering
Ord, Int -> UnexpectedBufferViewStride -> String -> String
[UnexpectedBufferViewStride] -> String -> String
UnexpectedBufferViewStride -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UnexpectedBufferViewStride] -> String -> String
$cshowList :: [UnexpectedBufferViewStride] -> String -> String
show :: UnexpectedBufferViewStride -> String
$cshow :: UnexpectedBufferViewStride -> String
showsPrec :: Int -> UnexpectedBufferViewStride -> String -> String
$cshowsPrec :: Int -> UnexpectedBufferViewStride -> String -> String
Show)

instance Exception UnexpectedBufferViewStride