Yuichi Nishiwaki
commit
11c1427860
|
|
@ -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))
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
(define-library (srfi 8)
|
||||
(import (scheme base))
|
||||
|
||||
(define-syntax receive
|
||||
(syntax-rules ()
|
||||
((receive formals expression body ...)
|
||||
(call-with-values (lambda () expression)
|
||||
(lambda formals body ...)))))
|
||||
|
||||
(export receive))
|
||||
Loading…
Reference in New Issue