srfi/srfi-1.scm

   1 ;;;; srfi-1.scm --- SRFI-1 procedures for Guile
   2 ;;;;
   3 ;;;;    Copyright (C) 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU General Public License as
   7 ;;;; published by the Free Software Foundation; either version 2, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; As a special exception, the Free Software Foundation gives permission
  21 ;;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;;
  23 ;;;; The exception is that, if you link the GUILE library with other files
  24 ;;;; to produce an executable, this does not by itself cause the
  25 ;;;; resulting executable to be covered by the GNU General Public License.
  26 ;;;; Your use of that executable is in no way restricted on account of
  27 ;;;; linking the GUILE library code into it.
  28 ;;;;
  29 ;;;; This exception does not however invalidate any other reasons why
  30 ;;;; the executable file might be covered by the GNU General Public License.
  31 ;;;;
  32 ;;;; This exception applies only to the code released by the
  33 ;;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;;; code from other Free Software Foundation releases into a copy of
  35 ;;;; GUILE, as the General Public License permits, the exception does
  36 ;;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;;; anyone as to the status of such modified files, you must delete
  38 ;;;; this exception notice from them.
  39 ;;;;
  40 ;;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;;; whether to permit this exception to apply to your modifications.
  42 ;;;; If you do not wish that, delete this exception notice.
  43
  44 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
  45 ;;; Date: 2001-06-06
  46
  47 ;;; Commentary:
  48
  49 ;;; This is an implementation of SRFI-1 (List Library)
  50 ;;;
  51 ;;; All procedures defined in SRFI-1, which are not already defined in
  52 ;;; the Guile core library, are exported.  The procedures in this
  53 ;;; implementation work, but they have not been tuned for speed or
  54 ;;; memory usage.
  55 ;;;
  56
  57 ;;; Code:
  58
  59 (define-module (srfi srfi-1)
  60   :use-module (ice-9 session)
  61   :use-module (ice-9 receive))
  62
  63 (export
  64 ;;; Constructors
  65  ;; cons                                <= in the core
  66  ;; list                                <= in the core
  67  xcons
  68  ;; cons*                               <= in the core
  69  ;; make-list                           <= in the core
  70  list-tabulate
  71  ;; list-copy                           <= in the core
  72  circular-list
  73  iota
  74
  75 ;;; Predicates
  76  proper-list?
  77  circular-list?
  78  dotted-list?
  79  ;; pair?                               <= in the core
  80  ;; null?                               <= in the core
  81  null-list?
  82  not-pair?
  83  list=
  84
  85 ;;; Selectors
  86  ;; car                                 <= in the core
  87  ;; cdr                                 <= in the core
  88  ;; caar                                <= in the core
  89  ;; cadr                                <= in the core
  90  ;; cdar                                <= in the core
  91  ;; cddr                                <= in the core
  92  ;; caaar                               <= in the core
  93  ;; caadr                               <= in the core
  94  ;; cadar                               <= in the core
  95  ;; caddr                               <= in the core
  96  ;; cdaar                               <= in the core
  97  ;; cdadr                               <= in the core
  98  ;; cddar                               <= in the core
  99  ;; cdddr                               <= in the core
 100  ;; caaaar                              <= in the core
 101  ;; caaadr                              <= in the core
 102  ;; caadar                              <= in the core
 103  ;; caaddr                              <= in the core
 104  ;; cadaar                              <= in the core
 105  ;; cadadr                              <= in the core
 106  ;; caddar                              <= in the core
 107  ;; cadddr                              <= in the core
 108  ;; cdaaar                              <= in the core
 109  ;; cdaadr                              <= in the core
 110  ;; cdadar                              <= in the core
 111  ;; cdaddr                              <= in the core
 112  ;; cddaar                              <= in the core
 113  ;; cddadr                              <= in the core
 114  ;; cdddar                              <= in the core
 115  ;; cddddr                              <= in the core
 116  ;; list-ref                            <= in the core
 117  first
 118  second
 119  third
 120  fourth
 121  fifth
 122  sixth
 123  seventh
 124  eighth
 125  ninth
 126  tenth
 127  car+cdr
 128  take
 129  drop
 130  take-right
 131  drop-right
 132  take!
 133  drop-right!
 134  split-at
 135  split-at!
 136  last
 137  ;; last-pair                           <= in the core
 138
 139 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 140  ;; length                              <= in the core
 141  length+
 142  ;; append                              <= in the core
 143  ;; append!                             <= in the core
 144  concatenate
 145  concatenate!
 146  ;; reverse                             <= in the core
 147  ;; reverse!                            <= in the core
 148  append-reverse
 149  append-reverse!
 150  zip
 151  unzip1
 152  unzip2
 153  unzip3
 154  unzip4
 155  unzip5
 156  count
 157
 158 ;;; Fold, unfold & map
 159  fold
 160  fold-right
 161  pair-fold
 162  pair-fold-right
 163  reduce
 164  reduce-right
 165  unfold
 166  unfold-right
 167  map
 168  for-each
 169  append-map
 170  append-map!
 171  map!
 172  ;; map-in-order                        <= in the core
 173  pair-for-each
 174  filter-map
 175
 176 ;;; Filtering & partitioning
 177  filter
 178  partition
 179  remove
 180  filter!
 181  partition!
 182  remove!
 183
 184 ;;; Searching
 185  find
 186  find-tail
 187  take-while
 188  take-while!
 189  drop-while
 190  span
 191  span!
 192  break
 193  break!
 194  any
 195  every
 196  list-index
 197  member                                 ; Extended.
 198  ;; memq                                <= in the core
 199  ;; memv                                <= in the core
 200
 201 ;;; Deletion
 202  delete                                 ; Extended.
 203  delete!
 204  delete-duplicates
 205  delete-duplicates!
 206
 207 ;;; Association lists
 208  assoc                                  ; Extended.
 209  ;; assq                                <= in the core
 210  ;; assv                                <= in the core
 211  alist-cons
 212  alist-copy
 213  alist-delete
 214  alist-delete!
 215
 216 ;;; Set operations on lists
 217  lset<=
 218  lset=
 219  lset-adjoin
 220  lset-union
 221  lset-intersection
 222  lset-difference
 223  lset-xor
 224  lset-diff+intersection
 225  lset-union!
 226  lset-intersection!
 227  lset-difference!
 228  lset-xor!
 229  lset-diff+intersection!
 230
 231 ;;; Primitive side-effects
 232  ;; set-car!                            <= in the core
 233  ;; set-cdr!                            <= in the core
 234  )
 235
 236 (cond-expand-provide (current-module) '(srfi-1))
 237
 238 ;;; Constructors
 239
 240 (define (xcons d a)
 241   (cons a d))
 242
 243 (define (list-tabulate n init-proc)
 244   (let lp ((n n) (acc '()))
 245     (if (<= n 0)
 246       acc
 247       (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
 248
 249 (define (circular-list elt1 . rest)
 250   (let ((start (cons elt1 '())))
 251     (let lp ((r rest) (p start))
 252       (if (null? r)
 253         (begin
 254           (set-cdr! p start)
 255           start)
 256         (begin
 257           (set-cdr! p (cons (car r) '()))
 258           (lp (cdr r) (cdr p)))))))
 259
 260 (define (iota count . rest)
 261   (let ((start (if (pair? rest) (car rest) 0))
 262         (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
 263     (let lp ((n 0) (acc '()))
 264       (if (= n count)
 265         (reverse! acc)
 266         (lp (+ n 1) (cons (+ start (* n step)) acc))))))
 267
 268 ;;; Predicates
 269
 270 (define (proper-list? x)
 271   (list? x))
 272
 273 (define (circular-list? x)
 274   (if (not-pair? x)
 275     #f
 276     (let lp ((hare (cdr x)) (tortoise x))
 277       (if (not-pair? hare)
 278         #f
 279         (let ((hare (cdr hare)))
 280           (if (not-pair? hare)
 281             #f
 282             (if (eq? hare tortoise)
 283               #t
 284               (lp (cdr hare) (cdr tortoise)))))))))
 285
 286 (define (dotted-list? x)
 287   (cond
 288     ((null? x) #f)
 289     ((not-pair? x) #t)
 290     (else
 291      (let lp ((hare (cdr x)) (tortoise x))
 292        (cond
 293          ((null? hare) #f)
 294          ((not-pair? hare) #t)
 295          (else
 296           (let ((hare (cdr hare)))
 297             (cond
 298               ((null? hare) #f)
 299               ((not-pair? hare) #t)
 300               ((eq? hare tortoise) #f)
 301               (else
 302                (lp (cdr hare) (cdr tortoise)))))))))))
 303
 304 (define (null-list? x)
 305   (cond
 306     ((proper-list? x)
 307      (null? x))
 308     ((circular-list? x)
 309      #f)
 310     (else
 311      (error "not a proper list in null-list?"))))
 312
 313 (define (not-pair? x)
 314   (not (pair? x)))
 315
 316 (define (list= elt= . rest)
 317   (define (lists-equal a b)
 318     (let lp ((a a) (b b))
 319       (cond ((null? a)
 320              (null? b))
 321             ((null? b)
 322              #f)
 323             (else
 324              (and (elt= (car a) (car b))
 325                   (lp (cdr a) (cdr b)))))))
 326   (or (null? rest)
 327       (let ((first (car rest)))
 328         (let lp ((lists rest))
 329           (or (null? lists)
 330               (and (lists-equal first (car lists))
 331                    (lp (cdr lists))))))))
 332
 333 ;;; Selectors
 334
 335 (define first car)
 336 (define second cadr)
 337 (define third caddr)
 338 (define fourth cadddr)
 339 (define (fifth x) (car (cddddr x)))
 340 (define (sixth x) (cadr (cddddr x)))
 341 (define (seventh x) (caddr (cddddr x)))
 342 (define (eighth x) (cadddr (cddddr x)))
 343 (define (ninth x) (car (cddddr (cddddr x))))
 344 (define (tenth x) (cadr (cddddr (cddddr x))))
 345
 346 (define (car+cdr x) (values (car x) (cdr x)))
 347
 348 (define (take x i)
 349   (let lp ((n i) (l x) (acc '()))
 350     (if (zero? n)
 351       (reverse! acc)
 352       (lp (- n 1) (cdr l) (cons (car l) acc)))))
 353 (define (drop x i)
 354   (let lp ((n i) (l x))
 355     (if (zero? n)
 356       l
 357       (lp (- n 1) (cdr l)))))
 358 (define (take-right flist i)
 359   (let lp ((n i) (l flist))
 360     (if (zero? n)
 361       (let lp0 ((s flist) (l l))
 362         (if (null? l)
 363           s
 364           (lp0 (cdr s) (cdr l))))
 365       (lp (- n 1) (cdr l)))))
 366
 367 (define (drop-right flist i)
 368   (let lp ((n i) (l flist))
 369     (if (zero? n)
 370       (let lp0 ((s flist) (l l) (acc '()))
 371         (if (null? l)
 372           (reverse! acc)
 373           (lp0 (cdr s) (cdr l) (cons (car s) acc))))
 374       (lp (- n 1) (cdr l)))))
 375
 376 (define (take! x i)
 377   (if (zero? i)
 378     '()
 379     (let lp ((n (- i 1)) (l x))
 380       (if (zero? n)
 381         (begin
 382           (set-cdr! l '())
 383           x)
 384         (lp (- n 1) (cdr l))))))
 385
 386 (define (drop-right! flist i)
 387   (if (zero? i)
 388     flist
 389     (let lp ((n (+ i 1)) (l flist))
 390       (if (zero? n)
 391         (let lp0 ((s flist) (l l))
 392           (if (null? l)
 393             (begin
 394               (set-cdr! s '())
 395               flist)
 396             (lp0 (cdr s) (cdr l))))
 397         (if (null? l)
 398           '()
 399           (lp (- n 1) (cdr l)))))))
 400
 401 (define (split-at x i)
 402   (let lp ((l x) (n i) (acc '()))
 403     (if (zero? n)
 404       (values (reverse! acc) l)
 405       (lp (cdr l) (- n 1) (cons (car l) acc)))))
 406
 407 (define (split-at! x i)
 408   (if (zero? i)
 409     (values '() x)
 410     (let lp ((l x) (n (- i 1)))
 411       (if (zero? n)
 412         (let ((tmp (cdr l)))
 413           (set-cdr! l '())
 414           (values x tmp))
 415         (lp (cdr l) (- n 1))))))
 416
 417 (define (last pair)
 418   (car (last-pair pair)))
 419
 420 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 421
 422 (define (length+ clist)
 423   (if (null? clist)
 424     0
 425     (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
 426       (if (null? hare)
 427         l
 428         (let ((hare (cdr hare)))
 429           (if (null? hare)
 430             (+ l 1)
 431             (if (eq? hare tortoise)
 432               #f
 433               (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
 434
 435 (define (concatenate l-o-l)
 436   (let lp ((l l-o-l) (acc '()))
 437     (if (null? l)
 438       (reverse! acc)
 439       (let lp0 ((ll (car l)) (acc acc))
 440         (if (null? ll)
 441           (lp (cdr l) acc)
 442           (lp0 (cdr ll) (cons (car ll) acc)))))))
 443
 444 (define (concatenate! l-o-l)
 445   (let lp0 ((l-o-l l-o-l))
 446     (cond
 447       ((null? l-o-l)
 448        '())
 449       ((null? (car l-o-l))
 450        (lp0 (cdr l-o-l)))
 451       (else
 452        (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
 453          (let lp ((l (cdr l-o-l)) (ntail tail))
 454            (if (null? l)
 455              result
 456              (begin
 457                (set-cdr! ntail (car l))
 458                (lp (cdr l) (last-pair ntail))))))))))
 459
 460
 461 (define (append-reverse rev-head tail)
 462   (let lp ((l rev-head) (acc tail))
 463     (if (null? l)
 464       acc
 465       (lp (cdr l) (cons (car l) acc)))))
 466
 467 (define (append-reverse! rev-head tail)
 468   (append-reverse rev-head tail))       ; XXX:optimize
 469
 470 (define (zip clist1 . rest)
 471   (let lp ((l (cons clist1 rest)) (acc '()))
 472     (if (any null? l)
 473       (reverse! acc)
 474       (lp (map1 cdr l) (cons (map1 car l) acc)))))
 475
 476
 477 (define (unzip1 l)
 478   (map1 first l))
 479 (define (unzip2 l)
 480   (values (map1 first l) (map1 second l)))
 481 (define (unzip3 l)
 482   (values (map1 first l) (map1 second l) (map1 third l)))
 483 (define (unzip4 l)
 484   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
 485 (define (unzip5 l)
 486   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
 487           (map1 fifth l)))
 488
 489 (define (count pred clist1 . rest)
 490   (if (null? rest)
 491       (count1 pred clist1)
 492       (let lp ((lists (cons clist1 rest)))
 493         (cond ((any1 null? lists)
 494                0)
 495               (else
 496                (if (apply pred (map1 car lists))
 497                  (+ 1 (lp (map1 cdr lists)))
 498                  (lp (map1 cdr lists))))))))
 499
 500 (define (count1 pred clist)
 501   (if (null? clist)
 502     0
 503     (if (pred (car clist))
 504       (+ 1 (count1 pred (cdr clist)))
 505       (count1 pred (cdr clist)))))
 506
 507 ;;; Fold, unfold & map
 508
 509 (define (fold kons knil list1 . rest)
 510   (if (null? rest)
 511       (let f ((knil knil) (list1 list1))
 512         (if (null? list1)
 513             knil
 514             (f (kons (car list1) knil) (cdr list1))))
 515       (let f ((knil knil) (lists (cons list1 rest)))
 516         (if (any null? lists)
 517             knil
 518             (let ((cars (map1 car lists))
 519                   (cdrs (map1 cdr lists)))
 520               (f (apply kons (append! cars (list knil))) cdrs))))))
 521
 522 (define (fold-right kons knil clist1 . rest)
 523   (if (null? rest)
 524     (let f ((list1 clist1))
 525       (if (null? list1)
 526         knil
 527         (kons (car list1) (f (cdr list1)))))
 528     (let f ((lists (cons clist1 rest)))
 529       (if (any null? lists)
 530         knil
 531         (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
 532
 533 (define (pair-fold kons knil clist1 . rest)
 534   (if (null? rest)
 535       (let f ((knil knil) (list1 clist1))
 536         (if (null? list1)
 537             knil
 538             (let ((tail (cdr list1)))
 539             (f (kons list1 knil) tail))))
 540       (let f ((knil knil) (lists (cons clist1 rest)))
 541         (if (any null? lists)
 542             knil
 543             (let ((tails (map1 cdr lists)))
 544               (f (apply kons (append! lists (list knil))) tails))))))
 545
 546
 547 (define (pair-fold-right kons knil clist1 . rest)
 548   (if (null? rest)
 549     (let f ((list1 clist1))
 550       (if (null? list1)
 551         knil
 552         (kons list1 (f (cdr list1)))))
 553     (let f ((lists (cons clist1 rest)))
 554       (if (any null? lists)
 555         knil
 556         (apply kons (append! lists (list (f (map1 cdr lists)))))))))
 557
 558 (define (unfold p f g seed . rest)
 559   (let ((tail-gen (if (pair? rest)
 560                       (if (pair? (cdr rest))
 561                           (scm-error 'wrong-number-of-args
 562                                      "unfold" "too many arguments" '() '())
 563                           (car rest))
 564                       (lambda (x) '()))))
 565     (let uf ((seed seed))
 566       (if (p seed)
 567           (tail-gen seed)
 568           (cons (f seed)
 569                 (uf (g seed)))))))
 570
 571 (define (unfold-right p f g seed . rest)
 572   (let ((tail (if (pair? rest)
 573                   (if (pair? (cdr rest))
 574                       (scm-error 'wrong-number-of-args
 575                                      "unfold-right" "too many arguments" '()
 576                                      '())
 577                       (car rest))
 578                       '())))
 579     (let uf ((seed seed) (lis tail))
 580       (if (p seed)
 581           lis
 582           (uf (g seed) (cons (f seed) lis))))))
 583
 584 (define (reduce f ridentity lst)
 585   (fold f ridentity lst))
 586
 587 (define (reduce-right f ridentity lst)
 588   (fold-right f ridentity lst))
 589
 590
 591 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 592 ;;
 593 (define (map1 f ls)
 594   (let lp ((l ls))
 595     (if (null? l)
 596       '()
 597       (cons (f (car l)) (lp (cdr l))))))
 598
 599 ;; This `map' is extended from the standard `map'.  It allows argument
 600 ;; lists of different length, so that the shortest list determines the
 601 ;; number of elements processed.
 602 ;;
 603 (define (map f list1 . rest)
 604   (if (null? rest)
 605     (map1 f list1)
 606     (let lp ((l (cons list1 rest)))
 607       (if (any1 null? l)
 608         '()
 609         (cons (apply f (map1 car l)) (lp (map1 cdr l)))))))
 610
 611
 612 ;; This `for-each' is extended from the standard `for-each'.  It
 613 ;; allows argument lists of different length, so that the shortest
 614 ;; list determines the number of elements processed.
 615 ;;
 616 (define (for-each f list1 . rest)
 617   (if (null? rest)
 618     (let lp ((l list1))
 619       (if (null? l)
 620         (if #f #f)                      ; Return unspecified value.
 621         (begin
 622           (f (car l))
 623           (lp (cdr l)))))
 624     (let lp ((l (cons list1 rest)))
 625       (if (any1 null? l)
 626         (if #f #f)
 627         (begin
 628           (apply f (map1 car l))
 629           (lp (map1 cdr l)))))))
 630
 631
 632 (define (append-map f clist1 . rest)
 633   (if (null? rest)
 634     (let lp ((l clist1))
 635       (if (null? l)
 636         '()
 637         (append (f (car l)) (lp (cdr l)))))
 638     (let lp ((l (cons clist1 rest)))
 639       (if (any1 null? l)
 640         '()
 641         (append (apply f (map1 car l)) (lp (map1 cdr l)))))))
 642
 643
 644 (define (append-map! f clist1 . rest)
 645   (if (null? rest)
 646     (let lp ((l clist1))
 647       (if (null? l)
 648         '()
 649         (append! (f (car l)) (lp (cdr l)))))
 650     (let lp ((l (cons clist1 rest)))
 651       (if (any1 null? l)
 652         '()
 653         (append! (apply f (map1 car l)) (lp (map1 cdr l)))))))
 654
 655 (define (map! f list1 . rest)
 656   (if (null? rest)
 657     (let lp ((l list1))
 658       (if (null? l)
 659         '()
 660         (begin
 661           (set-car! l (f (car l)))
 662           (set-cdr! l (lp (cdr l)))
 663           l)))
 664     (let lp ((l (cons list1 rest)) (res list1))
 665       (if (any1 null? l)
 666         '()
 667         (begin
 668           (set-car! res (apply f (map1 car l)))
 669           (set-cdr! res (lp (map1 cdr l) (cdr res)))
 670           res)))))
 671
 672 (define (pair-for-each f clist1 . rest)
 673   (if (null? rest)
 674     (let lp ((l clist1))
 675       (if (null? l)
 676         (if #f #f)
 677         (begin
 678           (f l)
 679           (lp (cdr l)))))
 680     (let lp ((l (cons clist1 rest)))
 681       (if (any1 null? l)
 682         (if #f #f)
 683         (begin
 684           (apply f l)
 685           (lp (map1 cdr l)))))))
 686
 687 (define (filter-map f clist1 . rest)
 688   (if (null? rest)
 689     (let lp ((l clist1))
 690       (if (null? l)
 691         '()
 692         (let ((res (f (car l))))
 693           (if res
 694             (cons res (lp (cdr l)))
 695             (lp (cdr l))))))
 696     (let lp ((l (cons clist1 rest)))
 697       (if (any1 null? l)
 698         '()
 699         (let ((res (apply f (map1 car l))))
 700           (if res
 701             (cons res (lp (map1 cdr l)))
 702             (lp (map1 cdr l))))))))
 703
 704 ;;; Filtering & partitioning
 705
 706 (define (filter pred list)
 707   (if (null? list)
 708     '()
 709     (if (pred (car list))
 710       (cons (car list) (filter pred (cdr list)))
 711       (filter pred (cdr list)))))
 712
 713 (define (partition pred list)
 714   (if (null? list)
 715     (values '() '())
 716     (if (pred (car list))
 717       (receive (in out) (partition pred (cdr list))
 718                (values (cons (car list) in) out))
 719       (receive (in out) (partition pred (cdr list))
 720                (values in (cons (car list) out))))))
 721
 722 (define (remove pred list)
 723   (if (null? list)
 724     '()
 725     (if (pred (car list))
 726       (remove pred (cdr list))
 727       (cons (car list) (remove pred (cdr list))))))
 728
 729 (define (filter! pred list)
 730   (filter pred list))                   ; XXX:optimize
 731
 732 (define (partition! pred list)
 733   (partition pred list))                ; XXX:optimize
 734
 735 (define (remove! pred list)
 736   (remove pred list))                   ; XXX:optimize
 737
 738 ;;; Searching
 739
 740 (define (find pred clist)
 741   (if (null? clist)
 742     #f
 743     (if (pred (car clist))
 744       (car clist)
 745       (find pred (cdr clist)))))
 746
 747 (define (find-tail pred clist)
 748   (if (null? clist)
 749     #f
 750     (if (pred (car clist))
 751       clist
 752       (find-tail pred (cdr clist)))))
 753
 754 (define (take-while pred clist)
 755   (if (null? clist)
 756     '()
 757     (if (pred (car clist))
 758       (cons (car clist) (take-while pred (cdr clist)))
 759       '())))
 760
 761 (define (take-while! pred clist)
 762   (take-while pred clist))              ; XXX:optimize
 763
 764 (define (drop-while pred clist)
 765   (if (null? clist)
 766     '()
 767     (if (pred (car clist))
 768       (drop-while pred (cdr clist))
 769       clist)))
 770
 771 (define (span pred clist)
 772   (if (null? clist)
 773     (values '() '())
 774     (if (pred (car clist))
 775       (receive (first last) (span pred (cdr clist))
 776                (values (cons (car clist) first) last))
 777       (values '() clist))))
 778
 779 (define (span! pred list)
 780   (span pred list))                     ; XXX:optimize
 781
 782 (define (break pred clist)
 783   (if (null? clist)
 784     (values '() '())
 785     (if (pred (car clist))
 786       (values '() clist)
 787       (receive (first last) (break pred (cdr clist))
 788                (values (cons (car clist) first) last)))))
 789
 790 (define (break! pred list)
 791   (break pred list))                    ; XXX:optimize
 792
 793 (define (any pred ls . lists)
 794   (if (null? lists)
 795       (any1 pred ls)
 796       (let lp ((lists (cons ls lists)))
 797         (cond ((any1 null? lists)
 798                #f)
 799               ((any1 null? (map1 cdr lists))
 800                (apply pred (map1 car lists)))
 801               (else
 802                (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 803
 804 (define (any1 pred ls)
 805   (let lp ((ls ls))
 806     (cond ((null? ls)
 807            #f)
 808           ((null? (cdr ls))
 809            (pred (car ls)))
 810           (else
 811            (or (pred (car ls)) (lp (cdr ls)))))))
 812
 813 (define (every pred ls . lists)
 814   (if (null? lists)
 815       (every1 pred ls)
 816       (let lp ((lists (cons ls lists)))
 817         (cond ((any1 null? lists)
 818                #t)
 819               ((any1 null? (map1 cdr lists))
 820                (apply pred (map1 car lists)))
 821               (else
 822                (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 823
 824 (define (every1 pred ls)
 825   (let lp ((ls ls))
 826     (cond ((null? ls)
 827            #t)
 828           ((null? (cdr ls))
 829            (pred (car ls)))
 830           (else
 831            (and (pred (car ls)) (lp (cdr ls)))))))
 832
 833 (define (list-index pred clist1 . rest)
 834   (if (null? rest)
 835     (let lp ((l clist1) (i 0))
 836       (if (null? l)
 837         #f
 838         (if (pred (car l))
 839           i
 840           (lp (cdr l) (+ i 1)))))
 841     (let lp ((lists (cons clist1 rest)) (i 0))
 842       (cond ((any1 null? lists)
 843              #f)
 844             ((apply pred (map1 car lists)) i)
 845             (else
 846              (lp (map1 cdr lists) (+ i 1)))))))
 847
 848 (define (member x list . rest)
 849   (let ((l= (if (pair? rest) (car rest) equal?)))
 850     (let lp ((l list))
 851       (if (null? l)
 852         #f
 853         (if (l= x (car l))
 854           l
 855           (lp (cdr l)))))))
 856
 857 ;;; Deletion
 858
 859 (define (delete x list . rest)
 860   (let ((l= (if (pair? rest) (car rest) equal?)))
 861     (let lp ((l list))
 862       (if (null? l)
 863         '()
 864         (if (l= (car l) x)
 865           (lp (cdr l))
 866           (cons (car l) (lp (cdr l))))))))
 867
 868 (define (delete! x list . rest)
 869   (let ((l= (if (pair? rest) (car rest) equal?)))
 870     (delete x list l=)))                ; XXX:optimize
 871
 872 (define (delete-duplicates list . rest)
 873   (let ((l= (if (pair? rest) (car rest) equal?)))
 874     (let lp0 ((l1 list))
 875       (if (null? l1)
 876         '()
 877         (if (let lp1 ((l2 (cdr l1)))
 878               (if (null? l2)
 879                 #f
 880                 (if (l= (car l1) (car l2))
 881                   #t
 882                   (lp1 (cdr l2)))))
 883           (lp0 (cdr l1))
 884           (cons (car l1) (lp0 (cdr l1))))))))
 885
 886 (define (delete-duplicates list . rest)
 887   (let ((l= (if (pair? rest) (car rest) equal?)))
 888     (let lp ((list list))
 889       (if (null? list)
 890         '()
 891         (cons (car list) (lp (delete (car list) (cdr list) l=)))))))
 892
 893 (define (delete-duplicates! list . rest)
 894   (let ((l= (if (pair? rest) (car rest) equal?)))
 895     (delete-duplicates list l=)))       ; XXX:optimize
 896
 897 ;;; Association lists
 898
 899 (define (assoc key alist . rest)
 900   (let ((k= (if (pair? rest) (car rest) equal?)))
 901     (let lp ((a alist))
 902       (if (null? a)
 903         #f
 904         (if (k= key (caar a))
 905           (car a)
 906           (lp (cdr a)))))))
 907
 908 (define (alist-cons key datum alist)
 909   (acons key datum alist))
 910
 911 (define (alist-copy alist)
 912   (let lp ((a alist))
 913     (if (null? a)
 914       '()
 915       (acons (caar a) (cdar a) (lp (cdr a))))))
 916
 917 (define (alist-delete key alist . rest)
 918   (let ((k= (if (pair? rest) (car rest) equal?)))
 919     (let lp ((a alist))
 920       (if (null? a)
 921         '()
 922         (if (k= (caar a) key)
 923           (lp (cdr a))
 924           (cons (car a) (lp (cdr a))))))))
 925
 926 (define (alist-delete! key alist . rest)
 927   (let ((k= (if (pair? rest) (car rest) equal?)))
 928     (alist-delete key alist k=)))       ; XXX:optimize
 929
 930 ;;; Set operations on lists
 931
 932 (define (lset<= = . rest)
 933   (if (null? rest)
 934     #t
 935     (let lp ((f (car rest)) (r (cdr rest)))
 936       (or (null? r)
 937           (and (every (lambda (el) (member el (car r) =)) f)
 938                (lp (car r) (cdr r)))))))
 939
 940 (define (lset= = list1 . rest)
 941   (if (null? rest)
 942     #t
 943     (let lp ((f list1) (r rest))
 944       (or (null? r)
 945           (and (every (lambda (el) (member el (car r) =)) f)
 946                (every (lambda (el) (member el f =)) (car r))
 947                (lp (car r) (cdr r)))))))
 948
 949 (define (lset-adjoin = list . rest)
 950   (let lp ((l rest) (acc list))
 951     (if (null? l)
 952       acc
 953       (if (member (car l) acc)
 954         (lp (cdr l) acc)
 955         (lp (cdr l) (cons (car l) acc))))))
 956
 957 (define (lset-union = . rest)
 958   (let lp0 ((l rest) (acc '()))
 959     (if (null? l)
 960       (reverse! acc)
 961       (let lp1 ((ll (car l)) (acc acc))
 962         (if (null? ll)
 963           (lp0 (cdr l) acc)
 964           (if (member (car ll) acc =)
 965             (lp1 (cdr ll) acc)
 966             (lp1 (cdr ll) (cons (car ll) acc))))))))
 967
 968 (define (lset-intersection = list1 . rest)
 969   (let lp ((l list1) (acc '()))
 970     (if (null? l)
 971       (reverse! acc)
 972       (if (every (lambda (ll) (member (car l) ll =)) rest)
 973         (lp (cdr l) (cons (car l) acc))
 974         (lp (cdr l) acc)))))
 975
 976 (define (lset-difference = list1 . rest)
 977   (if (null? rest)
 978     list1
 979     (let lp ((l list1) (acc '()))
 980       (if (null? l)
 981         (reverse! acc)
 982         (if (any (lambda (ll) (member (car l) ll =)) rest)
 983           (lp (cdr l) acc)
 984           (lp (cdr l) (cons (car l) acc)))))))
 985
 986 ;(define (fold kons knil list1 . rest)
 987
 988 (define (lset-xor = . rest)
 989   (fold (lambda (lst res)
 990           (let lp ((l lst) (acc '()))
 991             (if (null? l)
 992               (let lp0 ((r res) (acc acc))
 993                 (if (null? r)
 994                   (reverse! acc)
 995                   (if (member (car r) lst =)
 996                     (lp0 (cdr r) acc)
 997                     (lp0 (cdr r) (cons (car r) acc)))))
 998               (if (member (car l) res =)
 999                 (lp (cdr l) acc)
1000                 (lp (cdr l) (cons (car l) acc))))))
1001         '()
1002         rest))
1003
1004 (define (lset-diff+intersection = list1 . rest)
1005   (let lp ((l list1) (accd '()) (acci '()))
1006     (if (null? l)
1007       (values (reverse! accd) (reverse! acci))
1008       (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
1009         (if appears
1010           (lp (cdr l) accd (cons (car l) acci))
1011           (lp (cdr l) (cons (car l) accd) acci))))))
1012
1013
1014 (define (lset-union! = . rest)
1015   (apply lset-union = rest))            ; XXX:optimize
1016
1017 (define (lset-intersection! = list1 . rest)
1018   (apply lset-intersection = list1 rest)) ; XXX:optimize
1019
1020 (define (lset-difference! = list1 . rest)
1021   (apply lset-difference = list1 rest)) ; XXX:optimize
1022
1023 (define (lset-xor! = . rest)
1024   (apply lset-xor = rest))              ; XXX:optimize
1025
1026 (define (lset-diff+intersection! = list1 . rest)
1027   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize