123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062 |
- (define-module (srfi srfi-1)
- :export (
-
-
- xcons
-
-
- list-tabulate
- list-copy
- circular-list
-
- proper-list?
- circular-list?
- dotted-list?
-
-
- null-list?
- not-pair?
- list=
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- first
- second
- third
- fourth
- fifth
- sixth
- seventh
- eighth
- ninth
- tenth
- car+cdr
- take
- drop
- take-right
- drop-right
- take!
- drop-right!
- split-at
- split-at!
- last
-
-
- length+
-
-
- concatenate
- concatenate!
-
-
- append-reverse
- append-reverse!
- zip
- unzip1
- unzip2
- unzip3
- unzip4
- unzip5
- count
- fold
- fold-right
- pair-fold
- pair-fold-right
- reduce
- reduce-right
- unfold
- unfold-right
-
-
- append-map
- append-map!
- map!
-
- pair-for-each
- filter-map
-
- partition
- remove
-
- partition!
- remove!
- find
- find-tail
- take-while
- take-while!
- drop-while
- span
- span!
- break
- break!
- any
- every
-
-
-
-
-
-
- delete-duplicates
- delete-duplicates!
-
-
-
- alist-cons
- alist-copy
- alist-delete
- alist-delete!
- lset<=
- lset=
- lset-adjoin
- lset-union
- lset-intersection
- lset-difference
- lset-xor
- lset-diff+intersection
- lset-union!
- lset-intersection!
- lset-difference!
- lset-xor!
- lset-diff+intersection!
-
-
- )
- :re-export (cons list cons* make-list pair? null?
- car cdr 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
- list-ref last-pair length append append! reverse reverse!
- filter filter! memq memv assq assv set-car! set-cdr!)
- :replace (iota map for-each map-in-order list-copy list-index member
- delete delete! assoc)
- )
- (cond-expand-provide (current-module) '(srfi-1))
- (load-extension (string-append "libguile-" (effective-version))
- "scm_init_srfi_1")
- (define (xcons d a)
- "Like `cons', but with interchanged arguments. Useful mostly when passed to
- higher-order procedures."
- (cons a d))
- (define (wrong-type-arg caller arg)
- (scm-error 'wrong-type-arg (symbol->string caller)
- "Wrong type argument: ~S" (list arg) '()))
- (define-syntax-rule (check-arg pred arg caller)
- (if (not (pred arg))
- (wrong-type-arg 'caller arg)))
- (define (out-of-range proc arg)
- (scm-error 'out-of-range proc
- "Value out of range: ~A" (list arg) (list arg)))
- (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
- (define (list-tabulate n init-proc)
- "Return an N-element list, where each list element is produced by applying the
- procedure INIT-PROC to the corresponding list index. The order in which
- INIT-PROC is applied to the indices is not specified."
- (check-arg non-negative-integer? n list-tabulate)
- (let lp ((n n) (acc '()))
- (if (<= n 0)
- acc
- (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
- (define (circular-list elt1 . elts)
- (set! elts (cons elt1 elts))
- (set-cdr! (last-pair elts) elts)
- elts)
- (define* (iota count #:optional (start 0) (step 1))
- (check-arg non-negative-integer? count iota)
- (let lp ((n 0) (acc '()))
- (if (= n count)
- (reverse! acc)
- (lp (+ n 1) (cons (+ start (* n step)) acc)))))
- (define (proper-list? x)
- (list? x))
- (define (circular-list? x)
- (if (not-pair? x)
- #f
- (let lp ((hare (cdr x)) (tortoise x))
- (if (not-pair? hare)
- #f
- (let ((hare (cdr hare)))
- (if (not-pair? hare)
- #f
- (if (eq? hare tortoise)
- #t
- (lp (cdr hare) (cdr tortoise)))))))))
- (define (dotted-list? x)
- (cond
- ((null? x) #f)
- ((not-pair? x) #t)
- (else
- (let lp ((hare (cdr x)) (tortoise x))
- (cond
- ((null? hare) #f)
- ((not-pair? hare) #t)
- (else
- (let ((hare (cdr hare)))
- (cond
- ((null? hare) #f)
- ((not-pair? hare) #t)
- ((eq? hare tortoise) #f)
- (else
- (lp (cdr hare) (cdr tortoise)))))))))))
- (define (null-list? x)
- (cond
- ((proper-list? x)
- (null? x))
- ((circular-list? x)
- #f)
- (else
- (error "not a proper list in null-list?"))))
- (define (not-pair? x)
- "Return #t if X is not a pair, #f otherwise.
- This is shorthand notation `(not (pair? X))' and is supposed to be used for
- end-of-list checking in contexts where dotted lists are allowed."
- (not (pair? x)))
- (define (list= elt= . rest)
- (define (lists-equal a b)
- (let lp ((a a) (b b))
- (cond ((null? a)
- (null? b))
- ((null? b)
- #f)
- (else
- (and (elt= (car a) (car b))
- (lp (cdr a) (cdr b)))))))
- (check-arg procedure? elt= list=)
- (or (null? rest)
- (let lp ((lists rest))
- (or (null? (cdr lists))
- (and (lists-equal (car lists) (cadr lists))
- (lp (cdr lists)))))))
- (define first car)
- (define second cadr)
- (define third caddr)
- (define fourth cadddr)
- (define (fifth x) (car (cddddr x)))
- (define (sixth x) (cadr (cddddr x)))
- (define (seventh x) (caddr (cddddr x)))
- (define (eighth x) (cadddr (cddddr x)))
- (define (ninth x) (car (cddddr (cddddr x))))
- (define (tenth x) (cadr (cddddr (cddddr x))))
- (define (car+cdr x)
- "Return two values, the `car' and the `cdr' of PAIR."
- (values (car x) (cdr x)))
- (define take list-head)
- (define drop list-tail)
- (define (take-right lis k)
- (let lp ((lag lis) (lead (drop lis k)))
- (if (pair? lead)
- (lp (cdr lag) (cdr lead))
- lag)))
- (define (drop-right lis k)
- (let recur ((lag lis) (lead (drop lis k)))
- (if (pair? lead)
- (cons (car lag) (recur (cdr lag) (cdr lead)))
- '())))
- (define (take! lst i)
- "Linear-update variant of `take'."
- (if (= i 0)
- '()
- (let ((tail (drop lst (- i 1))))
- (set-cdr! tail '())
- lst)))
- (define (drop-right! lst i)
- "Linear-update variant of `drop-right'."
- (let ((tail (drop lst i)))
- (if (null? tail)
- '()
- (let loop ((prev lst)
- (tail (cdr tail)))
- (if (null? tail)
- (if (pair? prev)
- (begin
- (set-cdr! prev '())
- lst)
- lst)
- (loop (cdr prev)
- (cdr tail)))))))
- (define (split-at lst i)
- "Return two values, a list of the elements before index I in LST, and
- a list of those after."
- (if (< i 0)
- (out-of-range 'split-at i)
- (let lp ((l lst) (n i) (acc '()))
- (if (<= n 0)
- (values (reverse! acc) l)
- (lp (cdr l) (- n 1) (cons (car l) acc))))))
- (define (split-at! lst i)
- "Linear-update variant of `split-at'."
- (cond ((< i 0)
- (out-of-range 'split-at! i))
- ((= i 0)
- (values '() lst))
- (else
- (let lp ((l lst) (n (- i 1)))
- (if (<= n 0)
- (let ((tmp (cdr l)))
- (set-cdr! l '())
- (values lst tmp))
- (lp (cdr l) (- n 1)))))))
- (define (last pair)
- "Return the last element of the non-empty, finite list PAIR."
- (car (last-pair pair)))
- (define (zip clist1 . rest)
- (let lp ((l (cons clist1 rest)) (acc '()))
- (if (any null? l)
- (reverse! acc)
- (lp (map cdr l) (cons (map car l) acc)))))
- (define (unzip1 l)
- (map first l))
- (define (unzip2 l)
- (values (map first l) (map second l)))
- (define (unzip3 l)
- (values (map first l) (map second l) (map third l)))
- (define (unzip4 l)
- (values (map first l) (map second l) (map third l) (map fourth l)))
- (define (unzip5 l)
- (values (map first l) (map second l) (map third l) (map fourth l)
- (map fifth l)))
- (define fold
- (case-lambda
- "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
- that result. See the manual for details."
- ((kons knil list1)
- (check-arg procedure? kons fold)
- (check-arg list? list1 fold)
- (let fold1 ((knil knil) (list1 list1))
- (if (pair? list1)
- (fold1 (kons (car list1) knil) (cdr list1))
- knil)))
- ((kons knil list1 list2)
- (check-arg procedure? kons fold)
- (let* ((len1 (length+ list1))
- (len2 (length+ list2))
- (len (if (and len1 len2)
- (min len1 len2)
- (or len1 len2))))
- (unless len
- (scm-error 'wrong-type-arg "fold"
- "Args do not contain a proper (finite) list: ~S"
- (list (list list1 list2)) #f))
- (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
- (if (zero? len)
- knil
- (fold2 (kons (car list1) (car list2) knil)
- (cdr list1) (cdr list2) (1- len))))))
- ((kons knil list1 . rest)
- (check-arg procedure? kons fold)
- (let foldn ((knil knil) (lists (cons list1 rest)))
- (if (any null? lists)
- knil
- (let ((cars (map car lists))
- (cdrs (map cdr lists)))
- (foldn (apply kons (append! cars (list knil))) cdrs)))))))
- (define (fold-right kons knil clist1 . rest)
- (check-arg procedure? kons fold-right)
- (if (null? rest)
- (let loop ((lst (reverse clist1))
- (result knil))
- (if (null? lst)
- result
- (loop (cdr lst)
- (kons (car lst) result))))
- (let loop ((lists (map reverse (cons clist1 rest)))
- (result knil))
- (if (any1 null? lists)
- result
- (loop (map cdr lists)
- (apply kons (append! (map car lists) (list result))))))))
- (define (pair-fold kons knil clist1 . rest)
- (check-arg procedure? kons pair-fold)
- (if (null? rest)
- (let f ((knil knil) (list1 clist1))
- (if (null? list1)
- knil
- (let ((tail (cdr list1)))
- (f (kons list1 knil) tail))))
- (let f ((knil knil) (lists (cons clist1 rest)))
- (if (any null? lists)
- knil
- (let ((tails (map cdr lists)))
- (f (apply kons (append! lists (list knil))) tails))))))
- (define (pair-fold-right kons knil clist1 . rest)
- (check-arg procedure? kons pair-fold-right)
- (if (null? rest)
- (let f ((list1 clist1))
- (if (null? list1)
- knil
- (kons list1 (f (cdr list1)))))
- (let f ((lists (cons clist1 rest)))
- (if (any null? lists)
- knil
- (apply kons (append! lists (list (f (map cdr lists)))))))))
- (define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
- (define (reverse+tail lst seed)
- (let loop ((lst lst)
- (result (tail-gen seed)))
- (if (null? lst)
- result
- (loop (cdr lst)
- (cons (car lst) result)))))
- (check-arg procedure? p unfold)
- (check-arg procedure? f unfold)
- (check-arg procedure? g unfold)
- (check-arg procedure? tail-gen unfold)
- (let loop ((seed seed)
- (result '()))
- (if (p seed)
- (reverse+tail result seed)
- (loop (g seed)
- (cons (f seed) result)))))
- (define* (unfold-right p f g seed #:optional (tail '()))
- (check-arg procedure? p unfold-right)
- (check-arg procedure? f unfold-right)
- (check-arg procedure? g unfold-right)
- (let uf ((seed seed) (lis tail))
- (if (p seed)
- lis
- (uf (g seed) (cons (f seed) lis)))))
- (define (reduce f ridentity lst)
- "`reduce' is a variant of `fold', where the first call to F is on two
- elements from LST, rather than one element and a given initial value.
- If LST is empty, RIDENTITY is returned. If LST has just one element
- then that's the return value."
- (check-arg procedure? f reduce)
- (if (null? lst)
- ridentity
- (fold f (car lst) (cdr lst))))
- (define (reduce-right f ridentity lst)
- "`reduce-right' is a variant of `fold-right', where the first call to
- F is on two elements from LST, rather than one element and a given
- initial value. If LST is empty, RIDENTITY is returned. If LST
- has just one element then that's the return value."
- (check-arg procedure? f reduce)
- (if (null? lst)
- ridentity
- (fold-right f (last lst) (drop-right lst 1))))
- (define map
- (case-lambda
- ((f l)
- (check-arg procedure? f map)
- (check-arg list? l map)
- (let map1 ((l l))
- (if (pair? l)
- (cons (f (car l)) (map1 (cdr l)))
- '())))
-
- ((f l1 l2)
- (check-arg procedure? f map)
- (let* ((len1 (length+ l1))
- (len2 (length+ l2))
- (len (if (and len1 len2)
- (min len1 len2)
- (or len1 len2))))
- (unless len
- (scm-error 'wrong-type-arg "map"
- "Args do not contain a proper (finite) list: ~S"
- (list (list l1 l2)) #f))
- (let map2 ((l1 l1) (l2 l2) (len len))
- (if (zero? len)
- '()
- (cons (f (car l1) (car l2))
- (map2 (cdr l1) (cdr l2) (1- len)))))))
- ((f l1 . rest)
- (check-arg procedure? f map)
- (let ((len (fold (lambda (ls len)
- (let ((ls-len (length+ ls)))
- (if len
- (if ls-len (min ls-len len) len)
- ls-len)))
- (length+ l1)
- rest)))
- (if (not len)
- (scm-error 'wrong-type-arg "map"
- "Args do not contain a proper (finite) list: ~S"
- (list (cons l1 rest)) #f))
- (let mapn ((l1 l1) (rest rest) (len len))
- (if (zero? len)
- '()
- (cons (apply f (car l1) (map car rest))
- (mapn (cdr l1) (map cdr rest) (1- len)))))))))
- (define map-in-order map)
- (define for-each
- (case-lambda
- ((f l)
- (check-arg procedure? f for-each)
- (check-arg list? l for-each)
- (let for-each1 ((l l))
- (unless (null? l)
- (f (car l))
- (for-each1 (cdr l)))))
- ((f l1 l2)
- (check-arg procedure? f for-each)
- (let* ((len1 (length+ l1))
- (len2 (length+ l2))
- (len (if (and len1 len2)
- (min len1 len2)
- (or len1 len2))))
- (unless len
- (scm-error 'wrong-type-arg "for-each"
- "Args do not contain a proper (finite) list: ~S"
- (list (list l1 l2)) #f))
- (let for-each2 ((l1 l1) (l2 l2) (len len))
- (unless (zero? len)
- (f (car l1) (car l2))
- (for-each2 (cdr l1) (cdr l2) (1- len))))))
- ((f l1 . rest)
- (check-arg procedure? f for-each)
- (let ((len (fold (lambda (ls len)
- (let ((ls-len (length+ ls)))
- (if len
- (if ls-len (min ls-len len) len)
- ls-len)))
- (length+ l1)
- rest)))
- (if (not len)
- (scm-error 'wrong-type-arg "for-each"
- "Args do not contain a proper (finite) list: ~S"
- (list (cons l1 rest)) #f))
- (let for-eachn ((l1 l1) (rest rest) (len len))
- (if (> len 0)
- (begin
- (apply f (car l1) (map car rest))
- (for-eachn (cdr l1) (map cdr rest) (1- len)))))))))
- (define (append-map f clist1 . rest)
- (concatenate (apply map f clist1 rest)))
-
- (define (append-map! f clist1 . rest)
- (concatenate! (apply map f clist1 rest)))
- (define map! map)
- (define (filter-map proc list1 . rest)
- "Apply PROC to the elements of LIST1... and return a list of the
- results as per SRFI-1 `map', except that any #f results are omitted from
- the list returned."
- (check-arg procedure? proc filter-map)
- (if (null? rest)
- (let lp ((l list1)
- (rl '()))
- (if (null? l)
- (reverse! rl)
- (let ((res (proc (car l))))
- (if res
- (lp (cdr l) (cons res rl))
- (lp (cdr l) rl)))))
- (let lp ((l (cons list1 rest))
- (rl '()))
- (if (any1 null? l)
- (reverse! rl)
- (let ((res (apply proc (map car l))))
- (if res
- (lp (map cdr l) (cons res rl))
- (lp (map cdr l) rl)))))))
- (define (pair-for-each f clist1 . rest)
- (check-arg procedure? f pair-for-each)
- (if (null? rest)
- (let lp ((l clist1))
- (if (null? l)
- (if #f #f)
- (begin
- (f l)
- (lp (cdr l)))))
- (let lp ((l (cons clist1 rest)))
- (if (any1 null? l)
- (if #f #f)
- (begin
- (apply f l)
- (lp (map cdr l)))))))
- (define (take-while pred ls)
- "Return a new list which is the longest initial prefix of LS whose
- elements all satisfy the predicate PRED."
- (check-arg procedure? pred take-while)
- (cond ((null? ls) '())
- ((not (pred (car ls))) '())
- (else
- (let ((result (list (car ls))))
- (let lp ((ls (cdr ls)) (p result))
- (cond ((null? ls) result)
- ((not (pred (car ls))) result)
- (else
- (set-cdr! p (list (car ls)))
- (lp (cdr ls) (cdr p)))))))))
- (define (take-while! pred lst)
- "Linear-update variant of `take-while'."
- (check-arg procedure? pred take-while!)
- (let loop ((prev #f)
- (rest lst))
- (cond ((null? rest)
- lst)
- ((pred (car rest))
- (loop rest (cdr rest)))
- (else
- (if (pair? prev)
- (begin
- (set-cdr! prev '())
- lst)
- '())))))
- (define (drop-while pred lst)
- "Drop the longest initial prefix of LST whose elements all satisfy the
- predicate PRED."
- (check-arg procedure? pred drop-while)
- (let loop ((lst lst))
- (cond ((null? lst)
- '())
- ((pred (car lst))
- (loop (cdr lst)))
- (else lst))))
- (define (span pred lst)
- "Return two values, the longest initial prefix of LST whose elements
- all satisfy the predicate PRED, and the remainder of LST."
- (check-arg procedure? pred span)
- (let lp ((lst lst) (rl '()))
- (if (and (not (null? lst))
- (pred (car lst)))
- (lp (cdr lst) (cons (car lst) rl))
- (values (reverse! rl) lst))))
- (define (span! pred list)
- "Linear-update variant of `span'."
- (check-arg procedure? pred span!)
- (let loop ((prev #f)
- (rest list))
- (cond ((null? rest)
- (values list '()))
- ((pred (car rest))
- (loop rest (cdr rest)))
- (else
- (if (pair? prev)
- (begin
- (set-cdr! prev '())
- (values list rest))
- (values '() list))))))
- (define (break pred clist)
- "Return two values, the longest initial prefix of LST whose elements
- all fail the predicate PRED, and the remainder of LST."
- (check-arg procedure? pred break)
- (let lp ((clist clist) (rl '()))
- (if (or (null? clist)
- (pred (car clist)))
- (values (reverse! rl) clist)
- (lp (cdr clist) (cons (car clist) rl)))))
- (define (break! pred list)
- "Linear-update variant of `break'."
- (check-arg procedure? pred break!)
- (let loop ((l list)
- (prev #f))
- (cond ((null? l)
- (values list '()))
- ((pred (car l))
- (if (pair? prev)
- (begin
- (set-cdr! prev '())
- (values list l))
- (values '() list)))
- (else
- (loop (cdr l) l)))))
- (define (any pred ls . lists)
- (check-arg procedure? pred any)
- (if (null? lists)
- (any1 pred ls)
- (let lp ((lists (cons ls lists)))
- (cond ((any1 null? lists)
- #f)
- ((any1 null? (map cdr lists))
- (apply pred (map car lists)))
- (else
- (or (apply pred (map car lists)) (lp (map cdr lists))))))))
- (define (any1 pred ls)
- (let lp ((ls ls))
- (cond ((null? ls)
- #f)
- ((null? (cdr ls))
- (pred (car ls)))
- (else
- (or (pred (car ls)) (lp (cdr ls)))))))
- (define (every pred ls . lists)
- (check-arg procedure? pred every)
- (if (null? lists)
- (every1 pred ls)
- (let lp ((lists (cons ls lists)))
- (cond ((any1 null? lists)
- #t)
- ((any1 null? (map cdr lists))
- (apply pred (map car lists)))
- (else
- (and (apply pred (map car lists)) (lp (map cdr lists))))))))
- (define (every1 pred ls)
- (let lp ((ls ls))
- (cond ((null? ls)
- #t)
- ((null? (cdr ls))
- (pred (car ls)))
- (else
- (and (pred (car ls)) (lp (cdr ls)))))))
- (define (list-index pred clist1 . rest)
- "Return the index of the first set of elements, one from each of
- CLIST1 ... CLISTN, that satisfies PRED."
- (check-arg procedure? pred list-index)
- (if (null? rest)
- (let lp ((l clist1) (i 0))
- (if (null? l)
- #f
- (if (pred (car l))
- i
- (lp (cdr l) (+ i 1)))))
- (let lp ((lists (cons clist1 rest)) (i 0))
- (cond ((any1 null? lists)
- #f)
- ((apply pred (map car lists)) i)
- (else
- (lp (map cdr lists) (+ i 1)))))))
- (define alist-cons acons)
- (define (alist-copy alist)
- "Return a copy of ALIST, copying both the pairs comprising the list
- and those making the associations."
- (let lp ((a alist)
- (rl '()))
- (if (null? a)
- (reverse! rl)
- (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
- (define* (alist-delete key alist #:optional (k= equal?))
- (check-arg procedure? k= alist-delete)
- (let lp ((a alist) (rl '()))
- (if (null? a)
- (reverse! rl)
- (if (k= key (caar a))
- (lp (cdr a) rl)
- (lp (cdr a) (cons (car a) rl))))))
- (define* (alist-delete! key alist #:optional (k= equal?))
- (alist-delete key alist k=))
- (define* (member x ls #:optional (= equal?))
- (cond
-
-
- ((eq? = eq?) (memq x ls))
- ((eq? = eqv?) (memv x ls))
- (else
- (check-arg procedure? = member)
- (find-tail (lambda (y) (= x y)) ls))))
- (define (lset<= = . rest)
- (check-arg procedure? = lset<=)
- (if (null? rest)
- #t
- (let lp ((f (car rest)) (r (cdr rest)))
- (or (null? r)
- (and (every (lambda (el) (member el (car r) =)) f)
- (lp (car r) (cdr r)))))))
- (define (lset= = . rest)
- (check-arg procedure? = lset<=)
- (if (null? rest)
- #t
- (let lp ((f (car rest)) (r (cdr rest)))
- (or (null? r)
- (and (every (lambda (el) (member el (car r) =)) f)
- (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
- (lp (car r) (cdr r)))))))
- (define (lset-adjoin = list . rest)
- "Add to LIST any of the elements of REST not already in the list.
- These elements are `cons'ed onto the start of LIST (so the return shares
- a common tail with LIST), but the order they're added is unspecified.
- The given `=' procedure is used for comparing elements, called
- as `(@var{=} listelem elem)', i.e., the second argument is one of the
- given REST parameters."
-
-
-
- (define pred
- (if (or (eq? = eq?) (eq? = eqv?))
- =
- (begin
- (check-arg procedure? = lset-adjoin)
- (lambda (x y) (= y x)))))
-
- (let lp ((ans list) (rest rest))
- (if (null? rest)
- ans
- (lp (if (member (car rest) ans pred)
- ans
- (cons (car rest) ans))
- (cdr rest)))))
- (define (lset-union = . rest)
-
- (define pred
- (if (or (eq? = eq?) (eq? = eqv?))
- =
- (begin
- (check-arg procedure? = lset-union)
- (lambda (x y) (= y x)))))
-
- (fold (lambda (lis ans)
- (cond ((null? lis) ans)
- ((null? ans) lis)
- ((eq? lis ans) ans)
- (else
- (fold (lambda (elt ans)
- (if (member elt ans pred)
- ans
- (cons elt ans)))
- ans lis))))
- '()
- rest))
- (define (lset-intersection = list1 . rest)
- (check-arg procedure? = lset-intersection)
- (let lp ((l list1) (acc '()))
- (if (null? l)
- (reverse! acc)
- (if (every (lambda (ll) (member (car l) ll =)) rest)
- (lp (cdr l) (cons (car l) acc))
- (lp (cdr l) acc)))))
- (define (lset-difference = list1 . rest)
- (check-arg procedure? = lset-difference)
- (if (null? rest)
- list1
- (let lp ((l list1) (acc '()))
- (if (null? l)
- (reverse! acc)
- (if (any (lambda (ll) (member (car l) ll =)) rest)
- (lp (cdr l) acc)
- (lp (cdr l) (cons (car l) acc)))))))
- (define (lset-xor = . rest)
- (check-arg procedure? = lset-xor)
- (fold (lambda (lst res)
- (let lp ((l lst) (acc '()))
- (if (null? l)
- (let lp0 ((r res) (acc acc))
- (if (null? r)
- (reverse! acc)
- (if (member (car r) lst =)
- (lp0 (cdr r) acc)
- (lp0 (cdr r) (cons (car r) acc)))))
- (if (member (car l) res =)
- (lp (cdr l) acc)
- (lp (cdr l) (cons (car l) acc))))))
- '()
- rest))
- (define (lset-diff+intersection = list1 . rest)
- (check-arg procedure? = lset-diff+intersection)
- (let lp ((l list1) (accd '()) (acci '()))
- (if (null? l)
- (values (reverse! accd) (reverse! acci))
- (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
- (if appears
- (lp (cdr l) accd (cons (car l) acci))
- (lp (cdr l) (cons (car l) accd) acci))))))
- (define (lset-union! = . rest)
- (check-arg procedure? = lset-union!)
- (apply lset-union = rest))
- (define (lset-intersection! = list1 . rest)
- (check-arg procedure? = lset-intersection!)
- (apply lset-intersection = list1 rest))
- (define (lset-xor! = . rest)
- (check-arg procedure? = lset-xor!)
- (apply lset-xor = rest))
- (define (lset-diff+intersection! = list1 . rest)
- (check-arg procedure? = lset-diff+intersection!)
- (apply lset-diff+intersection = list1 rest))
|