; $Id: minpr.scm 2156 2008-01-25 13:25:12Z schimans $
; Proof of the minimum principle with measure function from induction

(set! COMMENT-FLAG #f)
(mload "../lib/nat.scm")
(set! COMMENT-FLAG #t)

; Use general variable names instead
; (add-pvar-name "Q" (make-arity (make-tvar -1 DEFAULT-TVAR-NAME)))
; (add-var-name "h" (make-arrow (make-tvar -1 DEFAULT-TVAR-NAME)
; 			      (make-alg "nat")))
; (add-var-name "x" "y" "z" (make-tvar -1 DEFAULT-TVAR-NAME))

; We first prove course-of-values induction (with measure function)

; Prove this from material in nat.scm
; (add-global-assumption "Trans-Suc" (pf "all k,m,n.k<m -> m<n+1 -> k<n"))

(set-goal
 (pf "all alpha=>nat.
       (all alpha_1.(all alpha_2.alpha=>nat alpha_2<alpha=>nat alpha_1 ->
                                 (Pvar alpha)alpha_2) ->
                    (Pvar alpha)alpha_1) ->
       all alpha_1 (Pvar alpha)alpha_1"))
(assume "alpha=>nat" "H1")
; We need an auxiliary claim to get the induction through
(cut (pf "all nat,alpha_2.(alpha=>nat alpha_2)<nat -> (Pvar alpha)alpha_2"))

; From the auxiliary claim we easily obtain the claim:
(assume "H2" "alpha_1")
(use "H2" (pt "(alpha=>nat alpha_1)+1"))
(use "Truth-Axiom")

; Now the proof of the generalized claim:
(ind)

; Base
(assume "alpha_2" "Absurd")
(use "Efq")
(use "Absurd")

; Step
(assume "nat" "H2" "alpha_2" "H3")
(use "H1")
(assume "alpha_3" "H4")
(use "H2")
(use "NatLtLeTrans" (pt "alpha=>nat alpha_2"))
(use "H4")
(use "NatLtSuccToLe")
(use "H3")
(save "CVInd")

(set-goal
 (pf "all alpha=>nat.
       exca alpha_1 (Pvar alpha)alpha_1 -> 
       exca alpha_1.(all alpha_2.alpha=>nat alpha_2<alpha=>nat alpha_1 -> 
                                 (Pvar alpha)alpha_2 -> F) ! 
                    (Pvar alpha)alpha_1"))
(assume "alpha=>nat" "H1" "H2")
(use "H1")
(use-with (proof-substitute
	   (make-proof-in-aconst-form (theorem-name-to-aconst "CVInd"))
	   (make-subst-wrt
	    pvar-cterm-equal?
	    (predicate-form-to-predicate (pf "(Pvar alpha)alpha_1"))
	    (make-cterm (pv "alpha_1") (pf "(Pvar alpha)alpha_1 -> F"))))
	  (pt "alpha=>nat") "?")
(use "H2")

(save "Min-Pr-a-1-1")

(set-goal
 (pf "all alpha=>nat.
       excl alpha_1 (Pvar alpha)alpha_1 ->
       excl alpha_1.(all alpha_2.alpha=>nat alpha_2<alpha=>nat alpha_1 -> 
                                 (Pvar alpha)alpha_2 -> bot) !
                    (Pvar alpha)alpha_1"))
(assume "alpha=>nat" "H1" "H2")
(use "H1")
(use-with (proof-substitute
	   (make-proof-in-aconst-form (theorem-name-to-aconst "CVInd"))
	   (make-subst-wrt
	    pvar-cterm-equal?
	    (predicate-form-to-predicate (pf "(Pvar alpha)alpha_1"))
	    (make-cterm (pv "alpha_1") (pf "(Pvar alpha)alpha_1 -> bot"))))
	  (pt "alpha=>nat") "?")
(use "H2")

(save "Min-Pr-l-1-1")

; More generally

(define (formula-of-min-pr-at l-or-a-string n m)
  (let* ((fixed-vars
	  (do ((i (- n 1) (- i 1))
	       (res (list (make-var (make-tvar n DEFAULT-TVAR-NAME) n 1 ""))
		    (cons (make-var (make-tvar i DEFAULT-TVAR-NAME) i 1 "")
			  res)))
	      ((zero? i) res)))
	 (fixed-tvars (map var-to-type fixed-vars))
	 (fixed-arity (apply make-arity fixed-tvars))
	 (fixed-pvars
	  (do ((j (- m 1) (- j 1))
	       (res (list (make-pvar fixed-arity m h-deg-zero n-deg-zero ""))
		    (cons (make-pvar fixed-arity j h-deg-zero n-deg-zero "")
			  res)))
	      ((zero? j) res)))
	 (fixed-varterms (map make-term-in-var-form fixed-vars))
	 (fixed-formulas (map (lambda (x)
				(apply make-predicate-formula
				       (cons x fixed-varterms)))
			      fixed-pvars))
	 (fixed-pvar (make-pvar (make-arity) -1 h-deg-zero n-deg-zero ""))
	 (fixed-formula (make-predicate-formula fixed-pvar))
	 (fixed-exc-kernel (apply mk-tensor fixed-formulas))
	 (fixed-exc-formula
	  (cond
	   ((string=? "l" l-or-a-string)
	    (apply mk-excl (append fixed-vars (list fixed-exc-kernel))))
	   ((string=? "a" l-or-a-string)
	    (apply mk-exca (append fixed-vars (list fixed-exc-kernel))))
	   (else (myerror "formula-of-min-pr-at: string l or a expected"
			  l-or-a-string))))
	 (measure-function-type
	  (apply mk-arrow (append fixed-tvars (list (make-alg "nat")))))
	 (measure-function-var (make-var measure-function-type -1 1 ""))
	 (measure-term
	  (apply mk-term-in-app-form
		 (cons (make-term-in-var-form measure-function-var)
		       (map make-term-in-var-form fixed-vars))))
	 (fixed-vars1
	  (do ((i (- n 1) (- i 1))
	       (res
		(list (make-var (make-tvar n DEFAULT-TVAR-NAME) (+ n n) 1 ""))
		(cons (make-var (make-tvar i DEFAULT-TVAR-NAME) (+ n i) 1 "")
		      res)))
	      ((zero? i) res)))
	 (fixed-varterms1 (map make-term-in-var-form fixed-vars1))
	 (measure-term1
	  (apply mk-term-in-app-form
		 (cons (make-term-in-var-form measure-function-var)
		       fixed-varterms1)))
	 (fixed-formulas1 (map (lambda (x)
				 (apply make-predicate-formula
					(cons x fixed-varterms1)))
			       fixed-pvars))
	 (fixed-all-formula
	  (apply mk-all
		 (append
		  fixed-vars1
		  (list (apply mk-imp
			       (cons (make-atomic-formula
				      (mk-term-in-app-form
				       (make-term-in-const-form
					(pconst-name-to-pconst "NatLt"))
				       measure-term1 measure-term))
				     (append
				      fixed-formulas1
				      (list (if (string=? "l" l-or-a-string)
						falsity-log falsity)))))))))
	 (fixed-extended-exc-kernel
	  (apply mk-tensor (cons fixed-all-formula fixed-formulas)))
	 (fixed-extended-exc-formula
	  (if (string=? "l" l-or-a-string)
	      (apply mk-excl
		     (append fixed-vars (list fixed-extended-exc-kernel)))
	      (apply mk-exca
		     (append fixed-vars (list fixed-extended-exc-kernel))))))
    (make-all measure-function-var
	      (make-imp fixed-exc-formula fixed-extended-exc-formula))))

