srfi-214

  1(define-record-type Flexvector
  2  (%make-flexvector fv-vector fv-length)
  3  flexvector?
  4  (fv-vector vec set-vec!)
  5  (fv-length flexvector-length set-flexvector-length!))
  6
  7(define (cap fv)
  8  (vector-length (vec fv)))
  9
 10(define (grow! fv)
 11  (define old-vec (vec fv))
 12  (define new-vec (make-vector (quotient (* (vector-length old-vec) 3) 2)))
 13  (vector-copy! new-vec 0 old-vec)
 14  (set-vec! fv new-vec)
 15  new-vec)
 16
 17(define make-flexvector
 18  (case-lambda
 19    ((size)
 20      (assume (>= size 0))
 21      (%make-flexvector (make-vector (max size 4)) size))
 22    ((size fill)
 23      (assume (>= size 0))
 24      (%make-flexvector (make-vector (max size 4) fill) size))))
 25
 26(define (flexvector . xs)
 27  (if (null? xs)
 28    (%make-flexvector (make-vector 4) 0)
 29    (list->flexvector xs)))
 30
 31(define (flexvector-ref fv index)
 32  (assume (flexvector? fv))
 33  (assume (integer? index))
 34  (assume (< -1 index (flexvector-length fv)))
 35  (vector-ref (vec fv) index))
 36
 37(define (flexvector-set! fv index x)
 38  (assume (flexvector? fv))
 39  (assume (integer? index))
 40  (assume (< -1 index (flexvector-length fv)))
 41  (let ((last-value (vector-ref (vec fv) index)))
 42    (vector-set! (vec fv) index x)
 43    last-value))
 44
 45(define flexvector-add!
 46  (case-lambda
 47    ((fv i x)
 48      (assume (flexvector? fv))
 49      (assume (integer? i))
 50      (let* ((len (flexvector-length fv))
 51             (v (if (< len (cap fv)) (vec fv) (grow! fv))))
 52        (assume (<= 0 i len))
 53        (vector-copy! v (+ i 1) v i len)
 54        (vector-set! v i x)
 55        (set-flexvector-length! fv (+ len 1))
 56        fv))
 57    ((fv i . xs)
 58      (flexvector-add-all! fv i xs))))
 59
 60(define flexvector-add-back!
 61  (case-lambda
 62    ((fv x)
 63      (assume (flexvector? fv))
 64      (let* ((len (flexvector-length fv))
 65             (v (if (< len (cap fv)) (vec fv) (grow! fv))))
 66        (vector-set! v len x)
 67        (set-flexvector-length! fv (+ len 1))
 68        fv))
 69    ((fv x . xs)
 70      (flexvector-add-back! fv x)
 71      (apply flexvector-add-back! fv xs))))
 72
 73(define (flexvector-add-all! fv i xs)
 74  (assume (flexvector? fv))
 75  (assume (integer? i))
 76  (assume (list? xs))
 77  (let* ((len (flexvector-length fv))
 78         (xv (list->vector xs))
 79         (xvlen (vector-length xv))
 80         (v (let lp ((v (vec fv)))
 81              (if (< (+ len xvlen) (vector-length v)) v (lp (grow! fv))))))
 82    (assume (<= 0 i len))
 83    (vector-copy! v (+ i xvlen) v i len)
 84    (vector-copy! v i xv 0 xvlen)
 85    (set-flexvector-length! fv (+ len xvlen))
 86    fv))
 87
 88(define (flexvector-remove! fv i)
 89  (assume (flexvector? fv))
 90  (assume (integer? i))
 91  (assume (<= 0 i (- (flexvector-length fv) 1)))
 92  (let ((removed (flexvector-ref fv i)))
 93    (flexvector-remove-range! fv i (+ i 1))
 94    removed))
 95
 96(define (flexvector-remove-range! fv start end)
 97  (assume (flexvector? fv))
 98  (let ((len (flexvector-length fv)))
 99    (when (< start 0) (set! start 0))
100    (when (>= end len) (set! end len))
101    (assume (<= start end))
102    (vector-copy! (vec fv) start (vec fv) end)
103    (let ((new-len (- len (- end start))))
104      ;; Workaround a discrepancy in the implementation of vector-fill!
105      ;; between R7RS and SRFI-133: R7RS doesn't error out on an empty
106      ;; fill for the last vector element while SRFI-133 emits an error.
107      ;;
108      ;; See: http://paste.call-cc.org/paste?id=17238d2150d633b4053fc9dd0ce52ecd7c3b4f85
109      (unless (eqv? start end)
110        (vector-fill! (vec fv) #f new-len len))
111      (set-flexvector-length! fv new-len)))
112  fv)
113
114(define (flexvector-clear! fv)
115  (assume (flexvector? fv))
116  (set-vec! fv (make-vector 4))
117  (set-flexvector-length! fv 0)
118  fv)
119
120(define vector->flexvector
121  (case-lambda
122    ((vec)
123      (assume (vector? vec))
124      (vector->flexvector vec 0 (vector-length vec)))
125    ((vec start)
126      (assume (vector? vec))
127      (vector->flexvector vec start (vector-length vec)))
128    ((vec start end)
129      (assume (vector? vec))
130      (assume (<= 0 start end (vector-length vec)))
131      (let ((len (- end start)))
132        (cond
133          ((< len 4)
134            (let ((new-vec (make-vector 4)))
135              (vector-copy! new-vec 0 vec start end)
136              (%make-flexvector new-vec len)))
137          (else
138            (%make-flexvector (vector-copy vec start end) len)))))))
139
140(define flexvector->vector
141  (case-lambda
142    ((fv)
143      (assume (flexvector? fv))
144      (flexvector->vector fv 0 (flexvector-length fv)))
145    ((fv start)
146      (assume (flexvector? fv))
147      (flexvector->vector fv start (flexvector-length fv)))
148    ((fv start end)
149      (assume (flexvector? fv))
150      (assume (<= 0 start end (flexvector-length fv)))
151      (vector-copy (vec fv) start end))))
152
153(define (list->flexvector xs)
154  (let* ((vec (list->vector xs))
155         (len (vector-length vec)))
156    (cond
157      ((< len 4)
158        (let ((new-vec (make-vector 4)))
159          (vector-copy! new-vec 0 vec)
160          (%make-flexvector new-vec len)))
161      (else
162        (%make-flexvector vec len)))))
163
164(define flexvector-filter/index!
165  (case-lambda
166    ((pred? fv)
167      (assume (flexvector? fv))
168      (let ((v (vec fv)) (len (flexvector-length fv)))
169        (let lp ((i 0) (j 0))
170          (cond
171            ((>= i len)
172              (set-flexvector-length! fv j)
173              fv)
174            ((pred? i (vector-ref v i))
175              (unless (= i j) (vector-set! v j (vector-ref v i)))
176              (lp (+ i 1) (+ j 1)))
177            (else
178              (lp (+ i 1) j))))))
179    ((pred? fv . fvs)
180      (assume (flexvector? fv))
181      (let ((v (vec fv)) (len (flexvector-length fv)))
182        (let lp ((i 0) (j 0))
183          (cond
184            ((>= i len)
185              (set-flexvector-length! fv j)
186              fv)
187            ((apply pred?
188                    i
189                    (vector-ref v i)
190                    (map (lambda (fv) (flexvector-ref fv i)) fvs))
191              (unless (= i j) (vector-set! v j (vector-ref v i)))
192              (lp (+ i 1) (+ j 1)))
193            (else
194              (lp (+ i 1) j))))))))
195
196(define flexvector-copy
197  (case-lambda
198    ((fv)
199      (assume (flexvector? fv))
200      (%make-flexvector (vector-copy (vec fv))
201                        (flexvector-length fv)))
202    ((fv start)
203      (assume (flexvector? fv))
204      (flexvector-copy fv start (flexvector-length fv)))
205    ((fv start end)
206      (assume (flexvector? fv))
207      (assume (<= 0 start end (flexvector-length fv)))
208      (vector->flexvector (vector-copy (vec fv) start end)))))
209
210(define flexvector-copy!
211  (case-lambda
212    ((to at from)
213      (assume (flexvector? from))
214      (flexvector-copy! to at from 0 (flexvector-length from)))
215    ((to at from start)
216      (assume (flexvector? from))
217      (flexvector-copy! to at from start (flexvector-length from)))
218    ((to at from start end)
219      (assume (flexvector? to))
220      (assume (<= 0 at (flexvector-length to)))
221      (assume (<= 0 start end (flexvector-length from)))
222      (let* ((vf (vec from))
223             (lt (+ (flexvector-length to) (- end start)))
224             (vt (let lp ((v (vec to)))
225                   (if (< lt (vector-length v)) v (lp (grow! to))))))
226        (vector-copy! vt at vf start end)
227        (set-flexvector-length! to
228          (max (flexvector-length to) (+ at (- end start))))))))