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-pointer-of-pointers num-index root-index #:optional wrap-proc)
 106   (lambda (pointer)
 107     (let* ((num (bv-uint-ref pointer num-index))
 108            (rootp (make-pointer (bv-uint-ref pointer root-index))))
 109       (let loop ((i 0))
 110         (cond ((= i num)
 111                '())
 112               (else
 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))))))))))
 116
 117 ;;; Scenes
 118
 119 (define-type scene
 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))
 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)))
 128
 129 (define (load-scene filename flags)
 130   (wrap-scene
 131    (aiImportFile (string->pointer filename)
 132                  flags)))
 133
 134 (export load-scene
 135         unwrap-scene
 136         scene?
 137         scene-contents)
 138
 139
 140 ;;; Nodes
 141
 142 (define-type node
 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)))
 148
 149 (export node?
 150         node-contents)
 151
 152
 153 ;;; Meshes
 154
 155 (define-type mesh
 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))))
 167
 168 (export mesh?
 169         mesh-contents)