X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fassimp.scm;h=03c9b331517be8a07599ad9c1830451aeecf1a98;hb=ebdf468033662662f62674baf9bfa915e6f6a262;hp=7422b8175f7897ce4571b94759c0c371c57ae497;hpb=63cca7faa50c513c8aa201d15336e555438fddb5;p=guile-assimp.git diff --git a/src/assimp.scm b/src/assimp.scm index 7422b81..03c9b33 100644 --- a/src/assimp.scm +++ b/src/assimp.scm @@ -16,6 +16,8 @@ (define-module (assimp assimp) + #:use-module (assimp low-level material) + #:use-module (assimp low-level mesh) #:use-module (assimp low-level scene) #:use-module (ice-9 iconv) #:use-module (rnrs bytevectors) @@ -45,7 +47,7 @@ (string->symbol (apply mk-string args)))) (syntax-case x () - ((_ name (field field-proc) ...) + ((_ name parser (field field-proc) ...) (with-syntax ((type? (mk-symbol #'name "?")) (wrap-type (mk-symbol "wrap-" #'name)) (unwrap-type (mk-symbol "unwrap-" #'name)) @@ -69,7 +71,6 @@ (list (cons 'field (field-proc unwrapped)) ...)))))))))))) - (define (bv-uint-ref pointer index) (bytevector-uint-ref (pointer->bytevector pointer 4 index) @@ -127,85 +128,202 @@ (wp (if wrap-proc (wrap-proc p) p))) (cons wp (loop (+ i 1)))))))))) +(define-syntax define-conversion-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 (->) + ((_ parser -> name (field-name 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")) + (type-parse (mk-symbol #'name "-parse")) + ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...)))) + #'(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-parse wrapped) + (let ((unwrapped (unwrap-type wrapped))) + (cond ((= (pointer-address unwrapped) 0) + '()) + (else + (parser unwrapped))))) + (define (type-contents wrapped) + (let ((alist (type-parse wrapped))) + (list (cons 'field-name (field-proc alist)) + ...))) + (define (field-reader wrapped) + (let ((alist (type-parse wrapped))) + (field-proc alist))) + ...)))))) + +(define (field name) + (lambda (alist) + (assoc-ref alist name))) + +(define (get-element-address root-pointer offset) + (make-pointer (+ (pointer-address root-pointer) offset))) + +(define* (array size-tag root-tag #:key (element-size 4) (element-proc bv-uint-ref)) + (lambda (alist) + (let ((size (assoc-ref alist size-tag)) + (root (assoc-ref alist root-tag))) + (cond ((= (pointer-address root) 0) + '()) + (else + (let loop ((i 0)) + (cond ((= i size) + '()) + (else + (cons (element-proc root (* element-size i)) + (loop (+ i 1))))))))))) + +(define (wrap proc wrap-proc) + (define (make-wrap element) + (let ((pointer + (cond ((pointer? element) + (if (= (pointer-address element) 0) + #f + element)) + ((= element 0) + #f) + (else + (make-pointer element))))) + (cond (pointer + (wrap-proc pointer)) + (else + #f)))) + (lambda (alist) + (let ((res (proc alist))) + (cond ((list? res) + (map make-wrap res)) + (else + (make-wrap res)))))) + +(define (sized-string string-tag) + (lambda (alist) + (let ((s (assoc-ref alist string-tag))) + (cond (s + (bytevector->string + (u8-list->bytevector (list-head (cadr s) (car s))) + (fluid-ref %default-port-encoding))) + (else + #f))))) + + ;;; 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 8 12 wrap-mesh)) - (materials (get-pointer-of-pointers 16 20 wrap-material)) - (animations (get-pointer-of-pointers 24 28)) - (textures (get-pointer-of-pointers 32 36)) - (lights (get-pointer-of-pointers 40 44)) - (cameras (get-pointer-of-pointers 48 52))) - -(define (load-scene filename flags) - (wrap-scene - (aiImportFile (string->pointer filename) - flags))) - -(define (load-scene filename flags) - (parse-aiNode - (assoc-ref - (parse-aiScene - (aiImportFile (string->pointer filename) - flags)) - 'mRootNode))) +(define-conversion-type parse-aiScene -> scene + (flags (field 'mFlags)) + (root-node (wrap (field 'mRootNode) wrap-node)) + (meshes (wrap (array 'mNumMeshes 'mMeshes) wrap-mesh)) + (materials (wrap (array 'mNumMaterials 'mMaterials) wrap-material)) + (animations (array 'mNumAnimations 'mAnimations)) + (textures (array 'mNumTextures 'mTextures)) + (lights (array 'mNumLights 'mLights)) + (cameras (array 'mNumCameras 'mCameras))) + + (define (load-scene filename flags) + (wrap-scene + (aiImportFile (string->pointer filename) + 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 (get-aiString 0)) - (transformation (lambda (p) (array->list (pointer->bytevector p 16 1028 'f32)))) - (parent (get-pointer 1092 wrap-node)) - (children (get-pointer-of-pointers 1096 1100 wrap-node)) - (meshes (get-array 1104 1108 'u32))) +(define-conversion-type parse-aiNode -> node + (name (sized-string 'mName)) + (transformation (field 'mTransformation)) + (parent (wrap (field 'mParent) wrap-node)) + (children (wrap (array 'mNumChildren 'mChildren) wrap-node)) + (meshes (array 'mNumMeshes 'mMeshes))) (export node? - node-contents) + node-contents + node-name + node-transformation + node-parent + node-children + node-meshes) ;;; Meshes -(define AI_MAX_NUMBER_OF_COLOR_SETS 8) - -(define-type mesh - (num-primitive-types (lambda (p) (bv-uint-ref p 0))) - (vertices (get-pointer-of-pointers 4 12)) - (faces (get-structs-array 8 124 8 wrap-face)) - (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 128 132)) - (material-index (lambda (p) (bv-uint-ref p 136)))) +(define-conversion-type parse-aiMesh -> mesh + (name (sized-string 'mName)) + (primitive-types (field 'mPrimitiveTypes)) + (vertices (array 'mNumVertices 'mVertices #:element-proc get-element-address)) + (faces (wrap (array 'mNumFaces 'mFaces #:element-size 8 #:element-proc get-element-address) wrap-face)) + (normals (array 'mNumVertices 'mNormals #:element-size 12 #:element-proc get-element-address)) + (tangents (array 'mNumVertices 'mTangents #:element-size 12 #:element-proc get-element-address)) + (bitangents (array 'mNumVertices 'mBitangents #:element-size 12 #:element-proc get-element-address)) + (colors (field 'mColors)) + (texture-coords (field 'mTextureCoords)) + (num-uv-components (field 'mNumUVComponents)) + (bones (array 'mNumBones '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-type material - (properties (get-pointer-of-pointers 4 0)) - (allocated (lambda (p) (bv-uint-ref p 8)))) +(define-conversion-type parse-aiMaterial -> material + (properties (array 'mNumProperties 'mProperties)) + (num-allocated (field 'mNumAllocated))) (export material? - material-contents) + material-contents + material-properties + material-num-allocated) ;;; Faces -(define-type face - (indices (get-array 0 4 'u32))) +(define-conversion-type parse-aiFace -> face + (indices (array 'mNumIndices 'mIndices))) (export face? - face-contents) + face-contents + face-indices)