git.fiddlerwoaroof.com
derived/eq-ord.scm
4e987026
 ;;; ----------------------------------------------------------------
 ;;;  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)))