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