home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / base / sets.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  184 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: sets.scm,v 4.2 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Simple Set Abstraction
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (eq-set-adjoin element set)
  27.   (if (memq element set)
  28.       set
  29.       (cons element set)))
  30.  
  31. (define (eqv-set-adjoin element set)
  32.   (if (memv element set)
  33.       set
  34.       (cons element set)))
  35.  
  36. (define (eq-set-delete set item)
  37.   (define (loop set)
  38.     (cond ((null? set) '())
  39.       ((eq? (car set) item) (cdr set))
  40.       (else (cons (car set) (loop (cdr set))))))
  41.   (loop set))
  42.  
  43. (define (eqv-set-delete set item)
  44.   (define (loop set)
  45.     (cond ((null? set) '())
  46.       ((eqv? (car set) item) (cdr set))
  47.       (else (cons (car set) (loop (cdr set))))))
  48.   (loop set))
  49.  
  50. (define (eq-set-substitute set old new)
  51.   (define (loop set)
  52.     (cond ((null? set) '())
  53.       ((eq? (car set) old) (cons new (cdr set)))
  54.       (else (cons (car set) (loop (cdr set))))))
  55.   (loop set))
  56.  
  57. (define (eqv-set-substitute set old new)
  58.   (define (loop set)
  59.     (cond ((null? set) '())
  60.       ((eqv? (car set) old) (cons new (cdr set)))
  61.       (else (cons (car set) (loop (cdr set))))))
  62.   (loop set))
  63.  
  64. (define (set-search set procedure)
  65.   (define (loop items)
  66.     (and (not (null? items))
  67.      (or (procedure (car items))
  68.          (loop (cdr items)))))
  69.   (loop set))
  70.  
  71. ;;; The dataflow analyzer assumes that
  72. ;;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
  73.  
  74. (define (eq-set-union x y)
  75.   (if (null? y)
  76.       x
  77.       (let loop ((x x) (y y))
  78.     (if (null? x)
  79.         y
  80.         (loop (cdr x)
  81.           (if (memq (car x) y)
  82.               y
  83.               (cons (car x) y)))))))
  84.  
  85. (define (eqv-set-union x y)
  86.   (if (null? y)
  87.       x
  88.       (let loop ((x x) (y y))
  89.     (if (null? x)
  90.         y
  91.         (loop (cdr x)
  92.           (if (memv (car x) y)
  93.               y
  94.               (cons (car x) y)))))))
  95.  
  96. (define (eq-set-difference x y)
  97.   (define (loop x)
  98.     (cond ((null? x) '())
  99.       ((memq (car x) y) (loop (cdr x)))
  100.       (else (cons (car x) (loop (cdr x))))))
  101.   (loop x))
  102.  
  103. (define (eqv-set-difference x y)
  104.   (define (loop x)
  105.     (cond ((null? x) '())
  106.       ((memv (car x) y) (loop (cdr x)))
  107.       (else (cons (car x) (loop (cdr x))))))
  108.   (loop x))
  109.  
  110. (define (eq-set-intersection x y)
  111.   (define (loop x)
  112.     (cond ((null? x) '())
  113.       ((memq (car x) y) (cons (car x) (loop (cdr x))))
  114.       (else (loop (cdr x)))))
  115.   (loop x))
  116.  
  117. (define (eqv-set-intersection x y)
  118.   (define (loop x)
  119.     (cond ((null? x) '())
  120.       ((memv (car x) y) (cons (car x) (loop (cdr x))))
  121.       (else (loop (cdr x)))))
  122.   (loop x))
  123.  
  124. (define (eq-set-disjoint? x y)
  125.   (define (loop x)
  126.     (cond ((null? x) true)
  127.       ((memq (car x) y) false)
  128.       (else (loop (cdr x)))))
  129.   (loop x))
  130.  
  131. (define (eqv-set-disjoint? x y)
  132.   (define (loop x)
  133.     (cond ((null? x) true)
  134.       ((memv (car x) y) false)
  135.       (else (loop (cdr x)))))
  136.   (loop x))
  137.  
  138. (define (eq-set-subset? x y)
  139.   (define (loop x)
  140.     (cond ((null? x) true)
  141.       ((memq (car x) y) (loop (cdr x)))
  142.       (else false)))
  143.   (loop x))
  144.  
  145. (define (eqv-set-subset? x y)
  146.   (define (loop x)
  147.     (cond ((null? x) true)
  148.       ((memv (car x) y) (loop (cdr x)))
  149.       (else false)))
  150.   (loop x))
  151.  
  152. (define (eq-set-same-set? x y)
  153.   (and (eq-set-subset? x y)
  154.        (eq-set-subset? y x)))
  155.  
  156. (define (eqv-set-same-set? x y)
  157.   (and (eqv-set-subset? x y)
  158.        (eqv-set-subset? y x)))
  159.  
  160. (define (list->eq-set elements)
  161.   (if (null? elements)
  162.       '()
  163.       (eq-set-adjoin (car elements)
  164.              (list->eq-set (cdr elements)))))
  165.  
  166. (define (list->eqv-set elements)
  167.   (if (null? elements)
  168.       '()
  169.       (eqv-set-adjoin (car elements)
  170.               (list->eqv-set (cdr elements)))))
  171.  
  172. (define (map->eq-set procedure items)
  173.   (let loop ((items items))
  174.     (if (null? items)
  175.     '()
  176.     (eq-set-adjoin (procedure (car items))
  177.                (loop (cdr items))))))
  178.  
  179. (define (map->eqv-set procedure items)
  180.   (let loop ((items items))
  181.     (if (null? items)
  182.     '()
  183.     (eqv-set-adjoin (procedure (car items))
  184.             (loop (cdr items))))))