From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 25 Nov 2019 05:50:53 +0000 (-0800)
Subject: Implement complement, a predicate inverter.
X-Git-Tag: mit-scheme-pucked-10.1.20~10^2~48
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=318f183229760364049c768e056edb9ea3d85140;p=mit-scheme.git

Implement complement, a predicate inverter.
---

diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index 37269a93d..fef70a8f3 100644
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -55,6 +55,10 @@ USA.
   (and (compound-tag? object)
        (eq? 'conjoin (compound-tag-operator object))))
 
+(define (tag-is-complement? object)
+  (and (compound-tag? object)
+       (eq? 'complement (compound-tag-operator object))))
+
 (add-boot-init!
  (lambda ()
 
@@ -108,6 +112,12 @@ USA.
 		  'conjoin
 		  predicates))
 
+(define (complement predicate)
+  (make-predicate (lambda (object)
+		    (not (predicate object)))
+		  'complement
+		  (list predicate)))
+
 (define (make-predicate datum-test operator operands)
   (if (every predicate? operands)
       (dispatch-tag->predicate
@@ -157,4 +167,14 @@ USA.
      (make-joinish-memoizer dispatch-tag-is-top?))
 
    (define-compound-operator 'conjoin
-     (make-joinish-memoizer dispatch-tag-is-bottom?))))
\ No newline at end of file
+     (make-joinish-memoizer dispatch-tag-is-bottom?))
+
+   (define-compound-operator 'complement
+     (let ((table (make-key-weak-eqv-hash-table)))
+       (lambda (datum-test operator tags)
+	 (hash-table-intern! table
+			     (car tags)
+			     (lambda ()
+			       (make-compound-tag datum-test operator tags))))))
+
+   ))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 151185151..adf5ee221 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2032,6 +2032,7 @@ USA.
   (files "compound-predicate")
   (parent (runtime))
   (export ()
+	  complement
 	  conjoin
 	  conjoin*
 	  disjoin