135 lines
5.3 KiB
Racket
135 lines
5.3 KiB
Racket
(module gl-vectors mzscheme
|
|
(require mzlib/foreign
|
|
"gl-types.ss")
|
|
|
|
(define-syntax gl-vector-binop
|
|
(syntax-rules ()
|
|
((_ op name make-res)
|
|
(case-lambda
|
|
((v)
|
|
(unless (gl-vector? v)
|
|
(raise-type-error name "gl-vector" v))
|
|
(let* ((l (cvector-length v))
|
|
(res (make-res l)))
|
|
(let loop ((i 0))
|
|
(when (< i l)
|
|
(cvector-set! res i (op (cvector-ref v i)))
|
|
(loop (add1 i)))
|
|
res)))
|
|
((v1 v2)
|
|
(unless (gl-vector? v1)
|
|
(raise-type-error name "gl-vector" 0 v1 v2))
|
|
(unless (gl-vector? v2)
|
|
(raise-type-error name "gl-vector" 1 v1 v2))
|
|
(unless (= (cvector-length v1) (cvector-length v2))
|
|
(error name "given gl-vector arguments of unequal lengths: ~a"
|
|
(list (cvector-length v1) (cvector-length v2))))
|
|
(let* ((l (cvector-length v1))
|
|
(t (cvector-type v1))
|
|
(res (make-res l)))
|
|
(let loop ((i 0))
|
|
(when (< i l)
|
|
(cvector-set! res i (op (cvector-ref v1 i) (cvector-ref v2 i)))
|
|
(loop (add1 i))))
|
|
res))
|
|
((v . vs)
|
|
(let ((all-v (cons v vs)))
|
|
(unless (andmap gl-vector? all-v)
|
|
(let loop ((i 0)
|
|
(to-check all-v))
|
|
(unless (null? to-check)
|
|
(unless (gl-vector? (car to-check))
|
|
(apply raise-type-error (list* name "gl-vector" i all-v)))
|
|
(loop (add1 i) (cdr to-check)))))
|
|
(let ((l (cvector-length v)))
|
|
(unless (andmap (lambda (x) (= l (cvector-length x))) vs)
|
|
(error name "given gl-vector arguments of unequal lengths: ~a"
|
|
(map cvector-length all-v)))
|
|
(let ((res (make-res l)))
|
|
(let loop ((i 0))
|
|
(when (< i l)
|
|
(cvector-set! res i (apply op (map (lambda (x) (cvector-ref x i))
|
|
all-v)))
|
|
(loop (add1 i))))
|
|
res))))))))
|
|
|
|
(define-for-syntax (d->so stx str)
|
|
(datum->syntax-object stx (string->symbol str)))
|
|
|
|
(define-syntax (define-gl-vector stx)
|
|
(syntax-case stx ()
|
|
((_ type)
|
|
(let ((t (syntax-object->datum #'type)))
|
|
(with-syntax (((v? make-v v vector->v list->v v+ v- v*)
|
|
(map
|
|
(lambda (fmt)
|
|
(d->so #'type (format fmt t)))
|
|
'("gl-~a-vector?" "make-gl-~a-vector" "gl-~a-vector"
|
|
"vector->gl-~a-vector" "list->gl-~a-vector"
|
|
"gl-~a-vector+" "gl-~a-vector-" "gl-~a-vector*")))
|
|
(gl-type (d->so #'type (format "_gl-~a" t)))
|
|
(gl-vtype (d->so #'type (format "_gl-~av" t))))
|
|
#'(begin
|
|
(provide v? make-v v vector->v list->v v+ v- v*)
|
|
(define (v? v)
|
|
(and (cvector? v)
|
|
(eq? (cvector-type v) gl-type)))
|
|
(define (make-v len)
|
|
(make-cvector gl-type len))
|
|
(define (v . args)
|
|
(apply cvector (cons gl-type args)))
|
|
(define (vector->v v)
|
|
(unless (vector? v)
|
|
(raise-type-error 'vector->v "vector" v))
|
|
(list->cvector (vector->list v) gl-type))
|
|
(define (list->v l)
|
|
(list->cvector l gl-type))
|
|
(define v+ (gl-vector-binop + 'v+ make-v))
|
|
(define v- (gl-vector-binop - 'v- make-v))
|
|
(define (v* n v)
|
|
(unless (real? n)
|
|
(raise-type-error 'gl-vector* "real number" 0 n v))
|
|
(unless (gl-vector? v)
|
|
(raise-type-error 'gl-vector* "gl-vector" 1 n v))
|
|
(let* ((l (cvector-length v))
|
|
(t (cvector-type v))
|
|
(res (make-v l)))
|
|
(let loop ((i 0))
|
|
(when (< i l)
|
|
(cvector-set! res i (* n (cvector-ref v i)))
|
|
(loop (add1 i))))
|
|
res))))))))
|
|
|
|
(define-syntax define-gl-vectors
|
|
(syntax-rules ()
|
|
((_ type)
|
|
(define-gl-vector type))
|
|
((_ type rest ...)
|
|
(begin
|
|
(define-gl-vector type)
|
|
(define-gl-vectors rest ...)))))
|
|
|
|
(define-gl-vectors byte ubyte short ushort int uint
|
|
float double boolean)
|
|
(provide gl-vector->vector gl-vector->list gl-vector-length gl-vector-ref
|
|
gl-vector-set! gl-vector? gl-vector-norm)
|
|
(define (gl-vector->vector v)
|
|
(list->vector (cvector->list v)))
|
|
(define gl-vector->list cvector->list)
|
|
(define gl-vector-length cvector-length)
|
|
(define gl-vector-ref cvector-ref)
|
|
(define gl-vector-set! cvector-set!)
|
|
(define gl-vector? cvector?)
|
|
(define (gl-vector-norm v)
|
|
(unless (gl-vector? v)
|
|
(raise-type-error 'gl-vector-norm "gl-vector" v))
|
|
(let ((l (gl-vector-length v)))
|
|
(let loop ((i 0)
|
|
(res 0))
|
|
(cond
|
|
((< i l)
|
|
(loop (add1 i) (+ (expt (gl-vector-ref v i) 2) res)))
|
|
(else
|
|
(sqrt res))))))
|
|
)
|