; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2013-2019, Juergen Lorenz
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
;
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following dispasser.
;
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser in the
; documentation and/or other materials provided with the distribution.
;
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#|[
This is another implementation of lazy-lists. Contrary to other
implementations this one
-- is able to distinguish between finite and infinite lazy lists
-- implements most routines so that they can be used as partial routines
-- all routines are named with uppercase first letter, so that
they don't conflict with equally named standard list routines
-- arguments have standard orders:
procedure arguments first, biglist arguments last
]|#
(module biglists (
Append
Assoc
Assp
Assq
Assv
At
BigList?
BigList->list
Cons
Cycle
Cycle-times
Drop
Drop-while
Drop-until
Eager?
Eq?
Eqp?
Equal?
Eqv?
Every?
Filter
Fold-left
Fold-left0
Fold-right
Fold-right0
For
For-each
First
Index
Iterate
Iterate-times
Iterate-until
Iterate-while
Lazy?
Length
List
List?
List-of?
Map
Member
Memp
Memq
Memv
Merge
Null?
Print
Range
Read-forever
Remove
Remp
Remq
Remv
Repeat
Repeat-times
Rest
Reverse
Reverse*
Scan-left
Scan-right
Some?
Sort
Sorted?
Take
Take-until
Take-while
Unzip
Zip
biglist-lazy
biglists
eos
)
(import scheme (chicken base) (only bindings eos bind-seq-db))
(define (and? . xprs)
(call/cc
(lambda (out)
(for-each (lambda (x) (or x (out #f)))
xprs)
#t)))
(define-record-type lazy
(biglist-lazy first rest finite?)
lazy?
(first lazy-first)
(rest lazy-rest)
(finite? lazy-finite?))
(define-record-printer (lazy xs out)
(let ((start "(Lazy[") (stop ")"))
(display start out)
(display (if (List? xs)
"finite"
"infinite") out)
(display "]" out)
(cond ((and (Lazy? xs) (List? xs))
(let loop ((xs xs))
(if (Null? xs)
(display stop out)
(begin
(display " " out)
(write (First xs) out)
(loop (Rest xs))))))
((and (Lazy? xs) (not (List? xs)))
(let loop ((k 0) (xs xs))
(cond
((= k 10)
(display " ..." out)
(display stop out))
(else
(display " " out)
(write (First xs) out)
(loop (+ k 1) (Rest xs)))))))))
(define-syntax Cons
(syntax-rules ()
((_ x y finite?)
(biglist-lazy (delay x) (delay y) finite?))
((_ x y) (cons x y))
))
(define (BigList? xpr)
(or
(list? xpr)
(eq? xpr eos) ;;;;;;
(and (lazy? xpr)
(promise? (lazy-first xpr))
(promise? (lazy-rest xpr))
(boolean? (lazy-finite? xpr)))
))
(define Eager? list?)
(define (Lazy? xpr)
(and (BigList? xpr) (not (list? xpr))))
(define (List? xpr) ; finite
(or (eq? xpr eos)
(Eager? xpr)
(and (Lazy? xpr)
(lazy-finite? xpr))))
(define List-of?
(case-lambda
(oks?
(lambda (xpr)
(apply and?
(List? xpr)
(BigList->list
(Map (lambda (x)
(apply and?
(map (lambda (ok?) (ok? x))
oks?)))
xpr)))))
((k . oks?)
(lambda (xpr)
(and (BigList? xpr)
((apply List-of? oks?)
(Take k xpr)))))
))
(define (Null? xs)
(and (BigList? xs)
(or (eqv? xs '())
(eq? xs eos))))
(define (First xs)
(cond
((Eager? xs)
(if (null? xs)
eos
(car xs)))
((Lazy? xs)
(if (Null? xs)
eos
(force (lazy-first xs))))
(else (error 'First "not a biglist" xs))))
(define (Rest xs)
(cond
((list? xs)
(if (null? xs)
'()
(cdr xs)))
((Lazy? xs)
(if (Null? xs)
xs
(force (lazy-rest xs))))
(else (error 'Rest "not a biglist" xs))))
(define (Length xs)
(if (BigList? xs)
(cond
((Eager? xs) (length xs))
((List? xs)
(if (Null? xs)
0
(+ 1 (Length (Rest xs)))))
(else #f))
(error 'Length "not a biglist" xs)
))
(define (At n . xss)
(cond
((null? xss)
(lambda (xs)
(At n xs)))
((null? (cdr xss))
(let ((xs (car xss)))
(if (BigList? xs)
(if (zero? n)
(First xs)
(At (- n 1) (Rest xs)))
(error 'At "not a biglist" xs))))
(else (error 'At "too many arguments"))))
(define (List . args)
(if (null? args)
eos
(Cons (car args)
(apply List (cdr args))
#t)))
(define (Take k . xss)
(cond
((null? xss)
(lambda (xs)
(Take k xs)))
((null? (cdr xss))
(let ((xs (car xss)))
(if (BigList? xs)
(let ((eager? (Eager? xs)))
(cond
((Null? xs) xs)
((zero? k) (if eager? '() eos))
(else
(if eager?
(Cons (First xs) (Take (- k 1) (Rest xs)))
(Cons (First xs) (Take (- k 1) (Rest xs)) #t)))))
(error 'Take "not a biglist" xs))))
; (cond
; ((Eager? xs)
; (if (zero? k)
; '()
; (Cons (First xs) (Take (- k 1) (Rest xs)))))
; ((Lazy? xs)
; (if (zero? k)
; eos
; (Cons (First xs) (Take (- k 1) (Rest xs)) #t)))
; (else (error 'Take "not a biglist" xs)))))
(else (error 'Take "too many arguments"))))
(define (Take-while ok? . xss)
(cond
((null? xss)
(lambda (xs)
(Take-while ok? xs)))
((null? (cdr xss))
(let ((xs (car xss)))
(cond
((Eager? xs)
(let recur ((xs xs))
(cond
((null? xs) xs)
((ok? (First xs))
(Cons (First xs) (recur (Rest xs))))
(else '()))))
((Lazy? xs)
(let recur ((xs xs))
(if (ok? (First xs))
(Cons (First xs) (recur (Rest xs)) #t)
eos)))
(else (error 'Take-while "not a biglist" xs)))))
(else (error 'Take-while "too many arguments"))))
(define (Take-until ok? . xss)
(cond
((null? xss)
(lambda (xs)
(Take-while ok? xs)))
((null? (cdr xss))
(let ((xs (car xss)))
(cond
((Eager? xs)
(let recur ((xs xs))
(cond
((null? xs) xs)
((ok? (First xs)) '())
(else
(Cons (First xs) (recur (Rest xs)))))))
((Lazy? xs)
(let recur ((xs xs))
(cond
((Null? xs) xs)
((ok? (First xs))
eos)
(else
(Cons (First xs) (recur (Rest xs)) #t)))))
(else (error 'Take-until "not a biglist" xs)))))
(else (error 'Take-while "too many arguments"))))
(define (Drop k . xss)
(cond
((null? xss)
(lambda (xs)
(Drop k xs)))
((null? (cdr xss))
(let ((xs (car xss)))
(if (BigList? xs)
(if (zero? k)
xs
(Drop (- k 1) (Rest xs)))
(error 'Drop "not a biglist" xs))))
(else (error 'Drop "too many arguments"))))
(define (Drop-while ok? . xss)
(cond
((null? xss)
(lambda (xs)
(Drop-while ok? xs)))
((null? (cdr xss))
(let* ((xs (car xss))
(nil (cond
((Eager? xs) '())
((Lazy? xs) eos)
(error 'Drop-while "not a biglist" xs))))
(let loop ((xs xs))
(cond
((Null? xs) nil)
((ok? (First xs))
(loop (Rest xs)))
(else xs)))))
(else (error 'Drop-while "too many arguments"))))
(define (Drop-until ok? . xss)
(cond
((null? xss)
(lambda (xs)
(Drop-while ok? xs)))
((null? (cdr xss))
(let* ((xs (car xss))
(nil (cond
((Eager? xs) '())
((Lazy? xs) eos)
(error 'Drop-until "not a biglist" xs))))
(let loop ((xs xs))
(cond
((Null? xs) nil)
((ok? (First xs)) xs)
(else (loop (Rest xs)))))))
(else (error 'Drop-until "too many arguments"))))
(define BigList->list
(case-lambda
((xs)
(if (List? xs)
(BigList->list (Length xs) xs)
(error 'BigList->list "not a biglist" xs)))
((k . xss)
(cond
((null? xss)
(lambda (xs)
(BigList->list k xs)))
((null? (cdr xss))
(let ((xs (car xss)))
(cond
((Eager? xs) xs)
((Lazy? xs)
(let recur ((n 0) (xs xs))
(cond
((Null? xs) '())
((= n k) '())
(else
(Cons (First xs)
(recur (+ n 1) (Rest xs)))))))
(else (error 'BigList->list "not a biglist" xs)))))
(else
(error 'BigList->list "too many arguments"))))
))
(define (Filter ok? . xss)
(cond
((null? xss)
(lambda (xs)
(Filter ok? xs)))
((null? (cdr xss))
(let ((xs (car xss)))
; ;; this version is inefficient:
; ;; it checks for Eager again and again
; (if (BigList? xs)
; (let recur ((xs xs))
; (cond
; ((Null? xs)
; (if (Eager? xs) '() eos))
; ((ok? (First xs))
; (if (Eager? xs)
; (Cons (First xs) (recur (Rest xs)))
; (Cons (First xs)
; (recur (Rest xs))
; (List? xs))))
; (else (recur (Rest xs)))))
; (error 'Filter "not a biglist" xs))))
(cond
((Eager? xs)
(let recur ((xs xs))
(cond
((Null? xs) xs)
((ok? (First xs))
(Cons (First xs) (recur (Rest xs))))
(else (recur (Rest xs))))))
((Lazy? xs)
(let recur ((xs xs))
(cond
((Null? xs) eos);xs)
((ok? (First xs))
(Cons (First xs)
(recur (Rest xs))
(List? xs)))
(else (recur (Rest xs))))))
(else
(error 'Filter "not a biglist" xs)))))
(else
(error 'Filter "too many arguments"))
))
(define (Map fn . xss)
(if (null? xss)
(lambda lists
(apply Map fn lists))
(let ((xs (car xss)))
(cond
((Eager? xs)
(if ((list-of? BigList?) (cdr xss))
(let recur ((xss xss))
(if (memv #t (map Null? xss))
'()
(cons (apply fn (map First xss))
(recur (map Rest xss)))))
(error 'Map "not a list of biglists" xss)))
((Lazy? xs)
(if ((list-of? BigList?) (cdr xss))
(let recur ((xss xss))
(if (memv #t (map Null? xss))
eos
(Cons (apply fn (map First xss))
(recur (map Rest xss))
(and? (map List? xss)))))
(error 'Map "not a list of biglists" xss)))
(else
(error 'Map "not a biglists" xs))
))
))
(define (For-each fn . xss)
(if ((list-of? BigList?) xss)
(if (null? xss)
(lambda lists
(apply For-each fn lists))
(unless (memq #t (map Null? xss))
(cond
(((list-of? Eager?) xss)
(apply fn (map First xss))
(apply For-each fn (map Rest xss)))
(((list-of? Lazy?) xss)
(apply fn (map First xss))
(apply For-each fn (map Rest xss)))
(else
(error 'For-each "not all either eager or lazy" xss))
)))
(error 'For-each "not a list of biglists" xss)
))
(define (Append xs . xss)
(if (BigList? xs)
(cond
((null? xss) xs)
((null? (cdr xss))
(let ((ys (First xss)))
(cond
((and (List? xs) (Eager? ys))
(if (Null? xs)
ys
(Cons (First xs) (Append (Rest xs) ys))))
((and (List? xs) (BigList? ys))
(if (Null? xs)
ys
(Cons (First xs)
(Append (Rest xs) ys)
(List? ys))))
(else
(error 'Append "invalid arguments" xs ys)))))
(else
(Append xs (apply Append (car xss) (cdr xss)))))
(error 'Append "not a biglist" xs)))
(define (Reverse xs . xss)
(cond
((null? xss)
(cond
((Eager? xs)
(Reverse xs '()))
((List? xs)
(Reverse xs eos))
(else (error "not a finite biglist" xs))))
((null? (cdr xss))
(let ((ys (car xss)))
(cond
((and (Eager? xs) (Eager? ys))
(let loop ((xs xs) (result ys))
(if (Null? xs)
result
(loop (Rest xs)
(Cons (First xs) result)))))
((and (List? xs) (Eager? ys))
(let loop ((xs xs) (result ys))
(if (Null? xs)
result
(loop (Rest xs)
(Cons (First xs) result)))))
((and (Eager? xs) (BigList? ys))
(let loop ((xs xs) (result ys))
(if (Null? xs)
result
(loop (Rest xs)
(Cons (First xs) result (List? ys))))))
((and (List? xs) (BigList? ys))
(let loop ((xs xs) (result ys))
(if (Null? xs)
result
(loop (Rest xs)
(Cons (First xs) result (List? ys))))))
(else
(error 'Reverse "invalid arguments" xs ys)))))
(else (error 'Reverse "too many arguments"))))
(define (Reverse* xs)
(cond
((Eager? xs)
(let recur ((k 0))
(if (> k (Length xs))
'()
(Cons (Reverse (Take k xs)) (recur (+ k 1))))))
((BigList? xs)
(let recur ((k 0))
(cond
((not (Length xs))
(Cons (Reverse (Take k xs))
(recur (+ k 1))
#f))
(else
(if (> k (Length xs))
eos
(Cons (Reverse (Take k xs))
(recur (+ k 1))
#t))
))))
(else (error 'Reverse* "not a biglist" xs))))
(define (Zip xs ys)
(cond
((and (Eager? xs) (Eager? ys))
(let recur ((xs xs) (ys ys))
(if (Null? xs)
ys
(Cons (First xs) (recur ys (Rest xs))))))
((and (BigList? xs) (BigList? ys))
(let recur ((xs xs) (ys ys))
(if (Null? xs)
ys
(Cons (First xs)
(recur ys (Rest xs))
(and (List? xs) (List? ys))))))
(else
(error 'Zip "invalid arguments" xs ys))))
(define (Unzip xs)
(cond
((Eager? xs)
(let ((one
(let ((ev? #f))
(let recur ((xs xs))
(cond
((Null? xs) '())
(else
(set! ev? (not ev?))
(if ev?
(Cons (First xs) (recur (Rest xs)))
(recur (Rest xs))
))))))
(two
(let ((ev? #f))
(let recur ((xs xs))
(cond
((Null? xs) '())
(else
(set! ev? (not ev?))
(if ev?
(recur (Rest xs))
(Cons (First xs) (recur (Rest xs))))))))))
(values one two)))
((BigList? xs)
(let ((finite? (List? xs)))
(let ((one
(let ((ev? #f))
(let recur ((xs xs))
(cond
((Null? xs) eos)
(else
(set! ev? (not ev?))
(if ev?
(Cons (First xs) (recur (Rest xs)) finite?)
(recur (Rest xs))
))))))
(two
(let ((ev? #f))
(let recur ((xs xs))
(cond
((Null? xs) eos)
(else
(set! ev? (not ev?))
(if ev?
(recur (Rest xs))
(Cons (First xs) (recur (Rest xs)) finite?))))))))
(values one two))))
(else (error 'Unzip "not a biglist" xs))))
(define (Sorted? var) xss))
(define (Memv var . xss)
(apply Memp (cut eqv? <> var) xss))
(define (Member var . xss)
(apply Memp (cut equal? <> var) xss))
(define Eqp?
(case-lambda
((=?)
(lambda (xs ys)
(Eqp? =? xs ys)))
((=? xs ys)
(cond
((and (Eager? xs) (Lazy? ys)) #f)
((and (Lazy? xs) (Eager? ys)) #f)
((not (eqv? (Length xs) (Length ys))) #f)
((and (List? xs) (List? ys))
(let loop ((xs xs) (ys ys))
(cond
((and (Null? xs) (Null? ys))
#t)
((=? (First xs) (First ys))
(loop (Rest xs) (Rest ys)))
(else #f))))
((and (BigList? xs) (BigList? ys))
(eqv? xs ys))
(else (equal? xs ys))))
))
(define Eq? (Eqp? eq?))
(define Eqv? (Eqp? eqv?))
(define Equal? (Eqp? equal?))
(define (Assp ok? . xss)
(cond
((null? xss)
(lambda (xs)
(Assp ok? xs)))
((null? (cdr xss))
(let ((xs (car xss)))
(cond
(((List-of? BigList?) xs)
(let loop ((xs xs))
(cond
((Null? xs) #f)
((ok? (First (First xs)))
(First xs))
(else (loop (Rest xs))))))
(else (error 'Assp "not a finite biglist" xs)))))
(else (error 'Assp "too many arguments"))
))
(define (Assq key . xss)
(apply Assp (cut eq? <> key) xss))
(define (Assv key . xss)
(apply Assp (cut eqv? <> key) xss))
(define (Assoc key . xss)
(apply Assp (cut equal? <> key) xss))
(define (Remp ok? . xss)
(cond
((null? xss)
(lambda (xs) (Remp ok? xs)))
((null? (cdr xss))
(Filter (o not ok?) (car xss)))
(else (error 'Remp "too many arguements"))))
(define (Remove val . xss)
(apply Remp (cut equal? <> val) xss))
(define (Remq val . xss)
(apply Remp (cut eq? <> val) xss))
(define (Remv val . xss)
(apply Remp (cut eqv? <> val) xss))
(define (Fold-right op init . xss)
(cond
((null? xss)
(lambda pairs
(apply Fold-right op init pairs)))
(else
(if ((list-of? BigList?) xss)
(let recur ((xss xss))
(if (memv #t (map List? xss))
(cond
((memv #t (map Null? xss)) init)
(else
(apply op
(append (map First xss)
(list (recur (map Rest xss)))))))
(error 'Fold-right "all biglists infinite")))
(error 'Fold-right "not a list of biglists" xss)))
))
(define (Fold-left op init . xss)
(cond
((null? xss)
(lambda pairs
(apply Fold-left op init pairs)))
(else
(if ((list-of? BigList?) xss)
(let loop ((xss xss) (result init))
(if (memv #t (map List? xss))
(cond
((memv #t (map Null? xss)) result)
(else
(loop (map Rest xss)
(apply op result (map First xss)))))
(error 'Fold-left "all biglists infinite")))
(error 'Fold-left "not a list of biglists" xss)))
))
(define (Fold-right0 op . xss)
(cond
((null? xss)
(lambda pairs
(apply Fold-right0 op pairs)))
(else
(if ((list-of? List?) xss)
(let ((cars (map First xss)))
(if (not (memq eos cars))
(apply Fold-right
op
(apply op cars)
(map Rest xss))
(error 'Fold-right0 "some biglist empty")))
(error 'Fold-right0 "not a list of finite biglists" xss)))))
;(define (Fold-right0 op . xss)
; (cond
; ((null? xss)
; (lambda (xs)
; (Fold-right0 op xs)))
; ((null? (cdr xss))
; (let ((xs (car xss)))
; (if (List? xs)
; (if (Null? xs)
; (error 'Fold-right0 "biglist empty")
; (Fold-right op (First xs) (Rest xs)))
; (error 'Fold-ritht0 "not a finite biglist"))))
; (else (error 'Fold-right0 "too many arguments"))))
(define (Fold-left0 op . xss)
(cond
((null? xss)
(lambda pairs
(apply Fold-left0 op pairs)))
(else
(if ((list-of? List?) xss)
(let ((cars (map First xss)))
(if (not (memq eos cars))
(apply Fold-left
op
(apply op cars)
(map Rest xss))
(error 'Fold-left0 "some biglist empty")))
(error 'Fold-left0 "not a list of finite biglists" xss)))))
;(define (Fold-right0 op . xss)
; (cond
; ((null? xss)
; (lambda (xs)
; (Fold-left0 op xs)))
; ((null? (cdr xss))
; (let ((xs (car xss)))
; (if (List? xs)
; (if (Null? xs)
; (error 'Fold-left0 "biglist empty")
; (Fold-left op (First xs) (Rest xs)))
; (error 'Fold-left0 "not a finite biglist"))))
; (else (error 'Fold-left0 "too many arguments"))))
(define (Scan-right op init . xss)
(cond
((null? xss)
(lambda pairs
(apply Scan-right op init pairs)))
(else
(if ((list-of? BigList?) xss)
(let ((finite?
(if (memv #t (map List? xss)) #t #f)))
(let recur ((n 0) (tails xss))
(if (memv #t (map Null? tails))
eos
(Cons (apply Fold-right op init (map (Take n) xss))
(recur (+ n 1) (map Rest tails))
finite?))))
(error 'Scan-right "not a list of biglists" xss)))))
(define (Scan-left op init . xss)
(cond
((null? xss)
(lambda pairs
(apply Scan-left op init pairs)))
(else
(if ((list-of? BigList?) xss)
(let ((finite?
(if (memv #t (map List? xss)) #t #f)))
(let recur ((n 0) (tails xss))
(if (memv #t (map Null? tails))
eos
(Cons (apply Fold-left op init (map (Take n) xss))
(recur (+ n 1) (map Rest tails))
finite?))))
(error 'Scan-left "not a list of biglists" xss)))))
(define Range
(case-lambda
((upto)
(cond
((not upto) ; infinite case
(Range 0 upto 1))
((>= upto 0)
(Range 0 upto 1))
(else
(Range 0 upto -1))))
((from upto)
(cond
((not upto) ; infinite case
(Range from upto 1))
((>= upto from)
(Range from upto 1))
(else
(Range from upto -1))))
((from upto step)
(let ((from (if (integer? from)
from
(error 'Range "not an integer" from)))
(upto (if (or (not upto) (integer? upto))
upto
(error 'Range "neither an integer nor #f" upto)))
(step (if (integer? step)
step
(error 'Range "not an integer" step))))
(let recur ((k from))
(cond
((not upto) ; infinite case
(Cons k (recur (+ k step)) #f))
((and (>= upto from) (positive? step))
(if (>= k upto)
eos
(Cons k (recur (+ k step)) #t)))
((and (< upto from) (negative? step))
(if (<= k upto)
eos
(Cons k (recur (+ k step)) #t)))
(else
(error 'Range "wrong sign of" step))))))
))
(define (Repeat x)
(Cons x (Repeat x) #f))
(define (Repeat-times k x)
(Take k (Repeat x)))
(define (Iterate-while fn ok? . xs)
(Take-while ok? (apply Iterate fn xs)))
(define (Iterate-until fn ok? . xs)
(Take-until ok? (apply Iterate fn xs)))
(define (Iterate-times fn k . xs)
(Take k (apply Iterate fn xs)))
(define (Iterate fn . xs)
(cond
((null? xs)
(lambda (x)
(Iterate fn x)))
((null? (cdr xs))
(let recur ((x (First xs)))
(Cons x (recur (fn x)) #f)))
(else 'Iterate "too many arguments")))
(define (Cycle xs)
(cond
((Eager? xs)
(Cycle (apply List xs)))
((List? xs)
(if (Null? xs)
eos
(let recur ((tail xs))
(if (Null? tail)
(recur xs)
(Cons (First tail) (recur (Rest tail)) #f)))))
(else (error 'Cycle "not a finite biglist" xs))))
(define (Cycle-times k xs)
(Take k (Cycle xs)))
(define Print
(case-lambda
((k xs)
(if (BigList? xs)
(let loop ((n 0) (xs xs))
(unless (= n k)
(print (First xs))
(loop (+ n 1) (Rest xs))))
(error 'Print "not a biglist" xs)))
((xs)
(if (List? xs)
(let ((xs xs))
(Print (Length xs) xs))
(error 'Print "not a finite biglist" xs)))
))
;;; (For item-xpr (var xs ok-xpr ...) (var1 xs1 ok-xpr1 ...) ...)
;;; -------------------------------------------------------------
(define-syntax For
(syntax-rules ()
((_ item-xpr (var xs ok-xpr ...))
(cond
((Eager? xs)
(let recur ((seq xs))
(if (Null? seq)
'()
(let ((var (First seq)))
(if (and ok-xpr ...)
(Cons item-xpr (recur (Rest seq)))
(recur (Rest seq)))))))
((Lazy? xs)
(let recur ((seq xs))
(if (Null? seq)
eos
(let ((var (First seq)))
(if (and ok-xpr ...)
(Cons item-xpr (recur (Rest seq)) #t)
(recur (Rest seq)))))))
(else (error 'For "not a biglist" xs))))
((_ item-xpr (var xs ok-xpr ...) (var1 xs1 ok-xpr1 ...) ...)
(let recur ((seq xs))
(if (Null? seq)
(cond
((Eager? seq) '())
((Lazy? seq) eos)
(else (error 'For "not a biglist" seq)))
(let ((var (First seq)))
(if (and ok-xpr ...)
(Append (For item-xpr (var1 xs1 ok-xpr1 ...) ...)
(recur (Rest seq)))
(recur (Rest seq)))))))
))
(define (Read-forever)
(Map (lambda (x) (x))
(Repeat (lambda ()
(print* "enter a scheme object (stop with Ctrl-C): ")
(let ((obj (read)))
(print obj)
obj)))))
;;; make biglists accessible to pattern matching
;;; ----------------------------------------------
(bind-seq-db BigList?
#:ref (lambda (xs k) (At k xs))
#:tail (lambda (xs k) (Drop k xs)))
;(define (integers-from n)
; (Cons n (integers-from (+ n 1)) #f))
;
;(define integers (integers-from 0))
;;; (biglists sym ..)
;;; ----------------------------
;;; documentation procedure
(define biglists
(let ((als '(
(biglists
procedure:
(biglists sym ..)
"documentation procedure")
(Append
procedure:
(Append xs . xss)
"appends all argument lists, provided all but the last"
"are finite")
(Assoc
procedure:
(Assoc key)
(Assoc key xs)
"returns the biglist, whose First or car is Equal? to key")
(Assp
procedure:
(Assp ok?)
(Assp ok? xs)
"returns the biglist, whose First or car passes ok?")
(Assq
procedure:
(Assq key)
(Assq key xs)
"returns the biglist, whose First or car is Eq? to key")
(Assv
procedure:
(Assv key)
(Assv key xs)
"returns the biglist, whose First or car is Eqv? to key")
(At
procedure:
(At k)
(At k xs)
"returns the kth item of xs")
(BigList?
procedure:
(BigList? xpr)
"type predicate")
(BigList->list
procedure:
(BigList->list xs)
(BigList->list k xs)
"transforms a possibly infinite biglist xs into a list")
(Cons
macro:
(Cons x y finite?)
(Cons x y)
"returns either a lazy or an eager biglist")
(Cycle
procedure:
(Cycle xs)
"returns an infinite biglist by appending the finite"
"biglist xs over and over")
(Cycle-times
procedure:
(Cycle k xs)
"returns a finite biglist by appending the finite"
"biglist xs k times")
(Drop
procedure:
(Drop k)
(Drop k xs)
"drops the first k items of xs")
(Drop-while
procedure:
(Drop-while ok?)
(Drop-while ok? xs)
"returns the xs whith those front items x removed"
"which pass ok?")
(Drop-until
procedure:
(Drop-until ok?)
(Drop-until ok? xs)
"returns the xs whith those front items x removed"
"which don't pass ok?")
(Eager?
procedure:
(Eager? xpr)
"is xpr an eager biglist, i.e. a normal list?")
(Eq?
procedure:
(Eq? xs ys)
"returns #t if both lists have same length"
"and corresponding items are eq?")
(Eqp?
procedure:
(Eqp? =?)
(Eqp? =? xs ys)
"returns #t if both lists have same length"
"and corresponding items are =?")
(Equal?
procedure:
(Equal? xs ys)
"returns #t if both lists have same length"
"and corresponding items are equal?")
(Eqv?
procedure:
(Eqv? xs ys)
"returns #t if both lists have same length"
"and corresponding items are eqv?")
(Every?
procedure:
(Every? ok?)
(Every? ok? xs)
"returns #t if every item of the finite biglist xs"
"passes the ok? test")
(Filter
procedure:
(Filter ok?)
(Filter ok? xs)
"removes all items from the biglist xs which"
"do not pass the ok? test")
(Fold-left
procedure:
(Fold-left op init)
(Fold-left op init . xss)
"folds the finite biglists xss from the left")
(Fold-left0
procedure:
(Fold-left0 op)
(Fold-left0 op . xss)
"folds the finite biglists (map Rest xss) from the left"
"with init (map First xss)")
(Fold-right
procedure:
(Fold-right op init)
(Fold-right op init . xss)
"folds the finite biglists xss from the right")
(Fold-right0
procedure:
(Fold-right0 op)
(Fold-right0 op . xss)
"folds the finite biglists (map Rest xss) from the right"
"with init (map First xss)")
(For
macro:
(For item-xpr (var xs ok-xpr ...) (var1 xs1 ok-xpr1 ...) ...)
"creates a new list by binding var to each element"
"of the list xs in sequence, and if it passes the checks,"
"ok-xpr ..., inserts the value of item-xpr into the result list."
"The qualifieres, (var xs ok-xpr ...), are processed"
"sequentially from left to right, so that filters of a"
"qualifier have access to the variables of qualifiers"
"to its left.")
(For-each
procedure:
(For-each fn)
(For-each fn . xss)
"applies the procedure fn to each list of items"
"of xss at each commeon index")
(First
procedure:
(First xs)
"returns the front item of xs, which might be eos"
"if xs is empty")
(Index
procedure:
(Index ok?)
(Index ok? xs)
"returns the index of the first item of the biglist xs,"
"which passes the ok? test")
(Iterate
procedure:
(Iterate fn)
(Iterate fn x)
"returns an infinite list by iteratively"
"applying fn to x")
(Iterate-times
procedure:
(Iterate-times fn times)
(Iterate-times fn times x)
"returns a finite list of lentgh times by"
"iteratively applying fn to x")
(Iterate-until
procedure:
(Iterate-until fn ok?)
(Iterate-until fn ok? x)
"returns a finite list by iteratively applying"
"fn to x until ok? returns #t on the result")
(Iterate-while
procedure:
(Iterate-while fn ok?)
"returns a finite list by iteratively applying"
"fn to x as long as ok? returns #t on the result")
(Lazy?
procedure:
(Lazy? xpr)
"is xpr a lazy biglist?")
(Length
procedure:
(Length xs)
"retuns the length of a finite biglist or #f"
"of an infinite one")
(List
procedure:
(List . args)
"creates a lazy finite biglist with items args")
(List?
procedure:
(List? xpr)
"is xpr a finite biglist?")
(List-of?
procedure:
(List-of? . oks?)
(List-of? k . oks?)
"returs a predicate on a biglist, which checks,"
"if every item (or Take k item) is a finite biglist")
(Map
procedure:
(Map fn)
(Map fn . xss)
"maps every list of of items at fixed index of xss"
"with function fn")
(Member
procedure:
(Member x)
(Member x xs)
"returns the first tail af the biglist xs"
"whose first item is equal? to x")
(Memp
procedure:
(Memp ok?)
(Memp ok? xs)
"returns the first tail af the biglist xs"
"which passes the ok? test")
(Memq
procedure:
(Memq x)
(Memq x xs)
"returns the first tail af the biglist xs"
"whose first item is eq? to x")
(Memv
procedure:
(Memv x)
(Memv x xs)
"returns the first tail af the biglist xs"
"whose first item is eqv? to x")
(Merge
procedure:
(Merge