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.

diff --git a/src/assimp.scm b/src/assimp.scm
index 7422b8175f7897ce4571b94759c0c371c57ae497..874330ff630fe4cee050e3398087596402098c9a 100644 (file)
--- 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 6d67f4871866b096806fcbc7cf4ae592ddfae1cf..651ea3a7519923429b8277f4f99df9c9ab421ba0 100644 (file)
--- 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 '*)