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                                   ; Extended.
  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                                    ; Extended.
 168  for-each                               ; Extended.
 169  append-map
 170  append-map!
 171  map!
 172  map-in-order                           ; Extended.
 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                             ; Extended.
 197  member                                 ; Extended.
 198  ;; memq                                <= in the core
 199  ;; memv                                <= in the core
 200
 201 ;;; Deletion
 202  delete                                 ; Extended.
 203  delete!                                ; Extended.
 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 ;; internal helper, similar to (scsh utilities) check-arg.
 244 (define (check-arg-type pred arg caller)
 245   (if (pred arg)
 246       arg
 247       (scm-error 'wrong-type-arg caller
 248                  "Wrong type argument: ~S" (list arg) '())))
 249
 250 ;; the srfi spec doesn't seem to forbid inexact integers.
 251 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
 252
 253 (define (list-tabulate n init-proc)
 254   (check-arg-type non-negative-integer? n "list-tabulate")
 255   (let lp ((n n) (acc '()))
 256     (if (<= n 0)
 257       acc
 258       (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
 259
 260 (define (circular-list elt1 . rest)
 261   (let ((start (cons elt1 '())))
 262     (let lp ((r rest) (p start))
 263       (if (null? r)
 264         (begin
 265           (set-cdr! p start)
 266           start)
 267         (begin
 268           (set-cdr! p (cons (car r) '()))
 269           (lp (cdr r) (cdr p)))))))
 270
 271 (define (iota count . rest)
 272   (check-arg-type non-negative-integer? count "iota")
 273   (let ((start (if (pair? rest) (car rest) 0))
 274         (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
 275     (let lp ((n 0) (acc '()))
 276       (if (= n count)
 277         (reverse! acc)
 278         (lp (+ n 1) (cons (+ start (* n step)) acc))))))
 279
 280 ;;; Predicates
 281
 282 (define (proper-list? x)
 283   (list? x))
 284
 285 (define (circular-list? x)
 286   (if (not-pair? x)
 287     #f
 288     (let lp ((hare (cdr x)) (tortoise x))
 289       (if (not-pair? hare)
 290         #f
 291         (let ((hare (cdr hare)))
 292           (if (not-pair? hare)
 293             #f
 294             (if (eq? hare tortoise)
 295               #t
 296               (lp (cdr hare) (cdr tortoise)))))))))
 297
 298 (define (dotted-list? x)
 299   (cond
 300     ((null? x) #f)
 301     ((not-pair? x) #t)
 302     (else
 303      (let lp ((hare (cdr x)) (tortoise x))
 304        (cond
 305          ((null? hare) #f)
 306          ((not-pair? hare) #t)
 307          (else
 308           (let ((hare (cdr hare)))
 309             (cond
 310               ((null? hare) #f)
 311               ((not-pair? hare) #t)
 312               ((eq? hare tortoise) #f)
 313               (else
 314                (lp (cdr hare) (cdr tortoise)))))))))))
 315
 316 (define (null-list? x)
 317   (cond
 318     ((proper-list? x)
 319      (null? x))
 320     ((circular-list? x)
 321      #f)
 322     (else
 323      (error "not a proper list in null-list?"))))
 324
 325 (define (not-pair? x)
 326   (not (pair? x)))
 327
 328 (define (list= elt= . rest)
 329   (define (lists-equal a b)
 330     (let lp ((a a) (b b))
 331       (cond ((null? a)
 332              (null? b))
 333             ((null? b)
 334              #f)
 335             (else
 336              (and (elt= (car a) (car b))
 337                   (lp (cdr a) (cdr b)))))))
 338   (or (null? rest)
 339       (let ((first (car rest)))
 340         (let lp ((lists rest))
 341           (or (null? lists)
 342               (and (lists-equal first (car lists))
 343                    (lp (cdr lists))))))))
 344
 345 ;;; Selectors
 346
 347 (define first car)
 348 (define second cadr)
 349 (define third caddr)
 350 (define fourth cadddr)
 351 (define (fifth x) (car (cddddr x)))
 352 (define (sixth x) (cadr (cddddr x)))
 353 (define (seventh x) (caddr (cddddr x)))
 354 (define (eighth x) (cadddr (cddddr x)))
 355 (define (ninth x) (car (cddddr (cddddr x))))
 356 (define (tenth x) (cadr (cddddr (cddddr x))))
 357
 358 (define (car+cdr x) (values (car x) (cdr x)))
 359
 360 (define (take x i)
 361   (let lp ((n i) (l x) (acc '()))
 362     (if (<= n 0)
 363       (reverse! acc)
 364       (lp (- n 1) (cdr l) (cons (car l) acc)))))
 365 (define (drop x i)
 366   (let lp ((n i) (l x))
 367     (if (<= n 0)
 368       l
 369       (lp (- n 1) (cdr l)))))
 370 (define (take-right flist i)
 371   (let lp ((n i) (l flist))
 372     (if (<= n 0)
 373       (let lp0 ((s flist) (l l))
 374         (if (null? l)
 375           s
 376           (lp0 (cdr s) (cdr l))))
 377       (lp (- n 1) (cdr l)))))
 378
 379 (define (drop-right flist i)
 380   (let lp ((n i) (l flist))
 381     (if (<= n 0)
 382       (let lp0 ((s flist) (l l) (acc '()))
 383         (if (null? l)
 384           (reverse! acc)
 385           (lp0 (cdr s) (cdr l) (cons (car s) acc))))
 386       (lp (- n 1) (cdr l)))))
 387
 388 (define (take! x i)
 389   (if (<= i 0)
 390     '()
 391     (let lp ((n (- i 1)) (l x))
 392       (if (<= n 0)
 393         (begin
 394           (set-cdr! l '())
 395           x)
 396         (lp (- n 1) (cdr l))))))
 397
 398 (define (drop-right! flist i)
 399   (if (<= i 0)
 400     flist
 401     (let lp ((n (+ i 1)) (l flist))
 402       (if (<= n 0)
 403         (let lp0 ((s flist) (l l))
 404           (if (null? l)
 405             (begin
 406               (set-cdr! s '())
 407               flist)
 408             (lp0 (cdr s) (cdr l))))
 409         (if (null? l)
 410           '()
 411           (lp (- n 1) (cdr l)))))))
 412
 413 (define (split-at x i)
 414   (let lp ((l x) (n i) (acc '()))
 415     (if (<= n 0)
 416       (values (reverse! acc) l)
 417       (lp (cdr l) (- n 1) (cons (car l) acc)))))
 418
 419 (define (split-at! x i)
 420   (if (<= i 0)
 421     (values '() x)
 422     (let lp ((l x) (n (- i 1)))
 423       (if (<= n 0)
 424         (let ((tmp (cdr l)))
 425           (set-cdr! l '())
 426           (values x tmp))
 427         (lp (cdr l) (- n 1))))))
 428
 429 (define (last pair)
 430   (car (last-pair pair)))
 431
 432 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 433
 434 (define (length+ clist)
 435   (if (null? clist)
 436     0
 437     (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
 438       (if (null? hare)
 439         l
 440         (let ((hare (cdr hare)))
 441           (if (null? hare)
 442             (+ l 1)
 443             (if (eq? hare tortoise)
 444               #f
 445               (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
 446
 447 (define (concatenate l-o-l)
 448   (let lp ((l l-o-l) (acc '()))
 449     (if (null? l)
 450       (reverse! acc)
 451       (let lp0 ((ll (car l)) (acc acc))
 452         (if (null? ll)
 453           (lp (cdr l) acc)
 454           (lp0 (cdr ll) (cons (car ll) acc)))))))
 455
 456 (define (concatenate! l-o-l)
 457   (let lp0 ((l-o-l l-o-l))
 458     (cond
 459       ((null? l-o-l)
 460        '())
 461       ((null? (car l-o-l))
 462        (lp0 (cdr l-o-l)))
 463       (else
 464        (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
 465          (let lp ((l (cdr l-o-l)) (ntail tail))
 466            (if (null? l)
 467              result
 468              (begin
 469                (set-cdr! ntail (car l))
 470                (lp (cdr l) (last-pair ntail))))))))))
 471
 472
 473 (define (append-reverse rev-head tail)
 474   (let lp ((l rev-head) (acc tail))
 475     (if (null? l)
 476       acc
 477       (lp (cdr l) (cons (car l) acc)))))
 478
 479 (define (append-reverse! rev-head tail)
 480   (append-reverse rev-head tail))       ; XXX:optimize
 481
 482 (define (zip clist1 . rest)
 483   (let lp ((l (cons clist1 rest)) (acc '()))
 484     (if (any null? l)
 485       (reverse! acc)
 486       (lp (map1 cdr l) (cons (map1 car l) acc)))))
 487
 488
 489 (define (unzip1 l)
 490   (map1 first l))
 491 (define (unzip2 l)
 492   (values (map1 first l) (map1 second l)))
 493 (define (unzip3 l)
 494   (values (map1 first l) (map1 second l) (map1 third l)))
 495 (define (unzip4 l)
 496   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
 497 (define (unzip5 l)
 498   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
 499           (map1 fifth l)))
 500
 501 (define (count pred clist1 . rest)
 502   (if (null? rest)
 503       (count1 pred clist1)
 504       (let lp ((lists (cons clist1 rest)))
 505         (cond ((any1 null? lists)
 506                0)
 507               (else
 508                (if (apply pred (map1 car lists))
 509                  (+ 1 (lp (map1 cdr lists)))
 510                  (lp (map1 cdr lists))))))))
 511
 512 (define (count1 pred clist)
 513   (if (null? clist)
 514     0
 515     (if (pred (car clist))
 516       (+ 1 (count1 pred (cdr clist)))
 517       (count1 pred (cdr clist)))))
 518
 519 ;;; Fold, unfold & map
 520
 521 (define (fold kons knil list1 . rest)
 522   (if (null? rest)
 523       (let f ((knil knil) (list1 list1))
 524         (if (null? list1)
 525             knil
 526             (f (kons (car list1) knil) (cdr list1))))
 527       (let f ((knil knil) (lists (cons list1 rest)))
 528         (if (any null? lists)
 529             knil
 530             (let ((cars (map1 car lists))
 531                   (cdrs (map1 cdr lists)))
 532               (f (apply kons (append! cars (list knil))) cdrs))))))
 533
 534 (define (fold-right kons knil clist1 . rest)
 535   (if (null? rest)
 536     (let f ((list1 clist1))
 537       (if (null? list1)
 538         knil
 539         (kons (car list1) (f (cdr list1)))))
 540     (let f ((lists (cons clist1 rest)))
 541       (if (any null? lists)
 542         knil
 543         (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
 544
 545 (define (pair-fold kons knil clist1 . rest)
 546   (if (null? rest)
 547       (let f ((knil knil) (list1 clist1))
 548         (if (null? list1)
 549             knil
 550             (let ((tail (cdr list1)))
 551             (f (kons list1 knil) tail))))
 552       (let f ((knil knil) (lists (cons clist1 rest)))
 553         (if (any null? lists)
 554             knil
 555             (let ((tails (map1 cdr lists)))
 556               (f (apply kons (append! lists (list knil))) tails))))))
 557
 558
 559 (define (pair-fold-right kons knil clist1 . rest)
 560   (if (null? rest)
 561     (let f ((list1 clist1))
 562       (if (null? list1)
 563         knil
 564         (kons list1 (f (cdr list1)))))
 565     (let f ((lists (cons clist1 rest)))
 566       (if (any null? lists)
 567         knil
 568         (apply kons (append! lists (list (f (map1 cdr lists)))))))))
 569
 570 (define (unfold p f g seed . rest)
 571   (let ((tail-gen (if (pair? rest)
 572                       (if (pair? (cdr rest))
 573                           (scm-error 'wrong-number-of-args
 574                                      "unfold" "too many arguments" '() '())
 575                           (car rest))
 576                       (lambda (x) '()))))
 577     (let uf ((seed seed))
 578       (if (p seed)
 579           (tail-gen seed)
 580           (cons (f seed)
 581                 (uf (g seed)))))))
 582
 583 (define (unfold-right p f g seed . rest)
 584   (let ((tail (if (pair? rest)
 585                   (if (pair? (cdr rest))
 586                       (scm-error 'wrong-number-of-args
 587                                      "unfold-right" "too many arguments" '()
 588                                      '())
 589                       (car rest))
 590                       '())))
 591     (let uf ((seed seed) (lis tail))
 592       (if (p seed)
 593           lis
 594           (uf (g seed) (cons (f seed) lis))))))
 595
 596 (define (reduce f ridentity lst)
 597   (fold f ridentity lst))
 598
 599 (define (reduce-right f ridentity lst)
 600   (fold-right f ridentity lst))
 601
 602
 603 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 604 ;;
 605 (define (map1 f ls)
 606   (let lp ((l ls))
 607     (if (null? l)
 608       '()
 609       (cons (f (car l)) (lp (cdr l))))))
 610
 611 ;; This `map' is extended from the standard `map'.  It allows argument
 612 ;; lists of different length, so that the shortest list determines the
 613 ;; number of elements processed.
 614 ;;
 615 (define (map f list1 . rest)
 616   (if (null? rest)
 617     (map1 f list1)
 618     (let lp ((l (cons list1 rest)))
 619       (if (any1 null? l)
 620         '()
 621         (cons (apply f (map1 car l)) (lp (map1 cdr l)))))))
 622
 623 ;; extended to lists of unequal length.
 624 (define map-in-order map)
 625
 626 ;; This `for-each' is extended from the standard `for-each'.  It
 627 ;; allows argument lists of different length, so that the shortest
 628 ;; list determines the number of elements processed.
 629 ;;
 630 (define (for-each f list1 . rest)
 631   (if (null? rest)
 632     (let lp ((l list1))
 633       (if (null? l)
 634         (if #f #f)                      ; Return unspecified value.
 635         (begin
 636           (f (car l))
 637           (lp (cdr l)))))
 638     (let lp ((l (cons list1 rest)))
 639       (if (any1 null? l)
 640         (if #f #f)
 641         (begin
 642           (apply f (map1 car l))
 643           (lp (map1 cdr l)))))))
 644
 645
 646 (define (append-map f clist1 . rest)
 647   (if (null? rest)
 648     (let lp ((l clist1))
 649       (if (null? l)
 650         '()
 651         (append (f (car l)) (lp (cdr l)))))
 652     (let lp ((l (cons clist1 rest)))
 653       (if (any1 null? l)
 654         '()
 655         (append (apply f (map1 car l)) (lp (map1 cdr l)))))))
 656
 657
 658 (define (append-map! f clist1 . rest)
 659   (if (null? rest)
 660     (let lp ((l clist1))
 661       (if (null? l)
 662         '()
 663         (append! (f (car l)) (lp (cdr l)))))
 664     (let lp ((l (cons clist1 rest)))
 665       (if (any1 null? l)
 666         '()
 667         (append! (apply f (map1 car l)) (lp (map1 cdr l)))))))
 668
 669 (define (map! f list1 . rest)
 670   (if (null? rest)
 671     (let lp ((l list1))
 672       (if (null? l)
 673         '()
 674         (begin
 675           (set-car! l (f (car l)))
 676           (set-cdr! l (lp (cdr l)))
 677           l)))
 678     (let lp ((l (cons list1 rest)) (res list1))
 679       (if (any1 null? l)
 680         '()
 681         (begin
 682           (set-car! res (apply f (map1 car l)))
 683           (set-cdr! res (lp (map1 cdr l) (cdr res)))
 684           res)))))
 685
 686 (define (pair-for-each f clist1 . rest)
 687   (if (null? rest)
 688     (let lp ((l clist1))
 689       (if (null? l)
 690         (if #f #f)
 691         (begin
 692           (f l)
 693           (lp (cdr l)))))
 694     (let lp ((l (cons clist1 rest)))
 695       (if (any1 null? l)
 696         (if #f #f)
 697         (begin
 698           (apply f l)
 699           (lp (map1 cdr l)))))))
 700
 701 (define (filter-map f clist1 . rest)
 702   (if (null? rest)
 703     (let lp ((l clist1))
 704       (if (null? l)
 705         '()
 706         (let ((res (f (car l))))
 707           (if res
 708             (cons res (lp (cdr l)))
 709             (lp (cdr l))))))
 710     (let lp ((l (cons clist1 rest)))
 711       (if (any1 null? l)
 712         '()
 713         (let ((res (apply f (map1 car l))))
 714           (if res
 715             (cons res (lp (map1 cdr l)))
 716             (lp (map1 cdr l))))))))
 717
 718 ;;; Filtering & partitioning
 719
 720 (define (filter pred list)
 721   (check-arg-type list? list "caller")  ; reject circular lists.
 722   (letrec ((filiter (lambda (pred rest result)
 723                       (if (null? rest)
 724                           (reverse! result)
 725                           (filiter pred (cdr rest)
 726                                    (cond ((pred (car rest))
 727                                           (cons (car rest) result))
 728                                          (else
 729                                           result)))))))
 730     (filiter pred list '())))
 731
 732 (define (partition pred list)
 733   (if (null? list)
 734     (values '() '())
 735     (if (pred (car list))
 736       (receive (in out) (partition pred (cdr list))
 737                (values (cons (car list) in) out))
 738       (receive (in out) (partition pred (cdr list))
 739                (values in (cons (car list) out))))))
 740
 741 (define (remove pred list)
 742   (filter (lambda (x) (not (pred x))) list))
 743
 744 (define (filter! pred list)
 745   (filter pred list))                   ; XXX:optimize
 746
 747 (define (partition! pred list)
 748   (partition pred list))                ; XXX:optimize
 749
 750 (define (remove! pred list)
 751   (remove pred list))                   ; XXX:optimize
 752
 753 ;;; Searching
 754
 755 (define (find pred clist)
 756   (if (null? clist)
 757     #f
 758     (if (pred (car clist))
 759       (car clist)
 760       (find pred (cdr clist)))))
 761
 762 (define (find-tail pred clist)
 763   (if (null? clist)
 764     #f
 765     (if (pred (car clist))
 766       clist
 767       (find-tail pred (cdr clist)))))
 768
 769 (define (take-while pred clist)
 770   (if (null? clist)
 771     '()
 772     (if (pred (car clist))
 773       (cons (car clist) (take-while pred (cdr clist)))
 774       '())))
 775
 776 (define (take-while! pred clist)
 777   (take-while pred clist))              ; XXX:optimize
 778
 779 (define (drop-while pred clist)
 780   (if (null? clist)
 781     '()
 782     (if (pred (car clist))
 783       (drop-while pred (cdr clist))
 784       clist)))
 785
 786 (define (span pred clist)
 787   (if (null? clist)
 788     (values '() '())
 789     (if (pred (car clist))
 790       (receive (first last) (span pred (cdr clist))
 791                (values (cons (car clist) first) last))
 792       (values '() clist))))
 793
 794 (define (span! pred list)
 795   (span pred list))                     ; XXX:optimize
 796
 797 (define (break pred clist)
 798   (if (null? clist)
 799     (values '() '())
 800     (if (pred (car clist))
 801       (values '() clist)
 802       (receive (first last) (break pred (cdr clist))
 803                (values (cons (car clist) first) last)))))
 804
 805 (define (break! pred list)
 806   (break pred list))                    ; XXX:optimize
 807
 808 (define (any pred ls . lists)
 809   (if (null? lists)
 810       (any1 pred ls)
 811       (let lp ((lists (cons ls lists)))
 812         (cond ((any1 null? lists)
 813                #f)
 814               ((any1 null? (map1 cdr lists))
 815                (apply pred (map1 car lists)))
 816               (else
 817                (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 818
 819 (define (any1 pred ls)
 820   (let lp ((ls ls))
 821     (cond ((null? ls)
 822            #f)
 823           ((null? (cdr ls))
 824            (pred (car ls)))
 825           (else
 826            (or (pred (car ls)) (lp (cdr ls)))))))
 827
 828 (define (every pred ls . lists)
 829   (if (null? lists)
 830       (every1 pred ls)
 831       (let lp ((lists (cons ls lists)))
 832         (cond ((any1 null? lists)
 833                #t)
 834               ((any1 null? (map1 cdr lists))
 835                (apply pred (map1 car lists)))
 836               (else
 837                (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 838
 839 (define (every1 pred ls)
 840   (let lp ((ls ls))
 841     (cond ((null? ls)
 842            #t)
 843           ((null? (cdr ls))
 844            (pred (car ls)))
 845           (else
 846            (and (pred (car ls)) (lp (cdr ls)))))))
 847
 848 (define (list-index pred clist1 . rest)
 849   (if (null? rest)
 850     (let lp ((l clist1) (i 0))
 851       (if (null? l)
 852         #f
 853         (if (pred (car l))
 854           i
 855           (lp (cdr l) (+ i 1)))))
 856     (let lp ((lists (cons clist1 rest)) (i 0))
 857       (cond ((any1 null? lists)
 858              #f)
 859             ((apply pred (map1 car lists)) i)
 860             (else
 861              (lp (map1 cdr lists) (+ i 1)))))))
 862
 863 (define (member x list . rest)
 864   (let ((l= (if (pair? rest) (car rest) equal?)))
 865     (let lp ((l list))
 866       (if (null? l)
 867         #f
 868         (if (l= x (car l))
 869           l
 870           (lp (cdr l)))))))
 871
 872 ;;; Deletion
 873
 874 (define (delete x list . rest)
 875   (let ((l= (if (pair? rest) (car rest) equal?)))
 876     (let lp ((l list))
 877       (if (null? l)
 878         '()
 879         (if (l= (car l) x)
 880           (lp (cdr l))
 881           (cons (car l) (lp (cdr l))))))))
 882
 883 (define (delete! x list . rest)
 884   (let ((l= (if (pair? rest) (car rest) equal?)))
 885     (delete x list l=)))                ; XXX:optimize
 886
 887 (define (delete-duplicates list . rest)
 888   (let ((l= (if (pair? rest) (car rest) equal?)))
 889     (let lp0 ((l1 list))
 890       (if (null? l1)
 891         '()
 892         (if (let lp1 ((l2 (cdr l1)))
 893               (if (null? l2)
 894                 #f
 895                 (if (l= (car l1) (car l2))
 896                   #t
 897                   (lp1 (cdr l2)))))
 898           (lp0 (cdr l1))
 899           (cons (car l1) (lp0 (cdr l1))))))))
 900
 901 (define (delete-duplicates list . rest)
 902   (let ((l= (if (pair? rest) (car rest) equal?)))
 903     (let lp ((list list))
 904       (if (null? list)
 905         '()
 906         (cons (car list) (lp (delete (car list) (cdr list) l=)))))))
 907
 908 (define (delete-duplicates! list . rest)
 909   (let ((l= (if (pair? rest) (car rest) equal?)))
 910     (delete-duplicates list l=)))       ; XXX:optimize
 911
 912 ;;; Association lists
 913
 914 (define (assoc key alist . rest)
 915   (let ((k= (if (pair? rest) (car rest) equal?)))
 916     (let lp ((a alist))
 917       (if (null? a)
 918         #f
 919         (if (k= key (caar a))
 920           (car a)
 921           (lp (cdr a)))))))
 922
 923 (define (alist-cons key datum alist)
 924   (acons key datum alist))
 925
 926 (define (alist-copy alist)
 927   (let lp ((a alist))
 928     (if (null? a)
 929       '()
 930       (acons (caar a) (cdar a) (lp (cdr a))))))
 931
 932 (define (alist-delete key alist . rest)
 933   (let ((k= (if (pair? rest) (car rest) equal?)))
 934     (let lp ((a alist))
 935       (if (null? a)
 936         '()
 937         (if (k= (caar a) key)
 938           (lp (cdr a))
 939           (cons (car a) (lp (cdr a))))))))
 940
 941 (define (alist-delete! key alist . rest)
 942   (let ((k= (if (pair? rest) (car rest) equal?)))
 943     (alist-delete key alist k=)))       ; XXX:optimize
 944
 945 ;;; Set operations on lists
 946
 947 (define (lset<= = . rest)
 948   (if (null? rest)
 949     #t
 950     (let lp ((f (car rest)) (r (cdr rest)))
 951       (or (null? r)
 952           (and (every (lambda (el) (member el (car r) =)) f)
 953                (lp (car r) (cdr r)))))))
 954
 955 (define (lset= = list1 . rest)
 956   (if (null? rest)
 957     #t
 958     (let lp ((f list1) (r rest))
 959       (or (null? r)
 960           (and (every (lambda (el) (member el (car r) =)) f)
 961                (every (lambda (el) (member el f =)) (car r))
 962                (lp (car r) (cdr r)))))))
 963
 964 (define (lset-adjoin = list . rest)
 965   (let lp ((l rest) (acc list))
 966     (if (null? l)
 967       acc
 968       (if (member (car l) acc)
 969         (lp (cdr l) acc)
 970         (lp (cdr l) (cons (car l) acc))))))
 971
 972 (define (lset-union = . rest)
 973   (let lp0 ((l rest) (acc '()))
 974     (if (null? l)
 975       (reverse! acc)
 976       (let lp1 ((ll (car l)) (acc acc))
 977         (if (null? ll)
 978           (lp0 (cdr l) acc)
 979           (if (member (car ll) acc =)
 980             (lp1 (cdr ll) acc)
 981             (lp1 (cdr ll) (cons (car ll) acc))))))))
 982
 983 (define (lset-intersection = list1 . rest)
 984   (let lp ((l list1) (acc '()))
 985     (if (null? l)
 986       (reverse! acc)
 987       (if (every (lambda (ll) (member (car l) ll =)) rest)
 988         (lp (cdr l) (cons (car l) acc))
 989         (lp (cdr l) acc)))))
 990
 991 (define (lset-difference = list1 . rest)
 992   (if (null? rest)
 993     list1
 994     (let lp ((l list1) (acc '()))
 995       (if (null? l)
 996         (reverse! acc)
 997         (if (any (lambda (ll) (member (car l) ll =)) rest)
 998           (lp (cdr l) acc)
 999           (lp (cdr l) (cons (car l) acc)))))))
1000
1001 ;(define (fold kons knil list1 . rest)
1002
1003 (define (lset-xor = . rest)
1004   (fold (lambda (lst res)
1005           (let lp ((l lst) (acc '()))
1006             (if (null? l)
1007               (let lp0 ((r res) (acc acc))
1008                 (if (null? r)
1009                   (reverse! acc)
1010                   (if (member (car r) lst =)
1011                     (lp0 (cdr r) acc)
1012                     (lp0 (cdr r) (cons (car r) acc)))))
1013               (if (member (car l) res =)
1014                 (lp (cdr l) acc)
1015                 (lp (cdr l) (cons (car l) acc))))))
1016         '()
1017         rest))
1018
1019 (define (lset-diff+intersection = list1 . rest)
1020   (let lp ((l list1) (accd '()) (acci '()))
1021     (if (null? l)
1022       (values (reverse! accd) (reverse! acci))
1023       (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
1024         (if appears
1025           (lp (cdr l) accd (cons (car l) acci))
1026           (lp (cdr l) (cons (car l) accd) acci))))))
1027
1028
1029 (define (lset-union! = . rest)
1030   (apply lset-union = rest))            ; XXX:optimize
1031
1032 (define (lset-intersection! = list1 . rest)
1033   (apply lset-intersection = list1 rest)) ; XXX:optimize
1034
1035 (define (lset-difference! = list1 . rest)
1036   (apply lset-difference = list1 rest)) ; XXX:optimize
1037
1038 (define (lset-xor! = . rest)
1039   (apply lset-xor = rest))              ; XXX:optimize
1040
1041 (define (lset-diff+intersection! = list1 . rest)
1042   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize