(*  Title:      FOL/ex/Classical.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section{*Classical Predicate Calculus Problems*}

theory Classical imports FOL begin

lemma "(P --> Q | R) --> (P-->Q) | (P-->R)"
by blast

text{*If and only if*}

lemma "(P<->Q) <-> (Q<->P)"
by blast

lemma "~ (P <-> ~P)"
by blast

text{*Sample problems from
  F. J. Pelletier,
  Seventy-Five Problems for Testing Automatic Theorem Provers,
  J. Automated Reasoning 2 (1986), 191-216.
  Errata, JAR 4 (1988), 236-236.

The hardest problems -- judging by experience with several theorem provers,
including matrix ones -- are 34 and 43.
*}

subsection{*Pelletier's examples*}

text{*1*}
lemma "(P-->Q)  <->  (~Q --> ~P)"
by blast

text{*2*}
lemma "~ ~ P  <->  P"
by blast

text{*3*}
lemma "~(P-->Q) --> (Q-->P)"
by blast

text{*4*}
lemma "(~P-->Q)  <->  (~Q --> P)"
by blast

text{*5*}
lemma "((P|Q)-->(P|R)) --> (P|(Q-->R))"
by blast

text{*6*}
lemma "P | ~ P"
by blast

text{*7*}
lemma "P | ~ ~ ~ P"
by blast

text{*8.  Peirce's law*}
lemma "((P-->Q) --> P)  -->  P"
by blast

text{*9*}
lemma "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
by blast

text{*10*}
lemma "(Q-->R) & (R-->P&Q) & (P-->Q|R) --> (P<->Q)"
by blast

text{*11.  Proved in each direction (incorrectly, says Pelletier!!)  *}
lemma "P<->P"
by blast

text{*12.  "Dijkstra's law"*}
lemma "((P <-> Q) <-> R)  <->  (P <-> (Q <-> R))"
by blast

text{*13.  Distributive law*}
lemma "P | (Q & R)  <-> (P | Q) & (P | R)"
by blast

text{*14*}
lemma "(P <-> Q) <-> ((Q | ~P) & (~Q|P))"
by blast

text{*15*}
lemma "(P --> Q) <-> (~P | Q)"
by blast

text{*16*}
lemma "(P-->Q) | (Q-->P)"
by blast

text{*17*}
lemma "((P & (Q-->R))-->S) <-> ((~P | Q | S) & (~P | ~R | S))"
by blast

subsection{*Classical Logic: examples with quantifiers*}

lemma "(\<forall>x. P(x) & Q(x)) <-> (\<forall>x. P(x))  &  (\<forall>x. Q(x))"
by blast

lemma "(\<exists>x. P-->Q(x))  <->  (P --> (\<exists>x. Q(x)))"
by blast

lemma "(\<exists>x. P(x)-->Q)  <->  (\<forall>x. P(x)) --> Q"
by blast

lemma "(\<forall>x. P(x)) | Q  <->  (\<forall>x. P(x) | Q)"
by blast

text{*Discussed in Avron, Gentzen-Type Systems, Resolution and Tableaux,
  JAR 10 (265-281), 1993.  Proof is trivial!*}
lemma "~((\<exists>x.~P(x)) & ((\<exists>x. P(x)) | (\<exists>x. P(x) & Q(x))) & ~ (\<exists>x. P(x)))"
by blast

subsection{*Problems requiring quantifier duplication*}

text{*Theorem B of Peter Andrews, Theorem Proving via General Matings,
  JACM 28 (1981).*}
lemma "(\<exists>x. \<forall>y. P(x) <-> P(y)) --> ((\<exists>x. P(x)) <-> (\<forall>y. P(y)))"
by blast

text{*Needs multiple instantiation of ALL.*}
lemma "(\<forall>x. P(x)-->P(f(x)))  &  P(d)-->P(f(f(f(d))))"
by blast

text{*Needs double instantiation of the quantifier*}
lemma "\<exists>x. P(x) --> P(a) & P(b)"
by blast

lemma "\<exists>z. P(z) --> (\<forall>x. P(x))"
by blast

lemma "\<exists>x. (\<exists>y. P(y)) --> P(x)"
by blast

text{*V. Lifschitz, What Is the Inverse Method?, JAR 5 (1989), 1--23.  NOT PROVED*}
lemma "\<exists>x x'. \<forall>y. \<exists>z z'.
                (~P(y,y) | P(x,x) | ~S(z,x)) &
                (S(x,y) | ~S(y,z) | Q(z',z'))  &
                (Q(x',y) | ~Q(y,z') | S(x',x'))"
oops

subsection{*Hard examples with quantifiers*}

text{*18*}
lemma "\<exists>y. \<forall>x. P(y)-->P(x)"
by blast

text{*19*}
lemma "\<exists>x. \<forall>y z. (P(y)-->Q(z)) --> (P(x)-->Q(x))"
by blast

text{*20*}
lemma "(\<forall>x y. \<exists>z. \<forall>w. (P(x)&Q(y)-->R(z)&S(w)))
    --> (\<exists>x y. P(x) & Q(y)) --> (\<exists>z. R(z))"
by blast

text{*21*}
lemma "(\<exists>x. P-->Q(x)) & (\<exists>x. Q(x)-->P) --> (\<exists>x. P<->Q(x))"
by blast

text{*22*}
lemma "(\<forall>x. P <-> Q(x))  -->  (P <-> (\<forall>x. Q(x)))"
by blast

text{*23*}
lemma "(\<forall>x. P | Q(x))  <->  (P | (\<forall>x. Q(x)))"
by blast

text{*24*}
lemma "~(\<exists>x. S(x)&Q(x)) & (\<forall>x. P(x) --> Q(x)|R(x)) &
      (~(\<exists>x. P(x)) --> (\<exists>x. Q(x))) & (\<forall>x. Q(x)|R(x) --> S(x))
    --> (\<exists>x. P(x)&R(x))"
by blast

text{*25*}
lemma "(\<exists>x. P(x)) &
      (\<forall>x. L(x) --> ~ (M(x) & R(x))) &
      (\<forall>x. P(x) --> (M(x) & L(x))) &
      ((\<forall>x. P(x)-->Q(x)) | (\<exists>x. P(x)&R(x)))
    --> (\<exists>x. Q(x)&P(x))"
by blast

text{*26*}
lemma "((\<exists>x. p(x)) <-> (\<exists>x. q(x))) &
      (\<forall>x. \<forall>y. p(x) & q(y) --> (r(x) <-> s(y)))
  --> ((\<forall>x. p(x)-->r(x)) <-> (\<forall>x. q(x)-->s(x)))"
by blast

text{*27*}
lemma "(\<exists>x. P(x) & ~Q(x)) &
      (\<forall>x. P(x) --> R(x)) &
      (\<forall>x. M(x) & L(x) --> P(x)) &
      ((\<exists>x. R(x) & ~ Q(x)) --> (\<forall>x. L(x) --> ~ R(x)))
  --> (\<forall>x. M(x) --> ~L(x))"
by blast

text{*28.  AMENDED*}
lemma "(\<forall>x. P(x) --> (\<forall>x. Q(x))) &
        ((\<forall>x. Q(x)|R(x)) --> (\<exists>x. Q(x)&S(x))) &
        ((\<exists>x. S(x)) --> (\<forall>x. L(x) --> M(x)))
    --> (\<forall>x. P(x) & L(x) --> M(x))"
by blast

text{*29.  Essentially the same as Principia Mathematica *11.71*}
lemma "(\<exists>x. P(x)) & (\<exists>y. Q(y))
    --> ((\<forall>x. P(x)-->R(x)) & (\<forall>y. Q(y)-->S(y))   <->
         (\<forall>x y. P(x) & Q(y) --> R(x) & S(y)))"
by blast

text{*30*}
lemma "(\<forall>x. P(x) | Q(x) --> ~ R(x)) &
      (\<forall>x. (Q(x) --> ~ S(x)) --> P(x) & R(x))
    --> (\<forall>x. S(x))"
by blast

text{*31*}
lemma "~(\<exists>x. P(x) & (Q(x) | R(x))) &
        (\<exists>x. L(x) & P(x)) &
        (\<forall>x. ~ R(x) --> M(x))
    --> (\<exists>x. L(x) & M(x))"
by blast

text{*32*}
lemma "(\<forall>x. P(x) & (Q(x)|R(x))-->S(x)) &
      (\<forall>x. S(x) & R(x) --> L(x)) &
      (\<forall>x. M(x) --> R(x))
      --> (\<forall>x. P(x) & M(x) --> L(x))"
by blast

text{*33*}
lemma "(\<forall>x. P(a) & (P(x)-->P(b))-->P(c))  <->
      (\<forall>x. (~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c)))"
by blast

text{*34  AMENDED (TWICE!!).  Andrews's challenge*}
lemma "((\<exists>x. \<forall>y. p(x) <-> p(y))  <->
       ((\<exists>x. q(x)) <-> (\<forall>y. p(y))))     <->
      ((\<exists>x. \<forall>y. q(x) <-> q(y))  <->
       ((\<exists>x. p(x)) <-> (\<forall>y. q(y))))"
by blast

text{*35*}
lemma "\<exists>x y. P(x,y) -->  (\<forall>u v. P(u,v))"
by blast

text{*36*}
lemma "(\<forall>x. \<exists>y. J(x,y)) &
      (\<forall>x. \<exists>y. G(x,y)) &
      (\<forall>x y. J(x,y) | G(x,y) --> (\<forall>z. J(y,z) | G(y,z) --> H(x,z)))
  --> (\<forall>x. \<exists>y. H(x,y))"
by blast

text{*37*}
lemma "(\<forall>z. \<exists>w. \<forall>x. \<exists>y.
           (P(x,z)-->P(y,w)) & P(y,z) & (P(y,w) --> (\<exists>u. Q(u,w)))) &
      (\<forall>x z. ~P(x,z) --> (\<exists>y. Q(y,z))) &
      ((\<exists>x y. Q(x,y)) --> (\<forall>x. R(x,x)))
      --> (\<forall>x. \<exists>y. R(x,y))"
by blast

text{*38*}
lemma "(\<forall>x. p(a) & (p(x) --> (\<exists>y. p(y) & r(x,y))) -->
             (\<exists>z. \<exists>w. p(z) & r(x,w) & r(w,z)))  <->
      (\<forall>x. (~p(a) | p(x) | (\<exists>z. \<exists>w. p(z) & r(x,w) & r(w,z))) &
              (~p(a) | ~(\<exists>y. p(y) & r(x,y)) |
              (\<exists>z. \<exists>w. p(z) & r(x,w) & r(w,z))))"
by blast

text{*39*}
lemma "~ (\<exists>x. \<forall>y. F(y,x) <-> ~F(y,y))"
by blast

text{*40.  AMENDED*}
lemma "(\<exists>y. \<forall>x. F(x,y) <-> F(x,x)) -->
              ~(\<forall>x. \<exists>y. \<forall>z. F(z,y) <-> ~ F(z,x))"
by blast

text{*41*}
lemma "(\<forall>z. \<exists>y. \<forall>x. f(x,y) <-> f(x,z) & ~ f(x,x))
          --> ~ (\<exists>z. \<forall>x. f(x,z))"
by blast

text{*42*}
lemma "~ (\<exists>y. \<forall>x. p(x,y) <-> ~ (\<exists>z. p(x,z) & p(z,x)))"
by blast

text{*43*}
lemma "(\<forall>x. \<forall>y. q(x,y) <-> (\<forall>z. p(z,x) <-> p(z,y)))
          --> (\<forall>x. \<forall>y. q(x,y) <-> q(y,x))"
by blast

(*Other proofs: Can use auto, which cheats by using rewriting!
  Deepen_tac alone requires 253 secs.  Or
  by (mini_tac @{context} 1 THEN Deepen_tac 5 1) *)

text{*44*}
lemma "(\<forall>x. f(x) --> (\<exists>y. g(y) & h(x,y) & (\<exists>y. g(y) & ~ h(x,y)))) &
      (\<exists>x. j(x) & (\<forall>y. g(y) --> h(x,y)))
      --> (\<exists>x. j(x) & ~f(x))"
by blast

text{*45*}
lemma "(\<forall>x. f(x) & (\<forall>y. g(y) & h(x,y) --> j(x,y))
                      --> (\<forall>y. g(y) & h(x,y) --> k(y))) &
      ~ (\<exists>y. l(y) & k(y)) &
      (\<exists>x. f(x) & (\<forall>y. h(x,y) --> l(y))
                  & (\<forall>y. g(y) & h(x,y) --> j(x,y)))
      --> (\<exists>x. f(x) & ~ (\<exists>y. g(y) & h(x,y)))"
by blast

text{*46*}
lemma "(\<forall>x. f(x) & (\<forall>y. f(y) & h(y,x) --> g(y)) --> g(x)) &
      ((\<exists>x. f(x) & ~g(x)) -->
       (\<exists>x. f(x) & ~g(x) & (\<forall>y. f(y) & ~g(y) --> j(x,y)))) &
      (\<forall>x y. f(x) & f(y) & h(x,y) --> ~j(y,x))
       --> (\<forall>x. f(x) --> g(x))"
by blast

subsection{*Problems (mainly) involving equality or functions*}

text{*48*}
lemma "(a=b | c=d) & (a=c | b=d) --> a=d | b=c"
by blast

text{*49  NOT PROVED AUTOMATICALLY.  Hard because it involves substitution
  for Vars
  the type constraint ensures that x,y,z have the same type as a,b,u. *}
lemma "(\<exists>x y::'a. \<forall>z. z=x | z=y) & P(a) & P(b) & a~=b
                --> (\<forall>u::'a. P(u))"
apply safe
apply (rule_tac x = a in allE, assumption)
apply (rule_tac x = b in allE, assumption, fast)
       --{*blast's treatment of equality can't do it*}
done

text{*50.  (What has this to do with equality?) *}
lemma "(\<forall>x. P(a,x) | (\<forall>y. P(x,y))) --> (\<exists>x. \<forall>y. P(x,y))"
by blast

text{*51*}
lemma "(\<exists>z w. \<forall>x y. P(x,y) <->  (x=z & y=w)) -->
      (\<exists>z. \<forall>x. \<exists>w. (\<forall>y. P(x,y) <-> y=w) <-> x=z)"
by blast

text{*52*}
text{*Almost the same as 51. *}
lemma "(\<exists>z w. \<forall>x y. P(x,y) <->  (x=z & y=w)) -->
      (\<exists>w. \<forall>y. \<exists>z. (\<forall>x. P(x,y) <-> x=z) <-> y=w)"
by blast

text{*55*}

text{*Non-equational version, from Manthey and Bry, CADE-9 (Springer, 1988).
  fast DISCOVERS who killed Agatha. *}
schematic_lemma "lives(agatha) & lives(butler) & lives(charles) &
   (killed(agatha,agatha) | killed(butler,agatha) | killed(charles,agatha)) &
   (\<forall>x y. killed(x,y) --> hates(x,y) & ~richer(x,y)) &
   (\<forall>x. hates(agatha,x) --> ~hates(charles,x)) &
   (hates(agatha,agatha) & hates(agatha,charles)) &
   (\<forall>x. lives(x) & ~richer(x,agatha) --> hates(butler,x)) &
   (\<forall>x. hates(agatha,x) --> hates(butler,x)) &
   (\<forall>x. ~hates(x,agatha) | ~hates(x,butler) | ~hates(x,charles)) -->
    killed(?who,agatha)"
by fast --{*MUCH faster than blast*}

text{*56*}
lemma "(\<forall>x. (\<exists>y. P(y) & x=f(y)) --> P(x)) <-> (\<forall>x. P(x) --> P(f(x)))"
by blast

text{*57*}
lemma "P(f(a,b), f(b,c)) & P(f(b,c), f(a,c)) &
     (\<forall>x y z. P(x,y) & P(y,z) --> P(x,z))    -->   P(f(a,b), f(a,c))"
by blast

text{*58  NOT PROVED AUTOMATICALLY*}
lemma "(\<forall>x y. f(x)=g(y)) --> (\<forall>x y. f(f(x))=f(g(y)))"
by (slow elim: subst_context)

text{*59*}
lemma "(\<forall>x. P(x) <-> ~P(f(x))) --> (\<exists>x. P(x) & ~P(f(x)))"
by blast

text{*60*}
lemma "\<forall>x. P(x,f(x)) <-> (\<exists>y. (\<forall>z. P(z,y) --> P(z,f(x))) & P(x,y))"
by blast

text{*62 as corrected in JAR 18 (1997), page 135*}
lemma "(\<forall>x. p(a) & (p(x) --> p(f(x))) --> p(f(f(x))))  <->
      (\<forall>x. (~p(a) | p(x) | p(f(f(x)))) &
              (~p(a) | ~p(f(x)) | p(f(f(x)))))"
by blast

text{*From Davis, Obvious Logical Inferences, IJCAI-81, 530-531
  fast indeed copes!*}
lemma "(\<forall>x. F(x) & ~G(x) --> (\<exists>y. H(x,y) & J(y))) &
              (\<exists>x. K(x) & F(x) & (\<forall>y. H(x,y) --> K(y))) &
              (\<forall>x. K(x) --> ~G(x))  -->  (\<exists>x. K(x) & J(x))"
by fast

text{*From Rudnicki, Obvious Inferences, JAR 3 (1987), 383-393.
  It does seem obvious!*}
lemma "(\<forall>x. F(x) & ~G(x) --> (\<exists>y. H(x,y) & J(y))) &
      (\<exists>x. K(x) & F(x) & (\<forall>y. H(x,y) --> K(y)))  &
      (\<forall>x. K(x) --> ~G(x))   -->   (\<exists>x. K(x) --> ~G(x))"
by fast

text{*Halting problem: Formulation of Li Dafa (AAR Newsletter 27, Oct 1994.)
  author U. Egly*}
lemma "((\<exists>x. A(x) & (\<forall>y. C(y) --> (\<forall>z. D(x,y,z)))) -->
   (\<exists>w. C(w) & (\<forall>y. C(y) --> (\<forall>z. D(w,y,z)))))
  &
  (\<forall>w. C(w) & (\<forall>u. C(u) --> (\<forall>v. D(w,u,v))) -->
        (\<forall>y z.
            (C(y) &  P(y,z) --> Q(w,y,z) & OO(w,g)) &
            (C(y) & ~P(y,z) --> Q(w,y,z) & OO(w,b))))
  &
  (\<forall>w. C(w) &
    (\<forall>y z.
        (C(y) & P(y,z) --> Q(w,y,z) & OO(w,g)) &
        (C(y) & ~P(y,z) --> Q(w,y,z) & OO(w,b))) -->
    (\<exists>v. C(v) &
          (\<forall>y. ((C(y) & Q(w,y,y)) & OO(w,g) --> ~P(v,y)) &
                  ((C(y) & Q(w,y,y)) & OO(w,b) --> P(v,y) & OO(v,b)))))
   -->
   ~ (\<exists>x. A(x) & (\<forall>y. C(y) --> (\<forall>z. D(x,y,z))))"
by (blast 12)
   --{*Needed because the search for depths below 12 is very slow*}

text{*Halting problem II: credited to M. Bruschi by Li Dafa in JAR 18(1), p.105*}
lemma "((\<exists>x. A(x) & (\<forall>y. C(y) --> (\<forall>z. D(x,y,z)))) -->
   (\<exists>w. C(w) & (\<forall>y. C(y) --> (\<forall>z. D(w,y,z)))))
  &
  (\<forall>w. C(w) & (\<forall>u. C(u) --> (\<forall>v. D(w,u,v))) -->
        (\<forall>y z.
            (C(y) &  P(y,z) --> Q(w,y,z) & OO(w,g)) &
            (C(y) & ~P(y,z) --> Q(w,y,z) & OO(w,b))))
  &
  ((\<exists>w. C(w) & (\<forall>y. (C(y) &  P(y,y) --> Q(w,y,y) & OO(w,g)) &
                         (C(y) & ~P(y,y) --> Q(w,y,y) & OO(w,b))))
   -->
   (\<exists>v. C(v) & (\<forall>y. (C(y) &  P(y,y) --> P(v,y) & OO(v,g)) &
                         (C(y) & ~P(y,y) --> P(v,y) & OO(v,b)))))
  -->
  ((\<exists>v. C(v) & (\<forall>y. (C(y) &  P(y,y) --> P(v,y) & OO(v,g)) &
                         (C(y) & ~P(y,y) --> P(v,y) & OO(v,b))))
   -->
   (\<exists>u. C(u) & (\<forall>y. (C(y) &  P(y,y) --> ~P(u,y)) &
                         (C(y) & ~P(y,y) --> P(u,y) & OO(u,b)))))
   -->
   ~ (\<exists>x. A(x) & (\<forall>y. C(y) --> (\<forall>z. D(x,y,z))))"
by blast

text{* Challenge found on info-hol *}
lemma "\<forall>x. \<exists>v w. \<forall>y z. P(x) & Q(y) --> (P(v) | R(w)) & (R(z) --> Q(v))"
by blast

text{*Attributed to Lewis Carroll by S. G. Pulman.  The first or last assumption
can be deleted.*}
lemma "(\<forall>x. honest(x) & industrious(x) --> healthy(x)) &
      ~ (\<exists>x. grocer(x) & healthy(x)) &
      (\<forall>x. industrious(x) & grocer(x) --> honest(x)) &
      (\<forall>x. cyclist(x) --> industrious(x)) &
      (\<forall>x. ~healthy(x) & cyclist(x) --> ~honest(x))
      --> (\<forall>x. grocer(x) --> ~cyclist(x))"
by blast

(*Runtimes for old versions of this file:
Thu Jul 23 1992: loaded in 467s using iffE [on SPARC2]
Mon Nov 14 1994: loaded in 144s [on SPARC10, with deepen_tac]
Wed Nov 16 1994: loaded in 138s [after addition of norm_term_skip]
Mon Nov 21 1994: loaded in 131s [DEPTH_FIRST suppressing repetitions]

Further runtimes on a Sun-4
Tue Mar  4 1997: loaded in 93s (version 94-7)
Tue Mar  4 1997: loaded in 89s
Thu Apr  3 1997: loaded in 44s--using mostly Blast_tac
Thu Apr  3 1997: loaded in 96s--addition of two Halting Probs
Thu Apr  3 1997: loaded in 98s--using lim-1 for all haz rules
Tue Dec  2 1997: loaded in 107s--added 46; new equalSubst
Fri Dec 12 1997: loaded in 91s--faster proof reconstruction
Thu Dec 18 1997: loaded in 94s--two new "obvious theorems" (??)
*)

end


(*  Title:      ZF/OrdQuant.thy
    Authors:    Krzysztof Grabczewski and L C Paulson
*)

section \<open>Special quantifiers\<close>

theory OrdQuant imports Ordinal begin

subsection \<open>Quantifiers and union operator for ordinals\<close>

definition
  (* Ordinal Quantifiers *)
  oall :: "[i, i => o] => o"  where
    "oall(A, P) == \<forall>x. x<A \<longrightarrow> P(x)"

definition
  oex :: "[i, i => o] => o"  where
    "oex(A, P)  == \<exists>x. x<A & P(x)"

definition
  (* Ordinal Union *)
  OUnion :: "[i, i => i] => i"  where
    "OUnion(i,B) == {z: \<Union>x\<in>i. B(x). Ord(i)}"

syntax
  "_oall"     :: "[idt, i, o] => o"        ("(3\<forall>_<_./ _)" 10)
  "_oex"      :: "[idt, i, o] => o"        ("(3\<exists>_<_./ _)" 10)
  "_OUNION"   :: "[idt, i, i] => i"        ("(3\<Union>_<_./ _)" 10)
translations
  "\<forall>x<a. P" \<rightleftharpoons> "CONST oall(a, \<lambda>x. P)"
  "\<exists>x<a. P" \<rightleftharpoons> "CONST oex(a, \<lambda>x. P)"
  "\<Union>x<a. B" \<rightleftharpoons> "CONST OUnion(a, \<lambda>x. B)"

subsubsection \<open>simplification of the new quantifiers\<close>

(*MOST IMPORTANT that this is added to the simpset BEFORE Ord_atomize
  is proved.  Ord_atomize would convert this rule to
    x < 0 ==> P(x) == True, which causes dire effects!*)

lemma [simp]: "~(\<exists>x<0. P(x))"
by (simp add: oex_def)

lemma [simp]: "(\<forall>x<succ(i). P(x)) <-> (Ord(i) \<longrightarrow> P(i) & (\<forall>x<i. P(x)))"
apply (simp add: oall_def le_iff)
apply (blast intro: lt_Ord2)
done

lemma [simp]: "(\<exists>x<succ(i). P(x)) <-> (Ord(i) & (P(i) | (\<exists>x<i. P(x))))"
apply (simp add: oex_def le_iff)
apply (blast intro: lt_Ord2)
done

subsubsection \<open>Union over ordinals\<close>

lemma Ord_OUN [intro,simp]:
     "[| !!x. x<A ==> Ord(B(x)) |] ==> Ord(\<Union>x<A. B(x))"
by (simp add: OUnion_def ltI Ord_UN)

lemma OUN_upper_lt:
     "[| a<A;  i < b(a);  Ord(\<Union>x<A. b(x)) |] ==> i < (\<Union>x<A. b(x))"
by (unfold OUnion_def lt_def, blast )

lemma OUN_upper_le:
     "[| a<A;  i\<le>b(a);  Ord(\<Union>x<A. b(x)) |] ==> i \<le> (\<Union>x<A. b(x))"
apply (unfold OUnion_def, auto)
apply (rule UN_upper_le )
apply (auto simp add: lt_def)
done

lemma Limit_OUN_eq: "Limit(i) ==> (\<Union>x<i. x) = i"
by (simp add: OUnion_def Limit_Union_eq Limit_is_Ord)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma OUN_least:
     "(!!x. x<A ==> B(x) \<subseteq> C) ==> (\<Union>x<A. B(x)) \<subseteq> C"
by (simp add: OUnion_def UN_least ltI)

lemma OUN_least_le:
     "[| Ord(i);  !!x. x<A ==> b(x) \<le> i |] ==> (\<Union>x<A. b(x)) \<le> i"
by (simp add: OUnion_def UN_least_le ltI Ord_0_le)

lemma le_implies_OUN_le_OUN:
     "[| !!x. x<A ==> c(x) \<le> d(x) |] ==> (\<Union>x<A. c(x)) \<le> (\<Union>x<A. d(x))"
by (blast intro: OUN_least_le OUN_upper_le le_Ord2 Ord_OUN)

lemma OUN_UN_eq:
     "(!!x. x \<in> A ==> Ord(B(x)))
      ==> (\<Union>z < (\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z < B(x). C(z))"
by (simp add: OUnion_def)

lemma OUN_Union_eq:
     "(!!x. x \<in> X ==> Ord(x))
      ==> (\<Union>z < \<Union>(X). C(z)) = (\<Union>x\<in>X. \<Union>z < x. C(z))"
by (simp add: OUnion_def)

(*So that rule_format will get rid of this quantifier...*)
lemma atomize_oall [symmetric, rulify]:
     "(!!x. x<A ==> P(x)) == Trueprop (\<forall>x<A. P(x))"
by (simp add: oall_def atomize_all atomize_imp)

subsubsection \<open>universal quantifier for ordinals\<close>

lemma oallI [intro!]:
    "[| !!x. x<A ==> P(x) |] ==> \<forall>x<A. P(x)"
by (simp add: oall_def)

lemma ospec: "[| \<forall>x<A. P(x);  x<A |] ==> P(x)"
by (simp add: oall_def)

lemma oallE:
    "[| \<forall>x<A. P(x);  P(x) ==> Q;  ~x<A ==> Q |] ==> Q"
by (simp add: oall_def, blast)

lemma rev_oallE [elim]:
    "[| \<forall>x<A. P(x);  ~x<A ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: oall_def, blast)

(*Trival rewrite rule.  @{term"(\<forall>x<a.P)<->P"} holds only if a is not 0!*)
lemma oall_simp [simp]: "(\<forall>x<a. True) <-> True"
by blast

(*Congruence rule for rewriting*)
lemma oall_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oall(a, %x. P(x)) <-> oall(a', %x. P'(x))"
by (simp add: oall_def)

subsubsection \<open>existential quantifier for ordinals\<close>

lemma oexI [intro]:
    "[| P(x);  x<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

(*Not of the general form for such rules... *)
lemma oexCI:
   "[| \<forall>x<A. ~P(x) ==> P(a);  a<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

lemma oexE [elim!]:
    "[| \<exists>x<A. P(x);  !!x. [| x<A; P(x) |] ==> Q |] ==> Q"
apply (simp add: oex_def, blast)
done

lemma oex_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oex(a, %x. P(x)) <-> oex(a', %x. P'(x))"
apply (simp add: oex_def cong add: conj_cong)
done

subsubsection \<open>Rules for Ordinal-Indexed Unions\<close>

lemma OUN_I [intro]: "[| a<i;  b \<in> B(a) |] ==> b: (\<Union>z<i. B(z))"
by (unfold OUnion_def lt_def, blast)

lemma OUN_E [elim!]:
    "[| b \<in> (\<Union>z<i. B(z));  !!a.[| b \<in> B(a);  a<i |] ==> R |] ==> R"
apply (unfold OUnion_def lt_def, blast)
done

lemma OUN_iff: "b \<in> (\<Union>x<i. B(x)) <-> (\<exists>x<i. b \<in> B(x))"
by (unfold OUnion_def oex_def lt_def, blast)

lemma OUN_cong [cong]:
    "[| i=j;  !!x. x<j ==> C(x)=D(x) |] ==> (\<Union>x<i. C(x)) = (\<Union>x<j. D(x))"
by (simp add: OUnion_def lt_def OUN_iff)

lemma lt_induct:
    "[| i<k;  !!x.[| x<k;  \<forall>y<x. P(y) |] ==> P(x) |]  ==>  P(i)"
apply (simp add: lt_def oall_def)
apply (erule conjE)
apply (erule Ord_induct, assumption, blast)
done

subsection \<open>Quantification over a class\<close>

definition
  "rall"     :: "[i=>o, i=>o] => o"  where
    "rall(M, P) == \<forall>x. M(x) \<longrightarrow> P(x)"

definition
  "rex"      :: "[i=>o, i=>o] => o"  where
    "rex(M, P) == \<exists>x. M(x) & P(x)"

syntax
  "_rall"     :: "[pttrn, i=>o, o] => o"        ("(3\<forall>_[_]./ _)" 10)
  "_rex"      :: "[pttrn, i=>o, o] => o"        ("(3\<exists>_[_]./ _)" 10)
translations
  "\<forall>x[M]. P" \<rightleftharpoons> "CONST rall(M, \<lambda>x. P)"
  "\<exists>x[M]. P" \<rightleftharpoons> "CONST rex(M, \<lambda>x. P)"

subsubsection\<open>Relativized universal quantifier\<close>

lemma rallI [intro!]: "[| !!x. M(x) ==> P(x) |] ==> \<forall>x[M]. P(x)"
by (simp add: rall_def)

lemma rspec: "[| \<forall>x[M]. P(x); M(x) |] ==> P(x)"
by (simp add: rall_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_rallE [elim]:
    "[| \<forall>x[M]. P(x);  ~ M(x) ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: rall_def, blast)

lemma rallE: "[| \<forall>x[M]. P(x);  P(x) ==> Q;  ~ M(x) ==> Q |] ==> Q"
by blast

(*Trival rewrite rule;   (\<forall>x[M].P)<->P holds only if A is nonempty!*)
lemma rall_triv [simp]: "(\<forall>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<longrightarrow> P)"
by (simp add: rall_def)

(*Congruence rule for rewriting*)
lemma rall_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<forall>x[M]. P(x)) <-> (\<forall>x[M]. P'(x))"
by (simp add: rall_def)

subsubsection\<open>Relativized existential quantifier\<close>

lemma rexI [intro]: "[| P(x); M(x) |] ==> \<exists>x[M]. P(x)"
by (simp add: rex_def, blast)

(*The best argument order when there is only one M(x)*)
lemma rev_rexI: "[| M(x);  P(x) |] ==> \<exists>x[M]. P(x)"
by blast

(*Not of the general form for such rules... *)
lemma rexCI: "[| \<forall>x[M]. ~P(x) ==> P(a); M(a) |] ==> \<exists>x[M]. P(x)"
by blast

lemma rexE [elim!]: "[| \<exists>x[M]. P(x);  !!x. [| M(x); P(x) |] ==> Q |] ==> Q"
by (simp add: rex_def, blast)

(*We do not even have (\<exists>x[M]. True) <-> True unless A is nonempty!!*)
lemma rex_triv [simp]: "(\<exists>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<and> P)"
by (simp add: rex_def)

lemma rex_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<exists>x[M]. P(x)) <-> (\<exists>x[M]. P'(x))"
by (simp add: rex_def cong: conj_cong)

lemma rall_is_ball [simp]: "(\<forall>x[%z. z\<in>A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by blast

lemma rex_is_bex [simp]: "(\<exists>x[%z. z\<in>A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by blast

lemma atomize_rall: "(!!x. M(x) ==> P(x)) == Trueprop (\<forall>x[M]. P(x))"
by (simp add: rall_def atomize_all atomize_imp)

declare atomize_rall [symmetric, rulify]

lemma rall_simps1:
     "(\<forall>x[M]. P(x) & Q)   <-> (\<forall>x[M]. P(x)) & ((\<forall>x[M]. False) | Q)"
     "(\<forall>x[M]. P(x) | Q)   <-> ((\<forall>x[M]. P(x)) | Q)"
     "(\<forall>x[M]. P(x) \<longrightarrow> Q) <-> ((\<exists>x[M]. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x[M]. P(x))) <-> (\<exists>x[M]. ~P(x))"
by blast+

lemma rall_simps2:
     "(\<forall>x[M]. P & Q(x))   <-> ((\<forall>x[M]. False) | P) & (\<forall>x[M]. Q(x))"
     "(\<forall>x[M]. P | Q(x))   <-> (P | (\<forall>x[M]. Q(x)))"
     "(\<forall>x[M]. P \<longrightarrow> Q(x)) <-> (P \<longrightarrow> (\<forall>x[M]. Q(x)))"
by blast+

lemmas rall_simps [simp] = rall_simps1 rall_simps2

lemma rall_conj_distrib:
    "(\<forall>x[M]. P(x) & Q(x)) <-> ((\<forall>x[M]. P(x)) & (\<forall>x[M]. Q(x)))"
by blast

lemma rex_simps1:
     "(\<exists>x[M]. P(x) & Q) <-> ((\<exists>x[M]. P(x)) & Q)"
     "(\<exists>x[M]. P(x) | Q) <-> (\<exists>x[M]. P(x)) | ((\<exists>x[M]. True) & Q)"
     "(\<exists>x[M]. P(x) \<longrightarrow> Q) <-> ((\<forall>x[M]. P(x)) \<longrightarrow> ((\<exists>x[M]. True) & Q))"
     "(~(\<exists>x[M]. P(x))) <-> (\<forall>x[M]. ~P(x))"
by blast+

lemma rex_simps2:
     "(\<exists>x[M]. P & Q(x)) <-> (P & (\<exists>x[M]. Q(x)))"
     "(\<exists>x[M]. P | Q(x)) <-> ((\<exists>x[M]. True) & P) | (\<exists>x[M]. Q(x))"
     "(\<exists>x[M]. P \<longrightarrow> Q(x)) <-> (((\<forall>x[M]. False) | P) \<longrightarrow> (\<exists>x[M]. Q(x)))"
by blast+

lemmas rex_simps [simp] = rex_simps1 rex_simps2

lemma rex_disj_distrib:
    "(\<exists>x[M]. P(x) | Q(x)) <-> ((\<exists>x[M]. P(x)) | (\<exists>x[M]. Q(x)))"
by blast

subsubsection\<open>One-point rule for bounded quantifiers\<close>

lemma rex_triv_one_point1 [simp]: "(\<exists>x[M]. x=a) <-> ( M(a))"
by blast

lemma rex_triv_one_point2 [simp]: "(\<exists>x[M]. a=x) <-> ( M(a))"
by blast

lemma rex_one_point1 [simp]: "(\<exists>x[M]. x=a & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rex_one_point2 [simp]: "(\<exists>x[M]. a=x & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rall_one_point1 [simp]: "(\<forall>x[M]. x=a \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

lemma rall_one_point2 [simp]: "(\<forall>x[M]. a=x \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

subsubsection\<open>Sets as Classes\<close>

definition
  setclass :: "[i,i] => o"       ("##_" [40] 40)  where
   "setclass(A) == %x. x \<in> A"

lemma setclass_iff [simp]: "setclass(A,x) <-> x \<in> A"
by (simp add: setclass_def)

lemma rall_setclass_is_ball [simp]: "(\<forall>x[##A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by auto

lemma rex_setclass_is_bex [simp]: "(\<exists>x[##A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by auto

ML
\<open>
val Ord_atomize =
  atomize ([(@{const_name oall}, @{thms ospec}), (@{const_name rall}, @{thms rspec})] @
    ZF_conn_pairs, ZF_mem_pairs);
\<close>
declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

text \<open>Setting up the one-point-rule simproc\<close>

simproc_setup defined_rex ("\<exists>x[M]. P(x) & Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_bex
    (fn ctxt =>
      unfold_tac ctxt @{thms rex_def} THEN
      Quantifier1.prove_one_point_ex_tac ctxt)
\<close>

simproc_setup defined_rall ("\<forall>x[M]. P(x) \<longrightarrow> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_ball
    (fn ctxt =>
      unfold_tac ctxt @{thms rall_def} THEN
      Quantifier1.prove_one_point_all_tac ctxt)
\<close>

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Lexicographic order on functions\<close>

theory Fun_Lexorder
imports Main
begin

definition less_fun :: "('a::linorder \<Rightarrow> 'b::linorder) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "less_fun f g \<longleftrightarrow> (\<exists>k. f k < g k \<and> (\<forall>k' < k. f k' = g k'))"

lemma less_funI:
  assumes "\<exists>k. f k < g k \<and> (\<forall>k' < k. f k' = g k')"
  shows "less_fun f g"
  using assms by (simp add: less_fun_def)

lemma less_funE:
  assumes "less_fun f g"
  obtains k where "f k < g k" and "\<And>k'. k' < k \<Longrightarrow> f k' = g k'"
  using assms unfolding less_fun_def by blast

lemma less_fun_asym:
  assumes "less_fun f g"
  shows "\<not> less_fun g f"
proof
  from assms obtain k1 where k1: "f k1 < g k1" "k' < k1 \<Longrightarrow> f k' = g k'" for k'
    by (blast elim!: less_funE)
  assume "less_fun g f" then obtain k2 where k2: "g k2 < f k2" "k' < k2 \<Longrightarrow> g k' = f k'" for k'
    by (blast elim!: less_funE)
  show False proof (cases k1 k2 rule: linorder_cases)
    case equal with k1 k2 show False by simp
  next
    case less with k2 have "g k1 = f k1" by simp
    with k1 show False by simp
  next
    case greater with k1 have "f k2 = g k2" by simp
    with k2 show False by simp
  qed
qed

lemma less_fun_irrefl:
  "\<not> less_fun f f"
proof
  assume "less_fun f f"
  then obtain k where k: "f k < f k"
    by (blast elim!: less_funE)
  then show False by simp
qed

lemma less_fun_trans:
  assumes "less_fun f g" and "less_fun g h"
  shows "less_fun f h"
proof (rule less_funI)
  from \<open>less_fun f g\<close> obtain k1 where k1: "f k1 < g k1" "k' < k1 \<Longrightarrow> f k' = g k'" for k'
    by (blast elim!: less_funE)
  from \<open>less_fun g h\<close> obtain k2 where k2: "g k2 < h k2" "k' < k2 \<Longrightarrow> g k' = h k'" for k'
    by (blast elim!: less_funE)
  show "\<exists>k. f k < h k \<and> (\<forall>k'<k. f k' = h k')"
  proof (cases k1 k2 rule: linorder_cases)
    case equal with k1 k2 show ?thesis by (auto simp add: exI [of _ k2])
  next
    case less with k2 have "g k1 = h k1" "\<And>k'. k' < k1 \<Longrightarrow> g k' = h k'" by simp_all
    with k1 show ?thesis by (auto intro: exI [of _ k1])
  next
    case greater with k1 have "f k2 = g k2" "\<And>k'. k' < k2 \<Longrightarrow> f k' = g k'" by simp_all
    with k2 show ?thesis by (auto intro: exI [of _ k2])
  qed
qed

lemma order_less_fun:
  "class.order (\<lambda>f g. less_fun f g \<or> f = g) less_fun"
  by (rule order_strictI) (auto intro: less_fun_trans intro!: less_fun_irrefl less_fun_asym)

lemma less_fun_trichotomy:
  assumes "finite {k. f k \<noteq> g k}"
  shows "less_fun f g \<or> f = g \<or> less_fun g f"
proof -
  { define K where "K = {k. f k \<noteq> g k}"
    assume "f \<noteq> g"
    then obtain k' where "f k' \<noteq> g k'" by auto
    then have [simp]: "K \<noteq> {}" by (auto simp add: K_def)
    with assms have [simp]: "finite K" by (simp add: K_def)
    define q where "q = Min K"
    then have "q \<in> K" and "\<And>k. k \<in> K \<Longrightarrow> k \<ge> q" by auto
    then have "\<And>k. \<not> k \<ge> q \<Longrightarrow> k \<notin> K" by blast
    then have *: "\<And>k. k < q \<Longrightarrow> f k = g k" by (simp add: K_def)
    from \<open>q \<in> K\<close> have "f q \<noteq> g q" by (simp add: K_def)
    then have "f q < g q \<or> f q > g q" by auto
    with * have "less_fun f g \<or> less_fun g f"
      by (auto intro!: less_funI)
  } then show ?thesis by blast
qed

end


(*
  File:       E_Transcendental.thy
  Author:     Manuel Eberl <manuel@pruvisto.org>

  A proof that e (Euler's number) is transcendental.
  Could possibly be extended to a transcendence proof for pi or
  the very general Lindemann-Weierstrass theorem.
*)
section \<open>Proof of the Transcendence of $e$\<close>
theory E_Transcendental
  imports
    "HOL-Complex_Analysis.Complex_Analysis"
    "HOL-Number_Theory.Number_Theory"
    "HOL-Computational_Algebra.Polynomial"
begin

hide_const (open) UnivPoly.coeff  UnivPoly.up_ring.monom
hide_const (open) Module.smult  Coset.order

(* TODO: Lots of stuff to move to the distribution *)

subsection \<open>Various auxiliary facts\<close>

lemma fact_dvd_pochhammer:
  assumes "m \<le> n + 1"
  shows   "fact m dvd pochhammer (int n - int m + 1) m"
proof -
  have "(real n gchoose m) * fact m = of_int (pochhammer (int n - int m + 1) m)"
    by (simp add: gbinomial_pochhammer' pochhammer_of_int [symmetric])
  also have "(real n gchoose m) * fact m = of_int (int (n choose m) * fact m)"
    by (simp add: binomial_gbinomial)
  finally have "int (n choose m) * fact m = pochhammer (int n - int m + 1) m"
    by (subst (asm) of_int_eq_iff)
  from this [symmetric] show ?thesis by simp
qed

lemma prime_elem_int_not_dvd_neg1_power:
  "prime_elem (p :: int) \<Longrightarrow> \<not>p dvd (-1) ^ n"
  by (metis dvdI minus_one_mult_self unit_imp_no_prime_divisors)

lemma nat_fact [simp]: "nat (fact n) = fact n"
  by (metis nat_int of_nat_fact of_nat_fact)

lemma prime_dvd_fact_iff_int:
  "p dvd fact n \<longleftrightarrow> p \<le> int n" if "prime p"
  using that prime_dvd_fact_iff [of "nat \<bar>p\<bar>" n]
  by auto (simp add: prime_ge_0_int)

lemma power_over_fact_tendsto_0:
  "(\<lambda>n. (x :: real) ^ n / fact n) \<longlonglongrightarrow> 0"
  using summable_exp[of x] by (intro summable_LIMSEQ_zero) (simp add: sums_iff field_simps)

lemma power_over_fact_tendsto_0':
  "(\<lambda>n. c * (x :: real) ^ n / fact n) \<longlonglongrightarrow> 0"
  using tendsto_mult[OF tendsto_const[of c] power_over_fact_tendsto_0[of x]] by simp

subsection \<open>Lifting integer polynomials\<close>

lift_definition of_int_poly :: "int poly \<Rightarrow> 'a :: comm_ring_1 poly" is "\<lambda>g x. of_int (g x)"
  by (auto elim: eventually_mono)

lemma coeff_of_int_poly [simp]: "coeff (of_int_poly p) n = of_int (coeff p n)"
  by (simp add: of_int_poly.rep_eq)

lemma of_int_poly_0 [simp]: "of_int_poly 0 = 0"
  by transfer (simp add: fun_eq_iff)

lemma of_int_poly_pCons [simp]: "of_int_poly (pCons c p) = pCons (of_int c) (of_int_poly p)"
  by transfer' (simp add: fun_eq_iff split: nat.splits)

lemma of_int_poly_smult [simp]: "of_int_poly (smult c p) = smult (of_int c) (of_int_poly p)"
  by transfer simp

lemma of_int_poly_1 [simp]: "of_int_poly 1 = 1"
  by (simp add: one_pCons)

lemma of_int_poly_add [simp]: "of_int_poly (p + q) = of_int_poly p + of_int_poly q"
  by transfer' (simp add: fun_eq_iff)

lemma of_int_poly_mult [simp]: "of_int_poly (p * q) = (of_int_poly p * of_int_poly q)"
  by (induction p) simp_all

lemma of_int_poly_sum [simp]: "of_int_poly (sum f A) = sum (\<lambda>x. of_int_poly (f x)) A"
  by (induction A rule: infinite_finite_induct) simp_all

lemma of_int_poly_prod [simp]: "of_int_poly (prod f A) = prod (\<lambda>x. of_int_poly (f x)) A"
  by (induction A rule: infinite_finite_induct) simp_all

lemma of_int_poly_power [simp]: "of_int_poly (p ^ n) = of_int_poly p ^ n"
  by (induction n) simp_all

lemma of_int_poly_monom [simp]: "of_int_poly (monom c n) = monom (of_int c) n"
  by transfer (simp add: fun_eq_iff)

lemma poly_of_int_poly [simp]: "poly (of_int_poly p) (of_int x) = of_int (poly p x)"
  by (induction p) simp_all

lemma poly_of_int_poly_of_nat [simp]: "poly (of_int_poly p) (of_nat x) = of_int (poly p (int x))"
  by (induction p) simp_all

lemma poly_of_int_poly_0 [simp]: "poly (of_int_poly p) 0 = of_int (poly p 0)"
  by (induction p) simp_all

lemma poly_of_int_poly_1 [simp]: "poly (of_int_poly p) 1 = of_int (poly p 1)"
  by (induction p) simp_all

lemma poly_of_int_poly_of_real [simp]:
    "poly (of_int_poly p) (of_real x) = of_real (poly (of_int_poly p) x)"
  by (induction p) simp_all

lemma of_int_poly_eq_iff [simp]:
  "of_int_poly p = (of_int_poly q :: 'a :: {comm_ring_1, ring_char_0} poly) \<longleftrightarrow> p = q"
  by (simp add: poly_eq_iff)

lemma of_int_poly_eq_0_iff [simp]:
  "of_int_poly p = (0 :: 'a :: {comm_ring_1, ring_char_0} poly) \<longleftrightarrow> p = 0"
  using of_int_poly_eq_iff[of p 0] by (simp del: of_int_poly_eq_iff)

lemma degree_of_int_poly [simp]:
  "degree (of_int_poly p :: 'a :: {comm_ring_1, ring_char_0} poly) = degree p"
  by (simp add: degree_def)

lemma pderiv_of_int_poly [simp]: "pderiv (of_int_poly p) = of_int_poly (pderiv p)"
  by (induction p) (simp_all add: pderiv_pCons)

lemma higher_pderiv_of_int_poly [simp]:
  "(pderiv ^^ n) (of_int_poly p) = of_int_poly ((pderiv ^^ n) p)"
  by (induction n) simp_all

lemma int_polyE:
  assumes "\<And>n. coeff (p :: 'a :: {comm_ring_1, ring_char_0} poly) n \<in> \<int>"
  obtains p' where "p = of_int_poly p'"
proof -
  from assms have "\<forall>n. \<exists>c. coeff p n = of_int c" by (auto simp: Ints_def)
  hence "\<exists>c. \<forall>n. of_int (c n) = coeff p n" by (simp add: choice_iff eq_commute)
  then obtain c where c: "of_int (c n) = coeff p n" for n by blast
  have [simp]: "coeff (Abs_poly c) = c"
  proof (rule poly.Abs_poly_inverse, clarify)
    have "eventually (\<lambda>n. n > degree p) at_top" by (rule eventually_gt_at_top)
    hence "eventually (\<lambda>n. coeff p n = 0) at_top"
      by eventually_elim (simp add: coeff_eq_0)
    thus "eventually (\<lambda>n. c n = 0) cofinite"
      by (simp add: c [symmetric] cofinite_eq_sequentially)
  qed
  have "p = of_int_poly (Abs_poly c)"
    by (rule poly_eqI) (simp add: c)
  thus ?thesis by (rule that)
qed

subsection \<open>General facts about polynomials\<close>

lemma pderiv_power:
  "pderiv (p ^ n) = smult (of_nat n) (p ^ (n - 1) * pderiv p)"
  by (cases n) (simp_all add: pderiv_power_Suc del: power_Suc)

lemma degree_prod_sum_eq:
  "(\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0) \<Longrightarrow>
     degree (prod f A :: 'a :: idom poly) = (\<Sum>x\<in>A. degree (f x))"
  by (induction A rule: infinite_finite_induct) (auto simp: degree_mult_eq)

lemma pderiv_monom:
  "pderiv (monom c n) = monom (of_nat n * c) (n - 1)"
  by (cases n)
     (simp_all add: monom_altdef pderiv_power_Suc pderiv_smult pderiv_pCons mult_ac del: power_Suc)

lemma power_poly_const [simp]: "[:c:] ^ n = [:c ^ n:]"
  by (induction n) (simp_all add: power_commutes)

lemma monom_power: "monom c n ^ k = monom (c ^ k) (n * k)"
  by (induction k) (simp_all add: mult_monom)

lemma coeff_higher_pderiv:
  "coeff ((pderiv ^^ m) f) n = pochhammer (of_nat (Suc n)) m * coeff f (n + m)"
  by (induction m arbitrary: n) (simp_all add: coeff_pderiv pochhammer_rec algebra_simps)

lemma higher_pderiv_add: "(pderiv ^^ n) (p + q) = (pderiv ^^ n) p + (pderiv ^^ n) q"
  by (induction n arbitrary: p q) (simp_all del: funpow.simps add: funpow_Suc_right pderiv_add)

lemma higher_pderiv_smult: "(pderiv ^^ n) (smult c p) = smult c ((pderiv ^^ n) p)"
  by (induction n arbitrary: p) (simp_all del: funpow.simps add: funpow_Suc_right pderiv_smult)

lemma higher_pderiv_0 [simp]: "(pderiv ^^ n) 0 = 0"
  by (induction n) simp_all

lemma higher_pderiv_monom:
  "m \<le> n + 1 \<Longrightarrow> (pderiv ^^ m) (monom c n) = monom (pochhammer (int n - int m + 1) m * c) (n - m)"
proof (induction m arbitrary: c n)
  case (Suc m)
  thus ?case
    by (cases n)
       (simp_all del: funpow.simps add: funpow_Suc_right pderiv_monom pochhammer_rec' Suc.IH)
qed simp_all

lemma higher_pderiv_monom_eq_zero:
  "m > n + 1 \<Longrightarrow> (pderiv ^^ m) (monom c n) = 0"
proof (induction m arbitrary: c n)
  case (Suc m)
  thus ?case
    by (cases n)
       (simp_all del: funpow.simps add: funpow_Suc_right pderiv_monom pochhammer_rec' Suc.IH)
qed simp_all

lemma higher_pderiv_sum: "(pderiv ^^ n) (sum f A) = (\<Sum>x\<in>A. (pderiv ^^ n) (f x))"
  by (induction A rule: infinite_finite_induct) (simp_all add: higher_pderiv_add)

lemma fact_dvd_higher_pderiv:
  "[:fact n :: int:] dvd (pderiv ^^ n) p"
proof -
  have "[:fact n:] dvd (pderiv ^^ n) (monom c k)" for c :: int and k :: nat
    by (cases "n \<le> k + 1")
       (simp_all add: higher_pderiv_monom higher_pderiv_monom_eq_zero
          fact_dvd_pochhammer const_poly_dvd_iff)
  hence "[:fact n:] dvd (pderiv ^^ n) (\<Sum>k\<le>degree p. monom (coeff p k) k)"
    by (simp_all add: higher_pderiv_sum dvd_sum)
  thus ?thesis by (simp add: poly_as_sum_of_monoms)
qed

lemma fact_dvd_poly_higher_pderiv_aux:
  "(fact n :: int) dvd poly ((pderiv ^^ n) p) x"
proof -
  have "[:fact n:] dvd (pderiv ^^ n) p" by (rule fact_dvd_higher_pderiv)
  then obtain q where "(pderiv ^^ n) p = [:fact n:] * q" by (erule dvdE)
  thus ?thesis by simp
qed

lemma fact_dvd_poly_higher_pderiv_aux':
  "m \<le> n \<Longrightarrow> (fact m :: int) dvd poly ((pderiv ^^ n) p) x"
  by (meson dvd_trans fact_dvd fact_dvd_poly_higher_pderiv_aux)

lemma algebraicE':
  assumes "algebraic (x :: 'a :: field_char_0)"
  obtains p where "p \<noteq> 0" "poly (of_int_poly p) x = 0"
proof -
  from assms obtain q where "\<And>i. coeff q i \<in> \<int>" "q \<noteq> 0" "poly q x = 0"
    by (erule algebraicE)
  moreover from this(1) obtain q' where "q = of_int_poly q'" by (erule int_polyE)
  ultimately show ?thesis by (intro that[of q']) simp_all
qed

lemma algebraicE'_nonzero:
  assumes "algebraic (x :: 'a :: field_char_0)" "x \<noteq> 0"
  obtains p where "p \<noteq> 0" "coeff p 0 \<noteq> 0" "poly (of_int_poly p) x = 0"
proof -
  from assms(1) obtain p where p: "p \<noteq> 0" "poly (of_int_poly p) x = 0"
    by (erule algebraicE')
  define n :: nat where "n = order 0 p"
  have "monom 1 n dvd p" by (simp add: monom_1_dvd_iff p n_def)
  then obtain q where q: "p = monom 1 n * q" by (erule dvdE)
  from p have "q \<noteq> 0" "poly (of_int_poly q) x = 0" by (auto simp: q poly_monom assms(2))
  moreover from this have "order 0 p = n + order 0 q" by (simp add: q order_mult)
  hence "order 0 q = 0" by (simp add: n_def)
  with \<open>q \<noteq> 0\<close> have "poly q 0 \<noteq> 0" by (simp add: order_root)
  ultimately show ?thesis using that[of q] by (auto simp: poly_0_coeff_0)
qed

lemma algebraic_of_real_iff [simp]:
   "algebraic (of_real x :: 'a :: {real_algebra_1,field_char_0}) \<longleftrightarrow> algebraic x"
proof
  assume "algebraic (of_real x :: 'a)"
  then obtain p where "p \<noteq> 0" "poly (of_int_poly p) (of_real x :: 'a) = 0"
    by (erule algebraicE')
  hence "(of_int_poly p :: real poly) \<noteq> 0"
        "poly (of_int_poly p :: real poly) x = 0" by simp_all
  thus "algebraic x" by (intro algebraicI[of "of_int_poly p"]) simp_all
next
  assume "algebraic x"
  then obtain p where "p \<noteq> 0" "poly (of_int_poly p) x = 0" by (erule algebraicE')
  hence "of_int_poly p \<noteq> (0 :: 'a poly)" "poly (of_int_poly p) (of_real x :: 'a) = 0"
    by simp_all
  thus "algebraic (of_real x)" by (intro algebraicI[of "of_int_poly p"]) simp_all
qed

subsection \<open>Main proof\<close>

lemma lindemann_weierstrass_integral:
  fixes u :: complex and f :: "complex poly"
  defines "df \<equiv> \<lambda>n. (pderiv ^^ n) f"
  defines "m \<equiv> degree f"
  defines "I \<equiv> \<lambda>f u. exp u * (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) 0) -
                       (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) u)"
  shows "((\<lambda>t. exp (u - t) * poly f t) has_contour_integral I f u) (linepath 0 u)"
proof -
  note [derivative_intros] =
    exp_scaleR_has_vector_derivative_right vector_diff_chain_within
  let ?g = "\<lambda>t. 1 - t" and ?f = "\<lambda>t. -exp (t *\<^sub>R u)"
  have "((\<lambda>t. exp ((1 - t) *\<^sub>R u) * u) has_integral
          (?f \<circ> ?g) 1 - (?f \<circ> ?g) 0) {0..1}"
    by (rule fundamental_theorem_of_calculus)
       (auto intro!: derivative_eq_intros simp del: o_apply)
  hence aux_integral: "((\<lambda>t. exp (u - t *\<^sub>R u) * u) has_integral exp u - 1) {0..1}"
    by (simp add: algebra_simps)

  have "((\<lambda>t. exp (u - t *\<^sub>R u) * u * poly f (t *\<^sub>R u)) has_integral I f u) {0..1}"
    unfolding df_def m_def
  proof (induction "degree f" arbitrary: f)
    case 0
    then obtain c where c: "f = [:c:]" by (auto elim: degree_eq_zeroE)
    have "((\<lambda>t. c * (exp (u - t *\<^sub>R u) * u)) has_integral c * (exp u - 1)) {0..1}"
      using aux_integral by (rule has_integral_mult_right)
    with c show ?case by (simp add: algebra_simps I_def)
  next
    case (Suc m)
    define df where "df = (\<lambda>j. (pderiv ^^ j) f)"
    show ?case
    proof (rule integration_by_parts[OF bounded_bilinear_mult])
      fix t :: real assume "t \<in> {0..1}"
      have "((?f \<circ> ?g) has_vector_derivative exp (u - t *\<^sub>R u) * u) (at t)"
        by (auto intro!: derivative_eq_intros simp: algebra_simps simp del: o_apply)
      thus "((\<lambda>t. -exp (u - t *\<^sub>R u)) has_vector_derivative exp (u - t *\<^sub>R u) * u) (at t)"
        by (simp add: algebra_simps o_def)
    next
      fix t :: real assume "t \<in> {0..1}"
      have "(poly f \<circ> (\<lambda>t. t *\<^sub>R u) has_vector_derivative u * poly (pderiv f) (t *\<^sub>R u)) (at t)"
        by (rule field_vector_diff_chain_at) (auto intro!: derivative_eq_intros)
      thus "((\<lambda>t. poly f (t *\<^sub>R u)) has_vector_derivative u * poly (pderiv f) (t *\<^sub>R u)) (at t)"
        by (simp add: o_def)
    next
      from Suc(2) have m: "m = degree (pderiv f)" by (simp add: degree_pderiv)
      from Suc(1)[OF this] this
        have "((\<lambda>t. exp (u - t *\<^sub>R u) * u * poly (pderiv f) (t *\<^sub>R u)) has_integral
                exp u * (\<Sum>j=0..m. poly (df (Suc j)) 0) - (\<Sum>j=0..m. poly (df (Suc j)) u)) {0..1}"
        by (simp add: df_def funpow_swap1 atMost_atLeast0 I_def)
      also have "(\<Sum>j=0..m. poly (df (Suc j)) 0) = (\<Sum>j=Suc 0..Suc m. poly (df j) 0)"
        by (rule sum.shift_bounds_cl_Suc_ivl [symmetric])
      also have "\<dots> = (\<Sum>j=0..Suc m. poly (df j) 0) - poly f 0"
        by (subst (2) sum.atLeast_Suc_atMost) (simp_all add: df_def)
      also have "(\<Sum>j=0..m. poly (df (Suc j)) u) = (\<Sum>j=Suc 0..Suc m. poly (df j) u)"
        by (rule sum.shift_bounds_cl_Suc_ivl [symmetric])
      also have "\<dots> = (\<Sum>j=0..Suc m. poly (df j) u) - poly f u"
        by (subst (2) sum.atLeast_Suc_atMost) (simp_all add: df_def)
      finally have "((\<lambda>t. - (exp (u - t *\<^sub>R u) * u * poly (pderiv f) (t *\<^sub>R u))) has_integral
                        -(exp u * ((\<Sum>j = 0..Suc m. poly (df j) 0) - poly f 0) -
                                  ((\<Sum>j = 0..Suc m. poly (df j) u) - poly f u))) {0..1}"
          (is "(_ has_integral ?I) _") by (rule has_integral_neg)
      also have "?I = - exp (u - 1 *\<^sub>R u) * poly f (1 *\<^sub>R u) -
                       - exp (u - 0 *\<^sub>R u) * poly f (0 *\<^sub>R u) - I f u"
        by (simp add: df_def algebra_simps Suc(2) atMost_atLeast0 I_def)
      finally show "((\<lambda>t. - exp (u - t *\<^sub>R u) * (u * poly (pderiv f) (t *\<^sub>R u)))
                        has_integral \<dots>) {0..1}" by (simp add: algebra_simps)
    qed (auto intro!: continuous_intros)
  qed
  thus ?thesis by (simp add: has_contour_integral_linepath algebra_simps)
qed

locale lindemann_weierstrass_aux =
  fixes f :: "complex poly"
begin

definition I :: "complex \<Rightarrow> complex" where
  "I u = exp u * (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) 0) -
                       (\<Sum>j\<le>degree f. poly ((pderiv ^^ j) f) u)"

lemma lindemann_weierstrass_integral_bound:
  fixes u :: complex
  assumes "C \<ge> 0" "\<And>t. t \<in> closed_segment 0 u \<Longrightarrow> norm (poly f t) \<le> C"
  shows "norm (I u) \<le> norm u * exp (norm u) * C"
proof -
  have "I u = contour_integral (linepath 0 u) (\<lambda>t. exp (u - t) * poly f t)"
    using contour_integral_unique[OF lindemann_weierstrass_integral[of u f]] unfolding I_def ..
  also have "norm \<dots> \<le> exp (norm u) * C * norm (u - 0)"
  proof (intro contour_integral_bound_linepath)
    fix t assume t: "t \<in> closed_segment 0 u"
    then obtain s where s: "s \<in> {0..1}" "t = s *\<^sub>R u" by (auto simp: closed_segment_def)
    hence "s * norm u \<le> 1 * norm u" by (intro mult_right_mono) simp_all
    with s have norm_t: "norm t \<le> norm u" by auto

    from s have "Re u - Re t = (1 - s) * Re u" by (simp add: algebra_simps)
    also have "\<dots> \<le> norm u"
    proof (cases "Re u \<ge> 0")
      case True
      with \<open>s \<in> {0..1}\<close> have "(1 - s) * Re u \<le> 1 * Re u" by (intro mult_right_mono) simp_all
      also have "Re u \<le> norm u" by (rule complex_Re_le_cmod)
      finally show ?thesis by simp
    next
      case False
      with \<open>s \<in> {0..1}\<close> have "(1 - s) * Re u \<le> 0" by (intro mult_nonneg_nonpos) simp_all
      also have "\<dots> \<le> norm u" by simp
      finally show ?thesis .
    qed
    finally have "exp (Re u - Re t) \<le> exp (norm u)" by simp

    hence "exp (Re u - Re t) * norm (poly f t) \<le> exp (norm u) * C"
      using assms t norm_t by (intro mult_mono) simp_all
    thus "norm (exp (u - t) * poly f t) \<le> exp (norm u) * C"
      by (simp add: norm_mult exp_diff norm_divide field_simps)
  qed (auto simp: intro!: mult_nonneg_nonneg contour_integrable_continuous_linepath
                          continuous_intros assms)
  finally show ?thesis by (simp add: mult_ac)
qed

end

lemma poly_higher_pderiv_aux1:
  fixes c :: "'a :: idom"
  assumes "k < n"
  shows   "poly ((pderiv ^^ k) ([:-c, 1:] ^ n * p)) c = 0"
  using assms
proof (induction k arbitrary: n p)
  case (Suc k n p)
  from Suc.prems obtain n' where n: "n = Suc n'" by (cases n) auto
  from Suc.prems n have "k < n'" by simp
  have "(pderiv ^^ Suc k) ([:- c, 1:] ^ n * p) =
          (pderiv ^^ k) ([:- c, 1:] ^ n * pderiv p + [:- c, 1:] ^ n' * smult (of_nat n) p)"
    by (simp only: funpow_Suc_right o_def pderiv_mult n pderiv_power_Suc,
        simp only: n [symmetric]) (simp add: pderiv_pCons mult_ac)
  also from Suc.prems \<open>k < n'\<close> have "poly \<dots> c = 0"
    by (simp add: higher_pderiv_add Suc.IH del: mult_smult_right)
  finally show ?case .
qed simp_all

lemma poly_higher_pderiv_aux1':
  fixes c :: "'a :: idom"
  assumes "k < n" "[:-c, 1:] ^ n dvd p"
  shows   "poly ((pderiv ^^ k) p) c = 0"
proof -
  from assms(2) obtain q where "p = [:-c, 1:] ^ n * q" by (elim dvdE)
  also from assms(1) have "poly ((pderiv ^^ k) \<dots>) c = 0"
    by (rule poly_higher_pderiv_aux1)
  finally show ?thesis .
qed

lemma poly_higher_pderiv_aux2:
  fixes c :: "'a :: {idom, semiring_char_0}"
  shows   "poly ((pderiv ^^ n) ([:-c, 1:] ^ n * p)) c = fact n * poly p c"
proof (induction n arbitrary: p)
  case (Suc n p)
  have "(pderiv ^^ Suc n) ([:- c, 1:] ^ Suc n * p) =
          (pderiv ^^ n) ([:- c, 1:] ^ Suc n * pderiv p) +
            (pderiv ^^ n) ([:- c, 1:] ^ n * smult (1 + of_nat n) p)"
    by (simp del: funpow.simps power_Suc add: funpow_Suc_right pderiv_mult
          pderiv_power_Suc higher_pderiv_add pderiv_pCons mult_ac)
  also have "[:- c, 1:] ^ Suc n * pderiv p = [:- c, 1:] ^ n * ([:-c, 1:] * pderiv p)"
    by (simp add: algebra_simps)
  finally show ?case by (simp add: Suc.IH del: mult_smult_right power_Suc)
qed simp_all

lemma poly_higher_pderiv_aux3:
  fixes c :: "'a :: {idom,semiring_char_0}"
  assumes "k \<ge> n"
  shows   "\<exists>q. poly ((pderiv ^^ k) ([:-c, 1:] ^ n * p)) c = fact n * poly q c"
  using assms
proof (induction k arbitrary: n p)
  case (Suc k n p)
  show ?case
  proof (cases n)
    fix n' assume n: "n = Suc n'"
    have "poly ((pderiv ^^ Suc k) ([:-c, 1:] ^ n * p)) c =
            poly ((pderiv ^^ k) ([:- c, 1:] ^ n * pderiv p)) c +
              of_nat n * poly ((pderiv ^^ k) ([:-c, 1:] ^ n' * p)) c"
      by (simp del: funpow.simps power_Suc add: funpow_Suc_right pderiv_power_Suc
            pderiv_mult n pderiv_pCons higher_pderiv_add mult_ac higher_pderiv_smult)
    also have "\<exists>q1. poly ((pderiv ^^ k) ([:-c, 1:] ^ n * pderiv p)) c = fact n * poly q1 c"
      using Suc.prems Suc.IH[of n "pderiv p"]
      by (cases "n' = k") (auto simp: n poly_higher_pderiv_aux1 simp del: power_Suc of_nat_Suc
                                intro: exI[of _ "0::'a poly"])
    then obtain q1
      where "poly ((pderiv ^^ k) ([:-c, 1:] ^ n * pderiv p)) c = fact n * poly q1 c" ..
    also from Suc.IH[of n' p] Suc.prems obtain q2
      where "poly ((pderiv ^^ k) ([:-c, 1:] ^ n' * p)) c = fact n' * poly q2 c"
      by (auto simp: n)
    finally show ?case by (auto intro!: exI[of _ "q1 + q2"] simp: n algebra_simps)
  qed auto
qed auto

lemma poly_higher_pderiv_aux3':
  fixes c :: "'a :: {idom, semiring_char_0}"
  assumes "k \<ge> n" "[:-c, 1:] ^ n dvd p"
  shows   "fact n dvd poly ((pderiv ^^ k) p) c"
proof -
  from assms(2) obtain q where "p = [:-c, 1:] ^ n * q" by (elim dvdE)
  with poly_higher_pderiv_aux3[OF assms(1), of c q] show ?thesis by auto
qed

lemma e_transcendental_aux_bound:
  obtains C where "C \<ge> 0"
    "\<And>x. x \<in> closed_segment 0 (of_nat n) \<Longrightarrow>
        norm (\<Prod>k\<in>{1..n}. (x - of_nat k :: complex)) \<le> C"
proof -
  let ?f = "\<lambda>x. (\<Prod>k\<in>{1..n}. (x - of_nat k))"
  define C where "C = max 0 (Sup (cmod ` ?f ` closed_segment 0 (of_nat n)))"
  have "C \<ge> 0" by (simp add: C_def)
  moreover {
    fix x :: complex assume "x \<in> closed_segment 0 (of_nat n)"
    hence "cmod (?f x) \<le> Sup ((cmod \<circ> ?f) ` closed_segment 0 (of_nat n))"
      by (intro cSup_upper bounded_imp_bdd_above compact_imp_bounded compact_continuous_image)
         (auto intro!: continuous_intros)
    also have "\<dots> \<le> C" by (simp add: C_def image_comp)
    finally have "cmod (?f x) \<le> C" .
  }
  ultimately show ?thesis by (rule that)
qed

theorem e_transcendental_complex: "\<not> algebraic (exp 1 :: complex)"
proof
  assume "algebraic (exp 1 :: complex)"
  then obtain q :: "int poly"
    where q: "q \<noteq> 0" "coeff q 0 \<noteq> 0" "poly (of_int_poly q) (exp 1 :: complex) = 0"
      by (elim algebraicE'_nonzero) simp_all

  define n :: nat where "n = degree q"
  from q have [simp]: "n \<noteq> 0" by (intro notI) (auto simp: n_def elim!: degree_eq_zeroE)
  define qmax where "qmax = Max (insert 0 (abs ` set (coeffs q)))"
  have qmax_nonneg [simp]: "qmax \<ge> 0" by (simp add: qmax_def)
  have qmax: "\<bar>coeff q k\<bar> \<le> qmax" for k
    by (cases "k \<le> degree q")
       (auto simp: qmax_def coeff_eq_0 coeffs_def simp del: upt_Suc intro: Max.coboundedI)
  obtain C where C: "C \<ge> 0"
    "\<And>x. x \<in> closed_segment 0 (of_nat n) \<Longrightarrow> norm (\<Prod>k\<in>{1..n}. (x - of_nat k :: complex)) \<le> C"
    by (erule e_transcendental_aux_bound)
  define E where "E = (1 + real n) * real_of_int qmax * real n * exp (real n) / real n"
  define F where "F = real n * C"

  have ineq: "fact (p - 1) \<le> E * F ^ p" if p: "prime p" "p > n" "p > abs (coeff q 0)" for p
  proof -
    from p(1) have p_pos: "p > 0" by (simp add: prime_gt_0_nat)
    define f :: "int poly"
      where "f = monom 1 (p - 1) * (\<Prod>k\<in>{1..n}. [:-of_nat k, 1:] ^ p)"
    have poly_f: "poly (of_int_poly f) x = x ^ (p - 1) * (\<Prod>k\<in>{1..n}. (x - of_nat k)) ^ p"
      for x :: complex by (simp add: f_def poly_prod poly_monom prod_power_distrib)
    define m :: nat where "m = degree f"
    from p_pos have m: "m = (n + 1) * p - 1"
      by (simp add: m_def f_def degree_mult_eq degree_monom_eq degree_prod_sum_eq degree_linear_power)

    define M :: int where "M = (- 1) ^ (n * p) * fact n ^ p"
    with p have p_not_dvd_M: "\<not>int p dvd M"
      by (auto simp: M_def prime_elem_int_not_dvd_neg1_power prime_dvd_power_iff
            prime_gt_0_nat prime_dvd_fact_iff_int prime_dvd_mult_iff)

    interpret lindemann_weierstrass_aux "of_int_poly f" .
    define J :: complex where "J = (\<Sum>k\<le>n. of_int (coeff q k) * I (of_nat k))"
    define idxs where "idxs = ({..n}\<times>{..m}) - {(0, p - 1)}"

    hence "J = (\<Sum>k\<le>n. of_int (coeff q k) * exp 1 ^ k) * (\<Sum>n\<le>m. of_int (poly ((pderiv ^^ n) f) 0)) -
                 of_int (\<Sum>k\<le>n. \<Sum>n\<le>m. coeff q k * poly ((pderiv ^^ n) f) (int k))"
      by (simp add: J_def I_def algebra_simps sum_subtractf sum_distrib_left m_def
                    exp_of_nat_mult [symmetric])
    also have "(\<Sum>k\<le>n. of_int (coeff q k) * exp 1 ^ k) = poly (of_int_poly q) (exp 1 :: complex)"
      by (simp add: poly_altdef n_def)
    also have "\<dots> = 0" by fact
    finally have "J = of_int (-(\<Sum>(k,n)\<in>{..n}\<times>{..m}. coeff q k * poly ((pderiv ^^ n) f) (int k)))"
      by (simp add: sum.cartesian_product)
    also have "{..n}\<times>{..m} = insert (0, p - 1) idxs" by (auto simp: m idxs_def)
    also have "-(\<Sum>(k,n)\<in>\<dots>. coeff q k * poly ((pderiv ^^ n) f) (int k)) =
       - (coeff q 0 * poly ((pderiv ^^ (p - 1)) f) 0) -
         (\<Sum>(k, n)\<in>idxs. coeff q k * poly ((pderiv ^^ n) f) (of_nat k))"
      by (subst sum.insert) (simp_all add: idxs_def)
    also have "coeff q 0 * poly ((pderiv ^^ (p - 1)) f) 0 = coeff q 0 * M * fact (p - 1)"
    proof -
      have "f = [:-0, 1:] ^ (p - 1) * (\<Prod>k = 1..n. [:- of_nat k, 1:] ^ p)"
        by (simp add: f_def monom_altdef)
      also have "poly ((pderiv ^^ (p - 1)) \<dots>) 0 =
                   fact (p - 1) * poly (\<Prod>k = 1..n. [:- of_nat k, 1:] ^ p) 0"
        by (rule poly_higher_pderiv_aux2)
      also have "poly (\<Prod>k = 1..n. [:- of_nat k :: int, 1:] ^ p) 0 = (-1)^(n*p) * fact n ^ p"
        by (induction n) (simp_all add: prod.nat_ivl_Suc' power_mult_distrib mult_ac
                            power_minus' power_add del: of_nat_Suc)
      finally show ?thesis by (simp add: mult_ac M_def)
    qed
    also obtain N where "(\<Sum>(k, n)\<in>idxs. coeff q k * poly ((pderiv ^^ n) f) (int k)) = fact p * N"
    proof -
      have "\<forall>(k, n)\<in>idxs. fact p dvd poly ((pderiv ^^ n) f) (of_nat k)"
      proof clarify
        fix k j assume idxs: "(k, j) \<in> idxs"
        then consider "k = 0" "j < p - 1" | "k = 0" "j > p - 1" | "k \<noteq> 0" "j < p" | "k \<noteq> 0" "j \<ge> p"
          by (fastforce simp: idxs_def)
        thus "fact p dvd poly ((pderiv ^^ j) f) (of_nat k)"
        proof cases
          case 1
          thus ?thesis
            by (simp add: f_def poly_higher_pderiv_aux1' monom_altdef)
        next
          case 2
          thus ?thesis
            by (simp add: f_def poly_higher_pderiv_aux3' monom_altdef fact_dvd_poly_higher_pderiv_aux')
        next
          case 3
          thus ?thesis unfolding f_def
            by (subst poly_higher_pderiv_aux1'[of _ p])
               (insert idxs, auto simp: idxs_def intro!: dvd_mult)
        next
          case 4
          thus ?thesis unfolding f_def
            by (intro poly_higher_pderiv_aux3') (insert idxs, auto intro!: dvd_mult simp: idxs_def)
        qed
      qed
      hence "fact p dvd (\<Sum>(k, n)\<in>idxs. coeff q k * poly ((pderiv ^^ n) f) (int k))"
        by (auto intro!: dvd_sum dvd_mult simp del: of_int_fact)
      with that show thesis
        by blast
    qed
    also from p have "- (coeff q 0 * M * fact (p - 1)) - fact p * N =
                        - fact (p - 1) * (coeff q 0 * M + p * N)"
      by (subst fact_reduce[of p]) (simp_all add: algebra_simps)
    finally have J: "J = -of_int (fact (p - 1) * (coeff q 0 * M + p * N))" by simp

    from p q(2) have "\<not>p dvd coeff q 0 * M + p * N"
      by (auto simp: dvd_add_left_iff p_not_dvd_M prime_dvd_fact_iff_int prime_dvd_mult_iff
               dest: dvd_imp_le_int)
    hence "coeff q 0 * M + p * N \<noteq> 0" by (intro notI) simp_all
    hence "abs (coeff q 0 * M + p * N) \<ge> 1" by simp
    hence "norm (of_int (coeff q 0 * M + p * N) :: complex) \<ge> 1" by (simp only: norm_of_int)
    hence "fact (p - 1) * \<dots> \<ge> fact (p - 1) * 1" by (intro mult_left_mono) simp_all
    hence J_lower: "norm J \<ge> fact (p - 1)" unfolding J norm_minus_cancel of_int_mult of_int_fact
      by (simp add: norm_mult)

    have "norm J \<le> (\<Sum>k\<le>n. norm (of_int (coeff q k) * I (of_nat k)))"
      unfolding J_def by (rule norm_sum)
    also have "\<dots> \<le> (\<Sum>k\<le>n. of_int qmax * (real n * exp (real n) * real n ^ (p - 1) * C ^ p))"
    proof (intro sum_mono)
      fix k assume k: "k \<in> {..n}"
      have "n > 0" by (rule ccontr) simp
      {
        fix x :: complex assume x: "x \<in> closed_segment 0 (of_nat k)"
        then obtain t where t: "t \<ge> 0" "t \<le> 1" "x = of_real t * of_nat k"
          by (auto simp: closed_segment_def scaleR_conv_of_real)
        hence "norm x = t * real k" by (simp add: norm_mult)
        also from \<open>t \<le> 1\<close> k have *: "\<dots> \<le> 1 * real n" by (intro mult_mono) simp_all
        finally have x': "norm x \<le> real n" by simp
        from t \<open>n > 0\<close> * have x'': "x \<in> closed_segment 0 (of_nat n)"
          by (auto simp: closed_segment_def scaleR_conv_of_real field_simps
                   intro!: exI[of _ "t * real k / real n"] )
        have "norm (poly (of_int_poly f) x) =
                norm x ^ (p - 1) * cmod (\<Prod>i = 1..n. x - i) ^ p"
          by (simp add: poly_f norm_mult norm_power)
        also from x x' x'' have "\<dots> \<le> of_nat n ^ (p - 1) * C ^ p"
          by (intro mult_mono C power_mono) simp_all
        finally have "norm (poly (of_int_poly f) x) \<le> real n ^ (p - 1) * C ^ p" .
      } note A = this

      have "norm (I (of_nat k)) \<le>
                      cmod (of_nat k) * exp (cmod (of_nat k)) * (of_nat n ^ (p - 1) * C ^ p)"
        by (intro lindemann_weierstrass_integral_bound[OF _ A]
              C mult_nonneg_nonneg zero_le_power) auto
      also have "\<dots> \<le> cmod (of_nat n) * exp (cmod (of_nat n)) * (of_nat n ^ (p - 1) * C ^ p)"
        using k by (intro mult_mono zero_le_power mult_nonneg_nonneg C) simp_all
      finally show "cmod (of_int (coeff q k) * I (of_nat k)) \<le>
                      of_int qmax * (real n * exp (real n) * real n ^ (p - 1) * C ^ p)"
        unfolding norm_mult
        by (intro mult_mono) (simp_all add: qmax of_int_abs [symmetric] del: of_int_abs)
    qed
    also have "\<dots> = E * F ^ p" using p_pos
      by (simp add: power_diff power_mult_distrib E_def F_def)
    finally show "fact (p - 1) \<le> E * F ^ p" using J_lower by linarith
  qed

  have "(\<lambda>n. E * F * F ^ (n - 1) / fact (n - 1)) \<longlonglongrightarrow> 0" (is ?P)
    by (intro filterlim_compose[OF power_over_fact_tendsto_0' filterlim_minus_const_nat_at_top])
  also have "?P \<longleftrightarrow> (\<lambda>n. E * F ^ n / fact (n - 1)) \<longlonglongrightarrow> 0"
    by (intro filterlim_cong refl eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
       (auto simp: power_Suc [symmetric] simp del: power_Suc)
  finally have "eventually (\<lambda>n. E * F ^ n / fact (n - 1) < 1) at_top"
    by (rule order_tendstoD) simp_all
  hence "eventually (\<lambda>n. E * F ^ n < fact (n - 1)) at_top" by eventually_elim simp
  then obtain P where P: "\<And>n. n \<ge> P \<Longrightarrow> E * F ^ n < fact (n - 1)"
    by (auto simp: eventually_at_top_linorder)

  have "\<exists>p. prime p \<and> p > Max {nat (abs (coeff q 0)), n, P}" by (rule bigger_prime)
  then obtain p where "prime p" "p > Max {nat (abs (coeff q 0)), n, P}" by blast
  hence "int p > abs (coeff q 0)" "p > n" "p \<ge> P" by auto
  with ineq[of p] \<open>prime p\<close> have "fact (p - 1) \<le> E * F ^ p" by simp
  moreover from \<open>p \<ge> P\<close> have "fact (p - 1) > E * F ^ p" by (rule P)
  ultimately show False by linarith
qed

corollary e_transcendental_real: "\<not> algebraic (exp 1 :: real)"
proof -
  have "\<not>algebraic (exp 1 :: complex)" by (rule e_transcendental_complex)
  also have "(exp 1 :: complex) = of_real (exp 1)" using exp_of_real[of 1] by simp
  also have "algebraic \<dots> \<longleftrightarrow> algebraic (exp 1 :: real)" by simp
  finally show ?thesis .
qed

end


(*
    Title:      Gauss_Jordan_PA.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Obtaining explicitly the invertible matrix which transforms a matrix to its reduced row echelon form*}

theory Gauss_Jordan_PA
imports
 Gauss_Jordan
 "../Rank_Nullity_Theorem/Miscellaneous"
 Linear_Maps (*Really, this file is not necessary, but it contains interesting properties about linear maps.*)
begin

subsection{*Definitions*}

text{*The following algorithm is similar to @{term "Gauss_Jordan"},
but in this case we will also return the P matrix which makes @{term "Gauss_Jordan A = P ** A"}. If A is invertible, this matrix P will be the inverse of it.*}

definition Gauss_Jordan_in_ij_PA :: "(('a::{semiring_1, inverse, one, uminus}^'rows::{finite, ord}^'rows::{finite, ord}) \<times> ('a^'cols^'rows::{finite, ord})) => 'rows=>'cols
  =>(('a^'rows::{finite, ord}^'rows::{finite, ord}) \<times> ('a^'cols^'rows::{finite, ord}))"
where "Gauss_Jordan_in_ij_PA A' i j = (let P=fst A'; A=snd A';
                                        n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n);
                                        interchange_A = (interchange_rows A i n);
                                        interchange_P = (interchange_rows P i n);
                                        P' = mult_row interchange_P i (1/interchange_A$i$j)
                                        in
                                       (vec_lambda(% s. if s=i then P' $ s else (row_add P' s i (-(interchange_A$s$j))) $ s), Gauss_Jordan_in_ij A i j))"

definition Gauss_Jordan_column_k_PA
where "Gauss_Jordan_column_k_PA A' k =
    (let P = fst A';
         i = fst (snd A');
         A = snd (snd A');
         from_nat_i=from_nat i;
         from_nat_k=from_nat k
         in
         if (\<forall>m\<ge>from_nat_i. A $ m $ from_nat_k = 0) \<or> i = nrows A then (P, i, A)
         else (let Gauss = Gauss_Jordan_in_ij_PA (P,A) (from_nat_i) (from_nat_k) in (fst Gauss, i + 1, snd Gauss)))"

definition "Gauss_Jordan_upt_k_PA A k = (let foldl=(foldl Gauss_Jordan_column_k_PA (mat 1,0, A) [0..<Suc k]) in (fst foldl, snd (snd foldl)))"
definition "Gauss_Jordan_PA A = Gauss_Jordan_upt_k_PA A (ncols A - 1)"

subsection{*Proofs*}

subsubsection{*Properties about @{term "Gauss_Jordan_in_ij_PA"}*}

text{*The following lemmas are very important in order to improve the efficience of the code*}
text{*We define the following function to obtain an efficient code for @{term "Gauss_Jordan_in_ij_PA A i j"}.*}

definition "Gauss_Jordan_wrapper i j A B = vec_lambda(%s. if s=i then A $ s else (row_add A s i (-(B$s$j))) $ s)"

lemma Gauss_Jordan_wrapper_code[code abstract]:
  "vec_nth (Gauss_Jordan_wrapper i j A B) = (%s. if s=i then A $ s else (row_add A s i (-(B$s$j))) $ s)"
  unfolding Gauss_Jordan_wrapper_def by force

lemma Gauss_Jordan_in_ij_PA_def'[code]:
   "Gauss_Jordan_in_ij_PA A' i j = (let P=fst A'; A=snd A';
                                        n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n);
                                        interchange_A = (interchange_rows A i n);
                                        A' = mult_row interchange_A i (1/interchange_A$i$j);
                                        interchange_P = (interchange_rows P i n);
                                        P' = mult_row interchange_P i (1/interchange_A$i$j)
                                        in
                                       (Gauss_Jordan_wrapper i j P' interchange_A,
                                        Gauss_Jordan_wrapper i j A' interchange_A))"
unfolding Gauss_Jordan_in_ij_PA_def Gauss_Jordan_in_ij_def Let_def Gauss_Jordan_wrapper_def by auto

text{*The second component is equal to @{term "Gauss_Jordan_in_ij"}*}
lemma snd_Gauss_Jordan_in_ij_PA_eq[code_unfold]: "snd (Gauss_Jordan_in_ij_PA (P,A) i j) = Gauss_Jordan_in_ij A i j"
  unfolding Gauss_Jordan_in_ij_PA_def Let_def snd_conv ..

lemma fst_Gauss_Jordan_in_ij_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes PB_A: "P ** B = A"
shows "fst (Gauss_Jordan_in_ij_PA (P,A) i j) ** B = snd (Gauss_Jordan_in_ij_PA (P,A) i j)"
proof (unfold Gauss_Jordan_in_ij_PA_def' Gauss_Jordan_wrapper_def Let_def fst_conv snd_conv, subst (1 2 3 4 5 6 7 8 9 10) interchange_rows_mat_1[symmetric], subst vec_eq_iff, auto)
show "((\<chi> s. if s = i then mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $ s
              else row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s i
              (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ i =
              mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $ i"
proof (unfold matrix_matrix_mult_def, vector, auto)
fix ia
have "mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)
** B = mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)"
by(subst (5) PB_A[symmetric], subst (1 2) mult_row_mat_1[symmetric], unfold matrix_mul_assoc, rule refl)
thus "(\<Sum>k\<in>UNIV. mult_row (\<chi> ia ja. \<Sum>k\<in>UNIV. interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ k * P $ k $ ja) i
                     (1 / (\<Sum>k\<in>UNIV. mat 1 $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ k * A $ k $ j)) $ i $ k * B $ k $ ia) =
                     mult_row (\<chi> ia ja. \<Sum>k\<in>UNIV. interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ k * A $ k $ ja) i
                     (1 / (\<Sum>k\<in>UNIV. mat 1 $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ k * A $ k $ j)) $ i $ ia"
unfolding matrix_matrix_mult_def
unfolding vec_lambda_beta unfolding interchange_rows_i using setsum.cong
by (metis (lifting, no_types) vec_lambda_beta)
qed
next
fix ia assume ia_not_i: "ia \<noteq> i"
have "((\<chi> s. if s = i then mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $
             s else row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s
             i (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ ia =
((\<chi> s. row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s
             i (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ ia"
unfolding row_matrix_matrix_mult[symmetric]
using ia_not_i by auto
also have "... = row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) ia i
     (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ ia $ j) $ ia v* B"
     by (subst (3) row_matrix_matrix_mult[symmetric], simp)
also have "... = row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) ia i
             (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ ia $ j) $ ia"
apply (subst (7) PB_A[symmetric])
apply (subst (1 2) mult_row_mat_1[symmetric])
apply (subst (1 2) row_add_mat_1[symmetric])
unfolding matrix_mul_assoc
unfolding row_matrix_matrix_mult ..
finally show "((\<chi> s. if s = i then mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j) $ s
        else row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) s i
              (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ s $ j) $ s) ** B) $ ia =
  row_add (mult_row (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) i (1 / (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ i $ j)) ia i
   (- (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** A) $ ia $ j) $ ia" .
qed

subsubsection{*Properties about @{term "Gauss_Jordan_column_k_PA"}*}
lemma fst_Gauss_Jordan_column_k:
assumes "i\<le>nrows A"
shows "fst (Gauss_Jordan_column_k (i, A) k) \<le> nrows A"
using assms unfolding Gauss_Jordan_column_k_def Let_def by auto

lemma fst_Gauss_Jordan_column_k_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes PB_A: "P ** B = A"
shows "fst (Gauss_Jordan_column_k_PA (P,i,A) k) ** B = snd (snd (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_PA_def unfolding Let_def
unfolding fst_conv snd_conv by (auto intro: assms fst_Gauss_Jordan_in_ij_PA)

lemma snd_snd_Gauss_Jordan_column_k_PA_eq:
shows "snd (snd (Gauss_Jordan_column_k_PA (P,i,A) k)) = snd (Gauss_Jordan_column_k (i,A) k)"
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_def unfolding Let_def snd_conv fst_conv unfolding snd_Gauss_Jordan_in_ij_PA_eq by auto

lemma fst_snd_Gauss_Jordan_column_k_PA_eq:
shows "fst (snd (Gauss_Jordan_column_k_PA (P,i,A) k)) = fst (Gauss_Jordan_column_k (i,A) k)"
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_def unfolding Let_def snd_conv fst_conv by auto

subsubsection{*Properties about @{term "Gauss_Jordan_upt_k_PA"}*}

lemma fst_Gauss_Jordan_upt_k_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "fst (Gauss_Jordan_upt_k_PA A k) ** A = snd (Gauss_Jordan_upt_k_PA A k)"
proof (induct k)
show "fst (Gauss_Jordan_upt_k_PA A 0) ** A = snd (Gauss_Jordan_upt_k_PA A 0)" unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv
apply auto unfolding snd_snd_Gauss_Jordan_column_k_PA_eq by (metis fst_Gauss_Jordan_column_k_PA matrix_mul_lid snd_snd_Gauss_Jordan_column_k_PA_eq)
next
case (Suc k)
have suc_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
show ?case
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv
unfolding suc_rw unfolding foldl_append unfolding List.foldl.simps using Suc.hyps[unfolded Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv]
by (metis fst_Gauss_Jordan_column_k_PA pair_collapse)
qed

lemma snd_foldl_Gauss_Jordan_column_k_eq:
"snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<k]) = foldl Gauss_Jordan_column_k (0, A) [0..<k]"
proof (induct k)
case 0
show ?case by simp
case (Suc k)
have suc_rw: "[0..<Suc k] = [0..<k] @ [k]" by simp
show ?case
unfolding suc_rw foldl_append unfolding List.foldl.simps by (metis Suc.hyps fst_snd_Gauss_Jordan_column_k_PA_eq snd_snd_Gauss_Jordan_column_k_PA_eq surjective_pairing)
qed

lemma snd_Gauss_Jordan_upt_k_PA:
shows "snd (Gauss_Jordan_upt_k_PA A k) = (Gauss_Jordan_upt_k A k)"
unfolding Gauss_Jordan_upt_k_PA_def Gauss_Jordan_upt_k_def Let_def
using snd_foldl_Gauss_Jordan_column_k_eq[of A "Suc k"] by simp

subsubsection{*Properties about @{term "Gauss_Jordan_PA"}*}

lemma fst_Gauss_Jordan_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "fst (Gauss_Jordan_PA A) ** A = snd (Gauss_Jordan_PA A)"
unfolding Gauss_Jordan_PA_def using fst_Gauss_Jordan_upt_k_PA by simp

lemma Gauss_Jordan_PA_eq:
shows "snd (Gauss_Jordan_PA A)= (Gauss_Jordan A)"
by (metis Gauss_Jordan_PA_def Gauss_Jordan_def snd_Gauss_Jordan_upt_k_PA)

subsubsection{*Proving that the transformation has been carried out by means of elementary operations*}
text{*This function is very similar to @{term "row_add_iterate"} one. It allows us to prove that @{term "fst (Gauss_Jordan_PA A)"} is an invertible matrix.
Concretly, it has been defined to demonstrate that @{term "fst (Gauss_Jordan_PA A)"} has been obtained by means of elementary operations applied to the identity matrix*}

fun row_add_iterate_PA :: "(('a::{semiring_1, uminus}^'m::{mod_type} ^'m::{mod_type}) \<times> ('a^'n^'m::{mod_type}))=> nat => 'm => 'n =>
    (('a^'m::{mod_type} ^'m::{mod_type}) \<times> ('a^'n^'m::{mod_type}))"
    where "row_add_iterate_PA (P,A) 0 i j = (if i=0 then (P,A) else (row_add P 0 i (-A $ 0 $ j), row_add A 0 i (-A $ 0 $ j)))"
         | "row_add_iterate_PA (P,A) (Suc n) i j = (if (Suc n = to_nat i) then row_add_iterate_PA (P,A) n i j
                  else row_add_iterate_PA ((row_add P (from_nat (Suc n)) i (- A $ (from_nat (Suc n)) $ j)), (row_add A (from_nat (Suc n)) i (- A $ (from_nat (Suc n)) $ j))) n i j)"

lemma fst_row_add_iterate_PA_preserves_greater_than_n:
  assumes n: "n<nrows A"
  and a: "to_nat a > n"
  shows "fst (row_add_iterate_PA (P,A) n i j) $ a $ b = P $ a $ b"
  using assms
proof (induct n arbitrary: A P)
  case 0
  show ?case unfolding row_add_iterate.simps
  proof (auto)
    assume "i \<noteq> 0"
    hence "a \<noteq> 0" by (metis "0.prems"(2) less_numeral_extra(3) to_nat_0)
    thus "row_add P 0 i (- A $ 0 $ j) $ a $ b = P $ a $ b" unfolding row_add_def by auto
  qed
next
  case (Suc n)
  have row_add_iterate_A: "fst (row_add_iterate_PA (P,A) n i j) $ a $ b = P $ a $ b" using Suc.hyps Suc.prems by auto
  show ?case
  proof (cases "Suc n = to_nat i")
    case True
    show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = P $ a $ b" unfolding row_add_iterate_PA.simps if_P[OF True] using row_add_iterate_A .
  next
    case False
    def A' \<equiv> "row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
    def P' \<equiv> "row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
    have row_add_iterate_A': "fst (row_add_iterate_PA (P',A') n i j) $ a $ b = P' $ a $ b" using Suc.hyps Suc.prems unfolding nrows_def by auto
    have from_nat_not_a: "from_nat (Suc n) \<noteq> a" by (metis less_not_refl Suc.prems to_nat_from_nat_id nrows_def)
    show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = P $ a $ b" unfolding row_add_iterate_PA.simps if_not_P[OF False] row_add_iterate_A'[unfolded A'_def P'_def]
      unfolding row_add_def using from_nat_not_a by simp
  qed
qed

lemma snd_row_add_iterate_PA_eq_row_add_iterate:
shows "snd (row_add_iterate_PA (P,A) n i j)  = row_add_iterate A n i j"
proof (induct n arbitrary: P A)
case 0
show ?case unfolding row_add_iterate_PA.simps row_add_iterate.simps by simp
next
case (Suc n)
show ?case unfolding row_add_iterate_PA.simps row_add_iterate.simps by (simp add: Suc.hyps)
qed

lemma row_add_iterate_PA_preserves_pivot_row:
  assumes n: "n<nrows A"
  and a: "to_nat i \<le> n"
  shows "fst (row_add_iterate_PA (P,A) n i j) $ i $ b = P $ i $ b"
using assms
proof (induct n arbitrary: P A)
case 0
show ?case by (metis "0.prems"(2) fst_conv le_0_eq row_add_iterate_PA.simps(1) to_nat_eq_0)
next
case (Suc n)
show ?case
proof (cases "Suc n = to_nat i")
case True show ?thesis unfolding row_add_iterate_PA.simps if_P[OF True]
  proof (rule fst_row_add_iterate_PA_preserves_greater_than_n)
     show "n < nrows A" by (metis Suc.prems(1) Suc_lessD)
     show "n < to_nat i" by (metis True lessI)
  qed
next
case False
def P'=="row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
def A'=="row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
have from_nat_noteq_i: "from_nat (Suc n) \<noteq> i"  using False Suc.prems(1) from_nat_not_eq unfolding nrows_def by blast
have hyp: "fst (row_add_iterate_PA (P', A') n i j) $ i $ b = P' $ i $ b"
proof (rule Suc.hyps)
show "n < nrows A'" using Suc.prems(1) unfolding nrows_def by simp
show "to_nat i \<le> n" using Suc.prems(2) False by simp
qed
show ?thesis unfolding row_add_iterate_PA.simps unfolding if_not_P[OF False] unfolding hyp[unfolded A'_def P'_def]
unfolding row_add_def using from_nat_noteq_i by auto
qed
qed

lemma fst_row_add_iterate_PA_eq_row_add:
  fixes A::"'a::{ring_1}^'n^'m::{mod_type}"
  assumes a_not_i: "a \<noteq> i"
  and n: "n<nrows A"
  and "to_nat a \<le> n"
  shows "fst (row_add_iterate_PA (P,A) n i j) $ a $ b = (row_add P a i (- A $ a $ j)) $ a $ b"
  using assms
proof (induct n arbitrary: A P)
case 0 show ?case by (metis "0.prems"(3) a_not_i fst_conv le_0_eq row_add_iterate_PA.simps(1) to_nat_eq_0)
next
case (Suc n)
show ?case
proof (cases " Suc n = to_nat i")
case True
show ?thesis
unfolding row_add_iterate_PA.simps if_P[OF True]
proof (rule Suc.hyps[OF a_not_i])
show "n < nrows A" by (metis Suc.prems(2) Suc_lessD)
show "to_nat a \<le> n" by (metis Suc.prems(3) True a_not_i le_SucE to_nat_eq)
qed
next
case False note Suc_n_not_i=False
    show ?thesis
    proof (cases "to_nat a = Suc n")
case True
show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = row_add P a i (- A $ a $ j) $ a $ b"
unfolding row_add_iterate_PA.simps if_not_P[OF False]
by (metis Suc_le_lessD True dual_order.order_refl less_imp_le fst_row_add_iterate_PA_preserves_greater_than_n Suc.prems(2) to_nat_from_nat nrows_def)
next
case False
def A'\<equiv>"(row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j))"
def P'\<equiv>"(row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j))"
      have rw: "fst (row_add_iterate_PA (P',A') n i j) $ a $ b = row_add P' a i (- A' $ a $ j) $ a $ b"
      proof (rule Suc.hyps)
        show "a \<noteq> i" using Suc.prems(1) by simp
        show "n < nrows A'" using Suc.prems(2) unfolding nrows_def by auto
        show "to_nat a \<le> n" using False Suc.prems(3) by simp
      qed

      have rw1: "P' $ a $ b = P $ a $ b"
        unfolding P'_def row_add_def using False Suc.prems unfolding nrows_def by (auto simp add: to_nat_from_nat_id)
      have rw2: "A' $ a $ j = A $ a $ j"
          unfolding A'_def row_add_def using False Suc.prems unfolding nrows_def by (auto simp add: to_nat_from_nat_id)
      have rw3: "P' $ i $ b = P $ i $ b"
          unfolding P'_def row_add_def using False Suc.prems Suc_n_not_i unfolding nrows_def  by (auto simp add: to_nat_from_nat_id)
show "fst (row_add_iterate_PA (P, A) (Suc n) i j) $ a $ b = row_add P a i (- A $ a $ j) $ a $ b"
unfolding row_add_iterate_PA.simps if_not_P[OF Suc_n_not_i] unfolding rw[unfolded P'_def A'_def]
  unfolding A'_def[symmetric] P'_def[symmetric] unfolding row_add_def apply auto
unfolding rw1 rw2 rw3 ..
    qed
  qed
qed

lemma fst_row_add_iterate_PA_eq_fst_Gauss_Jordan_in_ij_PA:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
and i::"'rows" and j::"'cols"
and P::"'a::{field}^'rows::{mod_type}^'rows::{mod_type}"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
defines P': "P'== mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
shows "fst (row_add_iterate_PA (P',A') (nrows A - 1) i j)  = fst (Gauss_Jordan_in_ij_PA (P,A) i j)"
proof (unfold Gauss_Jordan_in_ij_PA_def Let_def, vector, auto)
fix ia
have interchange_rw: "interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j = A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j"
using interchange_rows_j[symmetric, of A "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)"] by auto
show "fst (row_add_iterate_PA (P', A') (nrows A - Suc 0) i j) $ i $ ia =
         mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) $ i $ ia"
unfolding A' P' interchange_rw
proof (rule row_add_iterate_PA_preserves_pivot_row, unfold nrows_def)
show "CARD('rows) - Suc 0 < CARD('rows)" by auto
show "to_nat i \<le> CARD('rows) - Suc 0" by (metis Suc_pred leD not_less_eq_eq to_nat_less_card zero_less_card_finite)
qed
next
  fix ia iaa
 have interchange_rw: "A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j = interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j"
   using interchange_rows_j[symmetric, of A "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)"] by auto
  assume ia_not_i: "ia \<noteq> i"
  have rw: "(- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ j)
    = - mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j) $ ia $ j"
    unfolding interchange_rows_def mult_row_def using ia_not_i by auto
show "fst (row_add_iterate_PA (P', A') (nrows A - Suc 0) i j) $ ia $ iaa
    = row_add (mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j)) ia i
    (- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ j) $ ia $ iaa"  unfolding interchange_rw unfolding A' P' unfolding rw
proof (rule fst_row_add_iterate_PA_eq_row_add, unfold nrows_def)
 show "ia \<noteq> i" using ia_not_i .
 show "CARD('rows) - Suc 0 < CARD('rows)" using zero_less_card_finite by auto
 show "to_nat ia \<le> CARD('rows) - Suc 0" by (metis Suc_pred leD not_less_eq_eq to_nat_less_card zero_less_card_finite)
qed
qed

lemma invertible_fst_row_add_iterate_PA:
  fixes A::"'a::{ring_1}^'n^'m::{mod_type}"
  assumes n: "n<nrows A"
  and inv_P: "invertible P"
  shows "invertible (fst (row_add_iterate_PA (P,A) n i j))"
  using n inv_P
  proof (induct n arbitrary: A P)
  case 0
  show ?case
    proof (unfold row_add_iterate_PA.simps, auto simp add: "0.prems")
      assume i_not_0: "i \<noteq> 0"
      have "row_add P 0 i (- A $ 0 $ j) = row_add (mat 1) 0 i (- A $ 0 $ j) ** P" unfolding row_add_mat_1 ..
      show "invertible (row_add P 0 i (- A $ 0 $ j))"
        by (subst row_add_mat_1[symmetric], rule invertible_mult, auto simp add: invertible_row_add[of 0 i "(- A $ 0 $ j)"] i_not_0 "0.prems")
    qed
    next
    case (Suc n)
    show ?case
      proof (cases "Suc n = to_nat i")
        case True
        show ?thesis unfolding row_add_iterate_PA.simps if_P[OF True] using Suc.hyps Suc.prems by simp
        next
        case False
        show ?thesis
          proof (unfold row_add_iterate_PA.simps if_not_P[OF False], rule Suc.hyps, unfold nrows_def)
             show "n < CARD('m)" using Suc.prems(1) unfolding nrows_def by simp
             show "invertible (row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j))"
                proof (subst row_add_mat_1[symmetric], rule invertible_mult, rule invertible_row_add)
                   show "from_nat (Suc n) \<noteq> i" using False Suc.prems(1) from_nat_not_eq unfolding nrows_def by blast
                   show "invertible P" using Suc.prems(2) .
                qed
          qed
      qed
qed

lemma invertible_fst_Gauss_Jordan_in_ij_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
assumes inv_P: "invertible P"
and not_all_zero: "\<not> (\<forall>m\<ge>i. A $ m $ j = 0)"
shows "invertible (fst (Gauss_Jordan_in_ij_PA (P,A) i j))"
proof (unfold fst_row_add_iterate_PA_eq_fst_Gauss_Jordan_in_ij_PA[symmetric], rule invertible_fst_row_add_iterate_PA, simp add: nrows_def,
subst interchange_rows_mat_1[symmetric], subst mult_row_mat_1[symmetric], rule invertible_mult)
show "invertible (mult_row (mat 1) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j))"
    proof (rule invertible_mult_row')
      have "interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j = A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j" by simp
      also have "... \<noteq> 0" by (metis (lifting, mono_tags) LeastI_ex not_all_zero)
      finally show "1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j \<noteq> 0"
      unfolding inverse_eq_divide[symmetric] using nonzero_imp_inverse_nonzero by blast
    qed
show "invertible (interchange_rows (mat 1) i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) ** P)"
  by (rule invertible_mult, rule invertible_interchange_rows, rule inv_P)
qed

lemma invertible_fst_Gauss_Jordan_column_k_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
assumes inv_P: "invertible P"
shows "invertible (fst (Gauss_Jordan_column_k_PA (P,i,A) k))"
proof (unfold Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv, auto simp add: inv_P)
fix m
assume i_less_m: "from_nat i \<le> m" and Amk_not_0: "A $ m $ from_nat k \<noteq> 0"
show "invertible (fst (Gauss_Jordan_in_ij_PA (P, A) (from_nat i) (from_nat k)))"
by (rule invertible_fst_Gauss_Jordan_in_ij_PA[OF inv_P], auto intro!: i_less_m Amk_not_0)
qed

lemma invertible_fst_Gauss_Jordan_upt_k_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
shows "invertible (fst (Gauss_Jordan_upt_k_PA A k))"
proof (induct k)
case 0
show ?case unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv by (simp add: invertible_fst_Gauss_Jordan_column_k_PA invertible_mat_1)
next
case (Suc k)
have list_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
def f\<equiv>"foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]"
have f_rw: "f = (fst f, fst (snd f), snd (snd f))" by simp
show ?case unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw unfolding foldl_append unfolding List.foldl.simps using invertible_fst_Gauss_Jordan_column_k_PA
by (metis (mono_tags) Gauss_Jordan_upt_k_PA_def Suc.hyps fst_conv pair_collapse)
qed

lemma invertible_fst_Gauss_Jordan_PA:
fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
shows "invertible (fst (Gauss_Jordan_PA A))"
by (unfold Gauss_Jordan_PA_def, rule invertible_fst_Gauss_Jordan_upt_k_PA)

definition "P_Gauss_Jordan A = fst (Gauss_Jordan_PA A)"

end