From d765d803cbfe3b4b79e78ca6bea01b3162a5f4a5 Mon Sep 17 00:00:00 2001 From: stibear Date: Thu, 19 Jun 2014 03:23:47 +0900 Subject: [PATCH] implements (srfi 43) --- piclib/srfi/43.scm | 247 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 247 insertions(+) create mode 100644 piclib/srfi/43.scm diff --git a/piclib/srfi/43.scm b/piclib/srfi/43.scm new file mode 100644 index 00000000..a30757e6 --- /dev/null +++ b/piclib/srfi/43.scm @@ -0,0 +1,247 @@ +(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))