diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,17 @@ +Copyright 2022 Sean Gillespie + +Permission is hereby granted, free of charge, to any person obtaining a copy of this +software and associated documentation files (the "Software"), to deal in the Software +without restriction, including without limitation the rights to use, copy, modify, merge, +publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons +to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or +substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, +INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR +PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE +FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR +OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,85 @@ +# Haskell GlTF Loader + +[![pipeline status](https://gitlab.com/sgillespie/haskell-gltf-loader/badges/main/pipeline.svg)](https://gitlab.com/sgillespie/haskell-gltf-loader/-/commits/main) + +> A high level GlTF loader + + +## Prerequisites + +In order to build or install you will need + + * [GHC](https://www.haskell.org/downloads/) (Tested on 9.0.2) + * [Stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/) (Tested on 2.7.5) + +## Building + +Build the project + + stack setup + stack build + +Run the tests (if desired) + +``` +stack test +``` + +## API Documentation +To build the documentation, run + + stack haddock + +## API Examples +Use `fromFile` or `fromBytestring` to load a GlTF scene + + + import Text.GLTF.Loader (fromFile) + + -- ... + -- Load a GLTF scene from a file + loadGltfFile :: IO (Either Errors Gltf) + loadGltfFile = fromFile "./cube.gltf" + +Then you can, for example, get all the vertices: + + getVertices :: Gltf -> [V3 Float] + getVertices gltf = concatMap getVertices' (gltf ^. _meshes) + where getVertices' mesh = concatMap (^. _meshPrimitivePositions) (mesh ^. _meshPrimitives) + +## CLI +This includes a CLI utility to inspect GlTF files + + gltf-loader --help + +## Roadmap + +Currently, only retreiving indices are supported, but we hope to support the majority of GlTF +features: + +[] Animitions +[] Asset +[] Cameras +[] Images +[] Materials +[x] Meshes + [x] Positions + [x] Indices + [] Normals + [] Texture Coordinates +[] Node +[] Samplers +[] Skins + +## Authors + +Sean Gillespie + +## Acknowledgements + +This project is largely based on [https://hackage.haskell.org/package/gltf-codec](gltf-codec) by +Alexander Bondarenko + +## License +This project is licensed under the MIT License. See [LICENSE](LICENSE) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Command/GLTF/Loader.hs b/app/Command/GLTF/Loader.hs new file mode 100644 --- /dev/null +++ b/app/Command/GLTF/Loader.hs @@ -0,0 +1,7 @@ +module Command.GLTF.Loader + ( module Command.GLTF.Loader.App, + module Command.GLTF.Loader.Run + ) where + +import Command.GLTF.Loader.App +import Command.GLTF.Loader.Run diff --git a/app/Command/GLTF/Loader/App.hs b/app/Command/GLTF/Loader/App.hs new file mode 100644 --- /dev/null +++ b/app/Command/GLTF/Loader/App.hs @@ -0,0 +1,39 @@ +module Command.GLTF.Loader.App where + +import RIO +import RIO.Process + +-- | Command line arguments +data Options = Options + { optionsVerbose :: !Bool, + optionsFile :: FilePath + } + +-- | Application state +data App = App + { appLogFunc :: !LogFunc, + appProcessContext :: !ProcessContext, + appOptions :: !Options + } + +class HasOptions env where + optionsL :: Lens' env Options + +instance HasLogFunc App where + logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y }) + +instance HasProcessContext App where + processContextL = lens appProcessContext (\x y -> x { appProcessContext = y }) + +instance HasOptions App where + optionsL = lens appOptions (\app opts -> app { appOptions = opts }) + +_optionsVerbose :: Lens' Options Bool +_optionsVerbose = lens + optionsVerbose + (\opts verbose -> opts { optionsVerbose = verbose }) + +_optionsFile :: Lens' Options FilePath +_optionsFile = lens + optionsFile + (\opts file -> opts { optionsFile = file }) diff --git a/app/Command/GLTF/Loader/Run.hs b/app/Command/GLTF/Loader/Run.hs new file mode 100644 --- /dev/null +++ b/app/Command/GLTF/Loader/Run.hs @@ -0,0 +1,67 @@ +module Command.GLTF.Loader.Run (run) where + +import Command.GLTF.Loader.App +import Text.GLTF.Loader + +import Lens.Micro +import Linear (V3(..)) +import RIO +import RIO.List (nub) + +run :: RIO App () +run = do + file <- asks $ view (optionsL . _optionsFile) + logInfo $ "File: " <> fromString file + + result <- liftIO $ fromFile file + either reportError reportGltf result + +reportError :: HasLogFunc logger => Errors -> RIO logger () +reportError err + = logError (display err) + >> exitFailure + +reportGltf :: Gltf -> RIO App () +reportGltf gltf = do + reportAsset $ gltf ^. _asset + + logInfo "" -- Blank line + + reportNodes gltf + +reportAsset :: Asset -> RIO App () +reportAsset asset = do + logInfo $ "Generator: " <> asset ^. _assetGenerator . to (fromMaybe "Unknown") . to display + logInfo $ "Version: " <> asset ^. _assetVersion . to display + +reportNodes :: Gltf -> RIO App () +reportNodes gltf = do + let nodes = gltf ^. _nodes + logInfo $ "Nodes: " <> display (RIO.length nodes) + + forM_ nodes $ \node -> do + logInfo $ " Name: " <> maybe "Unknown node" display (view _nodeName node) + + forM_ (node ^. _nodeMeshId) $ \meshId -> do + logInfo " Mesh: " + forM_ (gltf ^. _meshes ^? ix meshId) reportMesh + + +reportMesh :: Mesh -> RIO App () +reportMesh mesh = do + logInfo $ " Name: " <> mesh ^. _meshName . to (display . fromMaybe "Unknown") + logInfo " Mesh Primitives:" + + forM_ (mesh ^. _meshPrimitives) $ \primitive' -> do + logInfo " Vertex Positions:" + + forM_ (nub $ primitive' ^. _meshPrimitivePositions) $ \position -> do + logInfo $ " " <> displayV3 position + +displayV3 :: Display a => V3 a -> Utf8Builder +displayV3 (V3 x y z) + = "(" + <> display x <> ", " + <> display y <> ", " + <> display z <> + ")" diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +module Main (main) where + +import Command.GLTF.Loader +import Paths_gltf_loader + +import RIO +import RIO.Process +import Options.Applicative.Simple + +main :: IO () +main = do + (options', _) <- parseOptions + logOptions <- logOptionsHandle stderr (optionsVerbose options') + processContext <- mkDefaultProcessContext + + runApp processContext options' logOptions run + +parseOptions :: IO (Options, ()) +parseOptions = simpleOptions version' header' description options empty + where version' = $(simpleVersion version) + header' = "Header for command line arguments" + description = "A tool it inspect GlTF files" + +runApp + :: MonadUnliftIO m + => ProcessContext + -> Options + -> LogOptions + -> RIO App a + -> m a +runApp processContext cliOptions logOptions appAction + = withLogFunc logOptions $ \logFunc -> runRIO (mkApp logFunc) appAction + where mkApp logFunc = App + { appLogFunc = logFunc, + appProcessContext = processContext, + appOptions = cliOptions + } + +options :: Parser Options +options = Options <$> switch verboseOption <*> strArgument fileArg + +verboseOption :: Mod FlagFields Bool +verboseOption + = long "verbose" + <> short 'v' + <> help "Verbose output?" + +fileArg :: Mod ArgumentFields FilePath +fileArg + = metavar "file" + <> help "Name of the GlTF file" + <> completer (bashCompleter "file") diff --git a/data/cube.gltf b/data/cube.gltf new file mode 100644 --- /dev/null +++ b/data/cube.gltf @@ -0,0 +1,117 @@ +{ + "asset" : { + "generator" : "Khronos glTF Blender I/O v3.2.40", + "version" : "2.0" + }, + "scene" : 0, + "scenes" : [ + { + "name" : "Scene", + "nodes" : [ + 0 + ] + } + ], + "nodes" : [ + { + "mesh" : 0, + "name" : "Cube" + } + ], + "materials" : [ + { + "doubleSided" : true, + "name" : "Material", + "pbrMetallicRoughness" : { + "baseColorFactor" : [ + 0.800000011920929, + 0.800000011920929, + 0.800000011920929, + 1 + ], + "metallicFactor" : 0, + "roughnessFactor" : 0.4000000059604645 + } + } + ], + "meshes" : [ + { + "name" : "Cube", + "primitives" : [ + { + "attributes" : { + "POSITION" : 0, + "NORMAL" : 1, + "TEXCOORD_0" : 2 + }, + "indices" : 3, + "material" : 0 + } + ] + } + ], + "accessors" : [ + { + "bufferView" : 0, + "componentType" : 5126, + "count" : 24, + "max" : [ + 1, + 1, + 1 + ], + "min" : [ + -1, + -1, + -1 + ], + "type" : "VEC3" + }, + { + "bufferView" : 1, + "componentType" : 5126, + "count" : 24, + "type" : "VEC3" + }, + { + "bufferView" : 2, + "componentType" : 5126, + "count" : 24, + "type" : "VEC2" + }, + { + "bufferView" : 3, + "componentType" : 5123, + "count" : 36, + "type" : "SCALAR" + } + ], + "bufferViews" : [ + { + "buffer" : 0, + "byteLength" : 288, + "byteOffset" : 0 + }, + { + "buffer" : 0, + "byteLength" : 288, + "byteOffset" : 288 + }, + { + "buffer" : 0, + "byteLength" : 192, + "byteOffset" : 576 + }, + { + "buffer" : 0, + "byteLength" : 72, + "byteOffset" : 768 + } + ], + "buffers" : [ + { + "byteLength" : 840, + "uri" : "data:application/octet-stream;base64,AACAPwAAgD8AAIC/AACAPwAAgD8AAIC/AACAPwAAgD8AAIC/AACAPwAAgL8AAIC/AACAPwAAgL8AAIC/AACAPwAAgL8AAIC/AACAPwAAgD8AAIA/AACAPwAAgD8AAIA/AACAPwAAgD8AAIA/AACAPwAAgL8AAIA/AACAPwAAgL8AAIA/AACAPwAAgL8AAIA/AACAvwAAgD8AAIC/AACAvwAAgD8AAIC/AACAvwAAgD8AAIC/AACAvwAAgL8AAIC/AACAvwAAgL8AAIC/AACAvwAAgL8AAIC/AACAvwAAgD8AAIA/AACAvwAAgD8AAIA/AACAvwAAgD8AAIA/AACAvwAAgL8AAIA/AACAvwAAgL8AAIA/AACAvwAAgL8AAIA/AAAAAAAAAAAAAIC/AAAAAAAAgD8AAACAAACAPwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIC/AACAPwAAAAAAAACAAAAAAAAAAAAAAIA/AAAAAAAAgD8AAACAAACAPwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIA/AACAPwAAAAAAAACAAACAvwAAAAAAAACAAAAAAAAAAAAAAIC/AAAAAAAAgD8AAACAAACAvwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIC/AACAvwAAAAAAAACAAAAAAAAAAAAAAIA/AAAAAAAAgD8AAACAAACAvwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIA/AAAgPwAAAD8AACA/AAAAPwAAID8AAAA/AADAPgAAAD8AAMA+AAAAPwAAwD4AAAA/AAAgPwAAgD4AACA/AACAPgAAID8AAIA+AADAPgAAgD4AAMA+AACAPgAAwD4AAIA+AAAgPwAAQD8AACA/AABAPwAAYD8AAAA/AADAPgAAQD8AAAA+AAAAPwAAwD4AAEA/AAAgPwAAgD8AACA/AAAAAAAAYD8AAIA+AADAPgAAgD8AAAA+AACAPgAAwD4AAAAAAQAOABQAAQAUAAcACgAGABMACgATABcAFQASAAwAFQAMAA8AEAADAAkAEAAJABYABQACAAgABQAIAAsAEQANAAAAEQAAAAQA" + } + ] +} diff --git a/data/invalid.gltf b/data/invalid.gltf new file mode 100644 --- /dev/null +++ b/data/invalid.gltf @@ -0,0 +1,1 @@ +ohea diff --git a/gltf-loader.cabal b/gltf-loader.cabal new file mode 100644 --- /dev/null +++ b/gltf-loader.cabal @@ -0,0 +1,212 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.7. +-- +-- see: https://github.com/sol/hpack + +name: gltf-loader +version: 0.1.0.0 +synopsis: High level GlTF loader +description: Please see the README on Github at +category: Graphics +homepage: https://github.com/sgillespiep/haskell-gltf-loader#readme +bug-reports: https://github.com/sgillespiep/haskell-gltf-loader/issues +author: Sean D Gillespie +maintainer: sean@mistersg.net +copyright: 2022 Sean Gillespie +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + data/cube.gltf + data/invalid.gltf + +source-repository head + type: git + location: https://github.com/sgillespiep/haskell-gltf-loader + +library + exposed-modules: + Text.GLTF.Loader + Text.GLTF.Loader.Adapter + Text.GLTF.Loader.BufferAccessor + Text.GLTF.Loader.Errors + Text.GLTF.Loader.Gltf + other-modules: + Paths_gltf_loader + hs-source-dirs: + src + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + OverloadedLists + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.11 && <10 + , binary + , bytestring + , gltf-codec + , linear + , microlens + , rio >=0.1.12.0 + , unordered-containers + default-language: Haskell2010 + +executable gltf-loader-exe + main-is: Main.hs + other-modules: + Command.GLTF.Loader + Command.GLTF.Loader.App + Command.GLTF.Loader.Run + Paths_gltf_loader + hs-source-dirs: + app + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + OverloadedLists + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.11 && <10 + , gltf-loader + , linear + , microlens + , optparse-simple + , rio >=0.1.12.0 + default-language: Haskell2010 + +test-suite gltf-loader-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Text.GLTF.Loader.AdapterSpec + Text.GLTF.Loader.BufferAccessorSpec + Text.GLTF.Loader.Test.MkGltf + Text.GLTF.LoaderSpec + Paths_gltf_loader + hs-source-dirs: + test + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + OverloadedLists + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.11 && <10 + , base64 + , binary + , bytestring + , gltf-codec + , gltf-loader + , hspec + , linear + , microlens + , rio >=0.1.12.0 + , unordered-containers + default-language: Haskell2010 diff --git a/src/Text/GLTF/Loader.hs b/src/Text/GLTF/Loader.hs new file mode 100644 --- /dev/null +++ b/src/Text/GLTF/Loader.hs @@ -0,0 +1,39 @@ +module Text.GLTF.Loader + ( fromByteString, + fromFile, + + module Text.GLTF.Loader.Errors, + module Text.GLTF.Loader.Gltf + ) where + +import Text.GLTF.Loader.Adapter +import Text.GLTF.Loader.BufferAccessor +import Text.GLTF.Loader.Errors +import Text.GLTF.Loader.Gltf + +import Data.Either +import Lens.Micro +import RIO + ( Monad((>>=)), + IsString(fromString), + String, + (<$>), + (.), + MonadIO(liftIO), + MonadUnliftIO, + ByteString, + FilePath ) +import qualified Codec.GlTF as GlTF + +fromByteString :: MonadUnliftIO io => ByteString -> io (Either Errors Gltf) +fromByteString = toGltfResult . GlTF.fromByteString + +fromFile :: MonadUnliftIO io => FilePath -> io (Either Errors Gltf) +fromFile path = liftIO (GlTF.fromFile path) >>= toGltfResult + +toGltfResult :: MonadUnliftIO io => Either String GlTF.GlTF -> io (Either Errors Gltf) +toGltfResult res + = res + & over _Left (ReadError . fromString) + & traverseOf _Right toGltfResult' + where toGltfResult' gltf = adaptGltf gltf <$> loadBuffers gltf diff --git a/src/Text/GLTF/Loader/Adapter.hs b/src/Text/GLTF/Loader/Adapter.hs new file mode 100644 --- /dev/null +++ b/src/Text/GLTF/Loader/Adapter.hs @@ -0,0 +1,108 @@ +-- |Transform a `Codec.GlTF.GlTF` to `Text.GLTF.Loader.Gltf.Gltf` +module Text.GLTF.Loader.Adapter + ( attributePosition, + attributeNormal, + adaptGltf, + adaptAsset, + adaptMeshes, + adaptNodes, + adaptMesh, + adaptNode, + adaptMeshPrimitives, + adaptMeshPrimitive, + adaptMeshPrimitiveMode + ) where + +import Text.GLTF.Loader.BufferAccessor +import Text.GLTF.Loader.Gltf + +import Linear (V3(..), V4(..)) +import RIO +import RIO.Partial (toEnum) +import qualified Codec.GlTF as GlTF +import qualified Codec.GlTF.Asset as GlTF.Asset +import qualified Codec.GlTF.Mesh as GlTF.Mesh +import qualified Codec.GlTF.Node as GlTF.Node +import qualified Data.HashMap.Strict as HashMap + +attributePosition :: Text +attributePosition = "POSITION" + +attributeNormal :: Text +attributeNormal = "NORMAL" + + +adaptGltf :: GlTF.GlTF -> Vector GltfBuffer -> Gltf +adaptGltf gltf@GlTF.GlTF{..} buffers' = Gltf + { gltfAsset = adaptAsset asset, + gltfMeshes = adaptMeshes gltf buffers' meshes, + gltfNodes = adaptNodes nodes + } + +adaptAsset :: GlTF.Asset.Asset -> Asset +adaptAsset GlTF.Asset.Asset{..} = Asset + { assetVersion = version, + assetCopyright = copyright, + assetGenerator = generator, + assetMinVersion = minVersion + } + +adaptMeshes + :: GlTF.GlTF + -> Vector GltfBuffer + -> Maybe (Vector GlTF.Mesh.Mesh) + -> [Mesh] +adaptMeshes gltf buffers' = maybe [] (map (adaptMesh gltf buffers') . toList) + +adaptNodes :: Maybe (Vector GlTF.Node.Node) -> [Node] +adaptNodes = maybe [] (map adaptNode . toList) + +adaptMesh + :: GlTF.GlTF + -> Vector GltfBuffer + -> GlTF.Mesh.Mesh + -> Mesh +adaptMesh gltf buffers' GlTF.Mesh.Mesh{..} = Mesh + { meshPrimitives = adaptMeshPrimitives gltf buffers' primitives, + meshWeights = maybe [] toList weights, + meshName = name + } + +adaptNode :: GlTF.Node.Node -> Node +adaptNode GlTF.Node.Node{..} = Node + { nodeMeshId = GlTF.Mesh.unMeshIx <$> mesh, + nodeName = name, + nodeRotation = toV4 <$> rotation, + nodeScale = toV3 <$> scale, + nodeTranslation = toV3 <$> translation, + nodeWeights = maybe [] toList weights + } + +adaptMeshPrimitives + :: GlTF.GlTF + -> Vector GltfBuffer + -> Vector GlTF.Mesh.MeshPrimitive + -> [MeshPrimitive] +adaptMeshPrimitives gltf buffers' = map (adaptMeshPrimitive gltf buffers') . toList + +adaptMeshPrimitive + :: GlTF.GlTF + -> Vector GltfBuffer + -> GlTF.Mesh.MeshPrimitive + -> MeshPrimitive +adaptMeshPrimitive gltf buffers' GlTF.Mesh.MeshPrimitive{..} = MeshPrimitive + { meshPrimitiveMode = adaptMeshPrimitiveMode mode, + meshPrimitiveIndices = maybe [] (vertexIndices gltf buffers') indices, + meshPrimitivePositions = maybe [] (vertexPositions gltf buffers') positions, + meshPrimitiveNormals = [] + } + where positions = attributes HashMap.!? attributePosition + +adaptMeshPrimitiveMode :: GlTF.Mesh.MeshPrimitiveMode -> MeshPrimitiveMode +adaptMeshPrimitiveMode = toEnum . GlTF.Mesh.unMeshPrimitiveMode + +toV3 :: (a, a, a) -> V3 a +toV3 (x, y, z) = V3 x y z + +toV4 :: (a, a, a, a) -> V4 a +toV4 (w, x, y, z) = V4 w x y z diff --git a/src/Text/GLTF/Loader/BufferAccessor.hs b/src/Text/GLTF/Loader/BufferAccessor.hs new file mode 100644 --- /dev/null +++ b/src/Text/GLTF/Loader/BufferAccessor.hs @@ -0,0 +1,236 @@ +module Text.GLTF.Loader.BufferAccessor + ( GltfBuffer(..), + -- * Loading GLTF buffers + loadBuffers, + -- * Deserializing Accessors + vertexIndices, + vertexPositions, + vertexNormals, + -- * Binary Get decoders + -- ** Specific Type decoders + getIndices, + getPositions, + -- ** GLTF Accessor Type decoders + getScalar, + getVec2, + getVec3, + getVec4, + getMat2, + getMat3, + getMat4, + -- ** GLTF Component Type decoders + getByte, + getUnsignedByte, + getShort, + getUnsignedShort, + getUnsignedInt, + getFloat + ) where + +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 + +newtype GltfBuffer = GltfBuffer { unBuffer :: ByteString } + deriving (Eq, Show) + +data BufferAccessor = BufferAccessor + { offset :: Int, + count :: Int, + buffer :: GltfBuffer + } + +loadBuffers :: MonadUnliftIO io => GlTF -> io (Vector GltfBuffer) +loadBuffers GlTF{buffers=buffers} = do + let buffers' = fromMaybe [] buffers + + Vector.forM buffers' $ \Buffer{..} -> do + payload <- + maybe + (return "") + (\uri' -> do + readRes <- liftIO $ loadURI undefined uri' + case readRes of + Left err -> error err + Right res -> return res) + uri + + return $ GltfBuffer payload + +vertexIndices :: GlTF -> Vector GltfBuffer -> AccessorIx -> [Int] +vertexIndices = readBufferWithGet getIndices + +vertexPositions :: GlTF -> Vector GltfBuffer -> AccessorIx -> [V3 Float] +vertexPositions = readBufferWithGet getPositions + +vertexNormals :: GlTF -> Vector GltfBuffer -> AccessorIx -> [V3 Float] +vertexNormals = undefined + +readBufferWithGet + :: Storable storable + => Get [storable] + -> GlTF + -> Vector GltfBuffer + -> AccessorIx + -> [storable] +readBufferWithGet getter gltf buffers' accessorId + = maybe [] + (readFromBuffer undefined getter) + (bufferAccessor gltf buffers' accessorId) + +bufferAccessor + :: GlTF + -> Vector GltfBuffer + -> AccessorIx + -> Maybe BufferAccessor +bufferAccessor GlTF{..} buffers' accessorId = do + accessor <- lookupAccessor accessorId =<< accessors + bufferView <- lookupBufferViewFromAccessor accessor =<< bufferViews + buffer <- lookupBufferFromBufferView bufferView buffers' + + let Accessor{byteOffset=offset, count=count} = accessor + BufferView{byteOffset=offset'} = bufferView + + return $ BufferAccessor + { offset = offset + offset', + count = count, + buffer = buffer + } + +lookupBufferViewFromAccessor :: Accessor -> Vector BufferView -> Maybe BufferView +lookupBufferViewFromAccessor Accessor{..} bufferViews + = bufferView >>= flip lookupBufferView bufferViews + +lookupBufferFromBufferView :: BufferView -> Vector GltfBuffer -> Maybe GltfBuffer +lookupBufferFromBufferView BufferView{..} = lookupBuffer buffer + +lookupAccessor :: AccessorIx -> Vector Accessor -> Maybe Accessor +lookupAccessor (AccessorIx accessorId) = (Vector.!? accessorId) + +lookupBufferView :: BufferViewIx -> Vector BufferView -> Maybe BufferView +lookupBufferView (BufferViewIx bufferViewId) = (Vector.!? bufferViewId) + +lookupBuffer :: BufferIx -> Vector GltfBuffer -> Maybe GltfBuffer +lookupBuffer (BufferIx bufferId) = (Vector.!? bufferId) + +readFromBuffer + :: Storable storable + => storable + -> Get [storable] + -> BufferAccessor + -> [storable] +readFromBuffer storable getter BufferAccessor{..} + = runGet getter (fromStrict payload') + where payload' = ByteString.take len' . ByteString.drop offset . unBuffer $ buffer + len' = count * sizeOf storable + +getIndices :: Get [Int] +getIndices = getScalar (fromIntegral <$> getUnsignedShort) + +getPositions :: Get [V3 Float] +getPositions = getVec3 getFloat + +getScalar :: Get a -> Get [a] +getScalar = getList + +getVec2 :: Get a -> Get [V2 a] +getVec2 getter = getList $ V2 <$> getter <*> getter + +getVec3 :: Get a -> Get [V3 a] +getVec3 getter = getList $ V3 <$> getter <*> getter <*> getter + +getVec4 :: Get a -> Get [V4 a] +getVec4 getter = getList $ V4 <$> getter <*> getter <*> getter <*> getter + +getMat2 :: Get a -> Get [M22 a] +getMat2 getter = getList $ do + m1_1 <- getter + m1_2 <- getter + + m2_1 <- getter + m2_2 <- getter + + return $ V2 + (V2 m1_1 m2_1) + (V2 m1_2 m2_2) + +getMat3 :: Get a -> Get [M33 a] +getMat3 getter = getList $ do + m1_1 <- getter + m1_2 <- getter + m1_3 <- getter + + m2_1 <- getter + m2_2 <- getter + m2_3 <- getter + + m3_1 <- getter + m3_2 <- getter + m3_3 <- getter + + return $ V3 + (V3 m1_1 m2_1 m3_1) + (V3 m1_2 m2_2 m3_2) + (V3 m1_3 m2_3 m3_3) + +getMat4 :: Get a -> Get [M44 a] +getMat4 getter = getList $ do + m1_1 <- getter + m1_2 <- getter + m1_3 <- getter + m1_4 <- getter + + m2_1 <- getter + m2_2 <- getter + m2_3 <- getter + m2_4 <- getter + + m3_1 <- getter + m3_2 <- getter + m3_3 <- getter + m3_4 <- getter + + m4_1 <- getter + m4_2 <- getter + m4_3 <- getter + m4_4 <- getter + + return $ V4 + (V4 m1_1 m2_1 m3_1 m4_1) + (V4 m1_2 m2_2 m3_2 m4_2) + (V4 m1_3 m2_3 m3_3 m4_3) + (V4 m1_4 m2_4 m3_4 m4_4) + +getByte :: Get Int8 +getByte = getInt8 + +getUnsignedByte :: Get Word8 +getUnsignedByte = getWord8 + +getShort :: Get Int16 +getShort = getInt16le + +getUnsignedShort :: Get Word16 +getUnsignedShort = getWord16le + +getUnsignedInt :: Get Word32 +getUnsignedInt = getWord32le + +getFloat :: Get Float +getFloat = getFloatle + +getList :: Get a -> Get [a] +getList getter = do + empty <- isEmpty + if empty + then return [] + else (:) <$> getter <*> getList getter diff --git a/src/Text/GLTF/Loader/Errors.hs b/src/Text/GLTF/Loader/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Text/GLTF/Loader/Errors.hs @@ -0,0 +1,28 @@ +module Text.GLTF.Loader.Errors + ( Errors(..), + _ReadError, + _ImpossibleError + ) where + +import Lens.Micro (Traversal'()) +import RIO + +data Errors + = ReadError Text + | ImpossibleError + deriving (Show, Eq, Typeable) + +instance Display Errors where + textDisplay = displayErrorText + +_ReadError :: Traversal' Errors Text +_ReadError f (ReadError text) = ReadError <$> f text +_ReadError _ err = pure err + +_ImpossibleError :: Traversal' Errors () +_ImpossibleError f ImpossibleError = f () $> ImpossibleError +_ImpossibleError _ err = pure err + +displayErrorText :: Errors -> Text +displayErrorText (ReadError txt) = txt +displayErrorText ImpossibleError = "An impossible error has occurred!" diff --git a/src/Text/GLTF/Loader/Gltf.hs b/src/Text/GLTF/Loader/Gltf.hs new file mode 100644 --- /dev/null +++ b/src/Text/GLTF/Loader/Gltf.hs @@ -0,0 +1,157 @@ +module Text.GLTF.Loader.Gltf + ( -- * Data constructors + Gltf(..), + Asset(..), + Mesh(..), + Node(..), + MeshPrimitive(..), + MeshPrimitiveMode(..), + -- * Lenses + _asset, + _meshes, + _nodes, + _assetVersion, + _assetCopyright, + _assetGenerator, + _assetMinVersion, + _meshPrimitives, + _meshPrimitiveMode, + _meshPrimitiveIndices, + _meshPrimitivePositions, + _meshPrimitiveNormals, + _meshWeights, + _meshName, + _nodeMeshId, + _nodeName, + _nodeRotation, + _nodeScale, + _nodeTranslation, + _nodeWeights + ) where + +import Linear.V3 (V3(..)) +import Linear.V4 (V4(..)) +import RIO + +data Gltf = Gltf + { gltfAsset :: Asset, + gltfMeshes :: [Mesh], + gltfNodes :: [Node] } + deriving (Eq, Show) + +data Asset = Asset + { assetVersion :: Text, + assetCopyright :: Maybe Text, + assetGenerator :: Maybe Text, + assetMinVersion :: Maybe Text + } deriving (Eq, Show) + +data Mesh = Mesh + { meshPrimitives :: [MeshPrimitive], + meshWeights :: [Float], + meshName :: Maybe Text + } deriving (Eq, Show) + +data Node = Node + { nodeMeshId :: Maybe Int, + nodeName :: Maybe Text, + nodeRotation :: Maybe (V4 Float), + nodeScale :: Maybe (V3 Float), + nodeTranslation :: Maybe (V3 Float), + nodeWeights :: [Float] + } deriving (Eq, Show) + +data MeshPrimitive = MeshPrimitive + { meshPrimitiveMode :: MeshPrimitiveMode, + meshPrimitiveIndices :: [Int], + meshPrimitivePositions :: [V3 Float], + meshPrimitiveNormals :: [V3 Float] + } deriving (Eq, Show) + +data MeshPrimitiveMode + = Points + | Lines + | LineLoop + | LineStrip + | Triangles + | TriangleStrip + | TriangleFan + deriving (Eq, Enum, Show) + +_asset :: Lens' Gltf Asset +_asset = lens gltfAsset (\gltf asset -> gltf { gltfAsset = asset }) + +_meshes :: Lens' Gltf [Mesh] +_meshes = lens gltfMeshes (\gltf meshes -> gltf { gltfMeshes = meshes }) + +_nodes :: Lens' Gltf [Node] +_nodes = lens gltfNodes (\gltf nodes -> gltf { gltfNodes = nodes }) + +_assetVersion :: Lens' Asset Text +_assetVersion = lens assetVersion (\asset version' -> asset { assetVersion = version' }) + +_assetCopyright :: Lens' Asset (Maybe Text) +_assetCopyright = lens + assetCopyright + (\asset copyright' -> asset { assetCopyright = copyright' }) + +_assetGenerator :: Lens' Asset (Maybe Text) +_assetGenerator = lens + assetGenerator + (\asset generator' -> asset { assetGenerator = generator' }) + +_assetMinVersion :: Lens' Asset (Maybe Text) +_assetMinVersion = lens + assetMinVersion + (\asset minVersion' -> asset { assetMinVersion = minVersion' }) + +_meshPrimitives :: Lens' Mesh [MeshPrimitive] +_meshPrimitives = lens + meshPrimitives + (\mesh primitives -> mesh { meshPrimitives = primitives }) + +_meshPrimitiveMode :: Lens' MeshPrimitive MeshPrimitiveMode +_meshPrimitiveMode = lens + meshPrimitiveMode + (\primitive' mode -> primitive' { meshPrimitiveMode = mode }) + +_meshPrimitiveIndices :: Lens' MeshPrimitive [Int] +_meshPrimitiveIndices = lens + meshPrimitiveIndices + (\primitive' indices -> primitive' { meshPrimitiveIndices = indices }) + +_meshPrimitivePositions :: Lens' MeshPrimitive [V3 Float] +_meshPrimitivePositions = lens + meshPrimitivePositions + (\primitive' positions -> primitive' { meshPrimitivePositions = positions }) + +_meshPrimitiveNormals :: Lens' MeshPrimitive [V3 Float] +_meshPrimitiveNormals = lens + meshPrimitiveNormals + (\primitive' normals -> primitive' { meshPrimitiveNormals = normals }) + +_meshWeights :: Lens' Mesh [Float] +_meshWeights = lens meshWeights (\mesh weights -> mesh { meshWeights = weights }) + +_meshName :: Lens' Mesh (Maybe Text) +_meshName = lens meshName (\mesh name -> mesh { meshName = name }) + +_nodeMeshId :: Lens' Node (Maybe Int) +_nodeMeshId = lens nodeMeshId (\node meshId -> node { nodeMeshId = meshId }) + +_nodeName :: Lens' Node (Maybe Text) +_nodeName = lens nodeName (\node name' -> node { nodeName = name' }) + +_nodeRotation :: Lens' Node (Maybe (V4 Float)) +_nodeRotation = lens nodeRotation (\node rotation' -> node { nodeRotation = rotation' }) + +_nodeScale :: Lens' Node (Maybe (V3 Float)) +_nodeScale = lens nodeScale (\node scale' -> node { nodeScale = scale' }) + +_nodeTranslation :: Lens' Node (Maybe (V3 Float)) +_nodeTranslation = lens + nodeTranslation + (\node translation' -> node { nodeTranslation = translation' }) + +_nodeWeights :: Lens' Node [Float] +_nodeWeights = lens nodeWeights (\node weights' -> node { nodeWeights = weights' }) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Text/GLTF/Loader/AdapterSpec.hs b/test/Text/GLTF/Loader/AdapterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Text/GLTF/Loader/AdapterSpec.hs @@ -0,0 +1,167 @@ +module Text.GLTF.Loader.AdapterSpec (spec) where + +import Text.GLTF.Loader.Adapter +import Text.GLTF.Loader.BufferAccessor +import Text.GLTF.Loader.Gltf +import Text.GLTF.Loader.Test.MkGltf + +import Linear (V3(..), V4(..)) +import RIO +import Test.Hspec +import qualified Codec.GlTF.Mesh as Mesh +import qualified Codec.GlTF.Node as Node + +spec :: Spec +spec = do + let codecGltf = mkCodecGltf + codecMeshPrimitive = mkCodecMeshPrimitive + + describe "adaptGltf" $ do + it "Adapts a basic GlTF" $ do + buffers' <- buffers + adaptGltf codecGltf buffers' `shouldBe` loaderGltf + + describe "adaptAsset" $ do + let codecAsset = mkCodecAsset + + it "Adapts a basic asset" $ + adaptAsset codecAsset `shouldBe` loaderAsset + + describe "adaptMeshes" $ do + let codecMesh = mkCodecMesh + codecMesh' = mkCodecMesh { Mesh.weights = Just [3.1] } + + it "Adapts a list of nodes" $ do + buffers' <- buffers + + let meshes = Just [codecMesh, codecMesh'] + adaptedMeshes = [loaderMesh, set _meshWeights [3.1] loaderMesh] + + adaptMeshes codecGltf buffers' meshes `shouldBe` adaptedMeshes + + it "Adapts empty meshes" $ do + buffers' <- buffers + + adaptMeshes codecGltf buffers' (Just []) `shouldBe` [] + adaptMeshes codecGltf buffers' Nothing `shouldBe` [] + + describe "adaptNodes" $ do + let codecNode = mkCodecNode + codecNode' = codecNode { Node.rotation = Nothing } + + it "Adapts a list of nodes" $ do + let nodes = Just [codecNode, codecNode'] + adaptNodes nodes `shouldBe` [loaderNode, set _nodeRotation Nothing loaderNode] + + it "Adapts empty nodes" $ do + adaptNodes (Just []) `shouldBe` [] + adaptNodes Nothing `shouldBe` [] + + describe "adaptMesh" $ do + let codecMesh = mkCodecMesh + codecMesh' = mkCodecMesh { Mesh.weights = Nothing } + codecMesh'' = mkCodecMesh { Mesh.weights = Just [] } + + it "Adapts a basic mesh" $ do + buffers' <- buffers + adaptMesh codecGltf buffers' codecMesh `shouldBe` loaderMesh + + it "Adapts empty weights" $ do + buffers' <- buffers + let meshEmptyWeight = set _meshWeights [] loaderMesh + + adaptMesh codecGltf buffers' codecMesh' `shouldBe` meshEmptyWeight + adaptMesh codecGltf buffers' codecMesh'' `shouldBe` meshEmptyWeight + + describe "adaptNode" $ do + let codecNode = mkCodecNode + codecNode' = mkCodecNode { Node.weights = Nothing } + codecNode'' = mkCodecNode { Node.weights = Just [] } + + it "Adapts a basic node" $ do + adaptNode codecNode `shouldBe` loaderNode + + it "Adapts empty weights" $ do + let nodeEmptyWeight = set _nodeWeights [] loaderNode + adaptNode codecNode' `shouldBe` nodeEmptyWeight + adaptNode codecNode'' `shouldBe` nodeEmptyWeight + + describe "adaptMeshPrimitives" $ do + let codecMeshPrimitive' = mkCodecMeshPrimitive + { Mesh.mode = Mesh.MeshPrimitiveMode 0 } + + it "adapts a list of primitives" $ do + buffers' <- buffers + let primitives = [codecMeshPrimitive, codecMeshPrimitive'] + expectedResult + = [ loaderMeshPrimitive, + set _meshPrimitiveMode Points loaderMeshPrimitive + ] + + adaptMeshPrimitives codecGltf buffers' primitives `shouldBe` expectedResult + + describe "adaptMeshPrimitive" $ do + it "adapts a basic primitive" $ do + buffers' <- buffers + + let codecMeshPrimitive' = mkCodecMeshPrimitive + { Mesh.indices = Nothing } + loaderMeshPrimitive' = set _meshPrimitiveIndices [] loaderMeshPrimitive + + adaptMeshPrimitive codecGltf buffers' codecMeshPrimitive `shouldBe` loaderMeshPrimitive + adaptMeshPrimitive codecGltf buffers' codecMeshPrimitive' `shouldBe` loaderMeshPrimitive' + + describe "adaptMeshPrimitiveMode" $ + it "Adapts all expected modes" $ do + adaptMeshPrimitiveMode Mesh.POINTS `shouldBe` Points + adaptMeshPrimitiveMode Mesh.LINES `shouldBe` Lines + adaptMeshPrimitiveMode Mesh.LINE_LOOP `shouldBe` LineLoop + adaptMeshPrimitiveMode Mesh.LINE_STRIP `shouldBe` LineStrip + adaptMeshPrimitiveMode Mesh.TRIANGLES `shouldBe` Triangles + adaptMeshPrimitiveMode Mesh.TRIANGLE_STRIP `shouldBe` TriangleStrip + adaptMeshPrimitiveMode Mesh.TRIANGLE_FAN `shouldBe` TriangleFan + evaluate (adaptMeshPrimitiveMode $ Mesh.MeshPrimitiveMode 7) + `shouldThrow` anyErrorCall + +buffers :: MonadUnliftIO io => io (Vector GltfBuffer) +buffers = loadBuffers mkCodecGltf + +loaderGltf :: Gltf +loaderGltf = Gltf + { gltfAsset = loaderAsset, + gltfMeshes = [loaderMesh], + gltfNodes = [loaderNode] + } + +loaderAsset :: Asset +loaderAsset = Asset + { assetVersion = "version", + assetCopyright = Just "copyright", + assetGenerator = Just "generator", + assetMinVersion = Just "minVersion" + } + +loaderMesh :: Mesh +loaderMesh = Mesh + { meshPrimitives = [loaderMeshPrimitive], + meshWeights = [1.2], + meshName = Just "mesh" + } + +loaderNode :: Node +loaderNode = Node + { nodeMeshId = Just 5, + nodeName = Just "node", + nodeRotation = Just $ V4 1 2 3 4, + nodeScale = Just $ V3 5 6 7, + nodeTranslation = Just $ V3 8 9 10, + nodeWeights = [11, 12, 13] + } + +loaderMeshPrimitive :: MeshPrimitive +loaderMeshPrimitive = MeshPrimitive + { meshPrimitiveMode = Triangles, + meshPrimitiveIndices = [1..4], + meshPrimitivePositions = map (\x -> V3 x x x) [1..4], + meshPrimitiveNormals = [] + } diff --git a/test/Text/GLTF/Loader/BufferAccessorSpec.hs b/test/Text/GLTF/Loader/BufferAccessorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Text/GLTF/Loader/BufferAccessorSpec.hs @@ -0,0 +1,94 @@ +module Text.GLTF.Loader.BufferAccessorSpec (spec) where + +import Text.GLTF.Loader.BufferAccessor +import Text.GLTF.Loader.Test.MkGltf + +import Linear (V3(..)) +import Data.Binary.Builder +import Data.Binary.Get (runGet) +import Data.Binary.Put (putFloatle, runPut) +import Data.ByteString.Lazy (fromStrict, toStrict) +import RIO +import RIO.Vector.Partial ((!)) +import Test.Hspec +import qualified Codec.GlTF as GlTF +import qualified Codec.GlTF.Accessor as Accessor +import qualified Codec.GlTF.Buffer as Buffer +import qualified Codec.GlTF.BufferView as BufferView +import qualified Codec.GlTF.URI as URI + +spec :: Spec +spec = do + let gltf = mkCodecGltf + + describe "loadBuffers" $ do + it "Reads buffers from GlTF" $ do + buffers <- loadBuffers gltf + + let (GltfBuffer buffer') = buffers ! 0 + values = runGet (getScalar (fromIntegral <$> getUnsignedShort)) . fromStrict $ buffer' + + values `shouldBe` ([1..4] :: [Integer]) + + it "Handles malformed URI" $ do + let gltf' = gltf + { GlTF.buffers = Just + [ mkCodecBufferIndices { Buffer.uri = Just $ URI.URI "uh oh!" } ] + } + + loadBuffers gltf' `shouldThrow` anyException + + it "Handles no buffer" $ do + let gltf' = gltf { GlTF.buffers = Nothing } + buffers <- loadBuffers gltf' + + buffers `shouldBe` [] + + + describe "vertexIndices" $ do + it "Reads basic values from buffer" $ do + vertexIndices gltf buffers' accessorIdIndices `shouldBe` [1, 2, 3, 4] + + it "Returns empty when accessor not defined" $ do + let gltf' = gltf { GlTF.accessors = Nothing } + vertexIndices gltf' buffers' accessorIdIndices `shouldBe` [] + + it "Returns empty when buffer not found" $ do + let bufferView = mkCodecBufferViewIndices { BufferView.buffer = Buffer.BufferIx 99 } + gltf' = gltf { GlTF.bufferViews = Just [bufferView] } + vertexIndices gltf' buffers' accessorIdIndices `shouldBe` [] + + describe "vertexPositions" $ do + it "Reads basic values from buffer" $ do + vertexPositions gltf buffers' accessorIdPositions `shouldBe` + [ V3 1 1 1, + V3 2 2 2, + V3 3 3 3, + V3 4 4 4 + ] + + it "Returns empty when accessor not defined" $ do + let gltf' = gltf { GlTF.accessors = Nothing } + vertexPositions gltf' buffers' accessorIdPositions `shouldBe` [] + + it "Returns empty when buffer not found" $ do + let bufferView = mkCodecBufferViewIndices { BufferView.buffer = Buffer.BufferIx 99 } + gltf' = gltf { GlTF.bufferViews = Just [bufferView] } + vertexPositions gltf' buffers' accessorIdPositions `shouldBe` [] + +buffers' :: Vector GltfBuffer +buffers' = [bufferIndices, bufferPositions] + +accessorIdIndices :: Accessor.AccessorIx +accessorIdIndices = 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]) + +bufferPositions :: GltfBuffer +bufferPositions = GltfBuffer . toStrict . runPut $ putPositions + where putPositions = mapM_ (replicateM_ 3 . putFloatle) ([1..4] :: [Float]) diff --git a/test/Text/GLTF/Loader/Test/MkGltf.hs b/test/Text/GLTF/Loader/Test/MkGltf.hs new file mode 100644 --- /dev/null +++ b/test/Text/GLTF/Loader/Test/MkGltf.hs @@ -0,0 +1,177 @@ +module Text.GLTF.Loader.Test.MkGltf where + +import Text.GLTF.Loader.Adapter (attributePosition) + +import Data.Binary.Builder +import Data.Binary.Put (putFloatle, runPut) +import Data.ByteString.Base64 (encodeBase64) +import Data.ByteString.Lazy (toStrict) +import Foreign (Storable(..)) +import Linear (V3(..)) +import RIO +import qualified Codec.GlTF as GlTF +import qualified Codec.GlTF.Accessor as Accessor +import qualified Codec.GlTF.Asset as Asset +import qualified Codec.GlTF.Buffer as Buffer +import qualified Codec.GlTF.BufferView as BufferView +import qualified Codec.GlTF.Mesh as Mesh +import qualified Codec.GlTF.Node as Node +import qualified Codec.GlTF.URI as URI +import qualified Data.HashMap.Strict as HashMap + +mkCodecGltf :: GlTF.GlTF +mkCodecGltf = GlTF.GlTF + { asset = mkCodecAsset, + extensionsUsed = Nothing, + extensionsRequired = Nothing, + accessors = Just [mkCodecAccessorIndices, mkCodecAccessorPositions], + animations = Nothing, + buffers = Just [mkCodecBufferIndices, mkCodecBufferPositions], + bufferViews = Just [mkCodecBufferViewIndices, mkCodecBufferViewPositions], + cameras = Nothing, + images = Nothing, + materials = Nothing, + meshes = Just [mkCodecMesh], + nodes = Just [mkCodecNode], + samplers = Nothing, + scenes = Nothing, + skins = Nothing, + textures = Nothing, + extensions = Nothing, + extras = Nothing + } + +mkCodecAsset :: Asset.Asset +mkCodecAsset = Asset.Asset + { version = "version", + copyright = Just "copyright", + generator = Just "generator", + minVersion = Just "minVersion", + extensions = Nothing, + extras = Nothing + } + +mkCodecAccessorIndices :: Accessor.Accessor +mkCodecAccessorIndices = Accessor.Accessor + { + bufferView = Just $ BufferView.BufferViewIx 0, + byteOffset = 0, + componentType = Accessor.ComponentType 5123, + count = 4, + extensions = Nothing, + extras = Nothing, + max = Nothing, + min = Nothing, + name = Just "Accessor Indices", + normalized = False, + sparse = Nothing, + type' = Accessor.AttributeType "SCALAR" + } + +mkCodecAccessorPositions :: Accessor.Accessor +mkCodecAccessorPositions = Accessor.Accessor + { + bufferView = Just $ BufferView.BufferViewIx 1, + byteOffset = 0, + componentType = Accessor.ComponentType 5126, + count = 4, + extensions = Nothing, + extras = Nothing, + max = Nothing, + min = Nothing, + name = Just "Accessor Positions", + normalized = False, + sparse = Nothing, + type' = Accessor.AttributeType "VEC3" + } + +mkCodecBufferViewIndices :: BufferView.BufferView +mkCodecBufferViewIndices = BufferView.BufferView + { buffer = Buffer.BufferIx 0, + byteOffset = 0, + byteLength = sizeOf (undefined :: Word16) * 4, + byteStride = Nothing, + target = Nothing, + name = Just "BufferView Indices", + extensions = Nothing, + extras = Nothing + } + +mkCodecBufferViewPositions :: BufferView.BufferView +mkCodecBufferViewPositions = BufferView.BufferView + { buffer = Buffer.BufferIx 1, + byteOffset = 0, + byteLength = sizeOf (undefined :: V3 Float) * 4, + byteStride = Nothing, + target = Nothing, + name = Just "BufferView Positions", + extensions = Nothing, + extras = Nothing + } + +mkCodecBufferIndices :: Buffer.Buffer +mkCodecBufferIndices = Buffer.Buffer + { byteLength = sizeOf (undefined :: Word16) * 4, + uri = Just mkCodecBufferUriIndices, + extensions = Nothing, + extras = Nothing, + name = Just "Buffer Indices" + } + +mkCodecBufferPositions :: Buffer.Buffer +mkCodecBufferPositions = Buffer.Buffer + { byteLength = sizeOf (undefined :: V3 Float) * 4, + uri = Just mkCodecBufferUriPositions, + extensions = Nothing, + extras = Nothing, + name = Just "Buffer Positions" + } + +mkCodecMesh :: Mesh.Mesh +mkCodecMesh = Mesh.Mesh + { primitives = [mkCodecMeshPrimitive], + weights = Just [1.2], + name = Just "mesh", + extensions = Nothing, + extras = Nothing + } + +mkCodecBufferUriIndices :: URI.URI +mkCodecBufferUriIndices = URI.URI uriText + where uriText = "data:application/octet-stream;base64," <> encodedText + encodedText = encodeBase64. toStrict . toLazyByteString $ putIndices + putIndices = foldr ((<>) . putWord16le) empty ([1..4] :: [Word16]) + +mkCodecBufferUriPositions :: URI.URI +mkCodecBufferUriPositions = URI.URI uriText + where uriText = "data:application/octet-stream;base64," <> encodedText + encodedText = encodeBase64. toStrict . runPut $ putPositions + putPositions = mapM_ (replicateM_ 3 . putFloatle) ([1..4] :: [Float]) + +mkCodecMeshPrimitive :: Mesh.MeshPrimitive +mkCodecMeshPrimitive = Mesh.MeshPrimitive + { attributes = HashMap.fromList + [(attributePosition, Accessor.AccessorIx 1)], + mode = Mesh.MeshPrimitiveMode 4, + indices = Just $ Accessor.AccessorIx 0, + material = Nothing, + targets = Nothing, + extensions = Nothing, + extras = Nothing + } + +mkCodecNode :: Node.Node +mkCodecNode = Node.Node + { camera = Nothing, + children = Nothing, + skin = Nothing, + matrix = Nothing, + mesh = Just (Mesh.MeshIx 5), + rotation = Just (1, 2, 3, 4), + scale = Just (5, 6, 7), + translation = Just (8, 9, 10), + weights = Just [11, 12, 13], + name = Just "node", + extensions = Nothing, + extras = Nothing + } diff --git a/test/Text/GLTF/LoaderSpec.hs b/test/Text/GLTF/LoaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Text/GLTF/LoaderSpec.hs @@ -0,0 +1,93 @@ +module Text.GLTF.LoaderSpec (spec) where + +import Text.GLTF.Loader + +import Lens.Micro +import Linear (V3(..)) +import RIO +import Test.Hspec + +spec :: Spec +spec = do + describe "fromByteString" $ do + it "Parses embedded gltf content" $ do + gltfText <- readFileBinary "data/cube.gltf" + res <- fromByteString gltfText + res `shouldSatisfy` has _Right + + it "Fails on invalid content" $ do + res <- fromByteString "Invalid GLTF" + res `shouldSatisfy` has (_Left . _ReadError) + + describe "fromFile" $ do + it "Parses embedded gltf file" $ do + gltf <- fromFile "data/cube.gltf" + gltf `shouldSatisfy` has _Right + + it "Parses expected nodes" $ do + gltf <- fromFile "data/cube.gltf" + let expected = Gltf + { gltfAsset = Asset + { assetVersion = "2.0", + assetGenerator = Just "Khronos glTF Blender I/O v3.2.40", + assetCopyright = Nothing, + assetMinVersion = Nothing + }, + + gltfMeshes + = [ Mesh + { meshPrimitives + = [ MeshPrimitive + { meshPrimitiveMode = Triangles, + meshPrimitiveIndices + = [ 1, 14, 20, 1, 20, 7, 10, 6, 19, 10, 19, 23, + 21, 18, 12, 21, 12, 15, 16, 3, 9, 16, 9, + 22, 5, 2, 8, 5, 8, 11, 17, 13, 0, 17, 0, 4 + ], + meshPrimitivePositions + = [ V3 1.0 1.0 (-1.0), -- 1 + V3 1.0 1.0 (-1.0), -- 2 + V3 1.0 1.0 (-1.0), -- 3 + V3 1.0 (-1.0) (-1.0), -- 4 + V3 1.0 (-1.0) (-1.0), -- 5 + V3 1.0 (-1.0) (-1.0), -- 6 + V3 1.0 1.0 1.0, -- 7 + V3 1.0 1.0 1.0, -- 8 + V3 1.0 1.0 1.0, -- 9 + V3 1.0 (-1.0) 1.0, -- 10 + V3 1.0 (-1.0) 1.0, -- 11 + V3 1.0 (-1.0) 1.0, -- 12 + V3 (-1.0) 1.0 (-1.0), -- 13 + V3 (-1.0) 1.0 (-1.0), -- 14 + V3 (-1.0) 1.0 (-1.0), -- 15 + V3 (-1.0) (-1.0) (-1.0),-- 16 + V3 (-1.0) (-1.0) (-1.0),-- 17 + V3 (-1.0) (-1.0) (-1.0),-- 18 + V3 (-1.0) 1.0 1.0, -- 19 + V3 (-1.0) 1.0 1.0, -- 20 + V3 (-1.0) 1.0 1.0, -- 21 + V3 (-1.0) (-1.0) 1.0, -- 22 + V3 (-1.0) (-1.0) 1.0, -- 23 + V3 (-1.0) (-1.0) 1.0 -- 24 + ], + meshPrimitiveNormals = [] + } + ], + meshWeights = [], + meshName = Just "Cube" + } + ], + + gltfNodes + = [ Node + { nodeMeshId = Just 0, + nodeName = Just "Cube", + nodeRotation = Nothing, + nodeScale = Nothing, + nodeTranslation = Nothing, + nodeWeights = [] + } + ] + } + + gltf `shouldBe` Right expected