summaryrefslogtreecommitdiffstats
path: root/comlist.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /comlist.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'comlist.scm')
-rw-r--r--comlist.scm317
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??)