1;; Chibi Scheme version of any
2
3(define (any pred ls)
4  (if (null? (cdr ls))
5    (pred (car ls))
6    ((lambda (x) (if x x (any pred (cdr ls)))) (pred (car ls)))))
7
8;; list->bytevector
9(define (list->bytevector list)
10  (let ((vec (make-bytevector (length list) 0)))
11    (let loop ((i 0) (list list))
12      (if (null? list)
13        vec
14        (begin
15          (bytevector-u8-set! vec i (car list))
16          (loop (+ i 1) (cdr list)))))))
17
18
19;; generator
20(define (generator . args)
21  (lambda () (if (null? args)
22               (eof-object)
23               (let ((next (car args)))
24                (set! args (cdr args))
25                next))))
26
27;; circular-generator
28(define (circular-generator . args)
29  (let ((base-args args))
30    (lambda ()
31      (when (null? args)
32        (set! args base-args))
33          (let ((next (car args)))
34                (set! args (cdr args))
35                next))))
36
37
38;; make-iota-generator
39(define make-iota-generator
40  (case-lambda ((count) (make-iota-generator count 0 1))
41               ((count start) (make-iota-generator count start 1))
42               ((count start step) (make-iota count start step))))
43
44;; make-iota
45(define (make-iota count start step)
46  (lambda ()
47    (cond
48      ((<= count 0)
49       (eof-object))
50      (else
51        (let ((result start))
52         (set! count (- count 1))
53         (set! start (+ start step))
54         result)))))
55
56
57;; make-range-generator
58(define make-range-generator
59  (case-lambda ((start end) (make-range-generator start end 1))
60               ((start) (make-infinite-range-generator start))
61               ((start end step)
62                (set! start (- (+ start step) step))
63                (lambda () (if (< start end)
64                             (let ((v start))
65                              (set! start (+ start step))
66                              v)
67                             (eof-object))))))
68
69(define (make-infinite-range-generator start)
70  (lambda ()
71    (let ((result start))
72     (set! start (+ start 1))
73     result)))
74
75
76
77;; make-coroutine-generator
78(define (make-coroutine-generator proc)
79  (define return #f)
80  (define resume #f)
81  (define yield (lambda (v) (call/cc (lambda (r) (set! resume r) (return v)))))
82  (lambda () (call/cc (lambda (cc) (set! return cc)
83                        (if resume
84                          (resume (if #f #f))  ; void? or yield again?
85                          (begin (proc yield)
86                                 (set! resume (lambda (v) (return (eof-object))))
87                                 (return (eof-object))))))))
88
89
90;; list->generator
91(define (list->generator lst)
92  (lambda () (if (null? lst)
93               (eof-object)
94               (let ((next (car lst)))
95                (set! lst (cdr lst))
96                next))))
97
98
99;; vector->generator
100(define vector->generator
101  (case-lambda ((vec) (vector->generator vec 0 (vector-length vec)))
102               ((vec start) (vector->generator vec start (vector-length vec)))
103               ((vec start end)
104                (lambda () (if (>= start end)
105                             (eof-object)
106                             (let ((next (vector-ref vec start)))
107                              (set! start (+ start 1))
108                              next))))))
109
110
111;; reverse-vector->generator
112(define reverse-vector->generator
113  (case-lambda ((vec) (reverse-vector->generator vec 0 (vector-length vec)))
114               ((vec start) (reverse-vector->generator vec start (vector-length vec)))
115               ((vec start end)
116                (lambda () (if (>= start end)
117                             (eof-object)
118                             (let ((next (vector-ref vec (- end 1))))
119                              (set! end (- end 1))
120                              next))))))
121
122
123;; string->generator
124(define string->generator
125  (case-lambda ((str) (string->generator str 0 (string-length str)))
126               ((str start) (string->generator str start (string-length str)))
127               ((str start end)
128                (lambda () (if (>= start end)
129                             (eof-object)
130                             (let ((next (string-ref str start)))
131                              (set! start (+ start 1))
132                              next))))))
133
134
135;; bytevector->generator
136(define bytevector->generator
137  (case-lambda ((str) (bytevector->generator str 0 (bytevector-length str)))
138               ((str start) (bytevector->generator str start (bytevector-length str)))
139               ((str start end)
140                (lambda () (if (>= start end)
141                             (eof-object)
142                             (let ((next (bytevector-u8-ref str start)))
143                              (set! start (+ start 1))
144                              next))))))
145
146
147;; make-for-each-generator
148;FIXME: seems to fail test
149(define (make-for-each-generator for-each obj)
150  (make-coroutine-generator (lambda (yield) (for-each yield obj))))
151
152
153;; make-unfold-generator
154(define (make-unfold-generator stop? mapper successor seed)
155  (make-coroutine-generator (lambda (yield)
156                              (let loop ((s seed))
157                               (if (stop? s)
158                                 (if #f #f)
159                                 (begin (yield (mapper s))
160                                        (loop (successor s))))))))
161
162
163;; gcons*
164(define (gcons* . args)
165  (lambda () (if (null? args)
166               (eof-object)
167               (if (= (length args) 1)
168                 ((car args))
169                 (let ((v (car args)))
170                  (set! args (cdr args))
171                  v)))))
172
173
174;; gappend
175(define (gappend . args)
176  (lambda () (if (null? args)
177               (eof-object)
178               (let loop ((v ((car args))))
179                (if (eof-object? v)
180                  (begin (set! args (cdr args))
181                         (if (null? args)
182                           (eof-object)
183                           (loop ((car args)))))
184                  v)))))
185
186;; gflatten
187(define (gflatten gen)
188  (let ((state '()))
189    (lambda ()
190      (if (null? state) (set! state (gen)))
191      (if (eof-object? state)
192        state
193        (let ((obj (car state)))
194          (set! state (cdr state))
195          obj)))))
196
197;; ggroup
198(define ggroup
199  (case-lambda
200    ((gen k)
201     (simple-ggroup gen k))
202    ((gen k padding)
203     (padded-ggroup (simple-ggroup gen k) k padding))))
204
205(define (simple-ggroup gen k)
206  (lambda ()
207    (let loop ((item (gen)) (result '()) (count (- k 1)))
208      (if (eof-object? item)
209        (if (null? result) item (reverse result))
210        (if (= count 0)
211          (reverse (cons item result))
212          (loop (gen) (cons item result) (- count 1)))))))
213
214(define (padded-ggroup gen k padding)
215  (lambda ()
216    (let ((item (gen)))
217      (if (eof-object? item)
218        item
219        (let ((len (length item)))
220          (if (= len k)
221              item
222              (append item (make-list (- k len) padding))))))))
223
224;; gmerge
225(define gmerge
226  (case-lambda
227    ((<) (error "wrong number of arguments for gmerge"))
228    ((< gen) gen)
229    ((< genleft genright)
230     (let ((left (genleft))
231           (right (genright)))
232       (lambda ()
233         (cond
234          ((and (eof-object? left) (eof-object? right))
235           left)
236          ((eof-object? left)
237           (let ((obj right)) (set! right (genright)) obj))
238          ((eof-object? right)
239           (let ((obj left))  (set! left (genleft)) obj))
240          ((< right left)
241           (let ((obj right)) (set! right (genright)) obj))
242          (else
243           (let ((obj left)) (set! left (genleft)) obj))))))
244    ((< . gens)
245     (apply gmerge <
246            (let loop ((gens gens) (gs '()))
247              (cond ((null? gens) (reverse gs))
248                    ((null? (cdr gens)) (reverse (cons (car gens) gs)))
249                    (else (loop (cddr gens)
250                                (cons (gmerge < (car gens) (cadr gens)) gs)))))))))
251
252;; gmap
253(define gmap
254  (case-lambda
255    ((proc) (error "wrong number of arguments for gmap"))
256    ((proc gen)
257     (lambda ()
258       (let ((item (gen)))
259         (if (eof-object? item) item (proc item)))))
260    ((proc . gens)
261     (lambda ()
262       (let ((items (map (lambda (x) (x)) gens)))
263         (if (any eof-object? items) (eof-object) (apply proc items)))))))
264
265;; gcombine
266(define (gcombine proc seed . gens)
267  (lambda ()
268    (define items (map (lambda (x) (x)) gens))
269    (if (any eof-object? items)
270      (eof-object)
271      (let ()
272       (define-values (value newseed) (apply proc (append items (list seed))))
273       (set! seed newseed)
274       value))))
275
276;; gfilter
277(define (gfilter pred gen)
278  (lambda () (let loop ()
279              (let ((next (gen)))
280               (if (or (eof-object? next)
281                       (pred next))
282                 next
283                 (loop))))))
284
285;; gstate-filter
286(define (gstate-filter proc seed gen)
287  (let ((state seed))
288    (lambda ()
289      (let loop ((item (gen)))
290        (if (eof-object? item)
291          item
292          (let-values (((yes newstate) (proc item state)))
293            (set! state newstate)
294            (if yes
295               item
296               (loop (gen)))))))))
297
298
299
300;; gremove
301(define (gremove pred gen)
302  (gfilter (lambda (v) (not (pred v))) gen))
303
304
305
306;; gtake
307(define gtake
308  (case-lambda ((gen k) (gtake gen k (eof-object)))
309               ((gen k padding)
310                (make-coroutine-generator (lambda (yield)
311                                            (if (> k 0)
312                                              (let loop ((i 0) (v (gen)))
313                                               (begin (if (eof-object? v) (yield padding) (yield v))
314                                                      (if (< (+ 1 i) k)
315                                                        (loop (+ 1 i) (gen))
316                                                        (eof-object))))
317                                              (eof-object)))))))
318
319
320
321;; gdrop
322(define (gdrop gen k)
323  (lambda () (do () ((<= k 0)) (set! k (- k 1)) (gen))
324    (gen)))
325
326
327
328;; gdrop-while
329(define (gdrop-while pred gen)
330  (define found #f)
331  (lambda ()
332    (let loop ()
333     (let ((val (gen)))
334      (cond (found val)
335            ((and (not (eof-object? val)) (pred val)) (loop))
336            (else (set! found #t) val))))))
337
338
339;; gtake-while
340(define (gtake-while pred gen)
341  (lambda () (let ((next (gen)))
342              (if (eof-object? next)
343                next
344                (if (pred next)
345                  next
346                  (begin (set! gen (generator))
347                         (gen)))))))
348
349
350
351;; gdelete
352(define gdelete
353  (case-lambda ((item gen) (gdelete item gen equal?))
354               ((item gen ==)
355                (lambda () (let loop ((v (gen)))
356                            (cond
357                              ((eof-object? v) (eof-object))
358                              ((== item v) (loop (gen)))
359                              (else v)))))))
360
361
362
363;; gdelete-neighbor-dups
364(define gdelete-neighbor-dups
365  (case-lambda ((gen)
366                (gdelete-neighbor-dups gen equal?))
367               ((gen ==)
368                (define firsttime #t)
369                (define prev #f)
370                (lambda () (if firsttime
371                             (begin (set! firsttime #f)
372                                    (set! prev (gen))
373                                    prev)
374                             (let loop ((v (gen)))
375                              (cond
376                                ((eof-object? v)
377                                 v)
378                                ((== prev v)
379                                 (loop (gen)))
380                                (else
381                                  (set! prev v)
382                                  v))))))))
383
384
385;; gindex
386(define (gindex value-gen index-gen)
387  (let ((done? #f) (count 0))
388   (lambda ()
389     (if done?
390       (eof-object)
391       (let loop ((value (value-gen)) (index (index-gen)))
392        (cond
393          ((or (eof-object? value) (eof-object? index))
394           (set! done? #t)
395           (eof-object))
396          ((= index count)
397           (set! count (+ count 1))
398           value)
399          (else
400            (set! count (+ count 1))
401            (loop (value-gen) index))))))))
402
403
404;; gselect
405(define (gselect value-gen truth-gen)
406  (let ((done? #f))
407   (lambda ()
408     (if done?
409       (eof-object)
410       (let loop ((value (value-gen)) (truth (truth-gen)))
411        (cond
412          ((or (eof-object? value) (eof-object? truth))
413           (set! done? #t)
414           (eof-object))
415          (truth value)
416          (else (loop (value-gen) (truth-gen)))))))))
417
418;; generator->list
419(define generator->list
420  (case-lambda ((gen n)
421                (generator->list (gtake gen n)))
422               ((gen)
423                (reverse (generator->reverse-list gen)))))
424
425;; generator->reverse-list
426(define generator->reverse-list
427  (case-lambda ((gen n)
428                (generator->reverse-list (gtake gen n)))
429               ((gen)
430                (generator-fold cons '() gen))))
431
432;; generator->vector
433(define generator->vector
434  (case-lambda ((gen) (list->vector (generator->list gen)))
435               ((gen n) (list->vector (generator->list gen n)))))
436
437
438;; generator->vector!
439(define (generator->vector! vector at gen)
440  (let loop ((value (gen)) (count 0) (at at))
441   (cond
442     ((eof-object? value) count)
443     ((>= at (vector-length vector)) count)
444     (else (begin
445             (vector-set! vector at value)
446             (loop (gen) (+ count 1) (+ at 1)))))))
447
448
449;; generator->string
450(define generator->string
451  (case-lambda ((gen) (list->string (generator->list gen)))
452               ((gen n) (list->string (generator->list gen n)))))
453
454
455
456
457;; generator-fold
458(define (generator-fold f seed . gs)
459  (define (inner-fold seed)
460    (let ((vs (map (lambda (g) (g)) gs)))
461     (if (any eof-object? vs)
462       seed
463       (inner-fold (apply f (append vs (list seed)))))))
464  (inner-fold seed))
465
466
467
468;; generator-for-each
469(define (generator-for-each f . gs)
470  (let loop ()
471   (let ((vs (map (lambda (g) (g)) gs)))
472    (if (any eof-object? vs)
473      (if #f #f)
474      (begin (apply f vs)
475             (loop))))))
476
477
478(define (generator-map->list f . gs)
479  (let loop ((result '()))
480   (let ((vs (map (lambda (g) (g)) gs)))
481    (if (any eof-object? vs)
482      (reverse result)
483      (loop (cons (apply f vs) result))))))
484
485
486;; generator-find
487(define (generator-find pred g)
488  (let loop ((v (g)))
489    (and (not (eof-object? v))
490         (if (pred v) v (loop (g))))))
491
492
493;; generator-count
494(define (generator-count pred g)
495  (generator-fold (lambda (v n) (if (pred v) (+ 1 n) n)) 0 g))
496
497
498;; generator-any
499(define (generator-any pred g)
500  (let loop ((v (g)))
501   (if (eof-object? v)
502     #f
503     (if (pred v)
504       #t
505       (loop (g))))))
506
507
508;; generator-every
509(define (generator-every pred g)
510  (let loop ((v (g)))
511   (if (eof-object? v)
512     #t
513     (if (pred v)
514       (loop (g))
515       #f ; the spec would have me return #f, but I think it must simply be wrong...
516       ))))
517
518
519;; generator-unfold
520(define (generator-unfold g unfold . args)
521  (apply unfold eof-object? (lambda (x) x) (lambda (x) (g)) (g) args))
522
523
524;; make-accumulator
525(define (make-accumulator kons knil finalize)
526  (let ((state knil))
527    (lambda (obj)
528      (if (eof-object? obj)
529        (finalize state)
530        (set! state (kons obj state))))))
531
532
533;; count-accumulator
534(define (count-accumulator) (make-accumulator
535                            (lambda (obj state) (+ 1 state)) 0 (lambda (x) x)))
536
537;; list-accumulator
538(define (list-accumulator) (make-accumulator cons '() reverse))
539
540;; reverse-list-accumulator
541(define (reverse-list-accumulator) (make-accumulator cons '() (lambda (x) x)))
542
543;; vector-accumulator
544(define (vector-accumulator)
545  (make-accumulator cons '() (lambda (x) (list->vector (reverse x)))))
546
547;; reverse-vector-accumulator
548(define (reverse-vector-accumulator)
549  (make-accumulator cons '() list->vector))
550
551;; vector-accumulator!
552(define (vector-accumulator! vec at)
553  (lambda (obj)
554    (if (eof-object? obj)
555      vec
556      (begin
557        (vector-set! vec at obj)
558        (set! at (+ at 1))))))
559
560;; bytevector-accumulator
561(define (bytevector-accumulator)
562  (make-accumulator cons '() (lambda (x) (list->bytevector (reverse x)))))
563
564(define (bytevector-accumulator! bytevec at)
565  (lambda (obj)
566    (if (eof-object? obj)
567      bytevec
568      (begin
569        (bytevector-u8-set! bytevec at obj)
570        (set! at (+ at 1))))))
571
572;; string-accumulator
573(define (string-accumulator)
574  (make-accumulator cons '()
575        (lambda (lst) (list->string (reverse lst)))))
576
577;; sum-accumulator
578(define (sum-accumulator) (make-accumulator + 0 (lambda (x) x)))
579
580;; product-accumulator
581(define (product-accumulator) (make-accumulator * 1 (lambda (x) x)))
582