Merge pull request #152 from stibear/srfi1
implements delete-duplicates(!) tail-recursively
This commit is contained in:
Yuichi Nishiwaki
commit
e489b3f6ec
|
|
@ -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!
|
||||
|
|
|
|||
Loading…
Reference in New Issue