;;; Lists.scheme
;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation. All rights reserved.
;;; Last changed by Pavel on March 26, 1990 7:04 pm PST
;;; Michael Plass, January 20, 1989 4:20:27 pm PST
(define (null? x)
(eq? x '()))
(define (list . x)
"Return a list of the arguments"
x)
(define (list* first . rest)
"Like LIST, but use last argument instead of () as tail of resulting list"
(cond
((null? (cdr rest))
(cons first (car rest)))
(else
(let loop ((prev-tail rest)
(tail (cdr rest)))
(cond
((null? (cdr tail))
(set-cdr! prev-tail (car tail))
(cons first rest))
(else
(loop tail (cdr tail))))))))
(define (append . lists)
"Append an arbitrary number of lists"
(cond
((null? (car lists))
(apply append (cdr lists)))
((null? (cdr lists))
(car lists))
(else
(let* ((head (list (caar lists)))
(tail head))
(let loop ((first (cdar lists))
(rest (cdr lists)))
(for-each
(lambda (elt)
(set-cdr! tail (list elt))
(set! tail (cdr tail)))
first)
(if (null? (cdr rest))
(set-cdr! tail (car rest))
(loop (car rest) (cdr rest))))
head))))
(define (reverse! l)
(let loop ((l l)
(rev-l '()))
(if (null? l)
rev-l
(let ((tail (cdr l)))
(set-cdr! l rev-l)
(loop tail l)))))
(define (list-tail x k)
"sublist of x omitting the first k elements"
(if (zero? k)
x
(list-tail (cdr x) (- k 1))))
(define (list-ref x k)
"Return k-th element of x"
(car (list-tail x k)))
(export (proper-list? last-pair)
(define (atom? x)
(not (pair? x)))
(define (proper-list? x)
(or (null? x)
(and (pair? x)
(let loop ((fast (cdr x))
(slow x))
(cond
((eq? fast slow) ; Circular list
#f)
(else
(let ((cdr-fast (cdr fast)))
(or (null? cdr-fast)
(and (pair? cdr-fast)
(loop (cdr cdr-fast) (cdr slow)))))))))))
(define (last-pair x)
"Return the last pair in the non-empty, possibly improper, list x"
(if (atom? (cdr x))
x
(let loop ((fast (cdr x))
(slow x))
(let ((cdr-fast (cdr fast)))
(cond
((eq? fast slow)
(error 'last-pair x "Circular list not allowed"))
((atom? (cdr cdr-fast))
cdr-fast)
(else
(loop (cdr cdr-fast) (cdr slow))))))))
) ; End export (proper-list? last-pair)
(define (member obj list)
"Return first tail of list whose car is equal? to obj"
(cond
((equal? obj (car list))
list)
(else
(member obj (cdr list)))))
(define (assoc obj list)
"Return first pair on list whose car is equal? to obj"
(cond
((equal? obj (caar list))
(car list))
(else
(assoc obj (cdr list)))))
(define (pairwise pred . args)
"apply an order predicate pairwise to a list"
(if (null? args)
#t
(let loop ((l args))
(cond
((pred (car l) (cadr l))
(loop (cdr l)))
(define (remove-if pred elts)
"Return a list of the elements of ELTS such that PRED is false of them"
(cond
((pred (car elts))
(remove-if pred (cdr elts)))
(else
(cons (car elts) (remove-if pred (cdr elts))))))
(define (remove-if-not pred elts)
"Return a list of the elements of ELTS such that PRED is true of them"
(cond
((pred (car elts))
(cons (car elts) (remove-if-not pred (cdr elts))))
(else
(remove-if-not pred (cdr elts)))))
(export (any every for-each map)
(define (null-copy l)
"Return a list of ()'s as long as L"
(let loop ((result '())
(l l))
(if (null? l)
result
(loop (cons '() result) (cdr l)))))
We're indebted to James Meehan for giving the idea behind this implementation of the multi-list versions of the mapping procedures to the T implementors, by whom we were inspired.
(define (any pred first-list . others)
"Return the first true value of PRED applied to successive elements of the given lists"
(if (null? others)
;; Special non-consing single-list version
(let loop ((l first-list))
(if (null? l)
#f
(or (pred (car l))
(loop (cdr l)))))
;; Hairy low-consing multi-list version
(let* ((lists (cons first-list others))
(args (null-copy lists)))
(let loop ((lists-tail lists)
(args-tail args))
(cond
((null? lists-tail)
;; The args are ready for this call
(or (apply pred args)
;; Not this time. Try the next set of args.
(loop lists args)))
((null? (car lists-tail))
;; One of the input lists has ended.
#f)
(else
;; Collect another argument
(set-car! args-tail (caar lists-tail))
;; Pop that input list
(set-car! lists-tail (cdar lists-tail))
;; Go get some more args.
(loop (cdr lists-tail) (cdr args-tail))))))))
(define (every pred first-list . others)
"Return the last value of PRED applied to successive elements of the given lists if none of the applications yielded false"
(if (null? others)
;; Special non-consing single-list version
(cond
((null? (cdr first-list))
(pred (car first-list)))
(else
(let loop ((l first-list))
(if (null? (cdr l))
(pred (car l))
(and (pred (car l))
(loop (cdr l)))))))
;; Hairy low-consing multi-list version
(let* ((lists (cons first-list others))
(args (null-copy lists))
(result #t))
(let loop ((lists-tail lists)
(args-tail args))
(cond
((null? lists-tail)
;; The args are ready for this call
(set! result (apply pred args))
(and result
;; Not this time. Try the next set of args.
(loop lists args)))
((null? (car lists-tail))
;; One of the input lists has ended.
;; Return whatever we got from the last application.
result)
(else
;; Collect another argument
(set-car! args-tail (caar lists-tail))
;; Pop that input list
(set-car! lists-tail (cdar lists-tail))
;; Go get some more args.
(loop (cdr lists-tail) (cdr args-tail))))))))
(define (for-each proc first-list . others)
(define (essential-for-each proc l)
(when (not (null? l))
(proc (car l))
(essential-for-each proc (cdr l))))
(if (null? others)
(essential-for-each proc first-list)
(let* ((lists (cons first-list others))
(args (null-copy lists)))
(let loop ((lists-tail lists)
(args-tail args))
(cond
((null? lists-tail)
;; The args are ready for this call
(apply proc args)
;; On to the next set of args.
(loop lists args))
((not (null? (car lists-tail)))
;; Collect another argument
(set-car! args-tail (caar lists-tail))
;; Pop that input list
(set-car! lists-tail (cdar lists-tail))
;; Go get some more args.
(loop (cdr lists-tail) (cdr args-tail))))))))
(define (map fn first-list . others)
(define (essential-map f l)
"Map the function f over the list l, returning a list of the results"
(let* ((head (list '()))
(tail head))
(let loop ((l l))
(cond
(else
(set-cdr! tail (list (f (car l))))
(set! tail (cdr tail))
(loop (cdr l)))))))
(if (null? others)
(essential-map fn first-list)
(let* ((lists (cons first-list others))
(args (null-copy lists))
(head (list '())) ;; To save time in the inner loop
(tail head))
(let loop ((lists-tail lists)
(args-tail args))
(cond
((null? lists-tail)
;; The args are ready for this call
(set-cdr! tail (list (apply fn args)))
(set! tail (cdr tail))
;; On to the next set of args.
(loop lists args))
((null? (car lists-tail))
;; One of the input lists has ended.
(cdr head)) ;; Throw away the extra cons cell from above.
(else
;; Collect another argument
(set-car! args-tail (caar lists-tail))
;; Pop that input list
(set-car! lists-tail (cdar lists-tail))
;; Go get some more args.
(loop (cdr lists-tail) (cdr args-tail))))))))
)