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 material)
  20   #:use-module (assimp low-level mesh)
  21   #:use-module (assimp low-level scene)
  22   #:use-module (ice-9 iconv)
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (system foreign))
  25
  26 (define libassimp (dynamic-link "libassimp"))
  27
  28 (define aiImportFile
  29   (pointer->procedure '*
  30                       (dynamic-func "aiImportFile" libassimp)
  31                       (list '* unsigned-int)))
  32
  33
  34 ;;; Type Generation
  35
  36 (define-syntax define-type
  37   (lambda (x)
  38     (define (mk-string . args)
  39       (string-concatenate
  40        (map (lambda (a)
  41               (if (string? a)
  42                   a
  43                   (symbol->string (syntax->datum a))))
  44             args)))
  45     (define (mk-symbol . args)
  46       (datum->syntax x
  47         (string->symbol
  48          (apply mk-string args))))
  49     (syntax-case x ()
  50       ((_ name parser (field field-proc) ...)
  51        (with-syntax ((type? (mk-symbol #'name "?"))
  52                      (wrap-type (mk-symbol "wrap-" #'name))
  53                      (unwrap-type (mk-symbol "unwrap-" #'name))
  54                      (output-string (mk-string "#<" #'name " ~x>"))
  55                      (type-contents (mk-symbol #'name "-contents")))
  56          #'(begin
  57              (define-wrapped-pointer-type name
  58                type?
  59                wrap-type unwrap-type
  60                (lambda (x p)
  61                  (format p output-string
  62                          (pointer-address (unwrap-type x)))))
  63              (define (type-contents wrapped)
  64                (let ((unwrapped (unwrap-type wrapped)))
  65                  (cond ((= (pointer-address unwrapped) 0)
  66                         '())
  67                        (else
  68                         (filter
  69                          (lambda (f)
  70                            (not (null? (cdr f))))
  71                          (list (cons 'field (field-proc unwrapped))
  72                                ...))))))))))))
  73
  74 (define (bv-uint-ref pointer index)
  75   (bytevector-uint-ref
  76    (pointer->bytevector pointer 4 index)
  77    0
  78    (native-endianness)
  79    4))
  80
  81 (define (get-aiString index)
  82   (lambda (pointer)
  83     (let* ((length (bv-uint-ref pointer index))
  84            (data (pointer->bytevector pointer length (+ index 4))))
  85       (bytevector->string data (fluid-ref %default-port-encoding)))))
  86
  87 (define* (get-pointer index #:optional wrap-proc)
  88   (lambda (pointer)
  89     (let ((p (bv-uint-ref pointer index)))
  90       (cond ((= p 0) '())
  91             (else
  92              (let ((p2 (make-pointer p)))
  93                (list
  94                 (cond (wrap-proc (wrap-proc p2))
  95                       (else p2)))))))))
  96
  97 (define (get-array num-index root-index type)
  98   (lambda (pointer)
  99     (let ((num (bv-uint-ref pointer num-index))
 100           (rootp (make-pointer (bv-uint-ref pointer root-index))))
 101       (cond ((> num 0)
 102              (array->list
 103               (pointer->bytevector rootp num 0 type)))
 104             (else
 105              '())))))
 106
 107 (define* (get-structs-array num-index root-index struct-size #:optional wrap-proc)
 108   (lambda (pointer)
 109     (let ((num (bv-uint-ref pointer num-index))
 110           (rootp (bv-uint-ref pointer root-index)))
 111       (let loop ((i (- num 1)))
 112         (cond ((< i 0)
 113                '())
 114               (else
 115                (let* ((p (make-pointer (+ rootp (* i struct-size))))
 116                       (wp (if wrap-proc (wrap-proc p) p)))
 117                  (cons wp (loop (- i 1))))))))))
 118
 119 (define* (get-pointer-of-pointers num-index root-index #:optional wrap-proc)
 120   (lambda (pointer)
 121     (let* ((num (bv-uint-ref pointer num-index))
 122            (rootp (make-pointer (bv-uint-ref pointer root-index))))
 123       (let loop ((i 0))
 124         (cond ((= i num)
 125                '())
 126               (else
 127                (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
 128                       (wp (if wrap-proc (wrap-proc p) p)))
 129                  (cons wp (loop (+ i 1))))))))))
 130
 131 (define-syntax define-conversion-type
 132   (lambda (x)
 133     (define (mk-string . args)
 134       (string-concatenate
 135        (map (lambda (a)
 136               (if (string? a)
 137                   a
 138                   (symbol->string (syntax->datum a))))
 139             args)))
 140     (define (mk-symbol . args)
 141       (datum->syntax x
 142         (string->symbol
 143          (apply mk-string args))))
 144     (syntax-case x (->)
 145       ((_ parser -> name (field-name field-proc) ...)
 146        (with-syntax ((type? (mk-symbol #'name "?"))
 147                      (wrap-type (mk-symbol "wrap-" #'name))
 148                      (unwrap-type (mk-symbol "unwrap-" #'name))
 149                      (output-string (mk-string "#<" #'name " ~x>"))
 150                      (type-contents (mk-symbol #'name "-contents"))
 151                      (type-parse (mk-symbol #'name "-parse"))
 152                      ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
 153          #'(begin
 154              (define-wrapped-pointer-type name
 155                type?
 156                wrap-type unwrap-type
 157                (lambda (x p)
 158                  (format p output-string
 159                          (pointer-address (unwrap-type x)))))
 160              (define (type-parse wrapped)
 161                (let ((unwrapped (unwrap-type wrapped)))
 162                  (cond ((= (pointer-address unwrapped) 0)
 163                         '())
 164                        (else
 165                         (parser unwrapped)))))
 166              (define (type-contents wrapped)
 167                (let ((alist (type-parse wrapped)))
 168                  (list (cons 'field-name (field-proc alist))
 169                        ...)))
 170              (define (field-reader wrapped)
 171                (let ((alist (type-parse wrapped)))
 172                  (field-proc alist)))
 173              ...))))))
 174
 175 (define (field name)
 176   (lambda (alist)
 177     (assoc-ref alist name)))
 178
 179 (define (get-element-address root-pointer offset)
 180   (make-pointer (+ (pointer-address root-pointer) offset)))
 181
 182 (define* (array size-tag root-tag #:key (element-size 4) (element-proc bv-uint-ref))
 183   (lambda (alist)
 184     (let ((size (assoc-ref alist size-tag))
 185           (root (assoc-ref alist root-tag)))
 186       (cond ((= (pointer-address root) 0)
 187              '())
 188             (else
 189              (let loop ((i 0))
 190                (cond ((= i size)
 191                       '())
 192                      (else
 193                       (cons (element-proc root (* element-size i))
 194                             (loop (+ i 1)))))))))))
 195
 196 (define (wrap proc wrap-proc)
 197   (define (make-wrap element)
 198     (let ((pointer
 199            (cond ((pointer? element)
 200                   (if (= (pointer-address element) 0)
 201                       #f
 202                       element))
 203                  ((= element 0)
 204                   #f)
 205                  (else
 206                   (make-pointer element)))))
 207       (cond (pointer
 208              (wrap-proc pointer))
 209             (else
 210              #f))))
 211   (lambda (alist)
 212     (let ((res (proc alist)))
 213       (cond ((list? res)
 214              (map make-wrap res))
 215             (else
 216              (make-wrap res))))))
 217
 218 (define (sized-string string-tag)
 219   (lambda (alist)
 220     (let ((s (assoc-ref alist string-tag)))
 221       (cond (s
 222              (bytevector->string
 223               (u8-list->bytevector (list-head (cadr s) (car s)))
 224               (fluid-ref %default-port-encoding)))
 225             (else
 226              #f)))))
 227
 228
 229 ;;; Scenes
 230
 231 (define-conversion-type parse-aiScene -> scene
 232   (flags (field 'mFlags))
 233   (root-node (wrap (field 'mRootNode) wrap-node))
 234   (meshes (wrap (array 'mNumMeshes 'mMeshes) wrap-mesh))
 235   (materials (wrap (array 'mNumMaterials 'mMaterials) wrap-material))
 236   (animations (array 'mNumAnimations 'mAnimations))
 237   (textures (array 'mNumTextures 'mTextures))
 238   (lights (array 'mNumLights 'mLights))
 239   (cameras (array 'mNumCameras 'mCameras)))
 240
 241  (define (load-scene filename flags)
 242    (wrap-scene
 243     (aiImportFile (string->pointer filename)
 244                  flags)))
 245
 246 (export load-scene
 247         scene?
 248         scene-contents
 249         scene-flags
 250         scene-root-node
 251         scene-meshes
 252         scene-materials
 253         scene-animations
 254         scene-textures
 255         scene-lights
 256         scene-cameras)
 257
 258
 259 ;;; Nodes
 260
 261 (define-conversion-type parse-aiNode -> node
 262   (name (sized-string 'mName))
 263   (transformation (field 'mTransformation))
 264   (parent (wrap (field 'mParent) wrap-node))
 265   (children (wrap (array 'mNumChildren 'mChildren) wrap-node))
 266   (meshes (array 'mNumMeshes 'mMeshes)))
 267
 268 (export node?
 269         node-contents
 270         node-name
 271         node-transformation
 272         node-parent
 273         node-children
 274         node-meshes)
 275
 276
 277 ;;; Meshes
 278
 279 (define-conversion-type parse-aiMesh -> mesh
 280   (name (sized-string 'mName))
 281   (primitive-types (field 'mPrimitiveTypes))
 282   (vertices (array 'mNumVertices 'mVertices #:element-proc get-element-address))
 283   (faces (wrap (array 'mNumFaces 'mFaces #:element-size 8 #:element-proc get-element-address) wrap-face))
 284   (normals (array 'mNumVertices 'mNormals #:element-size 12 #:element-proc get-element-address))
 285   (tangents (array 'mNumVertices 'mTangents #:element-size 12 #:element-proc get-element-address))
 286   (bitangents (array 'mNumVertices 'mBitangents #:element-size 12 #:element-proc get-element-address))
 287   (colors (field 'mColors))
 288   (texture-coords (field 'mTextureCoords))
 289   (num-uv-components (field 'mNumUVComponents))
 290   (bones (array 'mNumBones 'mBones))
 291   (material-index (field 'mMaterialIndex))
 292 )
 293
 294 (export mesh?
 295         mesh-contents
 296         mesh-name
 297         mesh-primitive-types
 298         mesh-vertices
 299         mesh-faces
 300         mesh-normals
 301         mesh-tangents
 302         mesh-bitangents
 303         mesh-colors
 304         mesh-texture-coords
 305         mesh-num-uv-components
 306         mesh-bones
 307         mesh-material-index)
 308
 309
 310 ;;; Materials
 311
 312 (define-conversion-type parse-aiMaterial -> material
 313   (properties (array 'mNumProperties 'mProperties))
 314   (num-allocated (field 'mNumAllocated)))
 315
 316 (export material?
 317         material-contents
 318         material-properties
 319         material-num-allocated)
 320
 321
 322 ;;; Faces
 323
 324 (define-conversion-type parse-aiFace -> face
 325   (indices (array 'mNumIndices 'mIndices)))
 326
 327 (export face?
 328         face-contents
 329         face-indices)