--- /dev/null
+;;;; srfi-1.scm --- SRFI-1 procedures for Guile
+;;;;
+;;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 2, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;
+;;;; As a special exception, the Free Software Foundation gives permission
+;;;; for additional uses of the text contained in its release of GUILE.
+;;;;
+;;;; The exception is that, if you link the GUILE library with other files
+;;;; to produce an executable, this does not by itself cause the
+;;;; resulting executable to be covered by the GNU General Public License.
+;;;; Your use of that executable is in no way restricted on account of
+;;;; linking the GUILE library code into it.
+;;;;
+;;;; This exception does not however invalidate any other reasons why
+;;;; the executable file might be covered by the GNU General Public License.
+;;;;
+;;;; This exception applies only to the code released by the
+;;;; Free Software Foundation under the name GUILE. If you copy
+;;;; code from other Free Software Foundation releases into a copy of
+;;;; GUILE, as the General Public License permits, the exception does
+;;;; not apply to the code that you add in this way. To avoid misleading
+;;;; anyone as to the status of such modified files, you must delete
+;;;; this exception notice from them.
+;;;;
+;;;; If you write modifications of your own for GUILE, it is your choice
+;;;; whether to permit this exception to apply to your modifications.
+;;;; If you do not wish that, delete this exception notice.
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;; Date: 2001-06-06
+
+;;; Commentary:
+
+;;; This is an implementation of SRFI-1 (List Library)
+;;;
+;;; All procedures defined in SRFI-1, which are not already defined in
+;;; the Guile core library, are exported. The procedures in this
+;;; implementation work, but they have not been tuned for speed or
+;;; memory usage.
+;;;
+
+;;; Code:
+
+(define-module (srfi srfi-1)
+ :use-module (ice-9 receive))
+
+(export
+;;; Constructors
+ ;; cons <= in the core
+ ;; list <= in the core
+ xcons
+ ;; cons* <= in the core
+ ;; make-list <= in the core
+ list-tabulate
+ ;; list-copy <= in the core
+ circular-list
+ iota
+
+;;; Predicates
+ proper-list?
+ circular-list?
+ dotted-list?
+ ;; pair? <= in the core
+ ;; null? <= in the core
+ null-list?
+ not-pair?
+ list=
+
+;;; Selectors
+ ;; car <= in the core
+ ;; cdr <= in the core
+ ;; caar <= in the core
+ ;; cadr <= in the core
+ ;; cdar <= in the core
+ ;; cddr <= in the core
+ ;; caaar <= in the core
+ ;; caadr <= in the core
+ ;; cadar <= in the core
+ ;; caddr <= in the core
+ ;; cdaar <= in the core
+ ;; cdadr <= in the core
+ ;; cddar <= in the core
+ ;; cdddr <= in the core
+ ;; caaaar <= in the core
+ ;; caaadr <= in the core
+ ;; caadar <= in the core
+ ;; caaddr <= in the core
+ ;; cadaar <= in the core
+ ;; cadadr <= in the core
+ ;; caddar <= in the core
+ ;; cadddr <= in the core
+ ;; cdaaar <= in the core
+ ;; cdaadr <= in the core
+ ;; cdadar <= in the core
+ ;; cdaddr <= in the core
+ ;; cddaar <= in the core
+ ;; cddadr <= in the core
+ ;; cdddar <= in the core
+ ;; cddddr <= in the core
+ ;; list-ref <= in the core
+ 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
+ ;; last-pair <= in the core
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+ ;; length <= in the core
+ length+
+ ;; append <= in the core
+ ;; append! <= in the core
+ concatenate
+ concatenate!
+ ;; reverse <= in the core
+ ;; reverse! <= in the core
+ append-reverse
+ append-reverse!
+ zip
+ unzip1
+ unzip2
+ unzip3
+ unzip4
+ unzip5
+ count
+
+;;; Fold, unfold & map
+ fold
+ fold-right
+ pair-fold
+ pair-fold-right
+ reduce
+ reduce-right
+ unfold
+ unfold-right
+ ;; map <= in the core
+ ;; for-each <= in the core
+ append-map
+ append-map!
+ map!
+ ;; map-in-order <= in the core
+ pair-for-each
+ filter-map
+
+;;; Filtering & partitioning
+ filter
+ partition
+ remove
+ filter!
+ partition!
+ remove!
+
+;;; Searching
+ find
+ find-tail
+ take-while
+ take-while!
+ drop-while
+ span
+ span!
+ break
+ break!
+ any
+ every
+ list-index
+ member ; Extended.
+ ;; memq <= in the core
+ ;; memv <= in the core
+
+;;; Deletion
+ delete ; Extended.
+ delete!
+ delete-duplicates
+ delete-duplicates!
+
+;;; Association lists
+ assoc ; Extended.
+ ;; assq <= in the core
+ ;; assv <= in the core
+ alist-cons
+ alist-copy
+ alist-delete
+ alist-delete!
+
+;;; Set operations on lists
+ 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!
+
+;;; Primitive side-effects
+ ;; set-car! <= in the core
+ ;; set-cdr! <= in the core
+ )
+
+(cond-expand-provide (current-module) '(srfi-1))
+
+;;; Constructors
+
+(define (xcons d a)
+ (cons a d))
+
+(define (list-tabulate n init-proc)
+ (let lp ((n n) (acc '()))
+ (if (zero? n)
+ acc
+ (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
+
+(define (circular-list elt1 . rest)
+ (let ((start (cons elt1 '())))
+ (let lp ((r rest) (p start))
+ (if (null? r)
+ (begin
+ (set-cdr! p start)
+ start)
+ (begin
+ (set-cdr! p (cons (car r) '()))
+ (lp (cdr r) (cdr p)))))))
+
+(define (iota count . rest)
+ (let ((start (if (pair? rest) (car rest) 0))
+ (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
+ (let lp ((n 0) (acc '()))
+ (if (= n count)
+ (reverse! acc)
+ (lp (+ n 1) (cons (+ start (* n step)) acc))))))
+
+;;; Predicates
+
+(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)
+ (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)))))))
+ (or (null? rest)
+ (let ((first (car rest)))
+ (let lp ((lists rest))
+ (or (null? lists)
+ (and (lists-equal first (car lists))
+ (lp (cdr lists))))))))
+
+;;; Selectors
+
+(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) (values (car x) (cdr x)))
+
+(define (take x i)
+ (let lp ((n i) (l x) (acc '()))
+ (if (zero? n)
+ (reverse! acc)
+ (lp (- n 1) (cdr l) (cons (car l) acc)))))
+(define (drop x i)
+ (let lp ((n i) (l x))
+ (if (zero? n)
+ l
+ (lp (- n 1) (cdr l)))))
+(define (take-right flist i)
+ (let lp ((n i) (l flist))
+ (if (zero? n)
+ (let lp0 ((s flist) (l l))
+ (if (null? l)
+ s
+ (lp0 (cdr s) (cdr l))))
+ (lp (- n 1) (cdr l)))))
+
+(define (drop-right flist i)
+ (let lp ((n i) (l flist))
+ (if (zero? n)
+ (let lp0 ((s flist) (l l) (acc '()))
+ (if (null? l)
+ (reverse! acc)
+ (lp0 (cdr s) (cdr l) (cons (car s) acc))))
+ (lp (- n 1) (cdr l)))))
+
+(define (take! x i)
+ (if (zero? i)
+ '()
+ (let lp ((n (- i 1)) (l x))
+ (if (zero? n)
+ (begin
+ (set-cdr! l '())
+ x)
+ (lp (- n 1) (cdr l))))))
+
+(define (drop-right! flist i)
+ (if (zero? i)
+ flist
+ (let lp ((n (+ i 1)) (l flist))
+ (if (zero? n)
+ (let lp0 ((s flist) (l l))
+ (if (null? l)
+ (begin
+ (set-cdr! s '())
+ flist)
+ (lp0 (cdr s) (cdr l))))
+ (if (null? l)
+ '()
+ (lp (- n 1) (cdr l)))))))
+
+(define (split-at x i)
+ (let lp ((l x) (n i) (acc '()))
+ (if (zero? n)
+ (values (reverse! acc) l)
+ (lp (cdr l) (- n 1) (cons (car l) acc)))))
+
+(define (split-at! x i)
+ (if (zero? i)
+ (values '() x)
+ (let lp ((l x) (n (- i 1)))
+ (if (zero? n)
+ (let ((tmp (cdr l)))
+ (set-cdr! l '())
+ (values x tmp))
+ (lp (cdr l) (- n 1))))))
+
+(define (last pair)
+ (car (last-pair pair)))
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+
+(define (length+ clist)
+ (if (null? clist)
+ 0
+ (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
+ (if (null? hare)
+ l
+ (let ((hare (cdr hare)))
+ (if (null? hare)
+ (+ l 1)
+ (if (eq? hare tortoise)
+ #f
+ (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
+
+(define (concatenate l-o-l)
+ (let lp ((l l-o-l) (acc '()))
+ (if (null? l)
+ (reverse! acc)
+ (let lp0 ((ll (car l)) (acc acc))
+ (if (null? ll)
+ (lp (cdr l) acc)
+ (lp0 (cdr ll) (cons (car ll) acc)))))))
+
+(define (concatenate! l-o-l)
+ (let lp0 ((l-o-l l-o-l))
+ (cond
+ ((null? l-o-l)
+ '())
+ ((null? (car l-o-l))
+ (lp0 (cdr l-o-l)))
+ (else
+ (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
+ (let lp ((l (cdr l-o-l)) (ntail tail))
+ (if (null? l)
+ result
+ (begin
+ (set-cdr! ntail (car l))
+ (lp (cdr l) (last-pair ntail))))))))))
+
+
+(define (append-reverse rev-head tail)
+ (let lp ((l rev-head) (acc tail))
+ (if (null? l)
+ acc
+ (lp (cdr l) (cons (car l) acc)))))
+
+(define (append-reverse! rev-head tail)
+ (append-reverse rev-head tail)) ; XXX:optimize
+
+(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 (count pred clist1 . rest)
+ (if (null? rest)
+ (count1 pred clist1)
+ (let lp ((lists (cons clist1 rest)))
+ (cond ((any1 null? lists)
+ 0)
+ (else
+ (if (apply pred (map car lists))
+ (+ 1 (lp (map cdr lists)))
+ (lp (map cdr lists))))))))
+
+(define (count1 pred clist)
+ (if (null? clist)
+ 0
+ (if (pred (car clist))
+ (+ 1 (count1 pred (cdr clist)))
+ (count1 pred (cdr clist)))))
+
+;;; Fold, unfold & map
+
+(define (fold kons knil list1 . rest)
+ (if (null? rest)
+ (let f ((knil knil) (list1 list1))
+ (if (null? list1)
+ knil
+ (f (kons (car list1) knil) (cdr list1))))
+ (let f ((knil knil) (lists (cons list1 rest)))
+ (if (any null? lists)
+ knil
+ (let ((cars (map car lists))
+ (cdrs (map cdr lists)))
+ (f (apply kons cars (list knil)) cdrs))))))
+
+(define (fold-right kons knil clist1 . rest)
+ (if (null? rest)
+ (let f ((list1 clist1))
+ (if (null? list1)
+ knil
+ (kons (car list1) (f (cdr list1)))))
+ (let f ((lists (cons clist1 rest)))
+ (if (any null? lists)
+ knil
+ (apply kons (append! (map car lists) (list (f (map cdr lists)))))))))
+
+(define (pair-fold kons knil clist1 . rest)
+ (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 lists (list knil)) tails))))))
+
+
+(define (pair-fold-right kons knil clist1 . rest)
+ (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 . rest)
+ (let ((tail-gen (if (pair? rest)
+ (if (pair? (cdr rest))
+ (scm-error 'wrong-number-of-args
+ "unfold" "too many arguments" '() '())
+ (car rest))
+ (lambda (x) '()))))
+ (let uf ((seed seed))
+ (if (p seed)
+ (tail-gen seed)
+ (cons (f seed)
+ (uf (g seed)))))))
+
+(define (unfold-right p f g seed . rest)
+ (let ((tail (if (pair? rest)
+ (if (pair? (cdr rest))
+ (scm-error 'wrong-number-of-args
+ "unfold-right" "too many arguments" '()
+ '())
+ (car rest))
+ '())))
+ (let uf ((seed seed) (lis tail))
+ (if (p seed)
+ lis
+ (uf (g seed) (cons (f seed) lis))))))
+
+(define (reduce f ridentity lst)
+ (fold f ridentity lst))
+
+(define (reduce-right f ridentity lst)
+ (fold-right f ridentity lst))
+
+(define (append-map f clist1 . rest)
+ (if (null? rest)
+ (let lp ((l clist1))
+ (if (null? l)
+ '()
+ (append (f (car l)) (lp (cdr l)))))
+ (let lp ((l (cons clist1 rest)))
+ (if (any1 null? l)
+ '()
+ (append (apply f (map car l)) (lp (map cdr l)))))))
+
+(define (append-map! f clist1 . rest)
+ (if (null? rest)
+ (let lp ((l clist1))
+ (if (null? l)
+ '()
+ (append! (f (car l)) (lp (cdr l)))))
+ (let lp ((l (cons clist1 rest)))
+ (if (any1 null? l)
+ '()
+ (append! (apply f (map car l)) (lp (map cdr l)))))))
+
+(define (map! f list1 . rest)
+ (if (null? rest)
+ (let lp ((l list1))
+ (if (null? l)
+ '()
+ (begin
+ (set-car! l (f (car l)))
+ (set-cdr! l (lp (cdr l)))
+ l)))
+ (let lp ((l (cons list1 rest)) (res list1))
+ (if (any1 null? l)
+ '()
+ (begin
+ (set-car! res (apply f (map car l)))
+ (set-cdr! res (lp (map cdr l) (cdr res)))
+ res)))))
+
+(define (pair-for-each f clist1 . rest)
+ (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 (filter-map f clist1 . rest)
+ (if (null? rest)
+ (let lp ((l clist1))
+ (if (null? l)
+ '()
+ (let ((res (f (car l))))
+ (if res
+ (cons res (lp (cdr l)))
+ (lp (cdr l))))))
+ (let lp ((l (cons clist1 rest)))
+ (if (any1 null? l)
+ '()
+ (let ((res (apply f (map car l))))
+ (if res
+ (cons res (lp (map cdr l)))
+ (lp (map cdr l))))))))
+
+;;; Filtering & partitioning
+
+(define (filter pred list)
+ (if (null? list)
+ '()
+ (if (pred (car list))
+ (cons (car list) (filter pred (cdr list)))
+ (filter pred (cdr list)))))
+
+(define (partition pred list)
+ (if (null? list)
+ (values '() '())
+ (if (pred (car list))
+ (receive (in out) (partition pred (cdr list))
+ (values (cons (car list) in) out))
+ (receive (in out) (partition pred (cdr list))
+ (values in (cons (car list) out))))))
+
+(define (remove pred list)
+ (if (null? list)
+ '()
+ (if (pred (car list))
+ (remove pred (cdr list))
+ (cons (car list) (remove pred (cdr list))))))
+
+(define (filter! pred list)
+ (filter pred list)) ; XXX:optimize
+
+(define (partition! pred list)
+ (partition pred list)) ; XXX:optimize
+
+(define (remove! pred list)
+ (remove pred list)) ; XXX:optimize
+
+;;; Searching
+
+(define (find pred clist)
+ (if (null? clist)
+ #f
+ (if (pred (car clist))
+ (car clist)
+ (find pred (cdr clist)))))
+
+(define (find-tail pred clist)
+ (if (null? clist)
+ #f
+ (if (pred (car clist))
+ clist
+ (find-tail pred (cdr clist)))))
+
+(define (take-while pred clist)
+ (if (null? clist)
+ '()
+ (if (pred (car clist))
+ (cons (car clist) (take-while pred (cdr clist)))
+ '())))
+
+(define (take-while! pred clist)
+ (take-while pred clist)) ; XXX:optimize
+
+(define (drop-while pred clist)
+ (if (null? clist)
+ '()
+ (if (pred (car clist))
+ (drop-while pred (cdr clist))
+ clist)))
+
+(define (span pred clist)
+ (if (null? clist)
+ (values '() '())
+ (if (pred (car clist))
+ (receive (first last) (span pred (cdr clist))
+ (values (cons (car clist) first) last))
+ (values '() clist))))
+
+(define (span! pred list)
+ (span pred list)) ; XXX:optimize
+
+(define (break pred clist)
+ (if (null? clist)
+ (values '() '())
+ (if (pred (car clist))
+ (values '() clist)
+ (receive (first last) (break pred (cdr clist))
+ (values (cons (car clist) first) last)))))
+
+(define (break! pred list)
+ (break pred list)) ; XXX:optimize
+
+(define (any pred ls . lists)
+ (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)
+ (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)
+ (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 (member x list . rest)
+ (let ((l= (if (pair? rest) (car rest) equal?)))
+ (let lp ((l list))
+ (if (null? l)
+ #f
+ (if (l= (car l) x)
+ l
+ (lp (cdr l)))))))
+
+;;; Deletion
+
+(define (delete x list . rest)
+ (let ((l= (if (pair? rest) (car rest) equal?)))
+ (let lp ((l list))
+ (if (null? l)
+ '()
+ (if (l= (car l) x)
+ (lp (cdr l))
+ (cons (car l) (lp (cdr l))))))))
+
+(define (delete! x list . rest)
+ (let ((l= (if (pair? rest) (car rest) equal?)))
+ (delete x list l=))) ; XXX:optimize
+
+(define (delete-duplicates list . rest)
+ (let ((l= (if (pair? rest) (car rest) equal?)))
+ (let lp0 ((l1 list))
+ (if (null? l1)
+ '()
+ (if (let lp1 ((l2 (cdr l1)))
+ (if (null? l2)
+ #f
+ (if (l= (car l1) (car l2))
+ #t
+ (lp1 (cdr l2)))))
+ (lp0 (cdr l1))
+ (cons (car l1) (cdr l1)))))))
+
+(define (delete-duplicates! list . rest)
+ (let ((l= (if (pair? rest) (car rest) equal?)))
+ (delete-duplicates list l=))) ; XXX:optimize
+
+;;; Association lists
+
+(define (assoc key alist . rest)
+ (let ((k= (if (pair? rest) (car rest) equal?)))
+ (let lp ((a alist))
+ (if (null? a)
+ #f
+ (if (k= (caar a) key)
+ (car a)
+ (lp (cdr a)))))))
+
+(define (alist-cons key datum alist)
+ (acons key datum alist))
+
+(define (alist-copy alist)
+ (let lp ((a alist))
+ (if (null? a)
+ '()
+ (cons (cons (caar a) (cdar a)) (lp (cdr a))))))
+
+(define (alist-delete key alist . rest)
+ (let ((k= (if (pair? rest) (car rest) equal?)))
+ (let lp ((a alist))
+ (if (null? a)
+ '()
+ (if (k= (caar a) key)
+ (lp (cdr a))
+ (cons (car a) (lp (cdr a))))))))
+
+(define (alist-delete! key alist . rest)
+ (let ((k= (if (pair? rest) (car rest) equal?)))
+ (alist-delete key alist k=))) ; XXX:optimize
+
+;;; Set operations on lists
+
+(define (lset<= = . rest)
+ (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= = list1 . rest)
+ (if (null? rest)
+ #t
+ (let lp ((f list1) (r rest))
+ (or (null? r)
+ (and (every (lambda (el) (member el (car r) =)) f)
+ (every (lambda (el) (member el f =)) (car r))
+ (lp (car r) (cdr r)))))))
+
+(define (lset-adjoin = list . rest)
+ (let lp ((l rest) (acc list))
+ (if (null? l)
+ acc
+ (if (member (car l) acc)
+ (lp (cdr l) acc)
+ (lp (cdr l) (cons (car l) acc))))))
+
+(define (lset-union = . rest)
+ (let lp0 ((l rest) (acc '()))
+ (if (null? l)
+ (reverse! acc)
+ (let lp1 ((ll (car l)) (acc acc))
+ (if (null? ll)
+ (lp0 (cdr l) acc)
+ (if (member (car ll) acc =)
+ (lp1 (cdr ll) acc)
+ (lp1 (cdr ll) (cons (car ll) acc))))))))
+
+(define (lset-intersection = list1 . rest)
+ (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)
+ (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 (fold kons knil list1 . rest)
+
+(define (lset-xor = . rest)
+ (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)
+ (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)
+ (apply lset-union = rest)) ; XXX:optimize
+
+(define (lset-intersection! = list1 . rest)
+ (apply lset-intersection = list1 rest)) ; XXX:optimize
+
+(define (lset-difference! = list1 . rest)
+ (apply lset-difference = list1 rest)) ; XXX:optimize
+
+(define (lset-xor! = . rest)
+ (apply lset-xor = rest)) ; XXX:optimize
+
+(define (lset-diff+intersection! = list1 . rest)
+ (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
HCoop / bpt / guile.git / commitdiff