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 (rnrs bytevectors)
  20   #:use-module (system foreign))
  21
  22 (define libassimp (dynamic-link "libassimp"))
  23
  24 (define aiImportFile
  25   (pointer->procedure '*
  26                       (dynamic-func "aiImportFile" libassimp)
  27                       (list '* unsigned-int)))
  28
  29
  30 ;;; Type Generation
  31
  32 (define-syntax define-type
  33   (lambda (x)
  34     (define (mk-string . args)
  35       (string-concatenate
  36        (map (lambda (a)
  37               (if (string? a)
  38                   a
  39                   (symbol->string (syntax->datum a))))
  40             args)))
  41     (define (mk-symbol . args)
  42       (datum->syntax x
  43         (string->symbol
  44          (apply mk-string args))))
  45     (syntax-case x ()
  46       ((_ name (field field-proc) ...)
  47        (with-syntax ((type? (mk-symbol #'name "?"))
  48                      (wrap-type (mk-symbol "wrap-" #'name))
  49                      (unwrap-type (mk-symbol "unwrap-" #'name))
  50                      (output-string (mk-string "#<" #'name " ~x>"))
  51                      (type-contents (mk-symbol #'name "-contents")))
  52          #'(begin
  53              (define-wrapped-pointer-type name
  54                type?
  55                wrap-type unwrap-type
  56                (lambda (x p)
  57                  (format p output-string
  58                          (pointer-address (unwrap-type x)))))
  59              (define (type-contents wrapped)
  60                (let ((unwrapped (unwrap-type wrapped)))
  61                  (cond ((= (pointer-address unwrapped) 0)
  62                         '())
  63                        (else
  64                         (filter
  65                          (lambda (f)
  66                            (not (null? (cdr f))))
  67                          (list (cons 'field (field-proc unwrapped))
  68                                ...))))))))))))
  69
  70
  71 (define (bv-uint-ref pointer index)
  72   (bytevector-uint-ref
  73    (pointer->bytevector pointer 4 index)
  74    0
  75    (native-endianness)
  76    4))
  77
  78 (define* (get-pointer-of-pointers-procedure num-index root-index #:optional wrap-proc)
  79   (lambda (pointer)
  80     (let* ((num (bv-uint-ref pointer num-index))
  81            (rootp (make-pointer (bv-uint-ref pointer root-index))))
  82       (let loop ((i 0))
  83         (cond ((= i num)
  84                '())
  85               (else
  86                (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
  87                       (wp (if wrap-proc (wrap-proc p) p)))
  88                  (cons wp (loop (+ i 1))))))))))
  89
  90 ;;; Scenes
  91
  92 (define-type scene
  93   (flags (lambda (p) (bv-uint-ref p 0)))
  94   (root-node (lambda (p) (wrap-node (make-pointer (bv-uint-ref p 4)))))
  95   (meshes (get-pointer-of-pointers-procedure 8 12 wrap-mesh))
  96   (materials (get-pointer-of-pointers-procedure 16 20))
  97   (animations (get-pointer-of-pointers-procedure 24 28))
  98   (textures (get-pointer-of-pointers-procedure 32 36))
  99   (lights (get-pointer-of-pointers-procedure 40 44))
 100   (cameras (get-pointer-of-pointers-procedure 48 52)))
 101
 102 (define (load-scene filename flags)
 103   (wrap-scene
 104    (aiImportFile (string->pointer filename)
 105                  flags)))
 106
 107 (export load-scene
 108         unwrap-scene
 109         scene?
 110         scene-contents)
 111
 112
 113 ;;; Nodes
 114
 115 (define-type node
 116   (name (lambda (p) (bv-uint-ref p 0))) ;check, it's a struct
 117   (transformation (lambda (p) (bv-uint-ref p 1028))) ;check, it's a struct
 118   (parent (lambda (p) (bv-uint-ref p 1092)))
 119   (children (get-pointer-of-pointers-procedure 1096 1100))
 120   (meshes (get-pointer-of-pointers-procedure 1104 1108)))
 121
 122 (export node?
 123         node-contents)
 124
 125
 126 ;;; Meshes
 127
 128 (define-type mesh
 129   (num-primitive-types (lambda (p) (bv-uint-ref p 0)))
 130   (vertices (get-pointer-of-pointers-procedure 4 12))
 131   (faces (get-pointer-of-pointers-procedure 8 124))
 132   (normals (lambda (p) (bv-uint-ref p 16)))
 133   (tangents (lambda (p) (bv-uint-ref p 20)))
 134   (bitangents (lambda (p) (bv-uint-ref p 24)))
 135   (colors (lambda (p) (bv-uint-ref p 28))) ;AI_MAX_NUMBER_OF_COLOR_SETS
 136   (texture-coords (lambda (p) (bv-uint-ref p 60))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
 137   (num-uv-components (lambda (p) (bv-uint-ref p 92))) ;AI_MAX_NUMBER_OF_TEXTURECOORDS
 138   (bones (get-pointer-of-pointers-procedure 128 132))
 139   (material-index (lambda (p) (bv-uint-ref p 136))))
 140
 141 (export mesh?
 142         mesh-contents)