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

#|  A Short Introduction to Reflection

The file reflection.scm provides the command (reflection). This
command can in many cases automatically find a proof of an atomic
goal provided the goal-kernel is a boolean term composed by
program-constants of type boole=>boole=> nat and nat=>nat=>nat.

EXAMPLE:

(sg "nat0+2+nat2<3+nat2+nat0")
(strip)
(reflection)
; ;
; ok, ?_2 is proved.  Proof finished.

(reflection) uses first (nt ) to normalise the goal, in our
example to nat0+nat2<=nat2+nat0. Then the goal is sorted, here to
nat2+nat0<=nat2+nat0 such that the variable occur in the same
order in the lhs and rhs of the goal. The sorted goal is then
returned hoping that it normalises to True. (reflection) also
tries to find a proof of "sortedgoal->goal".

In case a proof cannot been found, (reflection) will end with an
error message and some hints where the problem might be are given.


GENERALLY:

Assume the goal to be R(s,t) where R is of type nat->nat->boole.
Let s' and t' be the sorted terms of s and t respectively.

(reflection) tries to find proofs of s'=s and t'=t. Then the
theorem R(s',t') -> s'=s -> t'=t -> R(s,t) is applied so that we
are left with the goal R(s',t'). Since s' and t' are sorted the
chances that R(s',t') normalises to True are quite high.


WHICH FORM CAN THE GOAL HAVE ?

The set of allowed goals is inductively defines as

 Goal: R(s,t) | f(G,H)

 where f:boole->boole->boole and G,H are goals
       R:nat  ->nat  ->boole
       s:nat

However the sorting works only fine for terms not involving other
functions than + and *. Other functions are treated as primitives.


REMARK:

The file reflection_numbers.scm extends (reflection) to terms of
type "pos", so that R:pos/nat->pos/nat->boole is allowed.

END |#



(display "
Begin of reflection_nat.scm
")




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

;(load
; (string-append(getenv "SCHEME_LIBRARY_PATH")"/init/chez.init"))
;(require 'pretty-print)
;(define slpp pretty-print)
;(require (lib "errortrace.ss" "errortrace"))

(begin
  
(set! COMMENT-FLAG #f)



(define (termlist-to-string termlist)
  (do ((strs (map term-to-string termlist) (cdr strs))
       (i 0 (+ i 1))
       (str ""
            (string-append
             str "   " (number->string i) ": " (car strs))))
      ((null? strs) str)))




(define DEBUG-FLAG #f)
(define RFL-DEBUG-FLAG #f)

(define (display-debug . debug-strings)
  (if DEBUG-FLAG (display-more debug-strings)))

(define (display-rfl-debug . debug-string-list)
  (if RFL-DEBUG-FLAG (display-more debug-string-list)))





(exload  "ordinals/nat.scm")
(libload "list.scm")
(mload   "abbrev.scm")
(mload   "unicode.scm") ; OPTIONAL
(exload  "ordinals/reflection_thms.scm")

; variables
(av "ms"  "ns"  (py "list nat"))
(av "mms" "nns" (py "list list nat"))

(av "a"   "b"   (py "alpha"))
(av "as"  "bs"  (py "list alpha"))
(av "aas" "bbs" (py "list list alpha"))

(av "r"         (py "alpha=>alpha=>boole"))


(set! COMMENT-FLAG #t)

; 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

) ; matches (begin




; DEFINITIONS

(begin

(set! COMMENT-FLAG #f)

; Alegbra of Expressions   expr
(add-alg "expr"
	 '("Var" "nat=>expr")
	 '("Add" "list list nat=>expr")
	 '("Mult" "list nat=>expr"))


; Evaluation   Eval
(add-program-constant "Eval"  (py "expr=>list nat=>nat") 1)
(acrs
 "Eval (Var nat)       (Nil nat)"  "Zero"
 "Eval (Var Zero)      (m::ns)"    "m"
 "Eval (Var(Succ nat)) (m::ns)"    "Eval(Var nat)ns"

 "Eval (Add(Nil list nat))  ns"    "Zero"
 "Eval (Add(ms::nns))       ns"
         "(Eval(Mult ms) ns) + (Eval(Add nns) ns)"

 "Eval (Mult(Nil nat))      ns"    "1"
 "Eval (Mult(m::ms))        ns"
         "(Eval(Var m)(ns))  * (Eval(Mult ms) ns)")



; SortListInsert inserts the element a at the first place of
; the list b::bs such that a is "smaller" then the following element

(add-program-constant
 "SortListInsert"
 (py "(alpha=>alpha=>boole)=>alpha=>list alpha=>list alpha") 1)

(acrs
 "(SortListInsert alpha) r a (Nil alpha)" "a:"
 "(SortListInsert alpha) r a (b::bs)"
 "[if (r a b) (a::b::bs) (b::(SortListInsert alpha) r a bs)]")



; SortList sorts a list of type alpha according to the relation r

(add-program-constant
 "SortList"
 (py "(alpha=>alpha=>boole)=>list alpha=>list alpha") 1)

(acrs
 "(SortList alpha) r (Nil alpha)" "(Nil alpha)"
 "(SortList alpha) r (a::as)"
          "(SortListInsert alpha) r  a ((SortList alpha) r as)")



; OrderList is an order on (list alpha): First come the small lists,
; lists of equal length are lexicographically ordered

(add-program-constant
 "OrderList"
 (py "(alpha=>alpha=>boole)=>list alpha=>list alpha=>boole") 1)

(acrs
 "(OrderList alpha)r(Nil alpha) as"       "True"
 "(OrderList alpha)r(a::as)(Nil alpha)"   "False"
 "(OrderList alpha)r(a::as)(b::bs)"
 "[if (Lh(a::as)<Lh(b::bs))
      (True)
      [if (Lh(a::as)=Lh(b::bs))
          [if (r a b)
              (True)
              [if (r b a)
                  (False)
                  ((OrderList alpha)r(as)(bs))]]
          (False)]]")




; SortExprAux uses (SortListnat) to help sorting expressions

(add-program-constant "SortExprAux" (py"list list nat=>list list nat") 1)

(acrs
 "SortExprAux(Nil list nat)" "(Nil list nat)"
 "SortExprAux(ns::nns)" "(SortList nat)(NatLt)(ns)::SortExprAux(nns)")



; SortExpr sorts the expressions with the help of SortExprAux

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

(acrs
 "SortExpr(Var n)"        "Var n"
 "SortExpr(Add nns)"
       "Add((SortList list nat)((OrderList nat) NatLt)(SortExprAux nns))"
 "SortExpr(Mult ns)"      "Mult((SortList nat)(NatLt) ns)")


(set! COMMENT-FLAG #t)
(newline)
(display-constructors      "expr")
(display-program-constants "Eval")
(display-program-constants "SortListInsert")
(display-program-constants "SortList")
(display-program-constants "OrderList")
(display-program-constants "SortExprAux")
(display-program-constants "SortExpr")
(newline)

) ; matches (begin




; SOME PROPERTIES

(begin

(set! COMMENT-FLAG #f)

(sg "all mms,ms.
  Eval(Add((SortListInsert list nat)((OrderList nat)NatLt) ms mms)) ns
   = Eval(Add(ms::mms))ns")
(assume "ns")
(ind)
    (search)
(assume "ms0" "mms" "IH" "ms")
(ng)
(cases (pt"(OrderList nat)NatLt ms ms0"))
    (search)
(assume "*")
(ng)
(simp "IH")
(ng)
(simp-with "NatPlusComm" (pt" Eval(Mult ms0)ns")(pt" Eval(Mult ms)ns"))
(use "Truth-Axiom")
; Proof finished
(arw"Eval(Add((SortListInsert list nat)((OrderList nat)NatLt) ms mms))ns"
    "Eval(Add(ms::mms))ns")


(sg "all ms,nat.
     (Eval(Mult((SortListInsert nat) NatLt nat ms)) ns)
     =(Eval(Mult(nat::ms))ns)")
(assume "ns")
(ind)
    (search)
(assume "nat1" "ms" "IH" "nat2")
(ng)
(cases (pt"nat2<nat1"))
    (search)
(assume "*")
(ng)
(simp "IH")
(ng)
(simp-with "NatTimesComm" (pt" Eval(Var nat1)ns")(pt" Eval(Var nat2)ns"))
(use "Truth-Axiom")
; Proof finished
(arw "Eval(Mult((SortListInsert nat) NatLt nat ms)) ns"
     "Eval(Mult(nat::ms))ns")



(sg "all ns,ms Eval(Mult((SortList nat) NatLt ms))ns=Eval(Mult ms) ns")
(assume "ns")
(ind)
    (use "Truth-Axiom")
(assume "nat" "ms" "IH")
(ng)
(simp "IH")
(use "Truth-Axiom")
; Proof finished
(arw "Eval(Mult((SortList nat) NatLt ms))ns" "Eval(Mult ms) ns")



(sg "all ns,expr Eval(SortExpr expr)ns=Eval expr ns")
(assume "ns")
(cases)
    (strip)
    (use "Truth-Axiom")
(ind)
    (use "Truth-Axiom")
(assume "ms" "mms" "IH")
(ng)
(simp "IH")
(auto)
; Proof finished
(arw "Eval(SortExpr expr)ns" "Eval expr ns")


(sg "all ns,expr. Equal(Eval(SortExpr expr)ns) (Eval expr ns)")
(assume "ns" "expr")
(use-with "Eq-Refl" (py "nat") (pt"(Eval expr ns)"))
;Proof finished.
(save "EvalSortEqual")
(define (EvalSortEqual-proof ns expr)
  (mk-proof-in-elim-form
   (make-proof-in-aconst-form (theorem-name-to-aconst "EvalSortEqual"))
   ns expr))



(set! COMMENT-FLAG #t)
(display-theorems "EvalSortEqual")
; Eval(SortExpr expr)ns ≈ Eval expr ns

) ; matches (begin


(begin


; The following functions perform the translation
; from a term of type 'nat' to a term of type 'expr'.

; RFL-term-in-special-app-form?
; tests if term (first argument) has a particular form.

  (define (RFL-term-in-special-app-form? term string)
    (display-rfl-debug "RFL-term-in-special-app-form?   term: "
                   (term-to-string term)
                   "   string: " string)
    (let ((str
           (cond ((term-in-app-form? term)
                  (const-to-name
                   (term-in-const-form-to-const
                    (term-in-app-form-to-final-op term))))
                 ((term-in-const-form? term)
                  (const-to-name (term-in-const-form-to-const term)))
                 ((term-in-var-form? term)
                  (string-append
                   "VAR"
                   (type-to-string
                    (var-to-type (term-in-var-form-to-var term)))))
                 (else (myerror "RFL-term-in-special-app-form?"
                                "Unkown term :"
                                (term-to-string term))))))
      (string=? string str)))



; RFL-make-list
; creates a list from a term (with the appropriate type)

  (define (RFL-make-list term)
    (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(term-to-type term)))))
        (const-substitute constr subst #f)))
     term
     (make-term-in-const-form
      (let* ((constr (constr-name-to-constr "Nil"))
             (tvars (const-to-tvars constr))
             (subst (make-substitution tvars (list(term-to-type term)))))
        (const-substitute constr subst #f)))))

;(pp (RFL-make-list (pt "1::2:")))
; (1::2:):


; RFL-append-lists
; appends two (term) lists (with the appropriate type)

  (define (RFL-append-lists arg1 arg2)
    (display-rfl-debug "RFL-append-lists   arg1: " (term-to-string arg1)
                   "   arg2: " (term-to-string arg2))
    (mk-term-in-app-form
     (make-term-in-const-form
      (let* ((const (pconst-name-to-pconst "ListAppend"))
             (tvars (const-to-tvars const))
             (listtype (term-to-type arg1))
             (type (car (alg-form-to-types listtype)))
             (subst (make-substitution tvars (list type))))
        (const-substitute const subst #f)))
     arg1
     arg2))

; (pp (nt (RFL-append-lists (pt "1:") (pt "2:"))))
; 1::2:


; RFL-var-term-to-expr
; writes term into the environment

  (define (RFL-var-term-to-expr term env)
    (display-rfl-debug "RFL-var-term-to-expr    term:  "
                   (term-to-string term)
                   "   env: " (termlist-to-string(map car env)))
    (let ((info (assoc-wrt term=? term env)))
      (if info
          (list (make-numeric-term-in-nat (cadr info)) env)
          (let ((i (length env)))
            (list (make-numeric-term-in-nat i)
                  (append env (list (list term i))))))))

; (pp(car(RFL-var-term-to-expr (pt "") '())))
; 0
; (pp(caadr(RFL-var-term-to-expr (pt "n") '())))
; (n 0)



; RFL-mult-term-to-expr
; works with 'NatTimes'-terms, all other things are written
; directly via RFL-var-term-to-expr into the environment

  (define (RFL-mult-term-to-expr term env)
    (display-rfl-debug "RFL-mult-term-to-expr   term:"
                   (term-to-string term)
                   "    env:  " (termlist-to-string(map car env)))
    (if (not (RFL-term-in-special-app-form? term "NatTimes"))
        (let* ((prev (RFL-var-term-to-expr term env))
               (prev-term (car prev))
               (prev-env (cadr prev)))
          (list (RFL-make-list prev-term) prev-env))
        (let* ((args (term-in-app-form-to-args term))
               (arg1 (car args))
               (arg2 (cadr args))
               (prev1 (RFL-mult-term-to-expr arg1 env))
               (prev1-term (car prev1))
               (prev1-env (cadr prev1))
               (prev2 (RFL-mult-term-to-expr arg2 prev1-env))
               (prev2-term (car prev2))
               (prev2-env (cadr prev2)))
          (list (RFL-append-lists prev1-term prev2-term)
                prev2-env))))

; (pp(nt(car (RFL-mult-term-to-expr (pt "n*m") '()))))
; 0::1:
; (pp(cadr (RFL-mult-term-to-expr (pt "n*m") '())))
; ((n 0) (m 1))



; RFL-cut-succ
; cuts all 'Succ' from a term of type nat,
; and gives back a list, first element is the number of 'Succ'
; that were cut, and second element is the remaining term
; (with no 'Succ' any more)
; to run RFL-cut-succ, you have to provide k=0

  (define (RFL-cut-succ term k)
    (if (RFL-term-in-special-app-form? term "Succ")
        (let ((arg (term-in-app-form-to-arg term)))
          (RFL-cut-succ arg (+ k 1)))
        (list k term)))

; (pp(RFL-cut-succ(nt(pt "k*n+3")) 0))
; (3 k*n)



; RFL-make-succ-expr
; creates a list for the 'Add' constructor,
; representing all 'Succ' from the original term
; (k is number of 'Succ')

  (define (RFL-make-succ-expr k)
    (if (= k 0)
        (pt "(Nil (list nat))")
        (let ((prev (RFL-make-succ-expr (- k 1))))
          (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 (term-to-type (pt "(Nil nat)"))))))
              (const-substitute constr subst #f)))
           (pt "(Nil nat)")
           prev))))

; (pp (nt (RFL-make-succ-expr 3)))
; (Nil nat)::(Nil nat)::(Nil nat):


; RFL-add-term-to-expr
; works with 'NatPlus-terms', all other things are
; given to RFL-mult-term-to-expr
; first argument k means how many 'Succ' have to be added

  (define (RFL-add-term-to-expr k term umgebung)
    (display-rfl-debug "RFL-add-term-to-expr   k: "
                   (number->string k)
                   "   term:  " (term-to-string term)
                   "   umgebung:" (termlist-to-string(map car umgebung)))
    (if (RFL-term-in-special-app-form? term "Zero")
        (list (RFL-make-succ-expr k) umgebung)
        (if (RFL-term-in-special-app-form? term "NatPlus")
            (let* ((args (term-in-app-form-to-args term))
                   (arg1 (car args))
                   (arg2 (cadr args))
                   (prev1 (RFL-add-term-to-expr 0 arg1 umgebung))
                   (prev1-term (car prev1))
                   (prev1-env (cadr prev1))
                   (prev2 (RFL-add-term-to-expr 0 arg2 prev1-env))
                   (prev2-term (car prev2))
                   (prev2-env (cadr prev2))
                   (prev-term (RFL-append-lists prev1-term prev2-term))
                   (succ-term (RFL-make-succ-expr k))
                   (final-term (RFL-append-lists succ-term prev-term)))
              (list final-term prev2-env))
            (let* ((prev (RFL-mult-term-to-expr term umgebung))
                   (prev-term (RFL-make-list (car prev)))
                   (prev-env (cadr prev))
                   (succ-term (RFL-make-succ-expr k))
                   (final-term (RFL-append-lists succ-term prev-term)))
              (list final-term prev-env)))))


; RFL-term-and-env-to-expr-and-env
; takes a term of type 'nat' and an environment,
; and creates a term of type 'expr' (with environment)

  (define (RFL-term-and-env-to-expr-and-env pre-term umgebung)
    (display-rfl-debug "RFL-term-and-env-to-expr-and-env   pre-term: "
                   (term-to-string pre-term))
    (let ((term (nt pre-term)))
      (cond  
       ((RFL-term-in-special-app-form? term "Zero")
        (list (pt "Add(Nil list nat)") umgebung))
       ((or (RFL-term-in-special-app-form? term "Succ")
            (RFL-term-in-special-app-form? term "NatPlus")
            (RFL-term-in-special-app-form? term "NatTimes"))
        (let* ((cut-term (RFL-cut-succ term 0))
               (number-of-succs (car cut-term))
               (new-term (cadr cut-term))
               (prev
                (RFL-add-term-to-expr number-of-succs new-term umgebung))
               (prev-term (car prev))
               (prev-env (cadr prev)))
          (list (make-term-in-app-form
                 (make-term-in-const-form
                  (constr-name-to-constr "Add"))
                 prev-term)
                prev-env)))
       (else (let* ((prev (RFL-var-term-to-expr term umgebung))
                    (prev-term (car prev))
                    (prev-env (cadr prev)))
               (list (make-term-in-app-form
                      (make-term-in-const-form
                       (constr-name-to-constr "Var"))
                      prev-term)
                     prev-env))))))




; RFL-term-to-expr-and-env
; this is the main function for
;   term of type nat -> term of type expr
; here you don't have to provide an environment

 (define (RFL-term-to-expr-and-env term)
   (RFL-term-and-env-to-expr-and-env term '()))

; (pp(nt(car (RFL-term-to-expr-and-env(pt "3")))))
; Add((Nil nat)::(Nil nat)::(Nil nat):)
; (pp(nt(cdr (RFL-term-to-expr-and-env(pt "3")))))
; (Null)
; (pp(nt(car (RFL-term-to-expr-and-env(pt "nat0+nat1")))))
; (pp(nt(cadr (RFL-term-to-expr-and-env(pt "nat0*nat1+nat2")))))
; ((n 0))

 

; RFL-terms-to-list-term
; creates a list of terms (with the appropriate type)
; from a scheme list of terms

  (define (RFL-terms-to-list-term terms)
    (if (null? terms)
        (pt "(Nil nat)")
        (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 "nat")))))
            (const-substitute constr subst #f)))
         (car terms)
         (RFL-terms-to-list-term (cdr terms)))))

) ; matches begin



(begin


  (define (tyeq type1 type2 tystr)
    (and (string=? (type-to-string type1) tystr)
         (string=? (type-to-string type2) tystr)))


; (sort-two-terms arg1 arg2) sorts arg1 arg2 according to the
; environment of arg1 enlarged by arg2

  (define (sort-two-terms arg1 arg2)
    (display-debug "sort-two-terms.   arg1: " (term-to-string arg1)
                   "   arg2: " (term-to-string arg2))
    (let* ((e1-and-env1 (RFL-term-to-expr-and-env arg1))
           (e2-and-env2 (RFL-term-and-env-to-expr-and-env
                         arg2
                         (cadr e1-and-env1)))
           (ns (RFL-terms-to-list-term (map car(cadr e2-and-env2)))))
      (list
       (nt(mk-term-in-app-form
           (pt "Eval")
           (nt(make-term-in-app-form(pt "SortExpr")(car e1-and-env1)))
           ns))
       (nt(mk-term-in-app-form
           (pt "Eval")
           (nt(make-term-in-app-form(pt "SortExpr")(car e2-and-env2)))
           ns)))))



; (sort-term term) returns a term which has been sorted
; with the help of (sort-two-terms )


  (define (sort-term term)
    (display-debug "sort-term.   term: " (term-to-string term))
    (if (not(term-in-app-form? term)) term
        (let* ((const-term (term-in-app-form-to-final-op term))
               (const-string (term-to-string const-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)))
          (cond ((tyeq type1 type2 "boole")
                 (mk-term-in-app-form
                  const-term
                  (sort-term arg1) (sort-term arg2)))
                ((tyeq type1 type2 "pos")
                 (let((nat-arg1
                       (nt(make-term-in-app-form(pt "PosToNat")arg1)))
                      (nat-arg2
                       (nt(make-term-in-app-form(pt "PosToNat")arg2))))
                 (cond ((string=? const-string "=")
                        (sort-term (make-=-term nat-arg1 nat-arg2)))
                       ((string=? const-string "PosLt")
                        (sort-term
                         (mk-term-in-app-form (pt "NatLt") nat-arg1 nat-arg2)))
                       ((string=? const-string "PosLe")
                        (sort-term
                         (mk-term-in-app-form (pt "NatLe") nat-arg1 nat-arg2)))
                       (else
                        (let ((vses (sort-two-terms nat-arg1 nat-arg2)))
                          (mk-term-in-app-form
                           const-term
                           (make-term-in-app-form
                            (pt "PosPred")
                            (mk-term-in-app-form (pt "NatToPos")(car vses)))
                           (make-term-in-app-form
                            (pt "PosPred")
                            (mk-term-in-app-form (pt "NatToPos")(cadr vses)))))
                        ))))
                ((tyeq type1 type2 "nat")
                 (let ((vses (sort-two-terms arg1 arg2)))
                   (mk-term-in-app-form
                    const-term (car vses)(cadr vses))))
                (else
                 (myerror "sort-term"
                          "Other types not implemented !"))))))


  (define (no-further-simp-possible goalterm)
    (let ((sorted-goalterm
           (sort-term goalterm)))
      (newline)(display-comment "I can not deal with the following:")
      (newline)(pp goalterm)
      (display-comment "which sorts to:")
      (newline)(pp sorted-goalterm)
      (display-comment "and then normalises to:")
      (newline)(pp(nt sorted-goalterm))
      (myerror "Try to prove this term by hand and add it as RW-rule.")))


) ;matches (begin





;;    (reflection)


(begin


; (=-to-eq-proof term1 term2) returns a proof of
; term1=term2 -> term1≈term2

  (define (=-to-eq-proof term1 term2)
    (mk-proof-in-elim-form
     (make-proof-in-aconst-form
      (finalg-to-=-to-eq-aconst (term-to-type term1)))
     term1 term2))



; (reflection) is th main function. It just checks that the goal
; is atomic not normalising to false

  (define (reflection)
    (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))
             (norm-goal-term (nt goal-term)))
        (cond ((term=? norm-goal-term (pt"False"))
               (myerror "reflection"
                        "Goal formula normalises to False."
                        "Falsum is not provable !!!"))
              (else (reflection-intern norm-goal-term))))))



; (reflection-intern normal-goal-kernel) calls
; (reflection-aux-proof normal-goal-kernel), sets the PPROOF-STATE
; and pushes the pproof-state-history.

  (define (reflection-intern normal-goal-kernel)
    (display-debug "reflection intern  normal-goal-kernel: "
                   (term-to-string normal-goal-kernel))
    (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))))
      (set! PPROOF-STATE
            (apply
             use-intern
             (list num-goals proof maxgoal
                   (reflection-aux-proof normal-goal-kernel))))
      (newline)
      (pproof-state-history-push PPROOF-STATE)
      (display-new-goals num-goals number)))



; (reflection-aux-proof gt) returns a proof of gt (hopefully).
; It checks the type of the arguments and calls the corresponding
; auxiliary function.

  (define (reflection-aux-proof gt)
    (display-comment "")
    (display-debug "reflection-aux-proof.   gt: " (term-to-string gt))
    (let ((sgt (sort-term gt)))
      (cond ((term=? gt (pt"True")) truth-proof)
            ((or (term=? sgt gt) (term=? (nt sgt) gt))
             (display-comment
              "WARNING, reflection-aux-proof: All terms are sorted !")
             (no-further-simp-possible gt))
; Goal-term is in application form.
            ((term-in-app-form? gt)
             (let* ((args (term-in-app-form-to-args gt))
                    (type1 (term-to-type(car args)))
                    (type2 (term-to-type(cadr args))))
               (cond
; If both arguments are of type nat, then use reflection-aux-nat.
                ((tyeq type1 type2 "nat")
                 (reflection-aux-nat gt sgt))
; If both arguments are of type pos, then use reflection-aux-pos
                ((tyeq type1 type2 "pos")
                 (reflection-aux-pos gt sgt))
; If both arguments are of type boole, then we decompose the goal-term.
                ((tyeq type1 type2 "boole")
                 (reflection-aux-boole gt sgt))
                (else (no-further-simp-possible gt)))))
            (else (no-further-simp-possible gt)))))





; (reflection-aux-nat gt sgt) returns proof of gt building a proof of
; (sgt->gt) whereas sgt will be shown by (reflection-aux-proof ).
; The two args must be of type nat.

  (define (reflection-aux-nat goalterm sortedgoalterm)
    (display-debug "reflection-aux-nat   "
                   "goalterm: " (term-to-string goalterm)
                   "  sortedgoalterm: " (term-to-string sortedgoalterm))
    (let*
        ((const-term (term-in-app-form-to-final-op goalterm))
         (args (term-in-app-form-to-args goalterm))
         (arg1 (car args))
         (arg2 (cadr args))
         (sorted-args (term-in-app-form-to-args sortedgoalterm))
         (vse1 (car  sorted-args))
         (vse2 (cadr sorted-args))
         (e1-and-env1 (RFL-term-to-expr-and-env arg1))
         (e2-and-env2
          (RFL-term-and-env-to-expr-and-env arg2 (cadr e1-and-env1)))
         (ns (RFL-terms-to-list-term(map car(cadr e2-and-env2)))))
      (mk-proof-in-elim-form
       (BinaryBooleCompat-proof vse1 arg1 vse2 arg2 const-term)
       (EvalSortEqual-proof ns (car e1-and-env1))
       (EvalSortEqual-proof ns (car e2-and-env2))
       (reflection-aux-proof (nt sortedgoalterm)))))




; (reflection-aux-pos gt sgt) returns proof of gt building a proof of
; (sgt->gt) whereas sgt will be shown by (reflection-aux-proof ).
; The two args must be of type pos.

  (define (reflection-aux-pos goalterm sortedgoalterm)
    (display-debug "reflection-aux-pos   "
                   "goalterm: " (term-to-string goalterm)
                   "  sortedgoalterm: " (term-to-string sortedgoalterm))
    (let* ((const-term   (term-in-app-form-to-final-op goalterm))
           (const-string (term-to-string const-term))
           (args (term-in-app-form-to-args goalterm))
           (arg1 (car args))
           (arg2 (cadr args))
           (nat-arg1 (nt(make-term-in-app-form (pt "PosToNat") arg1)))
           (nat-arg2 (nt(make-term-in-app-form (pt "PosToNat") arg2)))
           (sorted-args (term-in-app-form-to-args sortedgoalterm))
           (vse1 (car  sorted-args))
           (vse2 (cadr sorted-args)))
      (cond ((string=? const-string "=")
             (mk-proof-in-elim-form
              (postonatinjective-proof arg1 arg2)
              (reflection-aux-nat
               (make-=-term nat-arg1 nat-arg2)
               (make-=-term vse1 vse2))))
            ((string=? const-string "PosLt")
             (mk-proof-in-elim-form
              (orderembed-postonat-proof 'left arg1 arg2)
              (reflection-aux-nat
               (mk-term-in-app-form (pt"NatLt") nat-arg1 nat-arg2)
               (mk-term-in-app-form (pt"NatLt") vse1 vse2))))
            ((string=? const-string "PosLe")
             (mk-proof-in-elim-form
              (orderembed-postonat-proof 'right arg1 arg2)
              (reflection-aux-nat
               (mk-term-in-app-form (pt"NatLe") nat-arg1 nat-arg2)
               (mk-term-in-app-form (pt"NatLe") vse1 vse2))))
            (else
             (let* ((nat-vse1 (nt(make-term-in-app-form (pt "PosToNat") vse1)))
                    (nat-vse2 (nt(make-term-in-app-form (pt "PosToNat") vse2)))
                    (e1-and-env1 (RFL-term-to-expr-and-env nat-arg1))
                    (e2-and-env2
                     (RFL-term-and-env-to-expr-and-env
                      nat-arg2 (cadr e1-and-env1)))
                    (ns (RFL-terms-to-list-term
                         (map car(cadr e2-and-env2)))))
               (mk-proof-in-elim-form
                (BinaryBooleCompat-proof vse1 arg1 vse2 arg2 const-term)
                (posEvalSortEqual-proof ns (car e1-and-env1))
                (posEvalSortEqual-proof ns (car e2-and-env2))
                (reflection-aux-proof (nt sortedgoalterm))))))))



; (reflection-aux-boole ) takes care of the goal
; when its arguments are of type boole

  (define (reflection-aux-boole goalterm sortedgoalterm)
    (display-debug "reflection-aux-boole   "
                   "goalterm: " (term-to-string goalterm)
                   "  sortedgoalterm: "(term-to-string sortedgoalterm))
    (let*
        ((const-term (term-in-app-form-to-final-op goalterm))
         (const-is-equal
          (string=?
           "=" (const-to-name (term-in-const-form-to-const const-term))))
         (args (term-in-app-form-to-args goalterm))
         (arg1 (car args))
         (arg2 (cadr args))
         (sorted-args (term-in-app-form-to-args sortedgoalterm))
         (vse1 (car  sorted-args))
         (vse2 (cadr sorted-args)))
      (cond
; Goal is of form True=boole :  Use BooleTrue 'left
       ((and (term=? arg1 (pt "True")) const-is-equal)
        (BooleTrue-proof 'left  arg2 (reflection-aux-proof arg2)))
; Goal is of form boole=True :  Use BooleTrue 'right
       ((and (term=? arg2 (pt "True"))const-is-equal)
        (BooleTrue-proof 'right arg1 (reflection-aux-proof arg1)))
; The sorted lhs of goal normalises to True: We only work on the lhs.
       ((and (term=? (nt vse1) (pt"True"))
             (not(term=? (nt arg1) (pt"True"))))
        (reflection-aux-boole-true 'left goalterm))
; The sorted rhs of goal normalises to True: We only work on the rhs.
       ((and (term=? (nt vse2) (pt"True"))
             (not(term=? (nt arg2) (pt"True"))))
        (reflection-aux-boole-true 'right goalterm))
; The lhs of goal normalises to False
       ((and const-is-equal
             (term=? (nt arg1) (pt"False"))
             (term-in-app-form? arg2))
        (reflection-aux-boole-false 'left arg2))
; The rhs of goal normalises to False
       ((and const-is-equal
             (term=? (nt arg2) (pt"False"))
             (term-in-app-form? arg1))
        (reflection-aux-boole-false 'right arg1))
; Goal is of form f(..)=g(..).
       ((and const-is-equal
             (term-in-app-form? arg1)
             (term-in-app-form? arg2))
        (reflection-aux-boolean-equality arg1 arg2))
; If goal is of form h(f(x,y),g(z,t)) where h is not equality.
       ((not const-is-equal)
        (reflection-aux-composed-boolean-term goalterm sortedgoalterm))
       (else (no-further-simp-possible goalterm)))))



; If one side of the goal normalises to true, then we replace
; that side by true and return the result to (reflection-aux-proof)

  (define (reflection-aux-boole-true side term)
    (display-debug "reflection-aux-boole-true   "
                   "  term: "(term-to-string 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)))
      (if (equal? side 'left)
          (mk-proof-in-elim-form
           (BinaryBooleCompat-proof
            (pt "True") arg1 arg2 arg2 const-term)
           (mk-proof-in-elim-form
            (=-to-eq-proof (pt"True") arg1)  
            (reflection-aux-proof (nt(make-=-term (pt"True") arg1))))
           (mk-proof-in-elim-form(=-to-eq-proof arg2 arg2)truth-proof)
           (reflection-aux-proof
            (nt (mk-term-in-app-form const-term (pt"True") arg2))))
          (mk-proof-in-elim-form
           (BinaryBooleCompat-proof
            arg1 arg1 (pt "True") arg2 const-term)
           (mk-proof-in-elim-form(=-to-eq-proof arg1 arg1)truth-proof)
           (mk-proof-in-elim-form
            (=-to-eq-proof (pt"True") arg2)
            (reflection-aux-proof (nt(make-=-term (pt"True") arg2))))
           (reflection-aux-proof
            (nt(mk-term-in-app-form const-term  arg1 (pt"True"))))))))



; (reflection-aux-boole-false ) uses ¬(n<=k)=(k<n) and ¬(n<k)=(k<=n)

  (define (reflection-aux-boole-false side term)
    (display-debug "reflection-aux-boole-false   "
                   "  term: "(term-to-string term))
    (let* ((const-string
            (term-to-string(term-in-app-form-to-final-op term)))
           (args (term-in-app-form-to-args term))
           (arg1 (car  args))
           (arg2 (cadr args)))
      (cond ((string=? const-string "NatLt")
             (natNotLt-proof
              side arg1 arg2
              (reflection-aux-proof
               (nt(mk-term-in-app-form (pt "NatLe") arg2 arg1)))))
            ((string=? const-string "NatLe")
             (natNotLe-proof
              side arg1 arg2
              (reflection-aux-proof
               (nt(mk-term-in-app-form (pt "NatLt") arg2 arg1)))))
            ((string=? const-string "PosLt")
             (posNotLt-proof
              side arg1 arg2
              (reflection-aux-proof
               (nt(mk-term-in-app-form (pt "PosLe") arg2 arg1)))))
            ((string=? const-string "PosLe")
             (posNotLe-proof
              side arg1 arg2
              (reflection-aux-proof
               (nt(mk-term-in-app-form (pt "PosLt") arg2 arg1)))))
            (else no-further-simp-possible term))))



; (reflection-aux-boolean-equality ) applies BinaryBooleFunctional
; if the lhs and rhs of goal have the same constant.

  (define (reflection-aux-boolean-equality arg1 arg2)
    (display-debug "reflection-aux-boolean-equality   "
                   "  arg1: "(term-to-string arg1)
                   "  arg2: "(term-to-string arg2))
    (let ((const-term1 (term-in-app-form-to-final-op arg1))
          (const-term2 (term-in-app-form-to-final-op arg2)))
      (cond
; If f=g, then use BinaryBooleFunctional
       ((const=?
         (term-in-const-form-to-const const-term1)
         (term-in-const-form-to-const const-term2))
        (let* ((arg1s (term-in-app-form-to-args arg1))
               (arg2s (term-in-app-form-to-args arg2))
               (arg11 (car  arg1s))
               (arg12 (cadr arg1s))
               (arg21 (car  arg2s))
               (arg22 (cadr arg2s))
               (arg21=arg11-term (nt(make-=-term arg21 arg11)))
               (arg22=arg12-term (nt(make-=-term arg22 arg12)))
               (arg21-equal-arg11-proof
                (mk-proof-in-elim-form
                 (=-to-eq-proof arg21 arg11)
                 (reflection-aux-proof arg21=arg11-term)))
               (arg22-equal-arg12-proof
                (mk-proof-in-elim-form
                 (=-to-eq-proof arg22 arg12)
                 (reflection-aux-proof arg22=arg12-term))))
          (display-debug "BinaryBooleFunctional-proof")
          (mk-proof-in-elim-form
           (BinaryBooleFunctional-proof
            arg21 arg11 arg22 arg12 const-term1)
           arg21-equal-arg11-proof arg22-equal-arg12-proof)))
       (else
        (reflection-aux-composed-boolean-term 
         (nt(make-=-term arg1 arg2))
         (sort-term(nt(make-=-term arg1 arg2))))
        ))))



; (reflection-aux-composed-boolean-term ) takse care of goal
; if it is not a boolean equality, i.e. h(x,y) with h ≠ =

  (define (reflection-aux-composed-boolean-term goalterm sortedgoalterm)
    (display-debug "reflection-aux-composed-boolean-term    "
                   "goalterm: " (term-to-string goalterm)
                   "  sortedgoalterm: " (term-to-string sortedgoalterm))
    (let* ((const-term (term-in-app-form-to-final-op goalterm))
           (args (term-in-app-form-to-args goalterm))
           (arg1 (car args))
           (arg2 (cadr args))
           (sorted-args (term-in-app-form-to-args sortedgoalterm))
           (vse1 (car  sorted-args))
           (vse2 (cadr sorted-args))
           (vse1=arg1-term (nt(make-=-term vse1 arg1)))
           (vse2=arg2-term (nt(make-=-term vse2 arg2)))
           (vse1-equal-arg1-proof
            (mk-proof-in-elim-form
             (=-to-eq-proof vse1 arg1)
             (reflection-aux-proof vse1=arg1-term)))
           (vse2-equal-arg2-proof
            (mk-proof-in-elim-form
             (=-to-eq-proof vse2 arg2)
             (reflection-aux-proof vse2=arg2-term))))
      (mk-proof-in-elim-form
       (BinaryBooleCompat-proof vse1 arg1 vse2 arg2 const-term)
       vse1-equal-arg1-proof vse2-equal-arg2-proof
       (reflection-aux-proof(nt sortedgoalterm)))))

) ; matches (begin



(display "
              SOME EXAMPLES FOR nat
")


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

#|




(sg "nat0*nat1+nat2<1+nat1*nat0+nat2")
(strip)
(reflection)
; (cdp) OK
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #f




(sg "(nat0*(nat1+nat2)+2+nat2<2+(nat2+(nat2+nat1)*nat0)) impb F")
(strip)
(reflection)
; (cdp) OK
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #f



(sg "F=(1+nat2+1+nat0+1<=Succ(Succ(nat0+nat2)))")
(strip)
(reflection)
; (cdp) OK
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #t


(sg "(nat2<Succ(Succ(nat2+nat0)))=(nat2<Succ(Succ(nat0+nat2)))")
(strip)
(reflection)
; (cdp) OK
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #f




(sg "(nat1+2+nat2<1+nat2+nat1) = False")
(strip)
(reflection)
; ok, ?_2 is proved.  Proof finished.
; (cdp) OK
(proof=? (current-proof)(np(current-proof)))
; #t


(sg "boole impb (nat0+nat1<1+nat1+nat0)")
(strip)
(reflection)
; ok, ?_2 is proved.  Proof finished.
; (cdp) OK
(proof=? (current-proof)(np(current-proof)))
; #t




(sg "(nat0+2+nat1+3+nat2=3+nat1+1+nat2+1+nat0)=True")
(strip)
(reflection)
; Proof finished.
; (cdp) OK
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #t


(sg "True=(nat0+2+nat1+3+nat2=3+nat1+1+nat2+1+nat0)")
(strip)
(reflection)
; Proof finished.
; (cdp) OK
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #t



(sg "2+nat0+2+nat1*nat2=3+nat2*nat1+1+nat0")
(strip)
(reflection)
; Proof finished.
; (cdp) OK
(proof=? (current-proof)(np(current-proof)))
; #f
; (dpe)




(sg "(nat1+2+nat2<1+nat2+nat1)=False")
(strip)
(reflection)
; ok, ?_2 is proved.  Proof finished.
; (cdp) OK
(proof=? (current-proof)(np(current-proof)))
; #t


(sg "nat0+nat1<nat1+nat0 and nat2+nat3<nat3+1+nat2")
(strip)
; ?_2: nat0+nat1<nat1+nat0∧nat2+nat3<nat3+1+nat2 from
; (reflection)

; ; WARNING, reflection-aux-proof: All terms are sorted !
; I can not deal with the following:
; False
; which sorts to:
; False
; and then normalises to:
; False

; Try to prove this term by hand and add it as RW-rule.


|#


(display "
        A longer example :

")

(sg "nat0+2+nat1*3+nat2=3*nat1+1+nat2+1+nat0
    and  nat0+2+nat1+3+nat2<3+nat1+1+nat2+1+nat0+1
    and  (1+nat0*nat1<=nat1*nat0
               impb
         (1+nat0+1+nat1+1+nat2+2+nat3) < (1+nat0+nat1+1+nat2+nat3))")
(strip)
(ng)
(time(reflection))
; ok, ?_2 is proved.  Proof finished.
; (cdp) OK
(display "Is the proof normal ?  ")
(display(proof=? (current-proof)(np(current-proof))))
; #f




(display "
End of reflection_nat.scm
")

