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-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))))))))))
132 (flags (lambda (p) (bv-uint-ref p 0)))
133 (root-node (lambda (p) (wrap-node (make-pointer (bv-uint-ref p 4)))))
134 (meshes (get-pointer-of-pointers 8 12 wrap-mesh))
135 (materials (get-pointer-of-pointers 16 20 wrap-material))
136 (animations (get-pointer-of-pointers 24 28))
137 (textures (get-pointer-of-pointers 32 36))
138 (lights (get-pointer-of-pointers 40 44))
139 (cameras (get-pointer-of-pointers 48 52)))
141 (define (load-scene filename flags)
143 (aiImportFile (string->pointer filename)
155 (name (get-aiString 0))
156 (transformation (lambda (p) (array->list (pointer->bytevector p 16 1028 'f32))))
157 (parent (get-pointer 1092 wrap-node))
158 (children (get-pointer-of-pointers 1096 1100 wrap-node))
159 (meshes (get-array 1104 1108 'u32)))
168 (num-primitive-types (lambda (p) (bv-uint-ref p 0)))
169 (vertices (get-pointer-of-pointers 4 12))
170 (faces (get-structs-array 8 124 8 wrap-face))
171 (normals (lambda (p) (bv-uint-ref p 16)))
172 (tangents (lambda (p) (bv-uint-ref p 20)))
173 (bitangents (lambda (p) (bv-uint-ref p 24)))
174 (colors (lambda (p) (bv-uint-ref p 28))) ;AI_MAX_NUMBER_OF_COLOR_SETS
175 (texture-coords (lambda (p) (bv-uint-ref p 60))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
176 (num-uv-components (lambda (p) (bv-uint-ref p 92))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
177 (bones (get-pointer-of-pointers 128 132))
178 (material-index (lambda (p) (bv-uint-ref p 136))))
186 (define-type material
187 (properties (get-pointer-of-pointers 4 0))
188 (allocated (lambda (p) (bv-uint-ref p 8))))
197 (indices (get-array 0 4 'u32)))