srfi-214

  1
  2(define flexvector-unfold
  3  (case-lambda
  4    ((p f g seed)
  5      (define fv (flexvector))
  6      (assume (procedure? p))
  7      (assume (procedure? f))
  8      (assume (procedure? g))
  9      (do ((seed seed (g seed))) ((p seed) fv)
 10        (flexvector-add-back! fv (f seed))))
 11    ((p f g . seeds)
 12      (define fv (flexvector))
 13      (assume (procedure? p))
 14      (assume (procedure? f))
 15      (assume (procedure? g))
 16      (do ((seeds seeds (let-values ((seeds (apply g seeds))) seeds)))
 17          ((apply p seeds) fv)
 18        (flexvector-add-back! fv (apply f seeds))))))
 19
 20(define (flexvector-unfold-right . args)
 21  (define fv (apply flexvector-unfold args))
 22  (flexvector-reverse! fv)
 23  fv)
 24
 25(define flexvector-fill!
 26  (case-lambda
 27    ((fv fill)
 28      (flexvector-fill! fv fill 0 (flexvector-length fv)))
 29    ((fv fill start)
 30      (flexvector-fill! fv fill start (flexvector-length fv)))
 31    ((fv fill start end)
 32      (let ((actual-end (min end (flexvector-length fv))))
 33        (do ((i (max 0 start) (+ i 1)))
 34            ((>= i actual-end))
 35          (flexvector-set! fv i fill))))))
 36
 37(define (flexvector-reverse-copy . args)
 38  (define fv (apply flexvector-copy args))
 39  (flexvector-reverse! fv)
 40  fv)
 41
 42(define flexvector-reverse-copy!
 43  (case-lambda
 44    ((to at from)
 45      (assume (flexvector? from))
 46      (flexvector-reverse-copy! to at from 0 (flexvector-length from)))
 47    ((to at from start)
 48      (assume (flexvector? from))
 49      (flexvector-reverse-copy! to at from start (flexvector-length from)))
 50    ((to at from start end)
 51      (flexvector-copy! to at from start end)
 52      (flexvector-reverse! to at (+ at (- end start))))))
 53
 54(define (flexvector-append! fv . fvs)
 55  (assume (flexvector? fv))
 56  (assume (every flexvector? fvs))
 57  (for-each
 58    (lambda (fv2) (flexvector-copy! fv (flexvector-length fv) fv2))
 59    fvs)
 60  fv)
 61
 62(define (flexvector-front fv)
 63  (assume (flexvector? fv))
 64  (assume (not (flexvector-empty? fv)))
 65  (flexvector-ref fv 0))
 66
 67(define (flexvector-back fv)
 68  (assume (flexvector? fv))
 69  (assume (not (flexvector-empty? fv)))
 70  (flexvector-ref fv (- (flexvector-length fv) 1)))
 71
 72(define flexvector-add-front!
 73  (case-lambda
 74    ((fv x) (flexvector-add! fv 0 x))
 75    ((fv . xs) (apply flexvector-add! fv 0 xs))))
 76
 77(define (flexvector-remove-front! fv)
 78  (assume (flexvector? fv))
 79  (assume (not (flexvector-empty? fv)))
 80  (flexvector-remove! fv 0))
 81
 82(define (flexvector-remove-back! fv)
 83  (assume (flexvector? fv))
 84  (assume (not (flexvector-empty? fv)))
 85  (flexvector-remove! fv (- (flexvector-length fv) 1)))
 86
 87(define (flexvector=? eq . o)
 88  (cond
 89    ((null? o) #t)
 90    ((null? (cdr o)) #t)
 91    (else
 92      (and (let* ((fv1 (car o))
 93                  (fv2 (cadr o))
 94                  (len (flexvector-length fv1)))
 95             (and (= len (flexvector-length fv2))
 96                  (let lp ((i 0))
 97                    (or (>= i len)
 98                        (and (eq (flexvector-ref fv1 i) (flexvector-ref fv2 i))
 99                             (lp (+ i 1)))))))
100           (apply flexvector=? eq (cdr o))))))
101
102(define (flexvector-fold kons knil fv1 . o)
103  (assume (procedure? kons))
104  (assume (flexvector? fv1))
105  (let ((len (flexvector-length fv1)))
106    (if (null? o)
107        (let lp ((i 0) (acc knil))
108          (if (>= i len) acc (lp (+ i 1) (kons acc (flexvector-ref fv1 i)))))
109        (let lp ((i 0) (acc knil))
110          (if (>= i len)
111              acc
112              (lp (+ i 1)
113                  (apply kons acc (flexvector-ref fv1 i)
114                         (map (lambda (fv) (flexvector-ref fv i)) o))))))))
115
116(define (flexvector-fold-right kons knil fv1 . o)
117  (assume (procedure? kons))
118  (assume (flexvector? fv1))
119  (let ((len (flexvector-length fv1)))
120    (if (null? o)
121        (let lp ((i (- len 1)) (acc knil))
122          (if (negative? i) acc (lp (- i 1) (kons acc (flexvector-ref fv1 i)))))
123        (let lp ((i (- len 1)) (acc knil))
124          (if (negative? i)
125              acc
126              (lp (- i 1)
127                  (apply kons acc (flexvector-ref fv1 i)
128                         (map (lambda (fv) (flexvector-ref fv i)) o))))))))
129
130(define flexvector-for-each/index
131  (case-lambda
132    ((proc fv)
133      (assume (procedure? proc))
134      (assume (flexvector? fv))
135      (let ((len (flexvector-length fv)))
136        (do ((i 0 (+ i 1))) ((= i len))
137          (proc i (flexvector-ref fv i)))))
138    ((proc . fvs)
139      (assume (procedure? proc))
140      (let ((len (apply min (map flexvector-length fvs))))
141        (do ((i 0 (+ i 1))) ((= i len))
142          (apply proc i (map (lambda (fv) (flexvector-ref fv i)) fvs)))))))
143
144(define flexvector-for-each
145  (case-lambda
146    ((proc fv)
147      (assume (procedure? proc))
148      (flexvector-for-each/index (lambda (i x) (proc x)) fv))
149    ((proc . fvs)
150      (assume (procedure? proc))
151      (apply flexvector-for-each/index (lambda (i . xs) (apply proc xs)) fvs))))
152
153(define flexvector-map/index!
154  (case-lambda
155    ((proc fv)
156      (assume (procedure? proc))
157      (assume (flexvector? fv))
158      (flexvector-for-each/index
159        (lambda (i x) (flexvector-set! fv i (proc i x)))
160        fv)
161      fv)
162    ((proc fv . fvs)
163      (assume (procedure? proc))
164      (assume (flexvector? fv))
165      (apply flexvector-for-each/index
166        (lambda (i . xs) (flexvector-set! fv i (apply proc i xs)))
167        fv
168        fvs)
169      fv)))
170
171(define flexvector-map!
172  (case-lambda
173    ((proc fv)
174      (assume (procedure? proc))
175      (flexvector-map/index! (lambda (i x) (proc x)) fv))
176    ((proc . fvs)
177      (assume (procedure? proc))
178      (apply flexvector-map/index! (lambda (i . xs) (apply proc xs)) fvs))))
179
180(define (flexvector-map/index proc fv . fvs)
181  (assume (flexvector? fv))
182  (apply flexvector-map/index! proc (flexvector-copy fv) fvs))
183
184(define (flexvector-map proc fv . fvs)
185  (assume (flexvector? fv))
186  (apply flexvector-map! proc (flexvector-copy fv) fvs))
187
188(define (flexvector-append-map/index proc fv . fvs)
189  (define out (flexvector))
190  (flexvector-for-each
191    (lambda (x) (flexvector-append! out x))
192    (apply flexvector-map/index proc fv fvs))
193  out)
194
195(define (flexvector-append-map proc fv . fvs)
196  (define out (flexvector))
197  (flexvector-for-each
198    (lambda (x) (flexvector-append! out x))
199    (apply flexvector-map proc fv fvs))
200  out)
201
202(define flexvector-filter!
203  (case-lambda
204    ((pred? fv)
205      (assume (procedure? pred?))
206      (assume (flexvector? fv))
207      (flexvector-filter/index! (lambda (i x) (pred? x)) fv))
208    ((pred? . fvs)
209      (assume (procedure? pred?))
210      (apply flexvector-filter/index! (lambda (i . xs) (apply pred? xs)) fvs))))
211
212(define (flexvector-filter/index proc fv . fvs)
213  (assume (flexvector? fv))
214  (apply flexvector-filter/index! proc (flexvector-copy fv) fvs))
215
216(define (flexvector-filter proc fv . fvs)
217  (assume (flexvector? fv))
218  (apply flexvector-filter! proc (flexvector-copy fv) fvs))
219
220(define (flexvector-index pred? fv1 . o)
221  (assume (procedure? pred?))
222  (assume (flexvector? fv1))
223  (let ((len (flexvector-length fv1)))
224    (let lp ((i 0))
225      (and (< i len)
226           (if (apply pred?
227                      (flexvector-ref fv1 i)
228                      (map (lambda (fv) (flexvector-ref fv i)) o))
229               i
230               (lp (+ i 1)))))))
231
232(define (flexvector-index-right pred? fv1 . o)
233  (assume (procedure? pred?))
234  (assume (flexvector? fv1))
235  (let ((len (flexvector-length fv1)))
236    (let lp ((i (- len 1)))
237      (and (>= i 0)
238           (if (apply pred?
239                      (flexvector-ref fv1 i)
240                      (map (lambda (fv) (flexvector-ref fv i)) o))
241               i
242               (lp (- i 1)))))))
243
244(define (complement f)
245  (lambda args (not (apply f args))))
246
247(define (flexvector-skip pred? fv1 . o)
248  (assume (procedure? pred?))
249  (assume (flexvector? fv1))
250  (apply flexvector-index (complement pred?) fv1 o))
251
252(define (flexvector-skip-right pred? fv1 . o)
253  (assume (procedure? pred?))
254  (assume (flexvector? fv1))
255  (apply flexvector-index-right (complement pred?) fv1 o))
256
257(define flexvector-binary-search
258  (case-lambda
259    ((fv value cmp)
260      (flexvector-binary-search fv value cmp 0 (flexvector-length fv)))
261    ((fv value cmp start)
262      (flexvector-binary-search fv value cmp start (flexvector-length fv)))
263    ((fv value cmp start end)
264      (assume (flexvector? fv))
265      (assume (procedure? cmp))
266      (assume (integer? start))
267      (assume (integer? end))
268      (assume (<= start end))
269      (let lp ((lo (max start 0))
270               (hi (- (min end (flexvector-length fv)) 1)))
271        (and (<= lo hi)
272             (let* ((mid (quotient (+ lo hi) 2))
273                    (x (flexvector-ref fv mid))
274                    (y (cmp value x)))
275               (cond
276                 ((< y 0) (lp lo (- mid 1)))
277                 ((> y 0) (lp (+ mid 1) hi))
278                 (else mid))))))))
279
280(define (flexvector-any pred? fv . o)
281  (assume (procedure? pred?))
282  (assume (flexvector? fv))
283  (let ((len (apply min (flexvector-length fv) (map flexvector-length o))))
284    (let lp ((i 0))
285      (and (< i len)
286           (or (apply pred?
287                      (flexvector-ref fv i)
288                      (map (lambda (v) (flexvector-ref v i)) o))
289               (lp (+ i 1)))))))
290
291(define (flexvector-every pred? fv . o)
292  (assume (procedure? pred?))
293  (assume (flexvector? fv))
294  (let ((len (apply min (flexvector-length fv) (map flexvector-length o))))
295    (or (zero? len)
296      (let lp ((i 0))
297        (let ((x (apply pred?
298                        (flexvector-ref fv i)
299                        (map (lambda (v) (flexvector-ref v i)) o))))
300          (if (= i (- len 1))
301              x
302              (and x (lp (+ i 1)))))))))
303
304(define (flexvector-swap! fv i j)
305  (assume (flexvector? fv))
306  (assume (integer? i))
307  (assume (integer? j))
308  (let ((tmp (flexvector-ref fv i)))
309    (flexvector-set! fv i (flexvector-ref fv j))
310    (flexvector-set! fv j tmp)))
311
312(define (flexvector-reverse! fv . o)
313  (assume (flexvector? fv))
314  (let lp ((left (if (pair? o) (car o) 0))
315           (right (- (if (and (pair? o) (pair? (cdr o)))
316                         (cadr o)
317                         (flexvector-length fv))
318                     1)))
319    (cond
320      ((>= left right) (if #f #f))
321      (else
322        (flexvector-swap! fv left right)
323        (lp (+ left 1) (- right 1))))))
324
325(define (flexvector-append fv . fvs)
326  (assume (flexvector? fv))
327  (apply flexvector-append! (flexvector-copy fv) fvs))
328
329(define (flexvector-concatenate ls)
330  (apply flexvector-append ls))
331
332(define (flexvector-append-subvectors . o)
333  (let lp ((ls o) (vecs '()))
334    (if (null? ls)
335        (flexvector-concatenate (reverse vecs))
336        (lp (cdr (cddr ls))
337            (cons (flexvector-copy (car ls) (cadr ls) (car (cddr ls))) vecs)))))
338
339(define (flexvector-empty? fv)
340  (assume (flexvector? fv))
341  (zero? (flexvector-length fv)))
342
343(define (flexvector-count pred? fv1 . o)
344  (assume (procedure? pred?))
345  (assume (flexvector? fv1))
346  (apply flexvector-fold
347         (lambda (count . x) (+ count (if (apply pred? x) 1 0)))
348         0
349         fv1 o))
350
351(define (flexvector-cumulate f knil fv)
352  (assume (procedure? f))
353  (assume (flexvector? fv))
354  (let* ((len (flexvector-length fv))
355         (res (make-vector len)))
356    (let lp ((i 0) (acc knil))
357      (if (>= i len)
358          (vector->flexvector res)
359          (let ((acc (f acc (flexvector-ref fv i))))
360            (vector-set! res i acc)
361            (lp (+ i 1) acc))))))
362
363(define (flexvector-partition pred? fv)
364  (assume (procedure? pred?))
365  (assume (flexvector? fv))
366  (let ((left (flexvector)) (right (flexvector)))
367    (flexvector-for-each
368      (lambda (x) (flexvector-add-back! (if (pred? x) left right) x))
369      fv)
370    (values left right)))
371
372(define flexvector->list
373  (case-lambda
374    ((fv)
375     (flexvector->list fv 0 (flexvector-length fv)))
376    ((fv start)
377     (flexvector->list fv start (flexvector-length fv)))
378    ((fv start end)
379     (if (< end start)
380       (error "invalid start/end specification")
381       (let lp ((acc '()) (idx (- end 1)))
382         (if (< idx start)
383           acc
384           (lp (cons (vector-ref (vec fv) idx) acc)
385               (- idx 1))))))))
386
387(define (reverse-flexvector->list fv . o)
388  (assume (flexvector? fv))
389  (flexvector->list (apply flexvector-reverse-copy fv o)))
390
391(define (reverse-list->flexvector ls)
392  (assume (list? ls))
393  (let ((fv (list->flexvector ls)))
394    (flexvector-reverse! fv)
395    fv))
396
397(define (string->flexvector s . o)
398  (assume (string? s))
399  (vector->flexvector (apply string->vector s o)))
400
401(define (flexvector->string fv . o)
402  (assume (flexvector? fv))
403  (vector->string (apply flexvector->vector fv o)))
404
405(define (generator->flexvector g)
406  (assume (procedure? g))
407  (flexvector-unfold eof-object? (lambda (x) x) (lambda (_) (g)) (g)))
408
409(define (flexvector->generator fv)
410  (assume (flexvector? fv))
411  (let ((i 0))
412    (lambda ()
413      (if (< i (flexvector-length fv))
414        (let ((element (flexvector-ref fv i)))
415          (set! i (+ i 1))
416          element)
417        #!eof))))