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

(display "

Begin of reflection_numbers.scm

")



; REFLECTION FOR NAT

(if (not (assoc "expr" ALGEBRAS))
    (exload "ordinals/reflection_nat.scm"))



; CLEANING UP NAME SPACE

(rv "a" "b" "as" "bs" "n" "m" "k")
(remove-nat-tokens)
(set! COMMENT-FLAG #f)
(libload "numbers.scm")



; SOME THEOREMS

(exload "ordinals/reflection_numbers_thms.scm")



; IMPORTANT THEOREMS

(begin


; PosToNatInjective

(sg "(PosToNat pos1)=(PosToNat pos2) -> pos1=pos2")
(assume "pos1" "pos2" "eq")
(simp-with(pf"pos1=PosPred(NatToPos(PosToNat pos1))"))
(simp-with(pf"pos2=PosPred(NatToPos(PosToNat pos2))"))
(simp "eq")
(auto)
; Proof finished
(save "PosToNatInjective")
(define (postonatinjective-proof term1 term2)
  (mk-proof-in-elim-form
   (make-proof-in-aconst-form
    (theorem-name-to-aconst "PosToNatInjective"))
   term1 term2))


; OrderembedPosToNat

(sg "(NatLt(PosToNat pos1)(PosToNat pos2)->pos1<pos2)
   & (NatLe(PosToNat pos1)(PosToNat pos2)->pos1<=pos2)")
(ind)
    (cases)
    (auto)
  (assume "pos1" "IH1")
  (cases)
  (auto)
(assume "pos1" "IH1")
(cases)
(auto)
; Proof finished
(save "OrderembedPosToNat")
(define (orderembed-postonat-proof side term1 term2)
  (let ((thm-proof
         (mk-proof-in-elim-form 
          (make-proof-in-aconst-form
           (theorem-name-to-aconst "OrderembedPosToNat"))
          term1 term2)))
    (if (equal? 'left side)
        (np(make-proof-in-and-elim-left-form thm-proof))
        (np(make-proof-in-and-elim-right-form thm-proof)))))


; posNotLtLe

(sg "( pos2<=pos1 -> ( False=(pos1<pos2) & (pos1<pos2) = False ))
   & ( pos2<pos1 -> ( False=(pos1<=pos2) & (pos1<=pos2) = False ))")
(ind)
(cases)
  (auto)
(assume "pos1" "IH")
(cases)
(auto)
(assume "pos1" "IH")
(cases)
(auto)
; Proof finished.
(add-theorem "posNotLtLe" (np(current-proof)))
(define (posNotLt-proof side term1 term2 proof)
  (let ((thm-proof
         (make-proof-in-and-elim-left-form
          (mk-proof-in-elim-form 
           (make-proof-in-aconst-form
            (theorem-name-to-aconst "posNotLtLe"))
           term2 term1))))
    (if (equal? 'left side)
        (np(make-proof-in-and-elim-left-form
            (mk-proof-in-elim-form thm-proof proof)))
        (np(make-proof-in-and-elim-right-form
            (mk-proof-in-elim-form thm-proof proof))))))
(define (posNotLe-proof side term1 term2 proof)
  (let ((thm-proof
        (make-proof-in-and-elim-right-form
         (mk-proof-in-elim-form 
          (make-proof-in-aconst-form
           (theorem-name-to-aconst "posNotLtLe"))
          term2 term1))))
    (if (equal? 'left side)
        (np(make-proof-in-and-elim-left-form
            (mk-proof-in-elim-form thm-proof proof)))
        (np(make-proof-in-and-elim-right-form
            (mk-proof-in-elim-form thm-proof proof))))))


; posEvalSortEqual

(sg "all nat=>pos,ns,expr.
     Equal(nat=>pos(Eval(SortExpr expr)ns)) (nat=>pos(Eval expr ns))")
(assume "nat=>pos" "ns" "expr")
(use-with "Eq-Refl" (py "pos") (pt"nat=>pos(Eval expr ns)"))
(save "posEvalSortEqual")
(define (posEvalSortEqual-proof ns expr)
  (mk-proof-in-elim-form
   (make-proof-in-aconst-form
    (theorem-name-to-aconst "posEvalSortEqual"))
   (pt "[nat] PosPred(NatToPos nat)") ns expr))

 ) ; matches begin




(set! COMMENT-FLAG #t)
(display-program-constants "PosToNat")
#|comprules
    PosToNat 1	Succ Zero
	PosToNat(SZero pos)	PosToNat pos+PosToNat pos
	PosToNat(SOne pos)	Succ(PosToNat(SZero pos))
  rewrules
	PosToNat(S pos)	Succ(PosToNat pos)
	PosToNat(pos1+pos2)	PosToNat pos1+PosToNat pos2
	PosToNat(n*k)	PosToNat n*PosToNat k |#
(display-program-constants "NatToPos")
#|comprules
	NatToPos Zero	1
	NatToPos(Succ nat)	NatToPos nat+1
  rewrules
	NatToPos(nat+nat)	PosPred(SZero(NatToPos nat))
	NatToPos(PosToNat pos)	S pos
	NatToPos(nat1+nat2)	PosPred(NatToPos nat1+NatToPos nat2)|#
(newline)
(display-theorems "posNotLtLe")
;   (n<=k -> False=(k<n)  & (k<n) =False)
; & (n<k  -> False=(k<=n) & (k<=n)=False)
(display-theorems "PosToNatInjective")
; PosToNat pos1=PosToNat pos2 -> pos1=pos2
(display-theorems "OrderembedPosToNat")
;   (PosToNat pos1< PosToNat pos2 -> pos1< pos2)
; & (PosToNat pos1<=PosToNat pos2 -> pos1<=pos2)
(display-theorems "posEvalSortEqual")
; nat=>pos(Eval(SortExpr expr)ns) ≈ nat=>pos(Eval expr ns)


(display "
              SOME EXAMPLES FOR pos
")


; (set! DEBUG-FLAG #t)

#|


(sg "pos1+pos2<=S(pos2+pos1)")
(strip)
(reflection)
(cdp)
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #f



(sg "(pos0+2+pos2<1+pos2+pos0) impb F")
(strip)
(reflection)
(cdp)
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #f



(sg "(pos0+2+pos2<S(S(pos2+pos0))) impb F")
(strip)
(reflection)
(cdp)
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #f



(sg "F=(1+pos2+1+pos0+1<=S(S(pos0+pos2)))")
(strip)
(reflection)
(cdp)
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #t



(sg "(pos2<S(S(pos2+pos0)))=(pos2<S(S(pos0+pos2)))")
(strip)
(reflection)
(cdp)
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #f



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


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


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


(sg "True=(pos0+pos1=pos1+pos0)")
(strip)
(reflection)
; Proof finished.
(cdp)
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #t


(sg "True=(pos0+2+pos1+3+pos2=3+pos1+1+pos2+1+pos0)")
(strip)
(reflection)
; Proof finished.
(cdp)
; (dpe)
(proof=? (current-proof)(np(current-proof)))
; #t


(sg "pos0+2+pos1+3+pos2=3+pos1+1+pos2+1+pos0")
(strip)
(reflection)
; Proof finished.
(cdp)
(proof=? (current-proof)(np(current-proof)))
; #f
; (dpe)

|#


(display "
      A Longer Example

")



(sg "(NatPlus (NatTimes nat nat1) nat2=NatPlus nat2 (NatTimes nat1 nat))
      and pos1+2+pos2=pos2+1+pos1+1
      and  pos0+1+pos1<pos1+1+pos0+1
      and  (pos1+3+pos2+1+pos2+pos1<=2*(2+pos2+pos1))")
(strip)
(ng)
(time(reflection))
; ok, ?_2 is proved.  Proof finished.
; (cdp)
(display "Is the proof normal ?  ")
(display (proof=? (current-proof)(np(current-proof))))
; #f



(display "
End of reflection_numbers.scm
")
