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-pointer-of-pointers-procedure num-index root-index #:optional wrap-proc)
  96   (lambda (pointer)
  97     (let* ((num (bv-uint-ref pointer num-index))
  98            (rootp (make-pointer (bv-uint-ref pointer root-index))))
  99       (let loop ((i 0))
 100         (cond ((= i num)
 101                '())
 102               (else
 103                (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
 104                       (wp (if wrap-proc (wrap-proc p) p)))
 105                  (cons wp (loop (+ i 1))))))))))
 106
 107 ;;; Scenes
 108
 109 (define-type scene
 110   (flags (lambda (p) (bv-uint-ref p 0)))
 111   (root-node (lambda (p) (wrap-node (make-pointer (bv-uint-ref p 4)))))
 112   (meshes (get-pointer-of-pointers-procedure 8 12 wrap-mesh))
 113   (materials (get-pointer-of-pointers-procedure 16 20))
 114   (animations (get-pointer-of-pointers-procedure 24 28))
 115   (textures (get-pointer-of-pointers-procedure 32 36))
 116   (lights (get-pointer-of-pointers-procedure 40 44))
 117   (cameras (get-pointer-of-pointers-procedure 48 52)))
 118
 119 (define (load-scene filename flags)
 120   (wrap-scene
 121    (aiImportFile (string->pointer filename)
 122                  flags)))
 123
 124 (export load-scene
 125         unwrap-scene
 126         scene?
 127         scene-contents)
 128
 129
 130 ;;; Nodes
 131
 132 (define-type node
 133   (name (get-aiString 0))
 134   (transformation (lambda (p) (array->list (pointer->bytevector p 16 1028 'f32))))
 135   (parent (get-pointer 1092 wrap-node))
 136   (children (get-pointer-of-pointers-procedure 1096 1100 wrap-node))
 137   (meshes (get-pointer-of-pointers-procedure 1104 1108 wrap-mesh)))
 138
 139 (export node?
 140         node-contents)
 141
 142
 143 ;;; Meshes
 144
 145 (define-type mesh
 146   (num-primitive-types (lambda (p) (bv-uint-ref p 0)))
 147   (vertices (get-pointer-of-pointers-procedure 4 12))
 148   (faces (get-pointer-of-pointers-procedure 8 124))
 149   (normals (lambda (p) (bv-uint-ref p 16)))
 150   (tangents (lambda (p) (bv-uint-ref p 20)))
 151   (bitangents (lambda (p) (bv-uint-ref p 24)))
 152   (colors (lambda (p) (bv-uint-ref p 28))) ;AI_MAX_NUMBER_OF_COLOR_SETS
 153   (texture-coords (lambda (p) (bv-uint-ref p 60))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
 154   (num-uv-components (lambda (p) (bv-uint-ref p 92))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
 155   (bones (get-pointer-of-pointers-procedure 128 132))
 156   (material-index (lambda (p) (bv-uint-ref p 136))))
 157
 158 (export mesh?
 159         mesh-contents)