implements delete-duplicates(!) tail-recursively

This commit is contained in:
stibear 2014-06-26 22:44:38 +09:00
parent b77fac6ce1
commit 2526474fb3
1 changed files with 325 additions and 325 deletions

View File

@ -1,6 +1,6 @@
(define-library (srfi 1) (define-library (srfi 1)
(import (scheme base) (import (scheme base)
(scheme cxr)) (scheme cxr))
;; # Constructors ;; # Constructors
;; cons list ;; cons list
@ -15,32 +15,32 @@
(define (cons* x . args) (define (cons* x . args)
(let rec ((acc '()) (x x) (lst args)) (let rec ((acc '()) (x x) (lst args))
(if (null? lst) (if (null? lst)
(append-reverse acc x) (append-reverse acc x)
(rec (cons x acc) (car lst) (cdr lst))))) (rec (cons x acc) (car lst) (cdr lst)))))
(define (list-tabulate n init-proc) (define (list-tabulate n init-proc)
(let rec ((acc '()) (n (- n 1))) (let rec ((acc '()) (n (- n 1)))
(if (zero? n) (if (zero? n)
(cons n acc) (cons n acc)
(rec (cons n acc) (- n 1))))) (rec (cons n acc) (- n 1)))))
(define (circular-list elt . args) (define (circular-list elt . args)
(let ((lst (cons elt args))) (let ((lst (cons elt args)))
(let rec ((l lst)) (let rec ((l lst))
(if (null? (cdr l)) (if (null? (cdr l))
(set-cdr! l lst) (set-cdr! l lst)
(rec (cdr l)))) (rec (cdr l))))
lst)) lst))
(define (iota count . lst) (define (iota count . lst)
(let ((start (if (pair? lst) (car lst) 0)) (let ((start (if (pair? lst) (car lst) 0))
(step (if (and (pair? lst) (pair? (cdr lst))) (step (if (and (pair? lst) (pair? (cdr lst)))
(cadr lst) 1))) (cadr lst) 1)))
(let rec ((count (- count 1)) (acc '())) (let rec ((count (- count 1)) (acc '()))
(if (zero? count) (if (zero? count)
(cons start acc) (cons start acc)
(rec (- count 1) (rec (- count 1)
(cons (+ start (* count step)) acc)))))) (cons (+ start (* count step)) acc))))))
(export cons list xcons make-list list-tabulate list-copy circular-list iota) (export cons list xcons make-list list-tabulate list-copy circular-list iota)
@ -55,38 +55,38 @@
(define (circular-list? x) (define (circular-list? x)
(let rec ((rapid x) (local x)) (let rec ((rapid x) (local x))
(if (and (pair? rapid) (pair? (cdr rapid))) (if (and (pair? rapid) (pair? (cdr rapid)))
(if (eq? (cddr rapid) (cdr local)) (if (eq? (cddr rapid) (cdr local))
#t #t
(rec (cddr rapid) (cdr local))) (rec (cddr rapid) (cdr local)))
#f))) #f)))
(define proper-list? list?) (define proper-list? list?)
(define (dotted-list? x) (define (dotted-list? x)
(and (pair? x) (and (pair? x)
(not (proper-list? x)) (not (proper-list? x))
(not (circular-list? x)))) (not (circular-list? x))))
(define (null-list? x) (define (null-list? x)
(cond ((pair? x) #f) (cond ((pair? x) #f)
((null? x) #t) ((null? x) #t)
(else (error "null-list?: argument out of domain" x)))) (else (error "null-list?: argument out of domain" x))))
(define (list= elt= . lists) (define (list= elt= . lists)
(or (null? lists) (or (null? lists)
(let rec1 ((list1 (car lists)) (others (cdr lists))) (let rec1 ((list1 (car lists)) (others (cdr lists)))
(or (null? others) (or (null? others)
(let ((list2 (car others)) (let ((list2 (car others))
(others (cdr others))) (others (cdr others)))
(if (eq? list1 list2) (if (eq? list1 list2)
(rec1 list2 others) (rec1 list2 others)
(let rec2 ((l1 list1) (l2 list2)) (let rec2 ((l1 list1) (l2 list2))
(if (null-list? l1) (if (null-list? l1)
(and (null-list? l2) (and (null-list? l2)
(rec1 list2 others)) (rec1 list2 others))
(and (not (null-list? l2)) (and (not (null-list? l2))
(elt= (car l1) (car l2)) (elt= (car l1) (car l2))
(rec2 (cdr l1) (cdr l2))))))))))) (rec2 (cdr l1) (cdr l2)))))))))))
(export pair? null? not-pair? proper-list? circular-list? null-list? list=) (export pair? null? not-pair? proper-list? circular-list? null-list? list=)
@ -124,17 +124,17 @@
(define (take! x i) (define (take! x i)
(let rec ((lis x) (n (- i 1))) (let rec ((lis x) (n (- i 1)))
(if (zero? n) (if (zero? n)
(begin (set-cdr! lis '()) x) (begin (set-cdr! lis '()) x)
(rec (cdr lis) (- n 1))))) (rec (cdr lis) (- n 1)))))
(define (drop-right! flist i) (define (drop-right! flist i)
(let ((lead (drop flist i))) (let ((lead (drop flist i)))
(if (not-pair? lead) (if (not-pair? lead)
'() '()
(let rec ((lis1 flist) (lis2 (cdr lead))) (let rec ((lis1 flist) (lis2 (cdr lead)))
(if (pair? lis2) (if (pair? lis2)
(rec (cdr lis1) (cdr lis2)) (rec (cdr lis1) (cdr lis2))
(begin (set-cdr! lis1 '()) flist)))))) (begin (set-cdr! lis1 '()) flist))))))
(define (split-at x i) (define (split-at x i)
(values (take x i) (drop x i))) (values (take x i) (drop x i)))
@ -167,12 +167,12 @@
(export car cdr car+cdr list-ref (export car cdr car+cdr list-ref
caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
cdadar cdaddr cddaar cddadr cdddar cddddr cdadar cdaddr cddaar cddadr cdddar cddddr
first second third fourth fifth sixth seventh eighth ninth tenth first second third fourth fifth sixth seventh eighth ninth tenth
take drop take-right drop-right take! drop-right! take drop take-right drop-right take! drop-right!
split-at split-at! last last-pair) split-at split-at! last last-pair)
;; # Miscellaneous ;; # Miscellaneous
;; length length+ ;; length length+
@ -183,19 +183,19 @@
;; count ;; count
(define (length+ lst) (define (length+ lst)
(if (not (circular-list? lst)) (if (not (circular-list? lst))
(length lst))) (length lst)))
(define (concatenate lists) (define (concatenate lists)
(apply append lists)) (apply append lists))
(define (append! . lists) (define (append! . lists)
(if (null? lists) (if (null? lists)
'() '()
(let rec ((lst lists)) (let rec ((lst lists))
(if (not-pair? (cdr lst)) (if (not-pair? (cdr lst))
(car lst) (car lst)
(begin (set-cdr! (last-pair (car lst)) (cdr lst)) (begin (set-cdr! (last-pair (car lst)) (cdr lst))
(rec (cdr lst))))))) (rec (cdr lst)))))))
(define (concatenate! lists) (define (concatenate! lists)
(apply append! lists)) (apply append! lists))
@ -203,10 +203,10 @@
(define (reverse! list) (define (reverse! list)
(let rec ((lst list) (acc '())) (let rec ((lst list) (acc '()))
(if (null? lst) (if (null? lst)
acc acc
(let ((rst (cdr lst))) (let ((rst (cdr lst)))
(set-cdr! lst acc) (set-cdr! lst acc)
(rec rst lst))))) (rec rst lst)))))
(set! append-reverse (set! append-reverse
(lambda (rev-head tail) (lambda (rev-head tail)
@ -217,9 +217,9 @@
(define (append-reverse! rev-head tail) (define (append-reverse! rev-head tail)
(let ((rst (cdr rev-head))) (let ((rst (cdr rev-head)))
(if (null? rev-head) (if (null? rev-head)
tail tail
(begin (set-cdr! rev-head tail) (begin (set-cdr! rev-head tail)
(append-reverse! rst rev-head))))) (append-reverse! rst rev-head)))))
(define (zip . lists) (define (zip . lists)
(apply map list lists)) (apply map list lists))
@ -229,37 +229,37 @@
(define (unzip2 list) (define (unzip2 list)
(values (map first list) (values (map first list)
(map second list))) (map second list)))
(define (unzip3 list) (define (unzip3 list)
(values (map first list) (values (map first list)
(map second list) (map second list)
(map third list))) (map third list)))
(define (unzip4 list) (define (unzip4 list)
(values (map first list) (values (map first list)
(map second list) (map second list)
(map third list) (map third list)
(map fourth list))) (map fourth list)))
(define (unzip5 list) (define (unzip5 list)
(values (map first list) (values (map first list)
(map second list) (map second list)
(map third list) (map third list)
(map fourth list) (map fourth list)
(map fifth list))) (map fifth list)))
(define (count pred . clists) (define (count pred . clists)
(let rec ((tflst (apply map pred clists)) (n 0)) (let rec ((tflst (apply map pred clists)) (n 0))
(if (null? tflst) (if (null? tflst)
n n
(rec (cdr tflst) (if (car tflst) (+ n 1) n))))) (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))
(export length length+ (export length length+
append append! concatenate concatenate! append append! concatenate concatenate!
reverse reverse! append-reverse append-reverse! reverse reverse! append-reverse append-reverse!
zip unzip1 unzip2 unzip3 unzip4 unzip5 zip unzip1 unzip2 unzip3 unzip4 unzip5
count) count)
;; # Fold, unfold & map ;; # Fold, unfold & map
;; map for-each ;; map for-each
@ -273,80 +273,80 @@
(define (fold kons knil clist . clists) (define (fold kons knil clist . clists)
(if (null? clists) (if (null? clists)
(let rec ((acc knil) (clist clist)) (let rec ((acc knil) (clist clist))
(if (null? clist) (if (null? clist)
acc acc
(rec (kons (car clist) acc) (cdr clist)))) (rec (kons (car clist) acc) (cdr clist))))
(let rec ((acc knil) (clists (cons clist clists))) (let rec ((acc knil) (clists (cons clist clists)))
(if (every pair? clists) (if (every pair? clists)
(rec (apply kons (append (map car clists) (list acc))) (rec (apply kons (append (map car clists) (list acc)))
(map cdr clists)) (map cdr clists))
acc)))) acc))))
(define (fold-right kons knil clist . clists) (define (fold-right kons knil clist . clists)
(if (null? clists) (if (null? clists)
(let rec ((clist clist) (cont values)) (let rec ((clist clist) (cont values))
(if (null? clist) (if (null? clist)
(cont knil) (cont knil)
(rec (cdr clist) (lambda (x) (cont (kons (car clist) x)))))) (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))
(let rec ((clists (cons clist clists)) (cont values)) (let rec ((clists (cons clist clists)) (cont values))
(if (every pair? clists) (if (every pair? clists)
(rec (map cdr clists) (rec (map cdr clists)
(lambda (x) (lambda (x)
(cont (apply kons (append (map car clists) (list x)))))) (cont (apply kons (append (map car clists) (list x))))))
(cont knil))))) (cont knil)))))
(define (pair-fold kons knil clist . clists) (define (pair-fold kons knil clist . clists)
(if (null? clists) (if (null? clists)
(let rec ((acc knil) (clist clist)) (let rec ((acc knil) (clist clist))
(if (null? clist) (if (null? clist)
acc acc
(let ((tail (cdr clist))) (let ((tail (cdr clist)))
(rec (kons clist acc) tail)))) (rec (kons clist acc) tail))))
(let rec ((acc knil) (clists (cons clist clists))) (let rec ((acc knil) (clists (cons clist clists)))
(if (every pair? clists) (if (every pair? clists)
(let ((tail (map cdr clists))) (let ((tail (map cdr clists)))
(rec (apply kons (append clists (list acc))) (rec (apply kons (append clists (list acc)))
tail)) tail))
acc)))) acc))))
(define (pair-fold-right kons knil clist . clists) (define (pair-fold-right kons knil clist . clists)
(if (null? clists) (if (null? clists)
(let rec ((clist clist) (cont values)) (let rec ((clist clist) (cont values))
(if (null? clist) (if (null? clist)
(cont knil) (cont knil)
(let ((tail (map cdr clists))) (let ((tail (map cdr clists)))
(rec tail (lambda (x) (cont (kons clist x))))))) (rec tail (lambda (x) (cont (kons clist x)))))))
(let rec ((clists (cons clist clists)) (cont values)) (let rec ((clists (cons clist clists)) (cont values))
(if (every pair? clists) (if (every pair? clists)
(let ((tail (map cdr clists))) (let ((tail (map cdr clists)))
(rec tail (rec tail
(lambda (x) (lambda (x)
(cont (apply kons (append clists (list x))))))) (cont (apply kons (append clists (list x)))))))
(cont knil))))) (cont knil)))))
(define (reduce f ridentity list) (define (reduce f ridentity list)
(if (null? list) (if (null? list)
ridentity ridentity
(fold f (car list) (cdr list)))) (fold f (car list) (cdr list))))
(define (reduce-right f ridentity list) (define (reduce-right f ridentity list)
(fold-right f ridentity list)) (fold-right f ridentity list))
(define (unfold p f g seed . tail-gen) (define (unfold p f g seed . tail-gen)
(let ((tail-gen (if (null? tail-gen) (let ((tail-gen (if (null? tail-gen)
(lambda (x) '()) (lambda (x) '())
(car tail-gen)))) (car tail-gen))))
(let rec ((seed seed) (cont values)) (let rec ((seed seed) (cont values))
(if (p seed) (if (p seed)
(cont (tail-gen seed)) (cont (tail-gen seed))
(rec (g seed) (lambda (x) (cont (cons (f seed) x)))))))) (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))
(define (unfold-right p f g seed . tail) (define (unfold-right p f g seed . tail)
(let rec ((seed seed) (lst tail)) (let rec ((seed seed) (lst tail))
(if (p seed) (if (p seed)
lst lst
(rec (g seed) (cons (f seed) lst))))) (rec (g seed) (cons (f seed) lst)))))
(define (append-map f . clists) (define (append-map f . clists)
(apply append (apply map f clists))) (apply append (apply map f clists)))
@ -356,47 +356,47 @@
(define (pair-for-each f clist . clists) (define (pair-for-each f clist . clists)
(if (null? clist) (if (null? clist)
(let rec ((clist clist)) (let rec ((clist clist))
(if (pair? clist) (if (pair? clist)
(begin (f clist) (rec (cdr clist))))) (begin (f clist) (rec (cdr clist)))))
(let rec ((clists (cons clist clists))) (let rec ((clists (cons clist clists)))
(if (every pair? clists) (if (every pair? clists)
(begin (apply f clists) (rec (map cdr clists))))))) (begin (apply f clists) (rec (map cdr clists)))))))
(define (map! f list . lists) (define (map! f list . lists)
(if (null? lists) (if (null? lists)
(pair-for-each (lambda (x) (set-car! x (f (car x)))) list) (pair-for-each (lambda (x) (set-car! x (f (car x)))) list)
(let rec ((list list) (lists lists)) (let rec ((list list) (lists lists))
(if (pair? list) (if (pair? list)
(let ((head (map car lists)) (let ((head (map car lists))
(rest (map cdr lists))) (rest (map cdr lists)))
(set-car! list (apply f (car list) head)) (set-car! list (apply f (car list) head))
(rec (cdr list) rest))))) (rec (cdr list) rest)))))
list) list)
(define (map-in-order f clist . clists) (define (map-in-order f clist . clists)
(if (null? clists) (if (null? clists)
(let rec ((clist clist) (acc '())) (let rec ((clist clist) (acc '()))
(if (null? clist) (if (null? clist)
(reverse! acc) (reverse! acc)
(rec (cdr clist) (cons (f (car clist)) acc)))) (rec (cdr clist) (cons (f (car clist)) acc))))
(let rec ((clists (cons clist clists)) (acc '())) (let rec ((clists (cons clist clists)) (acc '()))
(if (every pair? clists) (if (every pair? clists)
(rec (map cdr clists) (rec (map cdr clists)
(cons* (apply f (map car clists)) acc)) (cons* (apply f (map car clists)) acc))
(reverse! acc))))) (reverse! acc)))))
(define (filter-map f clist . clists) (define (filter-map f clist . clists)
(let recur ((l (apply map f clist clists))) (let recur ((l (apply map f clist clists)))
(cond ((null? l) '()) (cond ((null? l) '())
((car l) (cons (car l) (recur (cdr l)))) ((car l) (cons (car l) (recur (cdr l))))
(else (recur (cdr l)))))) (else (recur (cdr l))))))
(export map for-each (export map for-each
fold unfold pair-fold reduce fold unfold pair-fold reduce
fold-right unfold-right pair-fold-right reduce-right fold-right unfold-right pair-fold-right reduce-right
append-map append-map! append-map append-map!
map! pair-for-each filter-map map-in-order) map! pair-for-each filter-map map-in-order)
;; # Filtering & partitioning ;; # Filtering & partitioning
;; filter partition remove ;; filter partition remove
@ -415,21 +415,21 @@
(define (filter! pred list) (define (filter! pred list)
(let rec ((lst list)) (let rec ((lst list))
(if (null? lst) (if (null? lst)
lst lst
(if (pred (car lst)) (if (pred (car lst))
(begin (set-cdr! lst (rec (cdr lst))) (begin (set-cdr! lst (rec (cdr lst)))
lst) lst)
(rec (cdr lst)))))) (rec (cdr lst))))))
(define (remove! pred list) (define (remove! pred list)
(filter! (lambda (x) (not (pred x))) list)) (filter! (lambda (x) (not (pred x))) list))
(define (partition! pred list) (define (partition! pred list)
(values (filter! pred list) (values (filter! pred list)
(remove! pred list))) (remove! pred list)))
(export filter partition remove (export filter partition remove
filter! partition! remove!) filter! partition! remove!)
;; # Searching ;; # Searching
;; member memq memv ;; member memq memv
@ -455,55 +455,55 @@
(define (take-while pred clist) (define (take-while pred clist)
(let rec ((clist clist) (cont values)) (let rec ((clist clist) (cont values))
(if (null? clist) (if (null? clist)
(cont '()) (cont '())
(if (pred (car clist)) (if (pred (car clist))
(rec (cdr clist) (rec (cdr clist)
(lambda (x) (cont (cons (car clist) x)))) (lambda (x) (cont (cons (car clist) x))))
(cont '()))))) (cont '())))))
(define (take-while! pred clist) (define (take-while! pred clist)
(let rec ((clist clist)) (let rec ((clist clist))
(if (null? clist) (if (null? clist)
'() '()
(if (pred (car clist)) (if (pred (car clist))
(begin (set-cdr! clist (rec (cdr clist))) (begin (set-cdr! clist (rec (cdr clist)))
clist) clist)
'())))) '()))))
(define (drop-while pred clist) (define (drop-while pred clist)
(let rec ((clist clist)) (let rec ((clist clist))
(if (null? clist) (if (null? clist)
'() '()
(if (pred (car clist)) (if (pred (car clist))
(rec (cdr clist)) (rec (cdr clist))
clist)))) clist))))
(define (span pred clist) (define (span pred clist)
(values (take-while pred clist) (values (take-while pred clist)
(drop-while pred clist))) (drop-while pred clist)))
(define (span! pred clist) (define (span! pred clist)
(values (take-while! pred clist) (values (take-while! pred clist)
(drop-while pred clist))) (drop-while pred clist)))
(define (break pred clist) (define (break pred clist)
(values (take-while (lambda (x) (not (pred x))) clist) (values (take-while (lambda (x) (not (pred x))) clist)
(drop-while (lambda (x) (not (pred x))) clist))) (drop-while (lambda (x) (not (pred x))) clist)))
(define (break! pred clist) (define (break! pred clist)
(values (take-while! (lambda (x) (not (pred x))) clist) (values (take-while! (lambda (x) (not (pred x))) clist)
(drop-while (lambda (x) (not (pred x))) clist))) (drop-while (lambda (x) (not (pred x))) clist)))
(define (any pred clist . clists) (define (any pred clist . clists)
(if (null? clists) (if (null? clists)
(let rec ((clist clist)) (let rec ((clist clist))
(if (pair? clist) (if (pair? clist)
(or (pred (car clist)) (or (pred (car clist))
(rec (cdr clist))))) (rec (cdr clist)))))
(let rec ((clists (cons clist clists))) (let rec ((clists (cons clist clists)))
(if (every pair? clists) (if (every pair? clists)
(or (apply pred (map car clists)) (or (apply pred (map car clists))
(rec (map cdr clists))))))) (rec (map cdr clists)))))))
(set! every (set! every
(lambda (pred clist . clists) (lambda (pred clist . clists)
@ -519,23 +519,23 @@
(define (list-index pred clist . clists) (define (list-index pred clist . clists)
(if (null? clists) (if (null? clists)
(let rec ((clist clist) (n 0)) (let rec ((clist clist) (n 0))
(if (pair? clist) (if (pair? clist)
(if (pred (car clist)) (if (pred (car clist))
n n
(rec (cdr clist) (+ n 1))))) (rec (cdr clist) (+ n 1)))))
(let rec ((clists (cons clist clists)) (n 0)) (let rec ((clists (cons clist clists)) (n 0))
(if (every pair? clists) (if (every pair? clists)
(if (apply pred (map car clists)) (if (apply pred (map car clists))
n n
(rec (map cdr clists) (+ n 1))))))) (rec (map cdr clists) (+ n 1)))))))
(export member memq memv (export member memq memv
find find-tail find find-tail
any every any every
list-index list-index
take-while drop-while take-while! take-while drop-while take-while!
span break span! break!) span break span! break!)
;; # Deleting ;; # Deleting
;; delete delete-duplicates ;; delete delete-duplicates
@ -550,26 +550,26 @@
(define (delete-duplicates list . =) (define (delete-duplicates list . =)
(let ((= (if (null? =) equal? (car =)))) (let ((= (if (null? =) equal? (car =))))
(let rec ((list list)) (let rec ((list list) (cont values))
(if (null? list) (if (null? list)
list (cont '())
(let* ((x (car list)) (let* ((x (car list))
(rest (cdr list)) (rest (cdr list))
(deleted (rec (delete x list =)))) (deleted (delete x rest =)))
(if (eq? rest deleted) list (cons x deleted))))))) (rec deleted (lambda (y) (cont (cons x y)))))))))
(define (delete-duplicates! list . =) (define (delete-duplicates! list . =)
(let ((= (if (null? =) equal? (car =)))) (let ((= (if (null? =) equal? (car =))))
(let rec ((list list)) (let rec ((list list) (cont values))
(if (null? list) (if (null? list)
list (cont '())
(let* ((x (car list)) (let* ((x (car list))
(rest (cdr list)) (rest (cdr list))
(deleted (rec (delete! x list =)))) (deleted (delete! x list =)))
(if (eq? rest deleted) list (cons x deleted))))))) (rec deleted (lambda (y) (cont (cons x y)))))))))
(export delete delete-duplicates (export delete delete-duplicates
delete! delete-duplicates!) delete! delete-duplicates!)
;; # Association lists ;; # Association lists
;; assoc assq assv ;; assoc assq assv
@ -590,8 +590,8 @@
(remove! (lambda (x) (= key (car x))) alist))) (remove! (lambda (x) (= key (car x))) alist)))
(export assoc assq assv (export assoc assq assv
alist-cons alist-copy alist-cons alist-copy
alist-delete alist-delete!) alist-delete alist-delete!)
;; # Set operations on lists ;; # Set operations on lists
;; lset<= lset= lset-adjoin ;; lset<= lset= lset-adjoin
@ -602,156 +602,156 @@
;; lset-diff+intersenction lset-diff+intersection! ;; lset-diff+intersenction lset-diff+intersection!
(define (lset<= = . lists) (define (lset<= = . lists)
(or (null? lists) (or (null? lists)
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(or (null? rest) (or (null? rest)
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(and (or (eq? head next) (and (or (eq? head next)
(every (lambda (x) (member x next =)) head)) (every (lambda (x) (member x next =)) head))
(rec next rest))))))) (rec next rest)))))))
(define (lset= = . lists) (define (lset= = . lists)
(or (null? lists) (or (null? lists)
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(or (null? rest) (or (null? rest)
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(and (or (eq? head next) (and (or (eq? head next)
(and (every (lambda (x) (member x next =)) head) (and (every (lambda (x) (member x next =)) head)
(every (lambda (x) (member x head =)) next)) (every (lambda (x) (member x head =)) next))
(rec next rest)))))))) (rec next rest))))))))
(define (lset-adjoin = list . elts) (define (lset-adjoin = list . elts)
(let rec ((list list) (elts elts)) (let rec ((list list) (elts elts))
(if (null? elts) (if (null? elts)
list list
(if (member (car elts) list) (if (member (car elts) list)
(rec list (cdr elts)) (rec list (cdr elts))
(rec (cons (car elts) list) (cdr elts)))))) (rec (cons (car elts) list) (cdr elts))))))
(define (lset-union = . lists) (define (lset-union = . lists)
(if (null? lists) (if (null? lists)
lists lists
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
(rec head rest) (rec head rest)
(rec (apply lset-adjoin = head next) rest))))))) (rec (apply lset-adjoin = head next) rest)))))))
(define (lset-intersection = . lists) (define (lset-intersection = . lists)
(if (null? lists) (if (null? lists)
lists lists
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
(rec head rest) (rec head rest)
(rec (filter (lambda (x) (member x next =)) head) (rec (filter (lambda (x) (member x next =)) head)
rest))))))) rest)))))))
(define (lset-difference = list . lists) (define (lset-difference = list . lists)
(let rec ((head list) (rest lists)) (let rec ((head list) (rest lists))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
'() '()
(rec (remove (lambda (x) (member x next =)) head) (rec (remove (lambda (x) (member x next =)) head)
rest)))))) rest))))))
(define (lset-xor = . lists) (define (lset-xor = . lists)
(if (null? lists) (if (null? lists)
lists lists
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
'() '()
(rec (append (remove (lambda (x) (member x next =)) head) (rec (append (remove (lambda (x) (member x next =)) head)
(remove (lambda (x) (member x head =)) next)) (remove (lambda (x) (member x head =)) next))
rest))))))) rest)))))))
(define (lset-diff+intersection = list . lists) (define (lset-diff+intersection = list . lists)
(values (apply lset-difference = list lists) (values (apply lset-difference = list lists)
(lset-intersection = list (apply lset-union lists)))) (lset-intersection = list (apply lset-union lists))))
(define (lset-adjoin! = list . elts) (define (lset-adjoin! = list . elts)
(let rec ((list list) (elts elts)) (let rec ((list list) (elts elts))
(if (null? elts) (if (null? elts)
list list
(if (member (car elts) list) (if (member (car elts) list)
(rec list (cdr elts)) (rec list (cdr elts))
(let ((tail (cdr elts))) (let ((tail (cdr elts)))
(set-cdr! elts list) (set-cdr! elts list)
(rec elts tail)))))) (rec elts tail))))))
(define (lset-union! = . lists) (define (lset-union! = . lists)
(letrec ((adjoin (letrec ((adjoin
(lambda (lst1 lst2) (lambda (lst1 lst2)
(if (null? lst2) (if (null? lst2)
lst1 lst1
(if (member (car lst2) lst1 =) (if (member (car lst2) lst1 =)
(adjoin lst1 (cdr lst2)) (adjoin lst1 (cdr lst2))
(let ((tail (cdr lst2))) (let ((tail (cdr lst2)))
(set-cdr! lst2 lst1) (set-cdr! lst2 lst1)
(adjoin lst2 tail))))))) (adjoin lst2 tail)))))))
(if (null? lists) (if (null? lists)
lists lists
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
(rec head rest) (rec head rest)
(rec (adjoin head next) rest)))))))) (rec (adjoin head next) rest))))))))
(define (lset-intersection! = . lists) (define (lset-intersection! = . lists)
(if (null? lists) (if (null? lists)
lists lists
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
(rec head rest) (rec head rest)
(rec (filter! (lambda (x) (member x next =)) head) (rec (filter! (lambda (x) (member x next =)) head)
rest))))))) rest)))))))
(define (lset-difference! = list . lists) (define (lset-difference! = list . lists)
(let rec ((head list) (rest lists)) (let rec ((head list) (rest lists))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
'() '()
(rec (remove! (lambda (x) (member x next =)) head) (rec (remove! (lambda (x) (member x next =)) head)
rest)))))) rest))))))
(define (lset-xor! = . lists) (define (lset-xor! = . lists)
(if (null? lists) (if (null? lists)
lists lists
(let rec ((head (car lists)) (rest (cdr lists))) (let rec ((head (car lists)) (rest (cdr lists)))
(if (null? rest) (if (null? rest)
head head
(let ((next (car rest)) (rest (cdr rest))) (let ((next (car rest)) (rest (cdr rest)))
(if (eq? head next) (if (eq? head next)
'() '()
(rec (append! (remove! (lambda (x) (member x next =)) head) (rec (append! (remove! (lambda (x) (member x next =)) head)
(remove! (lambda (x) (member x head =)) next)) (remove! (lambda (x) (member x head =)) next))
rest))))))) rest)))))))
(define (lset-diff+intersection! = list . lists) (define (lset-diff+intersection! = list . lists)
(values (apply lset-difference! = list lists) (values (apply lset-difference! = list lists)
(lset-intersection! = list (apply lset-union! lists)))) (lset-intersection! = list (apply lset-union! lists))))
(export lset<= lset= lset-adjoin (export lset<= lset= lset-adjoin
lset-union lset-union! lset-union lset-union!
lset-intersection lset-intersection! lset-intersection lset-intersection!
lset-difference lset-difference! lset-difference lset-difference!
lset-xor lset-xor! lset-xor lset-xor!
lset-diff+intersection lset-diff+intersection!) lset-diff+intersection lset-diff+intersection!)
;; # Primitive side-effects ;; # Primitive side-effects
;; set-car! set-cdr! ;; set-car! set-cdr!