refactor: Allow vertex indices of any unsigned int type

gltf-loader.cabal

@@ -64,6 +64,7 @@ common shared
         ScopedTypeVariables
         StandaloneDeriving
         TupleSections
+        TypeApplications
         TypeFamilies
         TypeSynonymInstances
         ViewPatterns

src/Text/GLTF/Loader/Gltf.hs

@@ -188,7 +188,7 @@ data Texture = Texture
 -- | Geometry to be rendered with the given material
 data MeshPrimitive = MeshPrimitive
   { -- | A Vector of vertex indices.
-    meshPrimitiveIndices :: Vector Word16,
+    meshPrimitiveIndices :: Vector Word32,
     -- | The index of the material to apply to this primitive when rendering.
     meshPrimitiveMaterial :: Maybe Int,
     -- | The topology type of primitives to render.
@@ -241,7 +241,7 @@ data MinFilter
   | MinLinearMipmapLinear
   deriving (Enum, Eq, Show)
 
--- | Sampler wrapping mode.  
+-- | Sampler wrapping mode.
 data SamplerWrap
   = ClampToEdge
   | MirroredRepeat
@@ -460,7 +460,7 @@ _textureSourceId = lens
   (\tex source -> tex { textureSourceId = source })
 
 -- | A Vector of vertex indices.
-_meshPrimitiveIndices :: Lens' MeshPrimitive (Vector Word16)
+_meshPrimitiveIndices :: Lens' MeshPrimitive (Vector Word32)
 _meshPrimitiveIndices = lens
   meshPrimitiveIndices
   (\primitive' indices -> primitive' { meshPrimitiveIndices = indices })

src/Text/GLTF/Loader/Internal/BufferAccessor.hs

@@ -24,6 +24,7 @@ import Codec.GlTF.URI
 import Codec.GlTF
 import Data.Binary.Get
 import Data.ByteString.Lazy (fromStrict)
+import Data.Proxy (asProxyTypeOf)
 import Foreign.Storable
 import Linear
 import RIO hiding (min, max)
@@ -44,7 +45,8 @@ data GltfImageData
 
 -- | A buffer and some metadata
 data BufferAccessor = BufferAccessor
-  { offset :: Int,
+  { componentType :: ComponentType,
+    offset :: Int,
     count :: Int,
     buffer :: GltfBuffer
   }
@@ -59,13 +61,13 @@ loadBuffers
 loadBuffers GlTF{buffers=buffers} chunk basePath = do
   let buffers' = fromMaybe [] buffers
       iforM = flip Vector.imapM
-  
+
   iforM buffers' $ \idx Buffer{..} -> do
     -- If the first buffer does not have a URI defined, it refers to a GLB chunk
     let fallback = if idx == 0 && isNothing uri
           then maybe mempty chunkData chunk
           else mempty
-    
+
     uri' <- maybe (pure fallback) (loadUri' basePath) uri
     return $ GltfBuffer uri'
 
@@ -82,8 +84,18 @@ loadImages GlTF{images=images} basePath = do
     maybe fallbackImageData (fmap ImageData . loadUri' basePath) uri
 
 -- | Decode vertex indices
-vertexIndices :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector Word16
-vertexIndices = readBufferWithGet getIndices
+vertexIndices :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector Word32
+vertexIndices gltf buffers' accessorId =
+  fromMaybe mempty $ do
+    buffer@BufferAccessor{componentType=componentType} <-
+      bufferAccessor gltf buffers' accessorId
+
+    case componentType of
+      UNSIGNED_SHORT ->
+        Just (fromIntegral <$> readFromBuffer (Proxy @Word16) getIndices buffer)
+      UNSIGNED_INT ->
+        Just (readFromBuffer (Proxy @Word32) getIndices32 buffer)
+      _ -> Nothing
 
 -- | Decode vertex positions
 vertexPositions :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V3 Float)
@@ -155,11 +167,12 @@ bufferAccessor GlTF{..} buffers' accessorId = do
   bufferView <- lookupBufferViewFromAccessor accessor =<< bufferViews
   buffer <- lookupBufferFromBufferView bufferView buffers'
 
-  let Accessor{byteOffset=offset, count=count} = accessor
+  let Accessor{byteOffset=offset, count=count, componentType=compTy} = accessor
       BufferView{byteOffset=offset'} = bufferView
 
   return $ BufferAccessor
-    { offset = offset + offset',
+    { componentType = compTy,
+      offset = offset + offset',
       count = count,
       buffer = buffer
     }
@@ -177,7 +190,8 @@ bufferViewAccessor GlTF{..} buffers' bufferViewId = do
   let BufferView{byteLength=length', byteOffset=offset'} = bufferView
 
   return $ BufferAccessor
-    { offset = offset',
+    { componentType = BYTE, -- There's no accessor, assume byte
+      offset = offset',
       count = length',
       buffer = buffer
     }
@@ -206,14 +220,14 @@ lookupBuffer (BufferIx bufferId) = (Vector.!? bufferId)
 -- | Decode a buffer using the given Binary decoder
 readFromBuffer
   :: Storable storable
-  => storable
+  => Proxy storable
   -> Get (Vector storable)
   -> BufferAccessor
   -> Vector storable
-readFromBuffer storable getter accessor@BufferAccessor{..}
+readFromBuffer proxy getter accessor@BufferAccessor{..}
   = runGet getter . fromStrict $ payload
   where payload = readFromBufferRaw accessor len'
-        len' = count * sizeOf storable
+        len' = count * sizeOf (asProxyTypeOf undefined proxy)
 
 -- | Read from buffer without decoding
 readFromBufferRaw :: BufferAccessor -> Int -> ByteString

src/Text/GLTF/Loader/Internal/Decoders.hs

@@ -1,6 +1,7 @@
 module Text.GLTF.Loader.Internal.Decoders
   ( -- * GLTF Property-specific Type decoders
     getIndices,
+    getIndices32,
     getPositions,
     getNormals,
     getTexCoords,
@@ -22,15 +23,20 @@ module Text.GLTF.Loader.Internal.Decoders
     getFloat
   ) where
 
+import qualified Codec.GlTF.Accessor as GlTF
 import Data.Binary.Get
 import Linear
 import RIO hiding (min, max)
 import qualified RIO.Vector as Vector
 
--- | Vertex indices binary decoder
+-- | Vertex indices binary decoder, for unsigned short
 getIndices :: Get (Vector Word16)
 getIndices = getScalar getUnsignedShort
 
+-- | Vertex indices binary decoder, for unsigned int
+getIndices32 :: Get (Vector Word32)
+getIndices32 = getScalar getUnsignedInt
+
 -- | Vertex positions binary decoder
 getPositions :: Get (Vector (V3 Float))
 getPositions = getVec3 getFloat
@@ -82,7 +88,7 @@ getMat3 getter = getVector $ do
   m1_1 <- getter
   m1_2 <- getter
   m1_3 <- getter
-  
+
   m2_1 <- getter
   m2_2 <- getter
   m2_3 <- getter
@@ -103,7 +109,7 @@ getMat4 getter = getVector $ do
   m1_2 <- getter
   m1_3 <- getter
   m1_4 <- getter
-  
+
   m2_1 <- getter
   m2_2 <- getter
   m2_3 <- getter

test/Text/GLTF/Loader/Internal/BufferAccessorSpec.hs

@@ -23,14 +23,14 @@ spec :: Spec
 spec = do
   let gltf = mkCodecGltf
       basePath = "."
-  
+
   describe "loadBuffers" $ do
     it "Reads buffers from GlTF" $ do
       buffers <- loadBuffers gltf Nothing basePath
-      
+
       let (GltfBuffer buffer') = buffers ! 0
           values = runGet (getScalar (fromIntegral <$> getUnsignedShort)) . fromStrict $ buffer'
-      
+
       values `shouldBe` ([1..4] :: Vector Integer)
 
     it "Handles malformed URI" $ do
@@ -49,29 +49,29 @@ spec = do
 
     it "Handles a chunk buffer" $ do
       let chunk = mkCodecBufferChunk
-      
+
           gltf' = gltf
             { GlTF.buffers = Just
               [ mkCodecBufferIndices { Buffer.uri = Nothing } ]
             }
       buffers <- loadBuffers gltf' (Just chunk) basePath
-      
+
       let (GltfBuffer buffer') = buffers ! 0
           values = runGet (getScalar (fromIntegral <$> getUnsignedShort)) . fromStrict $ buffer'
-      
+
       values `shouldBe` ([1..4] :: Vector Integer)
-      
+
     it "Handles chunk + buffers" $ do
       let chunk = mkCodecBufferChunk
-      
+
           gltf' = gltf
             { GlTF.buffers = Just
               [ mkCodecBufferIndices { Buffer.uri = Nothing },
                 mkCodecBufferIndices
               ]
             }
       buffers <- loadBuffers gltf' (Just chunk) basePath
-      
+
       let getValue = runGet (getScalar (fromIntegral <$> getUnsignedShort)) . fromStrict
 
       forM_ buffers $ \buffer -> do
@@ -88,7 +88,7 @@ spec = do
             { GlTF.images = Just
                 [ mkCodecImage { Image.uri = Nothing } ]
             }
-      
+
       images <- loadImages gltf' basePath
       images `shouldBe` [ImageBufferView (BufferView.BufferViewIx 5)]
 
@@ -101,7 +101,7 @@ spec = do
                     }
                 ]
             }
-      
+
       images <- loadImages gltf' basePath
       images `shouldBe` [NoImageData]
 
@@ -112,13 +112,28 @@ spec = do
             }
 
       loadImages gltf' basePath `shouldThrow` anyException
-  
+
   describe "vertexIndices" $ do
     it "Reads basic values from buffer" $ do
       vertexIndices gltf buffers' accessorIdIndices `shouldBe` [1, 2, 3, 4]
 
+    it "Reads unsigned int values from buffer" $ do
+      let gltf' = gltf
+            { GlTF.accessors =
+                Just
+                  [ mkCodecAccessorIndices32,
+                    mkCodecAccessorPositions,
+                    mkCodecAccessorNormals,
+                    mkCodecAccessorTexCoords,
+                    mkCodecAccessorColors
+                  ]
+            }
+          buffers' = [ bufferIndices32, bufferPositions]
+
+      vertexIndices gltf' buffers' accessorIdIndices32 `shouldBe` [1, 2, 3, 4]
+
     it "Returns empty when accessor not defined" $ do
-      let gltf' = gltf { GlTF.accessors = Nothing } 
+      let gltf' = gltf { GlTF.accessors = Nothing }
       vertexIndices gltf' buffers' accessorIdIndices `shouldBe` []
 
     it "Returns empty when buffer not found" $ do
@@ -136,7 +151,7 @@ spec = do
         ]
 
     it "Returns empty when accessor not defined" $ do
-      let gltf' = gltf { GlTF.accessors = Nothing } 
+      let gltf' = gltf { GlTF.accessors = Nothing }
       vertexPositions gltf' buffers' accessorIdPositions `shouldBe` []
 
     it "Returns empty when buffer not found" $ do
@@ -145,18 +160,25 @@ spec = do
       vertexPositions gltf' buffers' accessorIdPositions `shouldBe` []
 
 buffers' :: Vector GltfBuffer
-buffers' = [bufferIndices, bufferPositions]
+buffers' = [bufferIndices, bufferPositions, bufferIndices32]
 
 accessorIdIndices :: Accessor.AccessorIx
 accessorIdIndices = Accessor.AccessorIx 0
 
+accessorIdIndices32 :: Accessor.AccessorIx
+accessorIdIndices32 = Accessor.AccessorIx 0
+
 accessorIdPositions :: Accessor.AccessorIx
 accessorIdPositions = Accessor.AccessorIx 1
 
 bufferIndices :: GltfBuffer
 bufferIndices = GltfBuffer . toStrict . toLazyByteString $ putIndices
   where putIndices = foldr ((<>) . putWord16le) empty ([1, 2, 3, 4] :: [Word16])
 
+bufferIndices32 :: GltfBuffer
+bufferIndices32 = GltfBuffer . toStrict . toLazyByteString $ putIndices
+  where putIndices = foldr ((<>) . putWord32le) empty ([1, 2, 3, 4] :: [Word32])
+
 bufferPositions :: GltfBuffer
 bufferPositions = GltfBuffer . toStrict . runPut $ putPositions
   where putPositions = mapM_ (replicateM_ 3 . putFloatle) ([1..4] :: [Float])

test/Text/GLTF/Loader/Test/MkGltf.hs

@@ -96,6 +96,22 @@ mkCodecAccessorIndices = Accessor.Accessor
     type' = Accessor.AttributeType "SCALAR"
   }
 
+mkCodecAccessorIndices32 :: Accessor.Accessor
+mkCodecAccessorIndices32 = Accessor.Accessor
+  { bufferView = Just $ BufferView.BufferViewIx 0,
+    byteOffset = 0,
+    componentType = Accessor.UNSIGNED_INT,
+    count = 4,
+    extensions = Nothing,
+    extras = Nothing,
+    max = Nothing,
+    min = Nothing,
+    name = Just "Accessor Indices",
+    normalized = False,
+    sparse = Nothing,
+    type' = Accessor.AttributeType "SCALAR"
+  }
+
 mkCodecAccessorNormals :: Accessor.Accessor
 mkCodecAccessorNormals = Accessor.Accessor
   {