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 (ice-9 iconv)
20 #:use-module (rnrs bytevectors)
21 #:use-module (system foreign))
23 (define libassimp (dynamic-link "libassimp"))
26 (pointer->procedure '*
27 (dynamic-func "aiImportFile" libassimp)
28 (list '* unsigned-int)))
33 (define-syntax define-type
35 (define (mk-string . args)
40 (symbol->string (syntax->datum a))))
42 (define (mk-symbol . args)
45 (apply mk-string args))))
47 ((_ name (field field-proc) ...)
48 (with-syntax ((type? (mk-symbol #'name "?"))
49 (wrap-type (mk-symbol "wrap-" #'name))
50 (unwrap-type (mk-symbol "unwrap-" #'name))
51 (output-string (mk-string "#<" #'name " ~x>"))
52 (type-contents (mk-symbol #'name "-contents")))
54 (define-wrapped-pointer-type name
58 (format p output-string
59 (pointer-address (unwrap-type x)))))
60 (define (type-contents wrapped)
61 (let ((unwrapped (unwrap-type wrapped)))
62 (cond ((= (pointer-address unwrapped) 0)
67 (not (null? (cdr f))))
68 (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-pointer-of-pointers num-index root-index #:optional wrap-proc)
107 (let* ((num (bv-uint-ref pointer num-index))
108 (rootp (make-pointer (bv-uint-ref pointer root-index))))
113 (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
114 (wp (if wrap-proc (wrap-proc p) p)))
115 (cons wp (loop (+ i 1))))))))))
120 (flags (lambda (p) (bv-uint-ref p 0)))
121 (root-node (lambda (p) (wrap-node (make-pointer (bv-uint-ref p 4)))))
122 (meshes (get-pointer-of-pointers 8 12 wrap-mesh))
123 (materials (get-pointer-of-pointers 16 20 wrap-material))
124 (animations (get-pointer-of-pointers 24 28))
125 (textures (get-pointer-of-pointers 32 36))
126 (lights (get-pointer-of-pointers 40 44))
127 (cameras (get-pointer-of-pointers 48 52)))
129 (define (load-scene filename flags)
131 (aiImportFile (string->pointer filename)
143 (name (get-aiString 0))
144 (transformation (lambda (p) (array->list (pointer->bytevector p 16 1028 'f32))))
145 (parent (get-pointer 1092 wrap-node))
146 (children (get-pointer-of-pointers 1096 1100 wrap-node))
147 (meshes (get-array 1104 1108 'u32)))
156 (num-primitive-types (lambda (p) (bv-uint-ref p 0)))
157 (vertices (get-pointer-of-pointers 4 12))
158 (faces (get-pointer-of-pointers 8 124))
159 (normals (lambda (p) (bv-uint-ref p 16)))
160 (tangents (lambda (p) (bv-uint-ref p 20)))
161 (bitangents (lambda (p) (bv-uint-ref p 24)))
162 (colors (lambda (p) (bv-uint-ref p 28))) ;AI_MAX_NUMBER_OF_COLOR_SETS
163 (texture-coords (lambda (p) (bv-uint-ref p 60))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
164 (num-uv-components (lambda (p) (bv-uint-ref p 92))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
165 (bones (get-pointer-of-pointers 128 132))
166 (material-index (lambda (p) (bv-uint-ref p 136))))
174 (define-type material
175 (properties (get-pointer-of-pointers 4 0))
176 (allocated (lambda (p) (bv-uint-ref p 8))))