1 ;;; guile-assimp, foreign interface to libassimp
2 ;;; Copyright (C) 2014 by Javier Sancho Fernandez <jsf at jsancho dot org>
4 ;;; This program is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation, either version 3 of the License, or
7 ;;; (at your option) any later version.
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
18 (define-module (assimp assimp)
19 #:use-module (assimp low-level scene)
20 #:use-module (ice-9 iconv)
21 #:use-module (rnrs bytevectors)
22 #:use-module (system foreign))
24 (define libassimp (dynamic-link "libassimp"))
27 (pointer->procedure '*
28 (dynamic-func "aiImportFile" libassimp)
29 (list '* unsigned-int)))
34 (define-syntax define-type
36 (define (mk-string . args)
41 (symbol->string (syntax->datum a))))
43 (define (mk-symbol . args)
46 (apply mk-string args))))
48 ((_ name parser (field field-proc) ...)
49 (with-syntax ((type? (mk-symbol #'name "?"))
50 (wrap-type (mk-symbol "wrap-" #'name))
51 (unwrap-type (mk-symbol "unwrap-" #'name))
52 (output-string (mk-string "#<" #'name " ~x>"))
53 (type-contents (mk-symbol #'name "-contents")))
55 (define-wrapped-pointer-type name
59 (format p output-string
60 (pointer-address (unwrap-type x)))))
61 (define (type-contents wrapped)
62 (let ((unwrapped (unwrap-type wrapped)))
63 (cond ((= (pointer-address unwrapped) 0)
68 (not (null? (cdr f))))
69 (list (cons 'field (field-proc unwrapped))
72 (define (bv-uint-ref pointer index)
74 (pointer->bytevector pointer 4 index)
79 (define (get-aiString index)
81 (let* ((length (bv-uint-ref pointer index))
82 (data (pointer->bytevector pointer length (+ index 4))))
83 (bytevector->string data (fluid-ref %default-port-encoding)))))
85 (define* (get-pointer index #:optional wrap-proc)
87 (let ((p (bv-uint-ref pointer index)))
90 (let ((p2 (make-pointer p)))
92 (cond (wrap-proc (wrap-proc p2))
95 (define (get-array num-index root-index type)
97 (let ((num (bv-uint-ref pointer num-index))
98 (rootp (make-pointer (bv-uint-ref pointer root-index))))
101 (pointer->bytevector rootp num 0 type)))
105 (define* (get-structs-array num-index root-index struct-size #:optional wrap-proc)
107 (let ((num (bv-uint-ref pointer num-index))
108 (rootp (bv-uint-ref pointer root-index)))
109 (let loop ((i (- num 1)))
113 (let* ((p (make-pointer (+ rootp (* i struct-size))))
114 (wp (if wrap-proc (wrap-proc p) p)))
115 (cons wp (loop (- i 1))))))))))
117 (define* (get-pointer-of-pointers num-index root-index #:optional wrap-proc)
119 (let* ((num (bv-uint-ref pointer num-index))
120 (rootp (make-pointer (bv-uint-ref pointer root-index))))
125 (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
126 (wp (if wrap-proc (wrap-proc p) p)))
127 (cons wp (loop (+ i 1))))))))))
129 (define-syntax define-conversion-type
131 (define (mk-string . args)
136 (symbol->string (syntax->datum a))))
138 (define (mk-symbol . args)
141 (apply mk-string args))))
143 ((_ parser -> name (field-name field-proc) ...)
144 (with-syntax ((type? (mk-symbol #'name "?"))
145 (wrap-type (mk-symbol "wrap-" #'name))
146 (unwrap-type (mk-symbol "unwrap-" #'name))
147 (output-string (mk-string "#<" #'name " ~x>"))
148 (type-contents (mk-symbol #'name "-contents"))
149 (type-parse (mk-symbol #'name "-parse"))
150 ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
152 (define-wrapped-pointer-type name
154 wrap-type unwrap-type
156 (format p output-string
157 (pointer-address (unwrap-type x)))))
158 (define (type-parse wrapped)
159 (let ((unwrapped (unwrap-type wrapped)))
160 (cond ((= (pointer-address unwrapped) 0)
163 (parser unwrapped)))))
164 (define (type-contents wrapped)
165 (let ((alist (type-parse wrapped)))
166 (list (cons 'field-name (field-proc alist))
168 (define (field-reader wrapped)
169 (let ((alist (type-parse wrapped)))
175 (assoc-ref alist name)))
177 (define (array size-tag root-tag)
179 (let ((size (assoc-ref alist size-tag))
180 (root (assoc-ref alist root-tag)))
185 (cons (bv-uint-ref root (* 4 i))
186 (loop (+ i 1)))))))))
188 (define (wrap proc wrap-proc)
189 (define (make-wrap element)
191 (cond ((pointer? element)
192 (if (= (pointer-address element) 0)
198 (make-pointer element)))))
204 (let ((res (proc alist)))
210 (define (sized-string string-tag)
212 (let ((s (assoc-ref alist string-tag)))
215 (u8-list->bytevector (list-head (cadr s) (car s)))
216 (fluid-ref %default-port-encoding)))
223 (define-conversion-type parse-aiScene -> scene
224 (flags (field 'mFlags))
225 (root-node (wrap (field 'mRootNode) wrap-node))
226 (meshes (wrap (array 'mNumMeshes 'mMeshes) wrap-mesh))
227 (materials (wrap (array 'mNumMaterials 'mMaterials) wrap-material))
228 (animations (array 'mNumAnimations 'mAnimations))
229 (textures (array 'mNumTextures 'mTextures))
230 (lights (array 'mNumLights 'mLights))
231 (cameras (array 'mNumCameras 'mCameras)))
233 (define (load-scene filename flags)
235 (aiImportFile (string->pointer filename)
253 (define-conversion-type parse-aiNode -> node
254 (name (sized-string 'mName))
255 (transformation (field 'mTransformation))
256 (parent (wrap (field 'mParent) wrap-node))
257 (children (wrap (array 'mNumChildren 'mChildren) wrap-node))
258 (meshes (array 'mNumMeshes 'mMeshes)))
271 (define AI_MAX_NUMBER_OF_COLOR_SETS 8)
274 (num-primitive-types (lambda (p) (bv-uint-ref p 0)))
275 (vertices (get-pointer-of-pointers 4 12))
276 (faces (get-structs-array 8 124 8 wrap-face))
277 (normals (lambda (p) (bv-uint-ref p 16)))
278 (tangents (lambda (p) (bv-uint-ref p 20)))
279 (bitangents (lambda (p) (bv-uint-ref p 24)))
280 (colors (lambda (p) (bv-uint-ref p 28))) ;AI_MAX_NUMBER_OF_COLOR_SETS
281 (texture-coords (lambda (p) (bv-uint-ref p 60))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
282 (num-uv-components (lambda (p) (bv-uint-ref p 92))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
283 (bones (get-pointer-of-pointers 128 132))
284 (material-index (lambda (p) (bv-uint-ref p 136))))
292 (define-type material
293 (properties (get-pointer-of-pointers 4 0))
294 (allocated (lambda (p) (bv-uint-ref p 8))))
303 (indices (get-array 0 4 'u32)))