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 (assimp low-level scene)
  20   #:use-module (ice-9 iconv)
  21   #:use-module (rnrs bytevectors)
  22   #:use-module (system foreign))
  23
  24 (define libassimp (dynamic-link "libassimp"))
  25
  26 (define aiImportFile
  27   (pointer->procedure '*
  28                       (dynamic-func "aiImportFile" libassimp)
  29                       (list '* unsigned-int)))
  30
  31
  32 ;;; Type Generation
  33
  34 (define-syntax define-type
  35   (lambda (x)
  36     (define (mk-string . args)
  37       (string-concatenate
  38        (map (lambda (a)
  39               (if (string? a)
  40                   a
  41                   (symbol->string (syntax->datum a))))
  42             args)))
  43     (define (mk-symbol . args)
  44       (datum->syntax x
  45         (string->symbol
  46          (apply mk-string args))))
  47     (syntax-case x ()
  48       ((_ name (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")))
  54          #'(begin
  55              (define-wrapped-pointer-type name
  56                type?
  57                wrap-type unwrap-type
  58                (lambda (x p)
  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)
  64                         '())
  65                        (else
  66                         (filter
  67                          (lambda (f)
  68                            (not (null? (cdr f))))
  69                          (list (cons 'field (field-proc unwrapped))
  70                                ...))))))))))))
  71
  72
  73 (define (bv-uint-ref pointer index)
  74   (bytevector-uint-ref
  75    (pointer->bytevector pointer 4 index)
  76    0
  77    (native-endianness)
  78    4))
  79
  80 (define (get-aiString index)
  81   (lambda (pointer)
  82     (let* ((length (bv-uint-ref pointer index))
  83            (data (pointer->bytevector pointer length (+ index 4))))
  84       (bytevector->string data (fluid-ref %default-port-encoding)))))
  85
  86 (define* (get-pointer index #:optional wrap-proc)
  87   (lambda (pointer)
  88     (let ((p (bv-uint-ref pointer index)))
  89       (cond ((= p 0) '())
  90             (else
  91              (let ((p2 (make-pointer p)))
  92                (list
  93                 (cond (wrap-proc (wrap-proc p2))
  94                       (else p2)))))))))
  95
  96 (define (get-array num-index root-index type)
  97   (lambda (pointer)
  98     (let ((num (bv-uint-ref pointer num-index))
  99           (rootp (make-pointer (bv-uint-ref pointer root-index))))
 100       (cond ((> num 0)
 101              (array->list
 102               (pointer->bytevector rootp num 0 type)))
 103             (else
 104              '())))))
 105
 106 (define* (get-structs-array num-index root-index struct-size #:optional wrap-proc)
 107   (lambda (pointer)
 108     (let ((num (bv-uint-ref pointer num-index))
 109           (rootp (bv-uint-ref pointer root-index)))
 110       (let loop ((i (- num 1)))
 111         (cond ((< i 0)
 112                '())
 113               (else
 114                (let* ((p (make-pointer (+ rootp (* i struct-size))))
 115                       (wp (if wrap-proc (wrap-proc p) p)))
 116                  (cons wp (loop (- i 1))))))))))
 117
 118 (define* (get-pointer-of-pointers num-index root-index #:optional wrap-proc)
 119   (lambda (pointer)
 120     (let* ((num (bv-uint-ref pointer num-index))
 121            (rootp (make-pointer (bv-uint-ref pointer root-index))))
 122       (let loop ((i 0))
 123         (cond ((= i num)
 124                '())
 125               (else
 126                (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
 127                       (wp (if wrap-proc (wrap-proc p) p)))
 128                  (cons wp (loop (+ i 1))))))))))
 129
 130 ;;; Scenes
 131
 132 (define-type scene
 133   (flags (lambda (p) (bv-uint-ref p 0)))
 134   (root-node (lambda (p) (wrap-node (make-pointer (bv-uint-ref p 4)))))
 135   (meshes (get-pointer-of-pointers 8 12 wrap-mesh))
 136   (materials (get-pointer-of-pointers 16 20 wrap-material))
 137   (animations (get-pointer-of-pointers 24 28))
 138   (textures (get-pointer-of-pointers 32 36))
 139   (lights (get-pointer-of-pointers 40 44))
 140   (cameras (get-pointer-of-pointers 48 52)))
 141
 142 (define (load-scene filename flags)
 143   (wrap-scene
 144    (aiImportFile (string->pointer filename)
 145                  flags)))
 146
 147 (define (load-scene filename flags)
 148   (parse-aiNode
 149    (assoc-ref
 150     (parse-aiScene
 151      (aiImportFile (string->pointer filename)
 152                    flags))
 153     'mRootNode)))
 154
 155 (export load-scene
 156         unwrap-scene
 157         scene?
 158         scene-contents)
 159
 160
 161 ;;; Nodes
 162
 163 (define-type node
 164   (name (get-aiString 0))
 165   (transformation (lambda (p) (array->list (pointer->bytevector p 16 1028 'f32))))
 166   (parent (get-pointer 1092 wrap-node))
 167   (children (get-pointer-of-pointers 1096 1100 wrap-node))
 168   (meshes (get-array 1104 1108 'u32)))
 169
 170 (export node?
 171         node-contents)
 172
 173
 174 ;;; Meshes
 175
 176 (define AI_MAX_NUMBER_OF_COLOR_SETS 8)
 177
 178 (define-type mesh
 179   (num-primitive-types (lambda (p) (bv-uint-ref p 0)))
 180   (vertices (get-pointer-of-pointers 4 12))
 181   (faces (get-structs-array 8 124 8 wrap-face))
 182   (normals (lambda (p) (bv-uint-ref p 16)))
 183   (tangents (lambda (p) (bv-uint-ref p 20)))
 184   (bitangents (lambda (p) (bv-uint-ref p 24)))
 185   (colors (lambda (p) (bv-uint-ref p 28))) ;AI_MAX_NUMBER_OF_COLOR_SETS
 186   (texture-coords (lambda (p) (bv-uint-ref p 60))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
 187   (num-uv-components (lambda (p) (bv-uint-ref p 92))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
 188   (bones (get-pointer-of-pointers 128 132))
 189   (material-index (lambda (p) (bv-uint-ref p 136))))
 190
 191 (export mesh?
 192         mesh-contents)
 193
 194
 195 ;;; Materials
 196
 197 (define-type material
 198   (properties (get-pointer-of-pointers 4 0))
 199   (allocated (lambda (p) (bv-uint-ref p 8))))
 200
 201 (export material?
 202         material-contents)
 203
 204
 205 ;;; Faces
 206
 207 (define-type face
 208   (indices (get-array 0 4 'u32)))
 209
 210 (export face?
 211         face-contents)