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