From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 derived/eq-ord.scm | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 69 insertions(+)
 create mode 100644 derived/eq-ord.scm

(limited to 'derived/eq-ord.scm')

diff --git a/derived/eq-ord.scm b/derived/eq-ord.scm
new file mode 100644
index 0000000..b005b58
--- /dev/null
+++ b/derived/eq-ord.scm
@@ -0,0 +1,69 @@
+;;; ----------------------------------------------------------------
+;;;  Eq
+;;; ----------------------------------------------------------------
+
+(define (Eq-fns algdata)
+  (list
+   (cond ((algdata-enum? algdata)
+	  (**define '== '(|x| |y|)
+		    (**== (**con-number (**var '|x|) algdata)
+			  (**con-number (**var '|y|) algdata))))
+	 (else
+	  (**multi-define '== algdata
+			  ;; For nullary constructors
+			  (function **true)
+			  ;; For unary constructors
+			  (lambda (v1 v2)
+			    (**== (funcall v1) (funcall v2)))
+			  ;; For n-ary constructors
+			  (lambda (v1 v2 bool)
+			    (**and (**== (funcall v1) (funcall v2)) bool))
+			  ;; The else clause in case the constructors do
+			  ;; not match.
+			  (if (algdata-tuple? algdata)
+			      '#f
+			      (function **false)))))))
+
+;;; ----------------------------------------------------------------
+;;;  Ord
+;;; ----------------------------------------------------------------
+
+(define (Ord-fns algdata)
+  (list (ord-fn1 algdata '< (function **<))
+	(ord-fn1 algdata '<= (function **<=))))
+
+(define (Ord-fn1 algdata fn prim)
+  (cond ((algdata-enum? algdata)
+	 (**define fn '(|x| |y|)
+		       (funcall prim (**con-number (**var '|x|) algdata)
+				     (**con-number (**var '|y|) algdata))))
+	((algdata-tuple? algdata)
+	 (**multi-define fn algdata
+		         (function **false)
+			 (lambda (x y) (funcall prim (funcall x) (funcall y)))
+			 (function combine-eq-<)
+			 '#f))
+	(else
+	 (**define fn '(|x| |y|)
+	   (**let
+	    (list 
+	     (**multi-define '|inner| algdata
+			       (if (eq? fn '<) (function **false)
+				               (function **true))
+			       (lambda (x y)
+				 (funcall prim (funcall x) (funcall y)))
+			       (function combine-eq-<)
+			       '#f)
+	     (**define '|cx| '() (**con-number (**var '|x|) algdata))
+	     (**define '|cy| '() (**con-number (**var '|y|) algdata)))
+	    (**or (**< (**var '|cx|) (**var '|cy|))
+		  (**and (**== (**var `|cx|) (**var '|cy|))
+			 (**app (**var '|inner|)
+				(**var '|x|)
+				(**var '|y|)))))))))
+
+(define (combine-eq-< v1 v2 rest)
+  (**or (**< (funcall v1) (funcall v2))
+	(**and (**== (funcall v1) (funcall v2))
+	       rest)))
+
-- 
cgit v1.2.3