X-Git-Url: https://git.jsancho.org/?p=guile-assimp.git;a=blobdiff_plain;f=src%2Fassimp.scm;h=9954e8212bcb47cab6f070bc22e4f80654e091bb;hp=03c9b331517be8a07599ad9c1830451aeecf1a98;hb=d53c6fdc3383148b2e73599fb955693aa6f597a5;hpb=ebdf468033662662f62674baf9bfa915e6f6a262 diff --git a/src/assimp.scm b/src/assimp.scm index 03c9b33..9954e82 100644 --- a/src/assimp.scm +++ b/src/assimp.scm @@ -16,314 +16,273 @@ (define-module (assimp assimp) + #:use-module (assimp low-level) + #:use-module (assimp low-level cimport) + #:use-module (assimp low-level color) #:use-module (assimp low-level material) + #:use-module (assimp low-level matrix) #:use-module (assimp low-level mesh) #:use-module (assimp low-level scene) - #:use-module (ice-9 iconv) - #:use-module (rnrs bytevectors) + #:use-module (assimp low-level types) + #:use-module (assimp low-level vector) #:use-module (system foreign)) -(define libassimp (dynamic-link "libassimp")) - -(define aiImportFile - (pointer->procedure '* - (dynamic-func "aiImportFile" libassimp) - (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 parser (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-aiString index) - (lambda (pointer) - (let* ((length (bv-uint-ref pointer index)) - (data (pointer->bytevector pointer length (+ index 4)))) - (bytevector->string data (fluid-ref %default-port-encoding))))) - -(define* (get-pointer index #:optional wrap-proc) - (lambda (pointer) - (let ((p (bv-uint-ref pointer index))) - (cond ((= p 0) '()) - (else - (let ((p2 (make-pointer p))) - (list - (cond (wrap-proc (wrap-proc p2)) - (else p2))))))))) - -(define (get-array num-index root-index type) - (lambda (pointer) - (let ((num (bv-uint-ref pointer num-index)) - (rootp (make-pointer (bv-uint-ref pointer root-index)))) - (cond ((> num 0) - (array->list - (pointer->bytevector rootp num 0 type))) - (else - '()))))) - -(define* (get-structs-array num-index root-index struct-size #:optional wrap-proc) - (lambda (pointer) - (let ((num (bv-uint-ref pointer num-index)) - (rootp (bv-uint-ref pointer root-index))) - (let loop ((i (- num 1))) - (cond ((< i 0) - '()) - (else - (let* ((p (make-pointer (+ rootp (* i struct-size)))) - (wp (if wrap-proc (wrap-proc p) p))) - (cons wp (loop (- i 1)))))))))) - -(define* (get-pointer-of-pointers 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)))))))))) - -(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-conversion-type parse-aiScene -> scene +(define-conversion-type parse-aiScene -> ai-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 - scene? - scene-contents - scene-flags - scene-root-node - scene-meshes - scene-materials - scene-animations - scene-textures - scene-lights - scene-cameras) + (root-node (wrap (field 'mRootNode) wrap-ai-node)) + (meshes (wrap (array (field 'mNumMeshes) (field 'mMeshes)) wrap-ai-mesh)) + (materials (wrap (array (field 'mNumMaterials) (field 'mMaterials)) wrap-ai-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)))) + +(export ai-scene? + ai-scene-contents + ai-scene-flags + ai-scene-root-node + ai-scene-meshes + ai-scene-materials + ai-scene-animations + ai-scene-textures + ai-scene-lights + ai-scene-cameras) ;;; Nodes -(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))) +(define-conversion-type parse-aiNode -> ai-node + (name (sized-string (field 'mName))) + (transformation (wrap (parse-aiMatrix4x4 (field 'mTransformation) #:reverse #t) wrap-ai-matrix4x4)) + (parent (wrap (field 'mParent) wrap-ai-node)) + (children (wrap (array (field 'mNumChildren) (field 'mChildren)) wrap-ai-node)) + (meshes (array (field 'mNumMeshes) (field 'mMeshes)))) -(export node? - node-contents - node-name - node-transformation - node-parent - node-children - node-meshes) +(export ai-node? + ai-node-contents + ai-node-name + ai-node-transformation + ai-node-parent + ai-node-children + ai-node-meshes) ;;; Meshes -(define-conversion-type parse-aiMesh -> mesh - (name (sized-string 'mName)) +(define-conversion-type parse-aiMesh -> ai-mesh + (name (sized-string (field '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)) + (vertices (wrap + (array (field 'mNumVertices) (field 'mVertices) #:element-proc get-element-address) + wrap-ai-vector3d)) + (faces (wrap + (array (field 'mNumFaces) (field 'mFaces) #:element-size 8 #:element-proc get-element-address) + wrap-ai-face)) + (normals (wrap + (array (field 'mNumVertices) (field 'mNormals) #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (tangents (wrap + (array (field 'mNumVertices) (field 'mTangents) #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (bitangents (wrap + (array (field 'mNumVertices) (field 'mBitangents) #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (colors (map + (lambda (c) + (wrap + (array (field 'mNumVertices) c #:element-size 16 #:element-proc get-element-address) + wrap-ai-color4d)) + (field 'mColors))) + (texture-coords (map + (lambda (tc) + (wrap + (array (field 'mNumVertices) tc #:element-size 12 #:element-proc get-element-address) + wrap-ai-vector3d)) + (field 'mTextureCoords))) (num-uv-components (field 'mNumUVComponents)) - (bones (array 'mNumBones 'mBones)) - (material-index (field 'mMaterialIndex)) -) - -(export mesh? - 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) + (bones (wrap (array (field 'mNumBones) (field 'mBones)) wrap-ai-bone)) + (material-index (field 'mMaterialIndex))) + +(export ai-mesh? + ai-mesh-contents + ai-mesh-name + ai-mesh-primitive-types + ai-mesh-vertices + ai-mesh-faces + ai-mesh-normals + ai-mesh-tangents + ai-mesh-bitangents + ai-mesh-colors + ai-mesh-texture-coords + ai-mesh-num-uv-components + ai-mesh-bones + ai-mesh-material-index) ;;; Materials -(define-conversion-type parse-aiMaterial -> material - (properties (array 'mNumProperties 'mProperties)) +(define-conversion-type parse-aiMaterial -> ai-material + (properties (array (field 'mNumProperties) (field 'mProperties))) (num-allocated (field 'mNumAllocated))) -(export material? - material-contents - material-properties - material-num-allocated) +(export ai-material? + ai-material-contents + ai-material-properties + ai-material-num-allocated) ;;; Faces -(define-conversion-type parse-aiFace -> face - (indices (array 'mNumIndices 'mIndices))) - -(export face? - face-contents - face-indices) +(define-conversion-type parse-aiFace -> ai-face + (indices (array (field 'mNumIndices) (field 'mIndices)))) + +(export ai-face? + ai-face-contents + ai-face-indices) + + +;;; Vectors + +(define-conversion-type parse-aiVector2D -> ai-vector2d + (x (field 'x)) + (y (field 'y))) + +(export ai-vector2d? + ai-vector2d-contents + ai-vector2d-x + ai-vector2d-y) + +(define-conversion-type parse-aiVector3D -> ai-vector3d + (x (field 'x)) + (y (field 'y)) + (z (field 'z))) + +(export ai-vector3d? + ai-vector3d-contents + ai-vector3d-x + ai-vector3d-y + ai-vector3d-z) + + +;;; Matrixes + +(define-conversion-type parse-aiMatrix3x3 -> ai-matrix3x3 + (a1 (field 'a1)) + (a2 (field 'a2)) + (a3 (field 'a3)) + (b1 (field 'b1)) + (b2 (field 'b2)) + (b3 (field 'b3)) + (c1 (field 'c1)) + (c2 (field 'c2)) + (c3 (field 'c3))) + +(export ai-matrix3x3? + ai-matrix3x3-contents + ai-matrix3x3-a1 + ai-matrix3x3-a2 + ai-matrix3x3-a3 + ai-matrix3x3-b1 + ai-matrix3x3-b2 + ai-matrix3x3-b3 + ai-matrix3x3-c1 + ai-matrix3x3-c2 + ai-matrix3x3-c3) + +(define-conversion-type parse-aiMatrix4x4 -> ai-matrix4x4 + (a1 (field 'a1)) + (a2 (field 'a2)) + (a3 (field 'a3)) + (a4 (field 'a4)) + (b1 (field 'b1)) + (b2 (field 'b2)) + (b3 (field 'b3)) + (b4 (field 'b4)) + (c1 (field 'c1)) + (c2 (field 'c2)) + (c3 (field 'c3)) + (c4 (field 'c4)) + (d1 (field 'd1)) + (d2 (field 'd2)) + (d3 (field 'd3)) + (d4 (field 'd4))) + +(export ai-matrix4x4? + ai-matrix4x4-contents + ai-matrix4x4-a1 + ai-matrix4x4-a2 + ai-matrix4x4-a3 + ai-matrix4x4-a4 + ai-matrix4x4-b1 + ai-matrix4x4-b2 + ai-matrix4x4-b3 + ai-matrix4x4-b4 + ai-matrix4x4-c1 + ai-matrix4x4-c2 + ai-matrix4x4-c3 + ai-matrix4x4-c4 + ai-matrix4x4-d1 + ai-matrix4x4-d2 + ai-matrix4x4-d3 + ai-matrix4x4-d4) + + +;;; Colors + +(define-conversion-type parse-aiColor4D -> ai-color4d + (r (field 'r)) + (g (field 'g)) + (b (field 'b)) + (a (field 'a))) + +(export ai-color4d? + ai-color4d-contents + ai-color4d-r + ai-color4d-g + ai-color4d-b + ai-color4d-a) + + +;;; Bones + +(define-conversion-type parse-aiBone -> ai-bone + (name (sized-string (field 'mName))) + (weights (wrap + (array (field 'mNumWeights) (field 'mWeights) #:element-size 8 #:element-proc get-element-address) + wrap-ai-vertex-weight)) + (offset-matrix (wrap (parse-aiMatrix4x4 (field 'mOffsetMatrix) #:reverse #t) wrap-ai-matrix4x4))) + +(export ai-bone? + ai-bone-contents + ai-bone-name + ai-bone-weights + ai-bone-offset-matrix) + + +;;; Weights + +(define-conversion-type parse-aiVertexWeight -> ai-vertex-weight + (vertex-id (field 'mVertexId)) + (weight (field 'mWeight))) + +(export ai-vertex-weight? + ai-vertex-weight-contents + ai-vertex-weight-vertex-id + ai-vertex-weight-weight) + + +;;; Functions + +(define-public (ai-import-file filename flags) + (wrap-ai-scene + (aiImportFile (string->pointer filename) + flags))) + +(define-public (ai-multiply-matrix4 m1 m2) + (let ((cm1 (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents m1)) #:reverse #t)) + (cm2 (parse-aiMatrix4x4 (map cdr (ai-matrix4x4-contents m2)) #:reverse #t))) + (aiMultiplyMatrix4 cm1 cm2) + (wrap-ai-matrix4x4 cm1)))