Changeset 33876 in project


Ignore:
Timestamp:
03/04/17 18:23:26 (4 weeks ago)
Author:
juergen
Message:

lazy-lists 0.9 with finite? instead of length slot

Location:
release/4/lazy-lists
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/lazy-lists/tags/0.9/lazy-lists.scm

    r31803 r33876  
    22; ju (at) jugilo (dot) de
    33;
    4 ; Copyright (c) 2012-2014, Juergen Lorenz, Moritz Heidkamp
     4; Copyright (c) 2012-2017, Juergen Lorenz
    55; All rights reserved.
    66;
     
    3131; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    3232; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    33 ;
    34 ; Last update: Nor 09, 2014
    35 ;
     33
     34#|[
     35The lazy-list implementation of this module is inspired by Moritz
     36Heidkamp's lazy-seq egg. It's not based on the Scheme primitives delay
     37and force, but uses a record type instead. I've added an additional slot
     38to this record-type, a boolean, finite?, so that it is possible to
     39discriminate between finite and infinite lazy lists without realizing
     40the whole record. After all, some routines, reverse for example, make
     41only sense for finite lists. Moreover, the names of all exported
     42routines are capitalized, so that I could reuse the familiar names of
     43eager lists without fear of name clashes.
     44I followed a consistent argument order, at least in principle: List
     45arguments are always last, procedure arguments always first. Some well
     46known list primitives, List-ref and List-tail, with wrong argument
     47order, are still there, but accompanied by At and Drop with the right
     48order.
     49]|#
     50
    3651(module lazy-lists
    37   (lazy-lists Lazy assume-in Make-lazy
     52  (lazy-lists assume-in Lazy Make-lazy
    3853   List->list list->List input->List
    3954   First Rest Car Cdr Length Length-min Append Reverse
     
    4156   List-infinite? Realize
    4257   List-not-null? List-finite? Lists-one-finite?
    43    Take Drop Ref Take-while Drop-while Count-while
     58   At Ref List-ref List-tail
     59   Take Drop Take-while Drop-while Count-while
    4460   Memp Member Memq Memv
    4561   Equ? Equal? Eq? Eqv?
     
    5773        (only data-structures o compress list-of?)
    5874        (only chicken
    59               cond-expand
    6075              define-record-type
    6176              define-record-printer
    62               cut when case-lambda
    63               nth-value unless receive
    64               make-parameter error void add1 sub1
    65               fixnum? fx+ fx= fx>= fx< fx- fx/))
    66 
     77              define-reader-ctor
     78              cut case-lambda
     79              unless receive
     80              make-parameter error void
     81              fixnum? fx+ fx= fx>= fx< fx> fx- fx/ fxshr))
     82
     83;; documentation procedure
    6784(define lazy-lists
    6885  (let (
    6986    (signatures '(
    70       (Lazy len xpr . xprs)
    7187      (assume-in sym test . tests)
    72       (Make-lazy len thunk)
     88      (Lazy finite? xpr . xprs)
     89      (Make-lazy finite? thunk)
    7390      (List->list Lst-finite)
    7491      (list->List lst)
     
    103120      (Take k Lst)
    104121      (Drop k Lst)
     122      (List-tail Lst k)
    105123      (Ref k Lst)
     124      (List-ref Lst k)
     125      (At k Lst)
    106126      (Take-while ok? Lst)
    107127      (Drop-while ok? Lst)
     
    126146      (Map fn . Lsts)
    127147      (For-each proc . Lsts)
    128       (Iterate [n] fn x)
    129       (Repeat [n] x)
    130       (Repeatedly [n] thunk)
    131       (Cycle [n] Lst)
     148      (Iterate fn x [times])
     149      (Repeat x [times])
     150      (Repeatedly thunk [times])
     151      (Cycle [times] Lst)
    132152      (Range [from] upto [step])
    133153      (Cardinals)
     
    136156      (Merge <? Lst-finite1 Lst-finite2)
    137157      (Sorted? <? Lst-finite)
    138       (Fold-right op base . Lsts-one-finite)
    139       (Fold-left op base . Lists-one-finite)
    140       (Fold-right* op base . Lsts)
    141       (Fold-left* op base . Lsts)
     158      (Fold-right op base Lst . Lsts)
     159      (Fold-left op base Lst . Lsts)
     160      (Fold-right* op base Lst . Lsts)
     161      (Fold-left* op base Lst . Lsts)
    142162      (Zip Lst1 Lst2)
    143163      (Unzip Lst)
     
    179199(define lazy-list
    180200  (define-record-type lazy-list
    181     (make-lazy-list length body value)
     201    (make-lazy-list finite? body value)
    182202    lazy-list?
    183     (length lazy-list-length lazy-list-length-set!)
     203    (finite? lazy-list-finite?)
    184204    (body lazy-list-body lazy-list-body-set!)
    185205    (value lazy-list-value lazy-list-value-set!)))
     
    187207(define-syntax Lazy
    188208  (syntax-rules ()
    189     ((_ len xpr . xprs)
    190      (Make-lazy len (lambda () xpr . xprs)))))
    191 
    192 
    193 (define (Make-lazy len thunk)
    194   (make-lazy-list len thunk #f))
     209    ((_ finite? xpr . xprs)
     210     (Make-lazy finite? (lambda () xpr . xprs)))))
     211
     212
     213(define (Make-lazy finite? thunk)
     214  (make-lazy-list finite? thunk #f))
    195215
    196216(define (Cons var Lst)
    197217  (assume-in 'Cons
    198218    (List? Lst))
    199   (let ((len (lazy-list-length Lst)))
    200     (Lazy (if len (+ 1 len) #f)
     219  (let ((finite? (lazy-list-finite? Lst)))
     220    (Lazy finite?
    201221      (cons var Lst))))
    202222
    203 (define Length lazy-list-length)
     223(define (Length Lst)
     224  (assume-in 'Length
     225    (List? Lst))
     226  (if (lazy-list-finite? Lst)
     227    (let loop ((Lst Lst) (result 0))
     228      (if (Null? Lst)
     229        result
     230        (loop (Rest Lst) (fx+ 1 result))))
     231    #f))
    204232
    205233(define (Length-min . Lsts)
    206234  (assume-in 'Length-min
    207235    ((list-of? List?) Lsts))
    208   (let* ((lens (map Length Lsts))
    209          (finites (compress lens lens)))
    210     (if (null? finites)
     236  (let ((Finites (compress (map lazy-list-finite? Lsts)
     237                            Lsts)))
     238    (if (null? Finites)
    211239      #f
    212       (apply min finites))))
     240      (apply min (map Length Finites)))))
    213241
    214242(define List? lazy-list?)
    215243
    216244(define Nil
    217   (make-lazy-list 0 (lambda () '()) #f))
     245  (make-lazy-list #t (lambda () '()) #f))
    218246
    219247(define-record-printer (lazy-list Lst out)
    220248  (assume-in 'define-record-printer
    221249    (List? Lst))
    222   (display "#(List[" out)
    223   (display (lazy-list-length Lst) out)
     250  (display "#,(List[" out)
     251  (display (if (lazy-list-finite? Lst)
     252             "finite"
     253             "infinite") out)
     254  ;(display (lazy-list-finite? Lst) out)
    224255  (display "]" out)
    225256  (cond ((not (Realized? Lst))
     
    254285  (assume-in 'Realize
    255286    (List-finite? Lst))
    256   (let ((len (lazy-list-length Lst)))
    257     (when len
    258       (Ref (- len 1) Lst)
    259       Lst)))
     287  ;(let ((len (Length Lst)))
     288  ;  (when len
     289  ;    (At (fx- len 1) Lst)
     290  ;    Lst)))
     291  (At (fx- (Length Lst) 1) Lst)
     292  Lst)
    260293 
    261294(define (Realized? Lst)
     
    273306  (car (realize Lst)))
    274307
    275 (define (Car Lst)
    276   (assume-in 'Car
    277     (List? Lst))
    278   (First Lst))
    279 
    280 ;; to speed up cdring for lists with preknown length
    281 (define (rest Lst)
    282   (assume-in 'rest (List? Lst))
    283   (cdr (realize Lst)))
     308(define Car First)
    284309
    285310(define (Rest Lst)
    286311  (assume-in 'Rest (List? Lst))
    287   (let (
    288     (len (lazy-list-length Lst))
    289     (Result (cdr (realize Lst)))
    290     )
    291     (lazy-list-length-set! Result (if len (fx- len 1) #f))
    292     Result))
    293 
    294 (define (Cdr Lst)
    295   (assume-in 'Cdr (List? Lst))
    296   (Rest Lst))
    297 
     312  (cdr (realize Lst)))
     313
     314(define Cdr Rest)
     315
     316;; deprecated
     317;; makes finite Lists eager!!!
     318;; and if checked traverses Lists twice
    298319(define (Admissible? n Lst)
    299320  (assume-in 'Admissible?
     
    301322    (fixnum? n)
    302323    (fx>= n 0))
    303   (let ((len (lazy-list-length Lst)))
     324  (let ((len (Length Lst)));(lazy-list-length Lst)))
    304325    (or (not len) (fx< n len))))
    305326 
    306 (define (Ref n Lst)
    307   (assume-in 'Ref
    308     (Admissible? n Lst))
    309   (let ((len (lazy-list-length Lst)))
    310     (let loop ((n n) (Lst Lst))
    311       (if (fx= n 0)
    312         (First Lst)
    313         (loop (fx- n 1) (Rest Lst))))))
     327(define (At k Lst)
     328  (assume-in 'At
     329    (List? Lst) (fx>= k 0))
     330  (cond
     331    ((Null? Lst)
     332     (error 'At "out of range" k Lst))
     333    ((fx= 0 k)
     334     (First Lst))
     335    (else
     336     (At (fx- k 1) (Rest Lst)))))
     337
     338;; deprecated
     339(define Ref At)
     340
     341(define (List-ref Lst k)
     342  (At k Lst))
    314343
    315344(define (List->list Lst)
     
    328357    (if (null? lst)
    329358      Lst
    330       (loop (cdr lst) (Cons (car lst) Lst)))))
     359      (loop (cdr lst)
     360            (Lazy #t (cons (car lst) Lst))))))
    331361
    332362(define (List . args)
    333363  (list->List args))
    334364
     365(define-reader-ctor 'List List)
     366
     367;; Drop and Take as well as Split-at now check n parameter
    335368(define (Take n Lst)
    336369  (assume-in 'Take
     
    338371    (fixnum? n)
    339372    (fx>= n 0))
    340   (call-with-values
    341     (lambda () (Split-at n Lst))
    342     (lambda (a b) a)))
    343 
     373  (if (and (Null? Lst) (fx> n 0))
     374    (error 'Take "out of bounds" Lst n)
     375    (Lazy #t
     376      (if (or (fx= n 0) (Null? Lst))
     377        '()
     378        (cons
     379          (First Lst)
     380          (Take (fx- n 1) (Rest Lst)))))))
     381   
    344382(define (Drop n Lst)
    345383  (assume-in 'Drop
    346     (Admissible? n Lst))
    347   (call-with-values
    348     (lambda () (Split-at n Lst))
    349     (lambda (a b) b)))
     384    (List? Lst)
     385    (fixnum? n)
     386    (fx>= n 0))
     387  (cond
     388    ((and (Null? Lst) (fx> n 0))
     389     (error 'Drop "out of bounds" Lst n))
     390    ((or (zero? n) (Null? Lst))
     391     Lst)
     392    (else
     393      (Drop (fx- n 1) (Rest Lst)))))
     394
     395(define (List-tail Lst n)
     396  (Drop n Lst))
     397
     398(define (Split-at n Lst)
     399  (values (Take n Lst) (Drop n Lst)))
    350400
    351401(define (Take-while ok? Lst)
     
    353403    (List-finite? Lst)
    354404    (procedure? ok?))
    355   (nth-value 0 (Split-with ok? Lst)))
     405  (let ((finite? (lazy-list-finite? Lst)))
     406    (let loop ((Lst Lst))
     407      (Lazy finite?
     408        (cond
     409          ((Null? Lst)
     410           '())
     411          ((ok? (First Lst))
     412           (cons (First Lst) (loop (Rest Lst))))
     413          (else '()))))))
     414;  (Lazy (lazy-list-finite? Lst)
     415;    (let loop ((Lst Lst))
     416;      (cond
     417;        ((Null? Lst)
     418;         '())
     419;        ((ok? (First Lst))
     420;         (cons (First Lst) (loop (Rest Lst))))
     421;        (else '())))))
    356422
    357423(define (Count-while ok? Lst)
     
    359425    (List-finite? Lst)
    360426    (procedure? ok?))
    361   (nth-value 1 (Split-with ok? Lst)))
     427  (let loop ((Lst Lst) (index 0))
     428    (cond
     429      ((Null? Lst)
     430       index)
     431      ((ok? (First Lst))
     432       (loop (Rest Lst) (fx+ index 1)))
     433      (else index))))
    362434
    363435(define (Drop-while ok? Lst)
     
    365437    (List-finite? Lst)
    366438    (procedure? ok?))
    367   (nth-value 2 (Split-with ok? Lst)))
     439  (let ((finite? (lazy-list-finite? Lst)))
     440    (let loop ((Lst Lst))
     441      (Lazy finite?
     442        (cond
     443          ((Null? Lst)
     444           '())
     445          ((ok? (First Lst))
     446           (loop (Rest Lst)))
     447          (else Lst))))))
     448
     449(define (Split-with ok? Lst)
     450  (values (Take-while ok? Lst)
     451          (Count-while ok? Lst)
     452          (Drop-while ok? Lst)))
    368453
    369454(define (Memp ok? Lst)
     
    374459
    375460(define (Memq var Lst)
    376   (assume-in 'Memq
    377     (List-finite? Lst))
     461  ;(assume-in 'Memq
     462  ;  (List-finite? Lst))
    378463  (Memp (cut eq? <> var) Lst))
    379464
    380465(define (Memv var Lst)
    381   (assume-in 'Memv
    382     (List-finite? Lst))
     466  ;(assume-in 'Memv
     467  ;  (List-finite? Lst))
    383468  (Memp (cut eqv? <> var) Lst))
    384469
    385470(define (Member var Lst)
    386   (assume-in 'Member
    387     (List-finite? Lst))
     471  ;(assume-in 'Member
     472  ;  (List-finite? Lst))
    388473  (Memp (cut equal? <> var) Lst))
    389474
     
    393478    (List? Lst1)
    394479    (List? Lst2))
    395   (if (eqv? (lazy-list-length Lst1) (lazy-list-length Lst2))
    396     (if (lazy-list-length Lst1)
    397       ;; both finite
    398       (let loop ((Lst1 Lst1) (Lst2 Lst2))
    399         (cond
    400           ((Null? Lst1) #t)
    401           ((=? (First Lst1) (First Lst2))
    402            (loop (Rest Lst1) (Rest Lst2)))))
    403       ;; both infinite
    404       (eq? Lst1 Lst2))
    405     #f))
     480  (cond
     481    ((and (List-finite? Lst1) (List-finite? Lst2))
     482     (let loop ((Lst1 Lst1) (Lst2 Lst2))
     483       (cond
     484         ((and (Null? Lst1) (Null? Lst2))
     485          #t)
     486         ((=? (First Lst1) (First Lst2))
     487          (loop (Rest Lst1) (Rest Lst2)))
     488         (else #f))))
     489    ((and (List-infinite? Lst1) (List-infinite? Lst2))
     490     (eq? Lst1 Lst2))
     491    (else #f)))
    406492
    407493(define (Eq? Lst1 Lst2)
    408   (assume-in 'Eq?
    409     (List? Lst1)
    410     (List? Lst2))
     494  ;(assume-in 'Eq?
     495  ;  (List? Lst1)
     496  ;  (List? Lst2))
    411497  (Equ? eq? Lst1 Lst2))
    412498
    413499(define (Eqv? Lst1 Lst2)
    414   (assume-in 'Eqv?
    415     (List? Lst1)
    416     (List? Lst2))
     500  ;(assume-in 'Eqv?
     501  ;  (List? Lst1)
     502  ;  (List? Lst2))
    417503  (Equ? eqv? Lst1 Lst2))
    418504
    419505(define (Equal? Lst1 Lst2)
    420   (assume-in 'Equal?
    421     (List? Lst1)
    422     (List? Lst2))
     506  ;(assume-in 'Equal?
     507  ;  (List? Lst1)
     508  ;  (List? Lst2))
    423509  (Equ? equal? Lst1 Lst2))
    424510
     
    433519
    434520(define (Assq key al)
    435   (assume-in 'Assq
    436     (symbol? key)
    437     ((list-of? pair?) al))
     521  ;(assume-in 'Assq
     522  ;  ((list-of? pair?) al))
    438523  (Assp (cut eq? <> key) al))
    439524
    440525(define (Assv key al)
    441   (assume-in 'Assv
    442     ((list-of? pair?) al))
     526  ;(assume-in 'Assv
     527  ;  ((list-of? pair?) al))
    443528  (Assp (cut eqv? <> key) al))
    444529
    445530(define (Assoc key al)
    446   (assume-in 'Assoc
    447     ((list-of? pair?) al))
     531  ;(assume-in 'Assoc
     532  ;  ((list-of? pair?) al))
    448533  (Assp (cut equal? <> key) al))
    449534
     
    463548  (if (null? Lsts)
    464549    Nil
    465     (let loop ((Lsts Lsts))
    466       (Lazy (apply Length-min Lsts)
    467         (if (memp Null? Lsts)
    468           '()
    469           (cons (apply proc (map Car Lsts))
    470                 (loop (map Cdr Lsts))))))))
     550    (let ((finite? (if (not (apply Length-min Lsts)) #f #t)))
     551      (let loop ((Lsts Lsts))
     552        (Lazy finite?
     553          (if (memp Null? Lsts)
     554            '()
     555            (cons (apply proc (map Car Lsts))
     556                  (loop (map Cdr Lsts)))))))))
    471557
    472558(define (For-each proc . Lsts)
     
    485571    (List? Lst))
    486572  (let ((ev? #f))
    487     (let loop ((Lst Lst))
    488       (cond
    489         ((Null? Lst)
    490          (values Nil Nil))
    491         (else
    492           (set! ev? (not ev?))
    493           (if (lazy-list-length Lst)
    494             ;; compute new length via Cons
     573    (let ((finite? (lazy-list-finite? Lst)))
     574      (let loop ((Lst Lst))
     575        (cond
     576          ((Null? Lst)
     577           (values Nil Nil))
     578          (else
     579            (set! ev? (not ev?))
    495580            (if ev?
    496               (values (Cons (First Lst) (loop (Rest Lst)))
    497                       (loop (Rest Lst)))
    498               (values (loop (Rest Lst))
    499                       (Cons (First Lst) (loop (Rest Lst)))))
    500             ;; set new length #f
    501             (if ev?
    502               (values (Lazy #f (cons (First Lst) (loop (rest Lst))))
    503                       (Lazy #f (loop (rest Lst))))
    504               (values (Lazy #f (loop (rest Lst)))
    505                       (Lazy #f (cons (First Lst) (loop (rest Lst))))))))))))
     581              (values (Lazy finite?
     582                        (cons (First Lst) (loop (Rest Lst))))
     583                      (Lazy finite?
     584                        (loop (Rest Lst))))
     585              (values (Lazy finite?
     586                        (loop (Rest Lst)))
     587                      (Lazy finite?
     588                        (cons (First Lst) (loop (Rest Lst))))))))))))
    506589   
    507590(define (Zip Lst1 Lst2)
     
    509592    (List? Lst1)
    510593    (List? Lst2))
    511   (if (Null? Lst1)
    512     Lst2
    513     (if (and (lazy-list-length Lst1) (lazy-list-length Lst2))
    514       ;; both finite, compute new length with Cons
    515       (Cons (First Lst1) (Zip Lst2 (Rest Lst1)))
    516       ;; new length infinite
    517       (Lazy #f
    518         (cons (First Lst1) (Zip Lst2 (Rest Lst1)))))))
     594  (let ((both-finite?
     595          (and (lazy-list-finite? Lst1)
     596               (lazy-list-finite? Lst2))))
     597    (let loop ((Lst1 Lst1) (Lst2 Lst2))
     598      (if (Null? Lst1)
     599        Lst2
     600        (Lazy both-finite?
     601          (cons (First Lst1) (loop Lst2 (Rest Lst1))))))))
    519602
    520603(define (Filter ok? Lst)
    521604  (assume-in 'Filter
    522     (List? Lst))
    523   (let loop ((Lst Lst))
    524     (if (Null? Lst)
    525       Nil
    526       (let ((first (First Lst))
    527             (Result (if (lazy-list-length Lst)
    528                       (loop (Rest Lst))
    529                       (Lazy #f (loop (rest Lst))))))
    530         (if (ok? first)
    531           (Cons first Result)
    532           Result)))))
    533 ;  (if (Null? Lst)
    534 ;    (values Nil Nil)
    535 ;    (let ((first (First Lst)))
    536 ;      (if (lazy-list-length Lst)
    537 ;        (receive (Yes No) (Filter ok? (Rest Lst))
    538 ;          (if (ok? first)
    539 ;            (values (Cons first Yes) No)
    540 ;            (values Yes (Cons first No))))
    541 ;        (let ((yes (Lazy #f (Filter ok? (rest Lst))))
    542 ;              (no (Lazy #f (Filter (o not ok?) (rest Lst)))))
    543 ;        ;(receive (yes no) (Filter ok? (rest Lst)) ; wrong
    544 ;          (if (ok? first)
    545 ;            (values (Cons first yes) no)
    546 ;            (values yes (Cons first no))))))))
     605    (List? Lst)
     606    (procedure? ok?))
     607    (let ((finite? (lazy-list-finite? Lst)))
     608      (let loop ((Lst Lst))
     609        (Lazy finite?
     610          (if (Null? Lst)
     611            '()
     612            (let ((first (First Lst)) (rest (Rest Lst)))
     613              (if (ok? first)
     614                (cons first (loop rest))
     615                (loop rest))))))))
    547616
    548617(define (Remp ok? Lst)
     
    560629(define (input->List port read)
    561630  (let loop ()
    562     ;(Lazy #f
     631    (Lazy #f
    563632      (let ((datum (read port)))
    564633        (if (eof-object? datum)
    565             Nil
    566             (Cons datum (loop))))));)
     634            '()
     635            (cons datum (loop)))))))
    567636
    568637(define Repeat
    569638  (case-lambda
    570639    ((x) (Lazy #f (cons x (Repeat x))))
    571     ((n x)
     640    ((x times)
    572641     (assume-in 'Repeat
    573        (fixnum? n)
    574        (fx>= n 0))
    575      (Take n (Repeat x)))))
     642       (fixnum? times)
     643       (fx>= times 0))
     644     (Take times (Repeat x)))))
    576645
    577646(define Repeatedly
     
    581650       (procedure? thunk))
    582651     (Lazy #f (cons (thunk) (Repeatedly thunk))))
    583     ((n thunk)
     652    ((thunk times)
    584653     (assume-in 'Repeatedly
    585        (procedure? thunk)
    586        (fixnum? n)
    587        (fx>= n 0))
    588      (Take n (Repeatedly thunk)))))
     654       (fixnum? times)
     655       (fx>= times 0))
     656     (Take times (Repeatedly thunk)))))
    589657
    590658(define Iterate
    591659  (case-lambda
    592     ((f x)
     660    ((fn x)
    593661     (assume-in 'Iterate
    594        (procedure? f))
    595      (Lazy #f (cons x (Iterate f (f x)))))
    596     ((n f x)
     662       (procedure? fn))
     663     (Lazy #f (cons x (Iterate fn (fn x)))))
     664    ((fn x times)
    597665     (assume-in 'Iterate
    598        (procedure? f)
    599        (fixnum? n)
    600        (fx>= n 0))
    601      (Take n (Iterate f x)))))
     666       (fixnum? times)
     667       (fx>= times 0))
     668     (Take times (Iterate fn x)))))
    602669
    603670(define Cycle
     
    613680             (loop Lst)
    614681             (cons (First tail)
    615                    (loop (rest tail))))))))
     682                   (loop (Rest tail))))))))
    616683    ((n Lst)
    617684     (assume-in 'Cycle
    618        (List? Lst)
    619685       (fixnum? n)
    620686       (fx>= n 0))
     
    624690  (case-lambda
    625691    ((upto)
    626      (Iterate (abs upto)
    627               (if (fx>= upto 0)
     692     (Iterate (if (fx>= upto 0)
    628693                (cut fx+ <> 1)
    629694                (cut fx- <> 1))
    630               0))
     695              0
     696              (abs upto)))
    631697    ((from upto)
    632      (Iterate (abs (fx- upto from))
    633               (if (fx>= upto from)
     698     (Iterate (if (fx>= upto from)
    634699                      (cut fx+ <> 1)
    635700                      (cut fx- <> 1))
    636               from))
     701              from
     702              (abs (fx- upto from))
     703              ))
    637704    ((from upto step)
    638      (Iterate (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step)
    639               (if (fx>= upto from)
     705     (Iterate (if (fx>= upto from)
    640706                      (cut fx+ <> step)
    641707                      (cut fx- <> step))
    642               from))))
    643 
    644 (define (Append2 Lst1 Lst2)
    645   (if (not (lazy-list-length Lst1))
    646     Lst1
    647     (let loop ((Lst Lst1))
    648       (Lazy (if (lazy-list-length Lst2)
    649               (+ (lazy-list-length Lst1)
    650                  (lazy-list-length Lst2))
    651               #f)
    652         (if (Null? Lst)
    653           Lst2
    654           (cons (First Lst) (loop (rest Lst))))))))
    655 
    656 (define (Append . Lsts)
    657   (assume-in 'Append
    658     ((list-of? List-finite?) (butlast Lsts))
    659     (List? (last Lsts)))
    660   (cond
    661     ((null? Lsts) Nil)
    662     ((null? (cdr Lsts)) (car Lsts))
    663     (else
    664       (Append2 (car Lsts) (apply Append (cdr Lsts))))))
    665 
    666 (define (Reverse Lst)
    667   (assume-in 'Reverse
    668     (List-finite? Lst))
    669   (let loop ((Lst Lst) (reverse Nil))
    670     (if (Null? Lst)
    671       reverse
    672       (Lazy (lazy-list-length Lst)
    673         (loop (rest Lst)
    674               (Cons (First Lst) reverse))))))
     708              from
     709              (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step)
     710              ))))
     711
     712(define Append
     713  (case-lambda
     714    ((Lst1 Lst2)
     715     (assume-in 'Append
     716       (List? Lst1) (List? Lst2))
     717     (if (List-infinite? Lst1)
     718       Lst1
     719       (let ((finite? (lazy-list-finite? Lst2)))
     720         (let loop ((Lst1 Lst1))
     721           (Lazy finite?
     722             (if (Null? Lst1)
     723               Lst2
     724               (cons (First Lst1) (loop (Rest Lst1)))))))))
     725    ((Lst . Lsts)
     726     (if(Null? Lsts)
     727       Lst
     728       (apply Append
     729              (Append Lst (First Lsts))
     730              (Rest Lsts))))
     731    ))
     732
     733(define Reverse
     734  (case-lambda
     735    ((Lst1 Lst2)
     736     (assume-in 'Reverse
     737       (List-finite? Lst1) (List? Lst2))
     738     (let ((finite? (lazy-list-finite? Lst2)))
     739       (let loop ((Lst1 Lst1) (Result Lst2))
     740         (if (Null? Lst1)
     741           Result
     742           (loop (Rest Lst1)
     743                 (Lazy finite?
     744                   (cons (First Lst1) Result)))))))
     745    ((Lst)
     746     (Reverse Lst Nil))))
    675747
    676748(define (Reverse* Lst)
    677749  (assume-in 'Reverse*
    678750    (List? Lst))
    679   (letrec (
    680     (result
    681       (Cons Nil
    682         (Map Cons
    683              Lst
    684              (Lazy (lazy-list-length Lst) result))))
    685     )
    686     (Rest result)))
     751  (let ((finite? (lazy-list-finite? Lst)))
     752    (if (not finite?)
     753      (let loop ((n 1))
     754        (Lazy #f (cons (Reverse (Take n Lst))
     755                       (loop (fx+ n 1)))))
     756      (let ((len (Length Lst)))
     757        (let loop ((n 1))
     758          (Lazy #t
     759            (if (fx= 0 len)
     760              (list (First Lst))
     761              (cons (Reverse (Take n Lst))
     762                    (loop (fx+ n 1))))))))))
    687763
    688764(define (Merge <? Lst1 Lst2)
     
    691767    (List-finite? Lst1)
    692768    (List-finite? Lst2))
    693   (let ((len (+ (lazy-list-length Lst1) (lazy-list-length Lst2))))
    694     (let loop ((Lst1 Lst1) (Lst2 Lst2))
    695       (cond
    696         ((Null? Lst1) Lst2)
    697         ((Null? Lst2) Lst1)
    698         ((<? (First Lst1) (First Lst2))
    699          (Lazy len (cons (First Lst1) (loop (rest Lst1) Lst2))))
    700         (else
    701          (Lazy len
    702                (cons (First Lst2) (loop Lst1 (rest Lst2)))))))))
     769  (let loop ((Lst1 Lst1) (Lst2 Lst2))
     770    (cond
     771      ((Null? Lst1) Lst2)
     772      ((Null? Lst2) Lst1)
     773      ((<? (First Lst1) (First Lst2))
     774       (Lazy #t
     775         (cons (First Lst1) (loop (Rest Lst1) Lst2))))
     776      (else
     777       (Lazy #t
     778             (cons (First Lst2) (loop Lst1 (Rest Lst2))))))))
    703779
    704780(define (Sort <? Lst)
     
    706782    (procedure? <?)
    707783    (List-finite? Lst))
    708   (let ((len (lazy-list-length Lst)))
    709     (if (< len 2)
     784  (let ((len (Length Lst)))
     785    (if (fx< len 2)
    710786      Lst
    711       (let ((halflen (quotient len 2)))
     787      (let ((halflen (fxshr len 1)))
    712788        (Merge <?
    713789          (Sort <? (Take halflen Lst))
     
    721797    (cond
    722798      ((Null? Lst) #t)
    723       ((Null? (Cdr Lst)) #t)
    724       ((<? (Car Lst) (Car (Cdr Lst)))
    725        (loop (Cdr Lst)))
     799      ((Null? (Rest Lst)) #t)
     800      ((<? (First Lst) (First (Rest Lst)))
     801       (loop (Rest Lst)))
    726802      (else #f))))
    727803
     
    729805  (assume-in 'vector->List
    730806    (vector? vec))
    731   (let loop ((res Nil) (n (vector-length vec)))
    732     (if (zero? n)
    733       res
    734       (loop (Cons (vector-ref vec (- n 1)) res) (- n 1)))))
    735 
    736 ;; see comment to List->list
     807  (let loop ((Result Nil) (n (fx- (vector-length vec) 1)))
     808    (if (fx< n 0)
     809      Result
     810      (loop (Lazy #t (cons (vector-ref vec n) Result))
     811            (fx- n 1)))))
    737812(define (List->vector Lst)
    738813  (assume-in 'List->vector
    739814    (List-finite? Lst))
    740   (let ((vec (make-vector (lazy-list-length Lst) #f)))
    741     (let loop ((k 0) (Lst Lst))
    742       (cond
    743         ((Null? Lst)
    744          vec)
    745         (else
    746           (vector-set! vec k (First Lst))
    747           (loop (+ k 1) (rest Lst)))))))
    748 
    749 (define (Split-at n Lst)
    750   (assume-in 'Split-at
    751     (Admissible? n Lst))
    752   (let loop ((n n) (head Nil) (tail Lst))
    753     (if (or (Null? tail) (zero? n))
    754       (values (Reverse head) tail)
    755       (loop (- n 1)
    756             (Cons (First tail) head)
    757             (Rest tail)))))
    758 
    759 (define (Split-with ok? Lst)
    760   (assume-in 'Split-with
    761     (procedure? ok?)
    762     (List-finite? Lst))
    763   (let loop ((head Nil) (index 0) (tail Lst))
    764     (if (or (Null? tail) (not (ok? (First tail))))
    765     ;(if (or (Null? tail) (ok? (First tail)))
    766       (values (Reverse head) index tail)
    767       (loop (Cons (First tail) head)
    768             (+ index 1)
    769             (Rest tail)))))
     815  (let* ((len (Length Lst)) (vec (make-vector len #f)))
     816    (do ((k 0 (fx+ k 1)) (Lst Lst (Rest Lst)))
     817      ((fx= k len) vec)
     818      (vector-set! vec k (First Lst)))))
    770819
    771820(define (Sieve =? Lst)
     
    773822    (procedure? =?)
    774823    (List? Lst))
    775   (let loop ((Lst Lst))
    776     (if (Null? Lst)
    777       Nil
    778       (let (
    779         (first (First Lst))
    780         (tail
    781           (Filter
    782             (lambda (x)
    783               (not (=? x (First Lst))))
    784             (Rest Lst)))
    785         )
    786         (if (lazy-list-length Lst)
    787           (Cons first (loop tail))
    788           (Lazy #f
    789             (cons first (loop tail))))))))
    790 
    791 (define (Fold-left op base . Lsts)
     824  (let ((finite? (lazy-list-finite? Lst)))
     825    (let loop ((Lst Lst))
     826      (Lazy finite?
     827        (if (Null? Lst)
     828          '()
     829          (let (
     830            (first (First Lst))
     831            (rest
     832              (Filter
     833                (lambda (x)
     834                  (not (=? x (First Lst))))
     835                (Rest Lst)))
     836            )
     837            (cons first (loop rest))))))))
     838
     839(define (Fold-left op base Lst . Lsts)
    792840  (assume-in 'Fold-left
    793841    (procedure? op)
    794     (apply Lists-one-finite? Lsts))
    795   (let loop ((base base)
    796              (Lsts Lsts)
    797              (len (apply Length-min Lsts)))
    798     (if (zero? len)
    799       base
    800       (loop (apply op base (map First Lsts))
    801             (map Rest Lsts)
    802             (fx- len 1)))))
    803 
    804 (define (Fold-right op base . Lsts)
     842    (List? Lst)
     843    (or (List-finite? Lst) (apply Lists-one-finite? Lsts)))
     844  (let* ((Lsts (cons Lst Lsts)) (len (apply Length-min Lsts)))
     845    (let loop ((Lsts Lsts) (k 0) (result base))
     846      (if (fx= k len)
     847        result
     848        (loop (map Cdr Lsts)
     849              (fx+ k 1)
     850              (apply op result (map Car Lsts)))))))
     851
     852(define (Fold-right op base Lst . Lsts)
    805853  (assume-in 'Fold-right
    806854    (procedure? op)
    807     (apply Lists-one-finite? Lsts))
    808   (let loop ((Lsts Lsts)
    809              (len (apply Length-min Lsts)))
    810     (if (zero? len)
    811       base
    812       (apply op
    813              (append (map First Lsts)
    814                      (list (loop (map Rest Lsts) (fx- len 1))))))))
     855    (List? Lst)
     856    (or (List-finite? Lst) (apply Lists-one-finite? Lsts)))
     857  (let* ((Lsts (cons Lst Lsts)) (len (apply Length-min Lsts)))
     858    (let loop ((Lsts Lsts) (len len))
     859      (if (fx= 0 len)
     860        base
     861        (apply op
     862               (append (map First Lsts)
     863                       (list (loop (map Rest Lsts) (fx- len 1)))))))))
    815864
    816865;;; The following two routines return Lists
    817 (define (Fold-left* op base . Lsts)
     866(define (Fold-left* op base Lst . Lsts)
    818867  (assume-in 'Fold-left*
    819868    (procedure? op)
     869    (List? Lst)
    820870    ((list-of? List?) Lsts))
    821   (letrec (
    822     (fold
    823       (Cons base
    824         (apply Map op
    825                    (Lazy (apply Length-min Lsts) fold)
    826                    Lsts)))
    827     )
    828     (Rest fold)))
    829 
    830 (define (Fold-right* op base . Lsts) ; changes order of List items
     871  (let* ((Lsts (cons Lst Lsts))
     872         (finite? (if (not (apply Length-min Lsts))
     873                    #f
     874                    #t)))
     875    (letrec (
     876      (fold
     877        (Lazy finite?
     878          (cons base
     879                (apply Map op
     880                       (Lazy finite? fold)
     881                       Lsts))))
     882      )
     883      (Rest fold))))
     884
     885(define (Fold-right* op base Lst . Lsts) ; changes order of List items
    831886  (assume-in 'Fold-right*
    832887    (procedure? op)
     888    (List? Lst)
    833889    ((list-of? List?) Lsts))
    834   (letrec (
    835     (fold
    836       (Cons base
    837         (apply Map op
    838                (append Lsts
    839                        (list
    840                          (Lazy (apply Length-min Lsts) fold))))))
    841     )
    842     (Rest fold)))
     890  (let* ((Lsts (cons Lst Lsts))
     891         (finite? (if (not (apply Length-min Lsts))
     892                    #f
     893                    #t)))
     894      (letrec (
     895        (fold
     896          (Lazy finite?
     897            (cons base
     898                  (apply Map op
     899                         (append Lsts
     900                                 (list
     901                                   (Lazy finite? fold)))))))
     902        )
     903        (Rest fold))))
    843904
    844905(define (Every? ok? Lst)
     
    869930
    870931(define (List-finite? xpr)
    871   (and (List? xpr) (if (Length xpr) #t #f)))
     932  (and (List? xpr) ; (if (Length xpr) #t #f)))
     933       (lazy-list-finite? xpr)))
    872934
    873935(define (List-infinite? xpr)
    874   (and (List? xpr) (if (Length xpr) #f #t)))
     936  (and (List? xpr) ;(if (Length xpr) #f #t)))
     937       (not (lazy-list-finite? xpr))))
    875938
    876939(define (Lists-one-finite? . Lsts)
     
    878941    (not (null? Lsts))
    879942    ((list-of? List?) Lsts))
    880   (if (apply Length-min Lsts) #t #f))
     943  ;(if (apply Length-min Lsts) #t #f))
     944  (not (null? (compress (map lazy-list-finite? Lsts)
     945                        Lsts))))
    881946
    882947;;; two examples
  • release/4/lazy-lists/tags/0.9/lazy-lists.setup

    r31803 r33876  
    88 'lazy-lists
    99 '("lazy-lists.so" "lazy-lists.import.so")
    10  '((version "0.8.1")))
     10 '((version "0.9")))
  • release/4/lazy-lists/tags/0.9/tests/run.scm

    r31797 r33876  
    1 (require-library lazy-lists simple-tests)
     1(require-library simple-tests lazy-lists)
    22(import lazy-lists simple-tests)
    33(register-feature! 'assumptions-checked)
     
    55(define-test (lazy-list)
    66  (check
    7     (define (cons-right var lst)
    8       (if (null? lst)
    9         (cons var lst)
    10         (cons (car lst) (cons-right var (cdr lst)))))
    117    (define (First-five) (List 0 1 2 3 4))
    128    (define (Fibs)
     
    2622    (= (Length (First-five)) 5)
    2723    (= (Length (Rest (First-five))) 4)
    28     (eq? (Length (Rest (Cardinals))) #f)
     24    (not (Length (Rest (Cardinals))))
    2925    (= (Length (Take 5 (Cardinals))) 5)
    30     (eq? (Length (Cardinals)) #f)
    31     (eq? (Length (Drop 5 (Cardinals))) #f)
     26    (not (Length (Cardinals)))
     27    (not (Length (Drop 5 (Cardinals))))
    3228    (= (First (Drop 5 (Cardinals))) 5)
    33     (equal? (List->list (First-five)) '(0 1 2 3 4))
    34     (equal? (List->list (Take 5 (Cardinals))) '(0 1 2 3 4))
     29    (Eqv? (First-five) (List 0 1 2 3 4))
     30    (Eqv? (Take 5 (Cardinals)) (List 0 1 2 3 4))
    3531    (= (Length (Range 2 10)) (- 10 2))
    3632    (= (Length (Range 10)) 10)
    3733    (= (Length (Range -1 10 2)) 6)
    38     (equal? (List->list (Range -1 10 2)) '(-1 1 3 5 7 9))
    39     (equal? (List->list (Range 2 10)) '(2 3 4 5 6 7 8 9))
    40     (equal? (List->list (Range 10 2)) '(10 9 8 7 6 5 4 3))
     34    (Eqv? (Range -1 10 2) (List -1 1 3 5 7 9))
     35    (Eqv? (Range 2 10) (List 2 3 4 5 6 7 8 9))
     36    (Eqv? (Range 10 2) (List 10 9 8 7 6 5 4 3))
     37    (Eqv? (Drop-while (cut < <> 3) (First-five))
     38          (List 3 4))
     39    (Eqv? (Take-while (cut < <> 3) (First-five))
     40          (List 0 1 2))
    4141    (equal?
    4242      (receive (head index tail) (Split-with (cut < <> 3) (First-five))
     
    4949    (= (Count-while (cut < <> 2) (First-five)) 2)
    5050    (= (Count-while (cut < <> 20) (First-five)) 5)
    51     (equal? (List->list (Take-while (cut < <> 5) (Take 10 (Cardinals))))
    52             '(0 1 2 3 4))
     51    (Eqv? (Take-while (cut < <> 5) (Take 10 (Cardinals)))
     52          (List 0 1 2 3 4))
    5353    (= (Length (Take-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
    5454    (= (Length (Drop-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     
    5656    (= (Length (Drop-while (cut < <> 2) (First-five))) 3)
    5757    (= (First (Drop-while (cut < <> 2) (First-five))) 2)
    58     (equal? (List->list (Memp odd? (First-five))) '(1 2 3 4))
    59     (equal? (List->list (Memv 5 (Take 10 (Cardinals)))) '(5 6 7 8 9))
     58    (Eqv? (Memp odd? (First-five)) (List 1 2 3 4))
     59    (Eqv? (Memv 5 (Take 10 (Cardinals))) (List 5 6 7 8 9))
    6060    (equal? (Assv 5 (Take 10 (Map (lambda (x) (list x x)) (Cardinals))))
    6161            '(5 5))
    62     (eq? (Assv 10 (Map (lambda (x) (list x x)) (First-five))) #f)
    63     (eq? (Equal? (Cardinals) (Cardinals)) #f)
    64     (eq? (Equal? (Cardinals) (First-five)) #f)
    65     (eq? (Equal? (First-five) (First-five)) #t)
     62    (not (Assv 10 (Map (lambda (x) (list x x)) (First-five))))
     63    (not (Equal? (Cardinals) (Cardinals)))
     64    (let ((Card (Cardinals)))
     65      (Equal? Card Card))
     66    (not (Equal? (Cardinals) (First-five)))
     67    (Equal? (First-five) (First-five))
    6668    (= (Length (Take 10 (Cardinals))) 10)
    67     (equal? (List->list (Take 5 (Filter odd? (Drop 1 (Cardinals)))))
    68             '(1 3 5 7 9))
     69    (Eqv? (Take 5 (Filter odd? (Drop 1 (Cardinals))))
     70          (List 1 3 5 7 9))
    6971    (Eqv? (Remp odd? (First-five)) (List 0 2 4))
    7072    (Eqv? (Take 5 (Remp odd? (Cardinals)))
    7173          (Take 5 (Map (cut * <> 2) (Cardinals))))
    7274    (Eqv? (Remv 3 (First-five)) (List 0 1 2 4))
    73     (eq? (Length (Cardinals)) #f)
    74     (equal? (List->list (Map add1 (First-five))) '(1 2 3 4 5))
    75     (equal? (List->list (Map + (First-five) (Take 5 (Cardinals))))
    76             '(0 2 4 6 8))
    77     (eq? (Length (Map + (Cardinals) (Cardinals))) #f)
     75    (not (Length (Cardinals)))
     76    (Eqv? (Map add1 (First-five)) (List 1 2 3 4 5))
     77    (Eqv? (Map + (First-five) (Take 5 (Cardinals)))
     78          (List 0 2 4 6 8))
     79    (not (Length (Map + (Cardinals) (Cardinals))))
    7880    (For-each (lambda (x y) (print "### " x " " y)) (Cardinals) (First-five))
    7981    (= (Length (Filter odd? (First-five))) 2)
    80     (equal? (List->list (Filter odd? (First-five))) '(1 3))
    81     (eq? (Length (Filter odd? (Cardinals))) #f)
    82     (= (Ref 20 (Sieve = (Zip (Cardinals) (Cardinals)))) 20)
    83     (equal? (List->list (Sieve = (Zip (First-five) (First-five))))
    84             '(0 1 2 3 4))
    85     (= (Ref 25 (Cardinals)) 25)
    86     (= (Ref 2 (First-five)) 2)
    87     (equal? (List->list (Repeat 3 #f)) '(#f #f #f))
     82    (Eqv? (Filter odd? (First-five)) (List 1 3))
     83    (not (Length (Filter odd? (Cardinals))))
     84    (Eqv? (Take 10 (Zip (First-five) (Cardinals)))
     85          (List 0 0 1 1 2 2 3 3 4 4))
     86    (not (Length (Zip (First-five) (Cardinals))))
     87    (= (At 20 (Sieve = (Zip (Cardinals) (Cardinals)))) 20)
     88    (Eqv? (Sieve = (Zip (First-five) (First-five)))
     89          (List 0 1 2 3 4))
     90    (= (At 25 (Cardinals)) 25)
     91    (= (At 2 (First-five)) 2)
     92    (Eq? (Repeat #f 3) (List #f #f #f))
    8893    (List-infinite? (Repeatedly (lambda () 1)))
    89     (equal? (List->list (Repeatedly 3 (lambda () 1)))
    90             '(1 1 1))
     94    (Eqv? (Repeatedly (lambda () 1) 3)
     95          (List 1 1 1))
    9196    (List-infinite? (Iterate add1 0))
    92     (List-finite? (Iterate 3 add1 0))
    93     (equal? (List->list (Iterate 3 add1 0)) '(0 1 2))
    94     (eq? (Length (Iterate add1 0)) #f)
    95     (equal? (List->list (Cycle 10 (First-five)))
    96             '(0 1 2 3 4 0 1 2 3 4))
    97     (eq? (Length (Cycle (First-five))) #f)
     97    (List-finite? (Iterate add1 0 3))
     98    (Eqv? (Iterate add1 0 3) (List 0 1 2))
     99    (not (Length (Iterate add1 0)))
     100    (Eqv? (Cycle 10 (First-five))
     101          (List 0 1 2 3 4 0 1 2 3 4))
     102    (not (Length (Cycle (First-five))))
    98103    (= (Length (Append (First-five) (First-five))) 10)
    99104    (not (Length (Append (Cardinals) (First-five))))
    100     (equal? (List->list  (Append (First-five) (First-five)))
    101             '(0 1 2 3 4 0 1 2 3 4))
    102     (equal? (List->list (Take 12 (Append (First-five) (Cardinals))))
    103             '(0 1 2 3 4 0 1 2 3 4 5 6))
    104     (eq? (Length (Append (First-five) (Cardinals))) #f)
    105     (equal? (List->list (Reverse (First-five))) '(4 3 2 1 0))
    106     (equal? (List->list (Reverse (Take 5 (Cardinals)))) '(4 3 2 1 0))
     105    (Eqv? (Append (First-five) (First-five))
     106          (List 0 1 2 3 4 0 1 2 3 4))
     107    (Eqv? (Take 12 (Append (First-five) (Cardinals)))
     108          (List 0 1 2 3 4 0 1 2 3 4 5 6))
     109    (not (Length (Append (First-five) (Cardinals))))
     110    (List-finite? (Reverse (First-five)))
     111    (List-finite? Nil)
     112    (zero? (Length Nil))
     113    (Equ? = (Reverse (First-five)) (List 4 3 2 1 0))
     114    (Equ? = (Reverse (Take 5 (Cardinals))) (List 4 3 2 1 0))
     115    (= (Length (List 0 1 2 3 4)) 5)
    107116    (= (Length (Reverse (First-five))) 5)
    108     (eq? (Length (Reverse* (Cardinals))) #f)
    109     (equal? (List->list (Ref 5 (Reverse* (Cardinals)))) '(5 4 3 2 1 0))
    110     (equal? (List->list (Sort < (First-five))) '(0 1 2 3 4))
     117    (not (Length (Reverse* (Cardinals))))
     118    (Equal? (At 5 (Reverse* (Cardinals))) (List 5 4 3 2 1 0))
     119    (Equal? (At 4 (Reverse* (First-five))) (List 4 3 2 1 0))
    111120    (Sorted? < (First-five))
    112121    (not (Sorted? < (Append (First-five) (First-five))))
     122    (Equal? (Sort < (First-five)) (List 0 1 2 3 4))
    113123    (= (Length (Sort < (First-five))) 5)
    114     (equal? (List->list (Sort < (List 3 1 0 2 4))) '(0 1 2 3 4))
     124    (Equal? (Sort < (List 3 1 0 2 4)) (List 0 1 2 3 4))
    115125    (equal?
    116126      (receive (head tail) (Split-at 5 (Cardinals))
    117127        (cons (First tail) (List->list head)))
    118128      '(5 0 1 2 3 4))
    119     (equal?
    120       (receive (head tail) (Split-at 15 (Take 5 (Cardinals)))
    121         (append (List->list tail) (List->list head)))
    122       '(0 1 2 3 4))
    123129    "FOLDS"
     130    (define (cons-right var lst)
     131      (if (null? lst)
     132        (cons var lst)
     133        (cons (car lst) (cons-right var (cdr lst)))))
     134    (equal? (cons-right 10 '(0 1 2 3)) '(0 1 2 3 10))
    124135    (= (Fold-left + 0 (Take 5 (Cardinals))) 10)
    125136    (= (Fold-left + 0 (First-five) (First-five)) 20)
     
    127138    (equal? (Fold-left cons '() (Take 5 (Cardinals)))
    128139            '(((((() . 0) . 1) . 2) . 3) . 4))
    129     (equal? (Ref 4 (Fold-left* cons '() (Cardinals)))
     140    (equal? (At 4 (Fold-left* cons '() (Cardinals)))
    130141            '(((((() . 0) . 1) . 2) . 3) . 4))
    131142    (= (Fold-right + 0 (Take 5 (Cardinals))) 10)
    132143    (= (Fold-right + 0 (First-five) (First-five)) 20)
    133144    (equal? (Fold-right cons '() (First-five))
    134             '(0 1 2 3 4)) ; list
     145            '(0 1 2 3 4))
    135146    (equal? (Fold-right cons '(a b c) (First-five))
    136147            '(0 1 2 3 4 a b c)) ; append
    137     (equal? (Ref 4 (Fold-right* cons '() (Cardinals)))
     148    (equal? (At 4 (Fold-right* cons '() (Cardinals)))
    138149            '(4 3 2 1 0)) ; note changed order
    139     (equal? (Ref 4 (Fold-right* cons-right '() (Cardinals)))
     150    (equal? (At 4 (Fold-right* cons-right '() (Cardinals)))
    140151            '(0 1 2 3 4))
    141     (equal? (Ref 4 (Fold-right* cons '(a b c) (Cardinals)))
     152    (equal? (At 4 (Fold-right* cons '(a b c) (Cardinals)))
    142153            '(4 3 2 1 0 a b c)) ; note changed order
    143     (equal? (Ref 4 (Fold-right* cons-right '(a b c) (Cardinals)))
     154    (equal? (At 4 (Fold-right* cons-right '(a b c) (Cardinals)))
    144155            '(a b c 0 1 2 3 4))
    145156    "TRANSFORMATIONS"
    146     (equal? (List->list (vector->List '#(0 1 2 3 4))) '(0 1 2 3 4))
    147     (Null? (vector->List '#()))
    148     (equal? (List->vector (Take 5 (Cardinals))) '#(0 1 2 3 4))
    149     (equal? (List->vector (First-five)) '#(0 1 2 3 4))
     157    (Equal? (vector->List #(0 1 2 3 4)) (List 0 1 2 3 4))
     158    (Null? (vector->List #()))
     159    (equal? (List->vector (Take 5 (Cardinals))) #(0 1 2 3 4))
     160    (equal? (List->vector (First-five)) #(0 1 2 3 4))
    150161    (equal? (List->vector Nil) '#())
    151     (eq? (Every? odd? (Take 15 (Filter odd? (Cardinals)))) #t)
    152     (eq? (Every? odd? (Take 15 (Cardinals))) #f)
    153     (eq? (Every? odd? Nil) #t)
    154     (eq? (Some? odd? Nil) #f)
    155     (eq? (Some? odd? (Take 5 (Filter even? (Cardinals)))) #f)
    156     (eq? (Some? odd? (First-five)) #t)
     162    (Every? odd? (Take 15 (Filter odd? (Cardinals))))
     163    (not (Every? odd? (Take 15 (Cardinals))))
     164    (Every? odd? Nil)
     165    (not (Some? odd? Nil))
     166    (not (Some? odd? (Take 5 (Filter even? (Cardinals)))))
     167    (Some? odd? (First-five))
    157168    "ZIP AND UNZIP"
    158     (eq? (Length (Zip (Cardinals) (First-five))) #f)
    159     (eq? (Length (Zip (First-five) (Cardinals))) #f)
    160     (eq? (Length (Zip (Cardinals) (Cardinals))) #f)
     169    (not (Length (Zip (Cardinals) (First-five))))
     170    (not (Length (Zip (First-five) (Cardinals))))
     171    (not (Length (Zip (Cardinals) (Cardinals))))
    161172    (= (Length (Zip (First-five) (First-five))) 10)
    162173    (Eqv? (Take 14 (Zip (Cardinals) (First-five)))
     
    170181           (Eqv? (Take 5 Odds) (List 1 3 5 7 9))))
    171182    "PRIMES AND FIBS"
    172     (= (Ref 50 (Primes)) 233)
     183    (= (At 50 (Primes)) 233)
    173184    (Eqv? (Take 5 (Primes)) (List 2 3 5 7 11))
    174185    (Eqv? (Take 10 (Fibs)) (List  0 1 1 2 3 5 8 13 21 34))
    175186    "LIST OF SUMS"
    176187    (define (Sums Lst)
    177       (letrec ((sums (Cons 0 (Map + Lst (Lazy (Length Lst) sums)))))
    178         (Rest sums)))
    179     (equal? (List->list (Sums (First-five))) '(0 1 3 6 10))
     188      (let loop ((n 1))
     189        (Lazy #f (cons (apply + (List->list (Take n Lst)))
     190                       (loop (fx+ n 1))))))
     191    (Eqv? (Take 5 (Sums (Cardinals))) (List 0 1 3 6 10))
    180192    "COMPUTE SQUARE ROOT BY NEWTON'S METHOD"
    181193    (define (Within eps Lst)
    182194      (let loop ((Lst Lst))
    183         (let ((a (Ref 0 Lst)) (b (Ref 1 Lst)))
     195        (let ((a (At 0 Lst)) (b (At 1 Lst)))
    184196          (if (< (abs (- a b)) eps)
    185197            b
     
    187199    (define (Relative eps Lst)
    188200      (let loop ((Lst Lst))
    189         (let ((a (Ref 0 Lst)) (b (Ref 1 Lst)))
     201        (let ((a (At 0 Lst)) (b (At 1 Lst)))
    190202          (if (<= (abs (/ a b)) (* (abs b) eps))
    191203            b
     
    201213    (not (List-finite? Integers))
    202214    (not (Realized? Integers))
    203     (= (Ref 5 Integers) 6)
     215    (= (At 5 Integers) 6)
    204216    (Realized? Integers)
    205217    ))
  • release/4/lazy-lists/trunk/lazy-lists.scm

    r31803 r33876  
    22; ju (at) jugilo (dot) de
    33;
    4 ; Copyright (c) 2012-2014, Juergen Lorenz, Moritz Heidkamp
     4; Copyright (c) 2012-2017, Juergen Lorenz
    55; All rights reserved.
    66;
     
    3131; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    3232; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    33 ;
    34 ; Last update: Nor 09, 2014
    35 ;
     33
     34#|[
     35The lazy-list implementation of this module is inspired by Moritz
     36Heidkamp's lazy-seq egg. It's not based on the Scheme primitives delay
     37and force, but uses a record type instead. I've added an additional slot
     38to this record-type, a boolean, finite?, so that it is possible to
     39discriminate between finite and infinite lazy lists without realizing
     40the whole record. After all, some routines, reverse for example, make
     41only sense for finite lists. Moreover, the names of all exported
     42routines are capitalized, so that I could reuse the familiar names of
     43eager lists without fear of name clashes.
     44I followed a consistent argument order, at least in principle: List
     45arguments are always last, procedure arguments always first. Some well
     46known list primitives, List-ref and List-tail, with wrong argument
     47order, are still there, but accompanied by At and Drop with the right
     48order.
     49]|#
     50
    3651(module lazy-lists
    37   (lazy-lists Lazy assume-in Make-lazy
     52  (lazy-lists assume-in Lazy Make-lazy
    3853   List->list list->List input->List
    3954   First Rest Car Cdr Length Length-min Append Reverse
     
    4156   List-infinite? Realize
    4257   List-not-null? List-finite? Lists-one-finite?
    43    Take Drop Ref Take-while Drop-while Count-while
     58   At Ref List-ref List-tail
     59   Take Drop Take-while Drop-while Count-while
    4460   Memp Member Memq Memv
    4561   Equ? Equal? Eq? Eqv?
     
    5773        (only data-structures o compress list-of?)
    5874        (only chicken
    59               cond-expand
    6075              define-record-type
    6176              define-record-printer
    62               cut when case-lambda
    63               nth-value unless receive
    64               make-parameter error void add1 sub1
    65               fixnum? fx+ fx= fx>= fx< fx- fx/))
    66 
     77              define-reader-ctor
     78              cut case-lambda
     79              unless receive
     80              make-parameter error void
     81              fixnum? fx+ fx= fx>= fx< fx> fx- fx/ fxshr))
     82
     83;; documentation procedure
    6784(define lazy-lists
    6885  (let (
    6986    (signatures '(
    70       (Lazy len xpr . xprs)
    7187      (assume-in sym test . tests)
    72       (Make-lazy len thunk)
     88      (Lazy finite? xpr . xprs)
     89      (Make-lazy finite? thunk)
    7390      (List->list Lst-finite)
    7491      (list->List lst)
     
    103120      (Take k Lst)
    104121      (Drop k Lst)
     122      (List-tail Lst k)
    105123      (Ref k Lst)
     124      (List-ref Lst k)
     125      (At k Lst)
    106126      (Take-while ok? Lst)
    107127      (Drop-while ok? Lst)
     
    126146      (Map fn . Lsts)
    127147      (For-each proc . Lsts)
    128       (Iterate [n] fn x)
    129       (Repeat [n] x)
    130       (Repeatedly [n] thunk)
    131       (Cycle [n] Lst)
     148      (Iterate fn x [times])
     149      (Repeat x [times])
     150      (Repeatedly thunk [times])
     151      (Cycle [times] Lst)
    132152      (Range [from] upto [step])
    133153      (Cardinals)
     
    136156      (Merge <? Lst-finite1 Lst-finite2)
    137157      (Sorted? <? Lst-finite)
    138       (Fold-right op base . Lsts-one-finite)
    139       (Fold-left op base . Lists-one-finite)
    140       (Fold-right* op base . Lsts)
    141       (Fold-left* op base . Lsts)
     158      (Fold-right op base Lst . Lsts)
     159      (Fold-left op base Lst . Lsts)
     160      (Fold-right* op base Lst . Lsts)
     161      (Fold-left* op base Lst . Lsts)
    142162      (Zip Lst1 Lst2)
    143163      (Unzip Lst)
     
    179199(define lazy-list
    180200  (define-record-type lazy-list
    181     (make-lazy-list length body value)
     201    (make-lazy-list finite? body value)
    182202    lazy-list?
    183     (length lazy-list-length lazy-list-length-set!)
     203    (finite? lazy-list-finite?)
    184204    (body lazy-list-body lazy-list-body-set!)
    185205    (value lazy-list-value lazy-list-value-set!)))
     
    187207(define-syntax Lazy
    188208  (syntax-rules ()
    189     ((_ len xpr . xprs)
    190      (Make-lazy len (lambda () xpr . xprs)))))
    191 
    192 
    193 (define (Make-lazy len thunk)
    194   (make-lazy-list len thunk #f))
     209    ((_ finite? xpr . xprs)
     210     (Make-lazy finite? (lambda () xpr . xprs)))))
     211
     212
     213(define (Make-lazy finite? thunk)
     214  (make-lazy-list finite? thunk #f))
    195215
    196216(define (Cons var Lst)
    197217  (assume-in 'Cons
    198218    (List? Lst))
    199   (let ((len (lazy-list-length Lst)))
    200     (Lazy (if len (+ 1 len) #f)
     219  (let ((finite? (lazy-list-finite? Lst)))
     220    (Lazy finite?
    201221      (cons var Lst))))
    202222
    203 (define Length lazy-list-length)
     223(define (Length Lst)
     224  (assume-in 'Length
     225    (List? Lst))
     226  (if (lazy-list-finite? Lst)
     227    (let loop ((Lst Lst) (result 0))
     228      (if (Null? Lst)
     229        result
     230        (loop (Rest Lst) (fx+ 1 result))))
     231    #f))
    204232
    205233(define (Length-min . Lsts)
    206234  (assume-in 'Length-min
    207235    ((list-of? List?) Lsts))
    208   (let* ((lens (map Length Lsts))
    209          (finites (compress lens lens)))
    210     (if (null? finites)
     236  (let ((Finites (compress (map lazy-list-finite? Lsts)
     237                            Lsts)))
     238    (if (null? Finites)
    211239      #f
    212       (apply min finites))))
     240      (apply min (map Length Finites)))))
    213241
    214242(define List? lazy-list?)
    215243
    216244(define Nil
    217   (make-lazy-list 0 (lambda () '()) #f))
     245  (make-lazy-list #t (lambda () '()) #f))
    218246
    219247(define-record-printer (lazy-list Lst out)
    220248  (assume-in 'define-record-printer
    221249    (List? Lst))
    222   (display "#(List[" out)
    223   (display (lazy-list-length Lst) out)
     250  (display "#,(List[" out)
     251  (display (if (lazy-list-finite? Lst)
     252             "finite"
     253             "infinite") out)
     254  ;(display (lazy-list-finite? Lst) out)
    224255  (display "]" out)
    225256  (cond ((not (Realized? Lst))
     
    254285  (assume-in 'Realize
    255286    (List-finite? Lst))
    256   (let ((len (lazy-list-length Lst)))
    257     (when len
    258       (Ref (- len 1) Lst)
    259       Lst)))
     287  ;(let ((len (Length Lst)))
     288  ;  (when len
     289  ;    (At (fx- len 1) Lst)
     290  ;    Lst)))
     291  (At (fx- (Length Lst) 1) Lst)
     292  Lst)
    260293 
    261294(define (Realized? Lst)
     
    273306  (car (realize Lst)))
    274307
    275 (define (Car Lst)
    276   (assume-in 'Car
    277     (List? Lst))
    278   (First Lst))
    279 
    280 ;; to speed up cdring for lists with preknown length
    281 (define (rest Lst)
    282   (assume-in 'rest (List? Lst))
    283   (cdr (realize Lst)))
     308(define Car First)
    284309
    285310(define (Rest Lst)
    286311  (assume-in 'Rest (List? Lst))
    287   (let (
    288     (len (lazy-list-length Lst))
    289     (Result (cdr (realize Lst)))
    290     )
    291     (lazy-list-length-set! Result (if len (fx- len 1) #f))
    292     Result))
    293 
    294 (define (Cdr Lst)
    295   (assume-in 'Cdr (List? Lst))
    296   (Rest Lst))
    297 
     312  (cdr (realize Lst)))
     313
     314(define Cdr Rest)
     315
     316;; deprecated
     317;; makes finite Lists eager!!!
     318;; and if checked traverses Lists twice
    298319(define (Admissible? n Lst)
    299320  (assume-in 'Admissible?
     
    301322    (fixnum? n)
    302323    (fx>= n 0))
    303   (let ((len (lazy-list-length Lst)))
     324  (let ((len (Length Lst)));(lazy-list-length Lst)))
    304325    (or (not len) (fx< n len))))
    305326 
    306 (define (Ref n Lst)
    307   (assume-in 'Ref
    308     (Admissible? n Lst))
    309   (let ((len (lazy-list-length Lst)))
    310     (let loop ((n n) (Lst Lst))
    311       (if (fx= n 0)
    312         (First Lst)
    313         (loop (fx- n 1) (Rest Lst))))))
     327(define (At k Lst)
     328  (assume-in 'At
     329    (List? Lst) (fx>= k 0))
     330  (cond
     331    ((Null? Lst)
     332     (error 'At "out of range" k Lst))
     333    ((fx= 0 k)
     334     (First Lst))
     335    (else
     336     (At (fx- k 1) (Rest Lst)))))
     337
     338;; deprecated
     339(define Ref At)
     340
     341(define (List-ref Lst k)
     342  (At k Lst))
    314343
    315344(define (List->list Lst)
     
    328357    (if (null? lst)
    329358      Lst
    330       (loop (cdr lst) (Cons (car lst) Lst)))))
     359      (loop (cdr lst)
     360            (Lazy #t (cons (car lst) Lst))))))
    331361
    332362(define (List . args)
    333363  (list->List args))
    334364
     365(define-reader-ctor 'List List)
     366
     367;; Drop and Take as well as Split-at now check n parameter
    335368(define (Take n Lst)
    336369  (assume-in 'Take
     
    338371    (fixnum? n)
    339372    (fx>= n 0))
    340   (call-with-values
    341     (lambda () (Split-at n Lst))
    342     (lambda (a b) a)))
    343 
     373  (if (and (Null? Lst) (fx> n 0))
     374    (error 'Take "out of bounds" Lst n)
     375    (Lazy #t
     376      (if (or (fx= n 0) (Null? Lst))
     377        '()
     378        (cons
     379          (First Lst)
     380          (Take (fx- n 1) (Rest Lst)))))))
     381   
    344382(define (Drop n Lst)
    345383  (assume-in 'Drop
    346     (Admissible? n Lst))
    347   (call-with-values
    348     (lambda () (Split-at n Lst))
    349     (lambda (a b) b)))
     384    (List? Lst)
     385    (fixnum? n)
     386    (fx>= n 0))
     387  (cond
     388    ((and (Null? Lst) (fx> n 0))
     389     (error 'Drop "out of bounds" Lst n))
     390    ((or (zero? n) (Null? Lst))
     391     Lst)
     392    (else
     393      (Drop (fx- n 1) (Rest Lst)))))
     394
     395(define (List-tail Lst n)
     396  (Drop n Lst))
     397
     398(define (Split-at n Lst)
     399  (values (Take n Lst) (Drop n Lst)))
    350400
    351401(define (Take-while ok? Lst)
     
    353403    (List-finite? Lst)
    354404    (procedure? ok?))
    355   (nth-value 0 (Split-with ok? Lst)))
     405  (let ((finite? (lazy-list-finite? Lst)))
     406    (let loop ((Lst Lst))
     407      (Lazy finite?
     408        (cond
     409          ((Null? Lst)
     410           '())
     411          ((ok? (First Lst))
     412           (cons (First Lst) (loop (Rest Lst))))
     413          (else '()))))))
     414;  (Lazy (lazy-list-finite? Lst)
     415;    (let loop ((Lst Lst))
     416;      (cond
     417;        ((Null? Lst)
     418;         '())
     419;        ((ok? (First Lst))
     420;         (cons (First Lst) (loop (Rest Lst))))
     421;        (else '())))))
    356422
    357423(define (Count-while ok? Lst)
     
    359425    (List-finite? Lst)
    360426    (procedure? ok?))
    361   (nth-value 1 (Split-with ok? Lst)))
     427  (let loop ((Lst Lst) (index 0))
     428    (cond
     429      ((Null? Lst)
     430       index)
     431      ((ok? (First Lst))
     432       (loop (Rest Lst) (fx+ index 1)))
     433      (else index))))
    362434
    363435(define (Drop-while ok? Lst)
     
    365437    (List-finite? Lst)
    366438    (procedure? ok?))
    367   (nth-value 2 (Split-with ok? Lst)))
     439  (let ((finite? (lazy-list-finite? Lst)))
     440    (let loop ((Lst Lst))
     441      (Lazy finite?
     442        (cond
     443          ((Null? Lst)
     444           '())
     445          ((ok? (First Lst))
     446           (loop (Rest Lst)))
     447          (else Lst))))))
     448
     449(define (Split-with ok? Lst)
     450  (values (Take-while ok? Lst)
     451          (Count-while ok? Lst)
     452          (Drop-while ok? Lst)))
    368453
    369454(define (Memp ok? Lst)
     
    374459
    375460(define (Memq var Lst)
    376   (assume-in 'Memq
    377     (List-finite? Lst))
     461  ;(assume-in 'Memq
     462  ;  (List-finite? Lst))
    378463  (Memp (cut eq? <> var) Lst))
    379464
    380465(define (Memv var Lst)
    381   (assume-in 'Memv
    382     (List-finite? Lst))
     466  ;(assume-in 'Memv
     467  ;  (List-finite? Lst))
    383468  (Memp (cut eqv? <> var) Lst))
    384469
    385470(define (Member var Lst)
    386   (assume-in 'Member
    387     (List-finite? Lst))
     471  ;(assume-in 'Member
     472  ;  (List-finite? Lst))
    388473  (Memp (cut equal? <> var) Lst))
    389474
     
    393478    (List? Lst1)
    394479    (List? Lst2))
    395   (if (eqv? (lazy-list-length Lst1) (lazy-list-length Lst2))
    396     (if (lazy-list-length Lst1)
    397       ;; both finite
    398       (let loop ((Lst1 Lst1) (Lst2 Lst2))
    399         (cond
    400           ((Null? Lst1) #t)
    401           ((=? (First Lst1) (First Lst2))
    402            (loop (Rest Lst1) (Rest Lst2)))))
    403       ;; both infinite
    404       (eq? Lst1 Lst2))
    405     #f))
     480  (cond
     481    ((and (List-finite? Lst1) (List-finite? Lst2))
     482     (let loop ((Lst1 Lst1) (Lst2 Lst2))
     483       (cond
     484         ((and (Null? Lst1) (Null? Lst2))
     485          #t)
     486         ((=? (First Lst1) (First Lst2))
     487          (loop (Rest Lst1) (Rest Lst2)))
     488         (else #f))))
     489    ((and (List-infinite? Lst1) (List-infinite? Lst2))
     490     (eq? Lst1 Lst2))
     491    (else #f)))
    406492
    407493(define (Eq? Lst1 Lst2)
    408   (assume-in 'Eq?
    409     (List? Lst1)
    410     (List? Lst2))
     494  ;(assume-in 'Eq?
     495  ;  (List? Lst1)
     496  ;  (List? Lst2))
    411497  (Equ? eq? Lst1 Lst2))
    412498
    413499(define (Eqv? Lst1 Lst2)
    414   (assume-in 'Eqv?
    415     (List? Lst1)
    416     (List? Lst2))
     500  ;(assume-in 'Eqv?
     501  ;  (List? Lst1)
     502  ;  (List? Lst2))
    417503  (Equ? eqv? Lst1 Lst2))
    418504
    419505(define (Equal? Lst1 Lst2)
    420   (assume-in 'Equal?
    421     (List? Lst1)
    422     (List? Lst2))
     506  ;(assume-in 'Equal?
     507  ;  (List? Lst1)
     508  ;  (List? Lst2))
    423509  (Equ? equal? Lst1 Lst2))
    424510
     
    433519
    434520(define (Assq key al)
    435   (assume-in 'Assq
    436     (symbol? key)
    437     ((list-of? pair?) al))
     521  ;(assume-in 'Assq
     522  ;  ((list-of? pair?) al))
    438523  (Assp (cut eq? <> key) al))
    439524
    440525(define (Assv key al)
    441   (assume-in 'Assv
    442     ((list-of? pair?) al))
     526  ;(assume-in 'Assv
     527  ;  ((list-of? pair?) al))
    443528  (Assp (cut eqv? <> key) al))
    444529
    445530(define (Assoc key al)
    446   (assume-in 'Assoc
    447     ((list-of? pair?) al))
     531  ;(assume-in 'Assoc
     532  ;  ((list-of? pair?) al))
    448533  (Assp (cut equal? <> key) al))
    449534
     
    463548  (if (null? Lsts)
    464549    Nil
    465     (let loop ((Lsts Lsts))
    466       (Lazy (apply Length-min Lsts)
    467         (if (memp Null? Lsts)
    468           '()
    469           (cons (apply proc (map Car Lsts))
    470                 (loop (map Cdr Lsts))))))))
     550    (let ((finite? (if (not (apply Length-min Lsts)) #f #t)))
     551      (let loop ((Lsts Lsts))
     552        (Lazy finite?
     553          (if (memp Null? Lsts)
     554            '()
     555            (cons (apply proc (map Car Lsts))
     556                  (loop (map Cdr Lsts)))))))))
    471557
    472558(define (For-each proc . Lsts)
     
    485571    (List? Lst))
    486572  (let ((ev? #f))
    487     (let loop ((Lst Lst))
    488       (cond
    489         ((Null? Lst)
    490          (values Nil Nil))
    491         (else
    492           (set! ev? (not ev?))
    493           (if (lazy-list-length Lst)
    494             ;; compute new length via Cons
     573    (let ((finite? (lazy-list-finite? Lst)))
     574      (let loop ((Lst Lst))
     575        (cond
     576          ((Null? Lst)
     577           (values Nil Nil))
     578          (else
     579            (set! ev? (not ev?))
    495580            (if ev?
    496               (values (Cons (First Lst) (loop (Rest Lst)))
    497                       (loop (Rest Lst)))
    498               (values (loop (Rest Lst))
    499                       (Cons (First Lst) (loop (Rest Lst)))))
    500             ;; set new length #f
    501             (if ev?
    502               (values (Lazy #f (cons (First Lst) (loop (rest Lst))))
    503                       (Lazy #f (loop (rest Lst))))
    504               (values (Lazy #f (loop (rest Lst)))
    505                       (Lazy #f (cons (First Lst) (loop (rest Lst))))))))))))
     581              (values (Lazy finite?
     582                        (cons (First Lst) (loop (Rest Lst))))
     583                      (Lazy finite?
     584                        (loop (Rest Lst))))
     585              (values (Lazy finite?
     586                        (loop (Rest Lst)))
     587                      (Lazy finite?
     588                        (cons (First Lst) (loop (Rest Lst))))))))))))
    506589   
    507590(define (Zip Lst1 Lst2)
     
    509592    (List? Lst1)
    510593    (List? Lst2))
    511   (if (Null? Lst1)
    512     Lst2
    513     (if (and (lazy-list-length Lst1) (lazy-list-length Lst2))
    514       ;; both finite, compute new length with Cons
    515       (Cons (First Lst1) (Zip Lst2 (Rest Lst1)))
    516       ;; new length infinite
    517       (Lazy #f
    518         (cons (First Lst1) (Zip Lst2 (Rest Lst1)))))))
     594  (let ((both-finite?
     595          (and (lazy-list-finite? Lst1)
     596               (lazy-list-finite? Lst2))))
     597    (let loop ((Lst1 Lst1) (Lst2 Lst2))
     598      (if (Null? Lst1)
     599        Lst2
     600        (Lazy both-finite?
     601          (cons (First Lst1) (loop Lst2 (Rest Lst1))))))))
    519602
    520603(define (Filter ok? Lst)
    521604  (assume-in 'Filter
    522     (List? Lst))
    523   (let loop ((Lst Lst))
    524     (if (Null? Lst)
    525       Nil
    526       (let ((first (First Lst))
    527             (Result (if (lazy-list-length Lst)
    528                       (loop (Rest Lst))
    529                       (Lazy #f (loop (rest Lst))))))
    530         (if (ok? first)
    531           (Cons first Result)
    532           Result)))))
    533 ;  (if (Null? Lst)
    534 ;    (values Nil Nil)
    535 ;    (let ((first (First Lst)))
    536 ;      (if (lazy-list-length Lst)
    537 ;        (receive (Yes No) (Filter ok? (Rest Lst))
    538 ;          (if (ok? first)
    539 ;            (values (Cons first Yes) No)
    540 ;            (values Yes (Cons first No))))
    541 ;        (let ((yes (Lazy #f (Filter ok? (rest Lst))))
    542 ;              (no (Lazy #f (Filter (o not ok?) (rest Lst)))))
    543 ;        ;(receive (yes no) (Filter ok? (rest Lst)) ; wrong
    544 ;          (if (ok? first)
    545 ;            (values (Cons first yes) no)
    546 ;            (values yes (Cons first no))))))))
     605    (List? Lst)
     606    (procedure? ok?))
     607    (let ((finite? (lazy-list-finite? Lst)))
     608      (let loop ((Lst Lst))
     609        (Lazy finite?
     610          (if (Null? Lst)
     611            '()
     612            (let ((first (First Lst)) (rest (Rest Lst)))
     613              (if (ok? first)
     614                (cons first (loop rest))
     615                (loop rest))))))))
    547616
    548617(define (Remp ok? Lst)
     
    560629(define (input->List port read)
    561630  (let loop ()
    562     ;(Lazy #f
     631    (Lazy #f
    563632      (let ((datum (read port)))
    564633        (if (eof-object? datum)
    565             Nil
    566             (Cons datum (loop))))));)
     634            '()
     635            (cons datum (loop)))))))
    567636
    568637(define Repeat
    569638  (case-lambda
    570639    ((x) (Lazy #f (cons x (Repeat x))))
    571     ((n x)
     640    ((x times)
    572641     (assume-in 'Repeat
    573        (fixnum? n)
    574        (fx>= n 0))
    575      (Take n (Repeat x)))))
     642       (fixnum? times)
     643       (fx>= times 0))
     644     (Take times (Repeat x)))))
    576645
    577646(define Repeatedly
     
    581650       (procedure? thunk))
    582651     (Lazy #f (cons (thunk) (Repeatedly thunk))))
    583     ((n thunk)
     652    ((thunk times)
    584653     (assume-in 'Repeatedly
    585        (procedure? thunk)
    586        (fixnum? n)
    587        (fx>= n 0))
    588      (Take n (Repeatedly thunk)))))
     654       (fixnum? times)
     655       (fx>= times 0))
     656     (Take times (Repeatedly thunk)))))
    589657
    590658(define Iterate
    591659  (case-lambda
    592     ((f x)
     660    ((fn x)
    593661     (assume-in 'Iterate
    594        (procedure? f))
    595      (Lazy #f (cons x (Iterate f (f x)))))
    596     ((n f x)
     662       (procedure? fn))
     663     (Lazy #f (cons x (Iterate fn (fn x)))))
     664    ((fn x times)
    597665     (assume-in 'Iterate
    598        (procedure? f)
    599        (fixnum? n)
    600        (fx>= n 0))
    601      (Take n (Iterate f x)))))
     666       (fixnum? times)
     667       (fx>= times 0))
     668     (Take times (Iterate fn x)))))
    602669
    603670(define Cycle
     
    613680             (loop Lst)
    614681             (cons (First tail)
    615                    (loop (rest tail))))))))
     682                   (loop (Rest tail))))))))
    616683    ((n Lst)
    617684     (assume-in 'Cycle
    618        (List? Lst)
    619685       (fixnum? n)
    620686       (fx>= n 0))
     
    624690  (case-lambda
    625691    ((upto)
    626      (Iterate (abs upto)
    627               (if (fx>= upto 0)
     692     (Iterate (if (fx>= upto 0)
    628693                (cut fx+ <> 1)
    629694                (cut fx- <> 1))
    630               0))
     695              0
     696              (abs upto)))
    631697    ((from upto)
    632      (Iterate (abs (fx- upto from))
    633               (if (fx>= upto from)
     698     (Iterate (if (fx>= upto from)
    634699                      (cut fx+ <> 1)
    635700                      (cut fx- <> 1))
    636               from))
     701              from
     702              (abs (fx- upto from))
     703              ))
    637704    ((from upto step)
    638      (Iterate (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step)
    639               (if (fx>= upto from)
     705     (Iterate (if (fx>= upto from)
    640706                      (cut fx+ <> step)
    641707                      (cut fx- <> step))
    642               from))))
    643 
    644 (define (Append2 Lst1 Lst2)
    645   (if (not (lazy-list-length Lst1))
    646     Lst1
    647     (let loop ((Lst Lst1))
    648       (Lazy (if (lazy-list-length Lst2)
    649               (+ (lazy-list-length Lst1)
    650                  (lazy-list-length Lst2))
    651               #f)
    652         (if (Null? Lst)
    653           Lst2
    654           (cons (First Lst) (loop (rest Lst))))))))
    655 
    656 (define (Append . Lsts)
    657   (assume-in 'Append
    658     ((list-of? List-finite?) (butlast Lsts))
    659     (List? (last Lsts)))
    660   (cond
    661     ((null? Lsts) Nil)
    662     ((null? (cdr Lsts)) (car Lsts))
    663     (else
    664       (Append2 (car Lsts) (apply Append (cdr Lsts))))))
    665 
    666 (define (Reverse Lst)
    667   (assume-in 'Reverse
    668     (List-finite? Lst))
    669   (let loop ((Lst Lst) (reverse Nil))
    670     (if (Null? Lst)
    671       reverse
    672       (Lazy (lazy-list-length Lst)
    673         (loop (rest Lst)
    674               (Cons (First Lst) reverse))))))
     708              from
     709              (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step)
     710              ))))
     711
     712(define Append
     713  (case-lambda
     714    ((Lst1 Lst2)
     715     (assume-in 'Append
     716       (List? Lst1) (List? Lst2))
     717     (if (List-infinite? Lst1)
     718       Lst1
     719       (let ((finite? (lazy-list-finite? Lst2)))
     720         (let loop ((Lst1 Lst1))
     721           (Lazy finite?
     722             (if (Null? Lst1)
     723               Lst2
     724               (cons (First Lst1) (loop (Rest Lst1)))))))))
     725    ((Lst . Lsts)
     726     (if(Null? Lsts)
     727       Lst
     728       (apply Append
     729              (Append Lst (First Lsts))
     730              (Rest Lsts))))
     731    ))
     732
     733(define Reverse
     734  (case-lambda
     735    ((Lst1 Lst2)
     736     (assume-in 'Reverse
     737       (List-finite? Lst1) (List? Lst2))
     738     (let ((finite? (lazy-list-finite? Lst2)))
     739       (let loop ((Lst1 Lst1) (Result Lst2))
     740         (if (Null? Lst1)
     741           Result
     742           (loop (Rest Lst1)
     743                 (Lazy finite?
     744                   (cons (First Lst1) Result)))))))
     745    ((Lst)
     746     (Reverse Lst Nil))))
    675747
    676748(define (Reverse* Lst)
    677749  (assume-in 'Reverse*
    678750    (List? Lst))
    679   (letrec (
    680     (result
    681       (Cons Nil
    682         (Map Cons
    683              Lst
    684              (Lazy (lazy-list-length Lst) result))))
    685     )
    686     (Rest result)))
     751  (let ((finite? (lazy-list-finite? Lst)))
     752    (if (not finite?)
     753      (let loop ((n 1))
     754        (Lazy #f (cons (Reverse (Take n Lst))
     755                       (loop (fx+ n 1)))))
     756      (let ((len (Length Lst)))
     757        (let loop ((n 1))
     758          (Lazy #t
     759            (if (fx= 0 len)
     760              (list (First Lst))
     761              (cons (Reverse (Take n Lst))
     762                    (loop (fx+ n 1))))))))))
    687763
    688764(define (Merge <? Lst1 Lst2)
     
    691767    (List-finite? Lst1)
    692768    (List-finite? Lst2))
    693   (let ((len (+ (lazy-list-length Lst1) (lazy-list-length Lst2))))
    694     (let loop ((Lst1 Lst1) (Lst2 Lst2))
    695       (cond
    696         ((Null? Lst1) Lst2)
    697         ((Null? Lst2) Lst1)
    698         ((<? (First Lst1) (First Lst2))
    699          (Lazy len (cons (First Lst1) (loop (rest Lst1) Lst2))))
    700         (else
    701          (Lazy len
    702                (cons (First Lst2) (loop Lst1 (rest Lst2)))))))))
     769  (let loop ((Lst1 Lst1) (Lst2 Lst2))
     770    (cond
     771      ((Null? Lst1) Lst2)
     772      ((Null? Lst2) Lst1)
     773      ((<? (First Lst1) (First Lst2))
     774       (Lazy #t
     775         (cons (First Lst1) (loop (Rest Lst1) Lst2))))
     776      (else
     777       (Lazy #t
     778             (cons (First Lst2) (loop Lst1 (Rest Lst2))))))))
    703779
    704780(define (Sort <? Lst)
     
    706782    (procedure? <?)
    707783    (List-finite? Lst))
    708   (let ((len (lazy-list-length Lst)))
    709     (if (< len 2)
     784  (let ((len (Length Lst)))
     785    (if (fx< len 2)
    710786      Lst
    711       (let ((halflen (quotient len 2)))
     787      (let ((halflen (fxshr len 1)))
    712788        (Merge <?
    713789          (Sort <? (Take halflen Lst))
     
    721797    (cond
    722798      ((Null? Lst) #t)
    723       ((Null? (Cdr Lst)) #t)
    724       ((<? (Car Lst) (Car (Cdr Lst)))
    725        (loop (Cdr Lst)))
     799      ((Null? (Rest Lst)) #t)
     800      ((<? (First Lst) (First (Rest Lst)))
     801       (loop (Rest Lst)))
    726802      (else #f))))
    727803
     
    729805  (assume-in 'vector->List
    730806    (vector? vec))
    731   (let loop ((res Nil) (n (vector-length vec)))
    732     (if (zero? n)
    733       res
    734       (loop (Cons (vector-ref vec (- n 1)) res) (- n 1)))))
    735 
    736 ;; see comment to List->list
     807  (let loop ((Result Nil) (n (fx- (vector-length vec) 1)))
     808    (if (fx< n 0)
     809      Result
     810      (loop (Lazy #t (cons (vector-ref vec n) Result))
     811            (fx- n 1)))))
    737812(define (List->vector Lst)
    738813  (assume-in 'List->vector
    739814    (List-finite? Lst))
    740   (let ((vec (make-vector (lazy-list-length Lst) #f)))
    741     (let loop ((k 0) (Lst Lst))
    742       (cond
    743         ((Null? Lst)
    744          vec)
    745         (else
    746           (vector-set! vec k (First Lst))
    747           (loop (+ k 1) (rest Lst)))))))
    748 
    749 (define (Split-at n Lst)
    750   (assume-in 'Split-at
    751     (Admissible? n Lst))
    752   (let loop ((n n) (head Nil) (tail Lst))
    753     (if (or (Null? tail) (zero? n))
    754       (values (Reverse head) tail)
    755       (loop (- n 1)
    756             (Cons (First tail) head)
    757             (Rest tail)))))
    758 
    759 (define (Split-with ok? Lst)
    760   (assume-in 'Split-with
    761     (procedure? ok?)
    762     (List-finite? Lst))
    763   (let loop ((head Nil) (index 0) (tail Lst))
    764     (if (or (Null? tail) (not (ok? (First tail))))
    765     ;(if (or (Null? tail) (ok? (First tail)))
    766       (values (Reverse head) index tail)
    767       (loop (Cons (First tail) head)
    768             (+ index 1)
    769             (Rest tail)))))
     815  (let* ((len (Length Lst)) (vec (make-vector len #f)))
     816    (do ((k 0 (fx+ k 1)) (Lst Lst (Rest Lst)))
     817      ((fx= k len) vec)
     818      (vector-set! vec k (First Lst)))))
    770819
    771820(define (Sieve =? Lst)
     
    773822    (procedure? =?)
    774823    (List? Lst))
    775   (let loop ((Lst Lst))
    776     (if (Null? Lst)
    777       Nil
    778       (let (
    779         (first (First Lst))
    780         (tail
    781           (Filter
    782             (lambda (x)
    783               (not (=? x (First Lst))))
    784             (Rest Lst)))
    785         )
    786         (if (lazy-list-length Lst)
    787           (Cons first (loop tail))
    788           (Lazy #f
    789             (cons first (loop tail))))))))
    790 
    791 (define (Fold-left op base . Lsts)
     824  (let ((finite? (lazy-list-finite? Lst)))
     825    (let loop ((Lst Lst))
     826      (Lazy finite?
     827        (if (Null? Lst)
     828          '()
     829          (let (
     830            (first (First Lst))
     831            (rest
     832              (Filter
     833                (lambda (x)
     834                  (not (=? x (First Lst))))
     835                (Rest Lst)))
     836            )
     837            (cons first (loop rest))))))))
     838
     839(define (Fold-left op base Lst . Lsts)
    792840  (assume-in 'Fold-left
    793841    (procedure? op)
    794     (apply Lists-one-finite? Lsts))
    795   (let loop ((base base)
    796              (Lsts Lsts)
    797              (len (apply Length-min Lsts)))
    798     (if (zero? len)
    799       base
    800       (loop (apply op base (map First Lsts))
    801             (map Rest Lsts)
    802             (fx- len 1)))))
    803 
    804 (define (Fold-right op base . Lsts)
     842    (List? Lst)
     843    (or (List-finite? Lst) (apply Lists-one-finite? Lsts)))
     844  (let* ((Lsts (cons Lst Lsts)) (len (apply Length-min Lsts)))
     845    (let loop ((Lsts Lsts) (k 0) (result base))
     846      (if (fx= k len)
     847        result
     848        (loop (map Cdr Lsts)
     849              (fx+ k 1)
     850              (apply op result (map Car Lsts)))))))
     851
     852(define (Fold-right op base Lst . Lsts)
    805853  (assume-in 'Fold-right
    806854    (procedure? op)
    807     (apply Lists-one-finite? Lsts))
    808   (let loop ((Lsts Lsts)
    809              (len (apply Length-min Lsts)))
    810     (if (zero? len)
    811       base
    812       (apply op
    813              (append (map First Lsts)
    814                      (list (loop (map Rest Lsts) (fx- len 1))))))))
     855    (List? Lst)
     856    (or (List-finite? Lst) (apply Lists-one-finite? Lsts)))
     857  (let* ((Lsts (cons Lst Lsts)) (len (apply Length-min Lsts)))
     858    (let loop ((Lsts Lsts) (len len))
     859      (if (fx= 0 len)
     860        base
     861        (apply op
     862               (append (map First Lsts)
     863                       (list (loop (map Rest Lsts) (fx- len 1)))))))))
    815864
    816865;;; The following two routines return Lists
    817 (define (Fold-left* op base . Lsts)
     866(define (Fold-left* op base Lst . Lsts)
    818867  (assume-in 'Fold-left*
    819868    (procedure? op)
     869    (List? Lst)
    820870    ((list-of? List?) Lsts))
    821   (letrec (
    822     (fold
    823       (Cons base
    824         (apply Map op
    825                    (Lazy (apply Length-min Lsts) fold)
    826                    Lsts)))
    827     )
    828     (Rest fold)))
    829 
    830 (define (Fold-right* op base . Lsts) ; changes order of List items
     871  (let* ((Lsts (cons Lst Lsts))
     872         (finite? (if (not (apply Length-min Lsts))
     873                    #f
     874                    #t)))
     875    (letrec (
     876      (fold
     877        (Lazy finite?
     878          (cons base
     879                (apply Map op
     880                       (Lazy finite? fold)
     881                       Lsts))))
     882      )
     883      (Rest fold))))
     884
     885(define (Fold-right* op base Lst . Lsts) ; changes order of List items
    831886  (assume-in 'Fold-right*
    832887    (procedure? op)
     888    (List? Lst)
    833889    ((list-of? List?) Lsts))
    834   (letrec (
    835     (fold
    836       (Cons base
    837         (apply Map op
    838                (append Lsts
    839                        (list
    840                          (Lazy (apply Length-min Lsts) fold))))))
    841     )
    842     (Rest fold)))
     890  (let* ((Lsts (cons Lst Lsts))
     891         (finite? (if (not (apply Length-min Lsts))
     892                    #f
     893                    #t)))
     894      (letrec (
     895        (fold
     896          (Lazy finite?
     897            (cons base
     898                  (apply Map op
     899                         (append Lsts
     900                                 (list
     901                                   (Lazy finite? fold)))))))
     902        )
     903        (Rest fold))))
    843904
    844905(define (Every? ok? Lst)
     
    869930
    870931(define (List-finite? xpr)
    871   (and (List? xpr) (if (Length xpr) #t #f)))
     932  (and (List? xpr) ; (if (Length xpr) #t #f)))
     933       (lazy-list-finite? xpr)))
    872934
    873935(define (List-infinite? xpr)
    874   (and (List? xpr) (if (Length xpr) #f #t)))
     936  (and (List? xpr) ;(if (Length xpr) #f #t)))
     937       (not (lazy-list-finite? xpr))))
    875938
    876939(define (Lists-one-finite? . Lsts)
     
    878941    (not (null? Lsts))
    879942    ((list-of? List?) Lsts))
    880   (if (apply Length-min Lsts) #t #f))
     943  ;(if (apply Length-min Lsts) #t #f))
     944  (not (null? (compress (map lazy-list-finite? Lsts)
     945                        Lsts))))
    881946
    882947;;; two examples
  • release/4/lazy-lists/trunk/lazy-lists.setup

    r31803 r33876  
    88 'lazy-lists
    99 '("lazy-lists.so" "lazy-lists.import.so")
    10  '((version "0.8.1")))
     10 '((version "0.9")))
  • release/4/lazy-lists/trunk/tests/run.scm

    r31797 r33876  
    1 (require-library lazy-lists simple-tests)
     1(require-library simple-tests lazy-lists)
    22(import lazy-lists simple-tests)
    33(register-feature! 'assumptions-checked)
     
    55(define-test (lazy-list)
    66  (check
    7     (define (cons-right var lst)
    8       (if (null? lst)
    9         (cons var lst)
    10         (cons (car lst) (cons-right var (cdr lst)))))
    117    (define (First-five) (List 0 1 2 3 4))
    128    (define (Fibs)
     
    2622    (= (Length (First-five)) 5)
    2723    (= (Length (Rest (First-five))) 4)
    28     (eq? (Length (Rest (Cardinals))) #f)
     24    (not (Length (Rest (Cardinals))))
    2925    (= (Length (Take 5 (Cardinals))) 5)
    30     (eq? (Length (Cardinals)) #f)
    31     (eq? (Length (Drop 5 (Cardinals))) #f)
     26    (not (Length (Cardinals)))
     27    (not (Length (Drop 5 (Cardinals))))
    3228    (= (First (Drop 5 (Cardinals))) 5)
    33     (equal? (List->list (First-five)) '(0 1 2 3 4))
    34     (equal? (List->list (Take 5 (Cardinals))) '(0 1 2 3 4))
     29    (Eqv? (First-five) (List 0 1 2 3 4))
     30    (Eqv? (Take 5 (Cardinals)) (List 0 1 2 3 4))
    3531    (= (Length (Range 2 10)) (- 10 2))
    3632    (= (Length (Range 10)) 10)
    3733    (= (Length (Range -1 10 2)) 6)
    38     (equal? (List->list (Range -1 10 2)) '(-1 1 3 5 7 9))
    39     (equal? (List->list (Range 2 10)) '(2 3 4 5 6 7 8 9))
    40     (equal? (List->list (Range 10 2)) '(10 9 8 7 6 5 4 3))
     34    (Eqv? (Range -1 10 2) (List -1 1 3 5 7 9))
     35    (Eqv? (Range 2 10) (List 2 3 4 5 6 7 8 9))
     36    (Eqv? (Range 10 2) (List 10 9 8 7 6 5 4 3))
     37    (Eqv? (Drop-while (cut < <> 3) (First-five))
     38          (List 3 4))
     39    (Eqv? (Take-while (cut < <> 3) (First-five))
     40          (List 0 1 2))
    4141    (equal?
    4242      (receive (head index tail) (Split-with (cut < <> 3) (First-five))
     
    4949    (= (Count-while (cut < <> 2) (First-five)) 2)
    5050    (= (Count-while (cut < <> 20) (First-five)) 5)
    51     (equal? (List->list (Take-while (cut < <> 5) (Take 10 (Cardinals))))
    52             '(0 1 2 3 4))
     51    (Eqv? (Take-while (cut < <> 5) (Take 10 (Cardinals)))
     52          (List 0 1 2 3 4))
    5353    (= (Length (Take-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
    5454    (= (Length (Drop-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     
    5656    (= (Length (Drop-while (cut < <> 2) (First-five))) 3)
    5757    (= (First (Drop-while (cut < <> 2) (First-five))) 2)
    58     (equal? (List->list (Memp odd? (First-five))) '(1 2 3 4))
    59     (equal? (List->list (Memv 5 (Take 10 (Cardinals)))) '(5 6 7 8 9))
     58    (Eqv? (Memp odd? (First-five)) (List 1 2 3 4))
     59    (Eqv? (Memv 5 (Take 10 (Cardinals))) (List 5 6 7 8 9))
    6060    (equal? (Assv 5 (Take 10 (Map (lambda (x) (list x x)) (Cardinals))))
    6161            '(5 5))
    62     (eq? (Assv 10 (Map (lambda (x) (list x x)) (First-five))) #f)
    63     (eq? (Equal? (Cardinals) (Cardinals)) #f)
    64     (eq? (Equal? (Cardinals) (First-five)) #f)
    65     (eq? (Equal? (First-five) (First-five)) #t)
     62    (not (Assv 10 (Map (lambda (x) (list x x)) (First-five))))
     63    (not (Equal? (Cardinals) (Cardinals)))
     64    (let ((Card (Cardinals)))
     65      (Equal? Card Card))
     66    (not (Equal? (Cardinals) (First-five)))
     67    (Equal? (First-five) (First-five))
    6668    (= (Length (Take 10 (Cardinals))) 10)
    67     (equal? (List->list (Take 5 (Filter odd? (Drop 1 (Cardinals)))))
    68             '(1 3 5 7 9))
     69    (Eqv? (Take 5 (Filter odd? (Drop 1 (Cardinals))))
     70          (List 1 3 5 7 9))
    6971    (Eqv? (Remp odd? (First-five)) (List 0 2 4))
    7072    (Eqv? (Take 5 (Remp odd? (Cardinals)))
    7173          (Take 5 (Map (cut * <> 2) (Cardinals))))
    7274    (Eqv? (Remv 3 (First-five)) (List 0 1 2 4))
    73     (eq? (Length (Cardinals)) #f)
    74     (equal? (List->list (Map add1 (First-five))) '(1 2 3 4 5))
    75     (equal? (List->list (Map + (First-five) (Take 5 (Cardinals))))
    76             '(0 2 4 6 8))
    77     (eq? (Length (Map + (Cardinals) (Cardinals))) #f)
     75    (not (Length (Cardinals)))
     76    (Eqv? (Map add1 (First-five)) (List 1 2 3 4 5))
     77    (Eqv? (Map + (First-five) (Take 5 (Cardinals)))
     78          (List 0 2 4 6 8))
     79    (not (Length (Map + (Cardinals) (Cardinals))))
    7880    (For-each (lambda (x y) (print "### " x " " y)) (Cardinals) (First-five))
    7981    (= (Length (Filter odd? (First-five))) 2)
    80     (equal? (List->list (Filter odd? (First-five))) '(1 3))
    81     (eq? (Length (Filter odd? (Cardinals))) #f)
    82     (= (Ref 20 (Sieve = (Zip (Cardinals) (Cardinals)))) 20)
    83     (equal? (List->list (Sieve = (Zip (First-five) (First-five))))
    84             '(0 1 2 3 4))
    85     (= (Ref 25 (Cardinals)) 25)
    86     (= (Ref 2 (First-five)) 2)
    87     (equal? (List->list (Repeat 3 #f)) '(#f #f #f))
     82    (Eqv? (Filter odd? (First-five)) (List 1 3))
     83    (not (Length (Filter odd? (Cardinals))))
     84    (Eqv? (Take 10 (Zip (First-five) (Cardinals)))
     85          (List 0 0 1 1 2 2 3 3 4 4))
     86    (not (Length (Zip (First-five) (Cardinals))))
     87    (= (At 20 (Sieve = (Zip (Cardinals) (Cardinals)))) 20)
     88    (Eqv? (Sieve = (Zip (First-five) (First-five)))
     89          (List 0 1 2 3 4))
     90    (= (At 25 (Cardinals)) 25)
     91    (= (At 2 (First-five)) 2)
     92    (Eq? (Repeat #f 3) (List #f #f #f))
    8893    (List-infinite? (Repeatedly (lambda () 1)))
    89     (equal? (List->list (Repeatedly 3 (lambda () 1)))
    90             '(1 1 1))
     94    (Eqv? (Repeatedly (lambda () 1) 3)
     95          (List 1 1 1))
    9196    (List-infinite? (Iterate add1 0))
    92     (List-finite? (Iterate 3 add1 0))
    93     (equal? (List->list (Iterate 3 add1 0)) '(0 1 2))
    94     (eq? (Length (Iterate add1 0)) #f)
    95     (equal? (List->list (Cycle 10 (First-five)))
    96             '(0 1 2 3 4 0 1 2 3 4))
    97     (eq? (Length (Cycle (First-five))) #f)
     97    (List-finite? (Iterate add1 0 3))
     98    (Eqv? (Iterate add1 0 3) (List 0 1 2))
     99    (not (Length (Iterate add1 0)))
     100    (Eqv? (Cycle 10 (First-five))
     101          (List 0 1 2 3 4 0 1 2 3 4))
     102    (not (Length (Cycle (First-five))))
    98103    (= (Length (Append (First-five) (First-five))) 10)
    99104    (not (Length (Append (Cardinals) (First-five))))
    100     (equal? (List->list  (Append (First-five) (First-five)))
    101             '(0 1 2 3 4 0 1 2 3 4))
    102     (equal? (List->list (Take 12 (Append (First-five) (Cardinals))))
    103             '(0 1 2 3 4 0 1 2 3 4 5 6))
    104     (eq? (Length (Append (First-five) (Cardinals))) #f)
    105     (equal? (List->list (Reverse (First-five))) '(4 3 2 1 0))
    106     (equal? (List->list (Reverse (Take 5 (Cardinals)))) '(4 3 2 1 0))
     105    (Eqv? (Append (First-five) (First-five))
     106          (List 0 1 2 3 4 0 1 2 3 4))
     107    (Eqv? (Take 12 (Append (First-five) (Cardinals)))
     108          (List 0 1 2 3 4 0 1 2 3 4 5 6))
     109    (not (Length (Append (First-five) (Cardinals))))
     110    (List-finite? (Reverse (First-five)))
     111    (List-finite? Nil)
     112    (zero? (Length Nil))
     113    (Equ? = (Reverse (First-five)) (List 4 3 2 1 0))
     114    (Equ? = (Reverse (Take 5 (Cardinals))) (List 4 3 2 1 0))
     115    (= (Length (List 0 1 2 3 4)) 5)
    107116    (= (Length (Reverse (First-five))) 5)
    108     (eq? (Length (Reverse* (Cardinals))) #f)
    109     (equal? (List->list (Ref 5 (Reverse* (Cardinals)))) '(5 4 3 2 1 0))
    110     (equal? (List->list (Sort < (First-five))) '(0 1 2 3 4))
     117    (not (Length (Reverse* (Cardinals))))
     118    (Equal? (At 5 (Reverse* (Cardinals))) (List 5 4 3 2 1 0))
     119    (Equal? (At 4 (Reverse* (First-five))) (List 4 3 2 1 0))
    111120    (Sorted? < (First-five))
    112121    (not (Sorted? < (Append (First-five) (First-five))))
     122    (Equal? (Sort < (First-five)) (List 0 1 2 3 4))
    113123    (= (Length (Sort < (First-five))) 5)
    114     (equal? (List->list (Sort < (List 3 1 0 2 4))) '(0 1 2 3 4))
     124    (Equal? (Sort < (List 3 1 0 2 4)) (List 0 1 2 3 4))
    115125    (equal?
    116126      (receive (head tail) (Split-at 5 (Cardinals))
    117127        (cons (First tail) (List->list head)))
    118128      '(5 0 1 2 3 4))
    119     (equal?
    120       (receive (head tail) (Split-at 15 (Take 5 (Cardinals)))
    121         (append (List->list tail) (List->list head)))
    122       '(0 1 2 3 4))
    123129    "FOLDS"
     130    (define (cons-right var lst)
     131      (if (null? lst)
     132        (cons var lst)
     133        (cons (car lst) (cons-right var (cdr lst)))))
     134    (equal? (cons-right 10 '(0 1 2 3)) '(0 1 2 3 10))
    124135    (= (Fold-left + 0 (Take 5 (Cardinals))) 10)
    125136    (= (Fold-left + 0 (First-five) (First-five)) 20)
     
    127138    (equal? (Fold-left cons '() (Take 5 (Cardinals)))
    128139            '(((((() . 0) . 1) . 2) . 3) . 4))
    129     (equal? (Ref 4 (Fold-left* cons '() (Cardinals)))
     140    (equal? (At 4 (Fold-left* cons '() (Cardinals)))
    130141            '(((((() . 0) . 1) . 2) . 3) . 4))
    131142    (= (Fold-right + 0 (Take 5 (Cardinals))) 10)
    132143    (= (Fold-right + 0 (First-five) (First-five)) 20)
    133144    (equal? (Fold-right cons '() (First-five))
    134             '(0 1 2 3 4)) ; list
     145            '(0 1 2 3 4))
    135146    (equal? (Fold-right cons '(a b c) (First-five))
    136147            '(0 1 2 3 4 a b c)) ; append
    137     (equal? (Ref 4 (Fold-right* cons '() (Cardinals)))
     148    (equal? (At 4 (Fold-right* cons '() (Cardinals)))
    138149            '(4 3 2 1 0)) ; note changed order
    139     (equal? (Ref 4 (Fold-right* cons-right '() (Cardinals)))
     150    (equal? (At 4 (Fold-right* cons-right '() (Cardinals)))
    140151            '(0 1 2 3 4))
    141     (equal? (Ref 4 (Fold-right* cons '(a b c) (Cardinals)))
     152    (equal? (At 4 (Fold-right* cons '(a b c) (Cardinals)))
    142153            '(4 3 2 1 0 a b c)) ; note changed order
    143     (equal? (Ref 4 (Fold-right* cons-right '(a b c) (Cardinals)))
     154    (equal? (At 4 (Fold-right* cons-right '(a b c) (Cardinals)))
    144155            '(a b c 0 1 2 3 4))
    145156    "TRANSFORMATIONS"
    146     (equal? (List->list (vector->List '#(0 1 2 3 4))) '(0 1 2 3 4))
    147     (Null? (vector->List '#()))
    148     (equal? (List->vector (Take 5 (Cardinals))) '#(0 1 2 3 4))
    149     (equal? (List->vector (First-five)) '#(0 1 2 3 4))
     157    (Equal? (vector->List #(0 1 2 3 4)) (List 0 1 2 3 4))
     158    (Null? (vector->List #()))
     159    (equal? (List->vector (Take 5 (Cardinals))) #(0 1 2 3 4))
     160    (equal? (List->vector (First-five)) #(0 1 2 3 4))
    150161    (equal? (List->vector Nil) '#())
    151     (eq? (Every? odd? (Take 15 (Filter odd? (Cardinals)))) #t)
    152     (eq? (Every? odd? (Take 15 (Cardinals))) #f)
    153     (eq? (Every? odd? Nil) #t)
    154     (eq? (Some? odd? Nil) #f)
    155     (eq? (Some? odd? (Take 5 (Filter even? (Cardinals)))) #f)
    156     (eq? (Some? odd? (First-five)) #t)
     162    (Every? odd? (Take 15 (Filter odd? (Cardinals))))
     163    (not (Every? odd? (Take 15 (Cardinals))))
     164    (Every? odd? Nil)
     165    (not (Some? odd? Nil))
     166    (not (Some? odd? (Take 5 (Filter even? (Cardinals)))))
     167    (Some? odd? (First-five))
    157168    "ZIP AND UNZIP"
    158     (eq? (Length (Zip (Cardinals) (First-five))) #f)
    159     (eq? (Length (Zip (First-five) (Cardinals))) #f)
    160     (eq? (Length (Zip (Cardinals) (Cardinals))) #f)
     169    (not (Length (Zip (Cardinals) (First-five))))
     170    (not (Length (Zip (First-five) (Cardinals))))
     171    (not (Length (Zip (Cardinals) (Cardinals))))
    161172    (= (Length (Zip (First-five) (First-five))) 10)
    162173    (Eqv? (Take 14 (Zip (Cardinals) (First-five)))
     
    170181           (Eqv? (Take 5 Odds) (List 1 3 5 7 9))))
    171182    "PRIMES AND FIBS"
    172     (= (Ref 50 (Primes)) 233)
     183    (= (At 50 (Primes)) 233)
    173184    (Eqv? (Take 5 (Primes)) (List 2 3 5 7 11))
    174185    (Eqv? (Take 10 (Fibs)) (List  0 1 1 2 3 5 8 13 21 34))
    175186    "LIST OF SUMS"
    176187    (define (Sums Lst)
    177       (letrec ((sums (Cons 0 (Map + Lst (Lazy (Length Lst) sums)))))
    178         (Rest sums)))
    179     (equal? (List->list (Sums (First-five))) '(0 1 3 6 10))
     188      (let loop ((n 1))
     189        (Lazy #f (cons (apply + (List->list (Take n Lst)))
     190                       (loop (fx+ n 1))))))
     191    (Eqv? (Take 5 (Sums (Cardinals))) (List 0 1 3 6 10))
    180192    "COMPUTE SQUARE ROOT BY NEWTON'S METHOD"
    181193    (define (Within eps Lst)
    182194      (let loop ((Lst Lst))
    183         (let ((a (Ref 0 Lst)) (b (Ref 1 Lst)))
     195        (let ((a (At 0 Lst)) (b (At 1 Lst)))
    184196          (if (< (abs (- a b)) eps)
    185197            b
     
    187199    (define (Relative eps Lst)
    188200      (let loop ((Lst Lst))
    189         (let ((a (Ref 0 Lst)) (b (Ref 1 Lst)))
     201        (let ((a (At 0 Lst)) (b (At 1 Lst)))
    190202          (if (<= (abs (/ a b)) (* (abs b) eps))
    191203            b
     
    201213    (not (List-finite? Integers))
    202214    (not (Realized? Integers))
    203     (= (Ref 5 Integers) 6)
     215    (= (At 5 Integers) 6)
    204216    (Realized? Integers)
    205217    ))
Note: See TracChangeset for help on using the changeset viewer.