; $Id: numbers.scm 2340 2009-09-18 11:53:09Z schwicht $

; (load "~/minlog/init.scm")
; (set! DOT-NOTATION #f)
; (set! COMMENT-FLAG #f)
; (load "nat.scm")
; (set! COMMENT-FLAG #t)
(if (not (assoc "nat" ALGEBRAS))
    (myerror "First execute (libload \"nat.scm\")"))

(remove-var-name "k")

(display "loading numbers.scm ...") (newline)

; We change term-to-t-deg-aux in case of division by a non-zero term,
; or exponentiation of zero with a negative exponent.

(define (term-to-t-deg-aux term bound-vars)
  (case (tag term)
    ((term-in-var-form)
     (let ((var (term-in-var-form-to-var term)))
       (if (member var bound-vars) t-deg-one (var-to-t-deg var))))
    ((term-in-const-form) (const-to-t-deg
			   (term-in-const-form-to-const term)))
    ((term-in-abst-form)
     (let ((var (term-in-abst-form-to-var term))
	   (kernel (term-in-abst-form-to-kernel term)))
       (term-to-t-deg-aux kernel (cons var bound-vars))))
    ((term-in-app-form)
     (let* ((op (term-in-app-form-to-op term))
	    (arg (term-in-app-form-to-arg term))
	    (t-deg-op (term-to-t-deg-aux op bound-vars))
	    (t-deg-arg (term-to-t-deg-aux arg bound-vars)))
       (if
	(or (and (t-deg-one? t-deg-op) (t-deg-one? t-deg-arg))
	    (and (term-in-app-form? op)
		 (let* ((opop (term-in-app-form-to-op op))
			(oparg (term-in-app-form-to-arg op))
			(t-deg-oparg (term-to-t-deg-aux oparg bound-vars)))
		   (and (t-deg-one? t-deg-oparg)
			(term-in-const-form? opop)
			(let* ((const (term-in-const-form-to-const opop))
			       (name (const-to-name const)))
			  (or (and (member name '("RatDiv" "RealDiv" "CpxDiv"))
				   (synt-non-zero? arg))
			      (and (member name '("RatExp" "RealExp" "CpxExp"))
				   (or (synt-non-zero? oparg)
				       (synt-nneg? arg)))))))))
	t-deg-one
	t-deg-zero)))
    ((term-in-pair-form)
     (let* ((left (term-in-pair-form-to-left term))
	    (right (term-in-pair-form-to-right term))
	    (t-deg-left (term-to-t-deg-aux left bound-vars))
	    (t-deg-right (term-to-t-deg-aux right bound-vars)))
       (if (and (t-deg-one? t-deg-left) (t-deg-one? t-deg-right))
	   t-deg-one
	   t-deg-zero)))
    ((term-in-lcomp-form)
     (term-to-t-deg-aux (term-in-lcomp-form-to-kernel term) bound-vars))
    ((term-in-rcomp-form)
     (term-to-t-deg-aux (term-in-rcomp-form-to-kernel term) bound-vars))
    ((term-in-if-form)
     (let* ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term))
	    (t-deg-test (term-to-t-deg-aux test bound-vars))
	    (t-deg-alts (map (lambda (x) (term-to-t-deg-aux x bound-vars))
			     alts)))
       (if (apply and-op (cons (t-deg-one? t-deg-test)
			       (map t-deg-one? t-deg-alts)))
	   t-deg-one
	   t-deg-zero)))
    (else (myerror "term-to-t-deg-aux" "term expected" term))))

(define (synt-non-zero? term)
  (let ((op (term-in-app-form-to-final-op term))
	(args (term-in-app-form-to-args term))
	(type (term-to-type term)))
    (and
     (alg-form? type)
     (or
      (string=? (alg-form-to-name type) "pos")
      (and
       (term-in-const-form? op)
       (let* ((const (term-in-const-form-to-const op))
	      (name (const-to-name const)))
	 (cond
	  ((member name '("PosToNat" "Succ" "IntPos" "IntNeg")) #t)
	  ((member name '("NatPlus" "IntPlus" "RatPlus" "RealPlus" "CpxPlus"))
	   (or (and (synt-pos? (car args)) (synt-nneg? (cadr args)))
	       (and (synt-nneg? (car args)) (synt-pos? (cadr args)))))
	  ((member name
		   '("NatTimes" "IntTimes" "RatTimes" "RealTimes" "CpxTimes"))
	   (and (synt-non-zero? (car args)) (synt-non-zero? (cadr args))))
	  ((member name '("NatExp" "IntExp" "RatExp" "RealExp" "CpxExp"))
	   (synt-non-zero? (car args)))
	  ((member name '("NatToInt" "RatConstr"))
	   (synt-non-zero? (car args)))
	  ((member name '("RealConstr"))
	   (and (term-in-abst-form? (car args))
		(let ((var (term-in-abst-form-to-var (car args)))
		      (kernel (term-in-abst-form-to-kernel (car args))))
		  (and (not (member var (term-to-free kernel)))
		       (synt-non-zero? kernel)))))
	  (else #f))))))))

(define (synt-pos? term)
  (let ((op (term-in-app-form-to-final-op term))
	(args (term-in-app-form-to-args term))
	(type (term-to-type term)))
    (and
     (alg-form? type)
     (or
      (string=? (alg-form-to-name type) "pos")
      (and
       (term-in-const-form? op)
       (let* ((const (term-in-const-form-to-const op))
	      (name (const-to-name const)))
	 (cond
	  ((member name '("PosToNat" "Succ" "IntPos")) #t)
	  ((member name '("NatPlus" "IntPlus" "RatPlus" "RealPlus"))
	   (or (and (synt-pos? (car args)) (synt-nneg? (cadr args)))
	       (and (synt-nneg? (car args)) (synt-pos? (cadr args)))))
	  ((member name '("NatTimes" "IntTimes" "RatTimes" "RealTimes"))
	   (or (and (synt-pos? (car args)) (synt-pos? (cadr args)))
	       (and (synt-neg? (car args)) (synt-neg? (cadr args)))))
	  ((member name '("NatExp" "IntExp" "RatExp" "RealExp"))
	   (synt-pos? (car args)))
	  ((member name '("NatToInt" "RatConstr"))
	   (synt-pos? (car args)))
	  ((member name '("RealConstr"))
	   (and (term-in-abst-form? (car args))
		(let ((var (term-in-abst-form-to-var (car args)))
		      (kernel (term-in-abst-form-to-kernel (car args))))
		  (and (not (member var (term-to-free kernel)))
		       (synt-pos? kernel)))))
	  (else #f))))))))

(define (synt-nneg? term)
  (let ((op (term-in-app-form-to-final-op term))
	(args (term-in-app-form-to-args term))
	(type (term-to-type term)))
    (and
     (alg-form? type)
     (or
      (member (alg-form-to-name type) '("pos" "nat"))
      (and
       (term-in-const-form? op)
       (let* ((const (term-in-const-form-to-const op))
	      (name (const-to-name const)))
	 (cond
	  ((member name '("IntZero" "IntPos")) #t)
	  ((member name '("IntPlus" "RatPlus" "RealPlus"))
	   (and (synt-nneg? (car args) (synt-nneg? (cadr args)))))
	  ((member name '("IntTimes" "RatTimes" "RealTimes"))
	   (or (and (synt-nneg? (car args)) (synt-nneg? (cadr args)))
	       (and (synt-neg? (car args)) (synt-neg? (cadr args)))))
	  ((member name '("IntExp" "RatExp" "RealExp"))
	   (synt-nneg? (car args)))
	  ((member name '("NatToInt" "RatConstr"))
	   (synt-nneg? (car args)))
	  ((member name '("RealConstr"))
	   (and (term-in-abst-form? (car args))
		(let ((var (term-in-abst-form-to-var (car args)))
		      (kernel (term-in-abst-form-to-kernel (car args))))
		  (and (not (member var (term-to-free kernel)))
		       (synt-nneg? kernel)))))
	  (else #f))))))))

(define (synt-neg? term)
  (let ((op (term-in-app-form-to-final-op term))
	(args (term-in-app-form-to-args term))
	(type (term-to-type term)))
    (and
     (alg-form? type)
     (term-in-const-form? op)
     (let* ((const (term-in-const-form-to-const op))
	    (name (const-to-name const)))
       (cond
	((member name '("IntNeg")) #t)
	((member name '("NatPlus" "IntPlus" "RatPlus" "RealPlus"))
	 (or (and (synt-neg? (car args)) (synt-npos? (cadr args)))
	     (and (synt-npos? (car args)) (synt-neg? (cadr args)))))
	((member name '("NatTimes" "IntTimes" "RatTimes" "RealTimes"))
	 (or (and (synt-pos? (car args)) (synt-neg? (cadr args)))
	     (and (synt-neg? (car args)) (synt-pos? (cadr args)))))
	((member name '("RatConstr"))
	 (synt-neg? (car args)))
	((member name '("RealConstr"))
	 (and (term-in-abst-form? (car args))
	      (let ((var (term-in-abst-form-to-var (car args)))
		    (kernel (term-in-abst-form-to-kernel (car args))))
		(and (not (member var (term-to-free kernel)))
		     (synt-neg? kernel)))))
	(else #f))))))

(define (synt-npos? term)
  (let ((op (term-in-app-form-to-final-op term))
	(args (term-in-app-form-to-args term))
	(type (term-to-type term)))
    (and
     (alg-form? type)
     (term-in-const-form? op)
     (let* ((const (term-in-const-form-to-const op))
	    (name (const-to-name const)))
       (cond
	((member name '("Zero" "IntZero" "IntNeg")) #t)
	((member name '("NatPlus" "IntPlus" "RatPlus" "RealPlus"))
	 (and (synt-npos? (car args)) (synt-npos? (cadr args))))
	((member name '("IntTimes" "RatTimes" "RealTimes"))
	 (or (and (synt-npos? (car args) (synt-nneg? (cadr args))))
	     (and (synt-nneg? (car args) (synt-npos? (cadr args))))))
	((member name '("RatConstr"))
	 (synt-npos? (car args)))
	((member name '("RealConstr"))
	 (and (term-in-abst-form? (car args))
	      (let ((var (term-in-abst-form-to-var (car args)))
		    (kernel (term-in-abst-form-to-kernel (car args))))
		(and (not (member var (term-to-free kernel)))
		     (synt-npos? kernel)))))
	(else #f))))))

; (remove-nat-tokens) removes all tokens added in nat.scm and from
; DISPLAY-FUNCTIONS all items (nat proc).  The reason is that they
; will be reintroduced here, with a different assigned procedure.

(remove-nat-tokens)

; The functions make-numeric-term (used by the parser) and
; is-numeric-term?, numeric-term-to-number (used by term-to-expr and
; token-tree-to-string) take pos as default.

(set! NAT-NUMBERS #f)

(define TOKEN-AND-TYPES-TO-NAME-ALIST '())

(define (token-and-types-to-name token types)
  (let ((info (assoc token TOKEN-AND-TYPES-TO-NAME-ALIST)))
    (if info
        (let ((info1 (assoc types (cadr info))))
          (if info1
	      (cadr info1)
	      (apply myerror
		     (append (list "token-and-types-to-name" "token"
				   token "not defined for types")
			     types))))
	(myerror "token-and-types-to-name" "not an overloaded token" token))))

(define (token-and-type-to-name token type)
  (token-and-types-to-name token (list type)))

(define (add-token-and-types-to-name token types name)
  (let ((info (assoc token TOKEN-AND-TYPES-TO-NAME-ALIST)))
    (if info
	(set! TOKEN-AND-TYPES-TO-NAME-ALIST
	      (map (lambda (item)
		     (if (equal? (car item) token)
			 (list token (cons (list types name) (cadr item)))
			 item))
		   TOKEN-AND-TYPES-TO-NAME-ALIST))
	(set! TOKEN-AND-TYPES-TO-NAME-ALIST
	      (cons (list token (list (list types name)))
		    TOKEN-AND-TYPES-TO-NAME-ALIST)))))

(define (add-token-and-type-to-name token type name)
  (add-token-and-types-to-name token (list type) name))


; 1. Positive, Natural, Integer, Rational, Real and Complex Numbers
; =================================================================

; We want to overload operators like +,*,/, <=,<, and automatically
; raise the type of arguments when reading.  For instance, + should
; take its arguments, compute the lub rho of their types, raise the
; type of both arguments to type rho, apply RhoPlus to the results.

; A special situation occurs with exponentiation **: 2**3 is pos, and
; 2** -3 is rat.  We need both types to determine the value type.

; Moreover, a number should be displayed at the lowest possible level.

(add-alg "pos" '("One" "pos") '("SZero" "pos=>pos") '("SOne" "pos=>pos"))

; An integer is either positive or zero or negative.

(add-alg
 "int" '("IntPos" "pos=>int") '("IntZero" "int") '("IntNeg" "pos=>int"))

; make-numeric-term-wrt-pos produces an int object for 0, and a pos
; object for a positive integer.

(define (make-numeric-term-wrt-pos n) 
  (cond ((zero? n) (make-term-in-const-form (constr-name-to-constr "IntZero")))
	((= n 1) (pt "One"))
	((even? n) (make-term-in-app-form
		    (make-term-in-const-form (constr-name-to-constr "SZero"))
		    (make-numeric-term-wrt-pos (/ n 2))))
	((odd? n) (make-term-in-app-form
		   (make-term-in-const-form (constr-name-to-constr "SOne"))
		   (make-numeric-term-wrt-pos (/ (- n 1) 2))))
	(else
	 (myerror "make-numeric-term-wrt-pos" "natural number expected" n))))

(define make-numeric-term
  (if NAT-NUMBERS
      make-numeric-term-wrt-nat
      make-numeric-term-wrt-pos))

(define is-numeric-term?
  (if NAT-NUMBERS
      is-numeric-term-wrt-nat?
      is-numeric-term-wrt-pos?))

(define numeric-term-to-number
  (if NAT-NUMBERS
      numeric-term-wrt-nat-to-number
      numeric-term-wrt-pos-to-number))

; We postpone introduction of + etc, and first introduce the types rat
; of rationals, real of reals and cpx of complex numbers.  A rational
; is a pair of an integer and a positive number.

; Comparison with the treatment of constructive analysis in Nijmegen
; C-CoRN.  They want to be as general as possible, and for instance
; derive properties of the rationals by instantiation of general field
; facts.  However, when one wants to use proofs for program extraction
; and development, it seems better to have a more direct approach,
; which allows to take care of the underlying data structures.

(add-var-name "p" "q" (py "pos"))
(add-var-name  "k" "l" "i" "j" (py "int"))

(add-token
 "IntN"
 'prefix-op
 (lambda (x) (mk-term-in-app-form (pt "IntNeg") x)))

(add-token
 "IntP"
 'prefix-op
 (lambda (x) (mk-term-in-app-form (pt "IntPos") x)))

(add-display
 (py "int")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (= 1 (length args)))
	 (let ((name (const-to-name (term-in-const-form-to-const op))))
	   (cond
	    ((string=? name "IntNeg")
	     (list 'prefix-op "IntN" (term-to-token-tree (car args))))
	    ((string=? name "IntPos")
	     (term-to-token-tree (car args)))
; added 2007-09-05
	    ((string=? name "NatToInt")
	     (term-to-token-tree (car args)))
	    (else #f)))
	 #f))))

; 2004-09-03 To use external code in a pconst, we provide tests for
; numeral values and conversion operations from numerals values to
; numbers, for pos, nat and int

(define (pos-numeral-value? value)
  (and (nbe-constr-value? value)
       (let* ((name (nbe-constr-value-to-name value))
	      (args (nbe-constr-value-to-args value))
	      (vals (map nbe-object-to-value args)))
	 (or (string=? "One" name)
	     (and (or (string=? "SZero" name) (string=? "SOne" name))
		  (pair? vals)
		  (pos-numeral-value? (car vals)))))))

(define (pos-numeral-value-to-number value)
  (let* ((name (nbe-constr-value-to-name value))
	 (args (nbe-constr-value-to-args value))
	 (vals (map nbe-object-to-value args)))
    (if (string=? "One" name)
	1
	(let ((prev (pos-numeral-value-to-number (car vals))))
	  (if (string=? "SZero" name) (* 2 prev) (+ (* 2 prev) 1))))))

(define (nat-numeral-value? value)
  (and (nbe-constr-value? value)
       (let* ((name (nbe-constr-value-to-name value))
	      (args (nbe-constr-value-to-args value))
	      (vals (map nbe-object-to-value args)))
	 (or (string=? "Zero" name)
	     (and (string=? "Succ" name)
		  (pair? vals)
		  (nat-numeral-value? (car vals)))))))

(define (nat-numeral-value-to-number value)
  (let* ((name (nbe-constr-value-to-name value))
	 (args (nbe-constr-value-to-args value))
	 (vals (map nbe-object-to-value args)))
    (if (string=? "Zero" name)
	1
	(+ 1 (nat-numeral-value-to-number (car vals))))))

; Instead of the converse use pt.

(define (int-numeral-value? value)
  (and (nbe-constr-value? value)
       (let* ((name (nbe-constr-value-to-name value))
	      (args (nbe-constr-value-to-args value))
	      (vals (map nbe-object-to-value args)))
	 (or (and (string=? "IntPos" name)
		  (pos-numeral-value? (car vals)))
	     (string=? "IntZero" name)
	     (and (string=? "IntNeg" name)
		  (pos-numeral-value? (car vals)))))))

(define (int-numeral-value-to-number value)
  (let* ((name (nbe-constr-value-to-name value))
	 (args (nbe-constr-value-to-args value))
	 (vals (map nbe-object-to-value args)))
    (cond
     ((string=? "IntNeg" name) (- (pos-numeral-value-to-number (car vals))))
     ((string=? "IntZero" name) 0)
     ((string=? "IntPos" name) (pos-numeral-value-to-number (car vals)))
     (else (myerror "int-numeral-value-to-number" "unexpected arg" value)))))


; We also introduce the rationals.  A rational is a pair i#p of an
; integer i and a positive natural number p, interpreted as i/p.

(add-alg "rat" '("RatConstr" "int=>pos=>rat"))
(add-var-name "a" "b" "c" "d" (py "rat"))

(add-token
 "#"
 'pair-op
 (lambda (x y)
   (mk-term-in-app-form 
    (make-term-in-const-form (constr-name-to-constr "RatConstr"))
    x y)))

(add-display
 (py "rat")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "RatConstr"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (if (and (term-in-const-form? (cadr args))
		  (string=? "One" (const-to-name
				   (term-in-const-form-to-const (cadr args)))))
	     (term-to-token-tree (car args))
	     (list 'pair-op "#"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args))))
	 #f))))


; We now introduce the reals.  A real is a pair of a Cauchy sequence
; of rationals and a modulus.  We view real as a data type (i.e., no
; properties), and within this data type inductively define the
; predicate Real x, meaning that x is a (proper) real.

(add-alg "real" (list "RealConstr" "(nat=>rat)=>(int=>nat)=>real"))

(add-var-name "as" "bs" "cs" "ds" (py "nat=>rat"))
(add-var-name "M" "N" (py "int=>nat"))
(add-var-name "x" "y" (py "real"))

; To conveniently access the two fields of a real, we provide seq and
; mod as informative names to be used (postfix) in display strings.

(add-program-constant "RealSeq" (py "real=>nat=>rat") t-deg-one 'const 1)

(add-token
 "seq"
 'postfix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "RealSeq"))
    x)))

(add-display
 (py "nat=>rat")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "RealSeq"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 1 (length args)))
	 (let ((arg (car args)))
	   (list
	    'postfix-op "seq"
	    (term-to-token-tree arg)))
	 #f))))
 
(add-computation-rule (pt "(RealConstr as M)seq") (pt "as"))

(add-program-constant "RealMod" (py "real=>int=>nat") t-deg-one 'const 1)

(add-token
 "mod"
 'postfix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "RealMod"))
    x)))

(add-display
 (py "int=>nat")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "RealMod"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 1 (length args)))
	 (let ((arg (car args)))
	   (list
	    'postfix-op "mod"
	    (term-to-token-tree arg)))
	 #f))))
 
(add-computation-rule (pt "(RealConstr as M)mod") (pt "M"))

; (pp (pt "x seq n"))
; (pp (pt "x mod k"))


; We also introduce the complex numbers.  A complex number is a pair
; x##y of two reals, interpreted as x+iy

(add-alg "cpx" '("CpxConstr" "real=>real=>cpx"))
(add-var-name "z" (py "cpx"))

(add-token
 "##"
 'pair-op
 (lambda (x y)
   (mk-term-in-app-form 
    (make-term-in-const-form (constr-name-to-constr "CpxConstr"))
    x y)))

(add-display
 (py "cpx")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "CpxConstr"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "##"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))


; 2. Parsing and Display for Arithmetical Operations
; ==================================================

; We now come to some generalities concerning overloading and coercion.
; Requirements:
; - Internally every application is type correct
; - Displaying a term can lower its type.
; - Parsing (1) a term and (2) a new term obtained from it by lowering
;   the type of some of its subterms must always return the same result,
;   possibly up to lowering of its type.

; Possible problems with usage of terms as arguments of predicates:
; (P(3#1) is displayed as P 3, which is not type correct) or in lists:
; (3#1)::(1#2): is displayed as 3::(1#2): , which is not type correct.

; Solution: change make-term-in-app-form and make-predicate-formula.
; If the types do not fit, raise the types of the offending arguments.

(add-program-constant "PosToNat" (py "pos=>nat") t-deg-one)
(add-program-constant "NatToInt" (py "nat=>int") t-deg-one)

(define (add-item-to-algebra-edge-to-embed-term-alist
         alg1-name alg2-name embed-term)
  (set! ALGEBRA-EDGE-TO-EMBED-TERM-ALIST
        (cons (list (list (make-alg alg1-name) (make-alg alg2-name))
		    embed-term)
              ALGEBRA-EDGE-TO-EMBED-TERM-ALIST)))

; We want the path from "pos" to "int" going through "nat" to be in
; the association list AFTER the edge from "pos" to "int" because in
; this case the function "algebras-to-embedding" choose the edge and
; not the path.

(add-item-to-algebra-edge-to-embed-term-alist
 "pos" "nat"
 (let ((var (make-var (make-alg "pos") -1 t-deg-one "")))
   (make-term-in-abst-form
    var (make-term-in-app-form
         (make-term-in-const-form
          (pconst-name-to-pconst "PosToNat"))
         (make-term-in-var-form var)))))

(add-item-to-algebra-edge-to-embed-term-alist
 "nat" "int"
 (let ((var (make-var (make-alg "nat") -1 t-deg-one "")))
   (make-term-in-abst-form
    var (make-term-in-app-form
         (make-term-in-const-form
          (pconst-name-to-pconst "NatToInt"))
         (make-term-in-var-form var)))))

(add-item-to-algebra-edge-to-embed-term-alist
 "pos" "int"
 (let ((var (make-var (make-alg "pos") -1 t-deg-one "")))
   (make-term-in-abst-form
    var (make-term-in-app-form
         (make-term-in-const-form
          (constr-name-to-constr "IntPos"))
         (make-term-in-var-form var)))))

(add-item-to-algebra-edge-to-embed-term-alist
 "int" "rat"
 (let ((var (make-var (make-alg "int") -1 t-deg-one "")))
   (make-term-in-abst-form
    var (mk-term-in-app-form
         (make-term-in-const-form
          (constr-name-to-constr "RatConstr"))
         (make-term-in-var-form var)
         (make-term-in-const-form
          (constr-name-to-constr "One"))))))

(add-item-to-algebra-edge-to-embed-term-alist
 "rat" "real"
 (let ((var (make-var (make-alg "rat") -1 t-deg-one ""))
       (n (make-var (make-alg "nat") -1 t-deg-one ""))
       (k (make-var (make-alg "int") -1 t-deg-one "")))
   (make-term-in-abst-form
    var (mk-term-in-app-form
         (make-term-in-const-form
          (constr-name-to-constr "RealConstr"))
         (make-term-in-abst-form ;constant Cauchy sequence
          n (make-term-in-var-form var))
         (make-term-in-abst-form ;Zero modulus
          k (make-term-in-const-form
             (constr-name-to-constr "Zero")))))))

(add-item-to-algebra-edge-to-embed-term-alist
 "real" "cpx"
 (let ((var (make-var (make-alg "real") -1 t-deg-one ""))
       (n (make-var (make-alg "nat") -1 t-deg-one ""))
       (k (make-var (make-alg "int") -1 t-deg-one "")))
   (make-term-in-abst-form
    var (mk-term-in-app-form
         (make-term-in-const-form
          (constr-name-to-constr "CpxConstr"))
         (make-term-in-var-form var)
         (mk-term-in-app-form
          (make-term-in-const-form
           (constr-name-to-constr "RealConstr"))
          (make-term-in-abst-form ;Zero Cauchy sequence
           n (mk-term-in-app-form
              (make-term-in-const-form
               (constr-name-to-constr "RatConstr"))
              (make-term-in-const-form
               (constr-name-to-constr "IntZero"))
              (make-term-in-const-form
               (constr-name-to-constr "One"))))
          (make-term-in-abst-form ;Zero modulus
           k (make-term-in-const-form
              (constr-name-to-constr "Zero"))))))))

; (alg-le? (make-alg "pos") (make-alg "int"))
; (alg-le? (make-alg "pos") (make-alg "nat"))
; (alg-le? (make-alg "nat") (make-alg "pos"))
; (alg-le? (make-alg "nat") (make-alg "int"))
; (alg-le? (make-alg "pos") (make-alg "rat"))
; (alg-le? (make-alg "rat") (make-alg "pos"))
; (alg-le? (make-alg "rat") (make-alg "real"))
; (alg-le? (make-alg "real") (make-alg "cpx"))

(add-program-constant "S" (py "pos=>pos") t-deg-one)

(add-program-constant "PosPred" (py "pos=>pos") t-deg-one)
(add-program-constant "PosHalf" (py "pos=>pos") t-deg-one)

; Added 2007-02-12
(add-program-constant "IntS" (py "int=>int") t-deg-one)
(add-program-constant "IntPred" (py "int=>int") t-deg-one)

; We define an overloaded addition.

(add-program-constant "PosPlus" (py "pos=>pos=>pos") t-deg-one)
(add-program-constant "IntPlus" (py "int=>int=>int") t-deg-one)
(add-program-constant "RatPlus" (py "rat=>rat=>rat") t-deg-one)
(add-program-constant "RealPlus" (py "real=>real=>real") t-deg-one)
(add-program-constant "CpxPlus" (py "cpx=>cpx=>cpx") t-deg-one)

; We define a cut-off subtraction for pos (as we have it for nat).

(add-program-constant "PosMinus" (py "pos=>pos=>pos") t-deg-one)

; We define an overloaded subtraction for int, rat, real and cpx.

(add-program-constant "IntMinus" (py "int=>int=>int") t-deg-one)
(add-program-constant "RatMinus" (py "rat=>rat=>rat") t-deg-one)
(add-program-constant "RealMinus" (py "real=>real=>real") t-deg-one)
(add-program-constant "CpxMinus" (py "cpx=>cpx=>cpx") t-deg-one)

; We define an overloaded multiplication.

(add-program-constant "PosTimes" (py "pos=>pos=>pos") t-deg-one)
(add-program-constant "IntTimes" (py "int=>int=>int") t-deg-one)
(add-program-constant "RatTimes" (py "rat=>rat=>rat") t-deg-one)
(add-program-constant "RealTimes" (py "real=>real=>real") t-deg-one)
(add-program-constant "CpxTimes" (py "cpx=>cpx=>cpx") t-deg-one)

; We define an overloaded division for rat, real and cpx. 

(add-program-constant "RatDiv" (py "rat=>rat=>rat") t-deg-zero)
(add-program-constant "RealDiv" (py "real=>real=>real") t-deg-zero)
(add-program-constant "CpxDiv" (py "cpx=>cpx=>cpx") t-deg-zero)

; We define the absolute value for int, rat, real and cpx.

(add-program-constant "IntAbs" (py "int=>nat") t-deg-one)
(add-program-constant "RatAbs" (py "rat=>rat") t-deg-one)
(add-program-constant "RealAbs" (py "real=>real") t-deg-one)
(add-program-constant "CpxAbs" (py "cpx=>cpx") t-deg-one)

; We define the exponential with values in pos, nat, int, rat, real and cpx.

(add-program-constant "PosExp" (py "pos=>nat=>pos") t-deg-one)
(add-program-constant "NatExp" (py "nat=>nat=>nat") t-deg-one)
(add-program-constant "IntExp" (py "int=>nat=>int") t-deg-one)
(add-program-constant "RatExp" (py "rat=>int=>rat") t-deg-zero)
(add-program-constant "RealExp" (py "real=>int=>real") t-deg-zero)
(add-program-constant "CpxExp" (py "cpx=>int=>cpx") t-deg-zero)

; We define the overloaded maximum function, written infix:

(add-program-constant "PosMax" (py "pos=>pos=>pos") t-deg-one)
(add-program-constant "IntMax" (py "int=>int=>int") t-deg-one)
(add-program-constant "RatMax" (py "rat=>rat=>rat") t-deg-one)
(add-program-constant "RealMax" (py "real=>real=>real") t-deg-one)
(add-program-constant "CpxMax" (py "cpx=>cpx=>cpx") t-deg-one)

; We define the overloaded minimum function, written infix:

(add-program-constant "PosMin" (py "pos=>pos=>pos") t-deg-one)
(add-program-constant "IntMin" (py "int=>int=>int") t-deg-one)
(add-program-constant "RatMin" (py "rat=>rat=>rat") t-deg-one)
(add-program-constant "RealMin" (py "real=>real=>real") t-deg-one)
(add-program-constant "CpxMin" (py "cpx=>cpx=>cpx") t-deg-one)

; We define the intended equivalence relations on rat.  It is
; decidable and hence can be introduced by a program constant.  We
; need an extra token == here, since the standard equality = for
; finitary algebras is available for rat as well.  Equality for reals
; is not decidable.  We view it as a defined predicate constant.  For
; convenience we use the setup of inductively defined predicates,
; although the "inductive" definition is in fact explicit, i.e., does
; not contain recursive calls,

(add-program-constant "RatEq" (py "rat=>rat=>boole") t-deg-one)

; We define an overloaded less-than relation.  It can be a program
; constant for pos, int and rat.  

(add-program-constant "PosLt" (py "pos=>pos=>boole") t-deg-one)
(add-program-constant "IntLt" (py "int=>int=>boole") t-deg-one)
(add-program-constant "RatLt" (py "rat=>rat=>boole") t-deg-one)

; We define an overloaded less-than-or-equal relation.

(add-program-constant "PosLe" (py "pos=>pos=>boole") t-deg-one)
(add-program-constant "IntLe" (py "int=>int=>boole") t-deg-one)
(add-program-constant "RatLe" (py "rat=>rat=>boole") t-deg-one)

; We define the tokens that are used by the parser

(define (make-term-creator token min-type-string)
  (lambda (x y)
    (let* ((type1 (term-to-type x))
	   (type2 (term-to-type y))
	   (min-type (py min-type-string))
	   (type (types-lub type1 type2 min-type))
	   (internal-name (token-and-type-to-name token type)))
      (mk-term-in-app-form
       (make-term-in-const-form (pconst-name-to-pconst internal-name))
       x y))))

(define (make-term-creator1 token min-type-string)
  (lambda (x)
    (let* ((min-type (py min-type-string))
           (type (types-lub (term-to-type x) min-type))
	   (internal-name (token-and-type-to-name token type)))
      (mk-term-in-app-form
       (make-term-in-const-form (pconst-name-to-pconst internal-name))
       x))))

(define (make-term-creator-exp token)
  (lambda (x y)
    (let* ((type1 (term-to-type x))
           (type2 (term-to-type y))
	   (internal-name (token-and-types-to-name token (list type1 type2))))
      (mk-term-in-app-form
       (make-term-in-const-form (pconst-name-to-pconst internal-name))
       x y))))

(add-token "+" 'add-op (make-term-creator "+" "pos"))
(add-token-and-type-to-name "+" (py "pos") "PosPlus")
(add-token-and-type-to-name "+" (py "nat") "NatPlus")
(add-token-and-type-to-name "+" (py "int") "IntPlus")
(add-token-and-type-to-name "+" (py "rat") "RatPlus")
(add-token-and-type-to-name "+" (py "real") "RealPlus")
(add-token-and-type-to-name "+" (py "cpx") "CpxPlus")

(add-token "--" 'add-op (make-term-creator "--" "pos"))
(add-token-and-type-to-name "--" (py "pos") "PosMinus")
(add-token-and-type-to-name "--" (py "nat") "NatMinus")

(add-token "-" 'add-op (make-term-creator "-" "int"))
(add-token-and-type-to-name "-" (py "int") "IntMinus")
(add-token-and-type-to-name "-" (py "rat") "RatMinus")
(add-token-and-type-to-name "-" (py "real") "RealMinus")
(add-token-and-type-to-name "-" (py "cpx") "CpxMinus")

(add-token "*" 'mul-op (make-term-creator "*" "pos"))
(add-token-and-type-to-name "*" (py "pos") "PosTimes")
(add-token-and-type-to-name "*" (py "nat") "NatTimes")
(add-token-and-type-to-name "*" (py "int") "IntTimes")
(add-token-and-type-to-name "*" (py "rat") "RatTimes")
(add-token-and-type-to-name "*" (py "real") "RealTimes")
(add-token-and-type-to-name "*" (py "cpx") "CpxTimes")

(add-token "/" 'mul-op (make-term-creator "/" "rat"))
(add-token-and-type-to-name "/" (py "rat") "RatDiv")
(add-token-and-type-to-name "/" (py "real") "RealDiv")
(add-token-and-type-to-name "/" (py "cpx") "CpxDiv")

(add-token "abs" 'prefix-op (make-term-creator1 "abs" "int"))
(add-token-and-type-to-name "abs" (py "int") "IntAbs")
(add-token-and-type-to-name "abs" (py "rat") "RatAbs")
(add-token-and-type-to-name "abs" (py "real") "RealAbs")
(add-token-and-type-to-name "abs" (py "cpx") "CpxAbs")

(add-token "**" 'exp-op (make-term-creator-exp "**"))

(add-token-and-types-to-name "**" (list (py "pos") (py "pos")) "PosExp")
(add-token-and-types-to-name "**" (list (py "pos") (py "nat")) "PosExp")

(add-token-and-types-to-name "**" (list (py "nat") (py "pos")) "NatExp")
(add-token-and-types-to-name "**" (list (py "nat") (py "nat")) "NatExp")

(add-token-and-types-to-name "**" (list (py "int") (py "pos")) "IntExp")
(add-token-and-types-to-name "**" (list (py "int") (py "nat")) "IntExp")

(add-token-and-types-to-name "**" (list (py "pos") (py "int")) "RatExp")
(add-token-and-types-to-name "**" (list (py "nat") (py "int")) "RatExp")
(add-token-and-types-to-name "**" (list (py "int") (py "int")) "RatExp")
(add-token-and-types-to-name "**" (list (py "rat") (py "pos")) "RatExp")
(add-token-and-types-to-name "**" (list (py "rat") (py "nat")) "RatExp")
(add-token-and-types-to-name "**" (list (py "rat") (py "int")) "RatExp")

(add-token-and-types-to-name "**" (list (py "real") (py "pos")) "RealExp")
(add-token-and-types-to-name "**" (list (py "real") (py "nat")) "RealExp")
(add-token-and-types-to-name "**" (list (py "real") (py "int")) "RealExp")

(add-token-and-types-to-name "**" (list (py "cpx") (py "pos")) "CpxExp")
(add-token-and-types-to-name "**" (list (py "cpx") (py "nat")) "CpxExp")
(add-token-and-types-to-name "**" (list (py "cpx") (py "int")) "CpxExp")

; (1#2)**(IntN 1) has type rat, but (IntN 1)**(1#2) as type cpx.
; Hence generally we will need token-and-types-to-name for Exp.

(add-token "max" 'mul-op (make-term-creator "max" "pos"))
(add-token-and-type-to-name "max" (py "pos") "PosMax")
(add-token-and-type-to-name "max" (py "nat") "NatMax")
(add-token-and-type-to-name "max" (py "int") "IntMax")
(add-token-and-type-to-name "max" (py "rat") "RatMax")
(add-token-and-type-to-name "max" (py "real") "RealMax")

(add-token "min" 'mul-op (make-term-creator "min" "pos"))
(add-token-and-type-to-name "min" (py "pos") "PosMin")
(add-token-and-type-to-name "min" (py "nat") "NatMin")
(add-token-and-type-to-name "min" (py "int") "IntMin")
(add-token-and-type-to-name "min" (py "rat") "RatMin")
(add-token-and-type-to-name "min" (py "real") "RealMin")

(add-token "==" 'rel-op (make-term-creator "==" "rat"))
(add-token-and-type-to-name "==" (py "rat") "RatEq")

(add-token "<" 'rel-op (make-term-creator "<" "pos"))
(add-token-and-type-to-name "<" (py "pos") "PosLt")
(add-token-and-type-to-name "<" (py "nat") "NatLt")
(add-token-and-type-to-name "<" (py "int") "IntLt")
(add-token-and-type-to-name "<" (py "rat") "RatLt")

(add-token "<=" 'rel-op (make-term-creator "<=" "pos"))
(add-token-and-type-to-name "<=" (py "pos") "PosLe")
(add-token-and-type-to-name "<=" (py "nat") "NatLe")
(add-token-and-type-to-name "<=" (py "int") "IntLe")
(add-token-and-type-to-name "<=" (py "rat") "RatLe")

; (pp (pt "n+z"))
; (pp (pt "n<a"))
; (pp (pt "a**k"))
 
(define (make-display-creator name display-string token-type)
	 (lambda (x)
	   (let ((op (term-in-app-form-to-final-op x))
		 (args (term-in-app-form-to-args x)))
	     (if (and (term-in-const-form? op)
		      (string=? name (const-to-name
				      (term-in-const-form-to-const op)))
		      (= 2 (length args)))
		 (list token-type display-string
		       (term-to-token-tree (term-to-original (car args)))
		       (term-to-token-tree (term-to-original (cadr args))))
		 #f))))
(define (make-display-creator1 name display-string token-type)
	 (lambda (x)
	   (let ((op (term-in-app-form-to-final-op x))
		 (args (term-in-app-form-to-args x)))
	     (if (and (term-in-const-form? op)
		      (string=? name (const-to-name
				      (term-in-const-form-to-const op)))
		      (= 1 (length args)))
		 (list token-type display-string
		       (term-to-token-tree (term-to-original (car args))))
		 #f))))

(add-display (py "pos") (make-display-creator "PosPlus" "+" 'add-op))
(add-display (py "nat") (make-display-creator "NatPlus" "+" 'add-op))
(add-display (py "int") (make-display-creator "IntPlus" "+" 'add-op))
(add-display (py "rat") (make-display-creator "RatPlus" "+" 'add-op))
(add-display (py "real") (make-display-creator "RealPlus" "+" 'add-op))
(add-display (py "cpx") (make-display-creator "CpxPlus" "+" 'add-op))
(add-display (py "pos") (make-display-creator "PosMinus" "--" 'add-op))
(add-display (py "nat") (make-display-creator "NatMinus" "--" 'add-op))
(add-display (py "int") (make-display-creator "IntMinus" "-" 'add-op))
(add-display (py "rat") (make-display-creator "RatMinus" "-" 'add-op))
(add-display (py "real") (make-display-creator "RealMinus" "-" 'add-op))
(add-display (py "cpx") (make-display-creator "CpxMinus" "-" 'add-op))
(add-display (py "pos") (make-display-creator "PosTimes" "*" 'mul-op))
(add-display (py "nat") (make-display-creator "NatTimes" "*" 'mul-op))
(add-display (py "int") (make-display-creator "IntTimes" "*" 'mul-op))
(add-display (py "rat") (make-display-creator "RatTimes" "*" 'mul-op))
(add-display (py "real") (make-display-creator "RealTimes" "*" 'mul-op))
(add-display (py "cpx") (make-display-creator "CpxTimes" "*" 'mul-op))
(add-display (py "rat") (make-display-creator "RatDiv" "/" 'mul-op))
(add-display (py "real") (make-display-creator "RealDiv" "/" 'mul-op))
(add-display (py "cpx") (make-display-creator "CpxDiv" "/" 'mul-op))
(add-display (py "nat") (make-display-creator1 "IntAbs" "abs" 'prefix-op))
(add-display (py "int") (make-display-creator1 "IntAbs" "abs" 'prefix-op))
(add-display (py "rat") (make-display-creator1 "RatAbs" "abs" 'prefix-op))
(add-display (py "real") (make-display-creator1 "RealAbs" "abs" 'prefix-op))
(add-display (py "cpx") (make-display-creator1 "CpxAbs" "abs" 'prefix-op))
(add-display (py "pos") (make-display-creator "PosExp" "**" 'exp-op))
(add-display (py "nat") (make-display-creator "NatExp" "**" 'exp-op))
(add-display (py "int") (make-display-creator "IntExp" "**" 'exp-op))
(add-display (py "rat") (make-display-creator "RatExp" "**" 'exp-op))
(add-display (py "real") (make-display-creator "RealExp" "**" 'exp-op))
(add-display (py "cpx") (make-display-creator "CpxExp" "**" 'exp-op))
(add-display (py "pos") (make-display-creator "PosMax" "max" 'mul-op))
(add-display (py "nat") (make-display-creator "NatMax" "max" 'mul-op))
(add-display (py "int") (make-display-creator "IntMax" "max" 'mul-op))
(add-display (py "rat") (make-display-creator "RatMax" "max" 'mul-op))
(add-display (py "real") (make-display-creator "RealMax" "max" 'mul-op))
(add-display (py "pos") (make-display-creator "PosMin" "min" 'mul-op))
(add-display (py "nat") (make-display-creator "NatMin" "min" 'mul-op))
(add-display (py "int") (make-display-creator "IntMin" "min" 'mul-op))
(add-display (py "rat") (make-display-creator "RatMin" "min" 'mul-op))
(add-display (py "real") (make-display-creator "RealMin" "min" 'mul-op))
(add-display (py "boole") (make-display-creator "RatEq" "==" 'rel-op))

(add-display (py "boole") (make-display-creator "PosLt" "<" 'rel-op))
(add-display (py "boole") (make-display-creator "NatLt" "<" 'rel-op))
(add-display (py "boole") (make-display-creator "IntLt" "<" 'rel-op))
(add-display (py "boole") (make-display-creator "RatLt" "<" 'rel-op))
(add-display (py "boole") (make-display-creator "PosLe" "<=" 'rel-op))
(add-display (py "boole") (make-display-creator "NatLe" "<=" 'rel-op))
(add-display (py "boole") (make-display-creator "IntLe" "<=" 'rel-op))
(add-display (py "boole") (make-display-creator "RatLe" "<=" 'rel-op))

; (pp (pt "n<=i"))
; (pp (pt "n<a"))
; (pp (pt "n<m"))
; (pp (pt "n==m"))
; (pp (pt "i==m"))
; (pp (pt "i==a"))
; (pp (pt "n min m"))
; (pp (pt "a max i"))
; (pp (pt "a**i"))
; (pp (pt "abs i"))
; (pp (pt "2/3"))
; (pp (pt "a/z"))
; (pp (pt "k/z"))
; (pp (pt "k*z"))
; (pp (pt "k-z"))
; (pp (pt "p-n"))
; (pp (pt "p--n"))
; (pp (pt "(IntN p)+q"))
; (pp (pt "(IntN p)+x"))
; (pp (pt "(IntN p)+z"))
; (pp (pt "a+p"))
; (pp (pt "a+z"))
; (pp (pt "x+z"))

(add-display
 (py "real")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "RealConstr"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args))
	      (term-in-abst-form? (car args))
	      (not (member (term-in-abst-form-to-var (car args))
			   (term-to-free
			    (term-in-abst-form-to-kernel (car args))))))
	 (term-to-token-tree (term-to-original
			      (term-in-abst-form-to-kernel (car args))))
	 #f))))

; (pp (pt "(IntN p#q)+RealConstr([n]1)([k]7)"))

; We introduce an inductively defined predicate RealEq x y by the
; following clause.

; (pp (pt "abs(x seq(x mod(IntS k))-y seq(y mod(IntS k)))"))

; (pp (pt "1#2**k"))
; (pp (pf "abs(x seq(x mod(IntS k))-y seq(y mod(IntS k))) <= 1/2**k"))

(add-ids
 (list (list "RealEq" (make-arity (py "real") (py "real"))))
 '("allnc x,y(all k abs(x seq(x mod(IntS k))-y seq(y mod(IntS k)))<=1/2**k --> 
              RealEq x y)"))
; Notice that we cannot take = and use overloading, because the token
; = has token type rel-op and hence produces a term, not a predicate.

; predicate creator

(define (make-predicate-creator token min-type-string)
  (lambda (x y)
    (let* ((type1 (term-to-type x))
	   (type2 (term-to-type y))
	   (min-type (py min-type-string))
	   (type (types-lub type1 type2 min-type))
	   (internal-name (token-and-types-to-name token (list type))))
      (make-predicate-formula (make-idpredconst internal-name '() '()) x y))))

(add-token "===" 'pred-infix (make-predicate-creator "===" "real"))

(add-token-and-type-to-name "===" (py "real") "RealEq")

(add-idpredconst-display "RealEq" 'pred-infix "===")

#|
(define idpc
  (idpredconst-name-and-types-and-cterms-to-idpredconst "RealEq" '() '()))
|#

; There are no types, since the clauses do not contain type variables,
; and no cterms, since the clauses do not contain parameter predicate
; variables.

; (define aconst0 (number-and-idpredconst-to-intro-aconst 0 idpc))
; (pp (aconst-to-formula aconst0))
; all x,y(all k abs(x seq(x mod(IntS k))-y seq(y mod(IntS k)))<=1/2**k -> x===y)

; We now provide some comfort to work with the (general) introduction
; and elimination axioms for the inductively defined predicate RealEq.
; Recall that the (single) introduction axiom can be used in an
; interactive proof with the command (intro 0).

; "RealEqIntro"
(set-goal
 "all x,y(
       all k abs(x seq(x mod(IntS k))-y seq(y mod(IntS k)))<=1/2**k -> 
       x===y)")
(strip)
(intro 0)
(use 1)
(save "RealEqIntro")

; Recall also that (elim) expects a goal I(ts) -> A[ts].  Then the
; (strengthened) clauses are generated as new goals.

; RealEqElim
(set-goal
 "all x,y(x===y ->
          all k abs(x seq(x mod(IntS k))-y seq(y mod(IntS k)))<=1/2**k)")
(assume "x" "y")
(elim)
(search)
(save "RealEqElim")

; The following variant will be more useful, because its head will be
; more often of the form of a given goal.

; "RealEqElimVariant"
(set-goal
 "all as,M,bs,N(RealConstr as M===RealConstr bs N ->         
                all k abs(as(M(IntS k))-bs(N(IntS k)))<=1/2**k)")
(strip)
(use-with "RealEqElim"
	  (pt "RealConstr as M") (pt "RealConstr bs N") 1 (pt "k"))
(save "RealEqElimVariant")

; RealPos is a decidable property and hence can be given as a program
; constant.

(add-program-constant "RealPos" (py "real=>int=>boole") t-deg-one)

(add-display
 (make-alg "boole")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "RealPos"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (let ((arg1 (car args))
	       (arg2 (cadr args)))
	   (list
	    'appterm ""
	    (list
	     'appterm ""
	     (list 'const "RealPos")
	     (term-to-token-tree (term-to-original arg1)))
	    (term-to-token-tree (term-to-original arg2))))
	 #f))))

(add-computation-rule "RealPos(RealConstr as M)k" "1/2**k<=as(M(k+1))")

; RealLt is a decidable property and hence can be given as a program
; constant.

(add-program-constant "RealLt" (py "real=>real=>int=>boole") t-deg-one)

(add-display
 (make-alg "boole")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "RealLt"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 3 (length args)))
	 (let ((arg1 (car args))
	       (arg2 (cadr args))
	       (arg3 (caddr args)))
	   (list
	    'appterm ""
	    (list
	     'appterm ""
	     (list
	      'appterm ""
	      (list 'const "RealLt")
	      (term-to-token-tree (term-to-original arg1)))
	     (term-to-token-tree (term-to-original arg2)))
	    (term-to-token-tree (term-to-original arg3))))
	 #f))))

(add-computation-rule
 "RealLt(RealConstr as N)(RealConstr bs M)k"
 "RealPos(RealConstr bs N-RealConstr as M)k")


; Non-negative reals are defined inductively

(add-ids
 (list (list "RealNNeg" (make-arity (py "real"))))
 '("allnc x(all k 0<=x seq(x mod k)+1/2**k --> RealNNeg x)"))

; "RealNNegIntro"
(set-goal "all x(all k 0<=x seq(x mod k)+1/2**k -> RealNNeg x)")
(strip)
(intro 0)
(use 1)
(save "RealNNegIntro")

; "RealNNegElim"
(set-goal "all x(RealNNeg x -> all k 0<=x seq(x mod k)+1/2**k)")
(assume "x")
(elim)
(search)
(save "RealNNegElim")

; The following variant will be more useful, because its head will be
; more often of the form of a given goal.

; "RealNNegElimVariant"
(set-goal
 "all as,M(RealNNeg(RealConstr as M) -> all k 0<=as(M k)+1/2**k)")
(strip)
(use-with "RealNNegElim" (pt "RealConstr as M") 1 (pt "k"))
(save "RealNNegElimVariant")

; For reals less-than-or-equal-to is undecidable and hence must be
; treated as an inductively defined predicate.

(add-ids
 (list (list "RealLe" (make-arity (py "real") (py "real"))))
 '("allnc x,y(RealNNeg(y-x) --> RealLe x y)"))

; Notice that we cannot take <= and use overloading, because the token
; <= has token type rel-op and hence produces a term, not a predicate.

(add-token
 "<<="
 'pred-infix
 (lambda (x y)
   (make-predicate-formula (make-idpredconst "RealLe" '() '()) x y)))

(add-idpredconst-display "RealLe" 'pred-infix "<<=")

#|
(define idpc
  (idpredconst-name-and-types-and-cterms-to-idpredconst "RealLe" '() '()))
|#

; There are no types, since the clauses do not contain type variables,
; and no cterms, since the clauses do not contain parameter predicate
; variables.

; (define aconst0 (number-and-idpredconst-to-intro-aconst 0 idpc))
; (pp (aconst-to-formula aconst0))
; all x,y(RealNNeg(y-x) -> x<<=y)

; We now provide some comfort to work with the (general) introduction
; and elimination axioms for the inductively defined predicate RealLe.
; Recall that the (single) introduction axiom can be used in an
; interactive proof with the command (intro 0).

; "RealLeIntro"
(set-goal "all x,y(RealNNeg(y-x) -> x<<=y)")
(strip)
(intro 0)
(use 1)
(save "RealLeIntro")

; Recall also that (elim) expects a goal I(ts) -> A[ts].  Then the
; (strengthened) clauses are generated as new goals.

; "RealLeElim"
(set-goal "all x,y(x<<=y -> RealNNeg(y-x))")
(assume "x" "y")
(elim)
(search)
(save "RealLeElim")

; The following variant will be useful as well, when its head is of
; the form of a given goal.  However, the proof below assumes
;  (add-computation-rule
;   (pt "RealConstr as M-RealConstr bs N")
;   (pt "RealConstr([n]as n-bs n)([k]M(k+1)max N(k+1))"))
; which will only be added later.

; (set-goal
;  (pf "all as,M,bs,N.RealConstr as M<<=RealConstr bs N ->         
;                    RealNNeg(RealConstr([n]bs n-as n)([k]N(k+1)max M(k+1)))"))
; (strip)
; (use-with "RealLeElim" (pt "RealConstr as M") (pt "RealConstr bs N") 1)
; (save "RealLeElimVariant")


; 3. Arithmetic
; =============

(add-computation-rules
 "S One" "SZero One"
 "S(SZero pos)" "SOne pos"
 "S(SOne pos)" "SZero(S pos)")

(add-computation-rules
 "PosPred One" "One"
 "PosPred(SZero One)" "One"
 "PosPred(SZero(SZero pos))" "SOne(PosPred(SZero pos))"
 "PosPred(SZero(SOne pos))" "SOne(SZero pos)"
 "PosPred(SOne pos)" "SZero pos")

; (display-program-constants "PosPred")

(add-computation-rules
 "PosHalf One" "One"
 "PosHalf(SZero pos)" "pos"
 "PosHalf(SOne pos)" "pos")

; (display-program-constants "PosHalf")

(add-computation-rules
 "PosToNat One" "Succ Zero"
 "PosToNat(SZero pos)" "NatPlus(PosToNat pos)(PosToNat pos)"
 "PosToNat(SOne pos)" "Succ(PosToNat(SZero pos))")

(add-computation-rules
 "NatToInt Zero" "IntZero"
 "NatToInt(Succ nat)" "IntS(NatToInt nat)")

(add-computation-rules
 "pos1+One" "S pos1"
 "One+SZero pos1" "SOne pos1"
 "SZero pos1+SZero pos2" "SZero(pos1+pos2)"
 "SOne pos1+SZero pos2" "SOne(pos1+pos2)"
 "One+SOne pos1" "SZero(S pos1)"
 "SZero pos1+SOne pos2" "SOne(pos1+pos2)"
 "SOne pos1+SOne pos2" "SZero(S(pos1+pos2))")

; We derive some rewrite rules.  To ensure termination, we (1) decrease
; the sum of the lengths of summands, where the rhs counts more than
; the lhs.

(set-goal "all pos One+pos=S pos")
(cases)
(auto)
; Proof finished
(add-rewrite-rule "One+pos" "S pos")

(set-goal "all pos1,pos2 S pos1+pos2=S(pos1+pos2)")
(ind)
  (ind)
  (auto)
(assume "pos" "IHzero")
(ind)
  (auto)
(assume "pos" "IHone")
(ind)
(auto)
; Proof finished
(add-rewrite-rule "S pos1+pos2" "S(pos1+pos2)")

(set-goal "all pos1,pos2 pos1+S pos2=S(pos1+pos2)")
(ind)
  (cases)
(auto)
(assume "p" "IH1")
(cases)
  (auto)
(assume "p" "IH2")
(cases)
(auto)
; Proof finished
(add-rewrite-rule "pos1+S pos2" "S(pos1+pos2)")

; To prove "all pos1,pos2,pos3 pos1+(pos2+pos3)=pos1+pos2+pos3" by
; pos-induction seems to be difficult.  Solutions: (1) Using the rules
; just proved one can mimic the proof in nat.  This requires
; successor-induction for pos, which has to be proven before (see
; wwwpublic/seminars/prosemss04/sucind.scm).  (2) Another more general
; way out is to transfer the problem to nat via appropriate functions
; (see examples/ordinals/reflection_numbers_thms.scm) and then use
; associativity in nat.  - For the moment:

(add-rewrite-rule "pos1+(pos2+pos3)" "pos1+pos2+pos3")

; The following (former) rules are not used any more, because they
; increase the number of +'s.

; (add-rewrite-rule "pos1+SZero pos2" "pos1+pos2+pos2")
; (add-rewrite-rule "pos1+SOne pos2" "pos1+pos2+pos2+1")
; (add-rewrite-rule "SZero pos1+pos2" "pos1+pos1+pos2") ;no term. for 2+m
; (add-rewrite-rule "SOne pos1+pos2" "pos1+pos1+1+pos2"

; (display-program-constants "PosPlus")


; Rules for PosMinus:  They give correct results (only) if m<n.

(add-computation-rules
 "One--pos" "One"
 "SZero pos--One" "PosPred(SZero pos)"
 "SZero pos1--SZero pos2" "SZero(pos1--pos2)"
 "SZero pos1--SOne pos2" "PosPred(SZero(pos1--pos2))"
 "SOne pos--One" "SZero pos"
 "SOne pos1--SZero pos2" "SZero pos1--(SZero pos2--One)"
 "SOne pos1--SOne pos2" "SZero(pos1--pos2)")

; (display-program-constants "PosMinus")

; (pp (nt (pt "6--4")))
; (pp (nt (pt "66--44")))


; Rules for PosTimes:

(add-computation-rules
 "pos*One" "pos"
 "pos1*SZero pos2" "SZero(pos1*pos2)"
 "pos1*SOne pos2" "SZero(pos1*pos2)+pos1")

(set-goal "all pos One*pos=pos")
(ind)
(auto)
; Proof finished.
(add-rewrite-rule "One*pos" "pos")

(set-goal "all pos1,pos2 SZero pos1*pos2=SZero(pos1*pos2)")
(assume "pos1")
(ind)
  (auto)
(assume "pos2" "IHone")
(ng)
(simp "IHone")
(use "Truth-Axiom")
; Proof finished.
(add-rewrite-rule "SZero pos1*pos2" "SZero(pos1*pos2)")

; (set-goal "all pos1,pos2 SOne pos1*pos2=SZero(pos1*pos2)+pos2")
; Proof postponed.
(add-rewrite-rule "SOne pos1*pos2" "SZero(pos1*pos2)+pos2")
(add-rewrite-rule "pos1*(pos2*pos3)" "pos1*pos2*pos3")

; (display-program-constants "PosTimes")


; Rules for PosExp : pos=>nat=>pos

(add-computation-rules
 "pos**Zero" "One"
 "pos1**Succ nat2" "pos1**nat2*pos1")


; Rules for PosMax

(add-computation-rules
 "One max pos" "pos"
 "SZero pos max One" "SZero pos"
 "SZero pos1 max SZero pos2" "SZero(pos1 max pos2)"
 "SZero pos1 max SOne pos2"
 "[if (pos1<=pos2) (SOne pos2) (SZero pos1)]"
 "SOne pos max One" "SOne pos"
 "SOne pos1 max SZero pos2"
 "[if (pos2<=pos1) (SOne pos1) (SZero pos2)]"
 "SOne pos1 max SOne pos2" "SOne(pos1 max pos2)")

(add-rewrite-rule "pos max One" "pos")
(add-rewrite-rule "pos max pos" "pos")


; Rules for PosMin

(add-computation-rules
 "One min pos" "One"
 "SZero pos min One" "One"
 "SZero pos1 min SZero pos2" "SZero(pos1 min pos2)"
 "SZero pos1 min SOne pos2"
 "[if (pos1<=pos2) (SZero pos1) (SOne pos2)]"
 "SOne pos min One" "One"
 "SOne pos1 min SZero pos2"
 "[if (pos1<=pos2) (SZero pos2) (SOne pos1)]"
 "SOne pos1 min SOne pos2" "SOne(pos1 min pos2)")


; Rules for PosLt, PosLe

(add-computation-rules
 "pos<One" "False"
 "One<SZero pos" "True"
 "One<SOne pos" "True"
 "SZero pos1<SZero pos2" "pos1<pos2"
 "SZero pos1<SOne pos2" "pos1<=pos2"
 "SOne pos1<SZero pos2" "pos1<pos2"
 "SOne pos1<SOne pos2" "pos1<pos2")

(add-computation-rules
 "One<=pos" "True"
 "SZero pos<=One" "False"
 "SOne pos<=One" "False"
 "SZero pos1<=SZero pos2" "pos1<=pos2"
 "SZero pos1<=SOne pos2" "pos1<=pos2"
 "SOne pos1<=SZero pos2" "pos1<pos2"
 "SOne pos1<=SOne pos2" "pos1<=pos2")

(add-rewrite-rule "pos<pos" "False")
(add-rewrite-rule "pos<S pos" "True")
(add-rewrite-rule "S pos<pos" "False")
(add-rewrite-rule "pos1<pos1+pos2" "True")
(add-rewrite-rule "S pos1<S pos2" "pos1<pos2")
(add-rewrite-rule "One<S pos" "True")

(add-rewrite-rule "pos<=pos" "True")
(add-rewrite-rule "pos<=S pos" "True")
(add-rewrite-rule "S pos<=pos" "False")
(add-rewrite-rule "pos1<=pos1+pos2" "True")
(add-rewrite-rule "S pos1<=S pos2" "pos1<=pos2")
(add-rewrite-rule "S pos<=One" "False")


; Rules for NatExp : nat=>nat=>nat

(add-computation-rules
 "nat**Zero" "Succ Zero"
 "nat1**Succ nat2" "nat1**nat2*nat1")

(add-rewrite-rules
 "(PosToNat pos1)**nat2" "PosToNat(pos1**nat2)")


; Rules for IntS, IntPred

(add-computation-rules
 "IntS IntZero" "IntP One"
 "IntS(IntP pos)" "IntP(S pos)"
 "IntS(IntN One)" "IntZero"
 "IntS(IntN(SZero pos))" "IntN(PosPred(SZero pos))"
 "IntS(IntN(SOne pos))" "IntN(SZero pos)")

(add-rewrite-rule
 "IntS(int+IntN One)" "int")

(add-computation-rules
 "IntPred IntZero" "IntN One"
 "IntPred(IntN pos)" "IntN(S pos)"
 "IntPred(IntP One)" "IntZero"
 "IntPred(IntP(SZero pos))" "IntP(PosPred(SZero pos))"
 "IntPred(IntP(SOne pos))" "IntP(SZero pos)")

(add-rewrite-rule "IntPred(IntS i)" "i")
(add-rewrite-rule "IntS(IntPred i)" "i")


; Rules for IntPlus

(add-computation-rules
 "IntZero+i" "i"
 "IntP pos+IntZero" "IntP pos"
 "IntP pos1+IntP pos2" "IntP(pos1+pos2)"

 "IntP pos1+IntN pos2"
 "[if (pos1=pos2)
      IntZero
      [if (pos1<pos2) (IntN(pos2--pos1)) (IntP(pos1--pos2))]]"

 "IntN pos+IntZero" "IntN pos"

 "IntN pos1+IntP pos2"
 "[if (pos1=pos2)
      IntZero 
      [if (pos1<pos2) (IntP(pos2--pos1)) (IntN(pos1--pos2))]]"

 "IntN pos1+IntN pos2" "IntN(pos1+pos2)")

(add-rewrite-rule "i+IntZero" "i")
		      
; Added 2007-02-12
(add-rewrite-rule "i+One" "IntS i")
(add-rewrite-rule "i+IntP(SZero pos)" "i+IntP pos+IntP pos")
(add-rewrite-rule "i+IntP(SOne pos)" "IntS(i+IntP(SZero pos))")
(add-rewrite-rule "i+IntN(SZero pos)" "i+IntN pos+IntN pos")
(add-rewrite-rule "i+IntN(SOne pos)" "IntPred(i+IntN(SZero pos))")

(add-rewrite-rule "One+i" "IntS i")
(add-rewrite-rule "IntP(SZero pos)+i" "i+IntP pos+IntP pos")
(add-rewrite-rule "IntP(SOne pos)+i" "IntS(i+IntP(SZero pos))")
(add-rewrite-rule "IntN(SZero pos)+i" "i+IntN pos+IntN pos")
(add-rewrite-rule "IntN(SOne pos)+i" "IntPred(i+IntN(SZero pos))")

; Added 2007-02-13
(add-rewrite-rule "i1+(i2+i3)" "i1+i2+i3")
(add-rewrite-rule "IntS i+j" "IntS(i+j)")
(add-rewrite-rule "i+IntS j" "IntS(i+j)")


; Rules for IntMinus

(add-computation-rules
 "i-IntZero" "i"

 "IntP pos1-IntP pos2"
 "[if (pos1=pos2) 
      IntZero 
      [if (pos1<pos2) (IntN(pos2--pos1)) (IntP(pos1--pos2))]]"

 "IntP pos1-IntN pos2" "IntP(pos1+pos2)"
 "IntN pos1-IntP pos2" "IntN(pos1+pos2)"

 "IntN pos1-IntN pos2"
 "[if (pos1=pos2)
      IntZero 
      [if (pos1<pos2) (IntP(pos2--pos1)) (IntN(pos1--pos2))]]"
 
 "IntZero-IntN pos" "IntP pos"
 "IntZero-IntP pos" "IntN pos")
		      

; Rules for IntTimes

(add-computation-rules
 "IntZero*i" "IntZero"
 "IntP pos*IntZero" "IntZero"
 "IntP pos1*IntP pos2" "IntP(pos1*pos2)"
 "IntP pos1*IntN pos2" "IntN(pos1*pos2)"
 "IntN pos*IntZero" "IntZero"
 "IntN pos1*IntP pos2" "IntN(pos1*pos2)"
 "IntN pos1*IntN pos2" "IntP(pos1*pos2)")

(add-rewrite-rule "i*IntZero" "IntZero")
(add-rewrite-rule "i*IntP One" "i")
(add-rewrite-rule "IntP One*i" "i")
(add-rewrite-rule "int1*(int2*int3)" "int1*int2*int3")

; (pp (nt (pt "i+0")))
; So for integers we can use 0.  But beware:
; (pp (pf "i**0"))       ;i**0
; (pp (pf "i**IntZero")) ;i**IntZero


; Rules for IntAbs

(add-computation-rules
 "abs IntZero" "Zero"
 "abs IntP pos" "PosToNat pos"
 "abs IntN pos" "PosToNat pos")


; Rules for IntExp : int=>nat=>int

(add-computation-rules
 "int**Zero" "IntP One"
 "int1**Succ nat2" "int1**nat2*int1")

; Strategy: do computations at the lowest possible level.  Raise outside.

; We may assume that the given term is an original; otherwise use
; term-to-original first.  If it is say a sum, take the original of
; both components.  Let alg be the lub of their types.  If it is below
; the type of the given term, do the addition at level alg already
; (after embedding both components into alg via algebras-to-embedding)
; and then embed the result into the type of the given term.

(add-rewrite-rule "(IntP pos1)**nat2" "IntP(pos1**nat2)")


; Rules for IntMax

(add-computation-rules
 "IntZero max IntZero" "IntZero"
 "IntZero max IntP pos" "IntP pos"
 "IntZero max IntN pos" "IntZero"
 "IntP pos max IntZero" "IntP pos"
 "IntP pos1 max IntP pos2" "IntP(pos1 max pos2)"
 "IntP pos1 max IntN pos2" "IntP pos1"
 "IntN pos max IntZero" "IntZero"
 "IntN pos1 max IntP pos2" "IntP pos2"
 "IntN pos1 max IntN pos2" "IntN(pos1 min pos2)")


; Rules for IntMin

(add-computation-rules
 "IntZero min IntZero" "IntZero"
 "IntZero min IntP pos" "IntZero"
 "IntZero min IntN pos" "IntN pos"
 "IntP pos min IntZero" "IntZero"
 "IntP pos1 min IntP pos2" "IntP(pos1 min pos2)"
 "IntP pos1 min IntN pos2" "IntN pos2"
 "IntN pos min IntZero" "IntN pos"
 "IntN pos1 min IntP pos2" "IntN pos1"
 "IntN pos1 min IntN pos2" "IntN(pos1 max pos2)")


; Rules for IntLt

(add-computation-rules
 "IntZero<IntZero" "False"
 "IntZero<IntP pos" "True"
 "IntZero<IntN pos" "False"
 "IntP pos<IntZero" "False"
 "IntP pos1<IntP pos2" "pos1<pos2"
 "IntP pos1<IntN pos2" "False"
 "IntN pos<IntZero" "True"
 "IntN pos1<IntP pos2" "True"
 "IntN pos1<IntN pos2" "pos2<pos1")


; Rules for IntLe

(add-computation-rules
 "IntZero<=IntZero" "True"
 "IntZero<=IntP pos" "True"
 "IntZero<=IntN pos" "False"
 "IntP pos<=IntZero" "False"
 "IntP pos1<=IntP pos2" "pos1<=pos2"
 "IntP pos1<=IntN pos2" "False"
 "IntN pos<=IntZero" "True"
 "IntN pos1<=IntP pos2" "True"
 "IntN pos1<=IntN pos2" "pos1<=pos1")

(add-rewrite-rule "i<i" "False")
(add-rewrite-rule "i<i+pos" "True")

(add-rewrite-rule "i<=i" "True")
(add-rewrite-rule "i<=i+nat" "True")
(add-rewrite-rule "i<=i+pos" "True")
(add-rewrite-rule "i<=IntS i" "True")
(add-rewrite-rule "IntS i<=i" "False")


; Rules for RatPlus

(add-computation-rules
 "(i1#pos1)+(i2#pos2)" "i1*pos2+i2*pos1#pos1*pos2")

; 2007-02-13
; Added rules for RatPlus.  Goal: {1} Bring / out.  (2) Delete /.

(add-rewrite-rule "(a1/b1)+(a2/b2)" "(a1*b2+a2*b1)/(b1*b2)")
(add-rewrite-rule "a1+a2/b2" "(a1*b2+a2)/b2")
(add-rewrite-rule "a1/b1+a2" "(a1+a2*b1)/b1")

(add-rewrite-rule "(a1/b1)+(i2#pos2)" "(a1*pos2+i2*b1)/(b1*pos2)")
(add-rewrite-rule "(i1#pos1)+(a2/b2)" "(i1*b2+a2*pos1)/(pos1*b2)")
; The following leads to non-termination for a*b+1
; (add-rewrite-rule "a1+(i2#pos2)" "(a1*pos2+i2)/pos2")
; (add-rewrite-rule "(i1#pos1)+a2" "(i1+a2*pos1)/pos1")

; Added 1007-08-28

(add-rewrite-rule "a+(RatConstr IntZero One)" "a")
(add-rewrite-rule "(RatConstr IntZero One)+a" "a")
(add-rewrite-rule "a1+(a2+a3)" "a1+a2+a3")


; Rules for RatMinus

(add-computation-rules
 "(i1#pos1)-(i2#pos2)" "i1*pos2-i2*pos1#pos1*pos2")

(add-rewrite-rule "(a1/b1)-(a2/b2)" "(a1*b2-a2*b1)/(b1*b2)")
(add-rewrite-rule "a1-a2/b2" "(a1*b2-a2)/b2")
(add-rewrite-rule "a1/b1-a2" "(a1-a2*b1)/b1")

(add-rewrite-rule "(a1/b1)-(i2#pos2)" "(a1*pos2-i2*b1)/(b1*pos2)")
(add-rewrite-rule "(i1#pos1)-(a2/b2)" "(i1*b2-a2*pos1)/(pos1*b2)")
; (add-rewrite-rule "a1-(i2#pos2)" "(a1*pos2-i2)/pos2")
; (add-rewrite-rule "(i1#pos1)-a2" "(i1-a2*pos1)/pos1")

; Added 1007-08-28

(add-rewrite-rule "a-(RatConstr IntZero One)" "a")
(add-rewrite-rule "a-a" "RatConstr IntZero One")


; Rules for RatTimes

(add-computation-rules
 "(i1#pos1)*(i2#pos2)" "i1*i2#pos1*pos2")

(add-rewrite-rule "(a1/b1)*(a2/b2)" "(a1*a2)/(b1*b2)")
; (add-rewrite-rule "a1*(a2/b2)" "(a1*a2)/b2")
; (add-rewrite-rule "(a1/b1)*a2" "(a1*a2)/b1")

(add-rewrite-rule "(a1/b1)*(i2#pos2)" "(a1*i2)/(b1*pos2)")
(add-rewrite-rule "(i1#pos1)*(a2/b2)" "(i1*a2)/(pos1*b2)")
; (add-rewrite-rule "a1*(i2#pos2)" "(a1*i2)/pos2")
; (add-rewrite-rule "(i1#pos1)*a2" "(i1*a2)/pos1")

; Added 2007-02-26
(add-rewrite-rule "RatConstr(IntP One)One*a" "a")
(add-rewrite-rule "a*RatConstr(IntP One)One" "a")

; Added 2007-08-28

(add-rewrite-rule "a*(RatConstr IntZero One)" "RatConstr IntZero One")
(add-rewrite-rule "(RatConstr IntZero One)*a" "RatConstr IntZero One")
(add-rewrite-rule "a1*(a2*a3)" "a1*a2*a3")


; Rules for RatDiv

(add-computation-rules
 "(i1#pos1)/(IntP pos#pos2)" "(i1*pos2#pos*pos1)"
 "(i1#pos1)/(IntN pos#pos2)" "((IntZero-i1)*pos2#pos*pos1)")

(add-rewrite-rule "(a1/b1)/(a2/b2)" "(a1*b2)/(b1*a2)")


; Rules for RatAbs

(add-computation-rules
 "abs(IntZero#pos)" "IntZero#pos"
 "abs(IntP pos1#pos2)" "IntP pos1#pos2"
 "abs(IntN pos1#pos2)" "IntP pos1#pos2")


; Rules for RatExp : rat=>int=>rat

(add-computation-rules
 "(int1#pos2)**(IntP pos3)" "(int1**pos3)#(pos2**pos3)"

 "rat**IntZero" "IntP One#One"

 "((IntP pos1)#pos2)**(IntN pos3)" "IntP(pos2**pos3)#(pos1**pos3)"
 "((IntN pos1)#pos2)**(IntN pos3)" "(pos2#pos3)**((IntN pos1)**pos3)")

; Normal forms, which makes equally displayed terms equal.  Strategy:
; do computations at the lowest possible level.  Raise the type outside.

(add-rewrite-rules
 "rat**(IntP One)" "rat"
 "rat1**(IntS int2)" "rat1**int2*rat1"

 "((IntP pos1)#One)**(IntP pos2)" "IntP(pos1**pos2)#One"
 "((IntP pos1)#One)**(IntN pos2)" "IntP One#(pos1**pos2)"
 "((IntP pos1)#One)**(NatToInt nat2)" "IntP(pos1**nat2)#One"

 "((NatToInt nat1)#One)**(IntP pos2)" "NatToInt(nat1**pos2)#One"
 "((NatToInt nat1)#One)**(NatToInt nat2)" "NatToInt(nat1**nat2)#One"

 "((IntN pos1)#One)**(IntP pos2)" "IntN(pos1**pos2)#One"
 "((IntN pos1)#One)**(IntN pos2)" "IntN One#(pos1**pos2)"
 "((IntN pos1)#One)**(NatToInt nat2)" "IntN(pos1**nat2)#One"

 "(int1#One)**(IntP pos2)" "(int1**pos2)#One")


; Rules for RatMax

(add-computation-rules
 "(i1#pos1)max(i2#pos2)"
 "[if (i1*pos2<=i2*pos1) (i2#pos2) (i1#pos1)]")


; Rules for RatMin

(add-computation-rules
 "(i1#pos1)min(i2#pos2)"
 "[if (i1*pos2<=i2*pos1) (i1#pos1) (i2#pos2)]")


; Rules for RatLe

(add-computation-rules
 "(i1#pos1)<=(i2#pos2)" "i1*pos2<=i2*pos1")


; Rules for RatLt

(add-computation-rules
 "(i1#pos1)<(i2#pos2)" "i1*pos2<i2*pos1")

(add-rewrite-rule "a<a" "False")
(add-rewrite-rule "a<a+pos" "True")

(add-rewrite-rule "a<=a" "True")
(add-rewrite-rule "a<=a+pos" "True")
(add-rewrite-rule "a<=a+nat" "True")
(add-rewrite-rule "IntZero<=(IntN pos1#pos2)" "False")


; Rules for RatEq

(add-computation-rules
 "(i1#pos1)==(i2#pos2)" "i1*pos2=i2*pos1")

(add-rewrite-rule "a==a" "True")


; Rules for RealPlus

(add-computation-rule
 "RealConstr as M+RealConstr bs N"
 "RealConstr([n]as n+bs n)([k]M(k+1)max N(k+1))")

; Added 2007-08-29
(add-rewrite-rule
 "x+(RealConstr([n](RatConstr IntZero One))([k]Zero))" "x")
(add-rewrite-rule
 "(RealConstr([n](RatConstr IntZero One))([k]Zero))+x" "x")
(add-rewrite-rule "x1+(x2+x3)" "x1+x2+x3")


; Rules for RealMinus

(add-computation-rule
 "RealConstr as M-RealConstr bs N"
 "RealConstr([n]as n-bs n)([k]M(k+1)max N(k+1))")

; Added 2007-08-29
(add-rewrite-rule "x-(RealConstr([n](RatConstr IntZero One))([k]Zero))" "x")
(add-rewrite-rule "x-x" "RealConstr([n](RatConstr IntZero One))([k]Zero)")


; Rules for RealAbs

(add-computation-rule
 "abs(RealConstr as M)" "RealConstr([n]abs(as n))M")


; Rules for RealTimes.

(add-rewrite-rule
 "x*(RealConstr([n](RatConstr IntZero One))([k]Zero))"
 "RealConstr([n](RatConstr IntZero One))([k]Zero)")

(add-rewrite-rule
 "(RealConstr([n](RatConstr IntZero One))([k]Zero))*x"
 "RealConstr([n](RatConstr IntZero One))([k]Zero)")

(add-rewrite-rule
 "x*(RealConstr([n](RatConstr(IntP One)One))([k]Zero))" "x")

(add-rewrite-rule
 "(RealConstr([n](RatConstr(IntP One)One))([k]Zero))*x" "x")

(add-rewrite-rule "x1*(x2*x3)" "x1*x2*x3")


; Rules for RealExp : real=>int=>real

(add-computation-rules
 "real**(IntP One)" "real"
 "real1**(IntP(SZero pos2))" "(real1**(IntP pos2))*(real1**(IntP pos2))"
 "real1**(IntP(SOne pos2))" "(real1**(IntP(SZero pos2)))*real1"
 "real**IntZero" "RealConstr([n](RatConstr(IntPos One)One))([k]Zero)")

(add-rewrite-rules
 "(RealConstr([n]rat1)([k]Zero))**int2" "RealConstr([n]rat1**int2)([k]Zero)")


; 4.  Adding external code
; ========================

; We want to view RatPlus, RatMinus, RatTimes, RatDiv, RatLt, RatLe as
; program constants with external code, using add-external-code.  The
; external code - after evaluation and application to tsubst and the
; arguments - should give either the final value (e.g., the numeral
; for the sum) or else #f, in which case the rules are tried next on
; the arguments.

(define ratplus-code
  '(lambda (tsubst objs)
     (let ((val1 (nbe-object-to-value (car objs)))
	   (val2 (nbe-object-to-value (cadr objs))))
       (and (nbe-constr-value? val1) (nbe-constr-value? val2)
	    (let* ((args1 (nbe-constr-value-to-args val1))
		   (args2 (nbe-constr-value-to-args val2))
		   (vals1 (map nbe-object-to-value args1))
		   (vals2 (map nbe-object-to-value args2)))
	      (and (int-numeral-value? (car vals1))
		   (pos-numeral-value? (cadr vals1))
		   (int-numeral-value? (car vals2))
		   (pos-numeral-value? (cadr vals2))
		   (let* ((numer1 (int-numeral-value-to-number (car vals1)))
			  (denom1 (pos-numeral-value-to-number (cadr vals1)))
			  (numer2 (int-numeral-value-to-number (car vals2)))
			  (denom2 (pos-numeral-value-to-number (cadr vals2)))
			  (sum (+ (/ numer1 denom1) (/ numer2 denom2)))
			  (numer (numerator sum))
			  (denom (denominator sum))
			  (numer-term (int-to-int-term numer))
			  (denom-term (make-numeric-term denom))
			  (constr (constr-name-to-constr "RatConstr"))
			  (term (mk-term-in-app-form
				 (make-term-in-const-form constr)
				 numer-term denom-term)))
		     (nbe-term-to-object
		      term (nbe-make-bindings '() '())))))))))

(define ratminus-code
  '(lambda (tsubst objs)
     (let ((val1 (nbe-object-to-value (car objs)))
	   (val2 (nbe-object-to-value (cadr objs))))
       (and (nbe-constr-value? val1) (nbe-constr-value? val2)
	    (let* ((args1 (nbe-constr-value-to-args val1))
		   (args2 (nbe-constr-value-to-args val2))
		   (vals1 (map nbe-object-to-value args1))
		   (vals2 (map nbe-object-to-value args2)))
	      (and (int-numeral-value? (car vals1))
		   (pos-numeral-value? (cadr vals1))
		   (int-numeral-value? (car vals2))
		   (pos-numeral-value? (cadr vals2))
		   (let* ((numer1 (int-numeral-value-to-number (car vals1)))
			  (denom1 (pos-numeral-value-to-number (cadr vals1)))
			  (numer2 (int-numeral-value-to-number (car vals2)))
			  (denom2 (pos-numeral-value-to-number (cadr vals2)))
			  (diff (- (/ numer1 denom1) (/ numer2 denom2)))
			  (numer (numerator diff))
			  (denom (denominator diff))
			  (numer-term (int-to-int-term numer))
			  (denom-term (make-numeric-term denom))
			  (constr (constr-name-to-constr "RatConstr"))
			  (term (mk-term-in-app-form
				 (make-term-in-const-form constr)
				 numer-term denom-term)))
		     (nbe-term-to-object
		      term (nbe-make-bindings '() '())))))))))

(define rattimes-code
  '(lambda (tsubst objs)
     (let ((val1 (nbe-object-to-value (car objs)))
	   (val2 (nbe-object-to-value (cadr objs))))
       (and (nbe-constr-value? val1) (nbe-constr-value? val2)
	    (let* ((args1 (nbe-constr-value-to-args val1))
		   (args2 (nbe-constr-value-to-args val2))
		   (vals1 (map nbe-object-to-value args1))
		   (vals2 (map nbe-object-to-value args2)))
	      (and (int-numeral-value? (car vals1))
		   (pos-numeral-value? (cadr vals1))
		   (int-numeral-value? (car vals2))
		   (pos-numeral-value? (cadr vals2))
		   (let* ((numer1 (int-numeral-value-to-number (car vals1)))
			  (denom1 (pos-numeral-value-to-number (cadr vals1)))
			  (numer2 (int-numeral-value-to-number (car vals2)))
			  (denom2 (pos-numeral-value-to-number (cadr vals2)))
			  (prod (* (/ numer1 denom1) (/ numer2 denom2)))
			  (numer (numerator prod))
			  (denom (denominator prod))
			  (numer-term (int-to-int-term numer))
			  (denom-term (make-numeric-term denom))
			  (constr (constr-name-to-constr "RatConstr"))
			  (term (mk-term-in-app-form
				 (make-term-in-const-form constr)
				 numer-term denom-term)))
		     (nbe-term-to-object
		      term (nbe-make-bindings '() '())))))))))

(define ratdiv-code
  '(lambda (tsubst objs)
     (let ((val1 (nbe-object-to-value (car objs)))
	   (val2 (nbe-object-to-value (cadr objs))))
       (and (nbe-constr-value? val1) (nbe-constr-value? val2)
	    (let* ((args1 (nbe-constr-value-to-args val1))
		   (args2 (nbe-constr-value-to-args val2))
		   (vals1 (map nbe-object-to-value args1))
		   (vals2 (map nbe-object-to-value args2)))
	      (and (int-numeral-value? (car vals1))
		   (pos-numeral-value? (cadr vals1))
		   (int-numeral-value? (car vals2))
		   (pos-numeral-value? (cadr vals2))
		   (let* ((numer1 (int-numeral-value-to-number (car vals1)))
			  (denom1 (pos-numeral-value-to-number (cadr vals1)))
			  (numer2 (int-numeral-value-to-number (car vals2)))
			  (denom2 (pos-numeral-value-to-number (cadr vals2)))
			  (quot (/ (/ numer1 denom1) (/ numer2 denom2)))
			  (numer (numerator quot))
			  (denom (denominator quot))
			  (numer-term (int-to-int-term numer))
			  (denom-term (make-numeric-term denom))
			  (constr (constr-name-to-constr "RatConstr"))
			  (term (mk-term-in-app-form
				 (make-term-in-const-form constr)
				 numer-term denom-term)))
		     (nbe-term-to-object
		      term (nbe-make-bindings '() '())))))))))

(define ratlt-code
  '(lambda (tsubst objs)
     (let ((val1 (nbe-object-to-value (car objs)))
	   (val2 (nbe-object-to-value (cadr objs))))
       (and (nbe-constr-value? val1) (nbe-constr-value? val2)
	    (let* ((args1 (nbe-constr-value-to-args val1))
		   (args2 (nbe-constr-value-to-args val2))
		   (vals1 (map nbe-object-to-value args1))
		   (vals2 (map nbe-object-to-value args2)))
	      (and (int-numeral-value? (car vals1))
		   (pos-numeral-value? (cadr vals1))
		   (int-numeral-value? (car vals2))
		   (pos-numeral-value? (cadr vals2))
		   (let* ((numer1 (int-numeral-value-to-number (car vals1)))
			  (denom1 (pos-numeral-value-to-number (cadr vals1)))
			  (numer2 (int-numeral-value-to-number (car vals2)))
			  (denom2 (pos-numeral-value-to-number (cadr vals2)))
			  (res (< (/ numer1 denom1) (/ numer2 denom2)))
			  (const (if res true-const false-const))
			  (term (make-term-in-const-form const)))
		     (nbe-term-to-object
		      term (nbe-make-bindings '() '())))))))))

(define ratle-code
  '(lambda (tsubst objs)
     (let ((val1 (nbe-object-to-value (car objs)))
	   (val2 (nbe-object-to-value (cadr objs))))
       (and (nbe-constr-value? val1) (nbe-constr-value? val2)
	    (let* ((args1 (nbe-constr-value-to-args val1))
		   (args2 (nbe-constr-value-to-args val2))
		   (vals1 (map nbe-object-to-value args1))
		   (vals2 (map nbe-object-to-value args2)))
	      (and (int-numeral-value? (car vals1))
		   (pos-numeral-value? (cadr vals1))
		   (int-numeral-value? (car vals2))
		   (pos-numeral-value? (cadr vals2))
		   (let* ((numer1 (int-numeral-value-to-number (car vals1)))
			  (denom1 (pos-numeral-value-to-number (cadr vals1)))
			  (numer2 (int-numeral-value-to-number (car vals2)))
			  (denom2 (pos-numeral-value-to-number (cadr vals2)))
			  (res (<= (/ numer1 denom1) (/ numer2 denom2)))
			  (const (if res true-const false-const))
			  (term (make-term-in-const-form const)))
		     (nbe-term-to-object
		      term (nbe-make-bindings '() '())))))))))

(add-external-code "RatPlus" ratplus-code)
(add-external-code "RatMinus" ratminus-code)
(add-external-code "RatTimes" rattimes-code)
(add-external-code "RatDiv" ratdiv-code)
(add-external-code "RatLt" ratlt-code)
(add-external-code "RatLe" ratle-code)

