diff options
Diffstat (limited to 'comlist.scm')
| -rw-r--r-- | comlist.scm | 317 |
1 files changed, 158 insertions, 159 deletions
diff --git a/comlist.scm b/comlist.scm index 008a2b0..2e3a6ef 100644 --- a/comlist.scm +++ b/comlist.scm @@ -1,5 +1,5 @@ ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme -; Copyright (C) 1991, 1993, 1995, 2001 Aubrey Jaffer. +; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer. ; Copyright (C) 2000 Colin Walters ; ;Permission to copy this software, to modify it, to redistribute it, @@ -9,7 +9,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -27,25 +27,32 @@ ;;; Colin Walters <walters@cis.ohio-state.edu> ;;; AGJ restored order July 2001. -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:make-list k . init) +;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker) +(define (make-list k . init) (set! init (if (pair? init) (car init))) (do ((k k (+ -1 k)) (result '() (cons init result))) ((<= k 0) result))) - -(define (comlist:copy-list lst) (append lst '())) - -(define (comlist:adjoin obj lst) (if (memv obj lst) lst (cons obj lst))) - -(define (comlist:union lst1 lst2) - (define ans (if (null? lst1) lst2 lst1)) - (cond ((null? lst2) lst1) - (else (for-each (lambda (elt) (set! ans (comlist:adjoin elt ans))) - lst2) - ans))) - -(define (comlist:intersection lst1 lst2) +;@ +(define (copy-list lst) (append lst '())) +;@ +(define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst))) +;@ +(define union + (letrec ((onion + (lambda (lst1 lst2) + (if (null? lst1) + lst2 + (onion (cdr lst1) (comlist:adjoin (car lst1) lst2)))))) + (lambda (lst1 lst2) + (cond ((null? lst1) lst2) + ((null? lst2) lst1) + ((null? (cdr lst1)) (comlist:adjoin (car lst1) lst2)) + ((null? (cdr lst2)) (comlist:adjoin (car lst2) lst1)) + ((< (length lst2) (length lst1)) (onion (reverse lst2) lst1)) + (else (onion (reverse lst1) lst2)))))) +;@ +(define (intersection lst1 lst2) (if (null? lst2) lst2 (let build-intersection ((lst1 lst1) @@ -55,8 +62,8 @@ (build-intersection (cdr lst1) (cons (car lst1) result))) (else (build-intersection (cdr lst1) result)))))) - -(define (comlist:set-difference lst1 lst2) +;@ +(define (set-difference lst1 lst2) (if (null? lst2) lst1 (let build-difference ((lst1 lst1) @@ -64,25 +71,32 @@ (cond ((null? lst1) (reverse result)) ((memv (car lst1) lst2) (build-difference (cdr lst1) result)) (else (build-difference (cdr lst1) (cons (car lst1) result))))))) - -(define (comlist:position obj lst) - (letrec ((pos (lambda (n lst) - (cond ((null? lst) #f) - ((eqv? obj (car lst)) n) - (else (pos (+ 1 n) (cdr lst))))))) - (pos 0 lst))) - -(define (comlist:reduce-init pred? init lst) +;@ +(define (subset? lst1 lst2) + (or (eq? lst1 lst2) + (let loop ((lst1 lst1)) + (or (null? lst1) + (and (memv (car lst1) lst2) + (loop (cdr lst1))))))) +;@ +(define (position obj lst) + (define pos (lambda (n lst) + (cond ((null? lst) #f) + ((eqv? obj (car lst)) n) + (else (pos (+ 1 n) (cdr lst)))))) + (pos 0 lst)) +;@ +(define (reduce-init pred? init lst) (if (null? lst) init (comlist:reduce-init pred? (pred? init (car lst)) (cdr lst)))) - -(define (comlist:reduce pred? lst) +;@ +(define (reduce pred? lst) (cond ((null? lst) lst) ((null? (cdr lst)) (car lst)) (else (comlist:reduce-init pred? (car lst) (cdr lst))))) - -(define (comlist:some pred lst . rest) +;@ +(define (some pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (and (not (null? lst)) @@ -91,8 +105,8 @@ (and (not (null? lst)) (or (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) - -(define (comlist:every pred lst . rest) +;@ +(define (every pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (or (null? lst) @@ -101,18 +115,18 @@ (or (null? lst) (and (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) - -(define (comlist:notany pred . ls) (not (apply comlist:some pred ls))) - -(define (comlist:notevery pred . ls) (not (apply comlist:every pred ls))) - -(define (comlist:list-of?? predicate . bound) +;@ +(define (notany pred . ls) (not (apply comlist:some pred ls))) +;@ +(define (notevery pred . ls) (not (apply comlist:every pred ls))) +;@ +(define (list-of?? predicate . bound) (define (errout) (apply slib:error 'list-of?? predicate bound)) (case (length bound) ((0) (lambda (obj) (and (list? obj) - (every predicate obj)))) + (comlist:every predicate obj)))) ((1) (set! bound (car bound)) (cond ((negative? bound) @@ -120,12 +134,12 @@ (lambda (obj) (and (list? obj) (<= bound (length obj)) - (every predicate obj)))) + (comlist:every predicate obj)))) (else (lambda (obj) (and (list? obj) (<= (length obj) bound) - (every predicate obj)))))) + (comlist:every predicate obj)))))) ((2) (let ((low (car bound)) (high (cadr bound))) @@ -136,45 +150,45 @@ (lambda (obj) (and (list? obj) (<= low (length obj) high) - (every predicate obj))))) + (comlist:every predicate obj))))) (else (errout)))) - -(define (comlist:find-if pred? lst) +;@ +(define (find-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) (car lst)) (else (comlist:find-if pred? (cdr lst))))) - -(define (comlist:member-if pred? lst) +;@ +(define (member-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) lst) (else (comlist:member-if pred? (cdr lst))))) - -(define (comlist:remove pred? lst) +;@ +(define (remove obj lst) (define head (list '*head*)) (let remove ((lst lst) (tail head)) (cond ((null? lst)) - ((eqv? pred? (car lst)) (remove (cdr lst) tail)) + ((eqv? obj (car lst)) (remove (cdr lst) tail)) (else (set-cdr! tail (list (car lst))) (remove (cdr lst) (cdr tail))))) (cdr head)) - -(define (comlist:remove-if pred? lst) +;@ +(define (remove-if pred? lst) (let remove-if ((lst lst) (result '())) (cond ((null? lst) (reverse result)) ((pred? (car lst)) (remove-if (cdr lst) result)) (else (remove-if (cdr lst) (cons (car lst) result)))))) - -(define (comlist:remove-if-not pred? lst) +;@ +(define (remove-if-not pred? lst) (let remove-if-not ((lst lst) (result '())) (cond ((null? lst) (reverse result)) ((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result))) (else (remove-if-not (cdr lst) result))))) - -(define comlist:nconc +;@ +(define nconc (if (provided? 'rev2-procedures) append! (lambda args (cond ((null? args) '()) @@ -185,8 +199,8 @@ (apply comlist:nconc (cdr args))) (car args)))))) -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:nreverse rev-it) +;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker) +(define (nreverse rev-it) ;;; Reverse order of elements of LIST by mutating cdrs. (cond ((null? rev-it) rev-it) ((not (list? rev-it)) @@ -195,100 +209,85 @@ (rev-cdr (cdr rev-it) (cdr rev-cdr)) (rev-it rev-it rev-cdr)) ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it))))) - -(define (comlist:last lst n) +;@ +(define (last lst n) (comlist:nthcdr (- (length lst) n) lst)) - -(define (comlist:butlast lst n) - (letrec - ((len (- (length lst) n)) - (bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero - (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butlast" n) - len)))) - -(define (comlist:nthcdr n lst) +;@ +(define (butlast lst n) + (comlist:butnthcdr (- (length lst) n) lst)) +;@ +(define (nthcdr n lst) (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst)))) - -(define (comlist:butnthcdr n lst) - (letrec - ((bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero - (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butnthcdr" n) - n)))) +;@ +(define (butnthcdr k lst) + (cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k) + ; SIMSYNCH FIFO8 uses negative k. + ((or (zero? k) (null? lst)) '()) + (else (let ((ans (list (car lst)))) + (do ((lst (cdr lst) (cdr lst)) + (tail ans (cdr tail)) + (k (+ -2 k) (+ -1 k))) + ((or (negative? k) (null? lst)) ans) + (set-cdr! tail (list (car lst)))))))) ;;;; CONDITIONALS - -(define (comlist:and? . args) +;@ +(define (and? . args) (cond ((null? args) #t) ((car args) (apply comlist:and? (cdr args))) (else #f))) - -(define (comlist:or? . args) +;@ +(define (or? . args) (cond ((null? args) #f) ((car args) #t) (else (apply comlist:or? (cdr args))))) -;;; Checks to see if a list has any duplicate MEMBERs. -(define (comlist:has-duplicates? lst) +;;;@ Checks to see if a list has any duplicate MEMBERs. +(define (has-duplicates? lst) (cond ((null? lst) #f) ((member (car lst) (cdr lst)) #t) (else (comlist:has-duplicates? (cdr lst))))) -;;; remove duplicates of MEMBERs of a list -(define (comlist:remove-duplicates lst) +;;;@ remove duplicates of MEMBERs of a list +(define remove-duplicates (letrec ((rem-dup (lambda (lst nlst) (cond ((null? lst) (reverse nlst)) ((member (car lst) nlst) (rem-dup (cdr lst) nlst)) (else (rem-dup (cdr lst) (cons (car lst) nlst))))))) - (rem-dup lst '()))) - -(define (comlist:list* obj1 . obj2) - (define (list*1 obj) - (if (null? (cdr obj)) - (car obj) - (cons (car obj) (list*1 (cdr obj))))) - (if (null? obj2) - obj1 - (cons obj1 (list*1 obj2)))) - -(define (comlist:atom? obj) + (lambda (lst) + (rem-dup lst '())))) +;@ +(define list* + (letrec ((list*1 (lambda (obj) + (if (null? (cdr obj)) + (car obj) + (cons (car obj) (list*1 (cdr obj))))))) + (lambda (obj1 . obj2) + (if (null? obj2) + obj1 + (cons obj1 (list*1 obj2)))))) +;@ +(define (atom? obj) (not (pair? obj))) - -(define (comlist:delete obj lst) +;@ +(define (delete obj lst) (let delete ((lst lst)) (cond ((null? lst) '()) ((equal? obj (car lst)) (delete (cdr lst))) (else (set-cdr! lst (delete (cdr lst))) lst)))) - -(define (comlist:delete-if pred lst) +;@ +(define (delete-if pred lst) (let delete-if ((lst lst)) (cond ((null? lst) '()) ((pred (car lst)) (delete-if (cdr lst))) (else (set-cdr! lst (delete-if (cdr lst))) lst)))) - -(define (comlist:delete-if-not pred lst) +;@ +(define (delete-if-not pred lst) (let delete-if ((lst lst)) (cond ((null? lst) '()) ((not (pred (car lst))) (delete-if (cdr lst))) @@ -296,42 +295,42 @@ (set-cdr! lst (delete-if (cdr lst))) lst)))) -;;; exports - -(define make-list comlist:make-list) -(define copy-list comlist:copy-list) -(define adjoin comlist:adjoin) -(define union comlist:union) -(define intersection comlist:intersection) -(define set-difference comlist:set-difference) -(define position comlist:position) -(define reduce-init comlist:reduce-init) -(define reduce comlist:reduce) ; reduce is also in collect.scm -(define some comlist:some) -(define every comlist:every) -(define notevery comlist:notevery) -(define notany comlist:notany) -(define find-if comlist:find-if) -(define member-if comlist:member-if) -(define remove comlist:remove) -(define remove-if comlist:remove-if) -(define remove-if-not comlist:remove-if-not) -(define nconc comlist:nconc) -(define nreverse comlist:nreverse) -(define last comlist:last) -(define butlast comlist:butlast) -(define nthcdr comlist:nthcdr) -(define butnthcdr comlist:butnthcdr) -(define and? comlist:and?) -(define or? comlist:or?) -(define has-duplicates? comlist:has-duplicates?) -(define remove-duplicates comlist:remove-duplicates) - -(define delete-if-not comlist:delete-if-not) -(define delete-if comlist:delete-if) -(define delete comlist:delete) -(define comlist:atom comlist:atom?) -(define atom comlist:atom?) -(define atom? comlist:atom?) -(define list* comlist:list*) -(define list-of?? comlist:list-of??) +;;; internal versions safe from name collisions. + +;;(define comlist:make-list make-list) +;;(define comlist:copy-list copy-list) +(define comlist:adjoin adjoin) +;;(define comlist:union union) +;;(define comlist:intersection intersection) +;;(define comlist:set-difference set-difference) +;;(define comlist:subset? subset?) +;;(define comlist:position position) +(define comlist:reduce-init reduce-init) +;;(define comlist:reduce reduce) ; reduce is also in collect.scm +(define comlist:some some) +(define comlist:every every) +;;(define comlist:notevery notevery) +;;(define comlist:notany notany) +(define comlist:find-if find-if) +(define comlist:member-if member-if) +;;(define comlist:remove remove) +;;(define comlist:remove-if remove-if) +;;(define comlist:remove-if-not remove-if-not) +(define comlist:nconc nconc) +;;(define comlist:nreverse nreverse) +;;(define comlist:last last) +;;(define comlist:butlast butlast) +(define comlist:nthcdr nthcdr) +(define comlist:butnthcdr butnthcdr) +(define comlist:and? and?) +(define comlist:or? or?) +(define comlist:has-duplicates? has-duplicates?) +;;(define comlist:remove-duplicates remove-duplicates) +;;(define comlist:delete-if-not delete-if-not) +;;(define comlist:delete-if delete-if) +;;(define comlist:delete delete) +;;(define comlist:atom? atom?) +;;(define atom atom?) +;;(define comlist:atom atom?) +;;(define comlist:list* list*) +;;(define comlist:list-of?? list-of??) |