-(define libassimp (dynamic-link "libassimp"))
-
-(define aiImportFile
- (pointer->procedure '*
- (dynamic-func "aiImportFile" libassimp)
- (list '* unsigned-int)))
-
-
-;;; Type Generation
-
-(define-syntax define-type
- (lambda (x)
- (define (mk-string . args)
- (string-concatenate
- (map (lambda (a)
- (if (string? a)
- a
- (symbol->string (syntax->datum a))))
- args)))
- (define (mk-symbol . args)
- (datum->syntax x
- (string->symbol
- (apply mk-string args))))
- (syntax-case x ()
- ((_ name parser (field field-proc) ...)
- (with-syntax ((type? (mk-symbol #'name "?"))
- (wrap-type (mk-symbol "wrap-" #'name))
- (unwrap-type (mk-symbol "unwrap-" #'name))
- (output-string (mk-string "#<" #'name " ~x>"))
- (type-contents (mk-symbol #'name "-contents")))
- #'(begin
- (define-wrapped-pointer-type name
- type?
- wrap-type unwrap-type
- (lambda (x p)
- (format p output-string
- (pointer-address (unwrap-type x)))))
- (define (type-contents wrapped)
- (let ((unwrapped (unwrap-type wrapped)))
- (cond ((= (pointer-address unwrapped) 0)
- '())
- (else
- (filter
- (lambda (f)
- (not (null? (cdr f))))
- (list (cons 'field (field-proc unwrapped))
- ...))))))))))))
-
-(define (bv-uint-ref pointer index)
- (bytevector-uint-ref
- (pointer->bytevector pointer 4 index)
- 0
- (native-endianness)
- 4))
-
-(define (get-aiString index)
- (lambda (pointer)
- (let* ((length (bv-uint-ref pointer index))
- (data (pointer->bytevector pointer length (+ index 4))))
- (bytevector->string data (fluid-ref %default-port-encoding)))))
-
-(define* (get-pointer index #:optional wrap-proc)
- (lambda (pointer)
- (let ((p (bv-uint-ref pointer index)))
- (cond ((= p 0) '())
- (else
- (let ((p2 (make-pointer p)))
- (list
- (cond (wrap-proc (wrap-proc p2))
- (else p2)))))))))
-
-(define (get-array num-index root-index type)
- (lambda (pointer)
- (let ((num (bv-uint-ref pointer num-index))
- (rootp (make-pointer (bv-uint-ref pointer root-index))))
- (cond ((> num 0)
- (array->list
- (pointer->bytevector rootp num 0 type)))
- (else
- '())))))
-
-(define* (get-structs-array num-index root-index struct-size #:optional wrap-proc)
- (lambda (pointer)
- (let ((num (bv-uint-ref pointer num-index))
- (rootp (bv-uint-ref pointer root-index)))
- (let loop ((i (- num 1)))
- (cond ((< i 0)
- '())
- (else
- (let* ((p (make-pointer (+ rootp (* i struct-size))))
- (wp (if wrap-proc (wrap-proc p) p)))
- (cons wp (loop (- i 1))))))))))
-
-(define* (get-pointer-of-pointers num-index root-index #:optional wrap-proc)
- (lambda (pointer)
- (let* ((num (bv-uint-ref pointer num-index))
- (rootp (make-pointer (bv-uint-ref pointer root-index))))
- (let loop ((i 0))
- (cond ((= i num)
- '())
- (else
- (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
- (wp (if wrap-proc (wrap-proc p) p)))
- (cons wp (loop (+ i 1))))))))))
-
-(define-syntax define-conversion-type
- (lambda (x)
- (define (mk-string . args)
- (string-concatenate
- (map (lambda (a)
- (if (string? a)
- a
- (symbol->string (syntax->datum a))))
- args)))
- (define (mk-symbol . args)
- (datum->syntax x
- (string->symbol
- (apply mk-string args))))
- (syntax-case x (->)
- ((_ parser -> name (field-name field-proc) ...)
- (with-syntax ((type? (mk-symbol #'name "?"))
- (wrap-type (mk-symbol "wrap-" #'name))
- (unwrap-type (mk-symbol "unwrap-" #'name))
- (output-string (mk-string "#<" #'name " ~x>"))
- (type-contents (mk-symbol #'name "-contents"))
- (type-parse (mk-symbol #'name "-parse"))
- ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
- #'(begin
- (define-wrapped-pointer-type name
- type?
- wrap-type unwrap-type
- (lambda (x p)
- (format p output-string
- (pointer-address (unwrap-type x)))))
- (define (type-parse wrapped)
- (let ((unwrapped (unwrap-type wrapped)))
- (cond ((= (pointer-address unwrapped) 0)
- '())
- (else
- (parser unwrapped)))))
- (define (type-contents wrapped)
- (let ((alist (type-parse wrapped)))
- (list (cons 'field-name (field-proc alist))
- ...)))
- (define (field-reader wrapped)
- (let ((alist (type-parse wrapped)))
- (field-proc alist)))
- ...))))))
-
-(define (field name)
- (lambda (alist)
- (assoc-ref alist name)))
-
-(define (array size-tag root-tag)
- (lambda (alist)
- (let ((size (assoc-ref alist size-tag))
- (root (assoc-ref alist root-tag)))
- (let loop ((i 0))
- (cond ((= i size)
- '())
- (else
- (cons (bv-uint-ref root (* 4 i))
- (loop (+ i 1)))))))))
-
-(define (wrap proc wrap-proc)
- (define (make-wrap element)
- (let ((pointer
- (cond ((pointer? element)
- (if (= (pointer-address element) 0)
- #f
- element))
- ((= element 0)
- #f)
- (else
- (make-pointer element)))))
- (cond (pointer
- (wrap-proc pointer))
- (else
- #f))))
- (lambda (alist)
- (let ((res (proc alist)))
- (cond ((list? res)
- (map make-wrap res))
- (else
- (make-wrap res))))))
-
-(define (sized-string string-tag)
- (lambda (alist)
- (let ((s (assoc-ref alist string-tag)))
- (cond (s
- (bytevector->string
- (u8-list->bytevector (list-head (cadr s) (car s)))
- (fluid-ref %default-port-encoding)))
- (else
- #f)))))
-