src/assimp.scm

   1 ;;; guile-assimp, foreign interface to libassimp
   2 ;;; Copyright (C) 2014 by Javier Sancho Fernandez <jsf at jsancho dot org>
   3 ;;;
   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.
   8 ;;;
   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.
  13 ;;;
  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/>.
  16
  17
  18 (define-module (assimp assimp)
  19   #:use-module (ice-9 iconv)
  20   #:use-module (rnrs bytevectors)
  21   #:use-module (system foreign))
  22
  23 (define libassimp (dynamic-link "libassimp"))
  24
  25 (define aiImportFile
  26   (pointer->procedure '*
  27                       (dynamic-func "aiImportFile" libassimp)
  28                       (list '* unsigned-int)))
  29
  30
  31 ;;; Type Generation
  32
  33 (define-syntax define-type
  34   (lambda (x)
  35     (define (mk-string . args)
  36       (string-concatenate
  37        (map (lambda (a)
  38               (if (string? a)
  39                   a
  40                   (symbol->string (syntax->datum a))))
  41             args)))
  42     (define (mk-symbol . args)
  43       (datum->syntax x
  44         (string->symbol
  45          (apply mk-string args))))
  46     (syntax-case x ()
  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")))
  53          #'(begin
  54              (define-wrapped-pointer-type name
  55                type?
  56                wrap-type unwrap-type
  57                (lambda (x p)
  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)
  63                         '())
  64                        (else
  65                         (filter
  66                          (lambda (f)
  67                            (not (null? (cdr f))))
  68                          (list (cons 'field (field-proc unwrapped))
  69                                ...))))))))))))
  70
  71
  72 (define (bv-uint-ref pointer index)
  73   (bytevector-uint-ref
  74    (pointer->bytevector pointer 4 index)
  75    0
  76    (native-endianness)
  77    4))
  78
  79 (define (get-aiString index)
  80   (lambda (pointer)
  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)))))
  84
  85 (define* (get-pointer index #:optional wrap-proc)
  86   (lambda (pointer)
  87     (let ((p (bv-uint-ref pointer index)))
  88       (cond ((= p 0) '())
  89             (else
  90              (let ((p2 (make-pointer p)))
  91                (list
  92                 (cond (wrap-proc (wrap-proc p2))
  93                       (else p2)))))))))
  94
  95 (define (get-array num-index root-index type)
  96   (lambda (pointer)
  97     (let ((num (bv-uint-ref pointer num-index))
  98           (rootp (make-pointer (bv-uint-ref pointer root-index))))
  99       (cond ((> num 0)
 100              (array->list
 101               (pointer->bytevector rootp num 0 type)))
 102             (else
 103              '())))))
 104
 105 (define* (get-structs-array num-index root-index struct-size #:optional wrap-proc)
 106   (lambda (pointer)
 107     (let ((num (bv-uint-ref pointer num-index))
 108           (rootp (bv-uint-ref pointer root-index)))
 109       (let loop ((i (- num 1)))
 110         (cond ((< i 0)
 111                '())
 112               (else
 113                (let* ((p (make-pointer (+ rootp (* i struct-size))))
 114                       (wp (if wrap-proc (wrap-proc p) p)))
 115                  (cons wp (loop (- i 1))))))))))
 116
 117 (define* (get-pointer-of-pointers num-index root-index #:optional wrap-proc)
 118   (lambda (pointer)
 119     (let* ((num (bv-uint-ref pointer num-index))
 120            (rootp (make-pointer (bv-uint-ref pointer root-index))))
 121       (let loop ((i 0))
 122         (cond ((= i num)
 123                '())
 124               (else
 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))))))))))
 128
 129 ;;; Scenes
 130
 131 (define-type scene
 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)))
 140
 141 (define (load-scene filename flags)
 142   (wrap-scene
 143    (aiImportFile (string->pointer filename)
 144                  flags)))
 145
 146 (export load-scene
 147         unwrap-scene
 148         scene?
 149         scene-contents)
 150
 151
 152 ;;; Nodes
 153
 154 (define-type node
 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)))
 160
 161 (export node?
 162         node-contents)
 163
 164
 165 ;;; Meshes
 166
 167 (define-type mesh
 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))))
 179
 180 (export mesh?
 181         mesh-contents)
 182
 183
 184 ;;; Materials
 185
 186 (define-type material
 187   (properties (get-pointer-of-pointers 4 0))
 188   (allocated (lambda (p) (bv-uint-ref p 8))))
 189
 190 (export material?
 191         material-contents)
 192
 193
 194 ;;; Faces
 195
 196 (define-type face
 197   (indices (get-array 0 4 'u32)))
 198
 199 (export face?
 200         face-contents)