(module gl-vectors mzscheme
  (require mzlib/foreign
           (only racket/base for/list in-list in-naturals)
           "gl-types.rkt")
  
  (define-syntax gl-vector-binop
    (syntax-rules ()
      ((_ op name make-res)
       (case-lambda
         ((v)
          (unless (gl-vector? v)
            (raise-argument-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-argument-error name "gl-vector?" 0 v1 v2))
          (unless (gl-vector? v2)
            (raise-argument-error name "gl-vector?" 1 v1 v2))
          (unless (= (cvector-length v1) (cvector-length v2))
            (raise-arguments-error name 
                                   "given gl-vector arguments of unequal lengths" 
                                   "first argument length" (cvector-length v1)
                                   "second argument length" (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-argument-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)
                (apply raise-arguments-error name 
                       "given gl-vector arguments of unequal lengths"
                       (apply
                        append
                        (for/list ([v (in-list all-v)]
                                   [i (in-naturals 1)])
                          (list (format "argument ~a" i)
                                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-argument-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-argument-error 'gl-vector* "real?" 0 n v))
                 (unless (gl-vector? v)
                   (raise-argument-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-argument-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))))))
)