From: Javier Sancho Date: Fri, 11 Jul 2014 08:18:18 +0000 (+0200) Subject: Rewrite definitions with new conversion-types X-Git-Url: https://git.jsancho.org/?p=guile-assimp.git;a=commitdiff_plain;h=cc3b67814bd3d1d26e1d1d5523db7bf19384bf33 Rewrite definitions with new conversion-types * src/assimp.scm: Remove type generation functions and use 'field' syntax in every request to data from C parser. * src/low-level.scm: Add type generation functions using new 'field' syntax. --- diff --git a/src/assimp.scm b/src/assimp.scm index 03c9b33..9f6bfc2 100644 --- a/src/assimp.scm +++ b/src/assimp.scm @@ -16,11 +16,10 @@ (define-module (assimp assimp) + #: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 (ice-9 iconv) - #:use-module (rnrs bytevectors) #:use-module (system foreign)) (define libassimp (dynamic-link "libassimp")) @@ -31,216 +30,21 @@ (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 (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) + (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))) (export load-scene @@ -259,14 +63,14 @@ ;;; Nodes (define-conversion-type parse-aiNode -> node - (name (sized-string 'mName)) + (name (sized-string (field 'mName))) (transformation (field 'mTransformation)) (parent (wrap (field 'mParent) wrap-node)) - (children (wrap (array 'mNumChildren 'mChildren) wrap-node)) - (meshes (array 'mNumMeshes 'mMeshes))) + (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 @@ -277,19 +81,18 @@ ;;; Meshes (define-conversion-type parse-aiMesh -> mesh - (name (sized-string 'mName)) + (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)) + (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 'mNumBones 'mBones)) - (material-index (field 'mMaterialIndex)) -) + (bones (array (field 'mNumBones) (field 'mBones))) + (material-index (field 'mMaterialIndex))) (export mesh? mesh-contents @@ -310,7 +113,7 @@ ;;; Materials (define-conversion-type parse-aiMaterial -> material - (properties (array 'mNumProperties 'mProperties)) + (properties (array (field 'mNumProperties) (field 'mProperties))) (num-allocated (field 'mNumAllocated))) (export material? @@ -322,7 +125,7 @@ ;;; Faces (define-conversion-type parse-aiFace -> face - (indices (array 'mNumIndices 'mIndices))) + (indices (array (field 'mNumIndices) (field 'mIndices)))) (export face? face-contents diff --git a/src/low-level.scm b/src/low-level.scm index a184082..53bb39e 100644 --- a/src/low-level.scm +++ b/src/low-level.scm @@ -16,9 +16,13 @@ (define-module (assimp low-level) + #:use-module (ice-9 iconv) + #:use-module (rnrs bytevectors) #:use-module (system foreign)) +;;; Parsers Definition + (define-syntax define-struct-parser (lambda (x) (syntax-case x () @@ -30,4 +34,122 @@ '(field-name ...) (parse-c-struct pointer (list field-type ...))))))))) -(export define-struct-parser) +(export-syntax define-struct-parser) + + +;;; Type Generation + +(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 type-contents type-parse (field-name field-proc) ...) + (define-field-reader field-reader type-parse field-proc) + ... + )))))) + +(define-macro (define-type-contents type-contents type-parse . fields) + `(define (,type-contents wrapped) + (let ((alist (,type-parse wrapped))) + (list ,@(map (lambda (f) + `(cons ',(car f) ,(cadr f))) + fields))))) + +(define-macro (define-field-reader field-reader type-parse body) + `(define (,field-reader wrapped) + (let ((alist (,type-parse wrapped))) + ,body))) + +(define-macro (field name) + `(assoc-ref alist ,name)) + +(export-syntax define-conversion-type + field) + + +;;; Support functions for type generation + +(define (bv-uint-ref pointer index) + (bytevector-uint-ref + (pointer->bytevector pointer 4 index) + 0 + (native-endianness) + 4)) + +(define* (array size root #:key (element-size 4) (element-proc bv-uint-ref)) + (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 (get-element-address root-pointer offset) + (make-pointer (+ (pointer-address root-pointer) offset))) + +(define (sized-string s) + (cond (s + (bytevector->string + (u8-list->bytevector (list-head (cadr s) (car s))) + (fluid-ref %default-port-encoding))) + (else + #f))) + +(define (wrap pointers 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)))) + (cond ((list? pointers) + (map make-wrap pointers)) + (else + (make-wrap pointers)))) + +(export array + get-element-address + sized-string + wrap)