; $Id: reflection_alpha.scm 2156 2008-01-25 13:25:12Z schimans $

; Reflection for Semi-Rings, Rings and Fields


; *****
; TODO:
; - Add a check of the axioms and terms in (prepare-simp-...)
; - Complete proofs, difficulty: dependent rewrite-rules
; - During simp-field, generate side conditions for the denominator
;     (like it was done in reflection_rationals.scm)
; - Extend reflection by handling explicitely powers of 2
;     (add a constructor exp2 and extend the normal form)
; - Extend reflection by simplification with user-defined equalities
;   which need to satisfy compatibility for the predicate or boolean
;   valued function in the recent goal
;     (needed for rat, real, etc. where one does not have a unique
;      representation of 0,1)
; - Replace all global assumptions by proved lemmata in interfaces
;   for nat, int
; - Extension to constant integer exponents

; *****


; This file should be loaded at the beginning of your session.

; It is well-known that reflection can be used in a theorem prover to
; solve equations in e.g. rings or fields. Here reflection is used in
; a more general way.

; With reflection one can simplify terms for arbitrary semi-rings
; (e.g. ring without the axiom of existence of the negative element),
; rings and fields. A term is transferred to an expression in the
; abstraction level, where we only have constructors for a variable, for
; addition, multiplication, exponentiation. In case of a ring, we have 
; additionally subtraction, and in case of a field, we have division on top.
; This abstraction of terms allows syntactic analyzation of those terms.
; After normalizing a term, we can evaluate it back to the (semi-)ring or
; field.

; Let M be the transfer function (written in Scheme, M stands for
; metaification), Eval the evaluation function, nf the normalizing function
; and let t be a term.
; Then we can prove the following theorem:
;    all t. Equal (Eval(nf(M(t)))) (Eval(M(t)))

; Note that we do not require a decidable equality in our (semi-)ring or
; field. However in the abstraction level we require to have a decidable
; equality.

; With the above theorem we allow to simplify the following formulas:
;    f(t,s)
; where f is a boolean valued function and t, s terms.
; The new goal is then f(t',s'), with t',s' the simplified terms.
; If we are in a ring or field, we can call the tactic with an optional flag
; that indicates reflection to subtract the term s from t and to give back
; the new goal f((t-s)',0).

; Furthermore we allow:
;    P t s
; where P is a binary predicate and t, s terms.
; The new goal is then P t' s'.

; In order to use reflection, one has to initialise the semi-ring, ring,
; field by calling the functions
;    (prepare-simp-semi-ring x),
;    (prepare-simp-ring x),
;    (prepare-simp-field x) resp.,
; where x is a list of terms (for e.g. 0,1), axioms and lemmas.

; The tactic commands are called
;    (simp-semi-ring),
;    (simp-ring optional-flag),
;    (simp-field).

; Please have a look at the section with the examples to get an idea
; how to use it.


; Overview:

; 1.  Loading of Resources
; 2.  Preparing Reflection for Usage
; 3.  General Program-Constants for Insertion-Sort
; 4.  Algebras, Program-Constants for Normalization
; 5.  Proofs
; 6.  Additional Preparation of Proofs
; 7.  Functions for Transferring Terms to Expressions
; 8.  Reflection Tactic Commands
; 9.  Debugging
; 10. Common (Semi-)Rings and Fields
; 11. Examples



;===================================================================
; 1. LOADING OF RESOURCES
;===================================================================

(display "loading reflection_alpha.scm ...")
(newline)
(display "THIS MAY TAKE SOME SECONDS.")
(newline)

;(load "~/minlog/init.scm")
(set! COMMENT-FLAG #f)
(define DEBUG-FLAG #f)
(define (display-debug . debug-string-list)
  (if DEBUG-FLAG
      (letrec
          ((debug-string
            (lambda (ds)
              (cond ((=(length ds) 0) "")
                    ((=(length ds) 1) (car ds))
                    (else
                     (debug-string
                      (append
                       (list(string-append (car ds)(cadr ds)))
                       (cddr ds))))))))
        (display (debug-string debug-string-list))
        (newline))))
(libload "nat.scm")
(libload "list.scm")
(srcload "unicode.scm")
(libload "numbers.scm")


;===================================================================
; 2. PREPARING REFLECTION FOR USAGE
;===================================================================

(define (theorem-or-global-assumption-name-to-aconst name)
  (cond
   ((and (string? name) (assoc name THEOREMS))
    (theorem-name-to-aconst name))
   ((and (string? name) (assoc name GLOBAL-ASSUMPTIONS))
    (global-assumption-name-to-aconst name))
   (else
    (myerror "theorem-or-global-assumption-name-to-aconst"
	     "name of theorem or global assumption expected"
	     name))))

; global variable to save all parameters provided with (prepare-simp-...)
(define INITIALISED-TYPES '())

(define (reset-global-var-for-reflection)
  (set! INITIALISED-TYPES '()))

(define (remove-from-assoc-list tag alist)
  (if (null? alist)
      '()
      (if (equal? (caar alist) tag)
	  (cdr alist)
	  (cons (car alist) (remove-from-assoc-list tag (cdr alist))))))

; (prepare-simp-semi-ring x)
; (prepare-simp-ring x)
; (prepare-simp-field x)
; Functions to initialise the use of reflection where x is
;  - type of the (semi-)ring, field
;  - scheme function that is true whenever a term should be handled as a 
;    constant term
;  - term for Null
;  - term for One
;  - term for Addition
;  - term for Multiplication
;  - term for Exponentiation
;  - name of ExpLemma1
;  - name of ExpLemma2
;  - name of ExpLemma3
;  - name of PlusAssoc
;  - name of PlusNeutral
;  - name of PlusComm
;  - name of TimesAssoc
;  - name of TimesNeutral
;  - name of TimesComm
;  - name of Distr
; For rings, additionally:
;  - term for Subtraction
;  - term for Negative
;  - name of NegativeLemma1
;  - name of NegativeLemma2
;  - name of MinusLemma
; For fields, additionally:
;  - term for Division

; The required lemmatas and axioms should have the following form.

; PlusAssoc
; all r1,r2,r3.Equal(r1+(r2+r3))((r1+r2)+r3)

; PlusNeutral
; all r.Equal(0+r)r

; PlusComm
; all r1,r2.Equal(r1+r2)(r2+r1)

; TimesAssoc
; all r1,r2,r3.Equal(r1*(r2*r3))((r1*r2)*r3)

; TimesNeutral
; all r.Equal(1*r)r

; TimesComm
; all r1,r2.Equal(r1*r2)(r2*r1)

; IntDistr
; all r1,r2,r3.Equal(r1*(r2+r3))((r1*r2)+(r1*r3))

; ExpLemma1
; all r,pos1,pos2.
;   Equal((exp r pos1)*(exp r pos2))(expon r(pos1+pos2))

; ExpLemma2
; all r.Equal(exp r One)r

; ExpLemma3
; all r,pos1,pos2.
;   Equal(exp(exp r pos1)pos2)(exp r(pos1*pos2))

; NegativeLemma1
; all r1,r2.rel(r1+(neg al2))0 -> (rel r1 r2)

; NegativeLemma2
; all r.Equal(r+(neg r))0

; MinusLemma
; all r1,r2.
;   Equal(r1+(neg r2))(r1-r2)

(define (prepare-simp-semi-ring
	 type const-term? null one plus times exp ExpLemma1 ExpLemma2
	 ExpLemma3 PlusAssoc PlusNeutral PlusComm TimesAssoc TimesNeutral
	 TimesComm Distr)
  ;remove any information about type
  (remove-from-assoc-list type INITIALISED-TYPES)
  (let ((new-entry 
	 (list
	  (list ;"basic" elements
	   const-term? null one plus times exp)
	  (list ;lemmatas on exp
	   ExpLemma1 ExpLemma2 ExpLemma3)
	  (list ;semi ring axioms
	   PlusAssoc PlusNeutral PlusComm TimesAssoc TimesNeutral
	   TimesComm Distr))))
    (set! INITIALISED-TYPES
	  (cons
	   (list
	    type
	    new-entry)
	   INITIALISED-TYPES)))
  (display-comment
   (string-append "Reflection for Semi-Ring "
		  (type-to-string type)
		  " loaded."))
  (newline))

(define (prepare-simp-ring
	 type const-term? null one plus times exp ExpLemma1 ExpLemma2
	 ExpLemma3 PlusAssoc PlusNeutral PlusComm TimesAssoc TimesNeutral
	 TimesComm Distr minus negative NegativeLemma1 NegativeLemma2 
	 MinusLemma)
  ;remove any information about type
  (remove-from-assoc-list type INITIALISED-TYPES)
  (let ((new-entry 
	 (list
	  (list ;"basic" elements
	   const-term? null one plus times exp)
	  (list ;lemmatas on exp
	   ExpLemma1 ExpLemma2 ExpLemma3)
	  (list ;semi ring axioms
	   PlusAssoc PlusNeutral PlusComm TimesAssoc TimesNeutral
	   TimesComm Distr)
	  (list ;extra info for proper rings
	   minus negative NegativeLemma1 NegativeLemma2 MinusLemma))))
    (set! INITIALISED-TYPES
	  (cons
	   (list
	    type
	    new-entry)
	   INITIALISED-TYPES)))
  (display-comment
   (string-append "Reflection for Ring "
		  (type-to-string type)
		  " loaded."))
  (newline))

(define (prepare-simp-field
	 type const-term? null one plus times exp ExpLemma1 ExpLemma2
	 ExpLemma3 PlusAssoc PlusNeutral PlusComm TimesAssoc TimesNeutral
	 TimesComm Distr minus negative NegativeLemma1 NegativeLemma2
	 MinusLemma div)
  ;remove any information about type
  (remove-from-assoc-list type INITIALISED-TYPES)
  (let ((new-entry 
	 (list
	  (list ;"basic" elements
	   const-term? null one plus times exp)
	  (list ;lemmatas on exp
	   ExpLemma1 ExpLemma2 ExpLemma3)
	  (list ;semi ring axioms
	   PlusAssoc PlusNeutral PlusComm TimesAssoc TimesNeutral
	   TimesComm Distr)
	  (list ;extra info for proper rings
	   minus negative NegativeLemma1 NegativeLemma2 MinusLemma)
	  (list ;extra info for fields
	   div))))
    (set! INITIALISED-TYPES
	  (cons
	   (list
	    type
	    new-entry)
	   INITIALISED-TYPES)))
  (display-comment
   (string-append "Reflection for Field "
		  (type-to-string type)
		  " loaded."))
  (newline))


; Accessor Functions for INITIALISED-TYPES

(define (get-basics1 x)
  (caadr (assoc x INITIALISED-TYPES)))
(define (get-basics2 x)
  (cddddr (get-basics1 x)))

(define (get-explemmas x)
  (cadadr (assoc x INITIALISED-TYPES)))

(define (get-semiringaxioms1 x)
  (car (cddadr (assoc x INITIALISED-TYPES))))
(define (get-semiringaxioms2 x)
  (cddddr (get-semiringaxioms1 x)))

(define (get-ringinfo1 x)
  (cadr (cddadr (assoc x INITIALISED-TYPES))))
(define (get-ringinfo2 x)
  (cddddr (get-ringinfo1 x)))

(define (get-fieldinfo x)
  (caddr (cddadr (assoc x INITIALISED-TYPES))))

(define (get-const-term? x)
  (car (get-basics1 x)))
(define (get-null x)
  (cadr (get-basics1 x)))
(define (get-one x)
  (caddr (get-basics1 x)))
(define (get-plus x)
  (cadddr (get-basics1 x)))
(define (get-times x)
  (car (get-basics2 x)))
(define (get-exp x)
  (cadr (get-basics2 x)))

(define (get-ExpLemma1 x)
  (car (get-explemmas x)))
(define (get-ExpLemma2 x)
  (cadr (get-explemmas x)))
(define (get-ExpLemma3 x)
  (caddr (get-explemmas x)))

(define (get-PlusAssoc x)
  (car (get-semiringaxioms1 x)))
(define (get-PlusNeutral x)
  (cadr (get-semiringaxioms1 x)))
(define (get-PlusComm x)
  (caddr (get-semiringaxioms1 x)))
(define (get-TimesAssoc x)
  (cadddr (get-semiringaxioms1 x)))
(define (get-TimesNeutral x)
  (car (get-semiringaxioms2 x)))
(define (get-TimesComm x)
  (cadr (get-semiringaxioms2 x)))
(define (get-Distr x)
  (caddr (get-semiringaxioms2 x)))

(define (get-minus x)
  (car (get-ringinfo1 x)))
(define (get-negative x)
  (cadr (get-ringinfo1 x)))
(define (get-NegativeLemma1 x)
  (caddr (get-ringinfo1 x)))
(define (get-NegativeLemma2 x)
  (cadddr (get-ringinfo1 x)))
(define (get-MinusLemma x)
  (car (get-ringinfo2 x)))

(define (get-div x)
  (car (get-fieldinfo x)))


; (display-reflection-rings) is a display function
; which (semi-)rings and fields have already been initialised

(define (display-reflection-types)
  (if COMMENT-FLAG
      (begin
	(newline)
	(display "Initialised Semi-Rings for Reflection:")
	(newline)
	(newline)
	(if (equal? '() INITIALISED-TYPES)
	    (begin
	      (display " none")
	      (newline)(newline))
	    (begin
	      (for-each
	       (lambda (x)
		 (if (= 3 (length (cadr x)))
		     (let* ((y (car x))
			    (null (get-null y))
			    (one (get-one y))
			    (plus (get-plus y))
			    (times (get-times y))
			    (exp (get-exp y)))
		       (display " ")
		       (pp y)
		       (display tab)
		       (display "Null  : ")
		       (pp null)
		       (display tab)
		       (display "One   : ")
		       (pp one)
		       (display tab)
		       (display "Plus  : ")
		       (pp plus)
		       (display tab)
		       (display "Times : ")
		       (pp times)
		       (display tab)
		       (display "Exp   : ")
		       (pp exp))))
	       INITIALISED-TYPES)
	      (newline)))
	(newline)
	(display "Initialised Rings for Reflection:")
	(newline)
	(newline)
	(if (equal? '() INITIALISED-TYPES)
	    (begin
	      (display " none")
	      (newline)(newline))
	    (begin
	      (for-each
	       (lambda (x)
		 (if (= 4 (length (cadr x)))
		     (let* ((y (car x))
			    (null (get-null y))
			    (one (get-one y))
			    (plus (get-plus y))
			    (times (get-times y))
			    (exp (get-exp y))
			    (minus (get-minus y)))
		       (display " ")
		       (pp y)
		       (display tab)
		       (display "Null  : ")
		       (pp null)
		       (display tab)
		       (display "One   : ")
		       (pp one)
		       (display tab)
		       (display "Plus  : ")
		       (pp plus)
		       (display tab)
		       (display "Minus : ")
		       (pp minus)
		       (display tab)
		       (display "Times : ")
		       (pp times)
		       (display tab)
		       (display "Exp   : ")
		       (pp exp))))
	       INITIALISED-TYPES)
	      (newline)))
	(newline)
	(display "Initialised Fields for Reflection:")
	(newline)
	(newline)
	(if (equal? '() INITIALISED-TYPES)
	    (begin
	      (display " none")
	      (newline)(newline))
	    (begin
	      (for-each
	       (lambda (x)
		 (if (= 5 (length (cadr x)))
		     (let* ((y (car x))
			    (null (get-null y))
			    (one (get-one y))
			    (plus (get-plus y))
			    (times (get-times y))
			    (exp (get-exp y))
			    (minus (get-minus y))
			    (div (get-div y)))
		       (display " ")
		       (pp y)
		       (display tab)
		       (display "Null  : ")
		       (pp null)
		       (display tab)
		       (display "One   : ")
		       (pp one)
		       (display tab)
		       (display "Plus  : ")
		       (pp plus)
		       (display tab)
		       (display "Minus : ")
		       (pp minus)
		       (display tab)
		       (display "Times : ")
		       (pp times)
		       (display tab)
		       (display "Div   : ")
		       (pp div)
		       (display tab)
		       (display "Exp   : ")
		       (pp exp))))
	       INITIALISED-TYPES)
	      (newline))))))


#| old test functions for the axioms, need to be adapted

; (axiom-form? ) takes as arguments a formula and a list of length ≥ 1
; with first element being a string identifying which form the axiom
; ought to be, e.g. "assoc". The (optional) second argument ought to
; be the neutral element if the first argument is "neutral". All other
; elements of the list are ignored. (axiom-form? ) is not restricted to
; + and * , it accepts any binary functions.
; 2006-09-11
; changed make-=-term to make-eq
(define (axiom-form? formula form)
  (display-debug "axiom-form?")
  (pp formula)
  (display-debug form)
  (let* ((top   term-in-app-form-to-op)
         (targ  term-in-app-form-to-arg)
         (maf   mk-term-in-app-form)
         (mvf   make-term-in-var-form)
         (test  (car form))
         (vars-and-kernel (all-form-to-vars-and-final-kernel formula))
         (vars  (car vars-and-kernel))
         (kernel-term (atom-form-to-kernel(cadr vars-and-kernel)))
         (ft (lambda (fm lg) (and (string=? test fm)(= (length vars) lg)))))
    (cond ((ft "assoc" 3)
           (let* ((fun (top(top(targ kernel-term))))
                  (vt1 (mvf   (car vars)))
                  (vt2 (mvf  (cadr vars)))
                  (vt3 (mvf (caddr vars)))
                  (axform (make-eq (maf fun vt1 (maf fun vt2 vt3))
                                       (maf fun (maf fun vt1 vt2) vt3))))
             (term=? axform kernel-term)))
          ((ft "neutral" 1)
           (let* ((fun    (top(targ(top kernel-term))))
                  (vt1    (mvf (car vars)))
                  (axform (make-eq (maf fun vt1) vt1)))
             (and (term=? (cadr form) (targ fun))
                  (term=? axform kernel-term))))
          ((ft "comm" 2)
           (let* ((fun (top(top(targ kernel-term))))
                  (vt1 (mvf (car vars)))
                  (vt2 (mvf(cadr vars)))
                  (axform
                   (make-eq
                    (maf fun vt1 vt2)
                    (maf fun vt2 vt1))))
             (term=? axform kernel-term)))
          ((ft "distr" 3)
           (let* ((fun1 (top(top(targ kernel-term))))
                  (fun2 (top(top(targ(targ kernel-term)))))
                  (vt1 (mvf  (car vars)))
                  (vt2 (mvf (cadr vars)))
                  (vt3 (mvf(caddr vars)))
                  (axform
                   (make-eq
                    (maf fun2 vt1 (maf fun1 vt2 vt3))
                    (maf fun1 (maf fun2 vt1 vt2) (maf fun2 vt1 vt3)))))
             (term=? axform kernel-term)))
          (else #f))))

; Main function to check ring axioms.
(define
  (check-axioms
   null one
   PlusAssoc     PlusNeutral   RingAddComm
   TimesAssoc   TimesNeutral TimesComm Distr)
  (do ((axioms
        (list PlusAssoc  PlusNeutral RingAddComm
              TimesAssoc  TimesNeutral TimesComm
              Distr)
        (cdr axioms))
       (i 0 (+ i 1)))
      ((null? axioms) #t)
    (let* ((ax (car axioms))
           (aconst
            (cond
             ((and (string? ax) (assoc ax THEOREMS))
              (theorem-name-to-aconst ax))
             ((and (string? ax) (assoc ax GLOBAL-ASSUMPTIONS))
              (global-assumption-name-to-aconst ax))
             (else
              (myerror "check-axioms"
                       "Name of theorem or global assumption expected!"
                       ax))))
           (formula (aconst-to-formula aconst))
           (form (cond ((or (= i 0)(= i 3)) (list "assoc"))
                       ((or (= i 2)(= i 5)) (list "comm"))
                       (    (= i 1)         (list "neutral" (pt null)))
                       (    (= i 4)         (list "neutral" (pt one)))
                       (    (= i 6)         (list "distr"))
                       (else (myerror "check-axioms"
                                      "Something went wrong !")))))
      (display-debug ".")
      (if (not (axiom-form? formula form))
          (myerror "check-axiom"
                   "Axiom not of appropriate form !"
                   (formula-to-string formula))))))

|#


;===================================================================
; 3. GENERAL PROGRAM-CONSTANTS FOR INSERTION-SORT
;===================================================================

; some variables with type variable alpha
(av "al"  (py "alpha"))
(av "als" (py "list alpha"))
(av "rel" (py "alpha=>alpha=>boole"))

; First argument of SortListInsert is a binary boolean valued
; function on the elements (of type alpha).
; Second argument is a single element that need to be
; inserted into a list (third argument) at the right position
; (with respect to the given boolean valued function).
(add-program-constant
 "SortListInsert"
 (py "(alpha=>alpha=>boole)=>alpha=>list alpha=>list alpha") 1)
  
(acrs
 "(SortListInsert alpha) rel al (Nil alpha)"
 "al:"
 "(SortListInsert alpha) rel al (al0::als)"
 "[if (rel al al0) (al::al0::als)
      (al0::(SortListInsert alpha) rel al als)]")
  
; SortList implements Insert-Sort on lists with elements of type alpha.
; SortList uses SortListInsert therefore one needs to provide the
; compare function as first argument.
(add-program-constant
 "SortList"
 (py "(alpha=>alpha=>boole)=>list alpha=>list alpha") 1)

(acrs
 "(SortList alpha)(rel)(Nil alpha)"
 "(Nil alpha)"
 "(SortList alpha)(rel)(al::als)"
 "(SortListInsert alpha)(rel)(al)((SortList alpha)(rel)(als))")

; OrderList is a program-constant that gives back #t or #f meaning
; if the first list (with elements of type alpha) is 'bigger'
; (with respect to the given boolean valued function) than
; the second. First criterion is the length. If the length of both
; is equal, then the elements of both lists are considered pairwise
; from the beginning, step by step (lexicographic order w.r.t.
; the given function).
(add-program-constant
 "OrderList"
 (py "(alpha=>alpha=>boole)=>list alpha=>list alpha=>boole") 1)

(acrs
 "(OrderList alpha)rel(Nil alpha) als"      
 "True"
 "(OrderList alpha)rel(al::als)(Nil alpha)"   
 "False"
 "(OrderList alpha)rel(al1::als1)(al2::als2)"
 "[if (NatLt Lh(al1::als1) Lh(al2::als2))
      True
      [if (Lh(al1::als1)=Lh(al2::als2))
          [if (rel al1 al2)
              True
              [if (rel al2 al1)
                  False
                  ((OrderList alpha)rel(als1)(als2))]]
          False]]")


;===================================================================
; 4. ALGEBRAS, PROGRAM-CONSTANTS FOR NORMALIZATION
;===================================================================

(add-param-alg "exprESD" 'prefix-typeop
	       '("VarESD" "nat=>pos=>exprESD")
	       '("ConstESD" "alpha=>exprESD")
	       '("AddESD" "exprESD=>exprESD=>exprESD")
	       '("MultESD" "exprESD=>exprESD=>exprESD")
	       '("Div" "exprESD=>exprESD=>exprESD")
	       '("ExpSD" "exprESD=>pos=>exprESD")
	       '("SubD" "exprESD=>exprESD=>exprESD"))


(add-param-alg "exprES" 'prefix-typeop
	       '("VarES" "nat=>pos=>exprES")
	       '("ConstES" "alpha=>exprES")
	       '("AddES" "exprES=>exprES=>exprES")
	       '("MultES" "exprES=>exprES=>exprES")
	       '("ExpS" "exprES=>pos=>exprES")
	       '("Sub" "exprES=>exprES=>exprES"))

(add-param-alg "exprE" 'prefix-typeop
	       '("VarE" "nat=>pos=>exprE")
	       '("ConstE" "alpha=>exprE")
	       '("AddE" "exprE=>exprE=>exprE")
	       '("MultE" "exprE=>exprE=>exprE")
	       '("Exp" "exprE=>pos=>exprE"))

(add-param-alg "expr" 'prefix-typeop
	       '("Var" "nat=>pos=>expr")
	       '("Const" "alpha=>expr")
	       '("Add" "expr=>expr=>expr")
	       '("Mult" "expr=>expr=>expr"))

(add-alg "var"
	 '("V" "nat=>pos=>var"))

(add-param-alg "mon" 'prefix-typeop
	       '("Mo" "alpha=>list var=>mon"))

    
; variables to easily write out computation rules
(rv "n" "m" "i" "j" "k" "l" "a" "b" "p" "q")
(av "r" "s" "t" (py "alpha"))
(av "rs" (py "list alpha"))
(av "e" "f" (py "expr alpha"))
(av "g" "h" (py "exprE alpha"))
(av "i" "j" (py "exprES alpha"))
(av "k" "l" (py "exprESD alpha"))
(av "null" "one" (py "alpha"))
(av "plus" "minus" "times" "div" (py "alpha=>alpha=>alpha"))
(av "expon" (py "alpha=>pos=>alpha")) ; exp is already used
(av "eq" (py "list expr alpha=>list expr alpha=>boole"))
(av "neg" (py "alpha=>alpha"))
(av "n" (py "nat"))
(av "ms" (py "list mon alpha"))
(av "m" (py "mon alpha"))
(av "v" (py "var"))
(av "vs" (py "list var"))
(av "p" "q" (py "pos"))
(av "msp" (py "list mon alpha@@list mon alpha"))


; Evaluation functions

; evaluation of a variable
(add-program-constant
 "EvalVar"
 (py (string-append
      "alpha=>"               ;null
      "(alpha=>pos=>alpha)=>" ;expon
      "nat=>"                 ;index
      "pos=>"                 ;exponent
      "list alpha=>"          ;environment
      "alpha")) 1)

(add-computation-rule
 (pt "(EvalVar alpha)null expon n p (Nil alpha)")
 (pt "null"))
(add-computation-rule
 (pt "(EvalVar alpha)null expon Zero One (r::rs)")
 (pt "r"))
(add-computation-rule
 (pt "(EvalVar alpha)null expon Zero (SZero p) (r::rs)")
 (pt "expon r (SZero p)"))
(add-computation-rule
 (pt "(EvalVar alpha)null expon Zero (SOne p) (r::rs)")
 (pt "expon r (SOne p)"))
(add-computation-rule
 (pt "(EvalVar alpha)null expon (Succ n) p (r::rs)")
 (pt "(EvalVar alpha)null expon n p rs"))

; evaluates a term of type expr
(add-program-constant
 "EvalExpr" 
 (py (string-append
      "alpha=>"                 ;null
      "(alpha=>alpha=>alpha)=>" ;plus
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>pos=>alpha)=>"   ;expon
      "expr alpha=>"            ;expression
      "list alpha=>"            ;environment
      "alpha")) 1)

(add-computation-rule
 (pt "(EvalExpr alpha)null plus times expon((Const alpha)r)rs")
 (pt "r"))
(add-computation-rule
 (pt "(EvalExpr alpha)null plus times expon((Var alpha)n p)rs")
 (pt "(EvalVar alpha)null expon n p rs"))
(add-computation-rule
 (pt "(EvalExpr alpha)null plus times expon((Add alpha)e f)rs")
 (pt "plus((EvalExpr alpha)null plus times expon e rs)
          ((EvalExpr alpha)null plus times expon f rs)"))
(add-computation-rule
 (pt "(EvalExpr alpha)null plus times expon((Mult alpha)e f)rs")
 (pt "times((EvalExpr alpha)null plus times expon e rs)
           ((EvalExpr alpha)null plus times expon f rs)"))
    
; evaluates a term of type exprE
(add-program-constant
 "EvalExprE" 
 (py (string-append
      "alpha=>"                 ;null
      "(alpha=>alpha=>alpha)=>" ;plus
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>pos=>alpha)=>"   ;expon
      "exprE alpha=>"           ;expression
      "list alpha=>"            ;environment
      "alpha")) 1)

(add-computation-rule
 (pt "(EvalExprE alpha)null plus times expon((ConstE alpha)r)rs")
 (pt "r"))
(add-computation-rule
 (pt "(EvalExprE alpha)null plus times expon((VarE alpha)n p)rs")
 (pt "(EvalVar alpha)null expon n p rs"))
(add-computation-rule
 (pt "(EvalExprE alpha)null plus times expon((AddE alpha)g h)rs")
 (pt "plus((EvalExprE alpha)null plus times expon g rs)
          ((EvalExprE alpha)null plus times expon h rs)"))
(add-computation-rule
 (pt "(EvalExprE alpha)null plus times expon((MultE alpha)g h)rs")
 (pt "times((EvalExprE alpha)null plus times expon g rs)
           ((EvalExprE alpha)null plus times expon h rs)"))
(add-computation-rule
 (pt "(EvalExprE alpha)null plus times expon((Exp alpha)g p)rs")
 (pt "expon((EvalExprE alpha)null plus times expon g rs)p"))

; evaluates a term of type exprES
(add-program-constant
 "EvalExprES" 
 (py (string-append
      "alpha=>"                 ;null
      "(alpha=>alpha=>alpha)=>" ;plus
      "(alpha=>alpha=>alpha)=>" ;minus
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>pos=>alpha)=>"   ;expon
      "exprES alpha=>"          ;expression
      "list alpha=>"            ;environment
      "alpha")) 1)

(add-computation-rule
 (pt "(EvalExprES alpha)null plus minus times expon((ConstES alpha)r)rs")
 (pt "r"))
(add-computation-rule
 (pt "(EvalExprES alpha)null plus minus times expon((VarES alpha)n p)rs")
 (pt "(EvalVar alpha)null expon n p rs"))
(add-computation-rule
 (pt "(EvalExprES alpha)null plus minus times expon((AddES alpha)i j)rs")
 (pt "plus((EvalExprES alpha)null plus minus times expon i rs)
          ((EvalExprES alpha)null plus minus times expon j rs)"))
(add-computation-rule
 (pt "(EvalExprES alpha)null plus minus times expon((MultES alpha)i j)rs")
 (pt "times((EvalExprES alpha)null plus minus times expon i rs)
           ((EvalExprES alpha)null plus minus times expon j rs)"))
(add-computation-rule
 (pt "(EvalExprES alpha)null plus minus times expon((ExpS alpha)i p)rs")
 (pt "expon((EvalExprES alpha)null plus minus times expon i rs)p"))
(add-computation-rule
 (pt "(EvalExprES alpha)null plus minus times expon((Sub alpha)i j)rs")
 (pt "minus((EvalExprES alpha)null plus minus times expon i rs)
           ((EvalExprES alpha)null plus minus times expon j rs)"))

(add-program-constant
 "EvalExprESD" 
 (py (string-append
      "alpha=>"                 ;null
      "(alpha=>alpha=>alpha)=>" ;plus
      "(alpha=>alpha=>alpha)=>" ;minus
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>alpha=>alpha)=>" ;div
      "(alpha=>pos=>alpha)=>"   ;expon
      "exprESD alpha=>"         ;expression
      "list alpha=>"            ;environment
      "alpha")) 1)

(add-computation-rule
 (pt "(EvalExprESD alpha)null plus minus times div expon((ConstESD alpha)r)rs")
 (pt "r"))
(add-computation-rule
 (pt "(EvalExprESD alpha)null plus minus times div expon((VarESD alpha)n p)rs")
 (pt "(EvalVar alpha)null expon n p rs"))
(add-computation-rule
 (pt "(EvalExprESD alpha)null plus minus times div expon((AddESD alpha)k l)rs")
 (pt "plus((EvalExprESD alpha)null plus minus times div expon k rs)
          ((EvalExprESD alpha)null plus minus times div expon l rs)"))
(add-computation-rule
 (pt "(EvalExprESD alpha)null plus minus times div expon((MultESD alpha)k l)rs")
 (pt "times((EvalExprESD alpha)null plus minus times div expon k rs)
           ((EvalExprESD alpha)null plus minus times div expon l rs)"))
(add-computation-rule
 (pt "(EvalExprESD alpha)null plus minus times div expon((ExpSD alpha)k p)rs")
 (pt "expon((EvalExprESD alpha)null plus minus times div expon k rs)p"))
(add-computation-rule
 (pt "(EvalExprESD alpha)null plus minus times div expon((SubD alpha)k l)rs")
 (pt "minus((EvalExprESD alpha)null plus minus times div expon k rs)
           ((EvalExprESD alpha)null plus minus times div expon l rs)"))
(add-computation-rule
 (pt "(EvalExprESD alpha)null plus minus times div expon((Div alpha)k l)rs")
 (pt "div((EvalExprESD alpha)null plus minus times div expon k rs)
         ((EvalExprESD alpha)null plus minus times div expon l rs)"))


(add-program-constant
 "EvalListMon"
 (py (string-append
      "alpha=>" ;null
      "(alpha=>alpha=>alpha)=>" ;plus
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>pos=>alpha)=>" ;expon
      "list mon alpha=>" ;list of monomials
      "list alpha=>" ;environment
      "alpha")) 1)
(add-program-constant
 "EvalListMonAux"
 (py (string-append
      "alpha=>" ;null
      "(alpha=>alpha=>alpha)=>" ;plus
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>pos=>alpha)=>" ;expon
      "list mon alpha=>" ;list of monomials
      "list alpha=>" ;environment
      "alpha=>"
      "alpha")) 1)
(add-program-constant
 "EvalMon"
 (py (string-append
      "alpha=>" ;null
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>pos=>alpha)=>" ;expon
      "mon alpha=>" ;list of monomials
      "list alpha=>" ;environment
      "alpha")) 1)
(add-program-constant
 "EvalListVar"
 (py (string-append
      "alpha=>" ;null
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>pos=>alpha)=>" ;expon
      "list var=>" ;list of monomials
      "list alpha=>" ;environment
      "alpha=>"
      "alpha")) 1)

(add-computation-rule
 (pt "(EvalListMon alpha)null plus times expon(Nil mon alpha)rs")
 (pt "null"))
(add-computation-rule
 (pt "(EvalListMon alpha)null plus times expon(m::ms)rs")
 (pt "(EvalListMonAux alpha)null plus times expon ms rs
      ((EvalMon alpha)null times expon m rs)"))
(add-computation-rule
 (pt "(EvalListMonAux alpha)null plus times expon (Nil mon alpha) rs r")
 (pt "r"))
(add-computation-rule
 (pt "(EvalListMonAux alpha)null plus times expon (m::ms) rs r")
 (pt "(EvalListMonAux alpha)null plus times expon 
    ms rs (plus r ((EvalMon alpha)null times expon m rs))"))
(add-computation-rule
 (pt "(EvalMon alpha)null times expon ((Mo alpha)r (Nil var)) rs")
 (pt "r"))
(add-computation-rule
 (pt "(EvalMon alpha)null times expon ((Mo alpha)r (v::vs)) rs")
 (pt "((EvalListVar alpha)null times expon (v::vs) rs r)"))
(add-computation-rule
 (pt "(EvalListVar alpha)null times expon (Nil var) rs r")
 (pt "r"))
(add-computation-rule
 (pt "(EvalListVar alpha)null times expon ((V n p)::vs) rs r")
 (pt "(EvalListVar alpha)null times expon vs rs
    (times r ((EvalVar alpha)null expon n p rs))"))


(add-program-constant
 "EvalPairListMon" 
 (py (string-append
      "alpha=>" ;null
      "(alpha=>alpha=>alpha)=>" ;plus
      "(alpha=>alpha=>alpha)=>" ;minus
      "(alpha=>alpha=>alpha)=>" ;times
      "(alpha=>alpha=>alpha)=>" ;div
      "(alpha=>pos=>alpha)=>" ;expon
      "((list mon alpha)@@(list mon alpha))=>" ;expression
      "list alpha=>" ;environment
      "alpha")) 1)

(add-computation-rule
 (pt "(EvalPairListMon alpha)null plus minus times div expon msp rs")
 (pt "div ((EvalListMon alpha)null plus times expon (left msp) rs)
          ((EvalListMon alpha)null plus times expon (right msp) rs)"))

; Normalization Functions

(add-program-constant
 "FieldToFraction"
 (py (string-append
      "alpha=>" ;One
      "exprESD alpha=>" ;Expression
      "exprES alpha@@exprES alpha")) 1)

(add-computation-rule
 (pt "(FieldToFraction alpha)one((VarESD alpha)n p)")
 (pt "((VarES alpha)n p)@((ConstES alpha)one)"))
(add-computation-rule
 (pt "(FieldToFraction alpha)one((ConstESD alpha)r)")
 (pt "((ConstES alpha)r)@((ConstES alpha)one)"))
(add-computation-rule
 (pt "(FieldToFraction alpha)one((AddESD alpha)k l)")
 (pt "((AddES alpha)
    ((MultES alpha)(left((FieldToFraction alpha)one k))
                   (right((FieldToFraction alpha)one l)))
    ((MultES alpha)(left((FieldToFraction alpha)one l))
                   (right((FieldToFraction alpha)one k))))
    @((MultES alpha)(right((FieldToFraction alpha)one k))
                    (right((FieldToFraction alpha)one l)))"))
(add-computation-rule
 (pt "(FieldToFraction alpha)one((SubD alpha)k l)")
 (pt "((Sub alpha)
    ((MultES alpha)(left((FieldToFraction alpha)one k))
                   (right((FieldToFraction alpha)one l)))
    ((MultES alpha)(left((FieldToFraction alpha)one l))
                   (right((FieldToFraction alpha)one k))))
    @((MultES alpha)(right((FieldToFraction alpha)one k))
                    (right((FieldToFraction alpha)one l)))"))
(add-computation-rule
 (pt "(FieldToFraction alpha)one((MultESD alpha)k l)")
 (pt "((MultES alpha)(left((FieldToFraction alpha)one k))
                    (left((FieldToFraction alpha)one l)))
     @((MultES alpha)(right((FieldToFraction alpha)one k))
                     (right((FieldToFraction alpha)one l)))"))
(add-computation-rule
 (pt "(FieldToFraction alpha)one((Div alpha)k l)")
 (pt "((MultES alpha)(left((FieldToFraction alpha)one k))
                    (right((FieldToFraction alpha)one l)))
     @((MultES alpha)(right((FieldToFraction alpha)one k))
                     (left((FieldToFraction alpha)one l)))"))
(add-computation-rule
 (pt "(FieldToFraction alpha)one((ExpSD alpha)k p)")
 (pt "((ExpS alpha)(left((FieldToFraction alpha)one k))p)
      @((ConstES alpha)one)"))

 
(add-program-constant
 "ElimSub"
 (py (string-append
      "alpha=>" ;One
      "(alpha=>alpha)=>" ;Inverse for Addition
      "exprES alpha=>" ;Expression
      "exprE alpha")) 1)

(acrs
 "(ElimSub alpha)one neg
  ((VarES alpha) n p)"
 "(VarE alpha)n p"
 "(ElimSub alpha)one neg
  ((ConstES alpha)r)"
 "(ConstE alpha)r"
 "(ElimSub alpha)one neg
  ((AddES alpha)i j)"
 "(AddE alpha)
  ((ElimSub alpha)one neg i)
  ((ElimSub alpha)one neg j)"
 "(ElimSub alpha)one neg
  ((MultES alpha)i j)"
 "(MultE alpha)
  ((ElimSub alpha)one neg i)
  ((ElimSub alpha)one neg j)"
 "(ElimSub alpha)one neg
  ((ExpS alpha)i p)"
 "(Exp alpha)
  ((ElimSub alpha)one neg i)
  p"
 "(ElimSub alpha)one neg
  ((Sub alpha)i j)"
 "(AddE alpha)
  ((ElimSub alpha)one neg i)
  ((MultE alpha)((ConstE alpha)(neg one))
  ((ElimSub alpha)one neg j))")


(add-program-constant
 "ExpUnfold"
 (py (string-append
      "exprE alpha=>" ;expression
      "expr alpha")) 1)

(add-computation-rule
 (pt "(ExpUnfold alpha)((VarE alpha)n p)")
 (pt "(Var alpha)n p"))
(add-computation-rule
 (pt "(ExpUnfold alpha)((ConstE alpha)r)")
 (pt "(Const alpha)r"))
(add-computation-rule
 (pt "(ExpUnfold alpha)((AddE alpha)g h)")
 (pt "(Add alpha)((ExpUnfold alpha)g)((ExpUnfold alpha)h)"))
(add-computation-rule
 (pt "(ExpUnfold alpha)((MultE alpha)g h)")
 (pt "(Mult alpha)((ExpUnfold alpha)g)((ExpUnfold alpha)h)"))
(add-computation-rule
 (pt "(ExpUnfold alpha)((Exp alpha)g One)")
 (pt "(ExpUnfold alpha)g"))
(add-computation-rule
 (pt "(ExpUnfold alpha)((Exp alpha)g(SZero p))")
 (pt "(ExpUnfold alpha)((MultE alpha)((Exp alpha)g p)((Exp alpha)g p))"))
(add-computation-rule
 (pt "(ExpUnfold alpha)((Exp alpha)g(SOne p))")
 (pt "(ExpUnfold alpha)((MultE alpha)((MultE alpha)((Exp alpha)g p)
      ((Exp alpha)g p))g)"))


(add-program-constant
 "MultVars"
 (py "list var=>list var=>list var") 1)
(add-program-constant
 "MultVarsAux"
 (py "var=>list var=>list var") 1)

(acrs
 "MultVars (Nil var) vs"
 "vs"
 "MultVars (v:) vs"
 "(MultVarsAux v vs)"
 "MultVars (v1::v2::vs1) vs2"
 "(MultVarsAux v1 vs2):+:(MultVars (v2::vs1) vs2)"
 "MultVarsAux v (Nil var)"
 "v:"
 "MultVarsAux (V n1 p1) ((V n2 p2)::vs)"
 "[if (n1=n2)
      ((V n1 (p1+p2))::vs)
      ((V n2 p2)::(MultVarsAux(V n1 p1)vs))]")


(add-program-constant
 "MultMon"
 (py "(alpha=>alpha=>alpha)=>list mon alpha=>list mon alpha=>list mon alpha") 1)
(add-program-constant
 "MultMonAux"
 (py "(alpha=>alpha=>alpha)=>mon alpha=>list mon alpha=>list mon alpha") 1)
(add-program-constant
 "MultMonAuxAux"
 (py "(alpha=>alpha=>alpha)=>mon alpha=>mon alpha=>mon alpha") 1)

(acrs
 "(MultMon alpha)times(Nil mon alpha)ms"
 "(Nil mon alpha)"
 "(MultMon alpha)times(m::ms1)ms2"
 "((MultMonAux alpha)times m ms2):+:((MultMon alpha)times ms1 ms2)"
 "(MultMonAux alpha)times m(Nil mon alpha)"
 "(Nil mon alpha)"
 "(MultMonAux alpha)times m1(m2::ms)"
 "((MultMonAuxAux alpha)times m1 m2)::((MultMonAux alpha)times m1 ms)"
 "(MultMonAuxAux alpha)times((Mo alpha)r vs1)((Mo alpha)s vs2)"
 "(Mo alpha)(times r s)(MultVars vs1 vs2)")

(add-program-constant
 "OrderVars"
 (py "list mon alpha=>list mon alpha") 1)
(add-program-constant
 "OrderVarsAux"
 (py "list var=>list var") 1)
(add-program-constant
 "VarLt"
 (py "var=>var=>boole") 1)
(add-program-constant
 "VarLtExtended"
 (py "var=>var=>boole") 1)

(acrs
 "VarLt (V n1 p1) (V n2 p2)"
 "NatLt n1 n2"
 "VarLtExtended (V n1 p1) (V n2 p2)"
 "[if (NatLt n1 n2)
      True
      [if (NatLt n2 n1)
          False
          (PosLt p1 p2)]]"
 "(OrderVars alpha)(Nil mon alpha)"
 "(Nil mon alpha)"
 "(OrderVars alpha)(((Mo alpha)r vs)::ms)"
 "((Mo alpha)r(OrderVarsAux ((SortList var)VarLt vs)))::((OrderVars alpha)ms)"
 "OrderVarsAux (Nil var)"
 "(Nil var)"
 "OrderVarsAux (v:)"
 "v:"
 "OrderVarsAux ((V n1 p1)::(V n2 p2)::vs)"
 "[if (n1=n2)
      (OrderVarsAux ((V n1 (p1+p2))::vs))
      ((V n1 p1)::(OrderVarsAux ((V n2 p2)::vs)))]")

(add-program-constant
 "ExprToMonList"
 (py "alpha=>(alpha=>alpha=>alpha)=>expr alpha=>list mon alpha") 1)

(acrs
 "(ExprToMonList alpha) one times((Var alpha)nat pos)"
 "((Mo alpha) one ((V nat pos):)):"
 "(ExprToMonList alpha) one times((Const alpha)alpha)"
 "((Mo alpha) alpha (Nil var)):"
 "(ExprToMonList alpha) one times((Add alpha)e f)"
 "((ExprToMonList alpha) one times e)
  :+:((ExprToMonList alpha) one times f)"
 "(ExprToMonList alpha) one times((Mult alpha)e f)"
 "(MultMon alpha)times
    ((ExprToMonList alpha) one times e)
    ((ExprToMonList alpha) one times f)")

(add-program-constant
 "MonLt"
 (py "mon alpha=>mon alpha=>boole") 1)

(acrs
 "(MonLt alpha)((Mo alpha)r1 vs1)((Mo alpha)r2 vs2)"
 "((OrderList var)VarLtExtended vs1 vs2)")

(add-program-constant
 "SortListOfMonomials"
 (py "list mon alpha=>list mon alpha") 1)

(acrs
 "(SortListOfMonomials alpha)ms"
 "(SortList mon alpha)(MonLt alpha)ms")

(add-program-constant
 "UnifyMonomials"
 (py "(alpha=>alpha=>alpha)=>list mon alpha=>list mon alpha") 1)

(acrs
 "(UnifyMonomials alpha)plus(Nil mon alpha)"
 "(Nil mon alpha)"
 "(UnifyMonomials alpha)plus(m:)"
 "m:"
 "(UnifyMonomials alpha)plus(((Mo alpha)r vs1)::((Mo alpha)s vs2)::ms)"
 "[if (vs1=vs2)
      ((UnifyMonomials alpha)plus(((Mo alpha)(plus r s)vs1)::ms))
      (((Mo alpha)r vs1)::((UnifyMonomials alpha)plus(((Mo alpha)s vs2)::ms)))]")
      

(add-program-constant
 "NormalizeExprESD"
 (py "alpha=>(alpha=>alpha=>alpha)=>
      (alpha=>alpha=>alpha)=>
      (alpha=>alpha)=>exprESD alpha=>
      list mon alpha@@list mon alpha") 1)

(add-computation-rule
 (pt "(NormalizeExprESD alpha)one plus times neg exprESD alpha")
 (pt "((UnifyMonomials alpha) plus
  ((SortListOfMonomials alpha)
  ((OrderVars alpha)
  ((ExprToMonList alpha) one times
  ((ExpUnfold alpha)
  ((ElimSub alpha) one neg
  (left
  ((FieldToFraction alpha)one
  exprESD alpha))))))))
  @
  ((UnifyMonomials alpha) plus
  ((SortListOfMonomials alpha)
  ((OrderVars alpha)
  ((ExprToMonList alpha) one times
  ((ExpUnfold alpha)
  ((ElimSub alpha) one neg
  (right
  ((FieldToFraction alpha)one
  exprESD alpha))))))))"))

(add-program-constant
 "NormalizeExprES"
 (py "alpha=>(alpha=>alpha=>alpha)=>
      (alpha=>alpha=>alpha)=>
      (alpha=>alpha)=>exprES alpha=>list mon alpha") 1)

(add-computation-rule
 (pt "(NormalizeExprES alpha)one plus times neg exprES alpha")
 (pt "(UnifyMonomials alpha) plus
  ((SortListOfMonomials alpha)
  ((OrderVars alpha)
  ((ExprToMonList alpha) one times
  ((ExpUnfold alpha)
  ((ElimSub alpha) one neg exprES alpha)))))"))


(add-program-constant
 "NormalizeExprE"
 (py "alpha=>(alpha=>alpha=>alpha)=>
      (alpha=>alpha=>alpha)=>
      exprE alpha=>list mon alpha") 1)

(add-computation-rule
 (pt "(NormalizeExprE alpha)one plus times exprE alpha")
 (pt "(UnifyMonomials alpha) plus
  ((SortListOfMonomials alpha)
  ((OrderVars alpha)
  ((ExprToMonList alpha) one times
  ((ExpUnfold alpha) exprE alpha))))"))

(add-program-constant
 "MoveToLeft"
 (py "(alpha=>alpha)=>list mon alpha=>list mon alpha=>list mon alpha") 1)

(add-computation-rule
 (pt "(MoveToLeft alpha)neg ms(Nil mon alpha)")
 (pt "ms"))
(add-computation-rule
 (pt "(MoveToLeft alpha)neg ms1 (((Mo alpha)r vs)::ms2)")
 (pt "(MoveToLeft alpha)neg (((Mo alpha)(neg r)vs)::ms1) ms2"))

(add-program-constant
 "NormalizeExprESLeft"
 (py "alpha=>(alpha=>alpha=>alpha)=>
      (alpha=>alpha=>alpha)=>
      (alpha=>alpha)=>exprES alpha=>exprES alpha=>list mon alpha") 1)

(add-computation-rule
 (pt "(NormalizeExprESLeft alpha)one plus times neg
       exprES alpha^1 exprES alpha^2")
 (pt "(UnifyMonomials alpha) plus
  ((SortListOfMonomials alpha)
  ((MoveToLeft alpha) neg

    ((OrderVars alpha)
    ((ExprToMonList alpha) one times
    ((ExpUnfold alpha)
    ((ElimSub alpha) one neg exprES alpha^1))))

    ((OrderVars alpha)
    ((ExprToMonList alpha) one times
    ((ExpUnfold alpha)
    ((ElimSub alpha) one neg exprES alpha^2))))))"))


; TODO: NormalizeExprESDLeft


;===================================================================
; 5. PROOFS
;===================================================================

; The proof still uses rewrite rules that are only valid under
; a set of assumptions (namely ring or semi-ring axioms).

; One solution would be to adapt the notion of rewrite rules.
; Or one has to replace inroduction of rewrite rules by
; saving the proof as a lemma; but then the proofs will
; probably 'explode' because many applications of those
; lemmatas are needed.

; alphaBinaryBooleCompat

(sg "Equal alpha1_3 alpha1_1 -> Equal alpha2_4 alpha2_2
  -> ((alpha1=>alpha2=>boole)alpha1_3 alpha2_4)
  -> ((alpha1=>alpha2=>boole)alpha1_1 alpha2_2)")
(assume "(alpha1)_3" "(alpha1)_1" "(alpha2)_4" "(alpha2)_2"
		"alpha1=>alpha2=>boole"
		"E31" "E42")
(simp "E31")
(simp "E42")
(search)
; Proof finished.
(add-theorem "alphaBinaryBooleCompat" (np(current-proof)))


; EqCompatArityTwo

(set-goal (pf "allnc alpha1^1,alpha1^2,alpha2^1,alpha2^2.
    Equal alpha1^1 alpha1^2 -> Equal alpha2^1 alpha2^2 -> 
    (Pvar alpha1 alpha2)^' alpha1^1 alpha2^1 -> (Pvar alpha1 alpha2)^' alpha1^2 alpha2^2"))
(assume "alpha1^1" "alpha1^2" "alpha2^1" "alpha2^2" "*" "**" "***")
(simp "<-" "*")
(simp "<-" "**")
(use "***")
; Proof finished.
(add-theorem "EqCompatArityTwo" (np(current-proof)))


(define (s . args)
  (let ((mult 5))
    (if (null? args)
	(search mult (list "Eq-Refl" mult))
	(let ((new-list (do ((l args (cdr l))
			     (z '() (cons (list (car l) mult) z)))
			    ((null? l) z))))
	  (search mult (list "Eq-Refl" mult) (car new-list))))))


(define PlusAxioms
  (string-append
   "(all r,s,t.Equal (plus r (plus s t))"
     "(plus (plus r s) t)) ->"
   "(all r.Equal (plus null r) r) ->"
   "(all r,s.Equal (plus r s) (plus s r))"))

(define TimesAxioms
  (string-append
   "(all r,s,t.Equal (times r (times s t))"
     "(times (times r s) t)) ->"
   "(all r.Equal (times one r) r) ->"
   "(all r,s.Equal (times r s) (times s r))"))

(define DistrAxiom
  (string-append
   "(all r,s,t.Equal (times r (plus s t))"
   "(plus (times r s) (times r t)))"))

(define SemiRingAxioms
  (string-append PlusAxioms "->" TimesAxioms "->" DistrAxiom)) 

(define NegativeLemma1
  (string-append
   "(all r,s."
   " (rel (plus r(neg s)) null)"
   "-> (rel r s))"))

(define NegativeLemma2
  "(all r. Equal (plus r (neg r)) null)")

(define ExpLemma1
  "(all r,p,q.Equal(times(expon r p)(expon r q))
   (expon r (PosPlus p q)))")

(define ExpLemma2
  "(all r.Equal(expon r One)r)")

(define ExpLemma3
  "(all r,p,q.Equal(expon (expon r p) q)
   (expon r (PosTimes p q)))")

(define Sub
  "(all r,s.Equal(plus r(neg s))(minus r s))")


; First, we need to prove that the additive inverse is unique.
; x+y=0 -> x+z=0 -> y=z

(sg "all null,one,plus."
    PlusAxioms "->"
    "all r,s,t."
    "Equal (plus r s) null"
    "-> Equal (plus r t) null"
    "-> Equal s t")
(assume "null" "one" "plus"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "r" "s" "t" "*" "**")
(simp-with "<-" "PlusNeutral" (pt "s"))
(simp-with "<-" "**")
(simp-with "PlusComm" (pt "r") (pt "t"))
(simp-with "<-" "PlusAssoc" (pt "t") (pt "r") (pt "s"))
(simp "*")
(simp "PlusComm")
(simp "PlusNeutral")
(use "Eq-Refl")
; Proof finished.
(save "UniqueInverse")

(define (inst-UniqueInverse r s t x)
  (inst-with-to "UniqueInverse"
		(pt "null")
		(pt "one")
		(pt "plus")
		"PlusAssoc" "PlusNeutral" "PlusComm"
		r s t x))

; Next lemma: the inverse function is a additive morphism.
; -(x+y) = (-x)+(-y)

(sg "all null,one,plus,neg."
    PlusAxioms "->"
    NegativeLemma2 "->"
    "all r,s."
    "Equal (neg (plus r s)) (plus (neg r) (neg s))")
(assume "null" "one" "plus" "neg"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "NegativeLemma2"
        "r" "s")
(inst-UniqueInverse
 (pt "plus r s")
 (pt "neg(plus r s)")
 (pt "plus(neg r)(neg s)")
 "!")
(use "!")
(simp "NegativeLemma2")
(use "Eq-Refl")
(simp-with "PlusAssoc"
	   (pt "plus r s")
	   (pt "neg r")
	   (pt "neg s"))
(simp-with "PlusComm"
	   (pt "r")
	   (pt "s"))
(simp-with "<-" "PlusAssoc"
	   (pt "s")
	   (pt "r")
	   (pt "neg r"))
(simp "NegativeLemma2")
(simp-with "PlusComm"
	   (pt "s")
	   (pt "null"))
(simp "PlusNeutral")
(simp "NegativeLemma2")
(use "Eq-Refl")
; Proof finished.
(save "NegativeLemma2Hom")

(define (inst-NegativeLemma2Hom r s x)
  (inst-with-to "NegativeLemma2Hom"
		(pt "null")
		(pt "one")
		(pt "plus")
		(pt "neg")
		"PlusAssoc" "PlusNeutral"
		"PlusComm" "NegativeLemma2"
		r s x))

; Next lemma:
; We can extend an equation by adding the same term to both sides.
; x = y -> x+z = y+z

(sg "all plus,r,s,t."
    "Equal r s"
    "-> Equal (plus r t) (plus s t)")
(assume "plus" "r" "s" "t" "*")
(inst-with-to
 "Eq-Compat"
 (make-cterm
  (pv "al")
  (pf "Equal (plus r t) (plus al t)"))
 (pt "r")
 (pt "s")
 "**")
(use "**")
(use "*")
(use "Eq-Refl")
; Proof finished.
(save "ExtendByAddition")

(define (inst-ExtendByAddition r s t x)
  (inst-with-to "ExtendByAddition"
		(pt "plus") r s t x))

; We can cancel terms if they are added to both sides.
; Note that now we need some ring axioms, and the
; desired property of the inverse function.
; x+z = y+z -> x = y

(sg "all null,one,plus,neg."
    PlusAxioms "->"
    NegativeLemma2 "->"
    "all r,s,t."
    "Equal (plus r t) (plus s t)"
    "-> Equal r s")
(assume "null" "one" "plus" "neg"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "NegativeLemma2"
	"r" "s" "t" "*")
(inst-with-to
 "Eq-Compat"
 (make-cterm
  (pv "al")
  (pf "Equal r (plus (neg t) al)"))
 (pt "plus r t")
 (pt "plus s t")
 "**")
(simp-with "<-" "PlusNeutral"
	   (pt "s"))
(simp-with "<-" "NegativeLemma2"
	   (pt "t"))
(simp-with "PlusComm"
	   (pt "t")
	   (pt "neg t"))
(simp "<-" "PlusAssoc")
(simp-with "PlusComm"
	   (pt "t")
	   (pt "s"))
(use "**")
(use "*")
(simp "PlusAssoc")
(simp-with "PlusComm"
	   (pt "neg t")
	   (pt "r"))
(simp "<-" "PlusAssoc")
(simp-with "PlusComm"
	   (pt "neg t")
	   (pt "t"))
(simp "NegativeLemma2")
(simp-with "PlusComm"
	   (pt "r")
	   (pt "null"))
(simp "PlusNeutral")
(use "Eq-Refl")
; Proof finished.
(save "CancelEqualAddition")

(define (inst-CancelEqualAddition r s t x)
  (inst-with-to
   "CancelEqualAddition"
   (pt "null")
   (pt "one")
   (pt "plus")
   (pt "neg")
   "PlusAssoc" "PlusNeutral"
   "PlusComm" "NegativeLemma2"
   r s t x))

; Lemma: x*0 = 0

(sg "all null,one,plus,times,neg."
    PlusAxioms "->"
    DistrAxiom "->"
    NegativeLemma2 "->"
    "all r. Equal (times r null) null")
(assume "null" "one" "plus" "times" "neg"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "Distr" "NegativeLemma2" "r")
(drop)
(inst-CancelEqualAddition
 (pt "times r null")
 (pt "null")
 (pt "times r null")
 "*")
(use "*")
(simp "<-" "Distr")
(simp "PlusNeutral")
(simp "PlusNeutral")
(use "Eq-Refl")
; Proof finished.
(save "TimesZeroEqualsZero")

(define (inst-TimesZeroEqualsZero r x)
  (inst-with-to
   "TimesZeroEqualsZero"
   (pt "null")
   (pt "one")
   (pt "plus")
   (pt "times")
   (pt "neg")
   "PlusAssoc" "PlusNeutral"
   "PlusComm" "Distr" "NegativeLemma2"
   r x))


; Lemma: -(x*y) = -x*y

(sg "all null,one,plus,times,neg."
    SemiRingAxioms "->"
    NegativeLemma2 "->"
    "all r,s."
    "Equal (neg (times r s))"
    "(times (neg r) s)")
(assume "null" "one" "plus" "times" "neg"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "TimesAssoc"
	"TimesNeutral" "TimesComm" 
	"Distr" "NegativeLemma2" "r" "s")
(drop)
(inst-UniqueInverse
 (pt "times r s")
 (pt "neg(times r s)")
 (pt "times(neg r)s")
 "*")
(use "*")
(simp "NegativeLemma2")
(use "Eq-Refl")
(simp-with "TimesComm"
	   (pt "r")
	   (pt "s"))
(simp-with "TimesComm"
	   (pt "neg r")
	   (pt "s"))
(simp "<-" "Distr")
(simp "NegativeLemma2")
(inst-TimesZeroEqualsZero
 (pt "s")
 "**")
(use "**")
; Proof finished.
(save "SplitNegativeLemma2")

(define (inst-SplitNegativeLemma2 r s x)
  (inst-with-to
   "SplitNegativeLemma2"
   (pt "null")
   (pt "one")
   (pt "plus")
   (pt "times")
   (pt "neg")
   "PlusAssoc" "PlusNeutral"
   "PlusComm" "TimesAssoc"
   "TimesNeutral" "TimesComm" 
   "Distr" "NegativeLemma2"
   r s x))


; Lemma 1
; --------

(sg "all null,one,plus,minus,times,expon,neg."
    SemiRingAxioms "->"
    NegativeLemma2 "->"
    Sub "->"
    "all rs,i."
    "Equal"
    "((EvalExprES alpha)null plus minus times expon i rs)"
    "((EvalExprE alpha)null plus times expon"
    "((ElimSub alpha)one neg i) rs)")
(assume "null" "one" "plus" "minus" "times" "expon" "neg"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "TimesAssoc"
	"TimesNeutral" "TimesComm" 
	"Distr" "NegativeLemma2" "SubLemma")
(drop)
(assume "rs")
(ind)
(assume "n" "p")
(ng)
(use "Eq-Refl")
(assume "r")
(ng)
(use "Eq-Refl")
(assume "i" "j" "IH1" "IH2")
(ng)
(simp "IH1")
(simp "IH2")
(use "Eq-Refl")
(assume "i" "j" "IH1" "IH2")
(ng)
(simp "IH1")
(simp "IH2")
(use "Eq-Refl")
(assume "i" "p" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
(assume "i" "j" "IH1" "IH2")
(ng)
(simp-with
 "<-" "SubLemma"
 (pt "((EvalExprES alpha)null plus minus times expon i rs)")
 (pt "((EvalExprES alpha)null plus minus times expon j rs)"))
(simp "IH1")
(simp "IH2")
(ng)
(inst-SplitNegativeLemma2
 (pt "one")
 (pt "((EvalExprE alpha)null plus times expon
         ((ElimSub alpha)one neg j)rs)")
 "!")
(simp "<-" "!")
(simp "TimesNeutral")
(use "Eq-Refl")
; Proof finished.
(save "Lemma1")

(define (inst-Lemma1 r s x)
  (inst-with-to
   "Lemma1"
   (pt "null")
   (pt "one")
   (pt "plus")
   (pt "minus")
   (pt "times")
   (pt "expon")
   (pt "neg")
   "PlusAssoc" "PlusNeutral"
   "PlusComm" "TimesAssoc"
   "TimesNeutral" "TimesComm" 
   "Distr" "NegativeLemma2" "SubLemma"
   r s x))


; Pos Lemma 1
; -----------

(sg "all p.Equal(SZero p)(p+p)")
(ind)
(ng)
(use "Eq-Refl")
(assume "p" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
(assume "p" "IH")
(ng)
(simp "<-" "IH")
(ng)
(use "Eq-Refl")
; Proof finished.
(save "PosLemma1")

; Pos Lemma 2
; -----------

(sg "all p.Equal(SOne p)(p+p+1)")
(ind)
(ng)
(use "Eq-Refl")
(assume "p" "IH")
(ng)
(simp-with "PosLemma1" (pt "p"))
(use "Eq-Refl")
(assume "p" "IH")
(ng)
(simp "<-" "IH")
(use "Eq-Refl")
; Proof finished.
(save "PosLemma2")


; Lemma 2
; -------

(sg "all null,one,plus,times,expon."
    ExpLemma1 "->"
    ExpLemma2 "->"
    "all rs,g."
    "Equal"
    "((EvalExprE alpha)null plus times expon g rs)"
    "((EvalExpr alpha)null plus times expon"
    "((ExpUnfold alpha)g)rs)")
(assume "null" "one" "plus" "times" "expon"
	"ExpLemma1" "ExpLemma2")
(drop)
(assume "rs")
(ind)
(s)
(s)
(assume "g" "h" "IH1" "IH2")
(ng)
(simp "IH1")
(simp "IH2")
(s)
(assume "g" "h" "IH1" "IH2")
(ng)
(simp "IH1")
(simp "IH2")
(s)
(assume "g")
(ind)
(assume "IH")
(ng)
(simp "IH")
(ng)
(simp "ExpLemma2")
(s)
(assume "p" "IH1" "IH2")
(ng)
(inst-with-to "IH1" "IH2" "*")
(simp "<-" "*")
(simp-with "PosLemma1" (pt "p"))
(simp-with
 "ExpLemma1"
 (pt "((EvalExprE alpha)null plus times expon g rs)")
 (pt "p")
 (pt "p"))
(s)
(assume "p" "IH1" "IH2")
(ng)
(inst-with-to "IH1" "IH2" "*")
(simp "<-" "*")
(simp-with "PosLemma2" (pt "p"))
(inst-with-to
 "ExpLemma1"
 (pt "((EvalExprE alpha)null plus times expon g rs)")
 (pt "p+p")
 (pt "1") "**")
(simp "<-" "**")
(simp-with
 "ExpLemma1"
 (pt "((EvalExprE alpha)null plus times expon g rs)")
 (pt "p")
 (pt "p"))
(drop "**")
(simp "IH2")
(ng)
(simp-with
 "ExpLemma2"
 (pt "((EvalExpr alpha)null plus times expon((ExpUnfold alpha)g)rs)"))
(s)
; Proof finished.
(save "Lemma2")

(define (inst-Lemma2 r s x)
  (inst-with-to
   "Lemma2"
   (pt "null")
   (pt "one")
   (pt "plus")
   (pt "times")
   (pt "expon")
   "ExpLemma1" "ExpLemma2"
   r s x))


; Lemma 3
; -------

(sg "all null,plus,times,expon."
    ExpLemma2 "->"
    "all rs,r,p."
    "Equal"
    "((EvalExpr alpha)null plus times expon"
    "((Var alpha)Zero p)(r::rs))"
    "(expon r p)")
(assume "null" "plus" "times" "expon" "ExpLemma2"
	"rs" "r")
(cases)
(ng)
(simp-with "ExpLemma2" (pt "r"))
(s)
(s)
(s)
; Proof finished.
(save "Lemma3")

(define (inst-Lemma3 r s t x)
  (inst-with-to
   "Lemma3"
   (pt "null")
   (pt "plus")
   (pt "times")
   (pt "expon")
   "ExpLemma2"
   r s t x))


(aga
 "Lemma4"
 (pf
  (string-append
   "all null,one,plus,times,expon."
   SemiRingAxioms "->"
   ExpLemma2 "->"
   "all e,rs."
   "Equal"
   "((EvalExpr alpha)null plus times expon e rs)"
   "((EvalListMon alpha)null plus times expon"
   "((ExprToMonList alpha) one times e)rs)")))

(aga
 "Lemma5"
 (pf
  (string-append
   "all null,one,plus,times,expon."
   SemiRingAxioms "->"
   ExpLemma2 "->"
   "all ms,rs."
   "Equal"
   "((EvalListMon alpha)null plus times expon ms rs)"
   "((EvalListMon alpha)null plus times expon"
   "((OrderVars alpha) ms)rs)")))

(aga
 "Lemma6"
 (pf
  (string-append
   "all null,one,plus,times,expon."
   SemiRingAxioms "->"
   ExpLemma2 "->"
   "all ms,rs."
   "Equal"
   "((EvalListMon alpha)null plus times expon ms rs)"
   "((EvalListMon alpha)null plus times expon"
   "((SortListOfMonomials alpha) ms)rs)")))

(aga
 "Lemma7"
 (pf
  (string-append
   "all null,one,plus,times,expon."
   SemiRingAxioms "->"
   ExpLemma2 "->"
   "all ms,rs."
   "Equal"
   "((EvalListMon alpha)null plus times expon ms rs)"
   "((EvalListMon alpha)null plus times expon"
   "((UnifyMonomials alpha)plus ms)rs)")))

#| First try for a proof of Lemma 7

(sg "all null,one,plus,times,expon."
    SemiRingAxioms "->"
    ExpLemma2 "->"
    "all rs,vs,r,s."
    "Equal"
    "((EvalListVar alpha)null times expon vs rs (times r s))"
    "(times r ((EvalListVar alpha)null times expon vs rs s))")
(assume "null" "one" "plus" "times" "expon"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "TimesAssoc"
	"TimesNeutral" "TimesComm" 
	"Distr" "ExpLemma2")
(drop "PlusAssoc" "PlusNeutral"
      "PlusComm" "TimesAssoc"
      "TimesNeutral" "TimesComm"
      "Distr" "ExpLemma2")
(assume "rs")
(ind)
(strip)
(ng)
(use "Eq-Refl")
(ng)
(cases)
(assume "n" "p" "vs" "IH" "r" "s")
(ng)
(simp-with "IH"
	   (pt "times r s")
	   (pt "((EvalVar alpha)null expon n p rs)"))
(simp-with "IH"
	   (pt "s")
	   (pt "((EvalVar alpha)null expon n p rs)"))
(simp "TimesAssoc")
(use "Eq-Refl")
(save "LemmaAux7")


(sg "all null,one,plus,times,expon."
    SemiRingAxioms "->"
    ExpLemma2 "->"
    "all rs,vs,r,s."
    "Equal"
    "((EvalListVar alpha)null times expon vs rs(plus r s))"
    "(plus((EvalListVar alpha)null times expon vs rs r)"
    "((EvalListVar alpha)null times expon vs rs s))")


(sg "all null,one,plus,times,expon."
    SemiRingAxioms "->"
    ExpLemma2 "->"
    "all rs,r,s,vs."
    "Equal"
    "((EvalMon alpha)null times expon"
    "((Mo alpha)(plus r s)vs)rs)"
    "(plus((EvalMon alpha)null times expon ((Mo alpha)r vs) rs)"
    "((EvalMon alpha)null times expon ((Mo alpha)s vs) rs))")

(sg "all null,one,plus,times,expon."
    SemiRingAxioms "->"
    ExpLemma2 "->"
    "all rs,ms,m."
    "Equal"
    "((EvalListMon alpha)null plus times expon"
    "((UnifyMonomials alpha)plus(m::ms))rs)"
    "(plus((EvalMon alpha)null times expon m rs)"
    "((EvalListMon alpha)null plus times expon"
    "((UnifyMonomials alpha)plus ms)rs))")

(sg "all null,one,plus,times,expon."
    SemiRingAxioms "->"
    ExpLemma2 "->"
    "all rs,ms."
    "Equal"
    "((EvalListMon alpha)null plus times expon ms rs)"
    "((EvalListMon alpha)null plus times expon"
    "((UnifyMonomials alpha)plus ms)rs)")

|#


; Theorem EvalSort for Rings

(sg "all null,one,plus,minus,times,expon,neg."
    SemiRingAxioms "->"
    ExpLemma1 "->"
    ExpLemma2 "->"
    Sub "->"
    NegativeLemma2 "->"
    "all list alpha,exprES alpha.Equal"
    "((EvalListMon alpha)null plus times expon"
    "((NormalizeExprES alpha)one plus times neg "
    "exprES alpha)list alpha)"
    "((EvalExprES alpha)null plus minus times expon "
    "exprES alpha list alpha)")
(assume "null" "one" "plus" "minus"
	"times" "expon" "neg"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "TimesAssoc"
	"TimesNeutral" "TimesComm" 
	"Distr" "ExpLemma1" "ExpLemma2"
	"SubLemma" "NegativeLemma2"
	"rs" "i")
(drop)
(ng)
(simp-with
 "<-" "Lemma7"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((SortListOfMonomials alpha)"
   "((OrderVars alpha)"
   "((ExprToMonList alpha)one times"
   "((ExpUnfold alpha)"
   "((ElimSub alpha)one neg "
   "i)))))"))
 (pt "rs"))
(simp-with
 "<-" "Lemma6"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((OrderVars alpha)"
   "((ExprToMonList alpha)one times"
   "((ExpUnfold alpha)"
   "((ElimSub alpha)one neg "
   "i))))"))
 (pt "rs"))
(simp-with
 "<-" "Lemma5"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((ExprToMonList alpha)one times"
   "((ExpUnfold alpha)"
   "((ElimSub alpha)one neg "
   "i)))"))
 (pt "rs"))
(simp-with
 "<-" "Lemma4"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((ExpUnfold alpha)"
   "((ElimSub alpha)one neg "
   "i))"))
 (pt "rs"))
(inst-Lemma2
 (pt "rs")
 (pt 
  (string-append
   "((ElimSub alpha)one neg i)"))
 "!")
(simp "<-" "!")
(drop "!")
(inst-Lemma1
 (pt "rs")
 (pt "i")
 "!!")
(simp "<-" "!!")
(use "Eq-Refl")
; Proof finished.
(save "EvalSortRing")

;(set! COMMENT-FLAG #t)
;(cdp)


; Theorem EvalSortSemiRing

(sg "all null,one,plus,times,expon."
    SemiRingAxioms "->"
    ExpLemma1 "->"
    ExpLemma2 "->"
    "all list alpha,exprE alpha.Equal"
    "((EvalListMon alpha)null plus times expon"
    "((NormalizeExprE alpha)one plus times "
    "exprE alpha)list alpha)"
    "((EvalExprE alpha)null plus times expon "
    "exprE alpha list alpha)")
(assume "null" "one" "plus"
	"times" "expon"
	"PlusAssoc" "PlusNeutral"
	"PlusComm" "TimesAssoc"
	"TimesNeutral" "TimesComm" 
	"Distr" "ExpLemma1" "ExpLemma2"
	"rs" "g")
(drop)
(ng)
(simp-with
 "<-" "Lemma7"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((SortListOfMonomials alpha)"
   "((OrderVars alpha)"
   "((ExprToMonList alpha)one times"
   "((ExpUnfold alpha)"
   "g))))"))
 (pt "rs"))
(simp-with
 "<-" "Lemma6"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((OrderVars alpha)"
   "((ExprToMonList alpha)one times"
   "((ExpUnfold alpha)"
   "g)))"))
 (pt "rs"))
(simp-with
 "<-" "Lemma5"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((ExprToMonList alpha)one times"
   "((ExpUnfold alpha)"
   "g))"))
 (pt "rs"))
(simp-with
 "<-" "Lemma4"
 (pt "null")(pt "one")(pt "plus")
 (pt "times")(pt "expon")
 "PlusAssoc" "PlusNeutral"
 "PlusComm" "TimesAssoc"
 "TimesNeutral" "TimesComm" 
 "Distr" "ExpLemma2"
 (pt 
  (string-append
   "((ExpUnfold alpha)"
   "g)"))
 (pt "rs"))
(inst-Lemma2
 (pt "rs")
 (pt "g")
 "!")
(simp "<-" "!")
(use "Eq-Refl")
; Proof finished.
(save "EvalSortSemiRing")


;Theorem EvalSortLeftRing

(aga
 "EvalSortLeftRing"
 (pf
  (string-append
   "all null,one,plus,minus,times,expon,neg,rel."
   SemiRingAxioms "->"
   ExpLemma1 "->"
   ExpLemma2 "->"
   Sub "->"
   NegativeLemma2 "->"
   NegativeLemma1 "->"
   "all list alpha,(exprES alpha)^1,(exprES alpha)^2."
   "rel"
   "((EvalListMon alpha)null plus times expon"
   "((NormalizeExprESLeft alpha)one plus times neg "
   "(exprES alpha)^1 (exprES alpha)^2)list alpha)"
   "null"
   "->"
   "rel"
   "((EvalExprES alpha)null plus minus times expon "
   "(exprES alpha)^1 list alpha)"
   "((EvalExprES alpha)null plus minus times expon "
   "(exprES alpha)^2 list alpha)")))

;TODO: EvalSortLeftField

(aga
 "EvalSortField"
 (pf
  (string-append
   "all null,one,plus,minus,times,div,expon,neg."
   SemiRingAxioms "->"
   ExpLemma1 "->"
   ExpLemma2 "->"
   Sub "->"
   NegativeLemma2 "->"
   "all list alpha,exprESD alpha.Equal"
   "((EvalPairListMon alpha)null plus minus"
   " times div expon"
   "((NormalizeExprESD alpha)one plus times neg"
   " exprESD alpha)"
   "list alpha)"
   "((EvalExprESD alpha)null plus minus times"
   " div expon "
   "exprESD alpha list alpha)")))

(rv "al" "als" "rel"
    "n" "m" "i" "j" "k" "l" "p" "q"
    "r" "s" "t" "rs"
    "e" "f" "g" "h"
    "null" "one" "plus" "minus" "times" "div"
    "expon" "eq" "neg"
    "ms" "v" "vs" "msp")

; return to the original state of variable declarations
; (taken from numbers.scm)
(add-var-name "n" "m" "k" "l" "p" "q" (py "pos"))
(add-var-name "i" "j" (py "int"))
(add-var-name "a" "b" "c" "d" (py "rat"))




;===================================================================
; 6. ADDITIONAL PREPARATION OF PROOFS
;===================================================================

(define (BinaryBooleCompat-proof term3 term1 term4 term2 const-term)
  (let ((type1 (term-to-type term1))
        (type2 (term-to-type term2))
        (type3 (term-to-type term3))
        (type4 (term-to-type term4)))
    (if (and (equal? type1 type3)(equal? type2 type4))
        (mk-proof-in-elim-form
         (proof-subst
          (proof-subst
           (make-proof-in-aconst-form
            (theorem-name-to-aconst "alphaBinaryBooleCompat"))
           (py "alpha1") type1)
          (py "alpha2") type2)
         term3 term1 term4 term2 const-term)
        (myerror "BinaryBooleCompat-proof" "types do not fit"))))


(define (EqCompatArityTwo-proof term1 term2 term3 term4 predicate)
  (let ((type1 (term-to-type term1))
        (type2 (term-to-type term2))
        (type3 (term-to-type term3))
        (type4 (term-to-type term4)))
    (if (and (equal? type1 type2)(equal? type3 type4))
	(let* ((var1 (type-to-new-var type1))
	       (var2 (type-to-new-var type3))
	       (ct (make-cterm
		    var1 var2
		    (make-predicate-formula
		     predicate
		     (make-term-in-var-form var1)
		     (make-term-in-var-form var2))))
	       (p1
		(proof-subst
		 (proof-subst
		  (make-proof-in-aconst-form
		   (theorem-name-to-aconst "EqCompatArityTwo"))
		  (py "alpha1") type1)
		 (py "alpha2") type3))
	       (fml1 (proof-to-formula p1))
	       (predvar
		(predicate-form-to-predicate
		 (imp-form-to-conclusion
		  (imp-form-to-conclusion
		   (imp-form-to-conclusion
		    (allnc-form-to-kernel
		     (allnc-form-to-kernel
		      (allnc-form-to-kernel
		       (allnc-form-to-kernel
			fml1))))))))))
	  (proof-subst
	   (mk-proof-in-elim-form
	    p1 term1 term2 term3 term4)
	   predvar ct))
        (myerror "EqCompatArityTwo-proof" "types do not fit"))))


(define (constr-substitute-alpha name ring)
  (make-term-in-const-form
   (let* ((constr (constr-name-to-constr name))
	  (tvars (const-to-tvars constr)))
     (if (not (= 1 (length tvars)))
	 (myerror "constr-substitute-alpha"
		  "more than one tvar in type of constructor"
		  name)
	 (let ((subst (make-substitution tvars (list ring))))
	   (const-substitute constr subst #f))))))

(define (pconst-substitute-alpha name ring)
  (make-term-in-const-form
   (let* ((pconst (pconst-name-to-pconst name))
	  (tvars (const-to-tvars pconst)))
     (if (not (= 1 (length tvars)))
	 (myerror "pconst-substitute-alpha"
		  "more than one tvar in type of constructor"
		  name)
	 (let ((subst (make-substitution tvars (list ring))))
	   (const-substitute pconst subst #f))))))

(define (sort-and-evaluate-expr-e env exprE type)
  (display-debug "sort-and-evaluate-expr-e")
  (let* ((null (get-null type))
	 (one (get-one type))
	 (plus (get-plus type))
	 (times (get-times type))
	 (exp (get-exp type)))
    (nt
     (mk-term-in-app-form
      (pconst-substitute-alpha "EvalListMon" type)
      null
      plus
      times
      exp
      (mk-term-in-app-form
       (pconst-substitute-alpha "NormalizeExprE" type)
       one
       plus
       times
       exprE)
      env))))

(define (sort-and-evaluate-expr-es env exprES type)
  (display-debug "sort-and-evalute-expr-es")
  (let* ((null (get-null type))
	 (one (get-one type))
	 (plus (get-plus type))
	 (times (get-times type))
	 (exp (get-exp type))
	 (negative (get-negative type)))
    (nt
     (mk-term-in-app-form
      (pconst-substitute-alpha "EvalListMon" type)
      null
      plus
      times
      exp
      (mk-term-in-app-form
       (pconst-substitute-alpha "NormalizeExprES" type)
       one
       plus
       times
       negative
       exprES)
      env))))

(define (sort-and-evaluate-expr-esd env exprESD type)
  (display-debug "sort-and-evalute-expr-esd")
  (let* ((null (get-null type))
	 (one (get-one type))
	 (plus (get-plus type))
	 (times (get-times type))
	 (exp (get-exp type))
	 (minus (get-minus type))
	 (negative (get-negative type))
	 (div (get-div type)))
    (nt
     (mk-term-in-app-form
      (pconst-substitute-alpha "EvalPairListMon" type)
      null
      plus
      minus
      times
      div
      exp
      (mk-term-in-app-form
       (pconst-substitute-alpha "NormalizeExprESD" type)
       one
       plus
       times
       negative
       exprESD)
      env))))


(define (evaluate-expr env expr type)
  (display-debug "evaluate-expr")
  (let* ((null (get-null type))
	 (plus (get-plus type))
	 (times (get-times type))
	 (exp (get-exp type)))
    (mk-term-in-app-form
     (pconst-substitute-alpha "EvalExpr" type)
     null
     plus
     times
     exp
     expr
     env)))

(define (evaluate-expr-e env exprE type)
  (display-debug "evaluate-expr-e")
  (let* ((null (get-null type))
	 (plus (get-plus type))
	 (times (get-times type))
	 (exp (get-exp type)))
    (mk-term-in-app-form
     (pconst-substitute-alpha "EvalExprE" type)
     null
     plus
     times
     exp
     exprE
     env)))

(define (evaluate-expr-es env exprES type)
  (display-debug "evaluate-expr-es")
  (let* ((null (get-null type))
	 (plus (get-plus type))
	 (minus (get-minus type))
	 (times (get-times type))
	 (exp (get-exp type)))
    (mk-term-in-app-form
     (pconst-substitute-alpha "EvalExprES" type)
     null
     plus
     minus
     times
     exp
     exprES
     env)))

(define (evaluate-expr-esd env exprESD type)
  (display-debug "evaluate-expr-esd")
  (let* ((null (get-null type))
	 (plus (get-plus type))
	 (minus (get-minus type))
	 (times (get-times type))
	 (exp (get-exp type))
	 (div (get-div type)))
    (mk-term-in-app-form
     (pconst-substitute-alpha "EvalExprESD" type)
     null
     plus
     minus
     times
     div
     exp
     exprESD
     env)))

(define (evaluate-list-mon env expr type)
  (display-debug "evaluate-list-mon")
  (let* ((null (get-null type))
	 (plus (get-plus type))
	 (times (get-times type))
	 (exp (get-exp type)))
    (mk-term-in-app-form
     (pconst-substitute-alpha "EvalListMon" type)
     null
     plus
     times
     exp
     expr
     env)))

; proof preparation

; for semi-rings: r=s -> t=u -> P r t -> P s u
; with maybe different types of s and u (but both semi-rings)

(define (EvalSortSemiRingPredicate-final-proof
	 predicate env1 env2 expr1 expr2 ty1 ty2)
  (display-debug "EvalSortSemiRingPredicate-final-proof.")
  (let* ((ve1 (evaluate-expr-e env1 expr1 ty1))
	 (ve2 (evaluate-expr-e env2 expr2 ty2 alist))
	 (vse1 (sort-and-evaluate-expr-e env1 expr1 ty1))
	 (vse2 (sort-and-evaluate-expr-e env2 expr2 ty2)))
    (mk-proof-in-elim-form
     (EqCompatArityTwo-proof vse1 ve1 vse2 ve2 predicate)
     (EvalSortSemiRing-proof env1 expr1 ty1)
     (EvalSortSemiRing-proof env2 expr2 ty2))))

; the same for rings: r=s -> t=u -> P r t -> P s u

(define (EvalSortRingPredicate-final-proof
	 predicate env1 env2 expr1 expr2 ty1 ty2)
  (display-debug "EvalSortRingPredicate-final-proof.")
  (let* ((ve1 (evaluate-expr-es env1 expr1 ty1))
	 (ve2 (evaluate-expr-es env2 expr2 ty2))
	 (vse1 (sort-and-evaluate-expr-es env1 expr1 ty1))
	 (vse2 (sort-and-evaluate-expr-es env2 expr2 ty2)))
    (mk-proof-in-elim-form
     (EqCompatArityTwo-proof vse1 ve1 vse2 ve2 predicate)
     (EvalSortRing-proof env1 expr1 ty1)
     (EvalSortRing-proof env2 expr2 ty2))))

; finally for fields: r=s -> t=u -> P r t -> P s u

(define (EvalSortFieldPredicate-final-proof
	 predicate env1 env2 expr1 expr2 ty1 ty2)
  (display-debug "EvalSortFieldPredicate-final-proof.")
  (let* ((ve1 (evaluate-expr-esd env1 expr1 ty1))
	 (ve2 (evaluate-expr-esd env2 expr2 ty2))
	 (vse1 (sort-and-evaluate-expr-esd env1 expr1 ty1))
	 (vse2 (sort-and-evaluate-expr-esd env2 expr2 ty2)))
    (mk-proof-in-elim-form
     (EqCompatArityTwo-proof vse1 ve1 vse2 ve2 predicate)
     (EvalSortField-proof env1 expr1 ty1)
     (EvalSortField-proof env2 expr2 ty2))))

; let < be a function of type tau=>tau=>boole (written infix),
; then we have a proof r=s -> t=u -> r<s -> t<u

(define (EvalSortSemiRingBoole-final-proof
	 rel env expr1 expr2 type)
  (display-debug "EvalSortSemiRingBoole-final-proof.")
  (let* ((ve1 (evaluate-expr-e env expr1 type))
	 (ve2 (evaluate-expr-e env expr2 type))
	 (vse1 (sort-and-evaluate-expr-e env expr1 type))
	 (vse2 (sort-and-evaluate-expr-e env expr2 type)))
    (mk-proof-in-elim-form
     (BinaryBooleCompat-proof vse1 ve1 vse2 ve2 rel)
     (EvalSortSemiRing-proof env expr1 type)
     (EvalSortSemiRing-proof env expr2 type))))

(define (EvalSortRingBoole-final-proof
	 rel env expr1 expr2 type)
  (display-debug "EvalSortRingBoole-final-proof.")
  (let* ((ve1 (evaluate-expr-es env expr1 type))
	 (ve2 (evaluate-expr-es env expr2 type))
	 (vse1 (sort-and-evaluate-expr-es env expr1 type))
	 (vse2 (sort-and-evaluate-expr-es env expr2 type)))
    (mk-proof-in-elim-form
     (BinaryBooleCompat-proof vse1 ve1 vse2 ve2 rel)
     (EvalSortRing-proof env expr1 type)
     (EvalSortRing-proof env expr2 type))))

(define (EvalSortFieldBoole-final-proof rel env expr1 expr2 type)
  (display-debug "EvalSortFieldBoole-final-proof.")
  (let* ((ve1 (evaluate-expr-esd env expr1 type))
	 (ve2 (evaluate-expr-esd env expr2 type))
	 (vse1 (sort-and-evaluate-expr-esd env expr1 type))
	 (vse2 (sort-and-evaluate-expr-esd env expr2 type)))
    (mk-proof-in-elim-form
     (BinaryBooleCompat-proof vse1 ve1 vse2 ve2 rel)
     (EvalSortField-proof env expr1 type)
     (EvalSortField-proof env expr2 type))))


; EvalSortLeftRing-final-proof gives back the proof of
; nf(r-s)<0 -> r<s   for < being a function of type tau=>tau=>boole

(define (EvalSortLeftRing-final-proof rel env expr1 expr2 type)
  (display-debug "EvalSortLeftRing-proof.")
  (let* ((const-term? (get-const-term? type))
	 (null (get-null type))
	 (one (get-one type))
	 (plus (get-plus type))
	 (minus (get-minus type))
	 (times (get-times type))
	 (exp (get-exp type))
	 (negative (get-negative type))
	 (PlusAssoc (get-PlusAssoc type))
	 (PlusNeutral (get-PlusNeutral type))
	 (PlusComm (get-PlusComm type))
	 (TimesAssoc (get-TimesAssoc type))
	 (TimesNeutral (get-TimesNeutral type))
	 (TimesComm (get-TimesComm type))
	 (Distr (get-Distr type))
	 (MinusLemma (get-MinusLemma type))
	 (NegativeLemma1 (get-NegativeLemma1 type))
	 (NegativeLemma2 (get-NegativeLemma2 type))
	 (expLemma1 (get-ExpLemma1 type))
	 (expLemma2 (get-ExpLemma2 type))
	 (expLemma3 (get-ExpLemma3 type)))
    (mk-proof-in-elim-form
     (proof-subst
      (make-proof-in-aconst-form 
       (global-assumption-name-to-aconst "EvalSortLeftRing"))
      (py "alpha")
      type)
     null one plus minus times exp negative rel
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       Distr))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma1))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma2))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       MinusLemma))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       NegativeLemma2))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       NegativeLemma1))
     env expr1 expr2)))

; r=nf(r) for r semi-ring term
; (nf = normalform)

(define (EvalSortSemiRing-proof env expr type)
  (display-debug "EvalSortSemiRing-proof.")
  (let* ((const-term? (get-const-term? type))
	 (null (get-null type))
	 (one (get-one type))
	 (plus (get-plus type))
	 (times (get-times type))
	 (exp (get-exp type))
	 (PlusAssoc (get-PlusAssoc type))
	 (PlusNeutral (get-PlusNeutral type))
	 (PlusComm (get-PlusComm type))
	 (TimesAssoc (get-TimesAssoc type))
	 (TimesNeutral (get-TimesNeutral type))
	 (TimesComm (get-TimesComm type))
	 (Distr (get-Distr type))
	 (expLemma1 (get-ExpLemma1 type))
	 (expLemma2 (get-ExpLemma2 type))
	 (expLemma3 (get-ExpLemma3 type)))
    (mk-proof-in-elim-form
     (proof-subst
      (make-proof-in-aconst-form
       (theorem-or-global-assumption-name-to-aconst
	"EvalSortSemiRing"))
      (py "alpha")
      type)
     null one plus times exp
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       Distr))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma1))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma2))
     env expr)))

; r=nf(r) for r ring term

(define (EvalSortRing-proof env expr type)
  (display-debug "EvalSortRing-proof.")
  (let* ((const-term? (get-const-term? type))
	 (null (get-null type))
	 (one (get-one type))
	 (plus (get-plus type))
	 (minus (get-minus type))
	 (times (get-times type))
	 (exp (get-exp type))
	 (negative (get-negative type))
	 (PlusAssoc (get-PlusAssoc type))
	 (PlusNeutral (get-PlusNeutral type))
	 (PlusComm (get-PlusComm type))
	 (TimesAssoc (get-TimesAssoc type))
	 (TimesNeutral (get-TimesNeutral type))
	 (TimesComm (get-TimesComm type))
	 (Distr (get-Distr type))
	 (MinusLemma (get-MinusLemma type))
	 (NegativeLemma2 (get-NegativeLemma2 type))
	 (expLemma1 (get-ExpLemma1 type))
	 (expLemma2 (get-ExpLemma2 type))
	 (expLemma3 (get-ExpLemma3 type)))
    (mk-proof-in-elim-form
     (proof-subst
      (make-proof-in-aconst-form
       (theorem-or-global-assumption-name-to-aconst
	"EvalSortRing"))
      (py "alpha")
      type)
     null one plus minus times exp negative
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       Distr))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma1))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma2))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       MinusLemma))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       NegativeLemma2))
     env expr)))


; r=nf(r) for r field term

(define (EvalSortField-proof env expr type)
  (display-debug "EvalSortField-proof.")
  (let* ((const-term? (get-const-term? type))
	 (null (get-null type))
	 (one (get-one type))
	 (plus (get-plus type))
	 (minus (get-minus type))
	 (times (get-times type))
	 (exp (get-exp type))
	 (negative (get-negative type))
	 (div (get-div type))
	 (PlusAssoc (get-PlusAssoc type))
	 (PlusNeutral (get-PlusNeutral type))
	 (PlusComm (get-PlusComm type))
	 (TimesAssoc (get-TimesAssoc type))
	 (TimesNeutral (get-TimesNeutral type))
	 (TimesComm (get-TimesComm type))
	 (Distr (get-Distr type))
	 (MinusLemma (get-MinusLemma type))
	 (NegativeLemma2 (get-NegativeLemma2 type))
	 (expLemma1 (get-ExpLemma1 type))
	 (expLemma2 (get-ExpLemma2 type))
	 (expLemma3 (get-ExpLemma3 type)))
    (mk-proof-in-elim-form
     (proof-subst
      (make-proof-in-aconst-form
       (theorem-or-global-assumption-name-to-aconst
	"EvalSortField"))
      (py "alpha")
      type)
     null one plus minus times div exp negative
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       PlusComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesAssoc))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesNeutral))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       TimesComm))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       Distr))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma1))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       expLemma2))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       MinusLemma))
     (make-proof-in-aconst-form
      (theorem-or-global-assumption-name-to-aconst
       NegativeLemma2))
     env expr)))


;===================================================================
; 7. FUNCTIONS FOR TRANSFERRING TERMS TO EXPRESSIONS
;===================================================================

(define (compare-const-name t u)
  (string=?
   (const-to-name
    (term-in-const-form-to-const t))
   (const-to-name
    (term-in-const-form-to-const
     (term-in-app-form-to-final-op u)))))

(define (semi-ring-term-and-env-to-linarith-expr-and-env
	 term env type plus times exp const-term?)
  (display-debug "semi-ring-term-and-env-to-linarith-expr-and-env")
  (if (not (equal? type (term-to-type term)))
      (myerror "semi-ring-term-and-env-to-linarith-expr-and-env"
	       "term of type "type" expected" term))
  (cond
   ((const-term? term)
    (list (mk-term-in-app-form
	   (constr-substitute-alpha "ConstE" type)
	   term) env))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name plus term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (semi-ring-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus times exp const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2 
	    (semi-ring-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus times exp const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "AddE" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name times term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (semi-ring-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus times exp const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2
	    (semi-ring-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus times exp const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "MultE" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name exp term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (semi-ring-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus times exp const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1)))
      (if (not (is-pos-numeric-term? arg2))
	  (let ((info (assoc-wrt term=? term env)))
	    (if info
		(list (mk-term-in-app-form
		       (constr-substitute-alpha "VarE" type)
		       (make-numeric-term-in-nat (cadr info))
		       (pt "One"))
		      env)
		(let* ((i (length env))
		       (var-expr
			(mk-term-in-app-form
			 (constr-substitute-alpha "VarE" type)
			 (make-numeric-term-in-nat i)
			 (pt "One"))))
		  (list var-expr
			(append env (list (list term i)))))))
	  (list (mk-term-in-app-form
		 (constr-substitute-alpha "Exp" type)
		 expr1 arg2) env1))))
;    ((and (term-in-app-form? term)
; 	 (term-in-const-form?
; 	  (term-in-app-form-to-final-op term))
; 	 (compare-const-name exp term)
; 	 (= 2 (length (term-in-app-form-to-args term))))
;     (let* ((kernel (term-in-app-form-to-args term))
; 	   (base (car kernel))
; 	   (exponent (cadr kernel))
; 	   (info (assoc-wrt term=? base env)))
;       (if info
; 	  (list (mk-term-in-app-form
; 		 (constr-substitute-alpha "VarE" type)
; 		 (make-numeric-term-in-nat (cadr info))
; 		 exponent)
; 		env)
; 	  (let* ((i (length env))
; 		 (var-expr
; 		  (mk-term-in-app-form
; 		   (constr-substitute-alpha "VarE" type)
; 		   (make-numeric-term-in-nat i)
; 		   exponent)))
; 	    (list var-expr (append env
; 				   (list (list base i))))))))
   (else
    (let ((info (assoc-wrt term=? term env)))
      (if info
	  (list (mk-term-in-app-form
		 (constr-substitute-alpha "VarE" type)
		 (make-numeric-term-in-nat (cadr info))
		 (pt "One"))
		env)
	  (let* ((i (length env))
		 (var-expr
		  (mk-term-in-app-form
		   (constr-substitute-alpha "VarE" type)
		   (make-numeric-term-in-nat i)
		   (pt "One"))))
	    (list var-expr (append env
				   (list (list term i))))))))))

(define (semi-ring-term-to-linarith-expr-and-env
	 term type plus times exp const-term?)
  (display-debug "semi-ring-term-to-linarith-expr-and-env.")
  (semi-ring-term-and-env-to-linarith-expr-and-env
   term '() type plus times exp const-term?))

(define (ring-term-and-env-to-linarith-expr-and-env
	 term env type plus minus times exp const-term?)
  (display-debug "ring-term-and-env-to-linarith-expr-and-env")
  (if (not (equal? type (term-to-type term)))
      (myerror "ring-term-and-env-to-linarith-expr-and-env"
	       "term of type "type" expected" term))
  (cond
   ((const-term? term)
    (list (mk-term-in-app-form
	   (constr-substitute-alpha "ConstES" type)
	   term) env))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name plus term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (ring-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2 
	    (ring-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus minus times exp const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "AddES" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name minus term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (ring-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2 
	    (ring-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus minus times exp const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "Sub" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name times term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (ring-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2
	    (ring-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus minus times exp const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "MultES" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name exp term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (ring-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1)))
      (if (not (is-pos-numeric-term? arg2))
	  (let ((info (assoc-wrt term=? term env)))
	    (if info
		(list (mk-term-in-app-form
		       (constr-substitute-alpha "VarES" type)
		       (make-numeric-term-in-nat (cadr info))
		       (pt "One"))
		      env)
		(let* ((i (length env))
		       (var-expr
			(mk-term-in-app-form
			 (constr-substitute-alpha "VarES" type)
			 (make-numeric-term-in-nat i)
			 (pt "One"))))
		  (list var-expr 
			(append env (list (list term i)))))))
	  (list (mk-term-in-app-form
		 (constr-substitute-alpha "ExpS" type)
		 expr1 arg2) env1))))
;    ((and (term-in-app-form? term)
; 	 (term-in-const-form?
; 	  (term-in-app-form-to-final-op term))
; 	 (compare-const-name exp term)
; 	 (= 2 (length (term-in-app-form-to-args term))))
;     (let* ((kernel (term-in-app-form-to-args term))
; 	   (base (car kernel))
; 	   (exponent (cadr kernel))
; 	   (info (assoc-wrt term=? base env)))
;       (if info
; 	  (list (mk-term-in-app-form
; 		 (constr-substitute-alpha "VarES" type)
; 		 (make-numeric-term-in-nat (cadr info))
; 		 exponent)
; 		env)
; 	  (let* ((i (length env))
; 		 (var-expr
; 		  (mk-term-in-app-form
; 		   (constr-substitute-alpha "VarES" type)
; 		   (make-numeric-term-in-nat i)
; 		   exponent)))
; 	    (list var-expr (append env
; 				   (list (list base i))))))))
   (else
    (let ((info (assoc-wrt term=? term env)))
      (if info
	  (list (mk-term-in-app-form
		 (constr-substitute-alpha "VarES" type)
		 (make-numeric-term-in-nat (cadr info))
		 (pt "One"))
		env)
	  (let* ((i (length env))
		 (var-expr
		  (mk-term-in-app-form
		   (constr-substitute-alpha "VarES" type)
		   (make-numeric-term-in-nat i)
		   (pt "One"))))
	    (list var-expr
		  (append env (list (list term i))))))))))

(define (ring-term-to-linarith-expr-and-env
	 term type plus minus times exp const-term?)
  (display-debug "ring-term-to-linarith-expr-and-env.")
  (ring-term-and-env-to-linarith-expr-and-env
   term '() type plus minus times exp const-term?))

(define (field-term-and-env-to-linarith-expr-and-env
	 term env type plus minus times exp div const-term?)
  (display-debug "field-term-and-env-to-linarith-expr-and-env")
  (if (not (equal? type (term-to-type term)))
      (myerror "field-term-and-env-to-linarith-expr-and-env"
	       "term of type "type"expected" term))
  (cond
   ((const-term? term)
    (list (mk-term-in-app-form
	   (constr-substitute-alpha "ConstESD" type)
	   term) env))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name plus term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (field-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp div const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2 
	    (field-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus minus times exp 
	     div const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "AddESD" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name minus term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (field-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp
	     div const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2 
	    (field-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus minus times exp
	     div const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "SubD" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name times term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (field-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp 
	     div const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2
	    (field-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus minus times exp
	     div const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "MultESD" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name div term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (field-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp 
	     div const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2
	    (field-term-and-env-to-linarith-expr-and-env
	     arg2 env1 type plus minus times exp
	     div const-term?))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (constr-substitute-alpha "Div" type)
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (compare-const-name exp term)
	 (= 2 (length (term-in-app-form-to-args term))))
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 
	    (field-term-and-env-to-linarith-expr-and-env
	     arg1 env type plus minus times exp
	     div const-term?))
	   (expr1 (car prev1))
	   (env1 (cadr prev1)))
      (if (not (is-pos-numeric-term? arg2))
	  (let ((info (assoc-wrt term=? term env)))
	    (if info
		(list (mk-term-in-app-form
		       (constr-substitute-alpha "VarESD" type)
		       (make-numeric-term-in-nat (cadr info))
		       (pt "One"))
		      env)
		(let* ((i (length env))
		       (var-expr
			(mk-term-in-app-form
			 (constr-substitute-alpha "VarESD" type)
			 (make-numeric-term-in-nat i)
			 (pt "One"))))
		  (list var-expr
			(append env (list (list term i)))))))
	  (list (mk-term-in-app-form
		 (constr-substitute-alpha "ExpSD" type)
		 expr1 arg2) env1))))
   ; ((and (term-in-app-form? term)
; 	 (term-in-const-form?
; 	  (term-in-app-form-to-final-op term))
; 	 (compare-const-name exp term)
; 	 (= 2 (length (term-in-app-form-to-args term))))
;     (let* ((kernel (term-in-app-form-to-args term))
; 	   (base (car kernel))
; 	   (exponent (cadr kernel))
; 	   (info (assoc-wrt term=? base env)))
;       (if info
; 	  (list (mk-term-in-app-form
; 		 (constr-substitute-alpha "VarESD" field)
; 		 (make-numeric-term-in-nat (cadr info))
; 		 exponent)
; 		env)
; 	  (let* ((i (length env))
; 		 (var-expr
; 		  (mk-term-in-app-form
; 		   (constr-substitute-alpha "VarESD" field)
; 		   (make-numeric-term-in-nat i)
; 		   exponent)))
; 	    (list var-expr (append env
; 				   (list (list base i))))))))
   (else
    (let ((info (assoc-wrt term=? term env)))
      (if info
	  (list (mk-term-in-app-form
		 (constr-substitute-alpha "VarESD" type)
		 (make-numeric-term-in-nat (cadr info))
		 (pt "One"))
		env)
	  (let* ((i (length env))
		 (var-expr
		  (mk-term-in-app-form
		   (constr-substitute-alpha "VarESD" type)
		   (make-numeric-term-in-nat i)
		   (pt "One"))))
	    (list var-expr
		  (append env (list (list term i))))))))))

(define (field-term-to-linarith-expr-and-env
	 term type plus minus times exp div const-term?)
  (display-debug "field-term-to-linarith-expr-and-env")
  (field-term-and-env-to-linarith-expr-and-env
   term '() type plus minus times exp div const-term?))

; (terms-to-list-term .)
; builds up from a scheme (meta-)list of terms a list of terms.
(define (terms-to-list-term type terms)
    (if (null? terms)
	(constr-substitute-alpha "Nil" type)
        (mk-term-in-app-form
         (constr-substitute-alpha "Cons" type)
         (car terms)
         (terms-to-list-term type (cdr terms)))))


;===================================================================
; 8. REFLECTION TACTIC COMMANDS
;===================================================================

(define (already-initialised? type n)
  (if (not (assoc type INITIALISED-TYPES))
      (myerror "reflection for "type
	       "not initialised"))
  (let ((m (length (cadr (assoc type INITIALISED-TYPES)))))
    (if (not (<= n m))
	(let ((s (case m
		   ((3) "semi-ring")
		   ((4) "ring"))))
	  (myerror "reflection for "type
		   "already initialised, but only as "
		   s)))))

; (simp-semi-ring)

; for semi-rings: only atomic formulas can be handled
; (simplification for predicates could be implemented here as well)

(define (simp-semi-ring)
  (let ((goal-form (goal-to-formula (current-goal))))
    (if (formula=? (nf goal-form) (pt "F"))
	(myerror "simp-semi-ring"
		 "falsum is not provable"))
    (cond
     ((atom-form? goal-form)
      (display-debug "atom-form")
      (let* ((goal-term (atom-form-to-kernel goal-form))
	     (ty (term-to-type
		  (term-in-app-form-to-final-op goal-term))))
	(if (not (and (arrow-form? ty)
		      (arrow-form? (arrow-form-to-val-type ty))
		      (equal? (arrow-form-to-arg-type ty)
			      (arrow-form-to-arg-type
			       (arrow-form-to-val-type ty)))
		      (equal? (py "boole")
			      (arrow-form-to-val-type
			       (arrow-form-to-val-type ty)))))
	    (myerror "simp-semi-ring"
		     "term in atomic goal formula"
		     "does not have appropriate type"
		     ty))
	(let ((type (arrow-form-to-arg-type ty)))
	  (already-initialised? type 3)
	  (simp-semi-ring-intern goal-term type))))
     (else
      (myerror "simp-semi-ring"
	       "reflection for this kind of goal not yet implemented")))))

(define (simp-semi-ring-intern goal-kernel semi-ring)
  (display-debug "Going into simp-semi-ring-intern.")
  (let*
      ((num-goals (pproof-state-to-num-goals))
       (proof (pproof-state-to-proof))
       (maxgoal (pproof-state-to-maxgoal))
       (number (num-goal-to-number (car num-goals)))
       (pproof-state-after-reflection
	(apply
	 use-intern
	 (list num-goals proof maxgoal
	       (simp-semi-ring-intern-sort 
		goal-kernel semi-ring))))
       (normalized-goal (apply normalize-goal-intern
			       pproof-state-after-reflection))
       (ng-num-goals (car normalized-goal))
       (ng-proof (cadr normalized-goal))
       (ng-maxgoal (caddr normalized-goal))
       (ng-goal (num-goal-to-goal (car ng-num-goals)))
       (ng-goal-term (atom-form-to-kernel
		      (goal-to-formula ng-goal))))
    (if (term=? ng-goal-term (pt"True"))
	(let ((true-appl (apply use-intern
				(list ng-num-goals
				      ng-proof
				      ng-maxgoal
				      "Truth-Axiom"))))
	  (set! PPROOF-STATE true-appl))
	(set! PPROOF-STATE normalized-goal))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simp-semi-ring-intern-sort gt semi-ring)
  (display-debug "simp-semi-ring-intern-sort. gt: " (term-to-string gt))
  (let* 
      ((const-term? (get-const-term? semi-ring))
       (plus (get-plus semi-ring))
       (times (get-times semi-ring))
       (exp (get-exp semi-ring))
       (const-term (term-in-app-form-to-final-op gt))
       (args (term-in-app-form-to-args gt))
       (arg1 (car args))
       (arg2 (cadr args))
       (e1-and-env1
	(semi-ring-term-to-linarith-expr-and-env
	 arg1 semi-ring plus times exp const-term?))
       (e2-and-env2
	(semi-ring-term-and-env-to-linarith-expr-and-env
	 arg2 (cadr e1-and-env1) semi-ring plus times exp const-term?))
       (env (terms-to-list-term
	     semi-ring (map car(cadr e2-and-env2)))))
    (EvalSortSemiRingBoole-final-proof
     const-term env (car e1-and-env1) (car e2-and-env2) semi-ring)))


; (simp-ring . #t/#f)

(define (simp-ring . move-to-left?)
  (let ((goal-form (goal-to-formula (current-goal)))
	(flag (if (not (equal? '() move-to-left?))
		  (car move-to-left?)
		  #f)))
    (if (formula=? (nf goal-form) (pt "F"))
	(myerror "simp-ring"
		 "falsum is not provable"))
    (if (not (or (equal? #t flag) (equal? #f flag)))
	(myerror "simp-ring"
		 "optional flag not correct"))
    (cond
     ((atom-form? goal-form)
      (display-debug "atom-form")
      (let* ((goal-term (atom-form-to-kernel goal-form))
	     (ty (term-to-type
		  (term-in-app-form-to-final-op goal-term))))
	(if (not (and (arrow-form? ty)
		      (arrow-form? (arrow-form-to-val-type ty))
		      (equal? (arrow-form-to-arg-type ty)
			      (arrow-form-to-arg-type
			       (arrow-form-to-val-type ty)))
		      (equal? (py "boole")
			      (arrow-form-to-val-type
			       (arrow-form-to-val-type ty)))))
	    (myerror "simp-ring"
		     "term in atomic goal formula "
		     "does not have appropriate type"
		     ty))
	(let ((ring (arrow-form-to-arg-type ty)))
	  (already-initialised? ring 4)
	  (simp-ring-atomic-intern goal-term ring flag))))
     ((predicate-form? goal-form)
      (display-debug "predicate-form")
      (if (not(= 2 (length (predicate-form-to-args goal-form))))
	  (myerror "simp-ring"
		   "reflection is implemented only "
		   "for predicates with arity 2"))
      (let* ((args (predicate-form-to-args goal-form))
	     (t1 (car args))
	     (t2 (cadr args))
	     (ty1 (term-to-type t1))
	     (ty2 (term-to-type t2)))
	(already-initialised? ty1 4)
	(already-initialised? ty2 4)
	(simp-ring-predicate-intern goal-form)))
     (else
      (myerror "simp-ring"
	       "reflection cannot handle this kind of goal")))))
      
(define (simp-ring-predicate-intern goal-form)
  (display-debug "Going into simp-ring-predicate-intern.")
  (let*
      ((num-goals (pproof-state-to-num-goals))
       (proof (pproof-state-to-proof))
       (maxgoal (pproof-state-to-maxgoal))
       (number (num-goal-to-number (car num-goals)))
       (pproof-state-after-reflection
	(apply
	 use-intern
	 (list num-goals proof maxgoal
	       (simp-ring-predicate-intern-sort 
		goal-form))))
       (normalized-goal (apply normalize-goal-intern
			       pproof-state-after-reflection))
       (ng-num-goals (car normalized-goal))
       (ng-proof (cadr normalized-goal))
       (ng-maxgoal (caddr normalized-goal))
       (ng-goal (num-goal-to-goal (car ng-num-goals)))
       (ng-goal-form (goal-to-formula ng-goal)))
    (if (formula=? ng-goal-form (pf "T"))
	(let ((true-appl (apply use-intern
				(list ng-num-goals
				      ng-proof
				      ng-maxgoal
				      "Truth-Axiom"))))
	  (set! PPROOF-STATE true-appl))
	(set! PPROOF-STATE normalized-goal))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simp-ring-predicate-intern-sort gf)
  (display-debug "simp-ring-predicate-intern-sort: "
		 (formula-to-string gf))
  (let* 
      ((predicate (predicate-form-to-predicate gf))
       (args (predicate-form-to-args gf))
       (t1 (car args))
       (t2 (cadr args))
       (ty1 (term-to-type t1))
       (ty2 (term-to-type t2)))
    (if (equal? ty1 ty2)
	(let* ((const-term? (get-const-term? ty1))
	       (plus (get-plus ty1))
	       (minus (get-minus ty1))
	       (times (get-times ty1))
	       (exp (get-exp ty1))
	       (e1-and-env1
		(ring-term-to-linarith-expr-and-env
		 t1 ty1 plus minus times exp const-term?))
	       (e2-and-env2
		(ring-term-and-env-to-linarith-expr-and-env
		 t2 (cadr e1-and-env1) ty2 plus minus times exp const-term?))
	       (env (terms-to-list-term
		     ty1 (map car(cadr e2-and-env2)))))
	  (EvalSortRingPredicate-final-proof
	   predicate env env (car e1-and-env1) (car e2-and-env2) ty1 ty2))
	(let* 
	    ((const-term?1 (get-const-term? ty1))
	     (const-term?2 (get-const-term? ty2))
	     (plus1 (get-plus ty1))
	     (plus2 (get-plus ty2))
	     (minus1 (get-minus ty1))
	     (minus2 (get-minus ty2))
	     (times1 (get-times ty1))
	     (times2 (get-times ty2))
	     (exp1 (get-exp ty1))
	     (exp2 (get-exp ty2))
	     (e1-and-env1
	      (ring-term-to-linarith-expr-and-env
	       t1 ty1 plus1 minus1 times1 exp1 const-term?1))
	     (e2-and-env2
	      (ring-term-to-linarith-expr-and-env
	       t2 ty2 plus2 minus2 times2 exp2 const-term?2))
	     (env1 (terms-to-list-term
		    ty1 (map car(cadr e1-and-env1))))
	     (env2 (terms-to-list-term
		    ty2 (map car(cadr e2-and-env2)))))
	  (EvalSortRingPredicate-final-proof
	   predicate env1 env2 (car e1-and-env1) (car e2-and-env2) ty1 ty2)))))

(define (simp-ring-atomic-intern goal-kernel ring flag)
  (display-debug "Going into simp-ring-atomic-intern.")
  (let*
      ((num-goals (pproof-state-to-num-goals))
       (proof (pproof-state-to-proof))
       (maxgoal (pproof-state-to-maxgoal))
       (number (num-goal-to-number (car num-goals)))
       (pproof-state-after-reflection
	(if flag
	    (apply
	     use-intern
	     (list num-goals proof maxgoal
		   (simp-ring-atomic-intern-sortleft
		    goal-kernel ring)))
	    (apply
	     use-intern
	     (list num-goals proof maxgoal
		   (simp-ring-atomic-intern-sort
		    goal-kernel ring)))))
       (normalized-goal (apply normalize-goal-intern
			       pproof-state-after-reflection))
       (ng-num-goals (car normalized-goal))
       (ng-proof (cadr normalized-goal))
       (ng-maxgoal (caddr normalized-goal))
       (ng-goal (num-goal-to-goal (car ng-num-goals)))
       (ng-goal-term (atom-form-to-kernel
		      (goal-to-formula ng-goal))))
    (if (term=? ng-goal-term (pt"True"))
	(let ((true-appl (apply use-intern
				(list ng-num-goals
				      ng-proof
				      ng-maxgoal
				      "Truth-Axiom"))))
	  (set! PPROOF-STATE true-appl))
	(set! PPROOF-STATE normalized-goal))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simp-ring-atomic-intern-sort gt ring)
  (display-debug "simp-ring-intern-sort. gt: "
		 (term-to-string gt))
  (let* 
      ((const-term? (get-const-term? ring))
       (plus (get-plus ring))
       (minus (get-minus ring))
       (times (get-times ring))
       (exp (get-exp ring))
       (const-term (term-in-app-form-to-final-op gt))
       (args (term-in-app-form-to-args gt))
       (arg1 (car args))
       (arg2 (cadr args))
       (e1-and-env1
	(ring-term-to-linarith-expr-and-env
	 arg1 ring plus minus times exp const-term?))
       (e2-and-env2
	(ring-term-and-env-to-linarith-expr-and-env
	 arg2 (cadr e1-and-env1) ring plus minus times exp const-term?))
       (env (terms-to-list-term
	     ring (map car(cadr e2-and-env2)))))
    (EvalSortRingBoole-final-proof
     const-term env (car e1-and-env1) (car e2-and-env2) ring)))

(define (simp-ring-atomic-intern-sortleft gt ring)
  (display-debug "Going into simp-ring-intern-cancel. gt: "
		 (term-to-string gt))
  (let*
      ((const-term? (get-const-term? ring))
       (plus (get-plus ring))
       (minus (get-minus ring))
       (times (get-times ring))
       (exp (get-exp ring))
       (const-term (term-in-app-form-to-final-op gt))
       (args (term-in-app-form-to-args gt))
       (arg1 (car args))
       (arg2 (cadr args))
       (e1-and-env1
	(ring-term-to-linarith-expr-and-env
	 arg1 ring plus minus times exp const-term?))
       (e2-and-env2
	(ring-term-and-env-to-linarith-expr-and-env
	 arg2 (cadr e1-and-env1) ring plus minus times exp const-term?))
       (env (terms-to-list-term
	    ring (map car(cadr e2-and-env2)))))
    (EvalSortLeftRing-final-proof
     const-term env (car e1-and-env1) (car e2-and-env2) ring)))


; (simp-field)
; flag is currently disabled

(define (simp-field . move-to-left?)
  (let ((goal-form (goal-to-formula (current-goal)))
	(flag (if (not (null? move-to-left?))
		  (car move-to-left?)
		  #f)))
    (if (formula=? (nf goal-form) (pt "F"))
	(myerror "simp-ring"
		 "falsum is not provable"))
    (if (not (or (equal? #t flag) (equal? #f flag)))
	(myerror "simp-field"
		 "optional flag not correct"))
    (cond
     ((atom-form? goal-form)
      (display-debug "atom-form")
      (let* ((goal-term (atom-form-to-kernel goal-form))
	     (ty (term-to-type
		  (term-in-app-form-to-final-op goal-term))))
	(if (not (and (arrow-form? ty)
		      (arrow-form? (arrow-form-to-val-type ty))
		      (equal? (arrow-form-to-arg-type ty)
			      (arrow-form-to-arg-type
			       (arrow-form-to-val-type ty)))
		      (equal? (py "boole")
			      (arrow-form-to-val-type
			       (arrow-form-to-val-type ty)))))
	    (myerror "simp-field"
		     "term in atomic goal formula"
		     "does not have appropriate type"
		     ty))
	(let ((field (arrow-form-to-arg-type ty)))
	  (already-initialised? field 5)
	  (simp-field-atomic-intern goal-term field flag))))
     ((predicate-form? goal-form)
      (display-debug "predicate-form")
      (if (not(= 2 (length (predicate-form-to-args goal-form))))
	  (myerror "simp-field"
		   "reflection is implemented only"
		   " for predicates with arity 2"))
      (let* ((args (predicate-form-to-args goal-form))
	     (t1 (car args))
	     (t2 (cadr args))
	     (ty1 (term-to-type t1))
	     (ty2 (term-to-type t2)))
	(already-initialised? ty1 5)
	(already-initialised? ty2 5)
	(simp-field-predicate-intern goal-form)))
     (else
      (myerror "simp-field"
	       "reflection cannot handle this kind of goal")))))

(define (simp-field-atomic-intern goal-kernel field flag)
  (display-debug "Going into simp-field-atomic-intern.")
  (let*
      ((num-goals (pproof-state-to-num-goals))
       (proof (pproof-state-to-proof))
       (maxgoal (pproof-state-to-maxgoal))
       (number (num-goal-to-number (car num-goals)))
       (pproof-state-after-reflection
	(if flag
	    (apply
	     use-intern
	     (list num-goals proof maxgoal
		   (simp-field-atomic-intern-sortleft 
		    goal-kernel field)))
	    (apply
	     use-intern
	     (list num-goals proof maxgoal
		   (simp-field-atomic-intern-sort 
		    goal-kernel field)))))
       (normalized-goal (apply normalize-goal-intern
			       pproof-state-after-reflection))
       (ng-num-goals (car normalized-goal))
       (ng-proof (cadr normalized-goal))
       (ng-maxgoal (caddr normalized-goal))
       (ng-goal (num-goal-to-goal (car ng-num-goals)))
       (ng-goal-term (atom-form-to-kernel
		      (goal-to-formula ng-goal))))
    (if (term=? ng-goal-term (pt"True"))
	(let ((true-appl (apply use-intern
				(list ng-num-goals
				      ng-proof
				      ng-maxgoal
				      "Truth-Axiom"))))
	  (set! PPROOF-STATE true-appl))
	(set! PPROOF-STATE normalized-goal))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simp-field-atomic-intern-sort gt field)
  (display-debug "Going into simp-field-atomic-intern-sort")
  (let* 
      ((const-term? (get-const-term? field))
       (plus (get-plus field))
       (minus (get-minus field))
       (times (get-times field))
       (exp (get-exp field))
       (div (get-div field))
       (const-term (term-in-app-form-to-final-op gt))
       (args (term-in-app-form-to-args gt))
       (arg1 (car args))
       (arg2 (cadr args))
       (e1-and-env1
	(field-term-to-linarith-expr-and-env
	 arg1 field plus minus times exp div const-term?))
       (e2-and-env2
	(field-term-and-env-to-linarith-expr-and-env
	 arg2 (cadr e1-and-env1) field plus minus times exp div
	 const-term?))
       (env (terms-to-list-term
	    field (map car(cadr e2-and-env2)))))
    (EvalSortFieldBoole-final-proof
     const-term env (car e1-and-env1) (car e2-and-env2) field)))

(define (simp-field-atomic-intern-sortleft goalterm field)
  (myerror "simp-field-atomic-intern-sortleft"
	   "not yet implemented")
  (let*
      ((const-term? (get-const-term? field))
       (plus (get-plus field))
       (minus (get-minus field))
       (times (get-times field))
       (exp (get-exp field))
       (const-term (term-in-app-form-to-final-op goalterm))
       (args (term-in-app-form-to-args goalterm))
       (arg1 (car args))
       (arg2 (cadr args))
       (e1-and-env1
	(field-term-to-linarith-expr-and-env
	 arg1 field plus minus times exp const-term?))
       (e2-and-env2
	(field-term-and-env-to-linarith-expr-and-env
	 arg2 (cadr e1-and-env1) field plus minus times exp
	 const-term?))
       (ns (terms-to-list-term
	    field (map car(cadr e2-and-env2)))))
    (EvalSortLeftField-proof
     const-term env (car e1-and-env1) (car e2-and-env2) field)))

(define (simp-field-predicate-intern goal-form)
  (let*
      ((num-goals (pproof-state-to-num-goals))
       (proof (pproof-state-to-proof))
       (maxgoal (pproof-state-to-maxgoal))
       (number (num-goal-to-number (car num-goals)))
       (pproof-state-after-reflection
	(apply
	 use-intern
	 (list num-goals proof maxgoal
	       (simp-field-predicate-intern-sort 
		goal-form))))
       (normalized-goal (apply normalize-goal-intern
			       pproof-state-after-reflection))
       (ng-num-goals (car normalized-goal))
       (ng-proof (cadr normalized-goal))
       (ng-maxgoal (caddr normalized-goal))
       (ng-goal (num-goal-to-goal (car ng-num-goals)))
       (ng-goal-form (goal-to-formula ng-goal)))
    (if (formula=? ng-goal-form (pf "T"))
	(let ((true-appl (apply use-intern
				(list ng-num-goals
				      ng-proof
				      ng-maxgoal
				      "Truth-Axiom"))))
	  (set! PPROOF-STATE true-appl))
	(set! PPROOF-STATE normalized-goal))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simp-field-predicate-intern-sort gf)
  (display-debug "simp-field-predicate-intern-sort: "
		 (formula-to-string gf))
  (let* 
      ((predicate (predicate-form-to-predicate gf))
       (args (predicate-form-to-args gf))
       (t1 (car args))
       (t2 (cadr args))
       (ty1 (term-to-type t1))
       (ty2 (term-to-type t2)))
    (if (equal? ty1 ty2)
	(let* ((const-term? (get-const-term? ty1))
	       (plus (get-plus ty1))
	       (minus (get-minus ty1))
	       (times (get-times ty1))
	       (exp (get-exp ty1))
	       (div (get-div ty1))
	       (e1-and-env1
		(field-term-to-linarith-expr-and-env
		 t1 ty1 plus minus times exp div const-term?))
	       (e2-and-env2
		(field-term-and-env-to-linarith-expr-and-env
		 t2 (cadr e1-and-env1) ty2 plus minus times exp div
		 const-term?))
	       (env (terms-to-list-term
		     ty1 (map car(cadr e2-and-env2)))))
	  (EvalSortFieldPredicate-final-proof
	   predicate env env (car e1-and-env1) (car e2-and-env2) ty1 ty2))
	(let* 
	    ((const-term?1 (get-const-term? ty1))
	     (const-term?2 (get-const-term? ty2))
	     (plus1 (get-plus ty1))
	     (plus2 (get-plus ty2))
	     (minus1 (get-minus ty1))
	     (minus2 (get-minus ty2))
	     (times1 (get-times ty1))
	     (times2 (get-times ty2))
	     (exp1 (get-exp ty1))
	     (exp2 (get-exp ty2))
	     (div1 (get-div ty1))
	     (div2 (get-div ty2))
	     (e1-and-env1
	      (ring-term-to-linarith-expr-and-env
	       t1 ty1 plus1 minus1 times1 exp1 div1 const-term?1))
	     (e2-and-env2
	      (ring-term-to-linarith-expr-and-env
	       t2 ty2 plus2 minus2 times2 exp2 div2 const-term?2))
	     (env1 (terms-to-list-term
		    ty1 (map car(cadr e1-and-env1))))
	     (env2 (terms-to-list-term
		    ty2 (map car(cadr e2-and-env2)))))
	  (EvalSortFieldPredicate-final-proof
	   predicate env1 env2 (car e1-and-env1) (car e2-and-env2) ty1 ty2)))))



(set! COMMENT-FLAG #t)

;===================================================================
; 9. DEBUGGING
;===================================================================

; debug function for displaying all the normalization steps

(define (simp-ring-debug term)
  (let ((ring (term-to-type term)))
    (already-initialised? ring 4)
    (let*
	((const-term? (get-const-term? ring))
	 (null (get-null ring))
	 (one (get-one ring))
	 (plus (get-plus ring))
	 (negative (get-negative ring))
	 (minus (get-minus ring))
	 (times (get-times ring))
	 (exp (get-exp ring))
	 (const-term (term-in-app-form-to-final-op term))
	 (e (ring-term-to-linarith-expr-and-env
	     term ring plus minus times exp const-term?))
	 (expr (car e))
	 (env (terms-to-list-term ring (map car (cadr e))))
	 (e1e
	  (nt (evaluate-expr-es env expr ring)))
	 (e2
	  (mk-term-in-app-form
	   (pconst-substitute-alpha "ElimSub" ring)
	   one
	   negative
	   expr))
	 (e2e (nt (evaluate-expr-e env e2 ring)))
	 (e3 (mk-term-in-app-form
	      (pconst-substitute-alpha "ExpUnfold" ring)
	      e2))
	 (e3e (nt (evaluate-expr env e3 ring)))
	 (e4 (mk-term-in-app-form
	      (pconst-substitute-alpha "ExprToMonList" ring)
	      one times e3))
	 (e4e (nt (evaluate-list-mon env e4 ring)))
	 (e5 (mk-term-in-app-form
	      (pconst-substitute-alpha "OrderVars" ring)
	      e4))
	 (e5e (nt (evaluate-list-mon env e5 ring)))
	 (e6 (mk-term-in-app-form
	      (pconst-substitute-alpha "SortListOfMonomials" ring)
	      e5))
	 (e6e (nt (evaluate-list-mon env e6 ring)))
	 (e7 (mk-term-in-app-form
	      (pconst-substitute-alpha "UnifyMonomials" ring)
	      plus e6))
	 (e7e (nt (evaluate-list-mon env e7 ring))))
      (newline)
      (display "---------------------------")(newline)
      (display "Reflection Debug")(newline)
      (display "---------------------------")(newline)
      (display "  Term                       : ")
      (pp term)
      (display "  Expression                 : ")
      (pp expr)
      (display "  Environment                : ")
      (pp env)
      (display "  Evaluated Expression       : ")
      (pp e1e)
      (display "  After 'ElimSub'            : ")
      (pp e2e)
      (display "  After 'ExpUnfold'          : ")
      (pp e3e)
      (display "  After 'ExprToMonList'      : ")
      (pp e4e)
      (display "  After 'OrderVars'          : ")
      (pp e5e)
      (display "  After 'SortListOfMonomials : ")
      (pp e6e)
      (display "  After 'UnifyMonomials'     : ")
      (pp e7e)
      )))


;===================================================================
; 10. COMMON (SEMI-)RINGS AND FIELDS
;===================================================================

; We provide functions to initialise reflection for
; the usual rings, namely nat, int, rat, real

(define (prepare-simp-semi-ring-for-nat)
  (begin
    (aga "NatPlusAssoc" 
	 (pf "all nat1,nat2,nat3.Equal(NatPlus nat1 (NatPlus nat2 nat3))(NatPlus (NatPlus nat1 nat2) nat3)"))
    (aga "NatPlusNeutral"
	 (pf "all nat.Equal(NatPlus Zero nat)nat"))
    (aga "NatPlusCommNew"
	 (pf "all nat1,nat2.Equal(NatPlus nat1 nat2)(NatPlus nat2 nat1)"))
    (aga "NatTimesAssoc"
	 (pf "all nat1,nat2,nat3.Equal(NatTimes nat1 (NatTimes nat2 nat3))(NatTimes (NatTimes nat1 nat2) nat3)"))
    (aga "NatTimesNeutral" 
	 (pf "all nat.Equal(NatTimes (Succ(Zero)) nat)nat"))
    (aga "NatTimesCommNew" 
	 (pf "all nat1,nat2.Equal(NatTimes nat1 nat2)(NatTimes nat2 nat1)"))
    (aga "NatDistr"  
	 (pf "all nat1,nat2,nat3.Equal(NatTimes nat1 (NatPlus nat2 nat3))(NatPlus (NatTimes nat1 nat2) (NatTimes nat1 nat3))"))
    (add-program-constant "NatExp" (py "nat=>pos=>nat") 1 'const 2)
    (add-computation-rule (pt "NatExp nat One") (pt "nat"))
    (aga "NatExpLemma1"
	 (pf "all nat,pos1,pos2.
              Equal(NatTimes(NatExp nat pos1)(NatExp nat pos2))
                   (NatExp nat (pos1+pos2))"))
    (aga "NatExpLemma2"
	 (pf "all nat.Equal(NatExp nat One)nat"))
    (aga "NatExpLemma3"
	 (pf "all nat,pos1,pos2.
              Equal(NatExp (NatExp nat pos1) pos2)
                   (NatExp nat (pos1+pos2))"))
    (prepare-simp-semi-ring
     (py "nat")
     is-numeric-term-in-nat?
     (pt "Zero")
     (pt "Succ Zero")
     (pt "NatPlus")
     (pt "NatTimes")
     (pt "NatExp")
     "NatExpLemma1"
     "NatExpLemma2"
     "NatExpLemma3"
     "NatPlusAssoc"
     "NatPlusNeutral"
     "NatPlusCommNew"
     "NatTimesAssoc"
     "NatTimesNeutral"
     "NatTimesCommNew"
     "NatDistr")))

(define (prepare-simp-ring-for-int)
  (aga "IntPlusAssoc"
       (pf "all i1,i2,i3.Equal(i1+(i2+i3))((i1+i2)+i3)"))
  (aga "IntPlusNeutral"
       (pf "all i.Equal(IntZero+i)i"))
  (aga "IntPlusComm"
       (pf "all i1,i2.Equal(i1+i2)(i2+i1)"))  
  (aga "IntTimesAssoc"  
       (pf "all i1,i2,i3.Equal(i1*(i2*i3))((i1*i2)*i3)"))
  (aga "IntTimesNeutral"
       (pf "all i.Equal((IntPos One)*i)i"))
  (aga "IntTimesComm"
       (pf "all i1,i2.Equal(i1*i2)(i2*i1)"))
  (aga "IntDistr"
       (pf "all i1,i2,i3.Equal(i1*(i2+i3))((i1*i2)+(i1*i3))"))
  (aga "IntExpLemma1"
       (pf "all i,pos1,pos2.
              Equal((exp i pos1)*(exp i pos2))
                   (exp i (pos1+pos2))"))
  (aga "IntExpLemma2"
       (pf "all i.Equal(exp i One)i"))
  (aga "IntExpLemma3"
       (pf "all i,pos1,pos2.
              Equal(exp (exp i pos1) pos2)
                   (exp i (pos1+pos2))"))
  (add-program-constant "IntPlusInverse" (py "int=>int") 1)
  (acrs
   "IntPlusInverse IntZero" "IntZero"
   "IntPlusInverse (IntPos pos)" "IntNeg pos"
   "IntPlusInverse (IntNeg pos)" "IntPos pos")
  (aga "IntNegativeLemma1"
       (pf "all i1,i2. i1 + (IntPlusInverse i2) = IntZero -> i1 = i2"))
  (aga "IntNegativeLemma2"
       (pf "all i. Equal (i + (IntPlusInverse i)) IntZero"))
  (aga "IntMinusLemma"
       (pf "all i1,i2. Equal (i1 + (IntPlusInverse i2)) (i1 - i2)"))
  (prepare-simp-ring (py "int")
		     is-int-numeric-term?
		     (pt "IntZero")
		     (pt "IntPos One")
		     (pt "IntPlus")
		     (pt "IntTimes")
		     (pt "IntExp")
		     "IntExpLemma1"
		     "IntExpLemma2"
		     "IntExpLemma3"
		     "IntPlusAssoc" "IntPlusNeutral" "IntPlusComm"
		     "IntTimesAssoc" "IntTimesNeutral" "IntTimesComm"
		     "IntDistr"
		     (pt "IntMinus")
		     (pt "IntPlusInverse")
		     "IntNegativeLemma1"
		     "IntNegativeLemma2"
		     "IntMinusLemma"))


; 2007-03-05
; There are different representations for 'equal' terms (e.g. for 0,1),
; and they are not equal in the sense of 'Equal' used within reflection.
; (Reflection simplifies terms by using compatibility of Equal.)

; (define (prepare-simp-field-for-rat)
;   (aga "RatPlusAssoc"
;        (pf "all rat1,rat2,rat3.Equal(rat1+(rat2+rat3))((rat1+rat2)+rat3)"))
;   (aga "RatPlusNeutral"
;        (pf "all rat.Equal((IntZero#1)+rat)rat"))
;   (aga "RatPlusComm"
;        (pf "all rat1,rat2.Equal(rat1+rat2)(rat2+rat1)"))  
;   (aga "RatTimesAssoc"  
;        (pf "all rat1,rat2,rat3.Equal(rat1*(rat2*rat3))((rat1*rat2)*rat3)"))
;   (aga "RatTimesNeutral"
;        (pf "all rat.Equal(((IntP One)#1)*rat)rat"))
;   (aga "RatTimesComm"
;        (pf "all rat1,rat2.Equal(rat1*rat2)(rat2*rat1)"))
;   (aga "RatDistr"
;        (pf "all rat1,rat2,rat3.Equal(rat1*(rat2+rat3))((rat1*rat2)+(rat1*rat3))"))
;   (aga "RatExpLemma1"
;        (pf "all rat,pos1,pos2.
;               Equal((exp rat pos1)*(exp rat pos2))
;                    (exp rat (pos1+pos2))"))
;   (aga "RatExpLemma2"
;        (pf "all rat.Equal(exp rat One)rat"))
;   (aga "RatExpLemma3"
;        (pf "all rat,pos1,pos2.
;               Equal(exp (exp rat pos1) pos2)
;                    (exp rat (pos1+pos2))"))
;   (add-program-constant "RatPlusInverse" (py "rat=>rat") 1)
;   (acrs
;    "RatPlusInverse (IntZero#1)" "IntZero#1"
;    "RatPlusInverse ((IntP pos)#1)" "(IntN pos)#1"
;    "RatPlusInverse ((IntN pos)#1)" "(IntP pos)#1")
;   (aga "RatPlusInverseCorrect"
;        (pf "all rat. Equal (rat + (RatPlusInverse rat)) (IntZero#1)"))
;   (aga "RatRelInverseCompat"
;        (pf "all rat1,rat2. rat1 + (RatPlusInverse rat2) = (IntZero#1) -> rat1 = rat2"))
;   (aga "RatSubL"
;        (pf "all rat1,rat2. Equal (rat1 + (RatPlusInverse rat2)) (rat1 - rat2)"))
;   (prepare-simp-field
;    (py "rat")
;    is-int-numeric-term?
;    (pt "IntZero#1")
;    (pt "(IntP One)#1")
;    (pt "RatPlus")
;    (pt "RatTimes")
;    (pt "RatExp")
;    "RatExpLemma1"
;    "RatExpLemma2"
;    "RatExpLemma3"
;    "RatPlusAssoc" "RatPlusNeutral" "RatPlusComm"
;    "RatTimesAssoc" "RatTimesNeutral" "RatTimesComm"
;    "RatDistr"
;    (pt "RatMinus")
;    (pt "RatPlusInverse")
;    "RatRelInverseCompat"
;    "RatPlusInverseCorrect"
;    "RatSubL"
;    (pt "RatDiv")))


; (define (prepare-simp-field-for-real)
;   (rv "x")
;   (av "x" (py "real"))
;   (aga "RealPlusAssoc"
;        (pf "all x1,x2,x3.Equal(x1+(x2+x3))((x1+x2)+x3)"))
;   (aga "RealPlusNeutral"
;        (pf "all x.Equal
;            ((RealConstr([pos](IntZero#1))([pos]One))+x)x"))
;   (aga "RealPlusComm"
;        (pf "all x1,x2.Equal(x1+x2)(x2+x1)"))  
;   (aga "RealTimesAssoc"  
;        (pf "all x1,x2,x3.Equal(x1*(x2*x3))((x1*x2)*x3)"))
;   (aga "RealTimesNeutral"
;        (pf "all x.Equal((RealConstr([pos](IntP One)#1)([pos]One))*x)x"))
;   (aga "RealTimesComm"
;        (pf "all x1,x2.Equal(x1*x2)(x2*x1)"))
;   (aga "RealDistr"
;        (pf "all x1,x2,x3.Equal(x1*(x2+x3))((x1*x2)+(x1*x3))"))
;   (aga "RealExpLemma1"
;        (pf "all x,pos1,pos2.
;               Equal((exp x pos1)*(exp x pos2))
;                    (exp x (pos1+pos2))"))
;   (aga "RealExpLemma2"
;        (pf "all x.Equal(exp x One)x"))
;   (aga "RealExpLemma3"
;        (pf "all x,pos1,pos2.
;               Equal(exp (exp x pos1) pos2)
;                    (exp x (pos1+pos2))"))
;   (add-program-constant "RealPlusInverse" (py "real=>real") 1)
;   (add-computation-rule
;    (pt "RealPlusInverse(RealConstr as M)")
;    (pt "RealConstr ([pos]((IntZero#1)-(as pos))) M"))
;   (aga "RealPlusInverseCorrect"
;        (pf "all x. Equal (x + (RealPlusInverse x)) (RealConstr([pos](IntZero#1))([pos]One))"))
;   (aga "RealRelInverseCompat"
;        (pf "all x1,x2. Equal (x1 + (RealPlusInverse x2)) (RealConstr([pos](IntZero#1))([pos]One)) -> Equal x1 x2"))
;   (aga "RealSubL"
;        (pf "all x1,x2. Equal (x1 + (RealPlusInverse x2)) (x1 - x2)"))
;   (prepare-simp-field
;    (py "real")
;    is-real-numeric-term?
;    (pt "RealConstr([pos](IntZero#1))([pos]One)")
;    (pt "RealConstr([pos](IntP One)#1)([pos]One)")
;    (pt "RealPlus")
;    (pt "RealTimes")
;    (pt "RealExp")
;    "RealExpLemma1"
;    "RealExpLemma2"
;    "RealExpLemma3"
;    "RealPlusAssoc" "RealPlusNeutral" "RealPlusComm"
;    "RealTimesAssoc" "RealTimesNeutral" "RealTimesComm"
;    "RealDistr"
;    (pt "RealMinus")
;    (pt "RealPlusInverse")
;    "RealPlusInverseCorrect"
;    "RealRelInverseCompat"
;    "RealSubL"
;    (pt "RealDiv")))


;===================================================================
; 11. EXAMPLES
;===================================================================


#| Examples

(set! COMMENT-FLAG #t)

(prepare-simp-semi-ring-for-nat)

(prepare-simp-ring-for-int)

;(prepare-simp-field-for-rat)

;(prepare-simp-field-for-real)


(display-reflection-types)



;(set! DEBUG-FLAG #t)
(set! DEBUG-FLAG #f)


; debug test
(simp-ring-debug (pt "x+y+exp x 2"))

(simp-ring-debug (pt "rat+(RatExp int 2)"))
(simp-ring-debug (pt "rat+(IntExp int 2)"))

(simp-ring-debug (pt "exp int pos"))

(simp-ring-debug (pt "exp (i1 + i2) 2"))
(simp-ring-debug (pt "exp (i1 + i2) pos"))

(simp-ring-debug (pt "2*i1*i2*i3"))


; some examples, how to use the simp command

(sg "NatPlus nat1 nat2 = NatPlus nat2 nat1")
(strip)
(ng)
(simp-semi-ring)

(sg "NatLe(NatExp nat 8)(NatTimes(NatExp nat 3)(NatPlus (NatExp nat2
7)(NatExp nat 2)))")
(strip)
(simp-semi-ring)

(sg "i1+i2 = i2+i1")
(strip)
(ng)
;nothing changes
(simp-ring)
;(simp-semi-ring)
; Proof finished.
(cdp)
; OK.

(sg "i1+5*i2=2*i2+i1")
(strip)
(simp-ring #f)
; ok, ?_2 can be obtained from
; ?_4: i1+5*i2=i1+2*i2 from
;   i1  i2

(sg "i1+5*i2=2*i2+i1")
(strip)
(simp-ring #t)
; ok, ?_2 can be obtained from
; ?_4: 3*i2=0 from
;   i1  i2

(sg "exp (i1 + i2) 2 =  exp i1 2 + exp i2 2 + 2*i1*i2")
(strip)
(simp-ring)
; Proof finished.
(cdp)
; OK.

(sg "2*exp i 3 + 3*exp i 3 = 6")
(strip)
(simp-ring)
; ok, ?_2 can be obtained from
; ?_4: 5*exp i 3=6 from
;   i

(sg "3+(181+i2)*i3+2+i1*i3*2+2*i2
     = 2*i2+i3*(171+i2+i1*2)+5+10*i3")
(strip)
(simp-ring)
; Proof finished.

(sg "3+i*4 = i+2+i*3+1")
(strip)
(simp-semi-ring) ;simp-semi-ring suffices here (no subtraction present)
; Proof finished.

(sg "15*i1-4*exp i2 2*i1+4*(exp i2 2+5+i1)*i1 = i1*(35 + 4*i1)")
(strip)
(simp-ring)
; Proof finished.

(sg "exp i1 2-exp i1 2=0")
(strip)
(simp-ring)
; Proof finished.

; Predicates

(add-predconst-name "A" (make-arity (py "int") (py "int")))

(set-goal (pf "A (i1+i2) (i3+i2+exp i1 2)"))
(strip)
(simp-ring)
(cdp)


(add-predconst-name "B" (make-arity (py "nat") (py "int")))

(set-goal (pf "B (nat) (i3+i2+exp i1 2)"))
(strip)
(simp-ring) ; nat not a ring


; 2007-03-05 
; see comment in section 10.

; ; field: real

; (set! COMMENT-FLAG #f)
; (rv "k" "n" "m")
; (av "k" "n" "m" (py "pos"))
; (exload "analysis/simpreal.scm")
; (exload "analysis/real.scm")
; (set! COMMENT-FLAG #t)

; (sg "x+y===y+x")
; (strip)
; (simp-ring)


; (sg "x+y+exp y 4===y+x+exp x 2")
; (strip)
; (simp-ring)


; (add-program-constant "TestReal" (py "real=>real=>boole"))

; (sg "TestReal (x+y) (y+x)")
; (strip)
; (simp-field)

; (add-rewrite-rule
;  (pt "(RealConstr([pos]1#1)([pos]One))*x")
;  (pt "x"))

; (ng)

|#

;===================================================================
; END OF FILE
;===================================================================
