source: project/release/4/lazy-lists/trunk/lazy-lists.scm @ 27153

Last change on this file since 27153 was 27153, checked in by juergen, 9 years ago

initial import

File size: 28.6 KB
Line 
1; Author: Juergen Lorenz
2; ju (at) jugilo (dot) de
3;
4; Copyright (c) 2012, Juergen Lorenz
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions are
9; met:
10;
11; Redistributions of source code must retain the above copyright
12; notice, this list of conditions and the following disclaimer.
13;
14; Redistributions in binary form must reproduce the above copyright
15; notice, this list of conditions and the following disclaimer in the
16; documentation and/or other materials provided with the distribution.
17;
18; Neither the name of the author nor the names of its contributors may be
19; used to endorse or promote products derived from this software without
20; specific prior written permission.
21;
22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
23; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
24; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
25; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
27; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
28; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
29; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
30; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
31; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
32; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33;
34; Last update: July 30, 2012
35;
36(require 'contracts)
37
38
39(module %lazy-lists
40  (Lazy make-lazy
41   List->list list->List input->List
42   First Rest Car Cdr Length Append Reverse
43   List? Null? Realized? Reverse* Index
44   Take Drop Ref Take-upto Drop-upto
45   Memp Member Memq Memv
46   Equ? Equal? Eq? Eqv?
47   Assp Assoc Assq Assv
48   Map Filter Sieve For-each
49   Iterate Repeat Repeatedly
50   Cardinals Primes Cycle Interval
51   Nil Cons Merge Sort Split-at Split-with
52   vector->List List->vector
53   Fold-right Fold-left Fold-right* Fold-left*
54   Zip Every? Some? List)
55
56(import scheme
57        (only chicken
58              define-record-type
59              define-record-printer
60              cut
61              add1
62              sub1
63              receive
64              unless))
65
66;; all defined operators hidden
67(define lazy-list
68  (define-record-type lazy-list
69    (make-lazy-list length body value)
70    lazy-list?
71    (length lazy-list-length lazy-list-length-set!)
72    (body lazy-list-body lazy-list-body-set!)
73    (value lazy-list-value lazy-list-value-set!)))
74
75
76(define-syntax Lazy
77  (syntax-rules ()
78    ((_ len xpr . xprs)
79     (make-lazy len (lambda () xpr . xprs)))))
80
81(define (Cons var seq)
82  (let ((len (lazy-list-length seq)))
83    (Lazy (if len (+ 1 len) #f)
84      (cons var seq))))
85
86(define (make-lazy len body)
87  (make-lazy-list len body #f))
88
89(define Length lazy-list-length)
90
91(define List? lazy-list?)
92
93(define Nil
94  (make-lazy-list 0 (lambda () '()) #f))
95
96(define (Cardinals)
97  (let loop ((n 0)) (Lazy #f (cons n (loop (+ n 1))))))
98
99(define (Primes)
100  (Sieve (lambda (x y) (zero? (remainder x y)))
101         (Drop 2 (Cardinals))))
102
103(define-record-printer (lazy-list seq out)
104  (display "#<List[" out)
105  (display (lazy-list-length seq) out)
106  (display "]" out)
107  (cond ((not (Realized? seq))
108         (display " ...>" out))
109        ((Null? seq)
110         (display "]>" out))
111        (else
112         (let loop ((seq seq))
113           (if (Realized? seq)
114               (if (Null? seq)
115                   (display ">" out)
116                   (begin
117                     (display " " out)
118                     (write (First seq) out)
119                     (loop (Rest seq))))
120               (display " ...>" out))))))
121
122(define (Realized? seq)
123  (not (lazy-list-body seq)))
124
125(define (Null? seq)
126  (null? (realize seq)))
127
128;; hidden, does most of the dirty work
129(define (realize seq)
130  (or (lazy-list-value seq)
131      (let ((value ((lazy-list-body seq))))
132        (lazy-list-body-set! seq #f)
133        (let loop ((value value))
134          (if (or (null? value) (pair? value))
135              (begin
136                (lazy-list-value-set! seq value)
137                value)
138              (loop (or (lazy-list-value value)
139                        ((lazy-list-body value)))))))))
140
141(define (First seq)
142  (car (realize seq)))
143
144(define Car First)
145
146;; to speed up cdring for lists with preknown length
147(define (rest seq)
148  (cdr (realize seq)))
149
150(define (Rest seq)
151  (let (
152    (len (lazy-list-length seq))
153    (Result (cdr (realize seq)))
154    )
155    (lazy-list-length-set! Result (if len (- len 1) #f))
156    Result))
157
158(define Cdr Rest)
159
160(define (Ref n seq)
161  (if (zero? n)
162      (First seq)
163      (Ref (- n 1) (Rest seq))))
164
165(define (List->list seq)
166  (let loop ((lst '()) (seq seq))
167    (if (Null? seq)
168      (reverse lst)
169      (loop (cons (First seq) lst)
170            (Rest seq)))))
171
172(define (list->List lst)
173  (let loop ((lst (reverse lst)) (seq Nil))
174    (if (null? lst)
175      seq
176      (loop (cdr lst) (Cons (car lst) seq)))))
177
178(define (List . args)
179  (list->List args))
180
181(define (Take n seq)
182  (call-with-values
183    (lambda () (Split-at n seq))
184    (lambda (a b) a)))
185
186(define (Drop n seq)
187  (call-with-values
188    (lambda () (Split-at n seq))
189    (lambda (a b) b)))
190
191(define (Take-upto ok? seq)
192;  (let loop ((len (lazy-list-length seq)) (seq seq))
193;    (cond
194;      ((Null? seq) Nil)
195;      ((ok? (First seq))
196;       (Lazy len
197;         (cons (First seq)
198;               (loop (if len (- len 1) #f)
199;                     (Rest seq)))))
200;      (else Nil))))
201  (receive (head index tail) (Split-with ok? seq)
202    head))
203
204(define (Index ok? seq)
205  (receive (head index tail) (Split-with ok? seq)
206    index))
207
208(define (Drop-upto ok? seq)
209;  (let loop ((len (lazy-list-length seq)) (seq seq))
210;    (cond
211;      ((Null? seq) Nil)
212;      ((ok? (First seq))
213;       (loop (if len (- len 1) #f)
214;             (Rest seq)))
215;      (else
216;        (Lazy len seq)))))
217  (receive (head index tail) (Split-with ok? seq)
218    tail))
219
220(define (Memp ok? seq)
221  (Drop-upto ok? seq))
222
223(define (Memq var seq)
224  (Memp (cut eq? <> var) seq))
225
226(define (Memv var seq)
227  (Memp (cut eqv? <> var) seq))
228
229(define (Member var seq)
230  (Memp (cut equal? <> var) seq))
231
232(define (Equ? =? seq1 seq2)
233  (if (eqv? (lazy-list-length seq1) (lazy-list-length seq2))
234    (if (lazy-list-length seq1)
235      ;; both finite
236      (let loop ((seq1 seq1) (seq2 seq2))
237        (cond
238          ((Null? seq1) #t)
239          ((=? (First seq1) (First seq2))
240           (loop (Rest seq1) (Rest seq2)))))
241      ;; both infinite
242      (eq? seq1 seq2))
243    #f))
244
245(define (Eq? seq1 seq2)
246  (Equ? eq? seq1 seq2))
247
248(define (Eqv? seq1 seq2)
249  (Equ? eqv? seq1 seq2))
250
251(define (Equal? seq1 seq2)
252  (Equ? equal? seq1 seq2))
253
254(define (Assp ok? al)
255  (let (
256    (seq (Drop-upto (lambda (pair) (ok? (car pair))) al))
257    )
258    (if (Null? seq) #f (First seq))))
259
260(define (Assq key al)
261  (Assp (cut eq? <> key) al))
262
263(define (Assv key al)
264  (Assp (cut eqv? <> key) al))
265
266(define (Assoc key al)
267  (Assp (cut equal? <> key) al))
268
269(define (Map proc seq . seqs)
270  ;; all equal length, as in R5RS Standard
271  (let (
272    (seqs (cons seq seqs))
273    (len (lazy-list-length seq))
274    )
275    (let loop ((seqs seqs))
276      (Lazy len
277        (if (Null? (car seqs))
278            '()
279            (cons (apply proc (map First seqs))
280                  (loop (map rest seqs))))))))
281
282(define (Filter ok? seq)
283  (let loop ((seq seq))
284    (if (Null? seq)
285      Nil
286      (let ((first (First seq)))
287        (if (lazy-list-length seq)
288          ;; compute new length via Cons
289          (if (ok? first)
290            (Cons first (loop (Rest seq)))
291            (loop (Rest seq)))
292          (Lazy #f
293            (if (ok? first)
294              (cons first (loop (rest seq)))
295              (loop (rest seq)))))))))
296
297(define (For-each proc seq . seqs)
298  ;; all equal finite length, as in R5RS Standard
299  (let ((seqs (cons seq seqs)))
300    (unless (Null? seq)
301      (apply proc (map First seqs))
302      (apply For-each proc (map Rest seqs)))))
303
304(define (input->List port read)
305  (let loop ()
306    ;(Lazy #f
307      (let ((datum (read port)))
308        (if (eof-object? datum)
309            Nil
310            ;'()
311            (Cons datum (loop))))));)
312
313(define (Repeat x)
314  (Lazy #f (cons x (Repeat x))))
315
316(define (Repeatedly thunk)
317  (Lazy #f (cons (thunk) (Repeatedly thunk))))
318
319(define (Iterate f x)
320  (Lazy #f
321    (cons x (Iterate f (f x)))))
322
323(define (Interval from upto)
324  (Take (abs (- upto from))
325        (Iterate (if (>= upto from) add1 sub1) from)))
326
327(define (Append2 seq1 seq2)
328  (let loop ((seq seq1))
329    (Lazy (if (lazy-list-length seq2)
330            (+ (lazy-list-length seq1)
331               (lazy-list-length seq2)) #f)
332      (if (Null? seq)
333        seq2
334        (cons (First seq) (loop (rest seq)))))))
335
336(define (Append . seqs)
337  (cond
338    ((null? seqs) Nil)
339    ((null? (cdr seqs)) (car seqs))
340    (else
341      (Append2 (car seqs) (apply Append (cdr seqs))))))
342
343(define (Reverse seq)
344  (let loop ((seq seq) (reverse Nil))
345    (if (Null? seq)
346      reverse
347      (Lazy (lazy-list-length seq)
348        (loop (rest seq)
349              (Cons (First seq) reverse))))))
350
351(define (Reverse* seq)
352  (letrec (
353    (result 
354      (Cons Nil
355        (Map Cons
356             seq
357             (Lazy (lazy-list-length seq) result))))
358    )
359    (Rest result)))
360
361(define (Cycle seq)
362  (if (Null? seq)
363      Nil
364      (let loop ((tail seq))
365        (Lazy #f
366          (if (Null? tail)
367              (loop seq)
368              (cons (First tail)
369                    (loop (rest tail))))))))
370
371(define (Merge <? seq1 seq2)
372  (let ((len (+ (lazy-list-length seq1) (lazy-list-length seq2))))
373    (let loop ((seq1 seq1) (seq2 seq2))
374      (cond
375        ((Null? seq1) seq2)
376        ((Null? seq2) seq1)
377        ((<? (First seq1) (First seq2))
378         (Lazy len (cons (First seq1) (loop (rest seq1) seq2))))
379        (else
380         (Lazy len
381               (cons (First seq2) (loop seq1 (rest seq2)))))))))
382
383(define (Sort <? seq)
384  (let ((len (lazy-list-length seq)))
385    (if (< len 2)
386      seq
387      (let ((halflen (quotient len 2)))
388        (Merge <?
389          (Sort <? (Take halflen seq))
390          (Sort <? (Drop halflen seq)))))))
391
392(define (vector->List vec)
393  (let loop ((res Nil) (n (vector-length vec)))
394    (if (zero? n)
395      res
396      (loop (Cons (vector-ref vec (- n 1)) res) (- n 1)))))
397
398;; see comment to List->list
399(define (List->vector seq)
400  (let ((vec (make-vector (lazy-list-length seq) #f)))
401    (let loop ((k 0) (seq seq))
402      (cond
403        ((Null? seq)
404         vec)
405        (else
406          (vector-set! vec k (First seq))
407          (loop (+ k 1) (rest seq)))))))
408
409(define (Split-at n seq)
410  (let loop ((n n) (head Nil) (tail seq))
411    (if (or (Null? tail) (zero? n))
412      (values (Reverse head) tail)
413      (loop (- n 1)
414            (Cons (First tail) head)
415            (Rest tail)))))
416
417(define (Split-with ok? seq)
418  (let loop ((head Nil) (index 0) (tail seq))
419    (if (or (Null? tail) (ok? (First tail)))
420      (values (Reverse head) index tail)
421      (loop (Cons (First tail) head)
422            (+ index 1)
423            (Rest tail)))))
424
425(define (Sieve =? seq)
426  (let loop ((seq seq))
427    (if (Null? seq)
428      Nil
429      (let (
430        (first (First seq))
431        (tail
432          (Filter
433            (lambda (x)
434              (not (=? x (First seq))))
435            (Rest seq)))
436        )
437        (if (lazy-list-length seq)
438          (Cons first (loop tail))
439          (Lazy #f
440            (cons first (loop tail))))))))
441
442(define (Fold-left op base seq . seqs)
443  ; all equal finite length
444  (let loop ((base base) (seqs (cons seq seqs)))
445    (if (Null? (car seqs))
446      base
447      (loop (apply op base (map First seqs))
448            (map Rest seqs)))))
449
450(define (Fold-right op base seq . seqs)
451  ; all equal finite length
452  (let loop ((seqs (cons seq seqs)))
453    (if (Null? (car seqs))
454      base
455      (apply op 
456             (append (map First seqs)
457                     (list (loop (map Rest seqs))))))))
458
459;;; The following two routines return Lists
460(define (Fold-left* op base . seqs)
461  ;; all of equal length
462  (letrec (
463    (fold
464      (Cons base
465        (apply Map op
466                   (Lazy (if (null? seqs)
467                           #f
468                           (lazy-list-length (car seqs))) fold)
469                   seqs)))
470    )
471    (Rest fold)))
472
473(define (Fold-right* op base . seqs) ; changes order of List items
474  ;; all of equal length
475  (letrec (
476    (fold
477      (Cons base
478        (apply Map op
479               (append seqs
480                       (list
481                         (Lazy (if (null? seqs)
482                                 #f
483                                 (lazy-list-length (car seqs)))
484                           fold))))))
485    )
486    (Rest fold)))
487
488(define (Every? ok? seq)
489  (let loop ((seq seq))
490    (cond
491      ((Null? seq) #t)
492      ((ok? (First seq))
493       (loop (Rest seq)))
494      (else #f))))
495
496(define (Some? ok? seq)
497  (let loop ((seq seq))
498    (cond
499      ((Null? seq) #f)
500      ((ok? (First seq)) #t)
501      (else
502        (loop (Rest seq))))))
503
504(define (Zip seq1 seq2)
505  (if (Null? seq1)
506    seq2
507    (if (and (lazy-list-length seq1) (lazy-list-length seq2))
508      ;; both finite, compute new length with Cons
509      (Cons (First seq1) (Zip seq2 (Rest seq1)))
510      ;; new length infinite
511      (Lazy #f 
512        (cons (First seq1) (Zip seq2 (Rest seq1)))))))
513   
514;; hidden helpers
515(define (all ok? lst)
516  (let loop ((lst lst))
517    (cond
518      ((null? lst) #t)
519      ((ok? (car lst))
520       (loop (cdr lst)))
521      (else #f))))
522
523) ; module %lazy-lists
524
525;;(define (Take-with ok? seq)
526;;  (let loop ((n 1) (seq seq))
527;;    (print n);;;
528;;    (if (or (Null? seq) (ok? (First seq)))
529;;      Nil
530;;      (Lazy n
531;;        (cons (First seq) (loop (+ n 1) (Rest seq)))))))
532;(define (First-five) (List 0 1 2 3 4))
533;(define (Index ok? seq)
534;  (let loop ((n 0) (seq seq))
535;    (cond
536;      ((Null? seq) #f)
537;      ((ok? (First seq)) n)
538;      (else (loop (+ n 1) (Rest seq))))))
539;;(receive (head tail) (Split-at (Index (cut = <> 3) (List 0 1 2 3 4))
540;;                               (List 0 1 2 3 4))
541;;  (print (List->list head) " " (List->list tail)))
542
543(module lazy-lists
544  (Lazy make-lazy Car Cdr Nil Cons 
545   List->list list->List input->List
546   First Rest Length Append Reverse
547   List? Null? Realized? Reverse*
548   Take Drop Ref Take-upto Drop-upto
549   Memp Member Memq Memv Index
550   Equ? Equal? Eq? Eqv?
551   Assp Assoc Assq Assv
552   Map Filter Sieve For-each
553   Iterate Repeat Repeatedly
554   Cardinals Primes Cycle Interval
555   Merge Sort Split-at Split-with
556   vector->List List->vector
557   Fold-right Fold-left Fold-right* Fold-left* Zip
558   Every? Some? List lazy-lists)
559
560(import scheme
561        contracts
562        (only data-structures list-of?)
563        (prefix %lazy-lists %))
564
565;; initialize documentation
566(doclist '())
567
568(define-syntax-with-contract Lazy
569  "wrapper to make-lazy constructor"
570  (syntax-rules ()
571    ((_ len xpr . xprs)
572     (%make-lazy len (lambda () xpr . xprs)))))
573
574(define-with-contract (Cons var seq)
575  "lazy version of cons"
576  (domain (%List? seq))
577  (range (%List? result)
578         (or (not (%Length seq))
579             (= (%Length result) (+ (%Length seq) 1)))) 
580  (%Cons var seq))
581
582(define-with-contract (make-lazy len thunk)
583  "lazy constructor"
584  (domain (or (not len)
585              (and (integer? len)
586                   (not (negative? len))))
587          (procedure? thunk)
588          "thunk returns either '(), a List or (cons val List)")
589  (range (%List? result) (= (%Length result) len))
590  (%make-lazy len thunk))
591
592(define-with-contract (Length seq)
593  "lazy version of length"
594  (domain (%List? seq))
595  (range (or (not result)
596             (and (integer? result)
597                  (not (negative? result)))))
598  (%Length seq))
599
600(define-with-contract (List? xpr)
601  "lazy version of list?"
602  (range (boolean? result))
603  (%List xpr))
604
605(define Nil %Nil)
606
607(define-with-contract (Interval from upto)
608  "List of integers from (included) upto (excluded)"
609  (domain (integer? from) (integer? upto))
610  (range (%List result)
611         (= (%Length result) (abs (- upto from))))
612  (%Interval from upto))
613
614(define-with-contract (Cardinals)
615  "lazy list of non negative integers"
616  (range (%List? result) (not (%Length result)))
617  (%Cardinals))
618
619(define-with-contract (Primes)
620  "lazy list of non prime numbers"
621  (range (%List? result) (not (%Length result)))
622  (%Primes))
623
624(define-with-contract (Realized? seq)
625  "Is seq realized?"
626  (domain (%List? seq))
627  (range (boolean? result))
628  (%Realized? seq))
629
630(define-with-contract (Null? seq)
631  "lazy version of null?"
632  (domain (%List? seq))
633  (range (boolean? result))
634  (%Null? seq))
635
636(define-with-contract (Car seq)
637  "lazy version of car"
638  (domain (%List? seq) (not (%Null? seq)))
639  (%First seq))
640
641(define-with-contract (First seq)
642  "lazy version of car"
643  (domain (%List? seq) (not (%Null? seq)))
644  (%First seq))
645
646(define-with-contract (Cdr seq)
647  "lazy version of cdr"
648  (domain (%List? seq) (not (%Null? seq)))
649  (range (%List? result)
650         (or (not (%Length seq))
651             (= (%Length result) (- (%Length seq) 1))))
652  (%Rest seq))
653
654(define-with-contract (Rest seq)
655  "lazy version of cdr"
656  (domain (%List? seq) (not (%Null? seq)))
657  (range (%List? result)
658         (or (not (%Length seq))
659             (= (%Length result) (- (%Length seq) 1))))
660  (%Rest seq))
661
662(define-with-contract (Ref n seq)
663  "lazy version of list-ref with changed argument order"
664  (domain (%List? seq) (integer? n)
665          (or (not (%Length seq))
666              (< -1 n (%Length seq))))
667  (%Ref n seq))
668
669(define-with-contract (List->list seq)
670  "transform finite lazy into ordinary list"
671  (domain (%List? seq) (%Length seq))
672  (range (list? result))
673  (%List->list seq))
674
675(define-with-contract (list->List lst)
676  "transform ordinary list into finite lazy list"
677  (domain (list? lst))
678  (range (%List? result)
679         (eqv? (%Length result) (length lst)))
680  (%list->List lst))
681
682(define-with-contract (List . args)
683  "lazy version of list"
684  (range (%List? result)
685         (eqv? (%Length result) (length args)))
686  (apply %List args))
687
688(define-with-contract (Take n seq)
689  "List of first n items of seq"
690  (domain (%List? seq)
691          (integer? n) (not (negative? n)))
692  (range (%List? result) (%Length result)
693         (if (%Length seq)
694             (= (%Length result) (min n (%Length seq)))
695             (= (%Length result) n)))
696  (%Take n seq))
697
698(define-with-contract (Drop n seq)
699  "lazy version of list-tail with changed argument order"
700  (domain (%List? seq)
701          (integer? n) (not (negative? n)))
702  (range (%List? result)
703         (if (%Length seq)
704             (= (%Length result) (max 0 (- (%Length seq) n)))
705             (not (%Length result))))
706  (%Drop n seq))
707
708
709(define-with-contract (Take-upto ok? seq)
710  "List of head items fulfilling ok?"
711  (domain (%List? seq) (%Length seq)
712          (procedure? ok?) "(ok? x)")
713  (range (%List? result)
714         (<= (%Length result) (%Length seq)))
715  (%Take-upto ok? seq))
716
717(define-with-contract (Drop-upto ok? seq)
718  "Tail of items not fulfilling ok?"
719  (domain (%List? seq) (%Length seq)
720          (procedure? ok?) "(ok? x)")
721  (range (%List? result)
722         (<= (%Length result) (%Length seq)))
723  (%Drop-upto ok? seq))
724
725(define-with-contract (Index ok? seq)
726  "return index of first item fulfilling ok?"
727  (domain (%List? seq) (%Length seq)
728          (procedure? ok?) "(ok? x)")
729  (range (integer? result)
730         (not (negative? result)))
731  (%Index ok? seq))
732
733(define-with-contract (Memp ok? seq)
734  "Tail of items not fulfilling ok?"
735  (domain (%List? seq) (%Length seq)
736          (procedure? ok?) "(ok? x)")
737  (range (%List? result)
738         (<= (%Length result) (%Length seq)))
739  (%Memp ok? seq))
740
741(define-with-contract (Memq var seq)
742  "lazy version of memq"
743  (domain (%List? seq) (%Length seq))
744  (range (%List? result)
745         (<= (%Length result) (%Length seq)))
746  (%Memq var seq))
747
748(define-with-contract (Memv var seq)
749  "lazy version of memv"
750  (domain (%List? seq) (%Length seq))
751  (range (%List? result)
752         (<= (%Length result) (%Length seq)))
753  (%Memv var seq))
754
755(define-with-contract (Member var seq)
756  "lazy version of member"
757  (domain (%List? seq) (%Length seq))
758  (range (%List? result)
759         (<= (%Length result) (%Length seq)))
760  (%Member var seq))
761
762(define-with-contract (Equ? =? seq1 seq2)
763  "compare two Lists with predicate =?"
764  (domain (%List? seq1) (%List? seq2)
765          (procedure? =?) "(=? x y)")
766  (range (boolean? result))
767  (%Equ? =? seq1 seq2))
768
769(define-with-contract (Eq? seq1 seq2)
770  "lazy version of eq?"
771  (domain (%List? seq1) (%List? seq2))
772  (range (boolean? result))
773  (%Equ? eq? seq1 seq2))
774  ;(%Eq? seq1 seq2))
775
776
777(define-with-contract (Eqv? seq1 seq2)
778  "lazy version of eqv?"
779  (domain (%List? seq1) (%List? seq2))
780  (range (boolean? result))
781  (%Equ? eqv? seq1 seq2))
782  ;(%Eqv? seq1 seq2))
783
784(define-with-contract (Equal? seq1 seq2)
785  "lazy version of equal?"
786  (domain (%List? seq1) (%List? seq2))
787  (range (boolean? result))
788  (%Equ? equal? seq1 seq2))
789  ;(%Equal? seq1 seq2))
790
791(define-with-contract (Assp ok? aseq)
792  "return #f or first pair, whose Car fulfills ok?"
793  (domain (%List? aseq) "List of pairs" (%Length aseq)
794          (procedure? ok?) "(ok? x)")
795  (range (or (not result) (pair? result)))
796  (%Assp ok? aseq))
797
798(define-with-contract (Assq key aseq)
799  "lazy version of assq"
800  (domain (%List? aseq) "List of pairs" (%Length aseq))
801  (range (or (not result) (pair? result)))
802  (%Assq key aseq))
803
804(define-with-contract (Assv key aseq)
805  "lazy version of assv"
806  (domain (%List? aseq) "List of pairs" (%Length aseq))
807  (range (or (not result) (pair? result)))
808  (%Assv key aseq))
809
810(define-with-contract (Assoc key aseq)
811  "lazy version of assoq"
812  (domain (%List? aseq) "List of pairs" (%Length aseq))
813  (range (or (not result) (pair? result)))
814  (%Assoc key aseq))
815
816(define-with-contract (Map proc seq . seqs)
817  "lazy version of map"
818  (domain (%List? seq)
819          ((list-of? %List?) seqs)
820          (procedure? proc) "(proc arg . args)"
821          (all (lambda (x) (eqv? (%Length x) (%Length seq))) seqs))
822  (range (%List? result) (eqv? (%Length result) (%Length seq)))
823  (apply %Map proc seq seqs))
824
825(define-with-contract (Filter ok? seq)
826  "lazy version of filter"
827  (domain (%List? seq)
828          (procedure? ok?) "(ok? x)")
829  (range (%List? result)
830         (or (not (%Length seq))
831           (<= (%Length result) (%Length seq))))
832  (%Filter ok? seq))
833
834(define-with-contract (For-each proc seq . seqs)
835  "lazy version of for-each"
836  (domain (%List? seq)
837          ((list-of? %List?) seqs)
838          (procedure? proc) "(proc arg . args)"
839          (all (lambda (x) (eqv? (%Length x) (%Length seq))) seqs))
840  (apply %For-each proc seq seqs))
841
842(define-with-contract (input->List port read-proc)
843  "transform input port into List with read-proc"
844  (domain (input-port? port) (procedure? read-proc))
845  (range (%List? result) (%Length result))
846  (%input->List port read-proc))
847
848(define-with-contract (Repeat x)
849  "create infinite List of x"
850  (range (%List? result) (not (%Length result)))
851  (%Repeat x))
852
853(define-with-contract (Repeatedly thunk)
854  "create infinite List of return values of thunk"
855  (domain (procedure? thunk))
856  (range (%List? result) (not (%Length result)))
857  (%Repeatedly thunk))
858
859(define-with-contract (Iterate proc x)
860  "create infinite List by applying proc succesively to x"
861  (domain (procedure? proc) "(proc x)")
862  (range (%List? result) (not (%Length result)))
863  (%Iterate proc x))
864
865(define-with-contract (Append . seqs)
866  "lazy version of append"
867  (domain ((list-of? %List?) seqs)
868          (let ((lst (memv #f (map %Length seqs))))
869            (or (not lst) (<= (length lst) 1))))
870  (range (%List? result)
871         (or (not (%Length result))
872             (= (%Length result) (apply + (map %Length seqs)))))
873  (apply %Append seqs))
874
875(define-with-contract (Reverse seq)
876  "lazy version of reverse"
877  (domain (%List? seq) (%Length seq))
878  (range (%List? result) (%Length result)
879         (= (%Length result) (%Length seq)))
880  (%Reverse seq))
881
882(define-with-contract (Reverse* seq)
883  "List of successive reversed subLists"
884  (domain (%List? seq))
885  (range (%List? result)
886         (eqv? (%Length result) (%Length seq)))
887  (%Reverse* seq))
888
889
890(define-with-contract (Cycle seq)
891  "create infinite List by cycling finite List seq"
892  (domain (%List? seq) (%Length seq))
893  (range (%List? result) (not (%Length result)))
894  (%Cycle seq))
895
896(define-with-contract (Merge <? seq1 seq2)
897  "merge two sorted lazy lists with respect to <?"
898  (domain (procedure? <?) "(<? a b)"
899          (%List? seq1) (%Length seq1) "<? sorted"
900          (%List? seq2) (%Length seq2) "<? sorted")
901  (range (%List? result) "<? sorted"
902         (= (%Length result)
903            (+ (%Length seq1) (%Length seq2))))
904  (%Merge <? seq1 seq2))
905
906(define-with-contract (Sort <? seq)
907  "sort a finite lazy list with respect to <?"
908  (domain (procedure? <?) "(<? a b)"
909          (%List? seq) (%Length seq))
910  (range (%List? result) "<? sorted"
911         (eqv? (%Length result) (%Length seq)))
912  (%Sort <? seq))
913
914(define-with-contract (vector->List vec)
915  "transform a vector into a lazy list"
916  (domain (vector? vec))
917  (range (%List? result)
918         (eqv? (%Length result) (vector-length vec)))
919  (%vector->List vec))
920
921(define-with-contract (List->vector seq)
922  "transform a finite lazy list into a vector"
923  (domain (%List? seq) (%Length seq))
924  (range (vector? result)
925         (eqv? (vector-length result) (%Length seq)))
926  (%List->vector seq))
927
928(define-with-contract (Split-at n seq)
929  "split a List at fixed position"
930  (domain (%List? seq)
931          (integer? n) (not (negative? n)))
932  (range (with-results (head tail)
933           (%List? head) (%Length head)
934           (<= (%Length head) n)
935           (%List? tail)
936           (if (%Length seq)
937             (<= (%Length tail) (%Length seq))
938             (not (%Length tail)))))
939  (%Split-at n seq))
940
941(define-with-contract (Split-with ok? seq)
942  "split a lazy list at first index fulfilling ok?"
943  (domain (%List? seq) (%Length seq)
944          (procedure? ok?) "(ok? x)")
945  (range (with-results (head index tail)
946           (%List? head) (%List? tail)
947           (integer? index) (not (negative? index))
948           (<= (%Length head) (%Length seq))
949           (<= (%Length tail) (%Length seq))))
950  (%Split-with ok? seq))
951
952(define-with-contract (Sieve =? seq)
953  "sievo of Erathostenes with respect to =?"
954  (domain (%List? seq)
955          (procedure? =?) "(=? a b)")
956  (range (%List? result) "not two items =?"
957         (if (%Length seq)
958           (<= (%Length result) (%Length seq))
959           (not (%Length result))))
960  (%Sieve =? seq))
961
962(define-with-contract (Fold-left op base seq . seqs)
963  "lazy version of fold-left"
964  (domain (procedure? op) "(op b s . ss)"
965          (%List? seq) ((list-of? %List?) seqs)
966          (%Length seq)
967          (all (lambda (x) (= (%Length x) (%Length seq))) seqs))
968  (apply %Fold-left op base seq seqs))
969
970(define-with-contract (Fold-right op base seq . seqs)
971  "lazy version of fold-right"
972  (domain (procedure? op) "(op b s . ss)"
973          (%List? seq) ((list-of? %List?) seqs)
974          (%Length seq)
975          (all (lambda (x) (= (%Length x) (%Length seq))) seqs))
976  (apply %Fold-right op base seq seqs))
977
978(define-with-contract (Fold-left* op base . seqs)
979  "create a lazy list of left folds"
980  (domain (procedure? op) "(op b . ss)"
981          ((list-of? %List?) seqs)
982          (or (null? seqs)
983              (all (lambda (x)
984                     (eqv? (%Length x) (%Length (car seqs))))
985                   (cdr seqs))))
986  (range (%List? result)
987         (if (null? seqs)
988           (not (%Length result))
989           (eqv? (%Length result) (%Length (car seqs)))))
990  (apply %Fold-left* op base seqs))
991
992(define-with-contract (Fold-right* op base . seqs)
993  "create a lazy list of right folds changing order or List items"
994  (domain (procedure? op) "(op b . ss)"
995          ((list-of? %List?) seqs)
996          (or (null? seqs)
997              (all (lambda (x)
998                     (eqv? (%Length x) (%Length (car seqs))))
999                   (cdr seqs))))
1000  (range (%List? result)
1001         (if (null? seqs)
1002           (not (%Length result))
1003           (eqv? (%Length result) (%Length (car seqs)))))
1004  (apply %Fold-right* op base seqs))
1005
1006(define-with-contract (Every? ok? seq)
1007  "does everey item of seq fulfill ok?"
1008  (domain (%List? seq) (%Length seq)
1009          (procedure? ok?) "(ok? x)")
1010  (%Every? ok? seq))
1011
1012(define-with-contract (Some? ok? seq)
1013  "does some item of seq fulfill ok?"
1014  (domain (%List? seq) (%Length seq)
1015          (procedure? ok?) "(ok? x)")
1016  (%Some? ok? seq))
1017
1018(define-with-contract (Zip seq1 seq2)
1019  "interleave two lazy lists"
1020  (domain (%List? seq1) (%List? seq2))
1021  (range (%List? result)
1022         (if (and (%Length seq1) (%Length seq2))
1023           (= (%Length result)
1024              (+ (%Length seq1) (%Length seq2)))
1025           (not (%Length result))))
1026  (%Zip seq1 seq2))
1027
1028(define lazy-lists (doclist->dispatcher (doclist)))
1029
1030;; hidden
1031(define (all ok? lst)
1032  (let loop ((lst lst))
1033    (cond
1034      ((null? lst) #t)
1035      ((ok? (car lst))
1036       (loop (cdr lst)))
1037      (else #f))))
1038
1039) ; module lazy-lists
1040
Note: See TracBrowser for help on using the repository browser.