From ef3e935778bfa89faa1b597180e0ec5d2986784b Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Sun, 22 Jun 2014 15:57:02 +0200 Subject: [PATCH] Rewrite definition types using new C parsers * src/assimp.scm: New macro 'define-conversion-type' for defining types for libassimp structs using new parsers from low-level files. * src/low-level/scene.scm: Rename fields in nodes parser. --- src/assimp.scm | 161 ++++++++++++++++++++++++++++++++-------- src/low-level/scene.scm | 4 +- 2 files changed, 130 insertions(+), 35 deletions(-) diff --git a/src/assimp.scm b/src/assimp.scm index 7422b81..874330f 100644 --- a/src/assimp.scm +++ b/src/assimp.scm @@ -45,7 +45,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 +69,6 @@ (list (cons 'field (field-proc unwrapped)) ...)))))))))))) - (define (bv-uint-ref pointer index) (bytevector-uint-ref (pointer->bytevector pointer 4 index) @@ -127,48 +126,144 @@ (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 (array size-tag root-tag) + (lambda (alist) + (let ((size (assoc-ref alist size-tag)) + (root (assoc-ref alist root-tag))) + (let loop ((i 0)) + (cond ((= i size) + '()) + (else + (cons (bv-uint-ref root (* 4 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 diff --git a/src/low-level/scene.scm b/src/low-level/scene.scm index 6d67f48..651ea3a 100644 --- a/src/low-level/scene.scm +++ b/src/low-level/scene.scm @@ -22,8 +22,8 @@ (define-struct-parser parse-aiNode - (aiString aiString-type) - (aiMatrix4x4 aiMatrix4x4-type) + (mName aiString-type) + (mTransformation aiMatrix4x4-type) (mParent '*) (mNumChildren unsigned-int) (mChildren '*) -- 2.39.2