X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fassimp.scm;h=9f6bfc2a3959bdee06358a4175b0374aa866305b;hb=cc3b67814bd3d1d26e1d1d5523db7bf19384bf33;hp=e4d8f8e6f1b78e342a74c5e10e6f68f0bc11123a;hpb=279b472d96c8bbe3edb18f1bd3998bb39b65324b;p=guile-assimp.git diff --git a/src/assimp.scm b/src/assimp.scm index e4d8f8e..9f6bfc2 100644 --- a/src/assimp.scm +++ b/src/assimp.scm @@ -16,7 +16,10 @@ (define-module (assimp assimp) - #:use-module (rnrs bytevectors) + #:use-module (assimp low-level) + #:use-module (assimp low-level material) + #:use-module (assimp low-level mesh) + #:use-module (assimp low-level scene) #:use-module (system foreign)) (define libassimp (dynamic-link "libassimp")) @@ -27,116 +30,103 @@ (list '* unsigned-int))) -;;; Type Generation - -(define-syntax define-type - (lambda (x) - (define (mk-string . args) - (string-concatenate - (map (lambda (a) - (if (string? a) - a - (symbol->string (syntax->datum a)))) - args))) - (define (mk-symbol . args) - (datum->syntax x - (string->symbol - (apply mk-string args)))) - (syntax-case x () - ((_ name (field field-proc) ...) - (with-syntax ((type? (mk-symbol #'name "?")) - (wrap-type (mk-symbol "wrap-" #'name)) - (unwrap-type (mk-symbol "unwrap-" #'name)) - (output-string (mk-string "#<" #'name " ~x>")) - (type-contents (mk-symbol #'name "-contents"))) - #'(begin - (define-wrapped-pointer-type name - type? - wrap-type unwrap-type - (lambda (x p) - (format p output-string - (pointer-address (unwrap-type x))))) - (define (type-contents wrapped) - (let ((unwrapped (unwrap-type wrapped))) - (cond ((= (pointer-address unwrapped) 0) - '()) - (else - (filter - (lambda (f) - (not (null? (cdr f)))) - (list (cons 'field (field-proc unwrapped)) - ...)))))))))))) - - -(define (bv-uint-ref pointer index) - (bytevector-uint-ref - (pointer->bytevector pointer 4 index) - 0 - (native-endianness) - 4)) - -(define* (get-pointer-of-pointers-procedure num-index root-index #:optional wrap-proc) - (lambda (pointer) - (let* ((num (bv-uint-ref pointer num-index)) - (rootp (make-pointer (bv-uint-ref pointer root-index)))) - (let loop ((i 0)) - (cond ((= i num) - '()) - (else - (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i)))) - (wp (if wrap-proc (wrap-proc p) p))) - (cons wp (loop (+ i 1)))))))))) - ;;; Scenes -(define-type scene - (flags (lambda (p) (bv-uint-ref p 0))) - (root-node (lambda (p) (wrap-node (make-pointer (bv-uint-ref p 4))))) - (meshes (get-pointer-of-pointers-procedure 8 12 wrap-mesh)) - (materials (get-pointer-of-pointers-procedure 16 20)) - (animations (get-pointer-of-pointers-procedure 24 28)) - (textures (get-pointer-of-pointers-procedure 32 36)) - (lights (get-pointer-of-pointers-procedure 40 44)) - (cameras (get-pointer-of-pointers-procedure 48 52))) +(define-conversion-type parse-aiScene -> scene + (flags (field 'mFlags)) + (root-node (wrap (field 'mRootNode) wrap-node)) + (meshes (wrap (array (field 'mNumMeshes) (field 'mMeshes)) wrap-mesh)) + (materials (wrap (array (field 'mNumMaterials) (field 'mMaterials)) wrap-material)) + (animations (array (field 'mNumAnimations) (field 'mAnimations))) + (textures (array (field 'mNumTextures) (field 'mTextures))) + (lights (array (field 'mNumLights) (field 'mLights))) + (cameras (array (field 'mNumCameras) (field 'mCameras)))) (define (load-scene filename flags) (wrap-scene (aiImportFile (string->pointer filename) - flags))) + flags))) (export load-scene - unwrap-scene scene? - scene-contents) + scene-contents + scene-flags + scene-root-node + scene-meshes + scene-materials + scene-animations + scene-textures + scene-lights + scene-cameras) ;;; Nodes -(define-type node - (name (lambda (p) (bv-uint-ref p 0))) ;check, it's a struct - (transformation (lambda (p) (bv-uint-ref p 1028))) ;check, it's a struct - (parent (lambda (p) (bv-uint-ref p 1092))) - (children (get-pointer-of-pointers-procedure 1096 1100)) - (meshes (get-pointer-of-pointers-procedure 1104 1108))) +(define-conversion-type parse-aiNode -> node + (name (sized-string (field 'mName))) + (transformation (field 'mTransformation)) + (parent (wrap (field 'mParent) wrap-node)) + (children (wrap (array (field 'mNumChildren) (field 'mChildren)) wrap-node)) + (meshes (array (field 'mNumMeshes) (field 'mMeshes)))) (export node? - node-contents) + node-contents + node-name + node-transformation + node-parent + node-children + node-meshes) ;;; Meshes -(define-type mesh - (num-primitive-types (lambda (p) (bv-uint-ref p 0))) - (vertices (get-pointer-of-pointers-procedure 4 12)) - (faces (get-pointer-of-pointers-procedure 8 124)) - (normals (lambda (p) (bv-uint-ref p 16))) - (tangents (lambda (p) (bv-uint-ref p 20))) - (bitangents (lambda (p) (bv-uint-ref p 24))) - (colors (lambda (p) (bv-uint-ref p 28))) ;AI_MAX_NUMBER_OF_COLOR_SETS - (texture-coords (lambda (p) (bv-uint-ref p 60))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS - (num-uv-components (lambda (p) (bv-uint-ref p 92))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS - (bones (get-pointer-of-pointers-procedure 128 132)) - (material-index (lambda (p) (bv-uint-ref p 136)))) +(define-conversion-type parse-aiMesh -> mesh + (name (sized-string (field 'mName))) + (primitive-types (field 'mPrimitiveTypes)) + (vertices (array (field 'mNumVertices) (field 'mVertices) #:element-proc get-element-address)) + (faces (wrap (array (field 'mNumFaces) (field 'mFaces) #:element-size 8 #:element-proc get-element-address) wrap-face)) + (normals (array (field 'mNumVertices) (field 'mNormals) #:element-size 12 #:element-proc get-element-address)) + (tangents (array (field 'mNumVertices) (field 'mTangents) #:element-size 12 #:element-proc get-element-address)) + (bitangents (array (field 'mNumVertices) (field 'mBitangents) #:element-size 12 #:element-proc get-element-address)) + (colors (field 'mColors)) + (texture-coords (field 'mTextureCoords)) + (num-uv-components (field 'mNumUVComponents)) + (bones (array (field 'mNumBones) (field 'mBones))) + (material-index (field 'mMaterialIndex))) (export mesh? - mesh-contents) + mesh-contents + mesh-name + mesh-primitive-types + mesh-vertices + mesh-faces + mesh-normals + mesh-tangents + mesh-bitangents + mesh-colors + mesh-texture-coords + mesh-num-uv-components + mesh-bones + mesh-material-index) + + +;;; Materials + +(define-conversion-type parse-aiMaterial -> material + (properties (array (field 'mNumProperties) (field 'mProperties))) + (num-allocated (field 'mNumAllocated))) + +(export material? + material-contents + material-properties + material-num-allocated) + + +;;; Faces + +(define-conversion-type parse-aiFace -> face + (indices (array (field 'mNumIndices) (field 'mIndices)))) + +(export face? + face-contents + face-indices)