;;;; misc-vector-math-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '23

;;;; Issues
;;
;; - Functor (VECTOR FIELD) - f32vector & fL | ...

(module misc-vector-math-utils

(;export
  absolute-magnitude
  cosine-similarity
  vector-apply
  vector-mul vector-div
  vector-sum vector-dif
  vector-min vector-max vector-lcm vector-gcd
  vector-compare
  vector<? vector=? vector>? vector<=? vector>=?
  dot-product
  cross-product)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken type))

;(define-type real (or integer ratnum float))

(define-type boolean-vector (vector-of boolean))
(define-type number-vector (vector-of number))

(define-type nary (* * #!rest * -> *))

(define-type nary-numeric (number number #!rest number -> *))

(: absolute-magnitude (number-vector -> number))

(: cosine-similarity (number-vector number-vector -> number))

(: vector-apply (nary vector vector #!rest vector -> vector))

(: vector-mul (number-vector number-vector #!rest number-vector -> number-vector))
(: vector-div (number-vector number-vector #!rest number-vector -> number-vector))
(: vector-sum (number-vector number-vector #!rest number-vector -> number-vector))
(: vector-dif (number-vector number-vector #!rest number-vector -> number-vector))
(: vector-min (number-vector number-vector #!rest number-vector -> number-vector))
(: vector-max (number-vector number-vector #!rest number-vector -> number-vector))
(: vector-lcm (number-vector number-vector #!rest number-vector -> number-vector))
(: vector-gcd (number-vector number-vector #!rest number-vector -> number-vector))

(: vector-compare (number-vector number-vector -> number-vector))

(: vector<? (number-vector number-vector #!rest number-vector -> boolean-vector))
(: vector=? (number-vector number-vector #!rest number-vector -> boolean-vector))
(: vector>? (number-vector number-vector #!rest number-vector -> boolean-vector))
(: vector<=? (number-vector number-vector #!rest number-vector -> boolean-vector))
(: vector>=? (number-vector number-vector #!rest number-vector -> boolean-vector))

(: dot-product (number-vector number-vector -> number))

(: cross-product (number-vector number-vector -> (or number number-vector)))

;;

(define-inline (sqrt-exact x) (inexact->exact (sqrt x)))
(define-inline (sqr a) (* a a))

(define (absolute-magnitude v)
  (let ((len (vector-length v)))
    (let loop ((i 0) (acc 0))
      (if (fx= i len) (sqrt-exact acc)
          (loop (fx+ i 1) (+ (sqr (vector-ref v i)) acc))) ) ) )

;https://en.wikipedia.org/wiki/Cosine_similarity
(define (cosine-similarity a b)
  ;unroll
  (let ((len (vector-length a)))
    (let loop ((i 0) (dot 0) (maga 0) (magb 0))
      (if (fx= i len) (/ dot (sqrt-exact (* maga magb)))
          (let ((ai (vector-ref a i)) (bi (vector-ref b i)))
            (loop (fx+ i 1) (+ (* ai bi) dot) (+ (sqr ai) maga) (+ (sqr bi) magb)) ) ) ) ) )

; assumes all same length
(define (vector-apply f . vs)
  (let* ((a (car vs))
         (n (vector-length a))
         (r (make-vector n)) )
    (do ((i 0 (fx+ i 1)))
        ((fx= i n) r)
      (set! (vector-ref r i)
            (apply f (map (cut vector-ref <> i) vs))) ) ) )

(define (vector-mul a b . vs) (apply vector-apply * a b vs))
(define (vector-div a b . vs) (apply vector-apply / a b vs))
(define (vector-sum a b . vs) (apply vector-apply + a b vs))
(define (vector-dif a b . vs) (apply vector-apply - a b vs))
(define (vector-min a b . vs) (apply vector-apply min a b vs))
(define (vector-max a b . vs) (apply vector-apply max a b vs))
(define (vector-lcm a b . vs) (apply vector-apply lcm a b vs))
(define (vector-gcd a b . vs) (apply vector-apply gcd a b vs))

(define (vector-compare a b) (apply vector-apply - b a))

(define (vector<? a b . vs) (apply vector-apply < a b vs))
(define (vector=? a b . vs) (apply vector-apply = a b vs))
(define (vector>? a b . vs) (apply vector-apply > a b vs))
(define (vector<=? a b . vs) (apply vector-apply <= a b vs))
(define (vector>=? a b . vs) (apply vector-apply >= a b vs))

(define (dot-product a b)
  (let ((len (vector-length a)))
    (let loop ((i 0) (acc 0))
      (if (fx= i len) acc
          (loop (fx+ i 1) (+ (* (vector-ref a i) (vector-ref b i)) acc))) ) ) )

;0 1 2 -> X, 3 -> #(X Y Z), 4 -> #(X Y Z W), 8 -> #(X Y Z W I J K L), * -> Error
(define (cross-product a b)
  (let ((alen (vector-length a)) (blen (vector-length b)))
    (if (not (fx= alen blen))
        (error 'cross-product "undefined for varying length" alen blen)
        (cond ((fx= 0 alen)
               0 )
              ((fx= 1 alen)
                (* (vector-ref a 0) (vector-ref b 0)) )
              ((fx= 2 alen)
                (- (* (vector-ref a 0) (vector-ref b 1))
                   (* (vector-ref a 1) (vector-ref b 0))) )
              ((fx= 3 alen)
                (vector
                  ;0
                  (- (* (vector-ref a 1) (vector-ref b 2))
                     (* (vector-ref a 2) (vector-ref b 1)))
                  ;1
                  (- (* (vector-ref a 2) (vector-ref b 0))
                     (* (vector-ref a 0) (vector-ref b 2)))
                  ;2
                  (- (* (vector-ref a 0) (vector-ref b 1))
                     (* (vector-ref a 1) (vector-ref b 0)))) )
              ((fx= 4 alen)
                ;{ {a[0] * b[0]} - {a[1] * b[1]} - {a[2] * b[2]} - {a[3] * b[3]} }
                ;{ {a[0] * b[1]} + {a[1] * b[0]} + {a[2] * b[3]} - {a[3] * b[2]} }
                ;{ {a[0] * b[2]} - {a[1] * b[3]} + {a[2] * b[0]} + {a[3] * b[1]} }
                ;{ {a[0] * b[3]} + {a[1] * b[2]} - {a[2] * b[1]} + {a[3] * b[0]} }
                (vector
                  ;0
                  (- (* (vector-ref a 0) (vector-ref b 0))
                     (* (vector-ref a 1) (vector-ref b 1))
                     (* (vector-ref a 2) (vector-ref b 2))
                     (* (vector-ref a 3) (vector-ref b 3)))
                  ;1
                  (- (+ (+ (* (vector-ref a 0) (vector-ref b 1))
                           (* (vector-ref a 1) (vector-ref b 0)))
                        (* (vector-ref a 2) (vector-ref b 3)))
                     (* (vector-ref a 3) (vector-ref b 2)))
                  ;2
                  (+ (+ (- (* (vector-ref a 0) (vector-ref b 2))
                           (* (vector-ref a 1) (vector-ref b 3)))
                        (* (vector-ref a 2) (vector-ref b 0)))
                     (* (vector-ref a 3) (vector-ref b 1)))
                  ;3
                  (+ (- (+ (* (vector-ref a 0) (vector-ref b 3))
                           (* (vector-ref a 1) (vector-ref b 2)))
                        (* (vector-ref a 2) (vector-ref b 1)))
                     (* (vector-ref a 3) (vector-ref b 0)))) )
              ((fx= 8 alen)
                ;{ {a[0] * b[0]} - {a[1] * b[1]} - {a[2] * b[2]} - {a[3] * b[3]} - {b[4] * a[4]} - {b[5] * a[5]} - {b[6] * a[6]} - {b[7] * a[7]} }
                ;{ {a[0] * b[1]} + {a[1] * b[0]} + {a[2] * b[3]} - {a[3] * b[2]} - {b[4] * a[5]} + {b[5] * a[4]} + {b[6] * a[7]} - {b[7] * a[6]} }
                ;{ {a[0] * b[2]} - {a[1] * b[3]} + {a[2] * b[0]} + {a[3] * b[1]} - {b[4] * a[6]} - {b[5] * a[7]} + {b[6] * a[4]} + {b[7] * a[5]} }
                ;{ {a[0] * b[3]} + {a[1] * b[2]} - {a[2] * b[1]} + {a[3] * b[0]} - {b[4] * a[7]} + {b[5] * a[6]} - {b[6] * a[5]} + {b[7] * a[4]} }
                ;{ {b[4] * a[0]} - {b[5] * a[1]} - {b[6] * a[2]} - {b[7] * a[3]} + {a[4] * b[0]} + {a[5] * b[1]} + {a[6] * b[2]} + {a[7] * b[3]} }
                ;{ {b[4] * a[1]} + {b[5] * a[0]} + {b[6] * a[3]} - {b[7] * a[2]} - {a[4] * b[1]} + {a[5] * b[0]} - {a[6] * b[3]} + {a[7] * b[2]} }
                ;{ {b[4] * a[2]} - {b[5] * a[3]} + {b[6] * a[0]} + {b[7] * a[1]} - {a[4] * b[2]} + {a[5] * b[3]} + {a[6] * b[0]} - {a[7] * b[1]} }
                ;{ {b[4] * a[3]} + {b[5] * a[2]} - {b[6] * a[1]} + {b[7] * a[0]} - {a[4] * b[3]} - {a[5] * b[2]} + {a[6] * b[1]} + {a[7] * b[0]} }

                (vector
                  ;0
                  (- (* (vector-ref a 0) (vector-ref b 0))
                     (* (vector-ref a 1) (vector-ref b 1))
                     (* (vector-ref a 2) (vector-ref b 2))
                     (* (vector-ref a 3) (vector-ref b 3))
                     (* (vector-ref b 4) (vector-ref a 4))
                     (* (vector-ref b 5) (vector-ref a 5))
                     (* (vector-ref b 6) (vector-ref a 6))
                     (* (vector-ref b 7) (vector-ref a 7)))
                  ;1
                  (- (+ (+ (- (- (+ (+ (* (vector-ref a 0) (vector-ref b 1))
                                       (* (vector-ref a 1) (vector-ref b 0)))
                                    (* (vector-ref a 2) (vector-ref b 3)))
                                 (* (vector-ref a 3) (vector-ref b 2)))
                              (* (vector-ref b 4) (vector-ref a 5)))
                           (* (vector-ref b 5) (vector-ref a 4)))
                        (* (vector-ref b 6) (vector-ref a 7)))
                     (* (vector-ref b 7) (vector-ref a 6)))
                  ;2
                  (+ (+ (- (- (+ (+ (- (* (vector-ref a 0) (vector-ref b 2))
                                       (* (vector-ref a 1) (vector-ref b 3)))
                                    (* (vector-ref a 2) (vector-ref b 0)))
                                 (* (vector-ref a 3) (vector-ref b 1)))
                              (* (vector-ref b 4) (vector-ref a 6)))
                           (* (vector-ref b 5) (vector-ref a 7)))
                        (* (vector-ref b 6) (vector-ref a 4)))
                     (* (vector-ref b 7) (vector-ref a 5)))
                  ;3
                  (+ (- (+ (- (+ (- (+ (* (vector-ref a 0) (vector-ref b 3))
                                       (* (vector-ref a 1) (vector-ref b 2)))
                                    (* (vector-ref a 2) (vector-ref b 1)))
                                 (* (vector-ref a 3) (vector-ref b 0)))
                              (* (vector-ref b 4) (vector-ref a 7)))
                           (* (vector-ref b 5) (vector-ref a 6)))
                        (* (vector-ref b 6) (vector-ref a 5)))
                     (* (vector-ref b 7) (vector-ref a 4)))
                  ;4
                  (+ (+ (+ (+ (- (- (- (* (vector-ref b 4) (vector-ref a 0))
                                       (* (vector-ref b 5) (vector-ref a 1)))
                                    (* (vector-ref b 6) (vector-ref a 2)))
                                 (* (vector-ref b 7) (vector-ref a 3)))
                              (* (vector-ref a 4) (vector-ref b 0)))
                           (* (vector-ref a 5) (vector-ref b 1)))
                        (* (vector-ref a 6) (vector-ref b 2)))
                     (* (vector-ref a 7) (vector-ref b 3)))
                  ;5
                  (+ (- (+ (- (- (+ (+ (* (vector-ref b 4) (vector-ref a 1))
                                       (* (vector-ref b 5) (vector-ref a 0)))
                                    (* (vector-ref b 6) (vector-ref a 3)))
                                 (* (vector-ref b 7) (vector-ref a 2)))
                              (* (vector-ref a 4) (vector-ref b 1)))
                           (* (vector-ref a 5) (vector-ref b 0)))
                        (* (vector-ref a 6) (vector-ref b 3)))
                     (* (vector-ref a 7) (vector-ref b 2)))
                  ;6
                  (- (+ (+ (- (+ (+ (- (* (vector-ref b 4) (vector-ref a 2))
                                       (* (vector-ref b 5) (vector-ref a 3)))
                                    (* (vector-ref b 6) (vector-ref a 0)))
                                 (* (vector-ref b 7) (vector-ref a 1)))
                              (* (vector-ref a 4) (vector-ref b 2)))
                           (* (vector-ref a 5) (vector-ref b 3)))
                        (* (vector-ref a 6) (vector-ref b 0)))
                     (* (vector-ref a 7) (vector-ref b 1)))
                  ;7
                  (+ (+ (- (- (+ (- (+ (* (vector-ref b 4) (vector-ref a 3))
                                       (* (vector-ref b 5) (vector-ref a 2)))
                                    (* (vector-ref b 6) (vector-ref a 1)))
                                 (* (vector-ref b 7) (vector-ref a 0)))
                              (* (vector-ref a 4) (vector-ref b 3)))
                           (* (vector-ref a 5) (vector-ref b 2)))
                        (* (vector-ref a 6) (vector-ref b 1)))
                     (* (vector-ref a 7) (vector-ref b 0)))) )
              (else
               (error 'cross-product "undefined for this length" alen blen) ) ) ) ) )

) ;misc-vector-math-utils