(define-library (srfi 43) (import (scheme base) (srfi 8)) ;; # Constructors (define (vector-unfold f length . seeds) (let ((seeds (if (null? seeds) '(0) seeds)) (vect (make-vector length))) (letrec ((tabulate (lambda (count . args) (if (= length count) vect (receive lst (apply f count args) (vector-set! vect count (car lst)) (apply tabulate (+ 1 count) (cdr lst))))))) (apply tabulate 0 seeds)))) (define (vector-unfold-right f length . seeds) (let ((seeds (if (null? seeds) '(0) seeds)) (vect (make-vector length))) (letrec ((tabulate (lambda (count . args) (if (< count 0) vect (receive lst (apply f count args) (vector-set! vect count (car lst)) (apply tabulate (- count 1) (cdr lst))))))) (apply tabulate (- length 1) seeds)))) (define (vector-reverse-copy vec . rst) (let* ((start (if (null? rst) 0 (car rst))) (end (if (or (null? rst) (null? (cdr rst))) (vector-length vec) (cadr rst))) (new-vect (make-vector (- end start)))) (let loop ((i (- end 1)) (count 0)) (if (< i start) new-vect (begin (vector-set! new-vect count (vector-ref vec i)) (loop (- i 1) (+ 1 count))))))) (define (vector-concatenate list-of-vectors) (apply vector-append list-of-vectors)) ;; # Predicates (define (vector-empty? vec) (zero? (vector-length vec))) ; for the symmetry, this should be rather 'vector=?' than 'vector='. (define (vector= elt=? . vects) (letrec ((2vector= (lambda (v1 v2) (let ((ln1 (vector-length v1))) (and (= ln1 (vector-length v2)) (let loop ((count 0)) (if (= ln1 count) #t (and (elt=? (vector-ref v1 count) (vector-ref v2 count)) (loop (+ 1 count)))))))))) (or (null? vects) (let rec1 ((vect1 (car vects)) (others (cdr vects))) (or (null? others) (let ((vect2 (car others)) (others (cdr others))) (if (eq? vect1 vect2) (rec1 vect1 others) (and (2vector= vect1 vect2) (rec1 vect2 others))))))))) ;; # Iteration (define (vector-fold kons knil vec . vects) (let* ((vects (cons vec vects)) (veclen (apply min (map vector-length vects)))) (let rec ((acc knil) (count 0)) (if (= count veclen) acc (rec (apply kons count acc (map (lambda (v) (vector-ref v count)) vects)) (+ 1 count)))))) (define (vector-fold-right kons knil vec . vects) (let* ((vects (cons vec vects)) (veclen (apply min (map vector-length vects)))) (let rec ((acc knil) (count (- veclen 1))) (if (< count 0) acc (rec (apply kons count acc (map (lambda (v) (vector-ref v count)) vects)) (- count 1)))))) (define (vector-map! f vec . vects) (let* ((vects (cons vec vects)) (veclen (apply min (map vector-length vects))) (new-vect (make-vector veclen))) (let rec ((count 0)) (if (< count veclen) (begin (vector-set! vec count (apply f (map (lambda (v) (vector-ref v count)) vects))) (rec (+ 1 count))))))) (define (vector-count pred? vec . vects) (let* ((vects (cons vec vects)) (veclen (apply min (map vector-length vects)))) (let rec ((i 0) (count 0)) (if (= i veclen) count (if (apply pred? count (map (lambda (v) (vector-ref v count)) vects)) (rec (+ 1 i) (+ 1 count)) (rec (+ 1 i) count)))))) ;; # Searching (define (vector-index pred? vec . vects) (let* ((vects (cons vec vects)) (veclen (apply min (map vector-length vects)))) (let rec ((count 0)) (cond ((= count veclen) #f) ((apply pred? (map (lambda (v) (vector-ref v count)) vects)) count) (else (rec (+ 1 count))))))) (define (vector-index-right pred? vec . vects) (let ((vects (cons vec vects)) (veclen (vector-length vec))) (let rec ((count (- veclen 1))) (cond ((< count 0) #f) ((apply pred? (map (lambda (v) (vector-ref v count)) vects)) count) (else (rec (- count 1))))))) (define (vector-skip pred? vec . vects) (apply vector-index (lambda args (not (apply pred? args))) vec vects)) (define (vector-skip-right pred? vec . vects) (apply vector-index-right (lambda args (not (apply pred? args))) vec vects)) (define (vector-binary-search vec value cmp) (let rec ((start 0) (end (vector-length vec)) (n -1)) (let ((count (floor/ (+ start end) 2))) (if (or (= start end) (= count n)) #f (let ((comparison (cmp (vector-ref vec count) value))) (cond ((zero? comparison) count) ((positive? comparison) (rec start count count)) (else (rec count end count)))))))) (define (vector-any pred? vec . vects) (let* ((vects (cons vec vects)) (veclen (vector-length vec))) (let rec ((count 0)) (if (= count veclen) #f (or (apply pred? (map (lambda (v) (vector-ref v count)) vects)) (rec (+ 1 count))))))) (define (vector-every pred? vec . vects) (let* ((vects (cons vec vects)) (veclen (vector-length vec))) (let rec ((count 0)) (if (= count veclen) #t (and (apply pred? (map (lambda (v) (vector-ref v count)) vects)) (rec (+ 1 count))))))) ;; # Mutators (define (vector-swap! vec i j) (let ((tmp (vector-ref vec i))) (vector-set! vec i (vector-ref vec j)) (vector-set! vec j tmp))) (define (vector-reverse! vec . rst) (let ((start (if (null? rst) 0 (car rst))) (end (if (or (null? rst) (cdr rst)) (vector-length vec) (cadr rst)))) (let rec ((i start) (j (- end 1))) (if (< i j) (begin (vector-swap! vec i j) (rec (+ 1 i) (- j 1))))))) (define (vector-reverse-copy! target tstart source . rst) (let ((sstart (if (null? rst) 0 (car rst))) (send (if (or (null? rst) (cdr rst)) (vector-length source) (cadr rst)))) (let rec ((i tstart) (j (- send 1))) (if (>= j sstart) (begin (vector-set! target i (vector-ref source j)) (rec (+ 1 i) (- j 1))))))) ;; # Conversion (define (reverse-vector->list vec . rst) (let ((start (if (null? rst) 0 (car rst))) (end (if (or (null? rst) (cdr rst)) (vector-length vec) (cadr rst)))) (let rec ((i start) (acc '())) (if (= i end) acc (rec (+ 1 i) (cons (vector-ref vec i) acc)))))) (define (reverse-list->vector proper-list) (apply vector (reverse proper-list))) (export vector? make-vector vector vector-length vector-ref vector-set! vector->list list->vector vector-fill! vector-copy! vector-unfold vector-unfold-right vector-reverse-copy vector-concatenate vector-empty? vector= vector-fold vector-fold-right vector-map! vector-count vector-index vector-index-right vector-skip vector-skip-right vector-binary-search vector-any vector-every vector-swap! vector-reverse! vector-reverse-copy! reverse-vector->list reverse-list->vector))