guile18/srfi/srfi-1.scm

   1 ;;; srfi-1.scm --- List Library
   2
   3 ;;      Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library 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 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
  20 ;;; Date: 2001-06-06
  21
  22 ;;; Commentary:
  23
  24 ;; This is an implementation of SRFI-1 (List Library).
  25 ;;
  26 ;; All procedures defined in SRFI-1, which are not already defined in
  27 ;; the Guile core library, are exported.  The procedures in this
  28 ;; implementation work, but they have not been tuned for speed or
  29 ;; memory usage.
  30 ;;
  31 ;; This module is fully documented in the Guile Reference Manual.
  32
  33 ;;; Code:
  34
  35 (define-module (srfi srfi-1)
  36   :export (
  37 ;;; Constructors
  38  ;; cons                                <= in the core
  39  ;; list                                <= in the core
  40  xcons
  41  ;; cons*                               <= in the core
  42  ;; make-list                           <= in the core
  43  list-tabulate
  44  list-copy
  45  circular-list
  46  ;; iota                                ; Extended.
  47
  48 ;;; Predicates
  49  proper-list?
  50  circular-list?
  51  dotted-list?
  52  ;; pair?                               <= in the core
  53  ;; null?                               <= in the core
  54  null-list?
  55  not-pair?
  56  list=
  57
  58 ;;; Selectors
  59  ;; car                                 <= in the core
  60  ;; cdr                                 <= in the core
  61  ;; caar                                <= in the core
  62  ;; cadr                                <= in the core
  63  ;; cdar                                <= in the core
  64  ;; cddr                                <= in the core
  65  ;; caaar                               <= in the core
  66  ;; caadr                               <= in the core
  67  ;; cadar                               <= in the core
  68  ;; caddr                               <= in the core
  69  ;; cdaar                               <= in the core
  70  ;; cdadr                               <= in the core
  71  ;; cddar                               <= in the core
  72  ;; cdddr                               <= in the core
  73  ;; caaaar                              <= in the core
  74  ;; caaadr                              <= in the core
  75  ;; caadar                              <= in the core
  76  ;; caaddr                              <= in the core
  77  ;; cadaar                              <= in the core
  78  ;; cadadr                              <= in the core
  79  ;; caddar                              <= in the core
  80  ;; cadddr                              <= in the core
  81  ;; cdaaar                              <= in the core
  82  ;; cdaadr                              <= in the core
  83  ;; cdadar                              <= in the core
  84  ;; cdaddr                              <= in the core
  85  ;; cddaar                              <= in the core
  86  ;; cddadr                              <= in the core
  87  ;; cdddar                              <= in the core
  88  ;; cddddr                              <= in the core
  89  ;; list-ref                            <= in the core
  90  first
  91  second
  92  third
  93  fourth
  94  fifth
  95  sixth
  96  seventh
  97  eighth
  98  ninth
  99  tenth
 100  car+cdr
 101  take
 102  drop
 103  take-right
 104  drop-right
 105  take!
 106  drop-right!
 107  split-at
 108  split-at!
 109  last
 110  ;; last-pair                           <= in the core
 111
 112 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 113  ;; length                              <= in the core
 114  length+
 115  ;; append                              <= in the core
 116  ;; append!                             <= in the core
 117  concatenate
 118  concatenate!
 119  ;; reverse                             <= in the core
 120  ;; reverse!                            <= in the core
 121  append-reverse
 122  append-reverse!
 123  zip
 124  unzip1
 125  unzip2
 126  unzip3
 127  unzip4
 128  unzip5
 129  count
 130
 131 ;;; Fold, unfold & map
 132  fold
 133  fold-right
 134  pair-fold
 135  pair-fold-right
 136  reduce
 137  reduce-right
 138  unfold
 139  unfold-right
 140  ;; map                                 ; Extended.
 141  ;; for-each                            ; Extended.
 142  append-map
 143  append-map!
 144  map!
 145  ;; map-in-order                        ; Extended.
 146  pair-for-each
 147  filter-map
 148
 149 ;;; Filtering & partitioning
 150  ;; filter                              <= in the core
 151  partition
 152  remove
 153  ;; filter!                             <= in the core
 154  partition!
 155  remove!
 156
 157 ;;; Searching
 158  find
 159  find-tail
 160  take-while
 161  take-while!
 162  drop-while
 163  span
 164  span!
 165  break
 166  break!
 167  any
 168  every
 169  ;; list-index                          ; Extended.
 170  ;; member                              ; Extended.
 171  ;; memq                                <= in the core
 172  ;; memv                                <= in the core
 173
 174 ;;; Deletion
 175  ;; delete                              ; Extended.
 176  ;; delete!                             ; Extended.
 177  delete-duplicates
 178  delete-duplicates!
 179
 180 ;;; Association lists
 181  ;; assoc                               ; Extended.
 182  ;; assq                                <= in the core
 183  ;; assv                                <= in the core
 184  alist-cons
 185  alist-copy
 186  alist-delete
 187  alist-delete!
 188
 189 ;;; Set operations on lists
 190  lset<=
 191  lset=
 192  lset-adjoin
 193  lset-union
 194  lset-intersection
 195  lset-difference
 196  lset-xor
 197  lset-diff+intersection
 198  lset-union!
 199  lset-intersection!
 200  lset-difference!
 201  lset-xor!
 202  lset-diff+intersection!
 203
 204 ;;; Primitive side-effects
 205  ;; set-car!                            <= in the core
 206  ;; set-cdr!                            <= in the core
 207  )
 208   :re-export (cons list cons* make-list pair? null?
 209               car cdr caar cadr cdar cddr
 210               caaar caadr cadar caddr cdaar cdadr cddar cdddr
 211               caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 212               cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 213               list-ref last-pair length append append! reverse reverse!
 214               filter filter! memq memv assq assv set-car! set-cdr!)
 215   :replace (iota map for-each map-in-order list-copy list-index member
 216             delete delete! assoc)
 217   )
 218
 219 (cond-expand-provide (current-module) '(srfi-1))
 220
 221 ;; Load the compiled primitives from the shared library.
 222 ;;
 223 (load-extension "libguile-srfi-srfi-1-v-3" "scm_init_srfi_1")
 224
 225
 226 ;;; Constructors
 227
 228 ;; internal helper, similar to (scsh utilities) check-arg.
 229 (define (check-arg-type pred arg caller)
 230   (if (pred arg)
 231       arg
 232       (scm-error 'wrong-type-arg caller
 233                  "Wrong type argument: ~S" (list arg) '())))
 234
 235 ;; the srfi spec doesn't seem to forbid inexact integers.
 236 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
 237
 238
 239
 240 (define (circular-list elt1 . elts)
 241   (set! elts (cons elt1 elts))
 242   (set-cdr! (last-pair elts) elts)
 243   elts)
 244
 245 (define (iota count . rest)
 246   (check-arg-type non-negative-integer? count "iota")
 247   (let ((start (if (pair? rest) (car rest) 0))
 248         (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
 249     (let lp ((n 0) (acc '()))
 250       (if (= n count)
 251         (reverse! acc)
 252         (lp (+ n 1) (cons (+ start (* n step)) acc))))))
 253
 254 ;;; Predicates
 255
 256 (define (proper-list? x)
 257   (list? x))
 258
 259 (define (circular-list? x)
 260   (if (not-pair? x)
 261     #f
 262     (let lp ((hare (cdr x)) (tortoise x))
 263       (if (not-pair? hare)
 264         #f
 265         (let ((hare (cdr hare)))
 266           (if (not-pair? hare)
 267             #f
 268             (if (eq? hare tortoise)
 269               #t
 270               (lp (cdr hare) (cdr tortoise)))))))))
 271
 272 (define (dotted-list? x)
 273   (cond
 274     ((null? x) #f)
 275     ((not-pair? x) #t)
 276     (else
 277      (let lp ((hare (cdr x)) (tortoise x))
 278        (cond
 279          ((null? hare) #f)
 280          ((not-pair? hare) #t)
 281          (else
 282           (let ((hare (cdr hare)))
 283             (cond
 284               ((null? hare) #f)
 285               ((not-pair? hare) #t)
 286               ((eq? hare tortoise) #f)
 287               (else
 288                (lp (cdr hare) (cdr tortoise)))))))))))
 289
 290 (define (null-list? x)
 291   (cond
 292     ((proper-list? x)
 293      (null? x))
 294     ((circular-list? x)
 295      #f)
 296     (else
 297      (error "not a proper list in null-list?"))))
 298
 299 (define (list= elt= . rest)
 300   (define (lists-equal a b)
 301     (let lp ((a a) (b b))
 302       (cond ((null? a)
 303              (null? b))
 304             ((null? b)
 305              #f)
 306             (else
 307              (and (elt= (car a) (car b))
 308                   (lp (cdr a) (cdr b)))))))
 309   (or (null? rest)
 310       (let lp ((lists rest))
 311         (or (null? (cdr lists))
 312             (and (lists-equal (car lists) (cadr lists))
 313                  (lp (cdr lists)))))))
 314
 315 ;;; Selectors
 316
 317 (define first car)
 318 (define second cadr)
 319 (define third caddr)
 320 (define fourth cadddr)
 321
 322 (define take list-head)
 323 (define drop list-tail)
 324
 325 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 326
 327 (define (zip clist1 . rest)
 328   (let lp ((l (cons clist1 rest)) (acc '()))
 329     (if (any null? l)
 330       (reverse! acc)
 331       (lp (map1 cdr l) (cons (map1 car l) acc)))))
 332
 333
 334 (define (unzip1 l)
 335   (map1 first l))
 336 (define (unzip2 l)
 337   (values (map1 first l) (map1 second l)))
 338 (define (unzip3 l)
 339   (values (map1 first l) (map1 second l) (map1 third l)))
 340 (define (unzip4 l)
 341   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
 342 (define (unzip5 l)
 343   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
 344           (map1 fifth l)))
 345
 346 ;;; Fold, unfold & map
 347
 348 (define (fold-right kons knil clist1 . rest)
 349   (if (null? rest)
 350     (let f ((list1 clist1))
 351       (if (null? list1)
 352         knil
 353         (kons (car list1) (f (cdr list1)))))
 354     (let f ((lists (cons clist1 rest)))
 355       (if (any null? lists)
 356         knil
 357         (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
 358
 359 (define (pair-fold kons knil clist1 . rest)
 360   (if (null? rest)
 361       (let f ((knil knil) (list1 clist1))
 362         (if (null? list1)
 363             knil
 364             (let ((tail (cdr list1)))
 365             (f (kons list1 knil) tail))))
 366       (let f ((knil knil) (lists (cons clist1 rest)))
 367         (if (any null? lists)
 368             knil
 369             (let ((tails (map1 cdr lists)))
 370               (f (apply kons (append! lists (list knil))) tails))))))
 371
 372
 373 (define (pair-fold-right kons knil clist1 . rest)
 374   (if (null? rest)
 375     (let f ((list1 clist1))
 376       (if (null? list1)
 377         knil
 378         (kons list1 (f (cdr list1)))))
 379     (let f ((lists (cons clist1 rest)))
 380       (if (any null? lists)
 381         knil
 382         (apply kons (append! lists (list (f (map1 cdr lists)))))))))
 383
 384 (define (unfold p f g seed . rest)
 385   (let ((tail-gen (if (pair? rest)
 386                       (if (pair? (cdr rest))
 387                           (scm-error 'wrong-number-of-args
 388                                      "unfold" "too many arguments" '() '())
 389                           (car rest))
 390                       (lambda (x) '()))))
 391     (let uf ((seed seed))
 392       (if (p seed)
 393           (tail-gen seed)
 394           (cons (f seed)
 395                 (uf (g seed)))))))
 396
 397 (define (unfold-right p f g seed . rest)
 398   (let ((tail (if (pair? rest)
 399                   (if (pair? (cdr rest))
 400                       (scm-error 'wrong-number-of-args
 401                                      "unfold-right" "too many arguments" '()
 402                                      '())
 403                       (car rest))
 404                       '())))
 405     (let uf ((seed seed) (lis tail))
 406       (if (p seed)
 407           lis
 408           (uf (g seed) (cons (f seed) lis))))))
 409
 410
 411 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 412 ;;
 413 (define map1 map)
 414
 415 (define (append-map f clist1 . rest)
 416   (concatenate (apply map f clist1 rest)))
 417
 418 (define (append-map! f clist1 . rest)
 419   (concatenate! (apply map f clist1 rest)))
 420
 421 ;; OPTIMIZE-ME: Re-use cons cells of list1
 422 (define map! map)
 423
 424 (define (pair-for-each f clist1 . rest)
 425   (if (null? rest)
 426     (let lp ((l clist1))
 427       (if (null? l)
 428         (if #f #f)
 429         (begin
 430           (f l)
 431           (lp (cdr l)))))
 432     (let lp ((l (cons clist1 rest)))
 433       (if (any1 null? l)
 434         (if #f #f)
 435         (begin
 436           (apply f l)
 437           (lp (map1 cdr l)))))))
 438
 439 ;;; Searching
 440
 441 (define (any pred ls . lists)
 442   (if (null? lists)
 443       (any1 pred ls)
 444       (let lp ((lists (cons ls lists)))
 445         (cond ((any1 null? lists)
 446                #f)
 447               ((any1 null? (map1 cdr lists))
 448                (apply pred (map1 car lists)))
 449               (else
 450                (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 451
 452 (define (any1 pred ls)
 453   (let lp ((ls ls))
 454     (cond ((null? ls)
 455            #f)
 456           ((null? (cdr ls))
 457            (pred (car ls)))
 458           (else
 459            (or (pred (car ls)) (lp (cdr ls)))))))
 460
 461 (define (every pred ls . lists)
 462   (if (null? lists)
 463       (every1 pred ls)
 464       (let lp ((lists (cons ls lists)))
 465         (cond ((any1 null? lists)
 466                #t)
 467               ((any1 null? (map1 cdr lists))
 468                (apply pred (map1 car lists)))
 469               (else
 470                (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 471
 472 (define (every1 pred ls)
 473   (let lp ((ls ls))
 474     (cond ((null? ls)
 475            #t)
 476           ((null? (cdr ls))
 477            (pred (car ls)))
 478           (else
 479            (and (pred (car ls)) (lp (cdr ls)))))))
 480
 481 ;;; Association lists
 482
 483 (define alist-cons acons)
 484
 485 (define (alist-delete key alist . rest)
 486   (let ((k= (if (pair? rest) (car rest) equal?)))
 487     (let lp ((a alist) (rl '()))
 488       (if (null? a)
 489         (reverse! rl)
 490         (if (k= key (caar a))
 491           (lp (cdr a) rl)
 492           (lp (cdr a) (cons (car a) rl)))))))
 493
 494 (define (alist-delete! key alist . rest)
 495   (let ((k= (if (pair? rest) (car rest) equal?)))
 496     (alist-delete key alist k=)))       ; XXX:optimize
 497
 498 ;;; Set operations on lists
 499
 500 (define (lset<= = . rest)
 501   (if (null? rest)
 502     #t
 503     (let lp ((f (car rest)) (r (cdr rest)))
 504       (or (null? r)
 505           (and (every (lambda (el) (member el (car r) =)) f)
 506                (lp (car r) (cdr r)))))))
 507
 508 (define (lset= = . rest)
 509   (if (null? rest)
 510     #t
 511     (let lp ((f (car rest)) (r (cdr rest)))
 512       (or (null? r)
 513           (and (every (lambda (el) (member el (car r) =)) f)
 514                (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
 515                (lp (car r) (cdr r)))))))
 516
 517 (define (lset-union = . rest)
 518   (let ((acc '()))
 519     (for-each (lambda (lst)
 520                 (if (null? acc)
 521                     (set! acc lst)
 522                     (for-each (lambda (elem)
 523                                 (if (not (member elem acc
 524                                                  (lambda (x y) (= y x))))
 525                                     (set! acc (cons elem acc))))
 526                               lst)))
 527               rest)
 528     acc))
 529
 530 (define (lset-intersection = list1 . rest)
 531   (let lp ((l list1) (acc '()))
 532     (if (null? l)
 533       (reverse! acc)
 534       (if (every (lambda (ll) (member (car l) ll =)) rest)
 535         (lp (cdr l) (cons (car l) acc))
 536         (lp (cdr l) acc)))))
 537
 538 (define (lset-difference = list1 . rest)
 539   (if (null? rest)
 540     list1
 541     (let lp ((l list1) (acc '()))
 542       (if (null? l)
 543         (reverse! acc)
 544         (if (any (lambda (ll) (member (car l) ll =)) rest)
 545           (lp (cdr l) acc)
 546           (lp (cdr l) (cons (car l) acc)))))))
 547
 548 ;(define (fold kons knil list1 . rest)
 549
 550 (define (lset-xor = . rest)
 551   (fold (lambda (lst res)
 552           (let lp ((l lst) (acc '()))
 553             (if (null? l)
 554               (let lp0 ((r res) (acc acc))
 555                 (if (null? r)
 556                   (reverse! acc)
 557                   (if (member (car r) lst =)
 558                     (lp0 (cdr r) acc)
 559                     (lp0 (cdr r) (cons (car r) acc)))))
 560               (if (member (car l) res =)
 561                 (lp (cdr l) acc)
 562                 (lp (cdr l) (cons (car l) acc))))))
 563         '()
 564         rest))
 565
 566 (define (lset-diff+intersection = list1 . rest)
 567   (let lp ((l list1) (accd '()) (acci '()))
 568     (if (null? l)
 569       (values (reverse! accd) (reverse! acci))
 570       (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
 571         (if appears
 572           (lp (cdr l) accd (cons (car l) acci))
 573           (lp (cdr l) (cons (car l) accd) acci))))))
 574
 575
 576 (define (lset-union! = . rest)
 577   (apply lset-union = rest))            ; XXX:optimize
 578
 579 (define (lset-intersection! = list1 . rest)
 580   (apply lset-intersection = list1 rest)) ; XXX:optimize
 581
 582 (define (lset-xor! = . rest)
 583   (apply lset-xor = rest))              ; XXX:optimize
 584
 585 (define (lset-diff+intersection! = list1 . rest)
 586   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
 587
 588 ;;; srfi-1.scm ends here