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

; (load "~/minlog/init.scm")

#| Reflection for Rationals

A more complete documentation will follow.

Overview:

1.  Loading of Resources
2.  Preparing Reflection for Usage
3.  General Program-Constants for Insert-Sort
4.  Algebra expr with Program-Const. for Sort & Simplification
5.  Proofs for EvalSort and EvalCancel
6.  Additional Preparation of both Proofs
7.  Functions for Transferring Ring Terms into the Meta-Level
8.  Function for Sorting Expressions
9.  Reflection Tactic Command
10. Examples

|#


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

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

(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))))

(exload "ordinals/nat.scm")
(libload "list.scm")
(srcload "unicode.scm") ; optional
(exload "ordinals/reflection_thms.scm")
(remove-nat-tokens)
(remove-var-name "n" "m" "k")
(libload "numbers.scm")
(remove-var-name "n" "m" "k")
(av "n" "m" "k" (py "nat"))

#| In reflection_thms.scm we have shown the following theorems:

(display-theorems "BooleTrue")
; boole -> True=boole & boole=True
(display-theorems "alphaFunctional")
; (alpha1=>alpha2)_2≈(alpha1=>alpha2)_1 -> (alpha1)_2≈(alpha1)_1
;   -> (alpha1=>alpha2)_1(alpha1)_1≈(alpha1=>alpha2)_2(alpha1)_2
(display-theorems "alphaBinaryBooleFunctional")
; (alpha1)_3≈(alpha1)_1 -> (alpha2)_4≈(alpha2)_2
; -> alpha1=>alpha2=>boole(alpha1)_1(alpha2)_2
;                     = alpha1=>alpha2=>boole(alpha1)_3(alpha2)_4
(display-theorems "alphaBinaryBooleCompat")
; (alpha1)_3≈(alpha1)_1 -> (alpha2)_4≈(alpha2)_2
; -> alpha1=>alpha2=>boole(alpha1)_3(alpha2)_4
; -> alpha1=>alpha2=>boole(alpha1)_1(alpha2)_2

|#

;===================================================================
; 2. ALGEBRA EXPR WITH PROGRAM-CONST. FOR SORTING & SIMPLIFICATION
;===================================================================

; 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 compare function for the
; elements. 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 relation).
(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 relation 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))")

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

(add-alg "posexp"
	 '("P" "pos=>posexp")
	 '("V" "nat=>posexp")
	 '("A" "posexp=>posexp=>posexp")
	 '("Ti" "posexp=>posexp=>posexp"))

(add-alg "exprES"
	 '("IntES" "int=>exprES")
	 '("VarES" "nat=>posexp=>exprES")
	 '("AddES" "exprES=>exprES=>exprES")
	 '("MultES" "exprES=>exprES=>exprES")
	 '("DivES" "exprES=>exprES=>exprES")
	 '("ExpS" "exprES=>posexp=>exprES")
         '("Sub" "exprES=>exprES=>exprES"))

(add-alg "exprE"
	 '("IntE" "int=>exprE")
	 '("VarE" "nat=>posexp=>exprE")
	 '("AddE" "exprE=>exprE=>exprE")
	 '("MultE" "exprE=>exprE=>exprE")
	 '("DivE" "exprE=>exprE=>exprE")
	 '("Exp" "exprE=>posexp=>exprE"))

(add-alg "expr"
	 '("Int" "int=>expr")
	 '("Var" "nat=>posexp=>expr")
	 '("Add" "expr=>expr=>expr")
	 '("Mult" "expr=>expr=>expr")
	 '("Div" "expr=>expr=>expr"))

(add-alg "posmon"
	 '("PosMon" "pos=>list nat=>posmon"))

(add-alg "factor"
	 '("FactorConstr" "int=>factor"))

(add-alg "variable"
	 '("VarConstr" "nat=>list posmon=>variable"))

(add-alg "monomial"
	 '("MonomialConstr" "factor=>list variable=>monomial"))


(av "rs" (py "list rat"))
(av "ns" (py "list nat"))
(av "r" (py "rat"))
(av "pexp" (py "posexp"))
(av "ps" (py "list pos"))
(av "p" (py "pos"))
(av "pmon" (py "posmon"))
(av "pmons" (py "list posmon"))
(av "lms" (py "list monomial"))
(av "lmspair" (py "list monomial@@list monomial"))
(av "mon" (py "monomial"))
(av "fac" (py "factor"))
(av "lvs" (py "list variable"))
(av "var" "v" (py "variable"))
(av "mms" (py "monomial@@list monomial"))

; evaluation functions

; on algebra posexp

(add-program-constant "EvalPosexp" (py "posexp=>list pos=>pos") 1)

(acrs
 "EvalPosexp (P pos) ps"
   "pos"
 "EvalPosexp (V Zero) (p::ps)"
   "p"
 "EvalPosexp (V (Succ nat)) (p::ps)"
   "EvalPosexp (V nat) ps"
 "EvalPosexp (A pexp1 pexp2) ps"
   "PosPlus (EvalPosexp pexp1 ps) (EvalPosexp pexp2 ps)"
 "EvalPosexp (Ti pexp1 pexp2) ps"
   "PosTimes (EvalPosexp pexp1 ps) (EvalPosexp pexp1 ps)")


; evaluation for type list pmon and pmon

(add-program-constant "EvalPosMon" (py "posmon=>list pos=>pos") 1)
(add-program-constant "EvalPosMonAux" (py "list nat=>list pos=>pos") 1)
(add-program-constant "EvalPosMonAuxTwo" (py "nat=>list pos=>pos") 1)
(add-program-constant "EvalListPosMon" (py "list posmon=>list pos=>pos") 1)

(acrs
 "EvalPosMon (PosMon p (Nil nat)) ps"
   "p"
 "EvalPosMon (PosMon p (n::ns)) ps"
   "PosTimes p (EvalPosMonAux (n::ns) ps)"
 "EvalPosMonAux (n:) ps"
   "EvalPosMonAuxTwo n ps"
 "EvalPosMonAux (m::n::ns) ps"
   "PosTimes (EvalPosMonAuxTwo m ps) (EvalPosMonAux (n::ns) ps)"
 "EvalPosMonAuxTwo Zero (p::ps)"
   "p"
 "EvalPosMonAuxTwo (Succ n) (p::ps)"
   "EvalPosMonAuxTwo n ps")

(acrs
 "EvalListPosMon (pmon:) ps"
   "EvalPosMon pmon ps"
 "EvalListPosMon (pmon1::pmon2::pmons) ps"
   "PosPlus (EvalPosMon pmon1 ps) (EvalListPosMon (pmon2::pmons) ps)")

; on algebra exprES

(add-program-constant "EvalExprES" (py "exprES=>list rat=>list pos=>rat") 1)

(av "e" "f"(py "exprES"))

(acrs
 "EvalExprES (IntES int) rs ps"
   "int#1"
 "EvalExprES (VarES Zero pexp) (r::rs) ps"
   "exp r (EvalPosexp pexp ps)"
 "EvalExprES (VarES (Succ nat) pexp) (r::rs) ps"
   "EvalExprES (VarES nat pexp) rs ps"
 "EvalExprES (AddES e f) rs ps"
   "RatPlus (EvalExprES e rs ps) (EvalExprES f rs ps)"
 "EvalExprES (MultES e f) rs ps"
   "RatTimes (EvalExprES e rs ps) (EvalExprES f rs ps)"
 "EvalExprES (DivES e f) rs ps"
   "RatDiv (EvalExprES e rs ps) (EvalExprES f rs ps)"
 "EvalExprES (ExpS e posexp) rs ps"
   "RatExp (EvalExprES e rs ps) (EvalPosexp posexp ps)"
 "EvalExprES (Sub e f) rs ps"
   "RatMinus (EvalExprES e rs ps) (EvalExprES f rs ps)")

; on algebra exprE

(add-program-constant "EvalExprE" (py "exprE=>list rat=>list pos=>rat") 1)

(rv "e" "f")
(av "e" "f"(py "exprE"))

(acrs
 "EvalExprE (IntE int) rs ps"
   "int#1"
 "EvalExprE (VarE Zero pexp) (r::rs) ps"
   "RatExp r (EvalPosexp pexp ps)"
 "EvalExprE (VarE (Succ nat) pexp) (r::rs) ps"
   "EvalExprE (VarE nat pexp) rs ps"
 "EvalExprE (AddE e f) rs ps"
   "RatPlus (EvalExprE e rs ps) (EvalExprE f rs ps)"
 "EvalExprE (MultE e f) rs ps"
   "RatTimes (EvalExprE e rs ps) (EvalExprE f rs ps)"
 "EvalExprE (DivE e f) rs ps"
   "RatDiv (EvalExprE e rs ps) (EvalExprE f rs ps)"
 "EvalExprE (Exp e pexp) rs ps"
   "RatExp (EvalExprE e rs ps) (EvalPosexp pexp ps)")

; on algebra expr

(rv "e" "f")
(av "e" "f"(py "expr"))

(add-program-constant "EvalExpr" (py "expr=>list rat=>list pos=>rat") 1)

(acrs
 "EvalExpr (Int int) rs ps"
   "int#1"
 "EvalExpr (Var Zero posexp) (r::rs) ps"
   "exp r (EvalPosexp posexp ps)"
 "EvalExpr (Var (Succ nat) posexp) (r::rs) ps"
   "EvalExpr (Var nat posexp) rs ps"
 "EvalExpr (Add e f) rs ps"
   "RatPlus (EvalExpr e rs ps) (EvalExpr f rs ps)"
 "EvalExpr (Mult e f) rs ps"
   "RatTimes (EvalExpr e rs ps) (EvalExpr f rs ps)"
 "EvalExpr (Div e f) rs ps"
   "RatDiv (EvalExpr e rs ps) (EvalExpr f rs ps)")
  

; evaluation for type list monomial@@list monomial

(add-program-constant "EvalFrac" (py "(list monomial@@list monomial)=>list rat=>list pos=>rat") 1)
(add-program-constant "EvalListMon" (py "list monomial=>list rat=>list pos=>rat") 1)
(add-program-constant "EvalMon" (py "monomial=>list rat=>list pos=>rat") 1)
(add-program-constant "EvalVars" (py "list variable=>list rat=>list pos=>rat") 1)
(add-program-constant "EvalVar" (py "variable=>list rat=>list pos=>rat") 1)

(acrs
 "EvalFrac lmspair rs ps"
   "[if ((right lmspair)=((MonomialConstr(FactorConstr (IntPos One))(Nil variable)):))
        (EvalListMon (left lmspair) rs ps)
        (RatDiv(EvalListMon (left lmspair) rs ps)(EvalListMon (right lmspair) rs ps))]"
 "EvalListMon (Nil monomial) rs ps"
   "0#1"
 "EvalListMon (mon:) rs ps"
   "EvalMon mon rs ps"
 "EvalListMon (mon1::mon2::lms) rs ps"
   "RatPlus (EvalMon mon1 rs ps) (EvalListMon (mon2::lms) rs ps)"
 "EvalMon (MonomialConstr(FactorConstr int)lvs) rs ps"
   "[if (int=(IntPos One))
        (EvalVars lvs rs ps)
        (RatTimes(int#1)(EvalVars lvs rs ps))]"
 "EvalVars (Nil variable) rs ps"
   "1#1"
 "EvalVars (var:) rs ps"
   "EvalVar var rs ps"
 "EvalVars (var1::var2::(list variable)) rs ps"
   "RatTimes (EvalVar var1 rs ps) (EvalVars (var2::(list variable)) rs ps)"
 "EvalVar (VarConstr Zero pmons) (r::rs) ps"
   "[if (pmons=(Nil posmon))
        (RatConstr (IntPos One) One)
        (RatExp r (EvalListPosMon pmons ps))]"
 "EvalVar (VarConstr (Succ nat) pmons) (r::rs) ps" 
   "EvalVar (VarConstr nat pmons) rs ps")

; transfer term of type exprES to term of type exprE
; (remove subtraction)

(add-program-constant
 "ExprESToExprE" (py "exprES=>exprE") 1)

(rv "e" "f")
(av "e" "f"(py "exprES"))

(acrs
 "ExprESToExprE (IntES int)"
   "IntE int"
 "ExprESToExprE (VarES nat pexp)"
   "VarE nat pexp"
 "ExprESToExprE (AddES e f)"
   "AddE (ExprESToExprE e) (ExprESToExprE f)"
 "ExprESToExprE (MultES e f)"
   "MultE (ExprESToExprE e) (ExprESToExprE f)"
 "ExprESToExprE (DivES e f)"
   "DivE (ExprESToExprE e) (ExprESToExprE f)"
 "ExprESToExprE (ExpS e pexp)"
   "Exp (ExprESToExprE e) pexp"
 "ExprESToExprE (Sub e f)"
   "AddE (ExprESToExprE e) (MultE (IntE (IntNeg One))(ExprESToExprE f))")

; transfer term of type exprE to term of type expr
; (unfolds exponents)

(add-program-constant "ExpUnfold" (py "exprE=>expr") 1)

(rv "e" "f")
(av "e" "f"(py "exprE"))

(acrs
 "ExpUnfold (Exp(VarE nat (P pos1))(P pos2))"
   "Var nat (P (PosTimes pos1 pos2))")

(acrs
 "ExpUnfold (IntE int)"
   "Int int"
 "ExpUnfold (VarE nat pexp)"
   "Var nat pexp"
 "ExpUnfold (AddE e f)"
   "Add (ExpUnfold e) (ExpUnfold f)"
 "ExpUnfold (MultE e f)"
   "Mult (ExpUnfold e) (ExpUnfold f)"
 "ExpUnfold (DivE e f)"
   "Div (ExpUnfold e) (ExpUnfold f)"
;  "ExpUnfold (Exp e One)"
;    "ExpUnfold e"
; should be defined... maybe pre-evaluate it?
;  "ExpUnfold (Exp (IntE int) pexp)"
;    "Int (IntExp int ...)"
;  "ExpUnfold (Exp (VarE nat pexp1) pexp2)"
;    "Var nat pexp"
;  "ExpUnfold (Exp (VarE nat pos) (SZero pos2))"
;    "Var nat (PosTimes pos (SZero pos2))"
;  "ExpUnfold (Exp (VarE nat pos) (SOne pos2))"
;    "Var nat (PosTimes pos (SOne pos2))"
; here again: this is not possible to define.. pre-evaluate??
; i.e. by putting under constructor Int
; or allowing introduce some "BOX" that will not be touched within
; reflection algorithm, i.e.
;  "ExpUnfold (Exp (AddE e f) pexp)"
;    "Box (Exp (AddE e f) pexp)"
;-----
 "ExpUnfold (Exp (AddE e f) (P One))"
   "ExpUnfold (AddE e f)"
 "ExpUnfold (Exp (AddE e f) (P (SZero pos)))"
   "Mult (ExpUnfold (Exp (AddE e f) (P pos))) (ExpUnfold (Exp (AddE e f) (P pos)))"
 "ExpUnfold (Exp (AddE e f) (P (SOne pos)))"
   "Mult (ExpUnfold (Exp (AddE e f) (P (SZero pos)))) (ExpUnfold (AddE e f))"
 "ExpUnfold (Exp (MultE e f) (P One))"
   "ExpUnfold (MultE e f)"
 "ExpUnfold (Exp (MultE e f) (P (SZero pos)))"
   "Mult (ExpUnfold (Exp e (P (SZero pos)))) (ExpUnfold (Exp f (P (SZero pos))))"
 "ExpUnfold (Exp (MultE e f) (P (SOne pos)))"
   "Mult (ExpUnfold (Exp e (P (SOne pos)))) (ExpUnfold (Exp f (P (SOne pos))))"
 "ExpUnfold (Exp (DivE e f) (P One))"
   "ExpUnfold (DivE e f)"
 "ExpUnfold (Exp (DivE e f) (P (SZero pos)))"
   "Div (ExpUnfold (Exp e (P (SZero pos)))) (ExpUnfold (Exp f (P (SZero pos))))"
 "ExpUnfold (Exp (DivE e f) (P (SOne pos)))"
   "Div (ExpUnfold (Exp e (P (SOne pos)))) (ExpUnfold (Exp f (P (SOne pos))))"
"ExpUnfold (Exp (Exp e pexp) (P One))"
   "ExpUnfold (Exp e pexp)"
 "ExpUnfold (Exp (Exp e (P pos1)) (P (SZero pos2)))"
   "Mult (ExpUnfold (Exp (Exp e (P pos1)) (P pos2))) (ExpUnfold (Exp (Exp e (P pos1)) (P pos2)))"
 "ExpUnfold (Exp (Exp e pexp) (P (SOne pos2)))"
   "Mult (ExpUnfold (Exp (Exp e pexp) (P (SZero pos2)))) (ExpUnfold (Exp e pexp))")

; height of a expression

(add-program-constant "Ht" (py "expr=>nat") 1)

(rv "e" "f")
(av "e" "f" "g" "h" (py "expr"))

(acrs
 "Ht (Int int)"
   "Zero"
 "Ht (Var nat pexp)"
   "Zero"
 "Ht (Add e f)"
   "Succ (NatMax (Ht e) (Ht f))"
 "Ht (Mult e f)"
   "Succ (NatMax (Ht e) (Ht f))"
 "Ht (Div e f)"
   "Succ (NatMax (Ht e) (Ht f))")

(add-program-constant "HtPosexp" (py "posexp=>nat") 1)

(acrs
 "HtPosexp (P pos)" "Zero"
 "HtPosexp (V nat)" "Zero"
 "HtPosexp (A pexp1 pexp2)" "Succ (NatMax (HtPosexp pexp1) (HtPosexp pexp2))"
 "HtPosexp (Ti pexp1 pexp2)" "Succ (NatMax (HtPosexp pexp1) (HtPosexp pexp2))")

(add-program-constant "DistPosexp" (py "posexp=>nat=>posexp") 1)

(acrs
 "DistPosexp pexp Zero" "pexp"
 "DistPosexp (P pos) (Succ nat)" "P pos"
 "DistPosexp (V nat) (Succ nat1)" "V nat"
 "DistPosexp (A pexp1 pexp2) (Succ nat)"
   "A (DistPosexp pexp1 nat) (DistPosexp pexp2 nat)"
 "DistPosexp (Ti (P pos1) (P pos2)) (Succ nat)"
   "Ti (P pos1) (P pos2)"
 "DistPosexp (Ti (P pos) (V nat)) (Succ nat1)"
   "Ti (P pos) (V nat)"
 "DistPosexp (Ti (P pos) (A pexp1 pexp2)) (Succ nat)"
   "DistPosexp (A (Ti (P pos) pexp1) (Ti (P pos) pexp2)) nat"
 "DistPosexp (Ti (P pos) (Ti pexp1 pexp2)) (Succ nat)"
   "DistPosexp (Ti (P pos) (DistPosexp (Ti pexp1 pexp2) nat)) nat"
 "DistPosexp (Ti (V nat) (P pos)) (Succ nat1)"
   "Ti (V nat) (P pos)"
 "DistPosexp (Ti (V nat1) (V nat2)) (Succ nat3)"
   "Ti (V nat1) (V nat2)"
 "DistPosexp (Ti (V nat) (A pexp1 pexp2)) (Succ nat1)"
   "DistPosexp (A (Ti (V nat) pexp1) (Ti (V nat) pexp2)) nat1"
 "DistPosexp (Ti (V nat) (Ti pexp1 pexp2)) (Succ nat1)"
   "DistPosexp (Ti (V nat) (DistPosexp (Ti pexp1 pexp2) nat1)) nat1"
 "DistPosexp (Ti (A pexp1 pexp2) pexp3) (Succ nat)"
   "DistPosexp (A (Ti pexp1 pexp3) (Ti pexp2 pexp3)) nat"
 "DistPosexp (Ti (Ti pexp1 pexp2) (P pos)) (Succ nat)"
   "DistPosexp (Ti (DistPosexp (Ti pexp1 pexp2) nat) (P pos)) nat"
 "DistPosexp (Ti (Ti pexp1 pexp2) (V nat)) (Succ nat1)"
   "DistPosexp (Ti (DistPosexp (Ti pexp1 pexp2) nat1) (V nat)) nat1"
 "DistPosexp (Ti (Ti pexp1 pexp2) (A pexp3 pexp4)) (Succ nat)"
   "DistPosexp (A (Ti (Ti pexp1 pexp2) pexp3) (Ti (Ti pexp1 pexp2) pexp4)) nat"
 "DistPosexp (Ti (Ti pexp1 pexp2) (Ti pexp3 pexp4)) (Succ nat)"
   "DistPosexp (Ti (DistPosexp (Ti pexp1 pexp2) nat)
                   (DistPosexp (Ti pexp3 pexp4) nat)) nat")
 
(add-program-constant "DistPosexpFinal" (py "expr=>expr") 1)

(acrs
 "DistPosexpFinal (Int int)" "Int int"
 "DistPosexpFinal (Var nat pexp)" "Var nat (DistPosexp pexp (HtPosexp pexp))"
 "DistPosexpFinal (Add e f)" "Add (DistPosexpFinal e) (DistPosexpFinal f)"
 "DistPosexpFinal (Mult e f)" "Mult (DistPosexpFinal e) (DistPosexpFinal f)"
 "DistPosexpFinal (Div e f)" "Div (DistPosexpFinal e) (DistPosexpFinal f)")

; applies distributivity
; second argument is a bound for the number of applications
; (bound will be the height of the expression)

(add-program-constant "Dist" (py "expr=>nat=>expr") 1)
(add-program-constant "DistFinal" (py "expr=>expr") 1)

; case 2nd argument 0 (then stop)
; or expression is a factor, variable, or sum

(acrs
 "DistFinal e"
   "Dist e (Ht e)"
 "Dist e Zero"
   "e"
 "Dist(Int int)(Succ(nat))"
   "Int int"
 "Dist(Var nat1 pexp)(Succ(nat2))"
   "Var nat1 pexp"
 "Dist(Add e f)(Succ(nat))"
   "Add(Dist e nat)(Dist f nat)"
 "Dist(Div e f)(Succ(nat))"
   "Div(Dist e nat)(Dist f nat)")

; case expression is a product

; subcase first factor is variable

(acrs
 "Dist(Mult(Var nat1 pexp1)(Int int))(Succ(nat2))"
   "Mult(Var nat1 pexp1)(Int int)"
 "Dist(Mult(Var nat1 pexp1)(Var nat2 pexp2))(Succ(nat3))"
   "Mult(Var nat1 pexp1)(Var nat2 pexp2)" ; maybe unify them?
 "Dist(Mult(Var nat1 pexp1)(Add e f))(Succ(nat2))"
   "Dist(Add(Mult(Var nat1 pexp1)e)(Mult(Var nat1 pexp1)f))nat2"
 "Dist(Mult(Var nat1 pexp1)(Mult e f))(Succ(nat2))"
   "Dist(Mult(Var nat1 pexp1)(Dist(Mult e f)nat2))nat2"
 "Dist(Mult(Var nat1 pexp1)(Div e f))(Succ(nat2))"
   "Dist(Mult(Var nat1 pexp1)(Dist(Div e f)nat2))nat2")

; subcase first factor is integer

(acrs
 "Dist(Mult(Int int1)(Int int2))(Succ(nat))"
   "Mult(Int int1)(Int int2)"
 "Dist(Mult(Int int)(Var nat1 pexp1))(Succ(nat2))"
   "Dist(Mult(Var nat1 pexp1)(Int int))(Succ(nat2))"
 "Dist(Mult(Int int)(Add e f))(Succ(nat))"
   "Dist(Add(Mult(Int int)e)(Mult(Int int)f))nat"
 "Dist(Mult(Int int)(Mult e f))(Succ(nat))"
   "Dist(Mult(Int int)(Dist(Mult e f)nat))nat"
 "Dist(Mult(Int int)(Div e f))(Succ(nat))"
   "Dist(Mult(Int int)(Dist(Div e f)nat))nat")

; subcase first factor is sum

(acrs
 "Dist(Mult(Add e f)(Int int))(Succ(nat))"
   "Dist(Mult(Int int)(Add e f))(Succ(nat))"
 "Dist(Mult(Add e f)(Var nat1 pexp1))(Succ(nat2))"
   "Dist(Mult(Var nat1 pexp1)(Add e f))(Succ(nat2))"
 "Dist(Mult(Add e f)(Add g h))(Succ(nat))"
   "Dist(Add(Add(Add(Mult e g)(Mult e h))(Mult f g))(Mult f h))nat"
 "Dist(Mult(Add e f)(Mult g h))(Succ(nat))"
   "Dist(Mult(Mult g h)(Add e f))(Succ(nat))"
 "Dist(Mult(Add e f)(Div g h))(Succ(nat))"
   "Dist(Mult(Div g h)(Add e f))(Succ(nat))")

; subcase first factor is again product

(acrs
 "Dist(Mult(Mult e f)(Int int))(Succ(nat))"
   "Dist(Mult(Int int)(Mult e f))(Succ(nat))"
 "Dist(Mult(Mult e f)(Var nat1 pexp1))(Succ(nat2))"
   "Dist(Mult(Var nat1 pexp1)(Mult e f))(Succ(nat2))"
 "Dist(Mult(Mult e f)(Add g h))(Succ(nat))"
   "Dist(Add(Mult(Mult e f)g)(Mult(Mult e f)h))nat"
 "Dist(Mult(Mult e f)(Mult g h))(Succ(nat))"
   "Dist(Mult(Dist(Mult e f)nat)(Dist(Mult g h)nat))nat"
 "Dist(Mult(Mult e f)(Div g h))(Succ(nat))"
   "Dist(Mult(Dist(Mult e f)nat)(Dist(Div g h)nat))nat"
)

; subcase first factor is fraction

(acrs
 "Dist(Mult(Div e f)(Int int))(Succ(nat))"
   "Dist(Mult(Int int)(Div e f))(Succ(nat))"
 "Dist(Mult(Div e f)(Var nat1 pexp1))(Succ(nat2))"
   "Dist(Mult(Var nat1 pexp1)(Div e f))(Succ(nat2))"
 "Dist(Mult(Div e f)(Add g h))(Succ(nat))"
   "Dist(Add(Mult(Div e f)g)(Mult(Div e f)h))nat"
 "Dist(Mult(Div e f)(Mult g h))(Succ(nat))"
   "Dist(Mult(Dist(Div e f)nat)(Dist(Mult g h)nat))nat"
 "Dist(Mult(Div e f)(Div g h))(Succ(nat))"
   "Dist(Mult(Dist(Div e f)nat)(Dist(Div g h)nat))nat"
)


; multiplication of posmon

(add-program-constant "PosMonTimes"
		      (py "posmon=>posmon=>posmon") 1)
(add-program-constant "MultPosMonAux"
		      (py "posmon=>list posmon=>list posmon") 1)
(add-program-constant "MultPosMon"
		      (py "list posmon=>list posmon=>list posmon") 1)

(acrs
 "PosMonTimes(PosMon p1 ns1)(PosMon p2 ns2)"
   "PosMon(PosTimes p1 p2)(ns1:+:ns2)"
 "MultPosMonAux pmon (Nil posmon)"
   "(Nil posmon)"
 "MultPosMonAux pmon (pmon1::pmons)"
  "(PosMonTimes pmon pmon1)::(MultPosMonAux pmon pmons)"
 "MultPosMon (Nil posmon) pmons"
   "(Nil posmon)"
 "MultPosMon (pmon::pmons1) pmons2"
   "(MultPosMonAux pmon pmons2):+:(MultPosMon pmons1 pmons2)")

; multiplication of monomials

(add-program-constant "MonTimes"
		      (py "monomial=>monomial=>monomial") 1)
(add-program-constant "MultMonomialsAux"
		      (py "monomial=>list monomial=>list monomial") 1)
(add-program-constant "MultMonomials"
		      (py "list monomial=>list monomial=>list monomial") 1)

(acrs
 "MonTimes(MonomialConstr(FactorConstr int1)lvs1)(MonomialConstr(FactorConstr int2)lvs2)"
   "MonomialConstr(FactorConstr(IntTimes int1 int2))(lvs1:+:lvs2)"
 "MultMonomialsAux mon (Nil monomial)"
   "(Nil monomial)"
 "MultMonomialsAux mon (mon1::lms)"
  "(MonTimes mon mon1)::(MultMonomialsAux mon lms)"
 "MultMonomials (Nil monomial) lms2"
   "(Nil monomial)"
 "MultMonomials (mon::lms1) lms2"
   "(MultMonomialsAux mon lms2):+:(MultMonomials lms1 lms2)")

; transfers term of type posexp to term of type posmon

(add-program-constant "PosExpToPosMon" (py "posexp=>list posmon") 1)

(acrs
 "PosExpToPosMon (P p)"
   "(PosMon p (Nil nat)):"
 "PosExpToPosMon (V n)"
   "(PosMon One (n:)):"
 "PosExpToPosMon (A pexp1 pexp2)"
   "(PosExpToPosMon pexp1):+:(PosExpToPosMon pexp2)"
 "PosExpToPosMon (Ti pexp1 pexp2)"
   "MultPosMon(PosExpToPosMon pexp1)(PosExpToPosMon pexp2)")

; transfers term of type expr to a pair numerator@denominator

(add-program-constant "ExprToNumDen"
		      (py "expr=>list monomial@@list monomial") 1)

(acrs
 "ExprToNumDen(Var nat pexp)"
   "((MonomialConstr(FactorConstr(IntPos One))((VarConstr nat (PosExpToPosMon pexp)):)):)
    @((MonomialConstr(FactorConstr(IntPos One))(Nil variable)):)"
 "ExprToNumDen(Int int)"
   "((MonomialConstr(FactorConstr(int))(Nil variable)):)
    @((MonomialConstr(FactorConstr(IntPos One))(Nil variable)):)"
 "ExprToNumDen(Add e f)"
   "((MultMonomials(left(ExprToNumDen e))(right(ExprToNumDen f)))
    :+:(MultMonomials(left(ExprToNumDen f))(right(ExprToNumDen e))))
    @(MultMonomials(right(ExprToNumDen e))(right(ExprToNumDen f)))"
 "ExprToNumDen(Mult e f)"
   "(MultMonomials(left(ExprToNumDen e))(left(ExprToNumDen f)))
    @(MultMonomials(right(ExprToNumDen e))(right(ExprToNumDen f)))"
 "ExprToNumDen(Div e f)"
   "(MultMonomials(left(ExprToNumDen e))(right(ExprToNumDen f)))
    @(MultMonomials(right(ExprToNumDen e))(left(ExprToNumDen f)))")

; should simplify (x⁵ * x³ -> x⁸) and then sort the list of variables

(add-program-constant "SimpVars"
		      (py "list monomial@@list monomial=>list monomial@@list monomial") 1)
(add-program-constant "SimpVarsAux"
		      (py "list monomial=>list monomial") 1)
(add-program-constant "SimpVarsMon"
		      (py "monomial=>monomial") 1)
(add-program-constant "SimpListVar"
		      (py "list variable=>list variable") 1)
(add-program-constant "MonomOrder"
		      (py "monomial=>monomial=>boole") 1)
(add-program-constant "VarLt"
		      (py "variable=>variable=>boole") 1)
(add-program-constant "VarLe"
		      (py "variable=>variable=>boole") 1)

(add-program-constant "PosMonLt"
		      (py "posmon=>posmon=>boole") 1)
(add-program-constant "ListPosMonLt"
		      (py "list posmon=>list posmon=>boole") 1)

(add-program-constant "SimpExp"
		      (py "list variable=>list variable") 1)
(add-program-constant "SimpExpAux"
		      (py "variable=>variable") 1)
(add-program-constant "SimpExpAuxOne"
		      (py "list posmon=>list posmon") 1)

(acrs
 ; SimpExp gets as argument an ordered list of variables
 "SimpExp(Nil variable)"
   "(Nil variable)"
 "SimpExp(v::lvs)"
   "(SimpExpAux v)::(SimpExp lvs)"
 "SimpExpAux (VarConstr nat pmons)"
   "VarConstr nat (SimpExpAuxOne((SortList posmon)PosMonLt pmons))"
 "SimpExpAuxOne (Nil posmon)"
   "(Nil posmon)"
 "SimpExpAuxOne (pmon:)"
   "(pmon:)"
 "SimpExpAuxOne ((PosMon p1 ns1)::(PosMon p2 ns2)::pmons)"
   "[if (ns1=ns2)
        (SimpExpAuxOne ((PosMon (PosPlus p1 p2) ns1)::pmons))
        ((PosMon p1 ns1)::(SimpExpAuxOne ((PosMon p2 ns2)::pmons)))]")

(acrs
 "PosMonLt (PosMon p (Nil nat)) pmon" "True"
 "PosMonLt (PosMon p1 (n::ns)) (PosMon p2 (Nil nat))" "False"
 "PosMonLt (PosMon p1 (n1::ns1)) (PosMon p2 (n2::ns2))"
   "[if (NatLt(Lh ns1)(Lh ns2))
        True
        [if ((Lh ns1)=(Lh ns2))
            [if (NatLt n1 n2)
                True
                [if (NatLt n2 n1)
                    False
                    (PosMonLt (PosMon p1 (ns1)) (PosMon p2 (ns2)))]]
            False]]"
 "ListPosMonLt (Nil posmon) pmons" "True"
 "ListPosMonLt (pmon::pmons) (Nil posmon)" "False"
 "ListPosMonLt (pmon1::pmons1) (pmon2::pmons2)"
   "[if (NatLt(Lh pmons1)(Lh pmons2))
        True
        [if ((Lh pmons1)=(Lh pmons2))
            [if (PosMonLt pmon1 pmon2)
                True
                [if (PosMonLt pmon2 pmon1)
                    False
                    (ListPosMonLt pmons1 pmons2)]]
            False]]")

(acrs
 "VarLt (VarConstr nat1 pmons1)(VarConstr nat2 pmons2)"
   "[if (NatLt nat1 nat2)
        True
        [if (NatLt nat2 nat1)
            False
            (ListPosMonLt pmons1 pmons2)]]"
 "MonomOrder(MonomialConstr(FactorConstr int1)(Nil variable))(MonomialConstr(FactorConstr int2)lvs)"
   "True"
 "MonomOrder(MonomialConstr(FactorConstr int1)(var1::lvs1))(MonomialConstr(FactorConstr int2)(Nil variable))"
   "False"
 "MonomOrder(MonomialConstr(FactorConstr int1)(var1::lvs1))(MonomialConstr(FactorConstr int2)(var2::lvs2))"
   "[if (NatLt(Lh lvs1)(Lh lvs2))
        True
        [if ((Lh lvs1)=(Lh lvs2))
            [if (VarLt var1 var2)
                True
                [if (VarLt var2 var1)
                    False
                    (MonomOrder(MonomialConstr(FactorConstr int1)lvs1)(MonomialConstr(FactorConstr int2)lvs2))]]
            False]]"
 "SimpListVar(Nil variable)" "(Nil variable)"
 "SimpListVar(v:)" "(v:)"
 "SimpListVar((VarConstr nat1 pmons1)::(VarConstr nat2 pmons2)::lvs)"
   "[if (nat1=nat2)
        (SimpListVar ((VarConstr nat1 (pmons1:+:pmons2))::lvs))
        ((VarConstr nat1 pmons1)::(SimpListVar ((VarConstr nat2 pmons2)::lvs)))]"
 "SimpVars lmspair"
   "((SortList monomial)MonomOrder(SimpVarsAux(left(lmspair))))@((SortList monomial)MonomOrder(SimpVarsAux(right(lmspair))))"
 "SimpVarsAux (Nil monomial)"
   "(Nil monomial)"
 "SimpVarsAux (mon::lms)"
   "(SimpVarsMon mon)::(SimpVarsAux lms)"
 "SimpVarsMon (MonomialConstr(FactorConstr int)lvs)"
   "(MonomialConstr(FactorConstr int)(SimpExp(SimpListVar((SortList variable)VarLt lvs))))")
 
; sum up monomials for which the list of variables are equal

(add-program-constant "UnifyMonAux" (py "list monomial=>list monomial") 1)
(add-program-constant "UnifyMon" (py "list monomial@@list monomial=>list monomial@@list monomial") 1)

(acrs
 "UnifyMonAux(Nil monomial)" "(Nil monomial)"
 "UnifyMonAux(mon:)" "mon:"
 "UnifyMonAux((MonomialConstr(FactorConstr int1)lvs1)::(MonomialConstr(FactorConstr int2)lvs2)::lms)"
   "[if (lvs1=lvs2)
        [if ((IntPlus int1 int2)=IntZero)
            (UnifyMonAux lms)
            (UnifyMonAux((MonomialConstr(FactorConstr(IntPlus int1 int2))lvs1)::lms))]
        ((MonomialConstr(FactorConstr int1)lvs1)::(UnifyMonAux((MonomialConstr(FactorConstr int2)lvs2)::lms)))]"
 "UnifyMon lmspair"
   "(UnifyMonAux(left lmspair))@(UnifyMonAux(right lmspair))")

; greatest common divisor for positive numbers

(add-program-constant "gcd" (py "pos=>pos=>pos") 1)
(add-program-constant "gcdaux" (py "pos=>pos=>pos") 1)
(add-program-constant "gcdmaxfactor" (py "pos=>pos=>pos=>pos") 1)

(acrs 
 "gcd p1 p2"
   "[if (p1 = p2) p1
        [if (PosLt p1 p2) (gcdaux p2 p1) (gcdaux p1 p2)]]"
 "gcdaux p1 p2" ; p1 > p2
   "[if (p1 = (PosTimes (gcdmaxfactor p1 p2 One) p2))
        p2
        (gcdaux p2 (PosMinus p1 (PosTimes (gcdmaxfactor p1 p2 One) p2)))]"
 "gcdmaxfactor p1 p2 pos"
  ; calculates the maximal value of pos such that   p1 >= p2*pos
   "[if (PosLt p1(PosTimes p2(S pos))) pos (gcdmaxfactor p1 p2(S pos))]")


; int to pos

(add-program-constant "IntToPos" (py "int=>pos"))

(acrs
 "IntToPos (IntPos pos)" "pos"
 "IntToPos (IntNeg pos)" "pos")


(add-program-constant "Cancel" (py "list monomial@@list monomial=>list monomial@@list monomial") 1)
(add-program-constant "CancelAux" (py "monomial@@list monomial=>monomial@@list monomial=>list monomial@@list monomial") 1)
(add-program-constant "MonomialListToMaxCommonAndRest" (py "list monomial=>monomial@@list monomial") 1)
(add-program-constant "MaxCommonMonomial" (py "list monomial=>monomial") 1)
(add-program-constant "MaxCommonMonomialAux" (py "monomial=>list monomial=>monomial") 1)
(add-program-constant "MaxCommon" (py "monomial=>monomial=>monomial") 1)
(add-program-constant "MaxCommonPosMon" (py "list posmon=>list posmon=>list posmon") 1)
(add-program-constant "MaxCommonPosMonAux" (py "list posmon=>list posmon=>list posmon=>list posmon") 1)
(add-program-constant "MaxCommonPosMonAuxTwo" (py "posmon=>list posmon=>list posmon") 1)
(add-program-constant "MaxVars" (py "list variable=>list variable=>list variable") 1)
(add-program-constant "MaxVarsAuxOne" (py "variable=>list variable=>list variable") 1)
(add-program-constant "MaxVarsAuxTwo" (py "list variable=>list variable=>list variable=>list variable") 1)
(add-program-constant "MonCalculateRest" (py "monomial=>list monomial=>list monomial") 1)
(add-program-constant "MonCalculateRestAux" (py "monomial=>list monomial=>list monomial=>list monomial") 1)
(add-program-constant "MonDiv" (py "monomial=>monomial=>monomial") 1)
(add-program-constant "VarDiff" (py "list variable=>list variable=>list variable") 1)
(add-program-constant "VarDiffAux" (py "list variable=>list variable=>list variable=>list variable") 1)
(add-program-constant "VarDiffAuxOne" (py "variable=>list variable=>list variable") 1)
(add-program-constant "VarDiffExp" (py "list posmon=>list posmon=>list posmon") 1)
(add-program-constant "VarDiffExpAux" (py "list posmon=>list posmon=>list posmon") 1)
(add-program-constant "VarDiffExpAuxTwo" (py "posmon=>list posmon=>list posmon") 1)

(acrs
 "Cancel lmspair"
   "[if ((left lmspair)=(MonomialConstr(FactorConstr 0)(Nil variable)):)
        lmspair
        (CancelAux(MonomialListToMaxCommonAndRest(left lmspair))
          (MonomialListToMaxCommonAndRest(right lmspair)))]"
 "CancelAux mms1 mms2"
   "(MultMonomialsAux (MonDiv (left mms1) (MaxCommon (left mms1) (left mms2))) (right mms1))
    @(MultMonomialsAux (MonDiv (left mms2) (MaxCommon (left mms1) (left mms2))) (right mms2))"
 "MonomialListToMaxCommonAndRest(Nil monomial)"
   "(MonomialConstr(FactorConstr IntZero)(Nil variable))@((MonomialConstr(FactorConstr IntZero)(Nil variable)):)"
 "MonomialListToMaxCommonAndRest (mon::lms)"
   "(MaxCommonMonomial(mon::lms))@(MonCalculateRest(MaxCommonMonomial(mon::lms))(mon::lms))"
 "MaxCommonMonomial (Nil monomial)"
   "(MonomialConstr(FactorConstr IntZero)(Nil variable))"
 "MaxCommonMonomial (mon::lms)"
   "MaxCommonMonomialAux mon lms"
 "MaxCommonMonomialAux mon (Nil monomial)"
   "mon"
 "MaxCommonMonomialAux mon1 (mon2::lms)"
   "MaxCommonMonomialAux (MaxCommon mon1 mon2) lms"
 "MaxCommon (MonomialConstr(FactorConstr int1)lvs1)
  (MonomialConstr(FactorConstr int2)lvs2)"
   "MonomialConstr (FactorConstr (IntPos (gcd (IntToPos int1) (IntToPos int2))))
    (MaxVars lvs1 lvs2)"
 "MaxVars lvs1 lvs2"
   "MaxVarsAuxTwo lvs1 lvs2 (Nil variable)"
 "MaxVarsAuxTwo (Nil variable) lvs1 lvs2"
   "lvs2"
 "MaxVarsAuxTwo (var::lvs1) lvs2 lvs3"
   "MaxVarsAuxTwo lvs1 lvs2 ((MaxVarsAuxOne var lvs2):+:lvs3)"
 "MaxVarsAuxOne var (Nil variable)"
   "(Nil variable)")

(acrs
 "MaxVarsAuxOne (VarConstr nat1 pmons1) ((VarConstr nat2 pmons2)::lvs)"
; if nat1 > nat2 end search
            ; because list of variables is already ordered
   "[if (nat1=nat2)
        ((VarConstr nat1 (MaxCommonPosMon pmons1 pmons2)):)
        [if (NatLt nat2 nat1)
            (Nil variable)
            (MaxVarsAuxOne (VarConstr nat1 pmons1) lvs)]]"
 "MaxCommonPosMon pmons1 pmons2"
   "MaxCommonPosMonAux pmons1 pmons2 (Nil posmon)"
; now assumed that they are already ordered.
 "MaxCommonPosMonAux (Nil posmon) pmons2 pmons3"
   "pmons3"
 "MaxCommonPosMonAux (pmon::pmons1) pmons2 pmons3"
   "MaxCommonPosMonAux pmons1 pmons2 ((MaxCommonPosMonAuxTwo pmon pmons2):+:pmons3)"
 "MaxCommonPosMonAuxTwo pmon (Nil posmon)"
   "(Nil posmon)"
 "MaxCommonPosMonAuxTwo (PosMon p1 ns1) ((PosMon p2 ns2)::pmons)"
   "[if (ns1=ns2)
        ((PosMon (PosMin p1 p2) ns1):)
        (MaxCommonPosMonAuxTwo (PosMon p1 ns1) pmons)]"
 "MonCalculateRest mon (Nil monomial)" "(Nil monomial)"
 "MonCalculateRest mon1 (mon2::lms)"
   "MonCalculateRestAux mon1 (mon2::lms) (Nil monomial)"
 "MonCalculateRestAux mon1 (Nil monomial) lms2"
   "lms2")
(acrs
 "MonCalculateRestAux mon1 (mon2::lms) lms2"
   "MonCalculateRestAux mon1 lms ((MonDiv mon2 mon1)::lms2)"
 "MonDiv (MonomialConstr(FactorConstr int1)lvs1)(MonomialConstr(FactorConstr int2)lvs2)"
   ; MonDiv: first the bigger monomial
   ; 'MonDiv mon1 mon2' calculates mon1 divided by mon2
   ; assumptions: int1,int2 not equal to 0
   "[if (IntLt IntZero int1)
        ([if (IntLt IntZero int2)
             (MonomialConstr (FactorConstr (IntPos (gcdmaxfactor (IntToPos int1) (IntToPos int2) One)))
                (VarDiff lvs1 lvs2))
             (MonomialConstr (FactorConstr (IntNeg (gcdmaxfactor (IntToPos int1) (IntToPos int2) One)))
                (VarDiff lvs1 lvs2))])
        ([if (IntLt IntZero int2)
             (MonomialConstr (FactorConstr (IntNeg (gcdmaxfactor (IntToPos int1) (IntToPos int2) One)))
                (VarDiff lvs1 lvs2))
             (MonomialConstr (FactorConstr (IntPos (gcdmaxfactor (IntToPos int1) (IntToPos int2) One)))
                (VarDiff lvs1 lvs2))])]")

(acrs
 "VarDiff lvs1 lvs2" ; first list is bigger than second
  ;VarDiff calculates the difference between first and second
  ; or in other words: lvs1 divided by lvs2
   "VarDiffAux lvs1 lvs2 (Nil variable)"
 "VarDiffAux (Nil variable) lvs1 lvs2"
   "lvs2"
 "VarDiffAux (var::lvs1) lvs2 lvs3"
   "VarDiffAux lvs1 lvs2 ((VarDiffAuxOne var lvs2):+:lvs3)"
 "VarDiffAuxOne var (Nil variable)"
   "var:"
 "VarDiffAuxOne (VarConstr nat1 pmons1) ((VarConstr nat2 pmons2)::lvs)"
; again assumed that lists are ordered
   "[if (nat1=nat2)
        ((VarConstr nat1 (VarDiffExp pmons1 pmons2)):)
        (VarDiffAuxOne (VarConstr nat1 pmons1) lvs)]"
; first bigger list of pmons
;  "VarDiffExp pmons1 pmons2"
;    "VarDiffExpAux pmons2 pmons1 (Nil posmon)"
;  "VarDiffExpAux (Nil posmon) pmons2 pmons3"
;    "pmons3"
;  "VarDiffExpAux (pmon::pmons1) pmons2 pmons3"
;    "VarDiffExpAux pmons1 pmons2 ((VarDiffExpAuxTwo pmon pmons2):+:pmons3)"
;  "VarDiffExpAuxTwo pmon (Nil posmon)"
;    "pmon:"
;  "VarDiffExpAuxTwo (PosMon p1 ns1) ((PosMon p2 ns2)::pmons)"
;    "[if (ns1=ns2)
;         ((PosMon (PosMinus p1 p2) ns1):)
;         (VarDiffExpAuxTwo (PosMon p1 ns1) pmons)]")

;first bigger list of pmons
 "VarDiffExp pmons1 pmons2"
   "VarDiffExpAux pmons1 pmons2"
 "VarDiffExpAux pmons1 (Nil posmon)"
   "pmons1"
 "VarDiffExpAux pmons1 (pmon::pmons2)"
   "VarDiffExpAux (VarDiffExpAuxTwo pmon pmons1) pmons2"
 ;VarDiffExpAuxTwo pmon pmons
 ;calculates 'pmons minus pmon'
 "VarDiffExpAuxTwo pmon (Nil posmon)"
   "(Nil posmon)"
 "VarDiffExpAuxTwo (PosMon p1 ns1) ((PosMon p2 ns2)::pmons)"
   "[if (ns1=ns2)
        [if (p1=p2)
            pmons
            ((PosMon (PosMinus p2 p1) ns1)::pmons)]
        ((PosMon p2 ns2)::(VarDiffExpAuxTwo (PosMon p1 ns1) pmons))]")

(add-program-constant "CleanUp" (py "list monomial@@list monomial=>list monomial@@list monomial") 1)
(add-program-constant "CleanUpAux" (py "list monomial=>list monomial") 1)
(add-program-constant "CleanUpAuxTwo" (py "list monomial=>list monomial") 1)
(add-program-constant "CleanUpAuxThree" (py "list variable=>list variable") 1)
(add-program-constant "CleanUpAuxFour" (py "list monomial=>list monomial") 1)

(acrs
 "CleanUp lmspair" "(CleanUpAux (left lmspair))@(CleanUpAux (right lmspair))"
 "CleanUpAux lms" "[if (NatLe (Lh lms) (Succ Zero)) (CleanUpAuxFour lms) (CleanUpAuxTwo lms)]"
 "CleanUpAuxTwo (Nil monomial)" "(Nil monomial)"
 "CleanUpAuxTwo ((MonomialConstr(FactorConstr int)lvs)::lms)"
   "[if ((int=(IntPos One)) andb (lvs=(Nil variable)))
        (CleanUpAuxTwo lms)
        ((MonomialConstr(FactorConstr int)(CleanUpAuxThree lvs))::(CleanUpAuxTwo lms))]"
 "CleanUpAuxThree (Nil variable)" "(Nil variable)"
 "CleanUpAuxThree ((VarConstr nat pmons)::lvs)"
   "[if (pmons=(Nil posmon))
        (CleanUpAuxThree lvs)
        ((VarConstr nat pmons)::(CleanUpAuxThree lvs))]"
 "CleanUpAuxFour ((MonomialConstr (FactorConstr int) lvs):)"
   "(MonomialConstr (FactorConstr int) (CleanUpAuxThree lvs)):")


; Normalization Process for Expressions:
; * first eliminate Sub constructor (ExprESToExprE)
; * unfold all exponents (except of variable exponents) (ExpUnfold)
; * apply distributivity (Dist)
; * apply distributivity in exponents (of variables) (DistPosexpFinal)
; * transfer expression to structure list monomial@@list monomial (ExprToNumDen)
; * simplificate variables in all monomials,
;      do the same in all exponents, and then sort num. and den. (SimpVar)

(add-program-constant "NormalizeExpr"
		      (py "exprES=>list monomial@@list monomial") 1)

(acrs
 "NormalizeExpr exprES"
   "SimpVars(CleanUp(Cancel(UnifyMon(SimpVars(ExprToNumDen(DistFinal(DistPosexpFinal(ExpUnfold(ExprESToExprE exprES)))))))))")



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


; Theorem EvalSort

(aga "EvalSort"
     (pf "all list rat,list pos,exprES.Equal(EvalFrac(NormalizeExpr exprES)(list rat)(list pos))(EvalExprES exprES (list rat)(list pos))"))


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


(define (EvalSort-proof env posenv expr)
  (mk-proof-in-elim-form
   (make-proof-in-aconst-form 
    (global-assumption-name-to-aconst "EvalSort"))
   env posenv expr))


;===================================================================
; 7. FUNCTIONS FOR TRANSFERRING RING TERMS INTO THE META-LEVEL
;===================================================================

(define (parse-to-var-for-posexp term env)
  (let ((info (assoc-wrt term=? term env)))
    (if info
	(list (mk-term-in-app-form
	       (pt "V")
	       (make-numeric-term-in-nat (cadr info)))
	      env)
	(let* ((i (length env))
	       (var-expr
		(mk-term-in-app-form
		 (pt "V")
		 (make-numeric-term-in-nat i))))
	  (list var-expr 
		(append
		 env
		 (list (list term i))))))))

(define (term-and-env-to-linarith-posexp-and-env term env)
  (display-debug "term-and-env-to-linarith-posexp-and-env")
  (display-debug ".. applied on term")
  ;(pp term)
  (display-debug ".. current env")
  ;(pp (terms-to-pos-list-term (map car env)))
  (if (not (equal? (py "pos") (term-to-type term)))
      (myerror "term-and-env-to-linarith-posexp-and-env"
	       "term of type pos expected" term))
  (cond
   ((is-pos-numeric-term? term)
    (display-debug "pos-numeric")
    (list (make-term-in-app-form
	   (pt "P") term) env))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (string=? "PosPlus" cstring))
	 (= 2 (length (term-in-app-form-to-args term))))
    (display-debug "+")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 (term-and-env-to-linarith-posexp-and-env arg1 env))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2 (term-and-env-to-linarith-posexp-and-env arg2 env1))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (pt "A")
	     expr1 expr2) env2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (string=? "PosTimes" cstring))
	 (= 2 (length (term-in-app-form-to-args term))))
    (display-debug "*")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 (term-and-env-to-linarith-posexp-and-env arg1 env))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (prev2 (term-and-env-to-linarith-posexp-and-env arg2 env1))
	   (expr2 (car prev2))
	   (env2 (cadr prev2)))
      (list (mk-term-in-app-form
	     (pt "Ti")
	     expr1 expr2) env2)))
   (else
    (display-debug "var")
    (parse-to-var-for-posexp term env))))
    

; contains-variable? returns #t if pexp contains the constructor V

(add-program-constant "ConVar" (py "posexp=>boole") 1)

(acrs
 "ConVar (P pos)" "False"
 "ConVar (V nat)" "True"
 "ConVar (A pexp1 pexp2)" "ConVar pexp1 orb ConVar pexp2"
 "ConVar (Ti pexp1 pexp2)" "ConVar pexp1 orb ConVar pexp2")

(define (contains-variable? pexp)
  (equal? 
   (nt (make-term-in-app-form (pt "ConVar") pexp))
   (pt "True")))


; (term-and-env-to-linarith-expr-and-env .)
; performs the translation of a term of type rat into the algebra exprES
; plus environment, list of denominators, environment for positive exponents

(define (term-and-env-to-linarith-expr-and-env term env denomterms posenv)
  (display-debug "term-and-env-to-linarith-expr-and-env")
  (display-debug ".. applied on term")
  ;(pp term)
  (display-debug ".. current env:")
  ;(pp (terms-to-list-term (map car env)))
  (if (not (or (equal? (py "pos") (term-to-type term))
	       (equal? (py "int") (term-to-type term))
	       (equal? (py "rat") (term-to-type term))))
      (myerror "term-and-env-to-linarith-expr-and-env"
	       "term of type pos, int, or rat expected" term))
  (cond
   ((is-pos-numeric-term? term)
    (list (make-term-in-app-form
	   (pt "IntES")
	   (make-term-in-app-form
	    (pt "IntPos") term))
	   env denomterms posenv))
   ((is-int-numeric-term? term)
    (list (make-term-in-app-form
	   (pt "IntES")
	   term)
	  env denomterms posenv))
   ((and (is-rat-numeric-term? term)
	 (term-in-app-form? term))
    ;critical!! could be arbitrary application
    (display-debug "is-rat-numeric-term")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args)))
      (list (make-term-in-app-form
	     (make-term-in-app-form
	      (pt "DivES")
	      (make-term-in-app-form
	       (pt "IntES")
	       arg1))
	     (make-term-in-app-form
	      (pt "IntES")
	      (make-term-in-app-form
	       (pt "IntPos")
	       arg2)))
	     env denomterms posenv)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (string=? "RatConstr" cstring))
	 (= 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 (term-and-env-to-linarith-expr-and-env arg1 env denomterms posenv))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (dts1 (caddr prev1))
	   (posenv1 (cadddr prev1))
	   (prev2 (term-and-env-to-linarith-expr-and-env arg2 env1 dts1 posenv1))
	   (expr2 (car prev2))
	   (env2 (cadr prev2))
	   (dts2 (caddr prev2))
	   (posenv2 (cadddr prev2)))
      (list (mk-term-in-app-form
	     (pt "DivES")
	     expr1 expr2) env2 dts2 posenv2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (or (string=? "PosPlus" cstring)
	       (string=? "IntPlus" cstring)
	       (string=? "RatPlus" cstring)))
	 (= 2 (length (term-in-app-form-to-args term))))
        (display-debug "+")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 (term-and-env-to-linarith-expr-and-env arg1 env denomterms posenv))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (dts1 (caddr prev1))
	   (posenv1 (cadddr prev1))
	   (prev2 (term-and-env-to-linarith-expr-and-env arg2 env1 dts1 posenv1))
	   (expr2 (car prev2))
	   (env2 (cadr prev2))
	   (dts2 (caddr prev2))
	   (posenv2 (cadddr prev2)))
      (list (mk-term-in-app-form
	     (pt "AddES")
	     expr1 expr2) env2 dts2 posenv2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (or (string=? "PosMinus" cstring)
	       (string=? "IntMinus" cstring)
	       (string=? "RatMinus" cstring)))
	 (= 2 (length (term-in-app-form-to-args term))))
        (display-debug "-")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 (term-and-env-to-linarith-expr-and-env arg1 env denomterms posenv))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (dts1 (caddr prev1))
	   (posenv1 (cadddr prev1))
	   (prev2 (term-and-env-to-linarith-expr-and-env arg2 env1 dts1 posenv1))
	   (expr2 (car prev2))
	   (env2 (cadr prev2))
	   (dts2 (caddr prev2))
	   (posenv2 (cadddr prev2)))
      (list (mk-term-in-app-form
	     (pt "Sub")
	     expr1 expr2) env2 dts2 posenv2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (or (string=? "PosTimes" cstring)
	       (string=? "IntTimes" cstring)
	       (string=? "RatTimes" cstring)))
	 (= 2 (length (term-in-app-form-to-args term))))
    (display-debug "*")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 (term-and-env-to-linarith-expr-and-env arg1 env denomterms posenv))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (dts1 (caddr prev1))
	   (posenv1 (cadddr prev1))
	   (prev2 (term-and-env-to-linarith-expr-and-env arg2 env1 dts1 posenv1))
	   (expr2 (car prev2))
	   (env2 (cadr prev2))
	   (dts2 (caddr prev2))
	   (posenv2 (cadddr prev2)))
      (list (mk-term-in-app-form
	     (pt "MultES")
	     expr1 expr2) env2 dts2 posenv2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (string=? "RatDiv" cstring))
	 (= 2 (length (term-in-app-form-to-args term))))
    (display-debug "/")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev1 (term-and-env-to-linarith-expr-and-env arg1 env denomterms posenv))
	   (expr1 (car prev1))
	   (env1 (cadr prev1))
	   (dts1 (caddr prev1))
	   (posenv1 (cadddr prev1))
	   (prev2 (term-and-env-to-linarith-expr-and-env arg2 env1 dts1 posenv1))
	   (expr2 (car prev2))
	   (env2 (cadr prev2))
	   (dts2 (caddr prev2))
	   (posenv2 (cadddr prev2)))
      (list (mk-term-in-app-form
	     (pt "DivES")
	     expr1 expr2)
	    env2
	    (append dts2 (list arg2)) posenv2)))
   ((and (term-in-app-form? term)
	 (term-in-const-form?
	  (term-in-app-form-to-final-op term))
	 (let ((cstring
		(const-to-name
		 (term-in-const-form-to-const
		  (term-in-app-form-to-final-op term)))))
	   (or (string=? "PosExp" cstring)
	       (string=? "IntExp" cstring)
	       (string=? "RatExp" cstring)))
	 (= 2 (length (term-in-app-form-to-args term))))
    (display-debug "exp")
    (let* ((args (term-in-app-form-to-args term))
	   (arg1 (car args))
	   (arg2 (cadr args))
	   (prev_exp (term-and-env-to-linarith-posexp-and-env arg2 posenv))
	   (expr_exp (car prev_exp))
	   (posenv1 (cadr prev_exp)))
      (if (contains-variable? expr_exp)
	  (begin
	    (display-debug "exponent contains var")
	    (parse-to-var arg1 env denomterms posenv1 expr_exp))
	  (begin
	    (display-debug "exponent does not contain var")
	    (let*
		((prev1 (term-and-env-to-linarith-expr-and-env
			 arg1 env denomterms posenv1))
		 (expr1 (car prev1))
		 (env1 (cadr prev1))
		 (dts1 (caddr prev1))
		 (posenv2 (cadddr prev1)))
	      (list (mk-term-in-app-form
		     (pt "ExpS")
		     expr1
		     expr_exp) env1 dts1 posenv2))))))
   (else
    (display-debug "variable")
    (parse-to-var term env denomterms posenv))))

; parsing to variable

(define (parse-to-var term env denomterms posenv . exponent)
  (let ((info (assoc-wrt term=? term env))
	(exp (if (null? exponent)
		 (pt "P One")
		 (car exponent))))
    (if info
	(list (mk-term-in-app-form
	       (pt "VarES")
	       (make-numeric-term-in-nat (cadr info))
	       exp)
	      env denomterms posenv)
	(let* ((i (length env))
	       (var-expr
		(mk-term-in-app-form
		 (pt "VarES")
		 (make-numeric-term-in-nat i)
		 exp)))
	  (list var-expr 
		(append
		 env
		 (list (list term i))) denomterms posenv)))))

  

; (term-to-linarith-expr-and-env .)
; does nearly the same like the previous function.
; But this function does not need an environment.
; It is assumed that one has an empty environment.
; (used when starting with first term)
(define (term-to-linarith-expr-and-env term)
  (display-debug "Going into term-to-linarith-expr-and-env.")
  (term-and-env-to-linarith-expr-and-env term '() '() '()))

; (terms-to-list-term .)
; builds up from a scheme (meta-)list of terms a list of terms.
(define (terms-to-list-term terms)
    (if (null? terms)
        (pt "(Nil rat)")
        (mk-term-in-app-form
         (make-term-in-const-form
          (let* ((constr (constr-name-to-constr "Cons"))
                 (tvars (const-to-tvars constr))
                 (subst (make-substitution tvars 
					   (list (py "rat")))))
            (const-substitute constr subst #f)))
         (car terms)
         (terms-to-list-term (cdr terms)))))


(define (terms-to-pos-list-term terms)
    (if (null? terms)
        (pt "(Nil pos)")
        (mk-term-in-app-form
         (make-term-in-const-form
          (let* ((constr (constr-name-to-constr "Cons"))
                 (tvars (const-to-tvars constr))
                 (subst (make-substitution tvars 
					   (list (py "pos")))))
            (const-substitute constr subst #f)))
         (car terms)
         (terms-to-pos-list-term (cdr terms)))))



;===================================================================
; 8. FUNCTION FOR SORTING EXPRESSIONS
;===================================================================


; (sort-term .) returns a term which has been sorted
; via the detour of the algebra expr.
(define (sort-term term)
  (if (not(term-in-app-form? term)) term
      (let* ((const-term (term-in-app-form-to-final-op term))
	     (args (term-in-app-form-to-args term))
	     (arg1 (car args))
	     (arg2 (cadr args))
	     (type1 (term-to-type arg1))
	     (type2 (term-to-type arg2))
	     (e1-and-env1
	      (term-to-linarith-expr-and-env arg1))
	     (expr1 (car e1-and-env1))
	     (env1 (cadr e1-and-env1))
	     (denomterms1 (caddr e1-and-env1))
	     (posenv1 (cadddr e1-and-env1))
	     (e2-and-env2
	      (term-and-env-to-linarith-expr-and-env
	       arg2 env1 denomterms1 posenv1))
	     (expr2 (car e2-and-env2))
	     (env2 (cadr e2-and-env2))
	     (denomterms2 (caddr e2-and-env2))
	     (posenv2 (cadddr e2-and-env2))
	     (rs (terms-to-list-term (map car env2)))
	     (ps (terms-to-pos-list-term (map car posenv2)))
	     (vse1
	      (nt (mk-term-in-app-form
		   (pt "EvalFrac")
		   (nt (mk-term-in-app-form
			(pt "NormalizeExpr")
			expr1))
		   rs ps)))
	     (vse2
	      (nt (mk-term-in-app-form
		   (pt "EvalFrac")
		   (nt (mk-term-in-app-form
			(pt "NormalizeExpr")
			expr2))
		   rs ps))))
	(list (mk-term-in-app-form const-term vse1 vse2)
	      denomterms2))))


;===================================================================
; 9. REFLECTION TACTIC COMMAND
;===================================================================


(define (simp-rat)
  (let ((goal-form (goal-to-formula(current-goal))))
    (if (not (atom-form? goal-form))
	(myerror "reflection"
		 "atomic goal-formula expected"))
    (let ((goal-term (atom-form-to-kernel goal-form)))
      (cond ((term=? goal-term (pt "False"))
	     (myerror "reflection"
		      "Falsum is not provable !!!"))
	    (else 
	     (begin
	       (display-debug "Reflection started.")
	       (simp-rat-intern
		goal-term)))))))

(define (simp-rat-intern goal-kernel)
  (display-debug "simp-rat-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)))
       (simpaux (simp-rat-aux goal-kernel))
       (nps1 (apply use-intern (list num-goals proof maxgoal simpaux))))
    ;(pp (goal-to-formula (num-goal-to-goal (caar nps1))))
    (if
     (classical-formula=?
      (goal-to-formula (num-goal-to-goal (caar nps1))) (pf "1=0->F"))
     (let* ((nps2 (apply normalize-goal-intern nps1))
	    (nps3 (apply use-intern (append nps2 (list "FimpliesF"))))
	    (nps4 (apply normalize-goal-intern nps3)))
       (if (formula=? 
	    (goal-to-formula (num-goal-to-goal (caar nps4)))
	    (pf "T"))
	   (let ((nps5 (apply use-intern (append nps4 (list "Truth-Axiom")))))
	     (set! PPROOF-STATE nps5)
	     (pproof-state-history-push PPROOF-STATE)
	     (display-new-goals num-goals number))
	   (begin
	     (set! PPROOF-STATE nps4)
	     (pproof-state-history-push PPROOF-STATE)
	     (display-new-goals num-goals number))))
     (begin
       (set! PPROOF-STATE nps1)
       (pproof-state-history-push PPROOF-STATE)
       (display-new-goals num-goals number)))))


(define (denom-product terms)
  (display-debug "denom-product")
  (if (null? terms)
      (pt "1#1")
      (if (= 1 (length terms))
	  (car terms)
	  (let* ((term (car terms))
		 (rem-terms (cdr terms))
		 (prod (denom-product rem-terms)))
	    (if (equal? (py "pos") (term-to-type term))
		prod
		(mk-term-in-app-form
		 (make-term-in-const-form
		  (pconst-name-to-pconst "RatTimes"))
		 term
		 prod))))))


(define (simp-rat-aux gt)
  (let* ((sgt (sort-term gt))
	 (sgt1 (car sgt))
	 (denomterms (cadr sgt))
	 (denomterm (denom-product denomterms))
	 (const-term (term-in-app-form-to-final-op gt))
	 (args (term-in-app-form-to-args gt))
	 (arg1 (car args))
	 (arg2 (cadr args))
	 (sorted-args
	  (term-in-app-form-to-args sgt1))
	 (vse1 (car  sorted-args))
	 (vse2 (cadr sorted-args))
	 (e1-and-env1
	  (term-to-linarith-expr-and-env arg1))
	 (e1 (car e1-and-env1))
	 (env1 (cadr e1-and-env1))
	 (denomterms1 (caddr e1-and-env1))
	 (posenv1 (cadddr e1-and-env1))
	 (e2-and-env2
	  (term-and-env-to-linarith-expr-and-env arg2 env1 denomterms1 posenv1))
	 (rs (terms-to-list-term (map car(cadr e2-and-env2))))
	 (ps (terms-to-pos-list-term (map car(cadddr e2-and-env2)))))
    (mk-proof-in-elim-form
     (BinaryBooleCompatA-proof vse1 arg1 vse2 arg2 const-term denomterm)
     (EvalSort-proof rs ps (car e1-and-env1))
     (EvalSort-proof rs ps (car e2-and-env2)))))


(av "eq" (py "alpha3=>alpha3=>boole"))

(sg "Equal alpha1_3 alpha1_1 -> Equal alpha2_4 alpha2_2
  -> ((eq alpha3_1 alpha3_2) -> F)
  -> ((alpha1=>alpha2=>boole)alpha1_3 alpha2_4)
  -> ((alpha1=>alpha2=>boole)alpha1_1 alpha2_2)")
(assume "alpha1_3" "alpha1_1" "alpha2_4" "alpha2_2" "eq"
	"alpha3_1" "alpha3_2" "alpha1=>alpha2=>boole")
(assume "!" "!!" "!!!" "!!!!")
(inst-with-to "alphaBinaryBooleCompat"
	      (pt "alpha1_3")
	      (pt "alpha1_1")
	      (pt "alpha2_4")
	      (pt "alpha2_2")
	      (pt "alpha1=>alpha2=>boole") "*")
(use "*")
(use "!")
(use "!!")
(use "!!!!")
; Proof finished.
(save "alphaBinaryBooleCompatA")

;(display-theorems "alphaBinaryBooleCompat")
;(display-theorems "alphaBinaryBooleCompatA")

(sg "F->F")
(search)
; Proof finished
(save "FimpliesF")


(define (BinaryBooleCompatA-proof term3 term1 term4 term2 const-term denomterm)
  (display-debug "BinaryBooleCompatA-proof")
  (let* ((denomtype (term-to-type denomterm))
	 (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
	   (proof-subst
	    (make-proof-in-aconst-form
	     (theorem-name-to-aconst "alphaBinaryBooleCompatA"))
	    (py "alpha1") type1)
	   (py "alpha2") type2)
	  (py "alpha3") (py "rat"))
	 term3 term1 term4 term2
 	 (make-term-in-const-form
	  (finalg-to-=-const (py "rat")))
	 (if (equal? denomtype (py "pos"))
	     (pt "One")
	     denomterm)
	 (if (equal? denomtype (py "pos"))
	     (pt "One")
	     (pt "0#1"))
	 const-term)
        (myerror "BinaryBooleCompat-proof" "types do not fit"))))

; (define (simphyp-rat hyp)
;   (display-debug "simphyp-rat")
;   (let ((fml (proof-to-formula
; 	      (hyp-info-to-leaf 
; 	       (car (pproof-state-to-num-goals)) hyp))))
;     (if (not (atom-form? fml))
; 	(myerror "simphyp-rat"
; 		 "atomic goal-formula expected"))
;     (let ((term (atom-form-to-kernel fml)))
;       (display-debug "Reflection started.")
;       (simphyp-rat-intern hyp term))))

; (define (simphyp-rat-intern hyp term)
;   (display-debug "simphyp-rat-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)))
; 	 (simpaux (simp-rat-aux term))
; 	 (simphyp-result
; 	  (apply simphyp-intern
; 		 (append (list num-goals proof maxgoal) simpaux))))
;     (if (not simphyp-result)
; 	(begin (display-comment "no simplification possible")
; 	       (if COMMENT-FLAG (newline)))
; 	(begin
; 	  (set! PPROOF-STATE simphyp-result)
; 	  (pproof-state-history-push PPROOF-STATE)
; 	  (display-new-goals num-goals number)))))




(remove-var-name "n" "m" "k")
(av "n" "m" "k" (py "pos"))

;===================================================================
; 10. EXAMPLES AND DEBUGGING
;===================================================================

;(to be done)

(define (refl-debug-intern term flag)
  (let*
      ((e (term-to-linarith-expr-and-env term))
       (expr (car e))
       (env (terms-to-list-term (map car (cadr e))))
       (denomterms (terms-to-list-term (caddr e)))
       (posenv (terms-to-pos-list-term (map car (cadddr e)))))
    (newline)
    (display "---------------------------")(newline)
    (display "Reflection Debug")(newline)
    (display "---------------------------")(newline)
    (display "  Term : ")
    (pp term)
    (display "  Expression : ")
    (pp expr)
    (display "  Environment : ")
    (pp env)
    (display "  Positive Environment : ")
    (pp posenv)
    (display "  Denominator : ")
    (pp denomterms)
    (newline)
    (display "  Evaluated Expression : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalExprES")
	     expr env posenv)))
    (display "  After 'ExpESToExprE' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalExprE")
	     (mk-term-in-app-form
	      (pt "ExprESToExprE")
	      expr)
	     env posenv)))
    (display "  After 'ExpUnfold' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalExpr")
	     (mk-term-in-app-form
	      (pt "ExpUnfold")
	      (mk-term-in-app-form
	       (pt "ExprESToExprE")
	       expr))
	     env posenv)))
    (display "  After 'DistPosexpFinal' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalExpr")
	     (mk-term-in-app-form
	      (pt "DistPosexpFinal")
	      (mk-term-in-app-form
	       (pt "ExpUnfold")
	       (mk-term-in-app-form
		(pt "ExprESToExprE")
		expr)))
	     env posenv)))
    (display "  After 'DistFinal' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalExpr")
	     (mk-term-in-app-form
	      (pt "DistFinal")
	      (mk-term-in-app-form
	       (pt "DistPosexpFinal")
	       (mk-term-in-app-form
		(pt "ExpUnfold")
		(mk-term-in-app-form
		 (pt "ExprESToExprE")
		 expr))))
	     env posenv)))
    (display "  After 'ExprToNumDen' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalFrac")
	     (mk-term-in-app-form
	      (pt "ExprToNumDen")
	      (mk-term-in-app-form
	       (pt "DistFinal")
	       (mk-term-in-app-form
		(pt "DistPosexpFinal")
		(mk-term-in-app-form
		 (pt "ExpUnfold")
		 (mk-term-in-app-form
		  (pt "ExprESToExprE")
		  expr)))))
	     env posenv)))
    (if (equal? flag #t)
	(begin
	  (display "    corresponding expression : ")
	  (pp (nt (mk-term-in-app-form
		   (pt "ExprToNumDen")
		   (mk-term-in-app-form
		    (pt "DistFinal")
		    (mk-term-in-app-form
		     (pt "DistPosexpFinal")
		     (mk-term-in-app-form
		      (pt "ExpUnfold")
		      (mk-term-in-app-form
		       (pt "ExprESToExprE")
		       expr)))))))))
    (display "  After 'SimpVars' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalFrac")
	     (mk-term-in-app-form
	      (pt "SimpVars")
	      (mk-term-in-app-form
	       (pt "ExprToNumDen")
	       (mk-term-in-app-form
		(pt "DistFinal")
		(mk-term-in-app-form
		 (pt "DistPosexpFinal")
		 (mk-term-in-app-form
		  (pt "ExpUnfold")
		  (mk-term-in-app-form
		   (pt "ExprESToExprE")
		   expr))))))
	     env posenv)))
    (display "  After 'UnifyMon' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalFrac")
	     (mk-term-in-app-form
	      (pt "UnifyMon")
	      (mk-term-in-app-form
	       (pt "SimpVars")
	       (mk-term-in-app-form
		(pt "ExprToNumDen")
		(mk-term-in-app-form
		 (pt "DistFinal")
		 (mk-term-in-app-form
		  (pt "DistPosexpFinal")
		  (mk-term-in-app-form
		   (pt "ExpUnfold")
		   (mk-term-in-app-form
		    (pt "ExprESToExprE")
		    expr)))))))
	     env posenv)))
    (if (equal? flag #t)
	(begin
	  (display "    corresponding expression : ")
	  (pp (nt (mk-term-in-app-form
		   (pt "UnifyMon")
		   (mk-term-in-app-form
		    (pt "SimpVars")
		    (mk-term-in-app-form
		     (pt "ExprToNumDen")
		     (mk-term-in-app-form
		      (pt "DistFinal")
		      (mk-term-in-app-form
		       (pt "DistPosexpFinal")
		       (mk-term-in-app-form
			(pt "ExpUnfold")
			(mk-term-in-app-form
			 (pt "ExprESToExprE")
			 expr)))))))))))
    (display "  After 'Cancel' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalFrac")
	     (mk-term-in-app-form
	      (pt "Cancel")
	      (mk-term-in-app-form
	       (pt "UnifyMon")
	       (mk-term-in-app-form
		(pt "SimpVars")
		(mk-term-in-app-form
		 (pt "ExprToNumDen")
		 (mk-term-in-app-form
		  (pt "DistFinal")
		  (mk-term-in-app-form
		   (pt "DistPosexpFinal")
		   (mk-term-in-app-form
		    (pt "ExpUnfold")
		    (mk-term-in-app-form
		     (pt "ExprESToExprE")
		     expr))))))))
	       env posenv)))
    (if (equal? flag #t)
	(begin
	  (display "    corresponding expression : ")
	  (pp (nt (mk-term-in-app-form
		   (pt "Cancel")
		   (mk-term-in-app-form
		    (pt "UnifyMon")
		    (mk-term-in-app-form
		     (pt "SimpVars")
		     (mk-term-in-app-form
		      (pt "ExprToNumDen")
		      (mk-term-in-app-form
		       (pt "DistFinal")
		       (mk-term-in-app-form
			(pt "DistPosexpFinal")
			(mk-term-in-app-form
			 (pt "ExpUnfold")
			 (mk-term-in-app-form
			  (pt "ExprESToExprE")
		    expr))))))))))))
    (display "  After 'CleanUp' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalFrac")
	     (mk-term-in-app-form
	      (pt "CleanUp")
	      (mk-term-in-app-form
	       (pt "Cancel")
	       (mk-term-in-app-form
		(pt "UnifyMon")
		(mk-term-in-app-form
		 (pt "SimpVars")
		 (mk-term-in-app-form
		  (pt "ExprToNumDen")
		  (mk-term-in-app-form
		   (pt "DistFinal")
		   (mk-term-in-app-form
		    (pt "DistPosexpFinal")
		    (mk-term-in-app-form
		     (pt "ExpUnfold")
		     (mk-term-in-app-form
		      (pt "ExprESToExprE")
		      expr)))))))))
	      env posenv)))
    (display "  After 'SimpVars' : ")
    (pp (nt (mk-term-in-app-form
	     (pt "EvalFrac")
	     (mk-term-in-app-form
	      (pt "SimpVars")
	      (mk-term-in-app-form
	       (pt "CleanUp")
	       (mk-term-in-app-form
		(pt "Cancel")
		(mk-term-in-app-form
		 (pt "UnifyMon")
		 (mk-term-in-app-form
		  (pt "SimpVars")
		  (mk-term-in-app-form
		   (pt "ExprToNumDen")
		   (mk-term-in-app-form
		    (pt "DistFinal")
		    (mk-term-in-app-form
		     (pt "DistPosexpFinal")
		     (mk-term-in-app-form
		      (pt "ExpUnfold")
		      (mk-term-in-app-form
		       (pt "ExprESToExprE")
		       expr))))))))))
	      env posenv)))
    ))

(define (refl-debug term)
  (refl-debug-intern term #f))

(define (refl-full-debug term)
  (refl-debug-intern term #t))

(set! COMMENT-FLAG #t)


#|

; in real.scm :
; (1#exp 2(k+2))+(1#exp 2(k+1))+(1#exp 2(k+2))<=(1#exp 2 k)

(refl-debug (pt "(a*(exp b 2)+3)*a"))
(refl-debug (pt "0"))

(refl-debug (pt "1#exp 2 k"))
(refl-debug (pt "(1#exp 2(k+2))+(1#exp 2(k+1))+(1#exp 2(k+2))"))
(refl-debug (pt "(exp a 30) / (exp a 27)"))

(refl-debug (pt "(exp a 2 + 3*a - exp b 2 * exp a 3) / (a*3)"))

(refl-debug (pt "exp rat (2+pos+3)"))
(refl-debug (pt "(exp rat (2+pos+2*pos))/(exp rat (2+pos))"))

|#


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