module Text.GLTF.Loader.BufferAccessor
  ( GltfBuffer(..),
    -- * Loading GLTF buffers
    loadBuffers,
    -- * Deserializing Accessors
    vertexIndices,
    vertexPositions,
    vertexNormals,
    vertexTexCoords,
  ) where

import Text.GLTF.Loader.Decoders

import Codec.GlTF.Accessor
import Codec.GlTF.Buffer
import Codec.GlTF.BufferView
import Codec.GlTF.URI
import Codec.GlTF
import Data.Binary.Get
import Data.ByteString.Lazy (fromStrict)
import Foreign.Storable
import Linear
import RIO hiding (min, max)
import qualified RIO.Vector as Vector
import qualified RIO.ByteString as ByteString

-- | Holds the entire payload of a glTF buffer
newtype GltfBuffer = GltfBuffer { GltfBuffer -> ByteString
unBuffer :: ByteString }
  deriving (GltfBuffer -> GltfBuffer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GltfBuffer -> GltfBuffer -> Bool
$c/= :: GltfBuffer -> GltfBuffer -> Bool
== :: GltfBuffer -> GltfBuffer -> Bool
$c== :: GltfBuffer -> GltfBuffer -> Bool
Eq, Int -> GltfBuffer -> ShowS
[GltfBuffer] -> ShowS
GltfBuffer -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GltfBuffer] -> ShowS
$cshowList :: [GltfBuffer] -> ShowS
show :: GltfBuffer -> String
$cshow :: GltfBuffer -> String
showsPrec :: Int -> GltfBuffer -> ShowS
$cshowsPrec :: Int -> GltfBuffer -> ShowS
Show)

-- | A buffer and some metadata
data BufferAccessor = BufferAccessor
  { BufferAccessor -> Int
offset :: Int,
    BufferAccessor -> Int
count :: Int,
    BufferAccessor -> GltfBuffer
buffer :: GltfBuffer
  }

-- | Read all the buffers into memory
loadBuffers :: MonadUnliftIO io => GlTF -> io (Vector GltfBuffer)
loadBuffers :: forall (io :: * -> *).
MonadUnliftIO io =>
GlTF -> io (Vector GltfBuffer)
loadBuffers GlTF{$sel:buffers:GlTF :: GlTF -> Maybe (Vector Buffer)
buffers=Maybe (Vector Buffer)
buffers} = do
  let buffers' :: Vector Buffer
buffers' = forall a. a -> Maybe a -> a
fromMaybe [] Maybe (Vector Buffer)
buffers

  forall (m :: * -> *) (v :: * -> *) a b.
(Monad m, Vector v a, Vector v b) =>
v a -> (a -> m b) -> m (v b)
Vector.forM Vector Buffer
buffers' forall a b. (a -> b) -> a -> b
$ \Buffer{Int
Maybe Text
Maybe Value
Maybe Object
Maybe URI
$sel:byteLength:Buffer :: Buffer -> Int
$sel:uri:Buffer :: Buffer -> Maybe URI
$sel:name:Buffer :: Buffer -> Maybe Text
$sel:extensions:Buffer :: Buffer -> Maybe Object
$sel:extras:Buffer :: Buffer -> Maybe Value
extras :: Maybe Value
extensions :: Maybe Object
name :: Maybe Text
uri :: Maybe URI
byteLength :: Int
..} -> do
    ByteString
payload <-
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"")
      (\URI
uri' -> do
          Either String ByteString
readRes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack =>
(String -> IO (Either String ByteString))
-> URI -> IO (Either String ByteString)
loadURI forall a. HasCallStack => a
undefined URI
uri'
          case Either String ByteString
readRes of
            Left String
err -> forall a. HasCallStack => String -> a
error String
err
            Right ByteString
res -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
res)
      Maybe URI
uri
    
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> GltfBuffer
GltfBuffer ByteString
payload

-- | Decode vertex indices
vertexIndices :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector Int
vertexIndices :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector Int
vertexIndices = forall storable.
Storable storable =>
Get (Vector storable)
-> GlTF -> Vector GltfBuffer -> AccessorIx -> Vector storable
readBufferWithGet Get (Vector Int)
getIndices

-- | Decode vertex positions
vertexPositions :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V3 Float)
vertexPositions :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V3 Float)
vertexPositions = forall storable.
Storable storable =>
Get (Vector storable)
-> GlTF -> Vector GltfBuffer -> AccessorIx -> Vector storable
readBufferWithGet Get (Vector (V3 Float))
getPositions

-- | Decode vertex normals
vertexNormals :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V3 Float)
vertexNormals :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V3 Float)
vertexNormals = forall storable.
Storable storable =>
Get (Vector storable)
-> GlTF -> Vector GltfBuffer -> AccessorIx -> Vector storable
readBufferWithGet Get (Vector (V3 Float))
getNormals

-- | Decode texture coordinates. Note that we only use the first one.
vertexTexCoords :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V2 Float)
vertexTexCoords :: GlTF -> Vector GltfBuffer -> AccessorIx -> Vector (V2 Float)
vertexTexCoords = forall storable.
Storable storable =>
Get (Vector storable)
-> GlTF -> Vector GltfBuffer -> AccessorIx -> Vector storable
readBufferWithGet Get (Vector (V2 Float))
getTexCoords

-- | Decode a buffer using the given Binary decoder
readBufferWithGet
  :: Storable storable
  => Get (Vector storable)
  -> GlTF
  -> Vector GltfBuffer
  -> AccessorIx
  -> Vector storable
readBufferWithGet :: forall storable.
Storable storable =>
Get (Vector storable)
-> GlTF -> Vector GltfBuffer -> AccessorIx -> Vector storable
readBufferWithGet Get (Vector storable)
getter GlTF
gltf Vector GltfBuffer
buffers' AccessorIx
accessorId
  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty
      (forall storable.
Storable storable =>
storable
-> Get (Vector storable) -> BufferAccessor -> Vector storable
readFromBuffer forall a. HasCallStack => a
undefined Get (Vector storable)
getter)
      (GlTF -> Vector GltfBuffer -> AccessorIx -> Maybe BufferAccessor
bufferAccessor GlTF
gltf Vector GltfBuffer
buffers' AccessorIx
accessorId)

-- | Look up a Buffer from a GlTF and AccessorIx
bufferAccessor
  :: GlTF
  -> Vector GltfBuffer
  -> AccessorIx
  -> Maybe BufferAccessor
bufferAccessor :: GlTF -> Vector GltfBuffer -> AccessorIx -> Maybe BufferAccessor
bufferAccessor GlTF{Maybe Value
Maybe Object
Maybe (Vector Text)
Maybe (Vector Animation)
Maybe (Vector Scene)
Maybe (Vector Node)
Maybe (Vector Skin)
Maybe (Vector Mesh)
Maybe (Vector Accessor)
Maybe (Vector Texture)
Maybe (Vector Image)
Maybe (Vector BufferView)
Maybe (Vector Buffer)
Maybe (Vector Material)
Maybe (Vector Sampler)
Maybe (Vector Camera)
Asset
$sel:asset:GlTF :: GlTF -> Asset
$sel:extensionsUsed:GlTF :: GlTF -> Maybe (Vector Text)
$sel:extensionsRequired:GlTF :: GlTF -> Maybe (Vector Text)
$sel:accessors:GlTF :: GlTF -> Maybe (Vector Accessor)
$sel:animations:GlTF :: GlTF -> Maybe (Vector Animation)
$sel:bufferViews:GlTF :: GlTF -> Maybe (Vector BufferView)
$sel:cameras:GlTF :: GlTF -> Maybe (Vector Camera)
$sel:images:GlTF :: GlTF -> Maybe (Vector Image)
$sel:materials:GlTF :: GlTF -> Maybe (Vector Material)
$sel:meshes:GlTF :: GlTF -> Maybe (Vector Mesh)
$sel:nodes:GlTF :: GlTF -> Maybe (Vector Node)
$sel:samplers:GlTF :: GlTF -> Maybe (Vector Sampler)
$sel:scenes:GlTF :: GlTF -> Maybe (Vector Scene)
$sel:skins:GlTF :: GlTF -> Maybe (Vector Skin)
$sel:textures:GlTF :: GlTF -> Maybe (Vector Texture)
$sel:extensions:GlTF :: GlTF -> Maybe Object
$sel:extras:GlTF :: GlTF -> Maybe Value
extras :: Maybe Value
extensions :: Maybe Object
textures :: Maybe (Vector Texture)
skins :: Maybe (Vector Skin)
scenes :: Maybe (Vector Scene)
samplers :: Maybe (Vector Sampler)
nodes :: Maybe (Vector Node)
meshes :: Maybe (Vector Mesh)
materials :: Maybe (Vector Material)
images :: Maybe (Vector Image)
cameras :: Maybe (Vector Camera)
bufferViews :: Maybe (Vector BufferView)
buffers :: Maybe (Vector Buffer)
animations :: Maybe (Vector Animation)
accessors :: Maybe (Vector Accessor)
extensionsRequired :: Maybe (Vector Text)
extensionsUsed :: Maybe (Vector Text)
asset :: Asset
$sel:buffers:GlTF :: GlTF -> Maybe (Vector Buffer)
..} Vector GltfBuffer
buffers' AccessorIx
accessorId = do
  Accessor
accessor <- AccessorIx -> Vector Accessor -> Maybe Accessor
lookupAccessor AccessorIx
accessorId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Vector Accessor)
accessors
  BufferView
bufferView <- Accessor -> Vector BufferView -> Maybe BufferView
lookupBufferViewFromAccessor Accessor
accessor forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Vector BufferView)
bufferViews
  GltfBuffer
buffer <- BufferView -> Vector GltfBuffer -> Maybe GltfBuffer
lookupBufferFromBufferView BufferView
bufferView Vector GltfBuffer
buffers'

  let Accessor{$sel:byteOffset:Accessor :: Accessor -> Int
byteOffset=Int
offset, $sel:count:Accessor :: Accessor -> Int
count=Int
count} = Accessor
accessor
      BufferView{$sel:byteOffset:BufferView :: BufferView -> Int
byteOffset=Int
offset'} = BufferView
bufferView

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BufferAccessor
    { offset :: Int
offset = Int
offset forall a. Num a => a -> a -> a
+ Int
offset',
      count :: Int
count = Int
count,
      buffer :: GltfBuffer
buffer = GltfBuffer
buffer
    }

-- | Look up a BufferView by Accessor
lookupBufferViewFromAccessor :: Accessor -> Vector BufferView -> Maybe BufferView
lookupBufferViewFromAccessor :: Accessor -> Vector BufferView -> Maybe BufferView
lookupBufferViewFromAccessor Accessor{Bool
Int
Maybe Text
Maybe Value
Maybe Object
Maybe AccessorSparse
Maybe BufferViewIx
Maybe (Vector Scientific)
ComponentType
AttributeType
$sel:componentType:Accessor :: Accessor -> ComponentType
$sel:normalized:Accessor :: Accessor -> Bool
$sel:type':Accessor :: Accessor -> AttributeType
$sel:bufferView:Accessor :: Accessor -> Maybe BufferViewIx
$sel:min:Accessor :: Accessor -> Maybe (Vector Scientific)
$sel:max:Accessor :: Accessor -> Maybe (Vector Scientific)
$sel:sparse:Accessor :: Accessor -> Maybe AccessorSparse
$sel:name:Accessor :: Accessor -> Maybe Text
$sel:extensions:Accessor :: Accessor -> Maybe Object
$sel:extras:Accessor :: Accessor -> Maybe Value
extras :: Maybe Value
extensions :: Maybe Object
name :: Maybe Text
sparse :: Maybe AccessorSparse
max :: Maybe (Vector Scientific)
min :: Maybe (Vector Scientific)
bufferView :: Maybe BufferViewIx
type' :: AttributeType
count :: Int
byteOffset :: Int
normalized :: Bool
componentType :: ComponentType
$sel:count:Accessor :: Accessor -> Int
$sel:byteOffset:Accessor :: Accessor -> Int
..} Vector BufferView
bufferViews
  = Maybe BufferViewIx
bufferView forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip BufferViewIx -> Vector BufferView -> Maybe BufferView
lookupBufferView Vector BufferView
bufferViews

-- | Look up a Buffer by BufferView
lookupBufferFromBufferView :: BufferView -> Vector GltfBuffer -> Maybe GltfBuffer
lookupBufferFromBufferView :: BufferView -> Vector GltfBuffer -> Maybe GltfBuffer
lookupBufferFromBufferView BufferView{Int
Maybe Int
Maybe Text
Maybe Value
Maybe Object
Maybe BufferViewTarget
BufferIx
$sel:buffer:BufferView :: BufferView -> BufferIx
$sel:byteLength:BufferView :: BufferView -> Int
$sel:byteStride:BufferView :: BufferView -> Maybe Int
$sel:target:BufferView :: BufferView -> Maybe BufferViewTarget
$sel:name:BufferView :: BufferView -> Maybe Text
$sel:extensions:BufferView :: BufferView -> Maybe Object
$sel:extras:BufferView :: BufferView -> Maybe Value
extras :: Maybe Value
extensions :: Maybe Object
name :: Maybe Text
target :: Maybe BufferViewTarget
byteStride :: Maybe Int
byteLength :: Int
byteOffset :: Int
buffer :: BufferIx
$sel:byteOffset:BufferView :: BufferView -> Int
..} = BufferIx -> Vector GltfBuffer -> Maybe GltfBuffer
lookupBuffer BufferIx
buffer

-- | Look up an Accessor by Ix
lookupAccessor :: AccessorIx -> Vector Accessor -> Maybe Accessor
lookupAccessor :: AccessorIx -> Vector Accessor -> Maybe Accessor
lookupAccessor (AccessorIx Int
accessorId) = (forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? Int
accessorId)

-- | Look up a BufferView by Ix
lookupBufferView :: BufferViewIx -> Vector BufferView -> Maybe BufferView
lookupBufferView :: BufferViewIx -> Vector BufferView -> Maybe BufferView
lookupBufferView (BufferViewIx Int
bufferViewId) = (forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? Int
bufferViewId)

-- | Look up a Buffer by Ix
lookupBuffer :: BufferIx -> Vector GltfBuffer -> Maybe GltfBuffer
lookupBuffer :: BufferIx -> Vector GltfBuffer -> Maybe GltfBuffer
lookupBuffer (BufferIx Int
bufferId) = (forall (v :: * -> *) a. Vector v a => v a -> Int -> Maybe a
Vector.!? Int
bufferId)

-- | Decode a buffer using the given Binary decoder
readFromBuffer
  :: Storable storable
  => storable
  -> Get (Vector storable)
  -> BufferAccessor
  -> Vector storable
readFromBuffer :: forall storable.
Storable storable =>
storable
-> Get (Vector storable) -> BufferAccessor -> Vector storable
readFromBuffer storable
storable Get (Vector storable)
getter BufferAccessor{Int
GltfBuffer
buffer :: GltfBuffer
count :: Int
offset :: Int
buffer :: BufferAccessor -> GltfBuffer
count :: BufferAccessor -> Int
offset :: BufferAccessor -> Int
..}
  = forall a. Get a -> ByteString -> a
runGet Get (Vector storable)
getter (ByteString -> ByteString
fromStrict ByteString
payload')
  where payload' :: ByteString
payload' = Int -> ByteString -> ByteString
ByteString.take Int
len' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
ByteString.drop Int
offset forall b c a. (b -> c) -> (a -> b) -> a -> c
. GltfBuffer -> ByteString
unBuffer forall a b. (a -> b) -> a -> b
$ GltfBuffer
buffer
        len' :: Int
len' = Int
count forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf storable
storable