
;; Incompatible procedures, which are taken from the SRFI-43
;; reference implementation:
;;
;; * vector-map
;; * vector-map!
;; * vector-for-each
;; * vector-fold
;; * vector-fold-right
;; * vector-count

(define-module srfi/43
  (import (prefix (srfi 133) s133-))
  (export
   ;;; Constructors
   make-vector vector
   vector-unfold                   vector-unfold-right
   vector-copy                     vector-reverse-copy
   vector-append                   vector-concatenate

   ;;; Predicates
   vector?
   vector-empty?
   vector=

   ;;; Selectors
   vector-ref
   vector-length

   ;;; Iteration
   vector-fold                     vector-fold-right
   vector-map                      vector-map!
   vector-for-each
   vector-count

   ;;; Searching
   vector-index                    vector-skip
   vector-index-right              vector-skip-right
   vector-binary-search
   vector-any                      vector-every

   ;;; Mutators
   vector-set!
   vector-swap!
   vector-fill!
   vector-copy!                    vector-reverse-copy!
   vector-reverse!

   ;;; Conversion
   vector->list                    reverse-vector->list
   list->vector                    reverse-list->vector
   )


;; We'll be bringing lots of bindings from the SCHEME module, so we
;; give it a short name.
(define scheme (find-module 'SCHEME))

;; Let's not write the fill line for each defined symbol, as they are
;; all very similar.
;;
(define-syntax from-scheme
  (syntax-rules ()
    ((_ name)
     (define name (symbol-value (quote name) scheme)))))

(define-macro (from-133 name)
  `(define ,name ,(string->symbol
                   (string-append "s133-"
                                  (symbol->string name)))))




(define unspecified-value void)

;++ This should be implemented more efficiently.  It shouldn't cons a
;++ closure, and the cons cells used in the loops when using this could
;++ be reused.
(define (vectors-ref vectors i)
  (map (lambda (v) (vector-ref v i)) vectors))


;;; (CHECK-TYPE <type-predicate?> <value> <callee>) -> value
;;;   Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an
;;;   error stating that VALUE did not satisfy TYPE-PREDICATE?, showing
;;;   that this happened while calling CALLEE.  Return VALUE if no
;;;   error was signalled.
(define (check-type pred? value callee)
  (if (pred? value)
      value
      ;; Recur: when (or if) the user gets a debugger prompt, he can
      ;; proceed where the call to ERROR was with the correct value.
      (check-type pred?
                  (error "erroneous value"
                         (list pred? value)
                         `(while calling ,callee))
                  callee)))

;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
;;;       -> exact, nonnegative integer
;;;   Compute the smallest length of VECTOR-LIST.  DEFAULT-LENGTH is
;;;   the length that is returned if VECTOR-LIST is empty.  Common use
;;;   of this is in n-ary vector routines:
;;;     (define (f vec . vectors)
;;;       (let ((vec (check-type vector? vec f)))
;;;         ...(%smallest-length vectors (vector-length vec) f)...))
;;;   %SMALLEST-LENGTH takes care of the type checking -- which is what
;;;   the CALLEE argument is for --; thus, the design is tuned for
;;;   avoiding redundant type checks.
(define %smallest-length
  (letrec ((loop (lambda (vector-list length callee)
                   (if (null? vector-list)
                       length
                       (loop (cdr vector-list)
                             (min (vector-length
                                   (check-type vector?
                                               (car vector-list)
                                               callee))
                                  length)
                             callee)))))
    loop))

;; Constructors

(from-scheme make-vector)
(from-scheme vector)
(from-133    vector-unfold)
(from-133    vector-unfold-right)

(define r7rs-vector-copy (symbol-value 'vector-copy scheme))
(define (vector-copy v :optional (start 0) stop (fill #void fill?))
  (let ((stop (if stop stop (vector-length v))))
    (if (<= stop (vector-length v))
        (r7rs-vector-copy v start stop)
        (let ((w (make-vector (- stop start))))
          (dotimes (i (- (vector-length v) start))
            (vector-set! w i (vector-ref v (+ start i))))
          (dotimes (i (- stop (vector-length v)))
            (vector-set! w (+ i (- (vector-length v) start))  fill))
          w))))


(from-133    vector-reverse-copy)
(from-scheme vector-append)
(from-133    vector-concatenate)

;; Predicates

(from-scheme vector?)
(from-133    vector-empty?)
(from-133    vector=)

;; Selectors

(from-scheme vector-ref)
(from-scheme vector-length)

;; Iteration

;;; (%VECTOR-FOLD1 <kons> <knil> <vector>) -> knil'
;;;     (KONS <index> <knil> <elt>) -> knil'
(define %vector-fold1
  (letrec ((loop (lambda (kons knil len vec i)
                   (if (= i len)
                       knil
                       (loop kons
                             (kons i knil (vector-ref vec i))
                             len vec (+ i 1))))))
    (lambda (kons knil len vec)
      (loop kons knil len vec 0))))

;;; (%VECTOR-FOLD2+ <kons> <knil> <vector> ...) -> knil'
;;;     (KONS <index> <knil> <elt> ...) -> knil'
(define %vector-fold2+
  (letrec ((loop (lambda (kons knil len vectors i)
                   (if (= i len)
                       knil
                       (loop kons
                             (apply kons i knil
                                    (vectors-ref vectors i))
                             len vectors (+ i 1))))))
    (lambda (kons knil len vectors)
      (loop kons knil len vectors 0))))

;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
;;;   The fundamental vector iterator.  KONS is iterated over each
;;;   index in all of the vectors in parallel, stopping at the end of
;;;   the shortest; KONS is applied to an argument list of (list I
;;;   STATE (vector-ref VEC I) ...), where STATE is the current state
;;;   value -- the state value begins with KNIL and becomes whatever
;;;   KONS returned at the respective iteration --, and I is the
;;;   current index in the iteration.  The iteration is strictly left-
;;;   to-right.
;;;     (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
;;;       <=>
;;;     (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
(define (vector-fold kons knil vec . vectors)
  (let ((kons (check-type procedure? kons vector-fold))
        (vec  (check-type vector?    vec  vector-fold)))
    (if (null? vectors)
        (%vector-fold1 kons knil (vector-length vec) vec)
        (%vector-fold2+ kons knil
                        (%smallest-length vectors
                                          (vector-length vec)
                                          vector-fold)
                        (cons vec vectors)))))

;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
;;;   The fundamental vector recursor.  Iterates in parallel across
;;;   VECTOR ... right to left, applying KONS to the elements and the
;;;   current state value; the state value becomes what KONS returns
;;;   at each next iteration.  KNIL is the initial state value.
;;;     (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
;;;       <=>
;;;     (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
;;;
;;; Not implemented in terms of a more primitive operations that might
;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
;;; useful elsewhere.
(define vector-fold-right
  (letrec ((loop1 (lambda (kons knil vec i)
                    (if (negative? i)
                        knil
                        (loop1 kons (kons i knil (vector-ref vec i))
                               vec
                               (- i 1)))))
           (loop2+ (lambda (kons knil vectors i)
                     (if (negative? i)
                         knil
                         (loop2+ kons
                                 (apply kons i knil
                                        (vectors-ref vectors i))
                                 vectors
                                 (- i 1))))))
    (lambda (kons knil vec . vectors)
      (let ((kons (check-type procedure? kons vector-fold-right))
            (vec  (check-type vector?    vec  vector-fold-right)))
        (if (null? vectors)
            (loop1  kons knil vec (- (vector-length vec) 1))
            (loop2+ kons knil (cons vec vectors)
                    (- (%smallest-length vectors
                                         (vector-length vec)
                                         vector-fold-right)
                       1)))))))

;;; (%VECTOR-MAP! <f> <target> <length> <vector>) -> target
;;;     (F <index> <elt>) -> elt'
(define %vector-map1!
  (letrec ((loop (lambda (f target vec i)
                   (if (zero? i)
                       target
                       (let ((j (- i 1)))
                         (vector-set! target j
                                      (f j (vector-ref vec j)))
                         (loop f target vec j))))))
    (lambda (f target vec len)
      (loop f target vec len))))

;;; (%VECTOR-MAP2+! <f> <target> <vectors> <len>) -> target
;;;     (F <index> <elt> ...) -> elt'
(define %vector-map2+!
  (letrec ((loop (lambda (f target vectors i)
                   (if (zero? i)
                       target
                       (let ((j (- i 1)))
                         (vector-set! target j
                           (apply f j (vectors-ref vectors j)))
                         (loop f target vectors j))))))
    (lambda (f target vectors len)
      (loop f target vectors len))))

;;; (VECTOR-MAP <f> <vector> ...) -> vector
;;;     (F <elt> ...) -> value ; N vectors -> N args
;;;   Constructs a new vector of the shortest length of the vector
;;;   arguments.  Each element at index I of the new vector is mapped
;;;   from the old vectors by (F I (vector-ref VECTOR I) ...).  The
;;;   dynamic order of application of F is unspecified.
(define (vector-map f vec . vectors)
  (let ((f   (check-type procedure? f   vector-map))
        (vec (check-type vector?    vec vector-map)))
    (if (null? vectors)
        (let ((len (vector-length vec)))
          (%vector-map1! f (make-vector len) vec len))
        (let ((len (%smallest-length vectors
                                     (vector-length vec)
                                     vector-map)))
          (%vector-map2+! f (make-vector len) (cons vec vectors)
                          len)))))

;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified
;;;     (F <elt> ...) -> element' ; N vectors -> N args
;;;   Similar to VECTOR-MAP, but rather than mapping the new elements
;;;   into a new vector, the new mapped elements are destructively
;;;   inserted into the first vector.  Again, the dynamic order of
;;;   application of F is unspecified, so it is dangerous for F to
;;;   manipulate the first VECTOR.
(define (vector-map! f vec . vectors)
  (let ((f   (check-type procedure? f   vector-map!))
        (vec (check-type vector?    vec vector-map!)))
    (if (null? vectors)
        (%vector-map1!  f vec vec (vector-length vec))
        (%vector-map2+! f vec (cons vec vectors)
                        (%smallest-length vectors
                                          (vector-length vec)
                                          vector-map!)))
    (unspecified-value)))

;;; (VECTOR-FOR-EACH <f> <vector> ...) -> unspecified
;;;     (F <elt> ...) ; N vectors -> N args
;;;   Simple vector iterator: applies F to each index in the range [0,
;;;   LENGTH), where LENGTH is the length of the smallest vector
;;;   argument passed, and the respective element at that index.  In
;;;   contrast with VECTOR-MAP, F is reliably applied to each
;;;   subsequent elements, starting at index 0 from left to right, in
;;;   the vectors.
(define vector-for-each
  (letrec ((for-each1
            (lambda (f vec i len)
              (cond ((< i len)
                     (f i (vector-ref vec i))
                     (for-each1 f vec (+ i 1) len)))))
           (for-each2+
            (lambda (f vecs i len)
              (cond ((< i len)
                     (apply f i (vectors-ref vecs i))
                     (for-each2+ f vecs (+ i 1) len))))))
    (lambda (f vec . vectors)
      (let ((f   (check-type procedure? f   vector-for-each))
            (vec (check-type vector?    vec vector-for-each)))
        (if (null? vectors)
            (for-each1 f vec 0 (vector-length vec))
            (for-each2+ f (cons vec vectors) 0
                        (%smallest-length vectors
                                          (vector-length vec)
                                          vector-for-each)))))))


;;; (VECTOR-COUNT <predicate?> <vector> ...)
;;;       -> exact, nonnegative integer
;;;     (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
;;;   PREDICATE? is applied element-wise to the elements of VECTOR ...,
;;;   and a count is tallied of the number of elements for which a
;;;   true value is produced by PREDICATE?.  This count is returned.
(define (vector-count pred? vec . vectors)
  (let ((pred? (check-type procedure? pred? vector-count))
        (vec   (check-type vector?    vec   vector-count)))
    (if (null? vectors)
        (%vector-fold1 (lambda (index count elt)
                         (if (pred? index elt)
                             (+ count 1)
                             count))
                       0
                       (vector-length vec)
                       vec)
        (%vector-fold2+ (lambda (index count . elts)
                          (if (apply pred? index elts)
                              (+ count 1)
                              count))
                        0
                        (%smallest-length vectors
                                          (vector-length vec)
                                          vector-count)
                        (cons vec vectors)))))

;; Searching

(from-133 vector-index)
(from-133 vector-index-right)
(from-133 vector-skip)
(from-133 vector-skip-right)
(from-133 vector-binary-search)
(from-133 vector-any)
(from-133 vector-every)

;; Mutators

(from-scheme vector-set!)
(from-133    vector-swap!)
(from-scheme vector-fill!)
(from-133    vector-reverse!)
(from-scheme vector-copy!)
(from-133    vector-reverse-copy!)

;; Conversion


(from-scheme vector->list)
(from-133    reverse-vector->list)
(from-scheme list->vector)
(from-133    reverse-list->vector)


)

(provide "srfi/43")
