Changeset 29298 in project


Ignore:
Timestamp:
07/02/13 17:36:02 (8 years ago)
Author:
juergen
Message:

Repeat(edly), Cycle, Iterate with optional additional arg, -upto changed to -while, Split-with changed semantics

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

Legend:

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

    r29274 r29298  
    3232; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3333;
    34 ; Last update: June 28, 2013
     34; Last update: June 26, 2013
    3535;
    3636(require-library multi-methods)
     
    4040   List->list list->List input->List
    4141   First Rest Car Cdr Length Length-min Append Reverse
    42    List? Null? Realized? Reverse* Index
     42   List? Null? Realized? Reverse*
    4343   List-infinite? Realize
    4444   List-not-null? List-finite? Lists-one-finite?
    45    Take Drop Ref Take-upto Drop-upto
     45   Take Drop Ref Take-while Drop-while Count-while
    4646   Memp Member Memq Memv
    4747   Equ? Equal? Eq? Eqv?
     
    4949   Map Filter Sieve For-each
    5050   Iterate Repeat Repeatedly
    51    Cardinals Primes Cycle Interval
     51   Cardinals Primes Cycle Range
    5252   Nil Cons Merge Sort Sorted? Split-at Split-with
    5353   vector->List List->vector
     
    5656
    5757(import scheme
    58         (only data-structures compress list-of?)
     58        (only data-structures o compress list-of?)
    5959        (only chicken
    6060              define-record-type
     
    6565              add1
    6666              sub1
    67               fx+ fx= fx< fx-
     67              fx+ fx= fx>= fx< fx- fx/
     68              case-lambda
    6869              assert
    69               receive
     70              nth-value
    7071              unless))
    7172
     
    204205    (lambda (a b) b)))
    205206
    206 (define (Take-upto ok? Lst)
    207 ;  (let loop ((len (lazy-list-length Lst)) (Lst Lst))
    208 ;    (cond
    209 ;      ((Null? Lst) Nil)
    210 ;      ((ok? (First Lst))
    211 ;       (Lazy len
    212 ;         (cons (First Lst)
    213 ;               (loop (if len (- len 1) #f)
    214 ;                     (Rest Lst)))))
    215 ;      (else Nil))))
    216   (receive (head index tail) (Split-with ok? Lst)
    217     head))
    218 
    219 (define (Index ok? Lst)
    220   (receive (head index tail) (Split-with ok? Lst)
    221     index))
    222 
    223 (define (Drop-upto ok? Lst)
    224 ;  (let loop ((len (lazy-list-length Lst)) (Lst Lst))
    225 ;    (cond
    226 ;      ((Null? Lst) Nil)
    227 ;      ((ok? (First Lst))
    228 ;       (loop (if len (- len 1) #f)
    229 ;             (Rest Lst)))
    230 ;      (else
    231 ;        (Lazy len Lst)))))
    232   (receive (head index tail) (Split-with ok? Lst)
    233     tail))
     207(define (Take-while ok? Lst)
     208  (nth-value 0 (Split-with ok? Lst)))
     209
     210(define (Count-while ok? Lst)
     211  (nth-value 1 (Split-with ok? Lst)))
     212
     213(define (Drop-while ok? Lst)
     214  (nth-value 2 (Split-with ok? Lst)))
    234215
    235216(define (Memp ok? Lst)
    236   (Drop-upto ok? Lst))
     217  (Drop-while (o not ok?) Lst))
    237218
    238219(define (Memq var Lst)
     
    269250(define (Assp ok? al)
    270251  (let (
    271     (Lst (Drop-upto (lambda (pair) (ok? (car pair))) al))
     252    (Lst (Drop-while (lambda (pair) (not (ok? (car pair)))) al))
    272253    )
    273254    (if (Null? Lst) #f (First Lst))))
     
    336317            (Cons datum (loop))))));)
    337318
    338 (define (Repeat x)
    339   (Lazy #f (cons x (Repeat x))))
    340 
    341 (define (Repeatedly thunk)
    342   (Lazy #f (cons (thunk) (Repeatedly thunk))))
    343 
    344 (define (Iterate f x)
    345   (Lazy #f
    346     (cons x (Iterate f (f x)))))
    347 
    348 (define (Interval from upto)
    349   (Take (abs (- upto from))
    350         (Iterate (if (>= upto from) add1 sub1) from)))
     319(define Repeat
     320  (case-lambda
     321    ((x) (Lazy #f (cons x (Repeat x))))
     322    ((n x) (Take n (Repeat x)))))
     323
     324(define Repeatedly
     325  (case-lambda
     326    ((thunk) (Lazy #f (cons (thunk) (Repeatedly thunk))))
     327    ((n thunk) (Take n (Repeatedly thunk)))))
     328
     329(define Iterate
     330  (case-lambda
     331    ((f x) (Lazy #f (cons x (Iterate f (f x)))))
     332    ((n f x) (Take n (Iterate f x)))))
     333
     334(define Cycle
     335  (case-lambda
     336    ((Lst)
     337     (if (Null? Lst)
     338       Nil
     339       (let loop ((tail Lst))
     340         (Lazy #f
     341           (if (Null? tail)
     342             (loop Lst)
     343             (cons (First tail)
     344                   (loop (rest tail))))))))
     345    ((n Lst) (Take n (Cycle Lst)))))
     346
     347(define Range
     348  (case-lambda
     349    ((upto)
     350     (Iterate (abs upto)
     351              (if (fx>= upto 0)
     352                (cut fx+ <> 1)
     353                (cut fx- <> 1))
     354              0))
     355    ((from upto)
     356     (Iterate (abs (fx- upto from))
     357              (if (fx>= upto from)
     358                      (cut fx+ <> 1)
     359                      (cut fx- <> 1))
     360              from))
     361    ((from upto step)
     362     (Iterate (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step)
     363              (if (fx>= upto from)
     364                      (cut fx+ <> step)
     365                      (cut fx- <> step))
     366              from))))
    351367
    352368(define (Append2 Lst1 Lst2)
     
    387403    (Rest result)))
    388404
    389 (define (Cycle Lst)
    390   (if (Null? Lst)
    391       Nil
    392       (let loop ((tail Lst))
    393         (Lazy #f
    394           (if (Null? tail)
    395               (loop Lst)
    396               (cons (First tail)
    397                     (loop (rest tail))))))))
    398 
    399405(define (Merge <? Lst1 Lst2)
    400406  (let ((len (+ (lazy-list-length Lst1) (lazy-list-length Lst2))))
     
    454460(define (Split-with ok? Lst)
    455461  (let loop ((head Nil) (index 0) (tail Lst))
    456     (if (or (Null? tail) (ok? (First tail)))
     462    (if (or (Null? tail) (not (ok? (First tail))))
     463    ;(if (or (Null? tail) (ok? (First tail)))
    457464      (values (Reverse head) index tail)
    458465      (loop (Cons (First tail) head)
     
    568575              List? Null? Realized? Reverse*
    569576              List-infinite? Realize
    570               Take Drop Ref Take-upto Drop-upto
    571               Memp Member Memq Memv Index
     577              Take Drop Ref Take-while Drop-while
     578              Memp Member Memq Memv Count-while
    572579              Equ? Equal? Eq? Eqv?
    573580              Assp Assoc Assq Assv
    574581              Map Filter Sieve For-each
    575582              Iterate Repeat Repeatedly
    576               Cardinals Primes Cycle Interval
     583              Cardinals Primes Cycle Range
    577584              Merge Sort Sorted? Split-at Split-with
    578585              vector->List List->vector
     
    583590        (only methods method query-checker no-checker
    584591              method-check-args-and-call effects-checked?)
    585         (only chicken fixnum? fx>= fx<= fx- fx+ fx= fx<)
     592        (only chicken fixnum? fx>= fx<= fx- fx+ fx= fx< fx* fx/ signum)
    586593        (only data-structures o list-of? conjoin sort)
    587594        (prefix %lazy-lists %))
     
    664671  %Nil)
    665672
    666 (define Interval
    667   (method ('Interval
    668            %Interval
    669            (query-checker
    670              (lambda (from upto)
    671                (lambda (result)
    672                  (and (%List? result)
    673                       (= (%Length result) (abs (- upto from))))))
    674              '(List-of-proper-length? result)))
     673(define Range
     674  (method #t ; variadic
     675          ('Range
     676           %Range
     677           (query-checker
     678             (lambda (arg . args)
     679               (lambda (result)
     680                 (let (
     681                   (from (cond
     682                           ((null? args) 0)
     683                           ((null? (cdr args)) arg)))
     684                   (upto (cond
     685                           ((null? args) arg)
     686                           ((null? (cdr args)) (car args))))
     687                   (step (cond
     688                           ((null? args) (signum arg))
     689                           ((null? (cdr args)) (signum (fx- (car args) arg)))
     690                           (else (fx* (abs (cadr args))
     691                                      (signum (fx- (car args) arg))))))
     692                   )
     693                   (and (%List-finite? result)
     694                        (fx= (%Length result)
     695                             (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step))))))
     696             '(and (List-finite? result)
     697                  (= (Length result)
     698                     (quotient (+ (- step 1) (abs (- upto from))) step)))))
    675699          ('1integer? integer?)
    676           ('2integer? integer?)))
     700          ('2integers? (list-of? integer?))))
    677701
    678702(define Cardinals
     
    890914             (lambda (n Lst)
    891915               (lambda (head tail)
    892                  (and (%List? head) (%Length head)
     916                 (and (%List? head) (%Length head) (%List tail)
    893917                      (if (%Length Lst)
    894918                        (and (fx= (%Length head) (min n (%Length Lst)))
     
    897921                        (and (fx= (%Length head) n)
    898922                             (not (%Length tail)))))))
    899              '(and (List? head) (Length head)
     923             '(and (List? head) (Length head) (List tail)
    900924                   (if (Length Lst)
    901925                     (and (= (Length head) (min n (Length Lst)))
     
    917941          (<= (Length result) (Length Lst)))))
    918942
    919 (define Take-upto
    920   (method ('Take-upto %Take-upto Sublist-finite-checker)
     943(define Take-while
     944  (method ('Take-while %Take-while Sublist-finite-checker)
    921945          ('1unary-predicate? procedure?)
    922946          ('2List-finite? %List-finite?)))
    923947
    924 (define Drop-upto
    925   (method ('Drop-upto %Drop-upto Sublist-finite-checker)
     948(define Drop-while
     949  (method ('Drop-while %Drop-while Sublist-finite-checker)
    926950          ('1unary-predicate? procedure?)
    927951          ('2List-finite? %List-finite?)))
     
    966990          ('2List-finite? %List-finite?)))
    967991
    968 (define Index
    969   (method ('Index
    970            %Index
     992(define Count-while
     993  (method ('Count-while
     994           %Count-while
    971995           (query-checker
    972996             (lambda (ok? Lst)
     
    11111135    '(and (List result) (not (Length result)))))
    11121136
     1137(define List-of-given-length-checker
     1138  (query-checker
     1139    (lambda args
     1140      (lambda (result)
     1141        (if (null? (cdr args))
     1142          (%List-infinite? result)
     1143          (and (%List? result)
     1144               (fx= (%Length result) (car args))))))
     1145    '(if (null? (cdr args))
     1146       (List-infinite? result)
     1147       (and (List? result)
     1148            (= (Length result) (car args))))))
     1149
     1150(define (any-or-index+any? args)
     1151  (and (list? args)
     1152       (<= 1 (length args) 2)
     1153       (if (null? (cdr args))
     1154         (any? (car args))
     1155         (and (%List-index? (car args))
     1156              (any? (cadr args))))))
     1157
    11131158(define Repeat
    1114   (method ('Repeat %Repeat List-infinite-checker)
    1115           ('1any? any?)))
     1159  (method #t ; variadic
     1160          ('Repeat
     1161           %Repeat
     1162           List-of-given-length-checker)
     1163          ('1any-or-index+any? any-or-index+any?)))
    11161164
    11171165(define Repeatedly
    1118   (method ('Repeatedly %Repeatedly List-infinite-checker)
    1119           ('1thunk? procedure?)))
     1166  (method #t ; variadic
     1167          ('Repeatedly %Repeatedly List-of-given-length-checker)
     1168          ('1thunk-or-index+thunk?
     1169           (lambda (args)
     1170             (and (list? args)
     1171                  (<= 1 (length args) 2)
     1172                  (if (null? (cdr args))
     1173                    (procedure? (car args))
     1174                    (and (%List-index? (car args))
     1175                         (procedure? (cadr args)))))))))
    11201176
    11211177(define Iterate
    1122   (method ('Iterate %Iterate List-infinite-checker)
    1123           ('1unary-procedure? procedure?)
    1124           ('2any? any?)))
     1178  (method #t ;variadic
     1179          ('Iterate %Iterate List-of-given-length-checker)
     1180          ('1proc+any-or-index+proc+any?
     1181           (lambda (args)
     1182             (and (list? args)
     1183                  (<= 2 (length args) 3)
     1184                  (if (null? (cddr args))
     1185                    (procedure? (car args))
     1186                    (and (%List-index? (car args))
     1187                         (procedure? (cadr args)))))))))
    11251188
    11261189(define Cycle
    1127   (method ('Cycle %Cycle List-infinite-checker)
    1128           ('1List-finite? %List-finite?)))
     1190  (method #t ; variadic
     1191          ('Cycle %Cycle List-of-given-length-checker)
     1192          ('1List-finite-or-index+List-finite?
     1193           (lambda (args)
     1194             (and (list? args)
     1195                  (<= 1 (length args) 2)
     1196                  (if (null? (cdr args))
     1197                    (%List-finite? (car args))
     1198                    (and (%List-index? (car args))
     1199                         (%List-finite? (cadr args)))))))))
    11291200
    11301201(define Append
     
    12911362       First Rest Length Append Reverse
    12921363       Reverse*
    1293        Take Drop Ref Take-upto Drop-upto
    1294        Memp Member Memq Memv Index
     1364       Take Drop Ref Take-while Drop-while
     1365       Memp Member Memq Memv Count-while
    12951366       Assp Assoc Assq Assv
    12961367       Map Filter Sieve For-each
    12971368       Iterate Repeat Repeatedly
    1298        Cardinals Primes Cycle Interval
     1369       Cardinals Primes Cycle Range
    12991370       Merge Sort Sorted? Split-at Split-with
    13001371       vector->List List->vector
     
    13061377) ; module lazy-lists
    13071378
    1308 
  • release/4/lazy-lists/tags/0.5/lazy-lists.setup

    r29274 r29298  
    88 'lazy-lists
    99 '("lazy-lists.so" "lazy-lists.import.so" "%lazy-lists.import.so")
    10  '((version "0.4")))
     10 '((version "0.5")))
  • release/4/lazy-lists/tags/0.5/tests/run.scm

    r29251 r29298  
    88      (cons var lst)
    99      (cons (car lst) (cons-right var (cdr lst)))))
    10 
    11 ;(define port (open-input-file "lazy-lists.scm"))
    12 ;(define input (input->List port read-line))
    1310
    1411(run-tests
     
    3532  (equal? (List->list (First-five)) '(0 1 2 3 4))
    3633  (equal? (List->list (Take 5 (Cardinals))) '(0 1 2 3 4))
    37   (= (Length (Interval 2 10)) (- 10 2))
    38   (equal? (List->list (Interval 2 10)) '(2 3 4 5 6 7 8 9))
    39   (equal? (List->list (Interval 10 2)) '(10 9 8 7 6 5 4 3))
     34  (= (Length (Range 2 10)) (- 10 2))
     35  (= (Length (Range 10)) 10)
     36  (= (Length (Range -1 10 2)) 6)
     37  (equal? (List->list (Range -1 10 2)) '(-1 1 3 5 7 9))
     38  (equal? (List->list (Range 2 10)) '(2 3 4 5 6 7 8 9))
     39  (equal? (List->list (Range 10 2)) '(10 9 8 7 6 5 4 3))
    4040  (equal?
    41     (receive (head index tail) (Split-with (cut = <> 3) (First-five))
     41    (receive (head index tail) (Split-with (cut < <> 3) (First-five))
    4242      (cons (First tail) (List->list head)))
    4343    '(3 0 1 2))
    4444  (equal?
    45     (receive (head index tail) (Split-with (cut = <> 5) (Take 10 (Cardinals)))
     45    (receive (head index tail) (Split-with (cut < <> 5) (Take 10 (Cardinals)))
    4646      (append (List->list tail) (List->list head)))
    4747    '(5 6 7 8 9 0 1 2 3 4))
    48   (= (Index (cut = <> 2) (First-five)) 2)
    49   (= (Index (cut = <> 20) (First-five)) 5)
    50   (equal? (List->list (Take-upto (cut = <> 5) (Take 10 (Cardinals))))
     48  (= (Count-while (cut < <> 2) (First-five)) 2)
     49  (= (Count-while (cut < <> 20) (First-five)) 5)
     50  (equal? (List->list (Take-while (cut < <> 5) (Take 10 (Cardinals))))
    5151       '(0 1 2 3 4))
    52   (= (Length (Take-upto (cut = <> 5) (Take 10 (Cardinals)))) 5)
    53   (= (Length (Drop-upto (cut = <> 5) (Take 10 (Cardinals)))) 5)
    54   (= (First (Drop-upto (cut = <> 5) (Take 10 (Cardinals)))) 5)
    55   (= (Length (Drop-upto (cut = <> 2) (First-five))) 3)
    56   (= (First (Drop-upto (cut = <> 2) (First-five))) 2)
     52  (= (Length (Take-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     53  (= (Length (Drop-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     54  (= (First (Drop-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     55  (= (Length (Drop-while (cut < <> 2) (First-five))) 3)
     56  (= (First (Drop-while (cut < <> 2) (First-five))) 2)
    5757  (equal? (List->list (Memp odd? (First-five))) '(1 2 3 4))
    5858  (equal? (List->list (Memv 5 (Take 10 (Cardinals)))) '(5 6 7 8 9))
     
    7979  (= (Ref 25 (Cardinals)) 25)
    8080  (= (Ref 2 (First-five)) 2)
    81   (equal? (List->list (Take 3 (Repeat #f))) '(#f #f #f))
    82   (equal? (List->list (Take 3 (Repeatedly (lambda () 1))))
     81  (equal? (List->list (Repeat 3 #f)) '(#f #f #f))
     82  (List-infinite? (Repeatedly (lambda () 1)))
     83  (equal? (List->list (Repeatedly 3 (lambda () 1)))
    8384    '(1 1 1))
    84   (equal? (List->list (Take 3 (Iterate add1 0))) '(0 1 2))
     85  (List-infinite? (Iterate add1 0))
     86  (List-finite? (Iterate 3 add1 0))
     87  (equal? (List->list (Iterate 3 add1 0)) '(0 1 2))
    8588  (eq? (Length (Iterate add1 0)) #f)
     89  (equal? (List->list (Cycle 10 (First-five)))
     90    '(0 1 2 3 4 0 1 2 3 4))
     91  (eq? (Length (Cycle (First-five))) #f)
    8692  (= (Length (Append (First-five) (First-five))) 10)
    8793  (not (Length (Append (Cardinals) (First-five))))
     
    96102  (eq? (Length (Reverse* (Cardinals))) #f)
    97103  (equal? (List->list (Ref 5 (Reverse* (Cardinals)))) '(5 4 3 2 1 0))
    98   (equal? (List->list (Take 10 (Cycle (First-five))))
    99     '(0 1 2 3 4 0 1 2 3 4))
    100   (eq? (Length (Cycle (First-five))) #f)
    101104  (equal? (List->list (Sort < (First-five))) '(0 1 2 3 4))
    102105  (Sorted? < (First-five))
  • release/4/lazy-lists/trunk/lazy-lists.scm

    r29274 r29298  
    3232; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3333;
    34 ; Last update: June 28, 2013
     34; Last update: June 26, 2013
    3535;
    3636(require-library multi-methods)
     
    4040   List->list list->List input->List
    4141   First Rest Car Cdr Length Length-min Append Reverse
    42    List? Null? Realized? Reverse* Index
     42   List? Null? Realized? Reverse*
    4343   List-infinite? Realize
    4444   List-not-null? List-finite? Lists-one-finite?
    45    Take Drop Ref Take-upto Drop-upto
     45   Take Drop Ref Take-while Drop-while Count-while
    4646   Memp Member Memq Memv
    4747   Equ? Equal? Eq? Eqv?
     
    4949   Map Filter Sieve For-each
    5050   Iterate Repeat Repeatedly
    51    Cardinals Primes Cycle Interval
     51   Cardinals Primes Cycle Range
    5252   Nil Cons Merge Sort Sorted? Split-at Split-with
    5353   vector->List List->vector
     
    5656
    5757(import scheme
    58         (only data-structures compress list-of?)
     58        (only data-structures o compress list-of?)
    5959        (only chicken
    6060              define-record-type
     
    6565              add1
    6666              sub1
    67               fx+ fx= fx< fx-
     67              fx+ fx= fx>= fx< fx- fx/
     68              case-lambda
    6869              assert
    69               receive
     70              nth-value
    7071              unless))
    7172
     
    204205    (lambda (a b) b)))
    205206
    206 (define (Take-upto ok? Lst)
    207 ;  (let loop ((len (lazy-list-length Lst)) (Lst Lst))
    208 ;    (cond
    209 ;      ((Null? Lst) Nil)
    210 ;      ((ok? (First Lst))
    211 ;       (Lazy len
    212 ;         (cons (First Lst)
    213 ;               (loop (if len (- len 1) #f)
    214 ;                     (Rest Lst)))))
    215 ;      (else Nil))))
    216   (receive (head index tail) (Split-with ok? Lst)
    217     head))
    218 
    219 (define (Index ok? Lst)
    220   (receive (head index tail) (Split-with ok? Lst)
    221     index))
    222 
    223 (define (Drop-upto ok? Lst)
    224 ;  (let loop ((len (lazy-list-length Lst)) (Lst Lst))
    225 ;    (cond
    226 ;      ((Null? Lst) Nil)
    227 ;      ((ok? (First Lst))
    228 ;       (loop (if len (- len 1) #f)
    229 ;             (Rest Lst)))
    230 ;      (else
    231 ;        (Lazy len Lst)))))
    232   (receive (head index tail) (Split-with ok? Lst)
    233     tail))
     207(define (Take-while ok? Lst)
     208  (nth-value 0 (Split-with ok? Lst)))
     209
     210(define (Count-while ok? Lst)
     211  (nth-value 1 (Split-with ok? Lst)))
     212
     213(define (Drop-while ok? Lst)
     214  (nth-value 2 (Split-with ok? Lst)))
    234215
    235216(define (Memp ok? Lst)
    236   (Drop-upto ok? Lst))
     217  (Drop-while (o not ok?) Lst))
    237218
    238219(define (Memq var Lst)
     
    269250(define (Assp ok? al)
    270251  (let (
    271     (Lst (Drop-upto (lambda (pair) (ok? (car pair))) al))
     252    (Lst (Drop-while (lambda (pair) (not (ok? (car pair)))) al))
    272253    )
    273254    (if (Null? Lst) #f (First Lst))))
     
    336317            (Cons datum (loop))))));)
    337318
    338 (define (Repeat x)
    339   (Lazy #f (cons x (Repeat x))))
    340 
    341 (define (Repeatedly thunk)
    342   (Lazy #f (cons (thunk) (Repeatedly thunk))))
    343 
    344 (define (Iterate f x)
    345   (Lazy #f
    346     (cons x (Iterate f (f x)))))
    347 
    348 (define (Interval from upto)
    349   (Take (abs (- upto from))
    350         (Iterate (if (>= upto from) add1 sub1) from)))
     319(define Repeat
     320  (case-lambda
     321    ((x) (Lazy #f (cons x (Repeat x))))
     322    ((n x) (Take n (Repeat x)))))
     323
     324(define Repeatedly
     325  (case-lambda
     326    ((thunk) (Lazy #f (cons (thunk) (Repeatedly thunk))))
     327    ((n thunk) (Take n (Repeatedly thunk)))))
     328
     329(define Iterate
     330  (case-lambda
     331    ((f x) (Lazy #f (cons x (Iterate f (f x)))))
     332    ((n f x) (Take n (Iterate f x)))))
     333
     334(define Cycle
     335  (case-lambda
     336    ((Lst)
     337     (if (Null? Lst)
     338       Nil
     339       (let loop ((tail Lst))
     340         (Lazy #f
     341           (if (Null? tail)
     342             (loop Lst)
     343             (cons (First tail)
     344                   (loop (rest tail))))))))
     345    ((n Lst) (Take n (Cycle Lst)))))
     346
     347(define Range
     348  (case-lambda
     349    ((upto)
     350     (Iterate (abs upto)
     351              (if (fx>= upto 0)
     352                (cut fx+ <> 1)
     353                (cut fx- <> 1))
     354              0))
     355    ((from upto)
     356     (Iterate (abs (fx- upto from))
     357              (if (fx>= upto from)
     358                      (cut fx+ <> 1)
     359                      (cut fx- <> 1))
     360              from))
     361    ((from upto step)
     362     (Iterate (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step)
     363              (if (fx>= upto from)
     364                      (cut fx+ <> step)
     365                      (cut fx- <> step))
     366              from))))
    351367
    352368(define (Append2 Lst1 Lst2)
     
    387403    (Rest result)))
    388404
    389 (define (Cycle Lst)
    390   (if (Null? Lst)
    391       Nil
    392       (let loop ((tail Lst))
    393         (Lazy #f
    394           (if (Null? tail)
    395               (loop Lst)
    396               (cons (First tail)
    397                     (loop (rest tail))))))))
    398 
    399405(define (Merge <? Lst1 Lst2)
    400406  (let ((len (+ (lazy-list-length Lst1) (lazy-list-length Lst2))))
     
    454460(define (Split-with ok? Lst)
    455461  (let loop ((head Nil) (index 0) (tail Lst))
    456     (if (or (Null? tail) (ok? (First tail)))
     462    (if (or (Null? tail) (not (ok? (First tail))))
     463    ;(if (or (Null? tail) (ok? (First tail)))
    457464      (values (Reverse head) index tail)
    458465      (loop (Cons (First tail) head)
     
    568575              List? Null? Realized? Reverse*
    569576              List-infinite? Realize
    570               Take Drop Ref Take-upto Drop-upto
    571               Memp Member Memq Memv Index
     577              Take Drop Ref Take-while Drop-while
     578              Memp Member Memq Memv Count-while
    572579              Equ? Equal? Eq? Eqv?
    573580              Assp Assoc Assq Assv
    574581              Map Filter Sieve For-each
    575582              Iterate Repeat Repeatedly
    576               Cardinals Primes Cycle Interval
     583              Cardinals Primes Cycle Range
    577584              Merge Sort Sorted? Split-at Split-with
    578585              vector->List List->vector
     
    583590        (only methods method query-checker no-checker
    584591              method-check-args-and-call effects-checked?)
    585         (only chicken fixnum? fx>= fx<= fx- fx+ fx= fx<)
     592        (only chicken fixnum? fx>= fx<= fx- fx+ fx= fx< fx* fx/ signum)
    586593        (only data-structures o list-of? conjoin sort)
    587594        (prefix %lazy-lists %))
     
    664671  %Nil)
    665672
    666 (define Interval
    667   (method ('Interval
    668            %Interval
    669            (query-checker
    670              (lambda (from upto)
    671                (lambda (result)
    672                  (and (%List? result)
    673                       (= (%Length result) (abs (- upto from))))))
    674              '(List-of-proper-length? result)))
     673(define Range
     674  (method #t ; variadic
     675          ('Range
     676           %Range
     677           (query-checker
     678             (lambda (arg . args)
     679               (lambda (result)
     680                 (let (
     681                   (from (cond
     682                           ((null? args) 0)
     683                           ((null? (cdr args)) arg)))
     684                   (upto (cond
     685                           ((null? args) arg)
     686                           ((null? (cdr args)) (car args))))
     687                   (step (cond
     688                           ((null? args) (signum arg))
     689                           ((null? (cdr args)) (signum (fx- (car args) arg)))
     690                           (else (fx* (abs (cadr args))
     691                                      (signum (fx- (car args) arg))))))
     692                   )
     693                   (and (%List-finite? result)
     694                        (fx= (%Length result)
     695                             (fx/ (fx+ (fx- step 1) (abs (fx- upto from))) step))))))
     696             '(and (List-finite? result)
     697                  (= (Length result)
     698                     (quotient (+ (- step 1) (abs (- upto from))) step)))))
    675699          ('1integer? integer?)
    676           ('2integer? integer?)))
     700          ('2integers? (list-of? integer?))))
    677701
    678702(define Cardinals
     
    890914             (lambda (n Lst)
    891915               (lambda (head tail)
    892                  (and (%List? head) (%Length head)
     916                 (and (%List? head) (%Length head) (%List tail)
    893917                      (if (%Length Lst)
    894918                        (and (fx= (%Length head) (min n (%Length Lst)))
     
    897921                        (and (fx= (%Length head) n)
    898922                             (not (%Length tail)))))))
    899              '(and (List? head) (Length head)
     923             '(and (List? head) (Length head) (List tail)
    900924                   (if (Length Lst)
    901925                     (and (= (Length head) (min n (Length Lst)))
     
    917941          (<= (Length result) (Length Lst)))))
    918942
    919 (define Take-upto
    920   (method ('Take-upto %Take-upto Sublist-finite-checker)
     943(define Take-while
     944  (method ('Take-while %Take-while Sublist-finite-checker)
    921945          ('1unary-predicate? procedure?)
    922946          ('2List-finite? %List-finite?)))
    923947
    924 (define Drop-upto
    925   (method ('Drop-upto %Drop-upto Sublist-finite-checker)
     948(define Drop-while
     949  (method ('Drop-while %Drop-while Sublist-finite-checker)
    926950          ('1unary-predicate? procedure?)
    927951          ('2List-finite? %List-finite?)))
     
    966990          ('2List-finite? %List-finite?)))
    967991
    968 (define Index
    969   (method ('Index
    970            %Index
     992(define Count-while
     993  (method ('Count-while
     994           %Count-while
    971995           (query-checker
    972996             (lambda (ok? Lst)
     
    11111135    '(and (List result) (not (Length result)))))
    11121136
     1137(define List-of-given-length-checker
     1138  (query-checker
     1139    (lambda args
     1140      (lambda (result)
     1141        (if (null? (cdr args))
     1142          (%List-infinite? result)
     1143          (and (%List? result)
     1144               (fx= (%Length result) (car args))))))
     1145    '(if (null? (cdr args))
     1146       (List-infinite? result)
     1147       (and (List? result)
     1148            (= (Length result) (car args))))))
     1149
     1150(define (any-or-index+any? args)
     1151  (and (list? args)
     1152       (<= 1 (length args) 2)
     1153       (if (null? (cdr args))
     1154         (any? (car args))
     1155         (and (%List-index? (car args))
     1156              (any? (cadr args))))))
     1157
    11131158(define Repeat
    1114   (method ('Repeat %Repeat List-infinite-checker)
    1115           ('1any? any?)))
     1159  (method #t ; variadic
     1160          ('Repeat
     1161           %Repeat
     1162           List-of-given-length-checker)
     1163          ('1any-or-index+any? any-or-index+any?)))
    11161164
    11171165(define Repeatedly
    1118   (method ('Repeatedly %Repeatedly List-infinite-checker)
    1119           ('1thunk? procedure?)))
     1166  (method #t ; variadic
     1167          ('Repeatedly %Repeatedly List-of-given-length-checker)
     1168          ('1thunk-or-index+thunk?
     1169           (lambda (args)
     1170             (and (list? args)
     1171                  (<= 1 (length args) 2)
     1172                  (if (null? (cdr args))
     1173                    (procedure? (car args))
     1174                    (and (%List-index? (car args))
     1175                         (procedure? (cadr args)))))))))
    11201176
    11211177(define Iterate
    1122   (method ('Iterate %Iterate List-infinite-checker)
    1123           ('1unary-procedure? procedure?)
    1124           ('2any? any?)))
     1178  (method #t ;variadic
     1179          ('Iterate %Iterate List-of-given-length-checker)
     1180          ('1proc+any-or-index+proc+any?
     1181           (lambda (args)
     1182             (and (list? args)
     1183                  (<= 2 (length args) 3)
     1184                  (if (null? (cddr args))
     1185                    (procedure? (car args))
     1186                    (and (%List-index? (car args))
     1187                         (procedure? (cadr args)))))))))
    11251188
    11261189(define Cycle
    1127   (method ('Cycle %Cycle List-infinite-checker)
    1128           ('1List-finite? %List-finite?)))
     1190  (method #t ; variadic
     1191          ('Cycle %Cycle List-of-given-length-checker)
     1192          ('1List-finite-or-index+List-finite?
     1193           (lambda (args)
     1194             (and (list? args)
     1195                  (<= 1 (length args) 2)
     1196                  (if (null? (cdr args))
     1197                    (%List-finite? (car args))
     1198                    (and (%List-index? (car args))
     1199                         (%List-finite? (cadr args)))))))))
    11291200
    11301201(define Append
     
    12911362       First Rest Length Append Reverse
    12921363       Reverse*
    1293        Take Drop Ref Take-upto Drop-upto
    1294        Memp Member Memq Memv Index
     1364       Take Drop Ref Take-while Drop-while
     1365       Memp Member Memq Memv Count-while
    12951366       Assp Assoc Assq Assv
    12961367       Map Filter Sieve For-each
    12971368       Iterate Repeat Repeatedly
    1298        Cardinals Primes Cycle Interval
     1369       Cardinals Primes Cycle Range
    12991370       Merge Sort Sorted? Split-at Split-with
    13001371       vector->List List->vector
     
    13061377) ; module lazy-lists
    13071378
    1308 
  • release/4/lazy-lists/trunk/lazy-lists.setup

    r29274 r29298  
    88 'lazy-lists
    99 '("lazy-lists.so" "lazy-lists.import.so" "%lazy-lists.import.so")
    10  '((version "0.4")))
     10 '((version "0.5")))
  • release/4/lazy-lists/trunk/tests/run.scm

    r29251 r29298  
    88      (cons var lst)
    99      (cons (car lst) (cons-right var (cdr lst)))))
    10 
    11 ;(define port (open-input-file "lazy-lists.scm"))
    12 ;(define input (input->List port read-line))
    1310
    1411(run-tests
     
    3532  (equal? (List->list (First-five)) '(0 1 2 3 4))
    3633  (equal? (List->list (Take 5 (Cardinals))) '(0 1 2 3 4))
    37   (= (Length (Interval 2 10)) (- 10 2))
    38   (equal? (List->list (Interval 2 10)) '(2 3 4 5 6 7 8 9))
    39   (equal? (List->list (Interval 10 2)) '(10 9 8 7 6 5 4 3))
     34  (= (Length (Range 2 10)) (- 10 2))
     35  (= (Length (Range 10)) 10)
     36  (= (Length (Range -1 10 2)) 6)
     37  (equal? (List->list (Range -1 10 2)) '(-1 1 3 5 7 9))
     38  (equal? (List->list (Range 2 10)) '(2 3 4 5 6 7 8 9))
     39  (equal? (List->list (Range 10 2)) '(10 9 8 7 6 5 4 3))
    4040  (equal?
    41     (receive (head index tail) (Split-with (cut = <> 3) (First-five))
     41    (receive (head index tail) (Split-with (cut < <> 3) (First-five))
    4242      (cons (First tail) (List->list head)))
    4343    '(3 0 1 2))
    4444  (equal?
    45     (receive (head index tail) (Split-with (cut = <> 5) (Take 10 (Cardinals)))
     45    (receive (head index tail) (Split-with (cut < <> 5) (Take 10 (Cardinals)))
    4646      (append (List->list tail) (List->list head)))
    4747    '(5 6 7 8 9 0 1 2 3 4))
    48   (= (Index (cut = <> 2) (First-five)) 2)
    49   (= (Index (cut = <> 20) (First-five)) 5)
    50   (equal? (List->list (Take-upto (cut = <> 5) (Take 10 (Cardinals))))
     48  (= (Count-while (cut < <> 2) (First-five)) 2)
     49  (= (Count-while (cut < <> 20) (First-five)) 5)
     50  (equal? (List->list (Take-while (cut < <> 5) (Take 10 (Cardinals))))
    5151       '(0 1 2 3 4))
    52   (= (Length (Take-upto (cut = <> 5) (Take 10 (Cardinals)))) 5)
    53   (= (Length (Drop-upto (cut = <> 5) (Take 10 (Cardinals)))) 5)
    54   (= (First (Drop-upto (cut = <> 5) (Take 10 (Cardinals)))) 5)
    55   (= (Length (Drop-upto (cut = <> 2) (First-five))) 3)
    56   (= (First (Drop-upto (cut = <> 2) (First-five))) 2)
     52  (= (Length (Take-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     53  (= (Length (Drop-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     54  (= (First (Drop-while (cut < <> 5) (Take 10 (Cardinals)))) 5)
     55  (= (Length (Drop-while (cut < <> 2) (First-five))) 3)
     56  (= (First (Drop-while (cut < <> 2) (First-five))) 2)
    5757  (equal? (List->list (Memp odd? (First-five))) '(1 2 3 4))
    5858  (equal? (List->list (Memv 5 (Take 10 (Cardinals)))) '(5 6 7 8 9))
     
    7979  (= (Ref 25 (Cardinals)) 25)
    8080  (= (Ref 2 (First-five)) 2)
    81   (equal? (List->list (Take 3 (Repeat #f))) '(#f #f #f))
    82   (equal? (List->list (Take 3 (Repeatedly (lambda () 1))))
     81  (equal? (List->list (Repeat 3 #f)) '(#f #f #f))
     82  (List-infinite? (Repeatedly (lambda () 1)))
     83  (equal? (List->list (Repeatedly 3 (lambda () 1)))
    8384    '(1 1 1))
    84   (equal? (List->list (Take 3 (Iterate add1 0))) '(0 1 2))
     85  (List-infinite? (Iterate add1 0))
     86  (List-finite? (Iterate 3 add1 0))
     87  (equal? (List->list (Iterate 3 add1 0)) '(0 1 2))
    8588  (eq? (Length (Iterate add1 0)) #f)
     89  (equal? (List->list (Cycle 10 (First-five)))
     90    '(0 1 2 3 4 0 1 2 3 4))
     91  (eq? (Length (Cycle (First-five))) #f)
    8692  (= (Length (Append (First-five) (First-five))) 10)
    8793  (not (Length (Append (Cardinals) (First-five))))
     
    96102  (eq? (Length (Reverse* (Cardinals))) #f)
    97103  (equal? (List->list (Ref 5 (Reverse* (Cardinals)))) '(5 4 3 2 1 0))
    98   (equal? (List->list (Take 10 (Cycle (First-five))))
    99     '(0 1 2 3 4 0 1 2 3 4))
    100   (eq? (Length (Cycle (First-five))) #f)
    101104  (equal? (List->list (Sort < (First-five))) '(0 1 2 3 4))
    102105  (Sorted? < (First-five))
Note: See TracChangeset for help on using the changeset viewer.