;;;; srfi-27-vector-support.scm
;;;; Kon Lovett, Feb '10

;; Issues
;;
;; - More could be coded in C, there is a lot of overhead

; Chicken Generic Arithmetic!

(module srfi-27-vector-support

  (;export
    vector-filled! u8vector-filled! f32vector-filled! f64vector-filled!
    f32vector-mapi!/1 f32vector-foldi/1
    f64vector-mapi!/1 f64vector-foldi/1
    ;
    check-vector%
    vector%-length
    vector%-mapi!/1
    vector%-foldi/1
    vector%-filled!
    vector%-scale!
    vector%-sum-squares)

  (import
    scheme
    chicken
    (only srfi-4
      u8vector-length u8vector-ref u8vector-set!
      f32vector? f32vector-length f32vector-ref f32vector-set!
      f64vector? f64vector-length f64vector-ref f64vector-set!)
    (only vector-lib vector-map! vector-fold)
    (only type-errors error-vector))

  (require-library srfi-4 vector-lib type-errors)

;;;

(define (u8vector-filled! u8vec u8gen #!optional (start 0) (end (u8vector-length u8vec)))
  (do ((idx start (fx+ idx 1)))
      ((fx= end idx) u8vec)
    (u8vector-set! u8vec idx (u8gen)) ) )

(define (f64vector-filled! f64vec f64gen #!optional (start 0) (end (f64vector-length f64vec)))
  (do ((idx start (fx+ idx 1)))
      ((fx= end idx) f64vec)
    (f64vector-set! f64vec idx (f64gen)) ) )

(define (f32vector-filled! f32vec f32gen #!optional (start 0) (end (f32vector-length f32vec)))
  (do ((idx start (fx+ idx 1)))
      ((fx= end idx) f32vec)
    (f32vector-set! f32vec idx (f32gen)) ) )

(define (vector-filled! vec gen #!optional (start 0) (end (vector-length vec)))
  (do ((idx start (fx+ idx 1)))
      ((fx= end idx) vec)
    (vector-set! vec idx (gen)) ) )

(define (f32vector-mapi!/1 proc vec)
  (let ((len (f32vector-length vec)))
    (do ((i 0 (fx+ i 1)))
        ((fx= i len) vec)
      (f32vector-set! vec i (proc i (f32vector-ref vec i))) ) ) )

(define (f32vector-foldi/1 proc init vec)
  (let ((len (f32vector-length vec)))
    (do ((i 0 (fx+ i 1) )
         (acc init (proc i acc (f32vector-ref vec i)) ) )
        ((fx= i len) acc) ) ) )

(define (f64vector-mapi!/1 proc vec)
  (let ((len (f64vector-length vec)))
    (do ((i 0 (fx+ i 1)))
        ((fx= i len) vec)
      (f64vector-set! vec i (proc i (f64vector-ref vec i))) ) ) )

(define (f64vector-foldi/1 proc init vec)
  (let ((len (f64vector-length vec)))
    (do ((i 0 (fx+ i 1) )
         (acc init (proc i acc (f64vector-ref vec i)) ) )
        ((fx= i len) acc) ) ) )

;;; Vector% Support

#; ;NOT YET
(define (array-rank/1? obj) (and (array? obj) (fx= 1 (array-rank obj))))

(define (check-vector% loc obj #!optional argnam)
  (unless (or (vector? obj)
              (f32vector? obj)
              (f64vector? obj)
              #; ;NOT YET
              (array-rank/1? vec) )
    (error-vector loc obj argnam) ) )

(define (vector%-length vec)
  (cond ((vector? vec)        (vector-length vec))
        ((f32vector? vec)     (f32vector-length vec))
        ((f64vector? vec)     (f64vector-length vec))
        #; ;NOT YET
        ((array-rank/1? vec)  (car (array-dimensions vec)))
        (else
          (error-vector #f vec))) )

(define (vector%-mapi!/1 proc vec)
  (cond ((vector? vec)        (vector-map! proc vec))
        ((f32vector? vec)     (f32vector-mapi!/1 proc vec))
        ((f64vector? vec)     (f64vector-mapi!/1 proc vec))
        #; ;NOT YET
        ((array-rank/1? vec)  (array-map! vec (cut proc #f <>)))
        (else
          (error-vector #f vec))) )

(define (vector%-foldi/1 proc seed vec)
  (cond ((vector? vec)        (vector-fold proc seed vec))
        ((f32vector? vec)     (f32vector-foldi/1 proc seed vec))
        ((f64vector? vec)     (f64vector-foldi/1 proc seed vec))
        #; ;NOT YET
        ((array-rank/1? vec)  (array-fold (cut proc #f <> <>) seed vec))
        (else
          (error-vector #f vec))) )

(define (vector%-filled! vec func)
  (cond ((vector? vec)        (vector-filled! vec func))
        ((f32vector? vec)     (f32vector-filled! vec func))
        ((f64vector? vec)     (f64vector-filled! vec func))
        #; ;NOT YET
        ((array-rank/1? vec)  (array-fold (lambda (x y) (func)) #f vec))
        (else
          (error-vector #f vec))) )

(define (vector%-scale! vec factor)
  (vector%-mapi!/1 (lambda (i elt) (* elt factor)) vec) )

(define (vector%-sum-squares vec)
  (vector%-foldi/1 (lambda (i sum elt) (+ sum (* elt elt))) 0 vec) )

) ;module srfi-27-vector-support