home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / alist next >
Text File  |  1994-05-23  |  2KB  |  67 lines
  1. ;;;"alist.scm", alist functions for Scheme.
  2. ;;;Copyright (c) 1992, 1993 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define (predicate->asso pred)
  21.   (cond ((eq? eq? pred) assq)
  22.     ((eq? = pred) assv)
  23.     ((eq? eqv? pred) assv)
  24.     ((eq? char=? pred) assv)
  25.     ((eq? equal? pred) assoc)
  26.     ((eq? string=? pred) assoc)
  27.     (else (lambda (key alist)
  28.         (let l ((al alist))
  29.           (cond ((null? al) #f)
  30.             ((pred key (caar al)) (car al))
  31.             (else (l (cdr al)))))))))
  32.  
  33. (define (alist-inquirer pred)
  34.   (let ((assofun (predicate->asso pred)))
  35.     (lambda (alist key)
  36.       (let ((pair (assofun key alist)))
  37.     (and pair (cdr pair))))))
  38.  
  39. (define (alist-associator pred)
  40.   (let ((assofun (predicate->asso pred)))
  41.     (lambda (alist key val)
  42.       (let* ((pair (assofun key alist)))
  43.     (cond (pair (set-cdr! pair val)
  44.             alist)
  45.           (else (cons (cons key val) alist)))))))
  46.  
  47. (define (alist-remover pred)
  48.   (lambda (alist key)
  49.     (cond ((null? alist) alist)
  50.       ((pred key (caar alist)) (cdr alist))
  51.       ((null? (cdr alist)) alist)
  52.       ((pred key (caadr alist))
  53.        (set-cdr! alist (cddr alist)) alist)
  54.       (else
  55.        (let l ((al (cdr alist)))
  56.          (cond ((null? (cdr al)) alist)
  57.            ((pred key (caadr al))
  58.             (set-cdr! al (cddr al)) alist)
  59.            (else (l (cdr al)))))))))
  60.  
  61. (define (alist-map proc alist)
  62.   (map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair))))
  63.        alist))
  64.  
  65. (define (alist-for-each proc alist)
  66.   (for-each (lambda (pair) (proc (car pair) (cdr pair))) alist))
  67.