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


; Begin of reflection_thms.scm


(if (not (assoc "nat" ALGEBRAS))
    (myerror "First execute (libload \"nat.scm\")"))


(define truth-proof (make-proof-in-aconst-form truth-aconst))


; True=boole  = boole
(sg "boole->(True=boole)&(boole=True)")
(cases)
(auto)
; Proof finished.
(add-theorem "BooleTrue" (np(current-proof)))
(define (BooleTrue-proof side term proof)
  (let ((btrue-proof
        (make-proof-in-aconst-form
         (theorem-name-to-aconst "BooleTrue"))))
    (if (equal? 'left side)
        (np (make-proof-in-and-elim-left-form
             (mk-proof-in-elim-form btrue-proof term proof)))
        (np (make-proof-in-and-elim-right-form
             (mk-proof-in-elim-form btrue-proof term proof))))))



(sg "(True impb boole)=boole")
(cases)
(auto)
; Proof finished.
(arw "(True impb boole)" "boole")


; alphaFunctional

(sg "Equal (alpha1=>alpha2)_2 (alpha1=>alpha2)_1 -> Equal alpha1_2 alpha1_1
 ->  Equal ((alpha1=>alpha2)_1 alpha1_1)  ((alpha1=>alpha2)_2 alpha1_2)")
(assume "(alpha1=>alpha2)_2" "(alpha1=>alpha2)_1"
        "(alpha1)_2" "(alpha1)_1"
        "Efg" "E21")
(simp "E21")
(simp "Efg")
(use "Eq-Refl")
; Proof finished.
(save "alphaFunctional")




; alphaBinaryBooleFunctional

(sg "Equal alpha1_3 alpha1_1 -> Equal alpha2_4 alpha2_2
  -> ((alpha1=>alpha2=>boole)alpha1_1 alpha2_2)=((alpha1=>alpha2=>boole)alpha1_3 alpha2_4)")
(assume "(alpha1)_3" "(alpha1)_1" "(alpha2)_4" "(alpha2)_2"
		"alpha1=>alpha2=>boole"
		"E31" "E42")
(simp "E31")
(simp "E42")
(search)
; Proof finished.
(add-theorem "alphaBinaryBooleFunctional"
			 (np(current-proof)))
(define (BinaryBooleFunctional-proof term3 term1 term4 term2 const-term)
  (let ((type1 (term-to-type term1))
        (type2 (term-to-type term2))
        (type3 (term-to-type term3))
        (type4 (term-to-type term4)))
    (if (and (equal? type1 type3)(equal? type2 type4))
        (mk-proof-in-elim-form
         (proof-subst
          (proof-subst
           (make-proof-in-aconst-form
            (theorem-name-to-aconst "alphaBinaryBooleFunctional"))
           (py "alpha1") type1)
          (py "alpha2") type2)
         term3 term1 term4 term2 const-term)
        (myerror "BinaryBooleFunctional-proof" "types do not fit"))))






; alphaBinaryBooleCompat

(sg "Equal alpha1_3 alpha1_1 -> Equal alpha2_4 alpha2_2
  -> ((alpha1=>alpha2=>boole)alpha1_3 alpha2_4)
  -> ((alpha1=>alpha2=>boole)alpha1_1 alpha2_2)")
(assume "(alpha1)_3" "(alpha1)_1" "(alpha2)_4" "(alpha2)_2"
		"alpha1=>alpha2=>boole"
		"E31" "E42")
(simp "E31")
(simp "E42")
(search)
; Proof finished.
(add-theorem "alphaBinaryBooleCompat" (np(current-proof)))
(define (BinaryBooleCompat-proof term3 term1 term4 term2 const-term)
  (let ((type1 (term-to-type term1))
        (type2 (term-to-type term2))
        (type3 (term-to-type term3))
        (type4 (term-to-type term4)))
    (if (and (equal? type1 type3)(equal? type2 type4))
        (mk-proof-in-elim-form
         (proof-subst
          (proof-subst
           (make-proof-in-aconst-form
            (theorem-name-to-aconst "alphaBinaryBooleCompat"))
           (py "alpha1") type1)
          (py "alpha2") type2)
         term3 term1 term4 term2 const-term)
        (myerror "BinaryBooleCompat-proof" "types do not fit"))))



; Some Theorems concerning natural numbers.

(add-more-nat-thms) ; defined in new nat.scm


(define (natNotLt-proof side term1 term2 proof)
  (let ((natNotLt-proof
        (make-proof-in-aconst-form
         (theorem-name-to-aconst "natNotLt"))))
    (if (equal? 'left side)
        (np(make-proof-in-and-elim-left-form
            (mk-proof-in-elim-form natNotLt-proof term2 term1 proof)))
        (np(make-proof-in-and-elim-right-form
            (mk-proof-in-elim-form natNotLt-proof term2 term1 proof))))))


(define (natNotLe-proof side term1 term2 proof)
  (let ((natNotLe-proof
        (make-proof-in-aconst-form
         (theorem-name-to-aconst "natNotLe"))))
    (if (equal? 'left side)
        (np(make-proof-in-and-elim-left-form
            (mk-proof-in-elim-form natNotLe-proof term2 term1 proof)))
        (np(make-proof-in-and-elim-right-form
            (mk-proof-in-elim-form natNotLe-proof term2 term1 proof))))))





; End of reflection_thms.scm
