diff options
Diffstat (limited to 'implementation/flexvectors-body2.scm')
-rw-r--r-- | implementation/flexvectors-body2.scm | 391 |
1 files changed, 391 insertions, 0 deletions
diff --git a/implementation/flexvectors-body2.scm b/implementation/flexvectors-body2.scm new file mode 100644 index 0000000..ba3e2f5 --- /dev/null +++ b/implementation/flexvectors-body2.scm @@ -0,0 +1,391 @@ +(define flexvector-unfold + (case-lambda + ((p f g seed) + (define fv (flexvector)) + (assume (procedure? p)) + (assume (procedure? f)) + (assume (procedure? g)) + (do ((seed seed (g seed))) ((p seed) fv) + (flexvector-add-back! fv (f seed)))) + ((p f g . seeds) + (define fv (flexvector)) + (assume (procedure? p)) + (assume (procedure? f)) + (assume (procedure? g)) + (do ((seeds seeds (let-values ((seeds (apply g seeds))) seeds))) + ((apply p seeds) fv) + (flexvector-add-back! fv (apply f seeds)))))) + +(define (flexvector-unfold-right . args) + (define fv (apply flexvector-unfold args)) + (flexvector-reverse! fv) + fv) + +(define (flexvector-reverse-copy . args) + (define fv (apply flexvector-copy args)) + (flexvector-reverse! fv) + fv) + +(define flexvector-reverse-copy! + (case-lambda + ((to at from) + (assume (flexvector? from)) + (flexvector-reverse-copy! to at from 0 (flexvector-length from))) + ((to at from start) + (assume (flexvector? from)) + (flexvector-reverse-copy! to at from start (flexvector-length from))) + ((to at from start end) + (flexvector-copy! to at from start end) + (flexvector-reverse! to at (+ at (- end start)))))) + +(define (flexvector-append! fv . fvs) + (assume (flexvector? fv)) + (assume (every flexvector? fvs)) + (for-each + (lambda (fv2) (flexvector-copy! fv (flexvector-length fv) fv2)) + fvs) + fv) + +(define (flexvector-front fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-ref fv 0)) + +(define (flexvector-back fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-ref fv (- (flexvector-length fv) 1))) + +(define flexvector-add-front! + (case-lambda + ((fv x) (flexvector-add! fv 0 x)) + ((fv . xs) (apply flexvector-add! fv 0 xs)))) + +(define (flexvector-remove-front! fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-remove! fv 0)) + +(define (flexvector-remove-back! fv) + (assume (flexvector? fv)) + (assume (not (flexvector-empty? fv))) + (flexvector-remove! fv (- (flexvector-length fv) 1))) + +(define (flexvector=? eq . o) + (cond + ((null? o) #t) + ((null? (cdr o)) #t) + (else + (and (let* ((fv1 (car o)) + (fv2 (cadr o)) + (len (flexvector-length fv1))) + (and (= len (flexvector-length fv2)) + (let lp ((i 0)) + (or (>= i len) + (and (eq (flexvector-ref fv1 i) (flexvector-ref fv2 i)) + (lp (+ i 1))))))) + (apply flexvector=? eq (cdr o)))))) + +(define (flexvector-fold kons knil fv1 . o) + (assume (procedure? kons)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (if (null? o) + (let lp ((i 0) (acc knil)) + (if (>= i len) acc (lp (+ i 1) (kons acc (flexvector-ref fv1 i))))) + (let lp ((i 0) (acc knil)) + (if (>= i len) + acc + (lp (+ i 1) + (apply kons acc (flexvector-ref v1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)))))))) + +(define (flexvector-fold-right kons knil fv1 . o) + (assume (procedure? kons)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (if (null? o) + (let lp ((i (- len 1)) (acc knil)) + (if (negative? i) acc (lp (- i 1) (kons acc (flexvector-ref fv1 i))))) + (let lp ((i (- len 1)) (acc knil)) + (if (negative? i) + acc + (lp (- i 1) + (apply kons acc (flexvector-ref v1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)))))))) + +(define flexvector-for-each/index + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (assume (flexvector? fv)) + (let ((len (flexvector-length fv))) + (do ((i 0 (+ i 1))) ((= i len)) + (proc i (flexvector-ref fv i))))) + ((proc . fvs) + (assume (procedure? proc)) + (let ((len (apply min (map flexvector-length fvs)))) + (do ((i 0 (+ i 1))) ((= i len)) + (apply proc i (map (lambda (fv) (flexvector-ref fv i)) fvs))))))) + +(define flexvector-for-each + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (flexvector-for-each/index (lambda (i x) (proc x)) fv)) + ((proc . fvs) + (assume (procedure? proc)) + (apply flexvector-for-each/index (lambda (i . xs) (apply proc xs)) fvs)))) + +(define flexvector-map/index! + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (assume (flexvector? fv)) + (flexvector-for-each/index + (lambda (i x) (flexvector-set! fv i (proc i x))) + fv) + fv) + ((proc fv . fvs) + (assume (procedure? proc)) + (assume (flexvector? fv)) + (apply flexvector-for-each/index + (lambda (i . xs) (flexvector-set! fv i (apply proc i xs))) + fv + fvs) + fv))) + +(define flexvector-map! + (case-lambda + ((proc fv) + (assume (procedure? proc)) + (flexvector-map/index! (lambda (i x) (proc x)) fv)) + ((proc . fvs) + (assume (procedure? proc)) + (apply flexvector-map/index! (lambda (i . xs) (apply proc xs)) fvs)))) + +(define (flexvector-map/index proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-map/index! proc (flexvector-copy fv) fvs)) + +(define (flexvector-map proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-map! proc (flexvector-copy fv) fvs)) + +(define (flexvector-append-map/index proc fv . fvs) + (define out (flexvector)) + (flexvector-for-each + (lambda (x) (flexvector-append! out x)) + (apply flexvector-map/index proc fv fvs)) + out) + +(define (flexvector-append-map proc fv . fvs) + (define out (flexvector)) + (flexvector-for-each + (lambda (x) (flexvector-append! out x)) + (apply flexvector-map proc fv fvs)) + out) + +(define flexvector-filter! + (case-lambda + ((pred? fv) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (flexvector-filter/index! (lambda (i x) (pred? x)) fv)) + ((pred? . fvs) + (assume (procedure? pred?)) + (apply flexvector-filter/index! (lambda (i . xs) (apply pred? xs)) fvs)))) + +(define (flexvector-filter/index proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-filter/index! proc (flexvector-copy fv) fvs)) + +(define (flexvector-filter proc fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-filter! proc (flexvector-copy fv) fvs)) + +(define (flexvector-index pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (let lp ((i 0)) + (and (< i len) + (if (apply pred? + (flexvector-ref fv1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)) + i + (lp (+ i 1))))))) + +(define (flexvector-index-right pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (let ((len (flexvector-length fv1))) + (let lp ((i (- len 1))) + (and (>= i 0) + (if (apply pred? + (flexvector-ref fv1 i) + (map (lambda (fv) (flexvector-ref fv i)) o)) + i + (lp (- i 1))))))) + +(define (complement f) + (lambda args (not (apply f args)))) + +(define (flexvector-skip pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (apply flexvector-index (complement pred?) fv1 o)) + +(define (flexvector-skip-right pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (apply flexvector-index-right (complement pred?) fv1 o)) + +(define flexvector-binary-search + (case-lambda + ((fv value cmp) + (flexvector-binary-search fv value cmp 0 (flexvector-length fv))) + ((fv value cmp start) + (flexvector-binary-search fv value cmp start (flexvector-length fv))) + ((fv value cmp start end) + (assume (flexvector? fv)) + (assume (procedure? cmp)) + (assume (integer? start)) + (assume (integer? end)) + (assume (<= start end)) + (let lp ((lo (max start 0)) + (hi (- (min end (flexvector-length fv)) 1))) + (and (<= lo hi) + (let* ((mid (quotient (+ lo hi) 2)) + (x (flexvector-ref fv mid)) + (y (cmp value x))) + (cond + ((< y 0) (lp lo (- mid 1))) + ((> y 0) (lp (+ mid 1) hi)) + (else mid)))))))) + +(define (flexvector-any pred? fv . o) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (let ((len (apply min (flexvector-length fv) (map flexvector-length o)))) + (let lp ((i 0)) + (and (< i len) + (or (apply pred? + (flexvector-ref fv i) + (map (lambda (v) (flexvector-ref v i)) o)) + (lp (+ i 1))))))) + +(define (flexvector-every pred? fv . o) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (let ((len (apply min (flexvector-length fv) (map flexvector-length o)))) + (or (zero? len) + (let lp ((i 0)) + (let ((x (apply pred? + (flexvector-ref fv i) + (map (lambda (v) (flexvector-ref v i)) o)))) + (if (= i (- len 1)) + x + (and x (lp (+ i 1))))))))) + +(define (flexvector-swap! fv i j) + (assume (flexvector? fv)) + (assume (integer? i)) + (assume (integer? j)) + (let ((tmp (flexvector-ref fv i))) + (flexvector-set! fv i (flexvector-ref fv j)) + (flexvector-set! fv j tmp))) + +(define (flexvector-reverse! fv . o) + (assume (flexvector? fv)) + (let lp ((left (if (pair? o) (car o) 0)) + (right (- (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (flexvector-length fv)) + 1))) + (cond + ((>= left right) (if #f #f)) + (else + (flexvector-swap! fv left right) + (lp (+ left 1) (- right 1)))))) + +(define (flexvector-reverse-copy! to at from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (flexvector-length from)))) + (flexvector-copy! to at from start end) + (flexvector-reverse! to at (+ at (- end start))))) + +(define (flexvector-append fv . fvs) + (assume (flexvector? fv)) + (apply flexvector-append! (flexvector-copy fv) fvs)) + +(define (flexvector-concatenate ls) + (apply flexvector-append ls)) + +(define (flexvector-append-subvectors . o) + (let lp ((ls o) (vecs '())) + (if (null? ls) + (flexvector-concatenate (reverse vecs)) + (lp (cdr (cddr ls)) + (cons (flexvector-copy (car ls) (cadr ls) (car (cddr ls))) vecs))))) + +(define (flexvector-empty? fv) + (assume (flexvector? fv)) + (zero? (flexvector-length fv))) + +(define (flexvector-count pred? fv1 . o) + (assume (procedure? pred?)) + (assume (flexvector? fv1)) + (apply flexvector-fold + (lambda (count . x) (+ count (if (apply pred? x) 1 0))) + 0 + fv1 o)) + +(define (flexvector-cumulate f knil fv) + (assume (procedure? f)) + (assume (flexvector? fv)) + (let* ((len (flexvector-length fv)) + (res (make-vector len))) + (let lp ((i 0) (acc knil)) + (if (>= i len) + (vector->flexvector res) + (let ((acc (f acc (flexvector-ref fv i)))) + (vector-set! res i acc) + (lp (+ i 1) acc)))))) + +(define (flexvector-partition pred? fv) + (assume (procedure? pred?)) + (assume (flexvector? fv)) + (let ((left (flexvector)) (right (flexvector))) + (flexvector-for-each + (lambda (x) (flexvector-add-back! (if (pred? x) left right) x)) + fv) + (values left right))) + +(define (flexvector->list fv) + (assume (flexvector? fv)) + (flexvector-fold-right (lambda (x y) (cons y x)) '() fv)) + +(define (reverse-flexvector->list fv . o) + (assume (flexvector? fv)) + (flexvector->list (apply flexvector-reverse-copy fv o))) + +(define (reverse-list->flexvector ls) + (assume (list? ls)) + (let ((fv (list->flexvector ls))) + (flexvector-reverse! fv) + fv)) + +(define (string->flexvector s . o) + (assume (string? s)) + (vector->flexvector (apply string->vector s o))) + +(define (flexvector->string fv . o) + (assume (flexvector? fv)) + (vector->string (apply flexvector->vector fv o))) + +(define (generator->flexvector g) + (assume (procedure? g)) + (flexvector-unfold eof-object? (lambda (x) x) (lambda (_) (g)) (g))) |