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 / sf / lsets.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  330 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lsets.scm,v 4.3 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988, 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. ;;;; Unordered Set abstraction
  23.  
  24. (declare (usual-integrations)
  25.      (automagic-integrations)
  26.      (open-block-optimizations))
  27.  
  28. #|
  29.  
  30. Each set has an ELEMENT-TYPE which is a predicate that all elements of
  31. the set must satisfy.  Each set has a PREDICATE that is used to compare
  32. identity of the elements.  An element appears in a set only once.
  33.  
  34. This code is bummed up the wazoo for speed.  It is derived from a SET
  35. abstraction based on streams written by JRM.  I would not recommend trying
  36. to figure out what is going on in this code.
  37.  
  38. ;; User functions.
  39.  
  40. (define empty-set)
  41. (define singleton-set)
  42. (define list->set)
  43. (define stream->set)
  44. (define set-element-type)
  45.  
  46. (define set/member?)
  47. (define set/adjoin)
  48. (define set/adjoin*)
  49. (define set/remove)
  50. (define set->stream)
  51. (define set->list)
  52. (define set/for-each)
  53. (define set/map)
  54. (define set/empty?)
  55. (define set/union)
  56. (define set/union*)
  57. (define set/intersection)
  58. (define set/intersection*)
  59.  
  60. (define any-type?)
  61.  
  62. |#
  63.  
  64. (define-integrable (check-type element-type element)
  65.   element-type element            ;ignore
  66.   true)
  67.  
  68. (define-integrable (member-procedure predicate) 
  69.   predicate                ;ignore
  70.   memq)
  71.  
  72. (define-integrable (list-deletor predicate)
  73.   (letrec ((list-deletor-loop
  74.         (lambda (list)
  75.           (if (pair? list)
  76.           (if (predicate (car list))
  77.               (list-deletor-loop (cdr list))
  78.               (cons (car list) (list-deletor-loop (cdr list))))
  79.           '()))))
  80.     list-deletor-loop))
  81.  
  82. (define-integrable (set? object)
  83.   object                ;ignore
  84.   true)
  85.  
  86. (define-integrable (%make-set element-type predicate elements)
  87.   element-type predicate        ;ignore
  88.   elements)
  89.  
  90. (define-integrable (%unsafe-set-element-type set)
  91.   set                    ;ignore
  92.   (lambda (object) 
  93.     (declare (integrate object))
  94.     object                ;ignore
  95.     true))
  96.  
  97. (define-integrable (%unsafe-set-predicate set) 
  98.   set                    ;ignore
  99.   eq?)
  100.  
  101. (define-integrable (%unsafe-set-elements set)
  102.   set)
  103.  
  104. (define-integrable (set-element-type set)
  105.   (%unsafe-set-element-type set))
  106.  
  107. (define-integrable (adjoin-lists-without-duplicates predicate l1 l2)
  108.   predicate                ;ignore
  109.   (let loop ((new-list l1) (old-list l2))
  110.     (cond ((null? old-list) new-list)
  111.       ((memq (car old-list) new-list) (loop new-list (cdr old-list)))
  112.       (else (loop (cons (car old-list) new-list) (cdr old-list))))))
  113.  
  114. (define-integrable (invert-sense predicate)
  115.   (lambda (object)
  116.     (declare (integrate object))
  117.     (not (predicate object))))
  118.  
  119. (define-integrable (%subset predicate list)
  120.   ((list-deletor (invert-sense predicate)) list))
  121.  
  122. (define-integrable (remove-duplicates predicate list)
  123.   (adjoin-lists-without-duplicates predicate '() list))
  124.  
  125. (define (empty-set element-type predicate)
  126.   (%make-set element-type predicate '()))
  127.  
  128. (define (singleton-set element-type predicate element)
  129.   (check-type element-type element)
  130.   (%make-set element-type predicate (cons element '())))
  131.  
  132. (define (list->set element-type predicate elements)
  133.   (%make-set element-type predicate
  134.          (let loop ((elements (apply list elements)))
  135.            (cond ((null? elements) '())
  136.              ((check-type element-type (car elements))
  137.               (remove-duplicates predicate 
  138.                          (cons (car elements)
  139.                            (loop (cdr elements)))))
  140.              (else (error "Can't happen"))))))
  141.  
  142. (define (stream->set element-type predicate stream)
  143.   (%make-set element-type predicate
  144.          (let loop ((stream stream))
  145.            (cond ((empty-stream? stream) '())
  146.              ((check-type element-type (head stream))
  147.               (remove-duplicates predicate
  148.                      (cons (head stream)
  149.                            (loop (tail stream)))))
  150.              (else (error "Can't happen"))))))
  151.  
  152. ;;; End of speed hack.
  153.  
  154. (declare (integrate-operator spread-set))
  155. (define (spread-set set receiver)
  156.   (declare (integrate receiver))
  157.   (if (not (set? set))
  158.       (error "Object not a set" set))
  159.   (receiver (%unsafe-set-element-type set)
  160.         (%unsafe-set-predicate    set)
  161.         (%unsafe-set-elements     set)))
  162.  
  163. #|
  164. (define (spread-2-sets set1 set2 receiver)
  165.   (declare (integrate set1 set2 receiver))
  166.   (spread-set set1
  167.     (lambda (etype1 pred1 stream1)
  168.       (spread-set set2
  169.         (lambda (etype2 pred2 stream2)
  170.       (declare (integrate etype2 pred2))
  171.       (if (not (and (eq? etype1 etype2)
  172.             (eq? pred1  pred2)))
  173.           (error "Set mismatch")
  174.           (receiver etype1 pred1 stream1 stream2)))))))
  175. |#
  176. (define-integrable (spread-2-sets set1 set2 receiver)
  177.   (spread-set set1
  178.     (lambda (etype1 pred1 stream1)
  179.       (declare (integrate etype1 pred1))
  180.       (spread-set set2
  181.         (lambda (etype2 pred2 stream2)
  182.       etype2 pred2 ; are ignored
  183.       (receiver etype1 pred1 stream1 stream2))))))
  184.  
  185. (define (set/member? set element)
  186.   (spread-set set
  187.     (lambda (element-type predicate list)
  188.       (declare (integrate element-type predicate stream))
  189.       (check-type element-type element)
  190.       ((member-procedure predicate) element list))))
  191.  
  192. (declare (integrate-operator adjoin-element))
  193. (define (adjoin-element predicate element list)
  194.   (declare (integrate list))
  195.   predicate                ;ignore
  196.   (if (memq element list)
  197.       list
  198.       (cons element list)))
  199.  
  200. (define (set/adjoin set element)
  201.   (spread-set set
  202.     (lambda (element-type predicate list)
  203.       (declare (integrate list))
  204.       (check-type element-type element)
  205.       (%make-set element-type predicate
  206.          (adjoin-element predicate element list)))))
  207.  
  208. (define (set/adjoin* set element-list)
  209.   (if (null? element-list)
  210.       set
  211.       (set/adjoin (set/adjoin* set (cdr element-list)) (car element-list))))
  212.  
  213. (define (set/remove set element)
  214.   (spread-set set
  215.     (lambda (element-type predicate list)
  216.       (declare (integrate list))
  217.       (check-type element-type element)
  218.       (%make-set element-type predicate (delq element list)))))
  219.  
  220. (define (set/subset set subset-predicate)
  221.   (spread-set set
  222.     (lambda (element-type predicate list)
  223.       (declare (integrate element-type predicate list))
  224.       (%make-set element-type predicate
  225.          (%subset subset-predicate list)))))
  226.  
  227. (define (set->stream set)
  228.   (spread-set set
  229.     (lambda (element-type predicate list)
  230.       (declare (integrate list))
  231.       element-type predicate        ;ignore
  232.       (list->stream list))))
  233.  
  234. (define (list->stream list)
  235.   (if (null? list)
  236.       the-empty-stream
  237.       (cons-stream (car list) (list->stream (cdr list)))))
  238.  
  239. (define (set->list set)
  240.   (spread-set set
  241.     (lambda (element-type predicate l)
  242.       (declare (integrate list))
  243.       element-type predicate        ;ignore
  244.       (apply list l))))
  245.  
  246. (define (set/for-each function set)
  247.   (spread-set set
  248.     (lambda (element-type predicate list)
  249.       (declare (integrate list))
  250.       element-type predicate        ;ignore
  251.       (for-each function list))))
  252.  
  253. #|
  254. (define (set/map new-element-type new-predicate function set)
  255.   (spread-set set
  256.     (lambda (element-type predicate list)
  257.       (declare (integrate list))
  258.       element-type predicate        ;ignore
  259.       (%make-set new-element-type new-predicate
  260.          (remove-duplicates
  261.           new-predicate
  262.           (map (lambda (element)
  263.              (let ((new-element (function element)))
  264.                (if (new-element-type new-element)
  265.                    new-element
  266.                    (error "Element of wrong type" new-element))))
  267.                list))))))
  268. |#
  269.  
  270. (define (set/map new-element-type new-predicate function set)
  271.   (spread-set set
  272.     (lambda (element-type predicate list)
  273.       (declare (integrate list))
  274.       element-type predicate        ;ignore
  275.       (%make-set new-element-type new-predicate
  276.          (remove-duplicates eq? (map function list))))))
  277.  
  278. (define (set/empty? set)
  279.   (spread-set set
  280.     (lambda (element-type predicate list)
  281.       (declare (integrate list))
  282.       element-type predicate        ;ignore
  283.       (null? list))))
  284.  
  285. (define (interleave l1 l2)
  286.   (if (null? l1)
  287.       l2
  288.       (cons (car l1) (interleave l2 (cdr l1)))))
  289.  
  290. (define (set/union s1 s2)
  291.   (spread-2-sets s1 s2
  292.     (lambda (etype pred list1 list2)
  293.       (declare (integrate etype list1 list2))
  294.       (%make-set
  295.        etype pred
  296.        (adjoin-lists-without-duplicates pred list1 list2)))))
  297.  
  298. (define (set/union* . sets)
  299.   (cond ((null? sets) (error "Set/union* with no args"))
  300.     ((null? (cdr sets)) (car sets))
  301.     (else (set/union (car sets) (apply set/union* (cdr sets))))))
  302.  
  303. (define (set/intersection s1 s2)
  304.   (spread-2-sets s1 s2
  305.     (lambda (etype pred l1 l2)
  306.       (%make-set etype pred
  307.          (let loop ((elements l1))
  308.            (cond ((null? elements) '())
  309.              (((member-procedure pred) (car elements) l2)
  310.               (cons (car elements) (loop (cdr elements))))
  311.              (else (loop (cdr elements)))))))))
  312.  
  313. (define (set/intersection* . sets)
  314.   (cond ((null? sets) (error "set/intersection* with no args"))
  315.     ((null? (cdr sets)) (car sets))
  316.     (else (set/intersection (car sets)
  317.                 (apply set/intersection* (cdr sets))))))
  318.  
  319. (define (set/difference set1 set2)
  320.   (spread-2-sets set1 set2
  321.     (lambda (etype pred l1 l2)
  322.       (declare (integrate etype l1 l2))
  323.       (%make-set etype pred
  324.          (%subset (lambda (l1-element)
  325.                 (not ((member-procedure pred) l1-element l2)))
  326.               l1)))))
  327.  
  328. (define (any-type? element)
  329.   element                ;ignore
  330.   true)