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

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

(set! COMMENT-FLAG #f)
(libload "nat.scm")
(set! COMMENT-FLAG #t)


(add-var-name "x" "y" "z" (py "alpha"))
(add-var-name "leq" (py "alpha=>alpha=>boole"))
(add-var-name "seg" (py "nat=>nat=>alpha"))
(add-var-name "i" "j" (py "nat"))

(set-goal (pf "all leq,seg.
  (all x,y,z.leq x y -> leq y z -> leq x z) ->
  all x leq x x ->
  (all x,y.(leq x y -> F) -> leq y x) ->
  all n.ex i,j,k.i<=k & j<=n & k<=n 
                 & (all i1,k1.i1<=k1 -> k1<=n -> leq(seg i1 k1)(seg i k))
                 & (all j1.j1<=n -> leq(seg j1 n)(seg j n))"))
(assume "leq" "seg" "leqTrans" "leqRefl" "leqLin")
(ind)

; Base case
(ex-intro (pt "0"))
(ex-intro (pt "0"))
(ex-intro (pt "0"))
(split)
(split)
(ng)
(prop)
(assume "i1" "k1" "i1<=k1" "k1<=0")
(add-global-assumption
 "L1" (pf "all leq,seg,i1,k1.i1<=k1 -> k1<=0 -> leq(seg 0 0)(seg 0 0) ->
                             leq(seg i1 k1)(seg 0 0)"))
(use "L1")
(auto)
(add-global-assumption
 "L2" (pf "all leq,seg,j1.j1<=0 -> leq(seg 0 0)(seg 0 0) ->
                          leq(seg j1 0)(seg 0 0)"))

(assume "j1" "j1<=0")
(use "L2")
(prop)
(use "leqRefl")

; Step case
(assume "n" "IH")
(by-assume-with "IH" "i" "iHyp")
(by-assume-with "iHyp" "j" "jHyp")
(by-assume-with "jHyp" "k" "ih")
(assert
 (pf "ex j2.j2<=n+1 & all j1.j1<=n+1 -> leq(seg j1(n+1))(seg j2(n+1))"))
 (assert
  (pf "all m.m<=n+1 -> 
       ex j2.j2<=m & (all j1.j1<=m -> leq(seg j1(n+1))(seg j2(n+1)))"))
  (ind)
  (assume "0<=n+1")
  (ex-intro (pt "0"))
  (split)
  (prop)
  (cases)
  (assume "Trivial")
  (use "leqRefl")
  (strip)
  (use "Efq")
  (use 9)
  ; Step of side induction
  (assume "m" "IHm")
  (assume "Succ m<=m+1")
  (assert (pf "ex j2.j2<=m & all j1.j1<=m -> leq(seg j1(n+1))(seg j2(n+1))"))
   (use "IHm")
   (add-global-assumption
    "TransLe" (pf "all n,m,k.n<=m -> m<=k -> n<=k"))
   (use "TransLe" (pt "Succ m"))
   (add-global-assumption
    "LeSucc" (pf "all m m<=Succ m"))
   (use "LeSucc")
   (prop)
  (assume "ExHyp")
  (by-assume-with "ExHyp" "j2" "j2Hyp")
  (cases (pt "leq(seg j2(n+1))(seg(m+1)(n+1))"))
  (assume "leq(seg j2(n+1))(seg(m+1)(n+1))")
  (ex-intro (pt "j2"))
  (split)
  (use "TransLe" (pt "m"))
  (use "j2Hyp")
  (use "LeSucc")
  (add-global-assumption
   "LeSuccDec"
   (pf "all m,j.(j<=m -> Pvar^) -> (j=Succ m -> Pvar^) -> j<=Succ m -> Pvar^"))
  (assume "j1")
  (assume "j1<=Succ m")
  (use "LeSuccDec" (pt "m") (pt "j1"))
  (use "j2Hyp")

; 2005-05-30 done up to this point

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Old code:
(agt 'obj 'x 'y 'z)
(av 'leq (c-arrow 'obj 'obj 'boole))
(av 'seg (c-arrow 'nat 'nat 'obj))
(av 'i 'nat)
(av 'j 'nat)

(set-goal '? (pf "all leq,seg.
(all x,y,z.leq x y -> leq y z -> leq x z)
-> all x leq x x
-> (all x,y.(leq x y -> F) -> leq y x)
-> all n.ex i,j,k.i<=k & j<=n & k<=n 
                  & (all i1,k1.i1<=k1 -> k1<=n -> leq(seg i1 k1)(seg i k))
                  & (all j1.j1<=n -> leq(seg j1 n)(seg j n))"))
(assume 'leq 'seg 'trans-leq 'refl-leq 'lin-leq)
(ind)
(ex-intro 0)
(ex-intro 0)
(ex-intro 0)
(split)
(split)
(ng)
(prop)
(assume 'i1 'k1 'hyp1 'hyp2)
(aga 'lemma1 (pf "all leq,seg,i1,k1.i1<=k1 -> k1<=0 -> leq(seg 0 0)(seg 0 0)
->leq(seg i1 k1)(seg 0 0)"))
(use-with 'lemma1 'leq 'seg 'i1 'k1 'hyp1 'hyp2 '?1)
(use-with 'refl-leq (pt "seg 0 0"))
(assume 'j1 'hyp)
(aga 'lemma2 (pf "all leq,seg,j1.j1<=0 -> leq(seg 0 0)(seg 0 0)
->leq(seg j1 0)(seg 0 0)"))
(use-with 'lemma2 'leq 'seg 'j1 'hyp '?2)
(use-with 'refl-leq (pt "seg 0 0"))
(assume 'n 'ihn)
(ex-elim 'ihn)
(assume 'i 'hyp-i)
(ex-elim 'hyp-i)
(assume 'j 'hyp-j)
(ex-elim 'hyp-j)
(assume 'k 'hyp) ;besser: ih statt hyp
(drop 'ihn 'hyp-i 'hyp-j)
(split-hyp 'hyp)
(split-hyp 'u01)
(split-hyp 'u03)
(split-hyp 'u05)
(drop 'hyp 'u01 'u03 'u05)
(use-with (list '?3
(pf "(ex j2.j2<=n+1 & all j1.j1<=n+1 -> leq(seg j1(n+1))(seg j2(n+1)))
     -> ex i,j,k.i<=k & j<=n+1 & k<=n+1 
                 & (all i1,k1.i1<=k1 -> k1<=n+1 -> leq(seg i1 k1)(seg i k)) 
                 & (all j1.j1<=n+1 -> leq(seg j1(n+1))(seg j(n+1)))"))
'?4 )
(assume 'hyp)
(ex-elim 'hyp)
(drop 'hyp)
(assume 'j2 'hyp)
(cases (pt "leq(seg i k)(seg j2(n+1))"))
(split-hyp 'hyp)
(drop 'hyp)
(assume 'hyp)
(ex-intro 'j2)
(ex-intro 'j2)
(ex-intro (pt "n+1"))
(split)
(split)
(split)
(prop)
(ng)
(prop)
(assume 'i1 'k1 'hyp1 'hyp2)
(cases (pt "k1<=n"))
(assume 'hyp3)
(drop 'hyp2)
(use-with 'trans-leq (pt "seg i1 k1") (pt "seg i k") (pt "seg j2(n+1)")
                     '?5 'hyp)
(use-with 'u04 'i1 'k1 'hyp1 'hyp3)
(assume 'hyp3)
(aga 'lemma3 (pf "all leq,seg,i1,k1,n,j2.k1<=n+1 ->(k1<=n -> F)
-> leq(seg i1(n+1))(seg j2(n+1)) -> leq(seg i1 k1)(seg j2(n+1))"))
(use-with 'lemma3 'leq 'seg 'i1 'k1 'n 'j2 'hyp2 'hyp3 '?6)
(use-with 'u011 'i1 '?7)
(aga 'trans-<= (pf "all i1,k1,m.i1<=k1 -> k1<=m -> i1<=m"))
(use-with 'trans-<= 'i1 'k1 (pt "n+1") 'hyp1 'hyp2)
(use 'u011)

(assume 'hyp1)
(ex-intro 'i)
(ex-intro 'j2)
(ex-intro 'k)
(split)
(split)
(split)
(prop)
(use-with 'trans-<= 'k 'n (pt "n+1") 'u06 '?8)

(ng)
(prop)
(assume 'i1 'k1 'hyp2 'hyp3)
(cases (pt "k1<=n"))                         
(drop 'hyp3)
(assume 'hyp3)
(use-with 'u04 'i1 'k1 'hyp2 'hyp3)
(assume 'hyp4)
(aga 'lemma4 (pf "all leq,seg,i1,k1,n,i,k.k1<=n+1 ->(k1<=n -> F)
-> leq(seg i1(n+1))(seg i k) -> leq(seg i1 k1)(seg i k)"))
(use-with 'lemma4 'leq 'seg 'i1 'k1 'n 'i 'k 'hyp3 'hyp4 '?9)
(use-with 'trans-leq (pt "seg i1(n+1)") (pt "seg j2(n+1)") (pt "seg i k")
                     '?10 '?11)
(use-with 'hyp 'right 'i1 '?12)
(use-with 'trans-<= 'i1 'k1 (pt "n+1") 'hyp2 'hyp3)
(use-with 'lin-leq (pt "seg i k") (pt "seg j2(n+1)") 'hyp1)

(use-with 'hyp 'right)

(use-with (list '?13 (pf "(all m.m<=n+1 
-> ex j2.j2<=m & (all j1.j1<=m -> leq(seg j1(n+1))(seg j2(n+1))))
-> ex j2.j2<=n+1 & (all j1.j1<=n+1 -> leq(seg j1(n+1))(seg j2(n+1)))"))
'?14)
(assume 'hyp)
(use-with 'hyp (pt "n+1") truth-axiom)
(ind)
(assume 'hyp)
(ex-intro 0)
(split)
(ng)
(prop)
(assume 'j1 'hyp1)
(aga 'lemma5 (pf "all leq,seg,j1,n.j1<=0
-> leq(seg 0(n+1))(seg 0(n+1)) -> leq(seg j1(n+1))(seg 0(n+1))"))
(use-with 'lemma5 'leq 'seg 'j1 'n 'hyp1 '?15)
(use-with 'refl-leq (pt "seg 0(n+1)"))

(assume 'm 'ihm)
(ng)
(assume 'hyp)
(use-with (list '?16 
(pf "(ex j2.j2<=m & (all j1.j1<=m -> leq(seg j1(n+1))(seg j2(n+1))))
-> ex j2.j2<=m+1 & (all j1.j1<=m+1 -> leq(seg j1(n+1))(seg j2(n+1)))"))
'?17)
(assume 'hyp1)
(ex-elim 'hyp1)
(assume 'j2 'hyp2)
(cases (pt "leq(seg j2(n+1))(seg(m+1)(n+1))"))
(assume 'hyp3)
(ex-intro (pt "m+1"))
(split)
(use truth-axiom)
(assume 'j1 'hyp4)
(cases (pt "j1<=m"))
