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

section\<open>Transitive Sets and Ordinals\<close>

theory Ordinal imports WF Bool equalities begin

definition
  Memrel        :: "i=>i"  where
    "Memrel(A)   == {z\<in>A*A . \<exists>x y. z=<x,y> & x\<in>y }"

definition
  Transset  :: "i=>o"  where
    "Transset(i) == \<forall>x\<in>i. x<=i"

definition
  Ord  :: "i=>o"  where
    "Ord(i)      == Transset(i) & (\<forall>x\<in>i. Transset(x))"

definition
  lt        :: "[i,i] => o"  (infixl "<" 50)   (*less-than on ordinals*)  where
    "i<j         == i\<in>j & Ord(j)"

definition
  Limit         :: "i=>o"  where
    "Limit(i)    == Ord(i) & 0<i & (\<forall>y. y<i \<longrightarrow> succ(y)<i)"

abbreviation
  le  (infixl "\<le>" 50) where
  "x \<le> y == x < succ(y)"

subsection\<open>Rules for Transset\<close>

subsubsection\<open>Three Neat Characterisations of Transset\<close>

lemma Transset_iff_Pow: "Transset(A) <-> A<=Pow(A)"
by (unfold Transset_def, blast)

lemma Transset_iff_Union_succ: "Transset(A) <-> \<Union>(succ(A)) = A"
apply (unfold Transset_def)
apply (blast elim!: equalityE)
done

lemma Transset_iff_Union_subset: "Transset(A) <-> \<Union>(A) \<subseteq> A"
by (unfold Transset_def, blast)

subsubsection\<open>Consequences of Downwards Closure\<close>

lemma Transset_doubleton_D:
    "[| Transset(C); {a,b}: C |] ==> a\<in>C & b\<in>C"
by (unfold Transset_def, blast)

lemma Transset_Pair_D:
    "[| Transset(C); <a,b>\<in>C |] ==> a\<in>C & b\<in>C"
apply (simp add: Pair_def)
apply (blast dest: Transset_doubleton_D)
done

lemma Transset_includes_domain:
    "[| Transset(C); A*B \<subseteq> C; b \<in> B |] ==> A \<subseteq> C"
by (blast dest: Transset_Pair_D)

lemma Transset_includes_range:
    "[| Transset(C); A*B \<subseteq> C; a \<in> A |] ==> B \<subseteq> C"
by (blast dest: Transset_Pair_D)

subsubsection\<open>Closure Properties\<close>

lemma Transset_0: "Transset(0)"
by (unfold Transset_def, blast)

lemma Transset_Un:
    "[| Transset(i);  Transset(j) |] ==> Transset(i \<union> j)"
by (unfold Transset_def, blast)

lemma Transset_Int:
    "[| Transset(i);  Transset(j) |] ==> Transset(i \<inter> j)"
by (unfold Transset_def, blast)

lemma Transset_succ: "Transset(i) ==> Transset(succ(i))"
by (unfold Transset_def, blast)

lemma Transset_Pow: "Transset(i) ==> Transset(Pow(i))"
by (unfold Transset_def, blast)

lemma Transset_Union: "Transset(A) ==> Transset(\<Union>(A))"
by (unfold Transset_def, blast)

lemma Transset_Union_family:
    "[| !!i. i\<in>A ==> Transset(i) |] ==> Transset(\<Union>(A))"
by (unfold Transset_def, blast)

lemma Transset_Inter_family:
    "[| !!i. i\<in>A ==> Transset(i) |] ==> Transset(\<Inter>(A))"
by (unfold Inter_def Transset_def, blast)

lemma Transset_UN:
     "(!!x. x \<in> A ==> Transset(B(x))) ==> Transset (\<Union>x\<in>A. B(x))"
by (rule Transset_Union_family, auto)

lemma Transset_INT:
     "(!!x. x \<in> A ==> Transset(B(x))) ==> Transset (\<Inter>x\<in>A. B(x))"
by (rule Transset_Inter_family, auto)

subsection\<open>Lemmas for Ordinals\<close>

lemma OrdI:
    "[| Transset(i);  !!x. x\<in>i ==> Transset(x) |]  ==>  Ord(i)"
by (simp add: Ord_def)

lemma Ord_is_Transset: "Ord(i) ==> Transset(i)"
by (simp add: Ord_def)

lemma Ord_contains_Transset:
    "[| Ord(i);  j\<in>i |] ==> Transset(j) "
by (unfold Ord_def, blast)

lemma Ord_in_Ord: "[| Ord(i);  j\<in>i |] ==> Ord(j)"
by (unfold Ord_def Transset_def, blast)

(*suitable for rewriting PROVIDED i has been fixed*)
lemma Ord_in_Ord': "[| j\<in>i; Ord(i) |] ==> Ord(j)"
by (blast intro: Ord_in_Ord)

(* Ord(succ(j)) ==> Ord(j) *)
lemmas Ord_succD = Ord_in_Ord [OF _ succI1]

lemma Ord_subset_Ord: "[| Ord(i);  Transset(j);  j<=i |] ==> Ord(j)"
by (simp add: Ord_def Transset_def, blast)

lemma OrdmemD: "[| j\<in>i;  Ord(i) |] ==> j<=i"
by (unfold Ord_def Transset_def, blast)

lemma Ord_trans: "[| i\<in>j;  j\<in>k;  Ord(k) |] ==> i\<in>k"
by (blast dest: OrdmemD)

lemma Ord_succ_subsetI: "[| i\<in>j;  Ord(j) |] ==> succ(i) \<subseteq> j"
by (blast dest: OrdmemD)

subsection\<open>The Construction of Ordinals: 0, succ, Union\<close>

lemma Ord_0 [iff,TC]: "Ord(0)"
by (blast intro: OrdI Transset_0)

lemma Ord_succ [TC]: "Ord(i) ==> Ord(succ(i))"
by (blast intro: OrdI Transset_succ Ord_is_Transset Ord_contains_Transset)

lemmas Ord_1 = Ord_0 [THEN Ord_succ]

lemma Ord_succ_iff [iff]: "Ord(succ(i)) <-> Ord(i)"
by (blast intro: Ord_succ dest!: Ord_succD)

lemma Ord_Un [intro,simp,TC]: "[| Ord(i); Ord(j) |] ==> Ord(i \<union> j)"
apply (unfold Ord_def)
apply (blast intro!: Transset_Un)
done

lemma Ord_Int [TC]: "[| Ord(i); Ord(j) |] ==> Ord(i \<inter> j)"
apply (unfold Ord_def)
apply (blast intro!: Transset_Int)
done

text\<open>There is no set of all ordinals, for then it would contain itself\<close>
lemma ON_class: "~ (\<forall>i. i\<in>X <-> Ord(i))"
proof (rule notI)
  assume X: "\<forall>i. i \<in> X \<longleftrightarrow> Ord(i)"
  have "\<forall>x y. x\<in>X \<longrightarrow> y\<in>x \<longrightarrow> y\<in>X"
    by (simp add: X, blast intro: Ord_in_Ord)
  hence "Transset(X)"
     by (auto simp add: Transset_def)
  moreover have "\<And>x. x \<in> X \<Longrightarrow> Transset(x)"
     by (simp add: X Ord_def)
  ultimately have "Ord(X)" by (rule OrdI)
  hence "X \<in> X" by (simp add: X)
  thus "False" by (rule mem_irrefl)
qed

subsection\<open>< is 'less Than' for Ordinals\<close>

lemma ltI: "[| i\<in>j;  Ord(j) |] ==> i<j"
by (unfold lt_def, blast)

lemma ltE:
    "[| i<j;  [| i\<in>j;  Ord(i);  Ord(j) |] ==> P |] ==> P"
apply (unfold lt_def)
apply (blast intro: Ord_in_Ord)
done

lemma ltD: "i<j ==> i\<in>j"
by (erule ltE, assumption)

lemma not_lt0 [simp]: "~ i<0"
by (unfold lt_def, blast)

lemma lt_Ord: "j<i ==> Ord(j)"
by (erule ltE, assumption)

lemma lt_Ord2: "j<i ==> Ord(i)"
by (erule ltE, assumption)

(* @{term"ja \<le> j ==> Ord(j)"} *)
lemmas le_Ord2 = lt_Ord2 [THEN Ord_succD]

(* i<0 ==> R *)
lemmas lt0E = not_lt0 [THEN notE, elim!]

lemma lt_trans [trans]: "[| i<j;  j<k |] ==> i<k"
by (blast intro!: ltI elim!: ltE intro: Ord_trans)

lemma lt_not_sym: "i<j ==> ~ (j<i)"
apply (unfold lt_def)
apply (blast elim: mem_asym)
done

(* [| i<j;  ~P ==> j<i |] ==> P *)
lemmas lt_asym = lt_not_sym [THEN swap]

lemma lt_irrefl [elim!]: "i<i ==> P"
by (blast intro: lt_asym)

lemma lt_not_refl: "~ i<i"
apply (rule notI)
apply (erule lt_irrefl)
done

text\<open>Recall that  @{term"i \<le> j"}  abbreviates  @{term"i<succ(j)"} !!\<close>

lemma le_iff: "i \<le> j <-> i<j | (i=j & Ord(j))"
by (unfold lt_def, blast)

(*Equivalently, i<j ==> i < succ(j)*)
lemma leI: "i<j ==> i \<le> j"
by (simp add: le_iff)

lemma le_eqI: "[| i=j;  Ord(j) |] ==> i \<le> j"
by (simp add: le_iff)

lemmas le_refl = refl [THEN le_eqI]

lemma le_refl_iff [iff]: "i \<le> i <-> Ord(i)"
by (simp (no_asm_simp) add: lt_not_refl le_iff)

lemma leCI: "(~ (i=j & Ord(j)) ==> i<j) ==> i \<le> j"
by (simp add: le_iff, blast)

lemma leE:
    "[| i \<le> j;  i<j ==> P;  [| i=j;  Ord(j) |] ==> P |] ==> P"
by (simp add: le_iff, blast)

lemma le_anti_sym: "[| i \<le> j;  j \<le> i |] ==> i=j"
apply (simp add: le_iff)
apply (blast elim: lt_asym)
done

lemma le0_iff [simp]: "i \<le> 0 <-> i=0"
by (blast elim!: leE)

lemmas le0D = le0_iff [THEN iffD1, dest!]

subsection\<open>Natural Deduction Rules for Memrel\<close>

(*The lemmas MemrelI/E give better speed than [iff] here*)
lemma Memrel_iff [simp]: "<a,b> \<in> Memrel(A) <-> a\<in>b & a\<in>A & b\<in>A"
by (unfold Memrel_def, blast)

lemma MemrelI [intro!]: "[| a \<in> b;  a \<in> A;  b \<in> A |] ==> <a,b> \<in> Memrel(A)"
by auto

lemma MemrelE [elim!]:
    "[| <a,b> \<in> Memrel(A);
        [| a \<in> A;  b \<in> A;  a\<in>b |]  ==> P |]
     ==> P"
by auto

lemma Memrel_type: "Memrel(A) \<subseteq> A*A"
by (unfold Memrel_def, blast)

lemma Memrel_mono: "A<=B ==> Memrel(A) \<subseteq> Memrel(B)"
by (unfold Memrel_def, blast)

lemma Memrel_0 [simp]: "Memrel(0) = 0"
by (unfold Memrel_def, blast)

lemma Memrel_1 [simp]: "Memrel(1) = 0"
by (unfold Memrel_def, blast)

lemma relation_Memrel: "relation(Memrel(A))"
by (simp add: relation_def Memrel_def)

(*The membership relation (as a set) is well-founded.
  Proof idea: show A<=B by applying the foundation axiom to A-B *)
lemma wf_Memrel: "wf(Memrel(A))"
apply (unfold wf_def)
apply (rule foundation [THEN disjE, THEN allI], erule disjI1, blast)
done

text\<open>The premise @{term "Ord(i)"} does not suffice.\<close>
lemma trans_Memrel:
    "Ord(i) ==> trans(Memrel(i))"
by (unfold Ord_def Transset_def trans_def, blast)

text\<open>However, the following premise is strong enough.\<close>
lemma Transset_trans_Memrel:
    "\<forall>j\<in>i. Transset(j) ==> trans(Memrel(i))"
by (unfold Transset_def trans_def, blast)

(*If Transset(A) then Memrel(A) internalizes the membership relation below A*)
lemma Transset_Memrel_iff:
    "Transset(A) ==> <a,b> \<in> Memrel(A) <-> a\<in>b & b\<in>A"
by (unfold Transset_def, blast)

subsection\<open>Transfinite Induction\<close>

(*Epsilon induction over a transitive set*)
lemma Transset_induct:
    "[| i \<in> k;  Transset(k);
        !!x.[| x \<in> k;  \<forall>y\<in>x. P(y) |] ==> P(x) |]
     ==>  P(i)"
apply (simp add: Transset_def)
apply (erule wf_Memrel [THEN wf_induct2], blast+)
done

(*Induction over an ordinal*)
lemmas Ord_induct [consumes 2] = Transset_induct [rule_format, OF _ Ord_is_Transset]

(*Induction over the class of ordinals -- a useful corollary of Ord_induct*)

lemma trans_induct [rule_format, consumes 1, case_names step]:
    "[| Ord(i);
        !!x.[| Ord(x);  \<forall>y\<in>x. P(y) |] ==> P(x) |]
     ==>  P(i)"
apply (rule Ord_succ [THEN succI1 [THEN Ord_induct]], assumption)
apply (blast intro: Ord_succ [THEN Ord_in_Ord])
done

section\<open>Fundamental properties of the epsilon ordering (< on ordinals)\<close>

subsubsection\<open>Proving That < is a Linear Ordering on the Ordinals\<close>

lemma Ord_linear:
     "Ord(i) \<Longrightarrow> Ord(j) \<Longrightarrow> i\<in>j | i=j | j\<in>i"
proof (induct i arbitrary: j rule: trans_induct)
  case (step i)
  note step_i = step
  show ?case using \<open>Ord(j)\<close>
    proof (induct j rule: trans_induct)
      case (step j)
      thus ?case using step_i
        by (blast dest: Ord_trans)
    qed
qed

text\<open>The trichotomy law for ordinals\<close>
lemma Ord_linear_lt:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (lt) "i<j" | (eq) "i=j" | (gt) "j<i"
apply (simp add: lt_def)
apply (rule_tac i1=i and j1=j in Ord_linear [THEN disjE])
apply (blast intro: o)+
done

lemma Ord_linear2:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (lt) "i<j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI sym o) +
done

lemma Ord_linear_le:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (le) "i \<le> j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI o) +
done

lemma le_imp_not_lt: "j \<le> i ==> ~ i<j"
by (blast elim!: leE elim: lt_asym)

lemma not_lt_imp_le: "[| ~ i<j;  Ord(i);  Ord(j) |] ==> j \<le> i"
by (rule_tac i = i and j = j in Ord_linear2, auto)

subsubsection \<open>Some Rewrite Rules for \<open><\<close>, \<open>\<le>\<close>\<close>

lemma Ord_mem_iff_lt: "Ord(j) ==> i\<in>j <-> i<j"
by (unfold lt_def, blast)

lemma not_lt_iff_le: "[| Ord(i);  Ord(j) |] ==> ~ i<j <-> j \<le> i"
by (blast dest: le_imp_not_lt not_lt_imp_le)

lemma not_le_iff_lt: "[| Ord(i);  Ord(j) |] ==> ~ i \<le> j <-> j<i"
by (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])

(*This is identical to 0<succ(i) *)
lemma Ord_0_le: "Ord(i) ==> 0 \<le> i"
by (erule not_lt_iff_le [THEN iffD1], auto)

lemma Ord_0_lt: "[| Ord(i);  i\<noteq>0 |] ==> 0<i"
apply (erule not_le_iff_lt [THEN iffD1])
apply (rule Ord_0, blast)
done

lemma Ord_0_lt_iff: "Ord(i) ==> i\<noteq>0 <-> 0<i"
by (blast intro: Ord_0_lt)

subsection\<open>Results about Less-Than or Equals\<close>

(** For ordinals, @{term"j\<subseteq>i"} implies @{term"j \<le> i"} (less-than or equals) **)

lemma zero_le_succ_iff [iff]: "0 \<le> succ(x) <-> Ord(x)"
by (blast intro: Ord_0_le elim: ltE)

lemma subset_imp_le: "[| j<=i;  Ord(i);  Ord(j) |] ==> j \<le> i"
apply (rule not_lt_iff_le [THEN iffD1], assumption+)
apply (blast elim: ltE mem_irrefl)
done

lemma le_imp_subset: "i \<le> j ==> i<=j"
by (blast dest: OrdmemD elim: ltE leE)

lemma le_subset_iff: "j \<le> i <-> j<=i & Ord(i) & Ord(j)"
by (blast dest: subset_imp_le le_imp_subset elim: ltE)

lemma le_succ_iff: "i \<le> succ(j) <-> i \<le> j | i=succ(j) & Ord(i)"
apply (simp (no_asm) add: le_iff)
apply blast
done

(*Just a variant of subset_imp_le*)
lemma all_lt_imp_le: "[| Ord(i);  Ord(j);  !!x. x<j ==> x<i |] ==> j \<le> i"
by (blast intro: not_lt_imp_le dest: lt_irrefl)

subsubsection\<open>Transitivity Laws\<close>

lemma lt_trans1: "[| i \<le> j;  j<k |] ==> i<k"
by (blast elim!: leE intro: lt_trans)

lemma lt_trans2: "[| i<j;  j \<le> k |] ==> i<k"
by (blast elim!: leE intro: lt_trans)

lemma le_trans: "[| i \<le> j;  j \<le> k |] ==> i \<le> k"
by (blast intro: lt_trans1)

lemma succ_leI: "i<j ==> succ(i) \<le> j"
apply (rule not_lt_iff_le [THEN iffD1])
apply (blast elim: ltE leE lt_asym)+
done

(*Identical to  succ(i) < succ(j) ==> i<j  *)
lemma succ_leE: "succ(i) \<le> j ==> i<j"
apply (rule not_le_iff_lt [THEN iffD1])
apply (blast elim: ltE leE lt_asym)+
done

lemma succ_le_iff [iff]: "succ(i) \<le> j <-> i<j"
by (blast intro: succ_leI succ_leE)

lemma succ_le_imp_le: "succ(i) \<le> succ(j) ==> i \<le> j"
by (blast dest!: succ_leE)

lemma lt_subset_trans: "[| i \<subseteq> j;  j<k;  Ord(i) |] ==> i<k"
apply (rule subset_imp_le [THEN lt_trans1])
apply (blast intro: elim: ltE) +
done

lemma lt_imp_0_lt: "j<i ==> 0<i"
by (blast intro: lt_trans1 Ord_0_le [OF lt_Ord])

lemma succ_lt_iff: "succ(i) < j <-> i<j & succ(i) \<noteq> j"
apply auto
apply (blast intro: lt_trans le_refl dest: lt_Ord)
apply (frule lt_Ord)
apply (rule not_le_iff_lt [THEN iffD1])
  apply (blast intro: lt_Ord2)
 apply blast
apply (simp add: lt_Ord lt_Ord2 le_iff)
apply (blast dest: lt_asym)
done

lemma Ord_succ_mem_iff: "Ord(j) ==> succ(i) \<in> succ(j) <-> i\<in>j"
apply (insert succ_le_iff [of i j])
apply (simp add: lt_def)
done

subsubsection\<open>Union and Intersection\<close>

lemma Un_upper1_le: "[| Ord(i); Ord(j) |] ==> i \<le> i \<union> j"
by (rule Un_upper1 [THEN subset_imp_le], auto)

lemma Un_upper2_le: "[| Ord(i); Ord(j) |] ==> j \<le> i \<union> j"
by (rule Un_upper2 [THEN subset_imp_le], auto)

(*Replacing k by succ(k') yields the similar rule for le!*)
lemma Un_least_lt: "[| i<k;  j<k |] ==> i \<union> j < k"
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (auto simp add: Un_commute le_subset_iff subset_Un_iff lt_Ord)
done

lemma Un_least_lt_iff: "[| Ord(i); Ord(j) |] ==> i \<union> j < k  <->  i<k & j<k"
apply (safe intro!: Un_least_lt)
apply (rule_tac [2] Un_upper2_le [THEN lt_trans1])
apply (rule Un_upper1_le [THEN lt_trans1], auto)
done

lemma Un_least_mem_iff:
    "[| Ord(i); Ord(j); Ord(k) |] ==> i \<union> j \<in> k  <->  i\<in>k & j\<in>k"
apply (insert Un_least_lt_iff [of i j k])
apply (simp add: lt_def)
done

(*Replacing k by succ(k') yields the similar rule for le!*)
lemma Int_greatest_lt: "[| i<k;  j<k |] ==> i \<inter> j < k"
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (auto simp add: Int_commute le_subset_iff subset_Int_iff lt_Ord)
done

lemma Ord_Un_if:
     "[| Ord(i); Ord(j) |] ==> i \<union> j = (if j<i then i else j)"
by (simp add: not_lt_iff_le le_imp_subset leI
              subset_Un_iff [symmetric]  subset_Un_iff2 [symmetric])

lemma succ_Un_distrib:
     "[| Ord(i); Ord(j) |] ==> succ(i \<union> j) = succ(i) \<union> succ(j)"
by (simp add: Ord_Un_if lt_Ord le_Ord2)

lemma lt_Un_iff:
     "[| Ord(i); Ord(j) |] ==> k < i \<union> j <-> k < i | k < j"
apply (simp add: Ord_Un_if not_lt_iff_le)
apply (blast intro: leI lt_trans2)+
done

lemma le_Un_iff:
     "[| Ord(i); Ord(j) |] ==> k \<le> i \<union> j <-> k \<le> i | k \<le> j"
by (simp add: succ_Un_distrib lt_Un_iff [symmetric])

lemma Un_upper1_lt: "[|k < i; Ord(j)|] ==> k < i \<union> j"
by (simp add: lt_Un_iff lt_Ord2)

lemma Un_upper2_lt: "[|k < j; Ord(i)|] ==> k < i \<union> j"
by (simp add: lt_Un_iff lt_Ord2)

(*See also Transset_iff_Union_succ*)
lemma Ord_Union_succ_eq: "Ord(i) ==> \<Union>(succ(i)) = i"
by (blast intro: Ord_trans)

subsection\<open>Results about Limits\<close>

lemma Ord_Union [intro,simp,TC]: "[| !!i. i\<in>A ==> Ord(i) |] ==> Ord(\<Union>(A))"
apply (rule Ord_is_Transset [THEN Transset_Union_family, THEN OrdI])
apply (blast intro: Ord_contains_Transset)+
done

lemma Ord_UN [intro,simp,TC]:
     "[| !!x. x\<in>A ==> Ord(B(x)) |] ==> Ord(\<Union>x\<in>A. B(x))"
by (rule Ord_Union, blast)

lemma Ord_Inter [intro,simp,TC]:
    "[| !!i. i\<in>A ==> Ord(i) |] ==> Ord(\<Inter>(A))"
apply (rule Transset_Inter_family [THEN OrdI])
apply (blast intro: Ord_is_Transset)
apply (simp add: Inter_def)
apply (blast intro: Ord_contains_Transset)
done

lemma Ord_INT [intro,simp,TC]:
    "[| !!x. x\<in>A ==> Ord(B(x)) |] ==> Ord(\<Inter>x\<in>A. B(x))"
by (rule Ord_Inter, blast)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma UN_least_le:
    "[| Ord(i);  !!x. x\<in>A ==> b(x) \<le> i |] ==> (\<Union>x\<in>A. b(x)) \<le> i"
apply (rule le_imp_subset [THEN UN_least, THEN subset_imp_le])
apply (blast intro: Ord_UN elim: ltE)+
done

lemma UN_succ_least_lt:
    "[| j<i;  !!x. x\<in>A ==> b(x)<j |] ==> (\<Union>x\<in>A. succ(b(x))) < i"
apply (rule ltE, assumption)
apply (rule UN_least_le [THEN lt_trans2])
apply (blast intro: succ_leI)+
done

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

lemma UN_upper_le:
     "[| a \<in> A;  i \<le> b(a);  Ord(\<Union>x\<in>A. b(x)) |] ==> i \<le> (\<Union>x\<in>A. b(x))"
apply (frule ltD)
apply (rule le_imp_subset [THEN subset_trans, THEN subset_imp_le])
apply (blast intro: lt_Ord UN_upper)+
done

lemma lt_Union_iff: "\<forall>i\<in>A. Ord(i) ==> (j < \<Union>(A)) <-> (\<exists>i\<in>A. j<i)"
by (auto simp: lt_def Ord_Union)

lemma Union_upper_le:
     "[| j \<in> J;  i\<le>j;  Ord(\<Union>(J)) |] ==> i \<le> \<Union>J"
apply (subst Union_eq_UN)
apply (rule UN_upper_le, auto)
done

lemma le_implies_UN_le_UN:
    "[| !!x. x\<in>A ==> c(x) \<le> d(x) |] ==> (\<Union>x\<in>A. c(x)) \<le> (\<Union>x\<in>A. d(x))"
apply (rule UN_least_le)
apply (rule_tac [2] UN_upper_le)
apply (blast intro: Ord_UN le_Ord2)+
done

lemma Ord_equality: "Ord(i) ==> (\<Union>y\<in>i. succ(y)) = i"
by (blast intro: Ord_trans)

(*Holds for all transitive sets, not just ordinals*)
lemma Ord_Union_subset: "Ord(i) ==> \<Union>(i) \<subseteq> i"
by (blast intro: Ord_trans)

subsection\<open>Limit Ordinals -- General Properties\<close>

lemma Limit_Union_eq: "Limit(i) ==> \<Union>(i) = i"
apply (unfold Limit_def)
apply (fast intro!: ltI elim!: ltE elim: Ord_trans)
done

lemma Limit_is_Ord: "Limit(i) ==> Ord(i)"
apply (unfold Limit_def)
apply (erule conjunct1)
done

lemma Limit_has_0: "Limit(i) ==> 0 < i"
apply (unfold Limit_def)
apply (erule conjunct2 [THEN conjunct1])
done

lemma Limit_nonzero: "Limit(i) ==> i \<noteq> 0"
by (drule Limit_has_0, blast)

lemma Limit_has_succ: "[| Limit(i);  j<i |] ==> succ(j) < i"
by (unfold Limit_def, blast)

lemma Limit_succ_lt_iff [simp]: "Limit(i) ==> succ(j) < i <-> (j<i)"
apply (safe intro!: Limit_has_succ)
apply (frule lt_Ord)
apply (blast intro: lt_trans)
done

lemma zero_not_Limit [iff]: "~ Limit(0)"
by (simp add: Limit_def)

lemma Limit_has_1: "Limit(i) ==> 1 < i"
by (blast intro: Limit_has_0 Limit_has_succ)

lemma increasing_LimitI: "[| 0<l; \<forall>x\<in>l. \<exists>y\<in>l. x<y |] ==> Limit(l)"
apply (unfold Limit_def, simp add: lt_Ord2, clarify)
apply (drule_tac i=y in ltD)
apply (blast intro: lt_trans1 [OF _ ltI] lt_Ord2)
done

lemma non_succ_LimitI:
  assumes i: "0<i" and nsucc: "\<And>y. succ(y) \<noteq> i"
  shows "Limit(i)"
proof -
  have Oi: "Ord(i)" using i by (simp add: lt_def)
  { fix y
    assume yi: "y<i"
    hence Osy: "Ord(succ(y))" by (simp add: lt_Ord Ord_succ)
    have "~ i \<le> y" using yi by (blast dest: le_imp_not_lt)
    hence "succ(y) < i" using nsucc [of y]
      by (blast intro: Ord_linear_lt [OF Osy Oi]) }
  thus ?thesis using i Oi by (auto simp add: Limit_def)
qed

lemma succ_LimitE [elim!]: "Limit(succ(i)) ==> P"
apply (rule lt_irrefl)
apply (rule Limit_has_succ, assumption)
apply (erule Limit_is_Ord [THEN Ord_succD, THEN le_refl])
done

lemma not_succ_Limit [simp]: "~ Limit(succ(i))"
by blast

lemma Limit_le_succD: "[| Limit(i);  i \<le> succ(j) |] ==> i \<le> j"
by (blast elim!: leE)

subsubsection\<open>Traditional 3-Way Case Analysis on Ordinals\<close>

lemma Ord_cases_disj: "Ord(i) ==> i=0 | (\<exists>j. Ord(j) & i=succ(j)) | Limit(i)"
by (blast intro!: non_succ_LimitI Ord_0_lt)

lemma Ord_cases:
 assumes i: "Ord(i)"
 obtains ("0") "i=0" | (succ) j where "Ord(j)" "i=succ(j)" | (limit) "Limit(i)"
by (insert Ord_cases_disj [OF i], auto)

lemma trans_induct3_raw:
     "[| Ord(i);
         P(0);
         !!x. [| Ord(x);  P(x) |] ==> P(succ(x));
         !!x. [| Limit(x);  \<forall>y\<in>x. P(y) |] ==> P(x)
      |] ==> P(i)"
apply (erule trans_induct)
apply (erule Ord_cases, blast+)
done

lemmas trans_induct3 = trans_induct3_raw [rule_format, case_names 0 succ limit, consumes 1]

text\<open>A set of ordinals is either empty, contains its own union, or its
union is a limit ordinal.\<close>

lemma Union_le: "[| !!x. x\<in>I ==> x\<le>j; Ord(j) |] ==> \<Union>(I) \<le> j"
  by (auto simp add: le_subset_iff Union_least)

lemma Ord_set_cases:
  assumes I: "\<forall>i\<in>I. Ord(i)"
  shows "I=0 \<or> \<Union>(I) \<in> I \<or> (\<Union>(I) \<notin> I \<and> Limit(\<Union>(I)))"
proof (cases "\<Union>(I)" rule: Ord_cases)
  show "Ord(\<Union>I)" using I by (blast intro: Ord_Union)
next
  assume "\<Union>I = 0" thus ?thesis by (simp, blast intro: subst_elem)
next
  fix j
  assume j: "Ord(j)" and UIj:"\<Union>(I) = succ(j)"
  { assume "\<forall>i\<in>I. i\<le>j"
    hence "\<Union>(I) \<le> j"
      by (simp add: Union_le j)
    hence False
      by (simp add: UIj lt_not_refl) }
  then obtain i where i: "i \<in> I" "succ(j) \<le> i" using I j
    by (atomize, auto simp add: not_le_iff_lt)
  have "\<Union>(I) \<le> succ(j)" using UIj j by auto
  hence "i \<le> succ(j)" using i
    by (simp add: le_subset_iff Union_subset_iff)
  hence "succ(j) = i" using i
    by (blast intro: le_anti_sym)
  hence "succ(j) \<in> I" by (simp add: i)
  thus ?thesis by (simp add: UIj)
next
  assume "Limit(\<Union>I)" thus ?thesis by auto
qed

text\<open>If the union of a set of ordinals is a successor, then it is an element of that set.\<close>
lemma Ord_Union_eq_succD: "[|\<forall>x\<in>X. Ord(x);  \<Union>X = succ(j)|] ==> succ(j) \<in> X"
  by (drule Ord_set_cases, auto)

lemma Limit_Union [rule_format]: "[| I \<noteq> 0;  \<forall>i\<in>I. Limit(i) |] ==> Limit(\<Union>I)"
apply (simp add: Limit_def lt_def)
apply (blast intro!: equalityI)
done

end


(*  Author:     Tobias Nipkow, TU München

A theory of types extended with a greatest and a least element.
Oriented towards numeric types, hence "\<infinity>" and "-\<infinity>".
*)

theory Extended
imports
  Main
  "~~/src/HOL/Library/Simps_Case_Conv"
begin

datatype 'a extended = Fin 'a | Pinf ("\<infinity>") | Minf ("-\<infinity>")

instantiation extended :: (order)order
begin

fun less_eq_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> bool" where
"Fin x \<le> Fin y = (x \<le> y)" |
"_     \<le> Pinf  = True" |
"Minf  \<le> _     = True" |
"(_::'a extended) \<le> _     = False"

case_of_simps less_eq_extended_case: less_eq_extended.simps

definition less_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> bool" where
"((x::'a extended) < y) = (x \<le> y & \<not> x \<ge> y)"

instance
  by intro_classes (auto simp: less_extended_def less_eq_extended_case split: extended.splits)

end

instance extended :: (linorder)linorder
  by intro_classes (auto simp: less_eq_extended_case split:extended.splits)

lemma Minf_le[simp]: "Minf \<le> y"
by(cases y) auto
lemma le_Pinf[simp]: "x \<le> Pinf"
by(cases x) auto
lemma le_Minf[simp]: "x \<le> Minf \<longleftrightarrow> x = Minf"
by(cases x) auto
lemma Pinf_le[simp]: "Pinf \<le> x \<longleftrightarrow> x = Pinf"
by(cases x) auto

lemma less_extended_simps[simp]:
  "Fin x < Fin y = (x < y)"
  "Fin x < Pinf  = True"
  "Fin x < Minf  = False"
  "Pinf < h      = False"
  "Minf < Fin x  = True"
  "Minf < Pinf   = True"
  "l    < Minf   = False"
by (auto simp add: less_extended_def)

lemma min_extended_simps[simp]:
  "min (Fin x) (Fin y) = Fin(min x y)"
  "min xx      Pinf    = xx"
  "min xx      Minf    = Minf"
  "min Pinf    yy      = yy"
  "min Minf    yy      = Minf"
by (auto simp add: min_def)

lemma max_extended_simps[simp]:
  "max (Fin x) (Fin y) = Fin(max x y)"
  "max xx      Pinf    = Pinf"
  "max xx      Minf    = xx"
  "max Pinf    yy      = Pinf"
  "max Minf    yy      = yy"
by (auto simp add: max_def)

instantiation extended :: (zero)zero
begin
definition "0 = Fin(0::'a)"
instance ..
end

declare zero_extended_def[symmetric, code_post]

instantiation extended :: (one)one
begin
definition "1 = Fin(1::'a)"
instance ..
end

declare one_extended_def[symmetric, code_post]

instantiation extended :: (plus)plus
begin

text {* The following definition of of addition is totalized
to make it asociative and commutative. Normally the sum of plus and minus infinity is undefined. *}

fun plus_extended where
"Fin x + Fin y = Fin(x+y)" |
"Fin x + Pinf  = Pinf" |
"Pinf  + Fin x = Pinf" |
"Pinf  + Pinf  = Pinf" |
"Minf  + Fin y = Minf" |
"Fin x + Minf  = Minf" |
"Minf  + Minf  = Minf" |
"Minf  + Pinf  = Pinf" |
"Pinf  + Minf  = Pinf"

case_of_simps plus_case: plus_extended.simps

instance ..

end

instance extended :: (ab_semigroup_add)ab_semigroup_add
  by intro_classes (simp_all add: ac_simps plus_case split: extended.splits)

instance extended :: (ordered_ab_semigroup_add)ordered_ab_semigroup_add
  by intro_classes (auto simp: add_left_mono plus_case split: extended.splits)

instance extended :: (comm_monoid_add)comm_monoid_add
proof
  fix x :: "'a extended" show "0 + x = x" unfolding zero_extended_def by(cases x)auto
qed

instantiation extended :: (uminus)uminus
begin

fun uminus_extended where
"- (Fin x) = Fin (- x)" |
"- Pinf    = Minf" |
"- Minf    = Pinf"

instance ..

end

instantiation extended :: (ab_group_add)minus
begin
definition "x - y = x + -(y::'a extended)"
instance ..
end

lemma minus_extended_simps[simp]:
  "Fin x - Fin y = Fin(x - y)"
  "Fin x - Pinf  = Minf"
  "Fin x - Minf  = Pinf"
  "Pinf  - Fin y = Pinf"
  "Pinf  - Minf  = Pinf"
  "Minf  - Fin y = Minf"
  "Minf  - Pinf  = Minf"
  "Minf  - Minf  = Pinf"
  "Pinf  - Pinf  = Pinf"
by (simp_all add: minus_extended_def)

text{* Numerals: *}

instance extended :: ("{ab_semigroup_add,one}")numeral ..

lemma Fin_numeral[code_post]: "Fin(numeral w) = numeral w"
  apply (induct w rule: num_induct)
  apply (simp only: numeral_One one_extended_def)
  apply (simp only: numeral_inc one_extended_def plus_extended.simps(1)[symmetric])
  done

lemma Fin_neg_numeral[code_post]: "Fin (- numeral w) = - numeral w"
by (simp only: Fin_numeral uminus_extended.simps[symmetric])

instantiation extended :: (lattice)bounded_lattice
begin

definition "bot = Minf"
definition "top = Pinf"

fun inf_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> 'a extended" where
"inf_extended (Fin i) (Fin j) = Fin (inf i j)" |
"inf_extended a Minf = Minf" |
"inf_extended Minf a = Minf" |
"inf_extended Pinf a = a" |
"inf_extended a Pinf = a"

fun sup_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> 'a extended" where
"sup_extended (Fin i) (Fin j) = Fin (sup i j)" |
"sup_extended a Pinf = Pinf" |
"sup_extended Pinf a = Pinf" |
"sup_extended Minf a = a" |
"sup_extended a Minf = a"

case_of_simps inf_extended_case: inf_extended.simps
case_of_simps sup_extended_case: sup_extended.simps

instance
  by (intro_classes) (auto simp: inf_extended_case sup_extended_case less_eq_extended_case
    bot_extended_def top_extended_def split: extended.splits)
end

end


(*
  File:     Jacobi_Symbol.thy
  Authors:  Daniel Stüwe, Manuel Eberl

  The Jacobi symbol, a generalisation of the Legendre symbol.
  This is used in the Solovay--Strassen test.
*)
section \<open>The Jacobi Symbol\<close>
theory Jacobi_Symbol
imports
  Legendre_Symbol
  Algebraic_Auxiliaries
begin

text \<open>
  The Jacobi symbol is a generalisation of the Legendre symbol to non-primes \cite{Legendre_Symbol, Jacobi_Symbol}.
  It is defined as
  \[\left(\frac{a}{n}\right) =
      \left(\frac{a}{p_1}\right)^{k_1} \ldots \left(\frac{a}{p_l}\right)^{k_l}\]
  where $(\frac{a}{p})$ denotes the Legendre symbol, \<open>a\<close> is an integer, \<open>n\<close> is an odd natural
  number and $p_1^{k_1}\ldots p_l^{k_l}$ is its prime factorisation.

  There is, however, a fairly natural generalisation to all non-zero integers for \<open>n\<close>.
  It is less clear what a good choice for \<open>n = 0\<close> is; Mathematica and Maxima adopt
  the convention that $(\frac{\pm 1}{0}) = 1$ and $(\frac{a}{0}) = 0$ otherwise. However,
  we chose the slightly different convention $(\frac{a}{0}) = 0$ for \<^emph>\<open>all\<close> \<open>a\<close> because then
  the Jacobi symbol is completely multiplicative in both arguments without any restrictions.
\<close>
definition Jacobi :: "int \<Rightarrow> int \<Rightarrow> int" where
  "Jacobi a n = (if n = 0 then 0 else
                  (\<Prod>p\<in>#prime_factorization n. Legendre a p))"

lemma Jacobi_0_right [simp]: "Jacobi a 0 = 0"
  by (simp add: Jacobi_def)

lemma Jacobi_mult_left [simp]: "Jacobi (a * b) n = Jacobi a n * Jacobi b n"
proof (cases "n = 0")
  case False
  have *: "{# Legendre (a * b) p          . p \<in># prime_factorization n #} =
           {# Legendre a p * Legendre b p . p \<in># prime_factorization n #}"
    by (meson Legendre_mult in_prime_factors_imp_prime image_mset_cong)

  show ?thesis using False unfolding Jacobi_def * prod_mset.distrib by auto
qed auto

lemma Jacobi_mult_right [simp]: "Jacobi a (n * m) = Jacobi a n * Jacobi a m"
  by (cases "m = 0"; cases "n = 0")
     (auto simp: Jacobi_def prime_factorization_mult)

lemma prime_p_Jacobi_eq_Legendre[intro!]: "prime p \<Longrightarrow> Jacobi a p = Legendre a p"
  unfolding Jacobi_def prime_factorization_prime by simp

lemma Jacobi_mod [simp]: "Jacobi (a mod m) n = Jacobi a n" if "n dvd m"
proof -
  have *: "{# Legendre (a mod m) p . p \<in># prime_factorization n #} =
           {# Legendre a p . p \<in># prime_factorization n #}" using that
    by (intro image_mset_cong, subst Legendre_mod)
       (auto intro: dvd_trans[OF in_prime_factors_imp_dvd])
  thus ?thesis by (simp add: Jacobi_def)
qed

lemma Jacobi_mod_cong: "[a = b] (mod n) \<Longrightarrow> Jacobi a n = Jacobi b n"
  by (metis Jacobi_mod cong_def dvd_refl)

lemma Jacobi_1_eq_1 [simp]: "p \<noteq> 0 \<Longrightarrow> Jacobi 1 p = 1"
  by (simp add: Jacobi_def in_prime_factors_imp_prime cong: image_mset_cong)

lemma Jacobi_p_eq_2'[simp]: "n > 0 \<Longrightarrow> Jacobi a (2^n) = a mod 2"
  by (auto simp add: Jacobi_def prime_factorization_prime_power)

lemma Jacobi_prod_mset[simp]: "n \<noteq> 0 \<Longrightarrow> Jacobi (prod_mset M) n = (\<Prod>q\<in>#M. Jacobi q n)"
  by (induction M) simp_all

lemma non_trivial_coprime_neq:
  "1 < a \<Longrightarrow> 1 < b \<Longrightarrow> coprime a b \<Longrightarrow> a \<noteq> b" for a b :: int by auto

lemma odd_odd_even:
  fixes a b :: int
  assumes "odd a" "odd b"
  shows "even ((a*b-1) div 2) = even ((a-1) div 2 + (b-1) div 2)"
  using assms by (auto elim!: oddE simp: algebra_simps)

lemma prime_nonprime_wlog [case_names primes nonprime sym]:
  assumes "\<And>p q. prime p \<Longrightarrow> prime q \<Longrightarrow> P p q"
  assumes "\<And>p q. \<not>prime p \<Longrightarrow> P p q"
  assumes "\<And>p q. P p q \<Longrightarrow> P q p"
  shows   "P p q"
  by (cases "prime p"; cases "prime q") (auto intro: assms)

lemma Quadratic_Reciprocity_Jacobi:
  fixes p q :: int
  assumes "coprime p q"
      and "2 < p" "2 < q"
      and "odd p" "odd q"
    shows "Jacobi p q * Jacobi q p =
           (- 1) ^ (nat ((p - 1) div 2 * ((q - 1) div 2)))"
  using assms
proof (induction "nat p" "nat q" arbitrary: p q
         rule: measure_induct_rule[where f = "\<lambda>(a, b). a + b", split_format(complete), simplified])
  case (1 p q)
  thus ?case
  proof (induction p q rule: prime_nonprime_wlog)
    case (sym p q)
    thus ?case by (simp only: add_ac coprime_commute mult_ac) blast
  next
    case (primes p q)
    from \<open>prime p\<close> \<open>prime q\<close> have "prime (nat p)" "prime (nat q)" "p \<noteq> q"
      using prime_int_nat_transfer primes(4) non_trivial_coprime_neq prime_gt_1_int
      by blast+

    with Quadratic_Reciprocity_int and prime_p_Jacobi_eq_Legendre
    show ?case
      using \<open>prime p\<close> \<open>prime q\<close> primes(5-)
      by presburger
  next
    case (nonprime p q)
    from \<open>\<not>prime p\<close> obtain a b where *: "p = a * b" "1 < b" "1 < a"
      using \<open>2 < p\<close> prime_divisor_exists_strong[of p] by auto

    hence odd_ab: "odd a" "odd b" using \<open>odd p\<close> by simp_all

    moreover have "2 < b" and "2 < a"
      using odd_ab and * by presburger+

    moreover have "coprime a q" and "coprime b q" using \<open>coprime p q\<close>
      unfolding * by simp_all

    ultimately have IH: "Jacobi a q * Jacobi q a = (- 1) ^ nat ((a - 1) div 2 * ((q - 1) div 2))"
                        "Jacobi b q * Jacobi q b = (- 1) ^ nat ((b - 1) div 2 * ((q - 1) div 2))"
      by (auto simp: * nonprime)

    have pos: "0 < q" "0 < p" "0 < a" "0 < b"
      using * \<open>2 < q\<close> by simp_all

    have "Jacobi p q * Jacobi q p = (Jacobi a q * Jacobi q a) * (Jacobi b q * Jacobi q b)"
      using * by simp

    also have "... = (- 1) ^ nat ((a - 1) div 2 * ((q - 1) div 2)) *
                     (- 1) ^ nat ((b - 1) div 2 * ((q - 1) div 2))"
      using IH by presburger

    also from odd_odd_even[OF odd_ab]
    have "... = (- 1) ^ nat ((p - 1) div 2 * ((q - 1) div 2))"
      unfolding * minus_one_power_iff using \<open>2 < q\<close> *
      by (auto simp add: even_nat_iff pos_imp_zdiv_nonneg_iff)

    finally show ?case .
  qed
qed

lemma Jacobi_values: "Jacobi p q \<in> {1, -1, 0}"
proof (cases "q = 0")
  case False
  hence "\<bar>Legendre p x\<bar> = 1" if "x \<in># prime_factorization q" "Jacobi p q \<noteq> 0" for x
    using that prod_mset_zero_iff Legendre_values[of p x]
    unfolding Jacobi_def is_unit_prod_mset_iff set_image_mset
    by fastforce

  then have "is_unit (prod_mset (image_mset (Legendre p) (prime_factorization q)))"
    if "Jacobi p q \<noteq> 0"
    using that False
    unfolding Jacobi_def is_unit_prod_mset_iff
    by auto

  thus ?thesis by (auto simp: Jacobi_def)
qed auto

lemma Quadratic_Reciprocity_Jacobi':
  fixes p q :: int
  assumes "coprime p q"
      and "2 < p" "2 < q"
      and "odd p" "odd q"
    shows "Jacobi q p = (if p mod 4 = 3 \<and> q mod 4 = 3 then -1 else 1) * Jacobi p q"
proof -
  have aux: "a \<in> {1, -1, 0} \<Longrightarrow> c \<noteq> 0 \<Longrightarrow> a*b = c \<Longrightarrow> b = c * a" for b c a :: int by auto

  from Quadratic_Reciprocity_Jacobi[OF assms]
  have "Jacobi q p = (-1) ^ nat ((p - 1) div 2 * ((q - 1) div 2)) * Jacobi p q"
    using Jacobi_values by (fastforce intro!: aux)

  also have "(-1 :: int) ^ nat ((p - 1) div 2 * ((q - 1) div 2)) = (if even ((p - 1) div 2) \<or> even ((q - 1) div 2) then 1 else - 1)"
    unfolding minus_one_power_iff using \<open>2 < p\<close> \<open>2 < q\<close>
    by (auto simp: even_nat_iff)

  also have "... = (if p mod 4 = 3 \<and> q mod 4 = 3 then -1 else 1)"
    using \<open>odd p\<close> \<open>odd q\<close> by presburger

  finally show ?thesis .

qed

lemma odd_odd_even':
  fixes a b :: int
  assumes "odd a" "odd b"
  shows "even (((a * b)\<^sup>2 - 1) div 8) \<longleftrightarrow> even (((a\<^sup>2 - 1) div 8) + ((b\<^sup>2 - 1) div 8))"
proof -
  obtain x where [simp]: "a = 2*x + 1" using \<open>odd a\<close> by (auto elim: oddE)
  obtain y where [simp]: "b = 2*y + 1" using \<open>odd b\<close> by (auto elim: oddE)
  show ?thesis
    by (cases "even x"; cases "even y"; elim oddE evenE)
       (auto simp: power2_eq_square algebra_simps)
qed

lemma odd_odd_even_nat':
  fixes a b :: nat
  assumes "odd a" "odd b"
  shows "even (((a * b)\<^sup>2 - 1) div 8) \<longleftrightarrow> even (((a\<^sup>2 - 1) div 8) + ((b\<^sup>2 - 1) div 8))"
proof -
  obtain x where [simp]: "a = 2*x + 1" using \<open>odd a\<close> by (auto elim: oddE)
  obtain y where [simp]: "b = 2*y + 1" using \<open>odd b\<close> by (auto elim: oddE)
  show ?thesis
    by (cases "even x"; cases "even y"; elim oddE evenE)
       (auto simp: power2_eq_square algebra_simps)
qed

lemma supplement2_Jacobi: "odd p \<Longrightarrow> p > 1 \<Longrightarrow> Jacobi 2 p = (- 1) ^ (((nat p)\<^sup>2 - 1) div 8)"
proof (induction p rule: prime_divisors_induct)
  case (factor p x)

  then have "odd x" by force

  have "2 < p"
    using \<open>odd (p * x)\<close> prime_gt_1_int[OF \<open>prime p\<close>]
    by (cases "p = 2") auto

  have "odd p" using prime_odd_int[OF \<open>prime p\<close> \<open>2 < p\<close>] .

  have "0 < x"
    using \<open>1 < (p * x)\<close> prime_gt_0_int[OF \<open>prime p\<close>]
    and less_trans less_numeral_extra(1) zero_less_mult_pos by blast

  have base_case : "Jacobi 2 p = (- 1) ^ (((nat p)\<^sup>2 - 1) div 8)"
    using \<open>2 < p\<close> \<open>prime p\<close> supplement2_Legendre and prime_p_Jacobi_eq_Legendre
    by presburger

  show ?case proof (cases "x = 1")
    case True
    thus ?thesis using base_case by force
  next
    case False
    have "Jacobi 2 (p * x) = Jacobi 2 p * Jacobi 2 x"
      using \<open>2 < p\<close> \<open>0 < x\<close> by simp

    also have "Jacobi 2 x = (- 1) ^ (((nat x)\<^sup>2 - 1) div 8)"
      using \<open>odd x\<close> \<open>0 < x\<close> \<open>x \<noteq> 1\<close> by (intro factor.IH) auto

    also note base_case

    also have "(-1) ^ (((nat p)\<^sup>2 - 1) div 8) * (-1) ^ (((nat x)\<^sup>2 - 1) div 8)
             = (-1 :: int) ^ (((nat (p * x))\<^sup>2 - 1) div 8)"
      unfolding minus_one_power_iff
      using \<open>2 < p\<close> \<open>0 < x\<close> \<open>odd x\<close> \<open>odd p\<close> and odd_odd_even_nat'
      using [[linarith_split_limit = 0]]
      by (force simp add: nat_mult_distrib even_nat_iff)

    finally show ?thesis .
  qed
qed simp_all

lemma mod_int_wlog [consumes 1, case_names modulo]:
  fixes P :: "int \<Rightarrow> bool"
  assumes "b > 0"
  assumes "\<And>k. 0 \<le> k \<Longrightarrow> k < b \<Longrightarrow> n mod b = k \<Longrightarrow> P n"
  shows   "P n"
  using assms and pos_mod_conj by blast

lemma supplement2_Jacobi':
  assumes "odd p" and "p > 1"
  shows "Jacobi 2 p = (if p mod 8 = 1 \<or> p mod 8 = 7 then 1 else -1)"
proof -
  have "0 < (4 :: nat)" by simp
  then have *: "even ((p\<^sup>2 - 1) div 8) = (p mod 8 = 1 \<or> p mod 8 = 7)" if "odd p" for p :: nat
  proof(induction p rule: mod_nat_wlog)
    case (modulo k)
    then consider "p mod 4 = 1" | "p mod 4 = 3"
      using \<open>odd p\<close>
      by (metis dvd_0_right even_even_mod_4_iff even_numeral mod_exhaust_less_4)

    then show ?case proof (cases)
      case 1
      then obtain l where l: "p = 4 * l + 1" using mod_natE by blast
      have "even l = ((4 * l + 1) mod 8 = 1 \<or> (4 * l + 1) mod 8 = 7)" by presburger
      thus ?thesis by (simp add: l power2_eq_square algebra_simps)
    next
      case 2
      then obtain l where l: "p = 4 * l + 3" using mod_natE by blast
      have "odd l = ((3 + l * 4) mod 8 = Suc 0 \<or> (3 + l * 4) mod 8 = 7)" by presburger
      thus ?thesis by (simp add: l power2_eq_square algebra_simps)
    qed
  qed

  have [simp]: "nat p mod 8 = nat (p mod 8)"
    using \<open>p > 1\<close> using nat_mod_distrib[of p 8] by simp
  from assms have "odd (nat p)" by (simp add: even_nat_iff)
  show ?thesis
    unfolding supplement2_Jacobi[OF assms]
              minus_one_power_iff *[OF \<open>odd (nat p)\<close>]
    by (simp add: nat_eq_iff)
qed

theorem supplement1_Jacobi:
  "odd p \<Longrightarrow> 1 < p \<Longrightarrow> Jacobi (-1) p = (-1) ^ (nat ((p - 1) div 2))"
proof (induction p rule: prime_divisors_induct)
  case (factor p x)
  then have "odd x" by force

  have "2 < p"
    using \<open>odd (p * x)\<close> prime_gt_1_int[OF \<open>prime p\<close>]
    by (cases "p = 2") auto

  have "prime (nat p)"
    using \<open>prime p\<close> prime_int_nat_transfer
    by blast

  have "Jacobi (-1) p = Legendre (-1) p"
    using prime_p_Jacobi_eq_Legendre[OF \<open>prime p\<close>] .

  also have "... = (-1) ^ ((nat p - 1) div 2)"
    using \<open>prime p\<close> \<open>2 < p\<close> and supplement1_Legendre[of "nat p"]
    by (metis int_nat_eq nat_mono_iff nat_numeral_as_int prime_gt_0_int prime_int_nat_transfer)

  also have "((nat p - 1) div 2) = nat ((p - 1) div 2)" by force

  finally have base_case: "Jacobi (-1) p = (-1) ^ nat ((p - 1) div 2)" .

  show ?case proof (cases "x = 1")
    case True
    then show ?thesis using base_case by simp
  next
    case False
    have "0 < x"
      using \<open>1 < (p * x)\<close> prime_gt_0_int[OF \<open>prime p\<close>]
      by (meson int_one_le_iff_zero_less not_less not_less_iff_gr_or_eq zero_less_mult_iff)

    have "odd p" using \<open>prime p\<close> \<open>2 < p\<close> by (simp add: prime_odd_int)

    have "Jacobi (-1) (p * x) = Jacobi (-1) p * Jacobi (-1) x"
      using \<open>2 < p\<close> \<open>0 < x\<close> by simp

    also note base_case

    also have "Jacobi (-1) x = (-1) ^ nat ((x - 1) div 2)"
      using \<open>0 < x\<close> False \<open>odd x\<close> factor.IH
      by fastforce

    also have "(- 1) ^ nat ((p - 1) div 2) * (- 1) ^ nat ((x - 1) div 2) =
               (- 1 :: int) ^ nat ((p*x - 1) div 2)"
      unfolding minus_one_power_iff
      using \<open>2 < p\<close> \<open>0 < x\<close> and \<open>odd x\<close> \<open>odd p\<close>
      by (fastforce elim!: oddE simp: even_nat_iff algebra_simps)

    finally show ?thesis .
  qed
qed simp_all

theorem supplement1_Jacobi':
  "odd n \<Longrightarrow> 1 < n \<Longrightarrow> Jacobi (-1) n = (if n mod 4 = 1 then 1 else -1)"
  by (simp add: even_nat_iff minus_one_power_iff supplement1_Jacobi)
     presburger?

lemma Jacobi_0_eq_0: "\<not>is_unit n \<Longrightarrow> Jacobi 0 n = 0"
  by (cases "prime_factorization n = {#}")
     (auto simp: Jacobi_def prime_factorization_empty_iff image_iff intro: Nat.gr0I)

lemma is_unit_Jacobi_aux: "is_unit x \<Longrightarrow> Jacobi a x = 1"
  unfolding Jacobi_def using prime_factorization_empty_iff[of x] by auto

lemma is_unit_Jacobi[simp]: "Jacobi a 1 = 1" "Jacobi a (-1) = 1"
  using is_unit_Jacobi_aux by simp_all

lemma Jacobi_neg_right [simp]:
  "Jacobi a (-n) = Jacobi a n"
proof -
  have * : "-n = (-1) * n" by simp
  show ?thesis unfolding *
    by (subst Jacobi_mult_right) auto
qed

lemma Jacobi_neg_left:
  assumes "odd n" "1 < n"
  shows   "Jacobi (-a) n = (if n mod 4 = 1 then 1 else -1) * Jacobi a n"
proof -
  have * : "-a = (-1) * a" by simp
  show ?thesis unfolding * Jacobi_mult_left supplement1_Jacobi'[OF assms] ..
qed

function jacobi_code :: "int \<Rightarrow> int \<Rightarrow> int" where
"jacobi_code a n = (
        if n = 0 then 0
   else if n = 1 then 1
   else if a = 1 then 1
   else if n < 0 then jacobi_code a (-n)
   else if even n then if even a then 0 else jacobi_code a (n div 2)
   else if a < 0 then (if n mod 4 = 1 then 1 else -1) * jacobi_code (-a) n
   else if a = 0 then 0
   else if a \<ge> n then jacobi_code (a mod n) n
   else if even a      then (if n mod 8 \<in> {1, 7} then 1 else -1) * jacobi_code (a div 2) n
   else if coprime a n then (if n mod 4 = 3 \<and> a mod 4 = 3 then -1 else 1) * jacobi_code n a
   else 0)"
  by auto
termination
proof (relation "measure (\<lambda>(a, n). nat(abs(a) + abs(n)*2) +
                   (if n < 0 then 1 else 0) + (if a < 0 then 1 else 0))", goal_cases)
  case (5 a n)
  thus ?case by (fastforce intro!: less_le_trans[OF pos_mod_bound])
qed auto

lemmas [simp del] = jacobi_code.simps

lemma Jacobi_code [code]: "Jacobi a n = jacobi_code a n"
proof (induction a n rule: jacobi_code.induct)
  case (1 a n)
  show ?case
  proof (cases "n = 0")
    case 2: False
    then show ?thesis proof (cases "n = 1")
      case 3: False
      then show ?thesis proof (cases "a = 1")
        case 4: False
          then show ?thesis proof (cases "n < 0")
            case True
            then show ?thesis using 2 3 4 1(1) by (subst jacobi_code.simps) simp
            next
            case 5: False
            then show ?thesis proof (cases "even n")
              case True
              then show ?thesis using 2 3 4 5 1(2)
                by (elim evenE, subst jacobi_code.simps) (auto simp: prime_p_Jacobi_eq_Legendre)
            next
              case 6: False
              then show ?thesis  proof (cases "a < 0")
                case True
                then show ?thesis using 2 3 4 5 6
                  by(subst jacobi_code.simps, subst 1(3)[symmetric]) (simp_all add: Jacobi_neg_left)
              next
                case 7: False
                then show ?thesis proof (cases "a = 0")
                  case True
                  have *: "\<not> is_unit n" using 3 5 by simp
                  then show ?thesis
                    using Jacobi_0_eq_0[OF *] 2 3 4 5 7 True
                    by (subst jacobi_code.simps) simp
                next
                  case 8: False
                  then show ?thesis proof (cases "a \<ge> n")
                    case True
                    then show ?thesis using 2 3 4 5 6 7 8 1(4)
                      by (subst jacobi_code.simps) simp
                  next
                    case 9: False
                    then show ?thesis proof (cases "even a")
                      case True
                      hence "a = 2 * (a div 2)" by simp
                      also have "Jacobi \<dots> n = Jacobi 2 n * Jacobi (a div 2) n"
                        by simp
                      also have "Jacobi (a div 2) n = jacobi_code (a div 2) n"
                        using 2 3 4 5 6 7 8 9 True by (intro 1(5))
                      also have "Jacobi 2 n = (if n mod 8 \<in> {1, 7} then 1 else - 1)"
                        using 2 3 5 supplement2_Jacobi'[OF 6] by simp
                      also have "\<dots> * jacobi_code (a div 2) n = jacobi_code a n"
                        using 2 3 4 5 6 7 8 9 True
                        by (subst (2) jacobi_code.simps) (simp only: if_False if_True HOL.simp_thms)
                      finally show ?thesis .
                    next
                      case 10: False
                      note foo = 1 2 3
                      then show ?thesis proof (cases "coprime a n")
                        case True
                        note this_case = 2 3 4 5 6 7 8 9 10 True
                        have "2 < a" using 10 4 7 by presburger
                        moreover have "2 < n" using 3 5 6 by presburger
                        ultimately have "jacobi_code a n = (if n mod 4 = 3 \<and> a mod 4 = 3 then - 1 else 1)
                                                        * jacobi_code n a"
                          using this_case by (subst jacobi_code.simps) simp
                        also have "jacobi_code n a = Jacobi n a"
                          using this_case by (intro 1(6) [symmetric]) auto
                        also have "(if n mod 4 = 3 \<and> a mod 4 = 3 then -1 else 1) * \<dots> = Jacobi a n"
                          using this_case and \<open>2 < a\<close>
                          by (intro Quadratic_Reciprocity_Jacobi' [symmetric])
                             (auto simp: coprime_commute)
                        finally show ?thesis ..
                      next
                        case False
                        have *: "0 < a" "0 < n" using 5 7 8 9 by linarith+
                        show ?thesis
                          using 1 2 3 4 5 6 7 8 9 10 False *
                          by (subst jacobi_code.simps) (auto simp: Jacobi_eq_0_not_coprime)
                      qed
                    qed
                  qed
                qed
              qed
            qed
        qed
      qed (subst jacobi_code.simps, simp)
    qed (subst jacobi_code.simps, simp)
  qed (subst jacobi_code.simps, simp)
qed

lemma Jacobi_eq_0_imp_not_coprime:
  assumes "p \<noteq> 0" "p \<noteq> 1"
  shows   "Jacobi n p = 0 \<Longrightarrow> \<not>coprime n p"
  using assms Jacobi_mod_cong coprime_iff_invertible_int by force

lemma Jacobi_eq_0_iff_not_coprime:
  assumes "p \<noteq> 0" "p \<noteq> 1"
  shows "Jacobi n p = 0 \<longleftrightarrow> \<not>coprime n p"
proof -
  from assms and Jacobi_eq_0_imp_not_coprime
  show ?thesis using Jacobi_eq_0_not_coprime by auto
qed

end


(*  Title:    HOL/Analysis/Harmonic_Numbers.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Harmonic Numbers\<close>

theory Harmonic_Numbers
imports
  Complex_Transcendental
  Summation_Tests
  Integral_Test
begin

text \<open>
  The definition of the Harmonic Numbers and the Euler-Mascheroni constant.
  Also provides a reasonably accurate approximation of @{term "ln 2 :: real"}
  and the Euler-Mascheroni constant.
\<close>

lemma ln_2_less_1: "ln 2 < (1::real)"
proof -
  have "2 < 5/(2::real)" by simp
  also have "5/2 \<le> exp (1::real)" using exp_lower_taylor_quadratic[of 1, simplified] by simp
  finally have "exp (ln 2) < exp (1::real)" by simp
  thus "ln 2 < (1::real)" by (subst (asm) exp_less_cancel_iff) simp
qed

lemma sum_Suc_diff':
  fixes f :: "nat \<Rightarrow> 'a::ab_group_add"
  assumes "m \<le> n"
  shows "(\<Sum>i = m..<n. f (Suc i) - f i) = f n - f m"
using assms by (induct n) (auto simp: le_Suc_eq)

subsection \<open>The Harmonic numbers\<close>

definition harm :: "nat \<Rightarrow> 'a :: real_normed_field" where
  "harm n = (\<Sum>k=1..n. inverse (of_nat k))"

lemma harm_altdef: "harm n = (\<Sum>k<n. inverse (of_nat (Suc k)))"
  unfolding harm_def by (induction n) simp_all

lemma harm_Suc: "harm (Suc n) = harm n + inverse (of_nat (Suc n))"
  by (simp add: harm_def)

lemma harm_nonneg: "harm n \<ge> (0 :: 'a :: {real_normed_field,linordered_field})"
  unfolding harm_def by (intro sum_nonneg) simp_all

lemma harm_pos: "n > 0 \<Longrightarrow> harm n > (0 :: 'a :: {real_normed_field,linordered_field})"
  unfolding harm_def by (intro sum_pos) simp_all

lemma of_real_harm: "of_real (harm n) = harm n"
  unfolding harm_def by simp

lemma norm_harm: "norm (harm n) = harm n"
  by (subst of_real_harm [symmetric]) (simp add: harm_nonneg)

lemma harm_expand:
  "harm 0 = 0"
  "harm (Suc 0) = 1"
  "harm (numeral n) = harm (pred_numeral n) + inverse (numeral n)"
proof -
  have "numeral n = Suc (pred_numeral n)" by simp
  also have "harm \<dots> = harm (pred_numeral n) + inverse (numeral n)"
    by (subst harm_Suc, subst numeral_eq_Suc[symmetric]) simp
  finally show "harm (numeral n) = harm (pred_numeral n) + inverse (numeral n)" .
qed (simp_all add: harm_def)

lemma not_convergent_harm: "\<not>convergent (harm :: nat \<Rightarrow> 'a :: real_normed_field)"
proof -
  have "convergent (\<lambda>n. norm (harm n :: 'a)) \<longleftrightarrow>
            convergent (harm :: nat \<Rightarrow> real)" by (simp add: norm_harm)
  also have "\<dots> \<longleftrightarrow> convergent (\<lambda>n. \<Sum>k=Suc 0..Suc n. inverse (of_nat k) :: real)"
    unfolding harm_def[abs_def] by (subst convergent_Suc_iff) simp_all
  also have "... \<longleftrightarrow> convergent (\<lambda>n. \<Sum>k\<le>n. inverse (of_nat (Suc k)) :: real)"
    by (subst sum_shift_bounds_cl_Suc_ivl) (simp add: atLeast0AtMost)
  also have "... \<longleftrightarrow> summable (\<lambda>n. inverse (of_nat n) :: real)"
    by (subst summable_Suc_iff [symmetric]) (simp add: summable_iff_convergent')
  also have "\<not>..." by (rule not_summable_harmonic)
  finally show ?thesis by (blast dest: convergent_norm)
qed

lemma harm_pos_iff [simp]: "harm n > (0 :: 'a :: {real_normed_field,linordered_field}) \<longleftrightarrow> n > 0"
  by (rule iffI, cases n, simp add: harm_expand, simp, rule harm_pos)

lemma ln_diff_le_inverse:
  assumes "x \<ge> (1::real)"
  shows   "ln (x + 1) - ln x < 1 / x"
proof -
  from assms have "\<exists>z>x. z < x + 1 \<and> ln (x + 1) - ln x = (x + 1 - x) * inverse z"
    by (intro MVT2) (auto intro!: derivative_eq_intros simp: field_simps)
  then obtain z where z: "z > x" "z < x + 1" "ln (x + 1) - ln x = inverse z" by auto
  have "ln (x + 1) - ln x = inverse z" by fact
  also from z(1,2) assms have "\<dots> < 1 / x" by (simp add: field_simps)
  finally show ?thesis .
qed

lemma ln_le_harm: "ln (real n + 1) \<le> (harm n :: real)"
proof (induction n)
  fix n assume IH: "ln (real n + 1) \<le> harm n"
  have "ln (real (Suc n) + 1) = ln (real n + 1) + (ln (real n + 2) - ln (real n + 1))" by simp
  also have "(ln (real n + 2) - ln (real n + 1)) \<le> 1 / real (Suc n)"
    using ln_diff_le_inverse[of "real n + 1"] by (simp add: add_ac)
  also note IH
  also have "harm n + 1 / real (Suc n) = harm (Suc n)" by (simp add: harm_Suc field_simps)
  finally show "ln (real (Suc n) + 1) \<le> harm (Suc n)" by - simp
qed (simp_all add: harm_def)

subsection \<open>The Euler--Mascheroni constant\<close>

text \<open>
  The limit of the difference between the partial harmonic sum and the natural logarithm
  (approximately 0.577216). This value occurs e.g. in the definition of the Gamma function.
 \<close>
definition euler_mascheroni :: "'a :: real_normed_algebra_1" where
  "euler_mascheroni = of_real (lim (\<lambda>n. harm n - ln (of_nat n)))"

lemma of_real_euler_mascheroni [simp]: "of_real euler_mascheroni = euler_mascheroni"
  by (simp add: euler_mascheroni_def)

interpretation euler_mascheroni: antimono_fun_sum_integral_diff "\<lambda>x. inverse (x + 1)"
  by unfold_locales (auto intro!: continuous_intros)

lemma euler_mascheroni_sum_integral_diff_series:
  "euler_mascheroni.sum_integral_diff_series n = harm (Suc n) - ln (of_nat (Suc n))"
proof -
  have "harm (Suc n) = (\<Sum>k=0..n. inverse (of_nat k + 1) :: real)" unfolding harm_def
    unfolding One_nat_def by (subst sum_shift_bounds_cl_Suc_ivl) (simp add: add_ac)
  moreover have "((\<lambda>x. inverse (x + 1) :: real) has_integral ln (of_nat n + 1) - ln (0 + 1))
                   {0..of_nat n}"
    by (intro fundamental_theorem_of_calculus)
       (auto intro!: derivative_eq_intros simp: divide_inverse
           has_field_derivative_iff_has_vector_derivative[symmetric])
  hence "integral {0..of_nat n} (\<lambda>x. inverse (x + 1) :: real) = ln (of_nat (Suc n))"
    by (auto dest!: integral_unique)
  ultimately show ?thesis
    by (simp add: euler_mascheroni.sum_integral_diff_series_def atLeast0AtMost)
qed

lemma euler_mascheroni_sequence_decreasing:
  "m > 0 \<Longrightarrow> m \<le> n \<Longrightarrow> harm n - ln (of_nat n) \<le> harm m - ln (of_nat m :: real)"
  by (cases m, simp, cases n, simp, hypsubst,
      subst (1 2) euler_mascheroni_sum_integral_diff_series [symmetric],
      rule euler_mascheroni.sum_integral_diff_series_antimono, simp)

lemma euler_mascheroni_sequence_nonneg:
  "n > 0 \<Longrightarrow> harm n - ln (of_nat n) \<ge> (0::real)"
  by (cases n, simp, hypsubst, subst euler_mascheroni_sum_integral_diff_series [symmetric],
      rule euler_mascheroni.sum_integral_diff_series_nonneg)

lemma euler_mascheroni_convergent: "convergent (\<lambda>n. harm n - ln (of_nat n) :: real)"
proof -
  have A: "(\<lambda>n. harm (Suc n) - ln (of_nat (Suc n))) =
             euler_mascheroni.sum_integral_diff_series"
    by (subst euler_mascheroni_sum_integral_diff_series [symmetric]) (rule refl)
  have "convergent (\<lambda>n. harm (Suc n) - ln (of_nat (Suc n) :: real))"
    by (subst A) (fact euler_mascheroni.sum_integral_diff_series_convergent)
  thus ?thesis by (subst (asm) convergent_Suc_iff)
qed

lemma euler_mascheroni_LIMSEQ:
  "(\<lambda>n. harm n - ln (of_nat n) :: real) \<longlonglongrightarrow> euler_mascheroni"
  unfolding euler_mascheroni_def
  by (simp add: convergent_LIMSEQ_iff [symmetric] euler_mascheroni_convergent)

lemma euler_mascheroni_LIMSEQ_of_real:
  "(\<lambda>n. of_real (harm n - ln (of_nat n))) \<longlonglongrightarrow>
      (euler_mascheroni :: 'a :: {real_normed_algebra_1, topological_space})"
proof -
  have "(\<lambda>n. of_real (harm n - ln (of_nat n))) \<longlonglongrightarrow> (of_real (euler_mascheroni) :: 'a)"
    by (intro tendsto_of_real euler_mascheroni_LIMSEQ)
  thus ?thesis by simp
qed

lemma euler_mascheroni_sum_real:
  "(\<lambda>n. inverse (of_nat (n+1)) + ln (of_nat (n+1)) - ln (of_nat (n+2)) :: real)
       sums euler_mascheroni"
 using sums_add[OF telescope_sums[OF LIMSEQ_Suc[OF euler_mascheroni_LIMSEQ]]
                   telescope_sums'[OF LIMSEQ_inverse_real_of_nat]]
  by (simp_all add: harm_def algebra_simps)

lemma euler_mascheroni_sum:
  "(\<lambda>n. inverse (of_nat (n+1)) + of_real (ln (of_nat (n+1))) - of_real (ln (of_nat (n+2))))
       sums (euler_mascheroni :: 'a :: {banach, real_normed_field})"
proof -
  have "(\<lambda>n. of_real (inverse (of_nat (n+1)) + ln (of_nat (n+1)) - ln (of_nat (n+2))))
       sums (of_real euler_mascheroni :: 'a :: {banach, real_normed_field})"
    by (subst sums_of_real_iff) (rule euler_mascheroni_sum_real)
  thus ?thesis by simp
qed

lemma alternating_harmonic_series_sums: "(\<lambda>k. (-1)^k / real_of_nat (Suc k)) sums ln 2"
proof -
  let ?f = "\<lambda>n. harm n - ln (real_of_nat n)"
  let ?g = "\<lambda>n. if even n then 0 else (2::real)"
  let ?em = "\<lambda>n. harm n - ln (real_of_nat n)"
  have "eventually (\<lambda>n. ?em (2*n) - ?em n + ln 2 = (\<Sum>k<2*n. (-1)^k / real_of_nat (Suc k))) at_top"
    using eventually_gt_at_top[of "0::nat"]
  proof eventually_elim
    fix n :: nat assume n: "n > 0"
    have "(\<Sum>k<2*n. (-1)^k / real_of_nat (Suc k)) =
              (\<Sum>k<2*n. ((-1)^k + ?g k) / of_nat (Suc k)) - (\<Sum>k<2*n. ?g k / of_nat (Suc k))"
      by (simp add: sum.distrib algebra_simps divide_inverse)
    also have "(\<Sum>k<2*n. ((-1)^k + ?g k) / real_of_nat (Suc k)) = harm (2*n)"
      unfolding harm_altdef by (intro sum.cong) (auto simp: field_simps)
    also have "(\<Sum>k<2*n. ?g k / real_of_nat (Suc k)) = (\<Sum>k|k<2*n \<and> odd k. ?g k / of_nat (Suc k))"
      by (intro sum.mono_neutral_right) auto
    also have "\<dots> = (\<Sum>k|k<2*n \<and> odd k. 2 / (real_of_nat (Suc k)))"
      by (intro sum.cong) auto
    also have "(\<Sum>k|k<2*n \<and> odd k. 2 / (real_of_nat (Suc k))) = harm n"
      unfolding harm_altdef
      by (intro sum.reindex_cong[of "\<lambda>n. 2*n+1"]) (auto simp: inj_on_def field_simps elim!: oddE)
    also have "harm (2*n) - harm n = ?em (2*n) - ?em n + ln 2" using n
      by (simp_all add: algebra_simps ln_mult)
    finally show "?em (2*n) - ?em n + ln 2 = (\<Sum>k<2*n. (-1)^k / real_of_nat (Suc k))" ..
  qed
  moreover have "(\<lambda>n. ?em (2*n) - ?em n + ln (2::real))
                     \<longlonglongrightarrow> euler_mascheroni - euler_mascheroni + ln 2"
    by (intro tendsto_intros euler_mascheroni_LIMSEQ filterlim_compose[OF euler_mascheroni_LIMSEQ]
              filterlim_subseq) (auto simp: subseq_def)
  hence "(\<lambda>n. ?em (2*n) - ?em n + ln (2::real)) \<longlonglongrightarrow> ln 2" by simp
  ultimately have "(\<lambda>n. (\<Sum>k<2*n. (-1)^k / real_of_nat (Suc k))) \<longlonglongrightarrow> ln 2"
    by (rule Lim_transform_eventually)

  moreover have "summable (\<lambda>k. (-1)^k * inverse (real_of_nat (Suc k)))"
    using LIMSEQ_inverse_real_of_nat
    by (intro summable_Leibniz(1) decseq_imp_monoseq decseq_SucI) simp_all
  hence A: "(\<lambda>n. \<Sum>k<n. (-1)^k / real_of_nat (Suc k)) \<longlonglongrightarrow> (\<Sum>k. (-1)^k / real_of_nat (Suc k))"
    by (simp add: summable_sums_iff divide_inverse sums_def)
  from filterlim_compose[OF this filterlim_subseq[of "op * (2::nat)"]]
    have "(\<lambda>n. \<Sum>k<2*n. (-1)^k / real_of_nat (Suc k)) \<longlonglongrightarrow> (\<Sum>k. (-1)^k / real_of_nat (Suc k))"
    by (simp add: subseq_def)
  ultimately have "(\<Sum>k. (- 1) ^ k / real_of_nat (Suc k)) = ln 2" by (intro LIMSEQ_unique)
  with A show ?thesis by (simp add: sums_def)
qed

lemma alternating_harmonic_series_sums':
  "(\<lambda>k. inverse (real_of_nat (2*k+1)) - inverse (real_of_nat (2*k+2))) sums ln 2"
unfolding sums_def
proof (rule Lim_transform_eventually)
  show "(\<lambda>n. \<Sum>k<2*n. (-1)^k / (real_of_nat (Suc k))) \<longlonglongrightarrow> ln 2"
    using alternating_harmonic_series_sums unfolding sums_def
    by (rule filterlim_compose) (rule mult_nat_left_at_top, simp)
  show "eventually (\<lambda>n. (\<Sum>k<2*n. (-1)^k / (real_of_nat (Suc k))) =
            (\<Sum>k<n. inverse (real_of_nat (2*k+1)) - inverse (real_of_nat (2*k+2)))) sequentially"
  proof (intro always_eventually allI)
    fix n :: nat
    show "(\<Sum>k<2*n. (-1)^k / (real_of_nat (Suc k))) =
              (\<Sum>k<n. inverse (real_of_nat (2*k+1)) - inverse (real_of_nat (2*k+2)))"
      by (induction n) (simp_all add: inverse_eq_divide)
  qed
qed

subsection \<open>Bounds on the Euler--Mascheroni constant\<close>

(* TODO: Move? *)
lemma ln_inverse_approx_le:
  assumes "(x::real) > 0" "a > 0"
  shows   "ln (x + a) - ln x \<le> a * (inverse x + inverse (x + a))/2" (is "_ \<le> ?A")
proof -
  define f' where "f' = (inverse (x + a) - inverse x)/a"
  have f'_nonpos: "f' \<le> 0" using assms by (simp add: f'_def divide_simps)
  let ?f = "\<lambda>t. (t - x) * f' + inverse x"
  let ?F = "\<lambda>t. (t - x)^2 * f' / 2 + t * inverse x"
  have diff: "\<forall>t\<in>{x..x+a}. (?F has_vector_derivative ?f t)
                               (at t within {x..x+a})" using assms
    by (auto intro!: derivative_eq_intros
             simp: has_field_derivative_iff_has_vector_derivative[symmetric])
  from assms have "(?f has_integral (?F (x+a) - ?F x)) {x..x+a}"
    by (intro fundamental_theorem_of_calculus[OF _ diff])
       (auto simp: has_field_derivative_iff_has_vector_derivative[symmetric] field_simps
             intro!: derivative_eq_intros)
  also have "?F (x+a) - ?F x = (a*2 + f'*a\<^sup>2*x) / (2*x)" using assms by (simp add: field_simps)
  also have "f'*a^2 = - (a^2) / (x*(x + a))" using assms
    by (simp add: divide_simps f'_def power2_eq_square)
  also have "(a*2 + - a\<^sup>2/(x*(x+a))*x) / (2*x) = ?A" using assms
    by (simp add: divide_simps power2_eq_square) (simp add: algebra_simps)
  finally have int1: "((\<lambda>t. (t - x) * f' + inverse x) has_integral ?A) {x..x + a}" .

  from assms have int2: "(inverse has_integral (ln (x + a) - ln x)) {x..x+a}"
    by (intro fundamental_theorem_of_calculus)
       (auto simp: has_field_derivative_iff_has_vector_derivative[symmetric] divide_simps
             intro!: derivative_eq_intros)
  hence "ln (x + a) - ln x = integral {x..x+a} inverse" by (simp add: integral_unique)
  also have ineq: "\<forall>xa\<in>{x..x + a}. inverse xa \<le> (xa - x) * f' + inverse x"
  proof
    fix t assume t': "t \<in> {x..x+a}"
    with assms have t: "0 \<le> (t - x) / a" "(t - x) / a \<le> 1" by simp_all
    have "inverse t = inverse ((1 - (t - x) / a) *\<^sub>R x + ((t - x) / a) *\<^sub>R (x + a))" (is "_ = ?A")
      using assms t' by (simp add: field_simps)
    also from assms have "convex_on {x..x+a} inverse" by (intro convex_on_inverse) auto
    from convex_onD_Icc[OF this _ t] assms
      have "?A \<le> (1 - (t - x) / a) * inverse x + (t - x) / a * inverse (x + a)" by simp
    also have "\<dots> = (t - x) * f' + inverse x" using assms
      by (simp add: f'_def divide_simps) (simp add: f'_def field_simps)
    finally show "inverse t \<le> (t - x) * f' + inverse x" .
  qed
  hence "integral {x..x+a} inverse \<le> integral {x..x+a} ?f" using f'_nonpos assms
    by (intro integral_le has_integral_integrable[OF int1] has_integral_integrable[OF int2] ineq)
  also have "\<dots> = ?A" using int1 by (rule integral_unique)
  finally show ?thesis .
qed

lemma ln_inverse_approx_ge:
  assumes "(x::real) > 0" "x < y"
  shows   "ln y - ln x \<ge> 2 * (y - x) / (x + y)" (is "_ \<ge> ?A")
proof -
  define m where "m = (x+y)/2"
  define f' where "f' = -inverse (m^2)"
  from assms have m: "m > 0" by (simp add: m_def)
  let ?F = "\<lambda>t. (t - m)^2 * f' / 2 + t / m"
  from assms have "((\<lambda>t. (t - m) * f' + inverse m) has_integral (?F y - ?F x)) {x..y}"
    by (intro fundamental_theorem_of_calculus)
       (auto simp: has_field_derivative_iff_has_vector_derivative[symmetric] divide_simps
             intro!: derivative_eq_intros)
  also from m have "?F y - ?F x = ((y - m)^2 - (x - m)^2) * f' / 2 + (y - x) / m"
    by (simp add: field_simps)
  also have "((y - m)^2 - (x - m)^2) = 0" by (simp add: m_def power2_eq_square field_simps)
  also have "0 * f' / 2 + (y - x) / m = ?A" by (simp add: m_def)
  finally have int1: "((\<lambda>t. (t - m) * f' + inverse m) has_integral ?A) {x..y}" .

  from assms have int2: "(inverse has_integral (ln y - ln x)) {x..y}"
    by (intro fundamental_theorem_of_calculus)
       (auto simp: has_field_derivative_iff_has_vector_derivative[symmetric] divide_simps
             intro!: derivative_eq_intros)
  hence "ln y - ln x = integral {x..y} inverse" by (simp add: integral_unique)
  also have ineq: "\<forall>xa\<in>{x..y}. inverse xa \<ge> (xa - m) * f' + inverse m"
  proof
    fix t assume t: "t \<in> {x..y}"
    from t assms have "inverse t - inverse m \<ge> f' * (t - m)"
      by (intro convex_on_imp_above_tangent[of "{0<..}"] convex_on_inverse)
         (auto simp: m_def interior_open f'_def power2_eq_square intro!: derivative_eq_intros)
    thus "(t - m) * f' + inverse m \<le> inverse t" by (simp add: algebra_simps)
  qed
  hence "integral {x..y} inverse \<ge> integral {x..y} (\<lambda>t. (t - m) * f' + inverse m)"
    using int1 int2 by (intro integral_le has_integral_integrable)
  also have "integral {x..y} (\<lambda>t. (t - m) * f' + inverse m) = ?A"
    using integral_unique[OF int1] by simp
  finally show ?thesis .
qed

lemma euler_mascheroni_lower:
        "euler_mascheroni \<ge> harm (Suc n) - ln (real_of_nat (n + 2)) + 1/real_of_nat (2 * (n + 2))"
  and euler_mascheroni_upper:
        "euler_mascheroni \<le> harm (Suc n) - ln (real_of_nat (n + 2)) + 1/real_of_nat (2 * (n + 1))"
proof -
  define D :: "_ \<Rightarrow> real"
    where "D n = inverse (of_nat (n+1)) + ln (of_nat (n+1)) - ln (of_nat (n+2))" for n
  let ?g = "\<lambda>n. ln (of_nat (n+2)) - ln (of_nat (n+1)) - inverse (of_nat (n+1)) :: real"
  define inv where [abs_def]: "inv n = inverse (real_of_nat n)" for n
  fix n :: nat
  note summable = sums_summable[OF euler_mascheroni_sum_real, folded D_def]
  have sums: "(\<lambda>k. (inv (Suc (k + (n+1))) - inv (Suc (Suc k + (n+1))))/2) sums ((inv (Suc (0 + (n+1))) - 0)/2)"
    unfolding inv_def
    by (intro sums_divide telescope_sums' LIMSEQ_ignore_initial_segment LIMSEQ_inverse_real_of_nat)
  have sums': "(\<lambda>k. (inv (Suc (k + n)) - inv (Suc (Suc k + n)))/2) sums ((inv (Suc (0 + n)) - 0)/2)"
    unfolding inv_def
    by (intro sums_divide telescope_sums' LIMSEQ_ignore_initial_segment LIMSEQ_inverse_real_of_nat)
  from euler_mascheroni_sum_real have "euler_mascheroni = (\<Sum>k. D k)"
    by (simp add: sums_iff D_def)
  also have "\<dots> = (\<Sum>k. D (k + Suc n)) + (\<Sum>k\<le>n. D k)"
    by (subst suminf_split_initial_segment[OF summable, of "Suc n"],
        subst lessThan_Suc_atMost) simp
  finally have sum: "(\<Sum>k\<le>n. D k) - euler_mascheroni = -(\<Sum>k. D (k + Suc n))" by simp

  note sum
  also have "\<dots> \<le> -(\<Sum>k. (inv (k + Suc n + 1) - inv (k + Suc n + 2)) / 2)"
  proof (intro le_imp_neg_le suminf_le allI summable_ignore_initial_segment[OF summable])
    fix k' :: nat
    define k where "k = k' + Suc n"
    hence k: "k > 0" by (simp add: k_def)
    have "real_of_nat (k+1) > 0" by (simp add: k_def)
    with ln_inverse_approx_le[OF this zero_less_one]
      have "ln (of_nat k + 2) - ln (of_nat k + 1) \<le> (inv (k+1) + inv (k+2))/2"
      by (simp add: inv_def add_ac)
    hence "(inv (k+1) - inv (k+2))/2 \<le> inv (k+1) + ln (of_nat (k+1)) - ln (of_nat (k+2))"
      by (simp add: field_simps)
    also have "\<dots> = D k" unfolding D_def inv_def ..
    finally show "D (k' + Suc n) \<ge> (inv (k' + Suc n + 1) - inv (k' + Suc n + 2)) / 2"
      by (simp add: k_def)
    from sums_summable[OF sums]
      show "summable (\<lambda>k. (inv (k + Suc n + 1) - inv (k + Suc n + 2))/2)" by simp
  qed
  also from sums have "\<dots> = -inv (n+2) / 2" by (simp add: sums_iff)
  finally have "euler_mascheroni \<ge> (\<Sum>k\<le>n. D k) + 1 / (of_nat (2 * (n+2)))"
    by (simp add: inv_def field_simps)
  also have "(\<Sum>k\<le>n. D k) = harm (Suc n) - (\<Sum>k\<le>n. ln (real_of_nat (Suc k+1)) - ln (of_nat (k+1)))"
    unfolding harm_altdef D_def by (subst lessThan_Suc_atMost) (simp add:  sum.distrib sum_subtractf)
  also have "(\<Sum>k\<le>n. ln (real_of_nat (Suc k+1)) - ln (of_nat (k+1))) = ln (of_nat (n+2))"
    by (subst atLeast0AtMost [symmetric], subst sum_Suc_diff) simp_all
  finally show "euler_mascheroni \<ge> harm (Suc n) - ln (real_of_nat (n + 2)) + 1/real_of_nat (2 * (n + 2))"
    by simp

  note sum
  also have "-(\<Sum>k. D (k + Suc n)) \<ge> -(\<Sum>k. (inv (Suc (k + n)) - inv (Suc (Suc k + n)))/2)"
  proof (intro le_imp_neg_le suminf_le allI summable_ignore_initial_segment[OF summable])
    fix k' :: nat
    define k where "k = k' + Suc n"
    hence k: "k > 0" by (simp add: k_def)
    have "real_of_nat (k+1) > 0" by (simp add: k_def)
    from ln_inverse_approx_ge[of "of_nat k + 1" "of_nat k + 2"]
      have "2 / (2 * real_of_nat k + 3) \<le> ln (of_nat (k+2)) - ln (real_of_nat (k+1))"
      by (simp add: add_ac)
    hence "D k \<le> 1 / real_of_nat (k+1) - 2 / (2 * real_of_nat k + 3)"
      by (simp add: D_def inverse_eq_divide inv_def)
    also have "\<dots> = inv ((k+1)*(2*k+3))" unfolding inv_def by (simp add: field_simps)
    also have "\<dots> \<le> inv (2*k*(k+1))" unfolding inv_def using k
      by (intro le_imp_inverse_le)
         (simp add: algebra_simps, simp del: of_nat_add)
    also have "\<dots> = (inv k - inv (k+1))/2" unfolding inv_def using k
      by (simp add: divide_simps del: of_nat_mult) (simp add: algebra_simps)
    finally show "D k \<le> (inv (Suc (k' + n)) - inv (Suc (Suc k' + n)))/2" unfolding k_def by simp
  next
    from sums_summable[OF sums']
      show "summable (\<lambda>k. (inv (Suc (k + n)) - inv (Suc (Suc k + n)))/2)" by simp
  qed
  also from sums' have "(\<Sum>k. (inv (Suc (k + n)) - inv (Suc (Suc k + n)))/2) = inv (n+1)/2"
    by (simp add: sums_iff)
  finally have "euler_mascheroni \<le> (\<Sum>k\<le>n. D k) + 1 / of_nat (2 * (n+1))"
    by (simp add: inv_def field_simps)
  also have "(\<Sum>k\<le>n. D k) = harm (Suc n) - (\<Sum>k\<le>n. ln (real_of_nat (Suc k+1)) - ln (of_nat (k+1)))"
    unfolding harm_altdef D_def by (subst lessThan_Suc_atMost) (simp add:  sum.distrib sum_subtractf)
  also have "(\<Sum>k\<le>n. ln (real_of_nat (Suc k+1)) - ln (of_nat (k+1))) = ln (of_nat (n+2))"
    by (subst atLeast0AtMost [symmetric], subst sum_Suc_diff) simp_all
  finally show "euler_mascheroni \<le> harm (Suc n) - ln (real_of_nat (n + 2)) + 1/real_of_nat (2 * (n + 1))"
    by simp
qed

lemma euler_mascheroni_pos: "euler_mascheroni > (0::real)"
  using euler_mascheroni_lower[of 0] ln_2_less_1 by (simp add: harm_def)

context
begin

private lemma ln_approx_aux:
  fixes n :: nat and x :: real
  defines "y \<equiv> (x-1)/(x+1)"
  assumes x: "x > 0" "x \<noteq> 1"
  shows "inverse (2*y^(2*n+1)) * (ln x - (\<Sum>k<n. 2*y^(2*k+1) / of_nat (2*k+1))) \<in>
            {0..(1 / (1 - y^2) / of_nat (2*n+1))}"
proof -
  from x have norm_y: "norm y < 1" unfolding y_def by simp
  from power_strict_mono[OF this, of 2] have norm_y': "norm y^2 < 1" by simp

  let ?f = "\<lambda>k. 2 * y ^ (2*k+1) / of_nat (2*k+1)"
  note sums = ln_series_quadratic[OF x(1)]
  define c where "c = inverse (2*y^(2*n+1))"
  let ?d = "c * (ln x - (\<Sum>k<n. ?f k))"
  have "\<forall>k. y\<^sup>2^k / of_nat (2*(k+n)+1) \<le> y\<^sup>2 ^ k / of_nat (2*n+1)"
    by (intro allI divide_left_mono mult_right_mono mult_pos_pos zero_le_power[of "y^2"]) simp_all
  moreover {
    have "(\<lambda>k. ?f (k + n)) sums (ln x - (\<Sum>k<n. ?f k))"
      using sums_split_initial_segment[OF sums] by (simp add: y_def)
    hence "(\<lambda>k. c * ?f (k + n)) sums ?d" by (rule sums_mult)
    also have "(\<lambda>k. c * (2*y^(2*(k+n)+1) / of_nat (2*(k+n)+1))) =
                   (\<lambda>k. (c * (2*y^(2*n+1))) * ((y^2)^k / of_nat (2*(k+n)+1)))"
      by (simp only: ring_distribs power_add power_mult) (simp add: mult_ac)
    also from x have "c * (2*y^(2*n+1)) = 1" by (simp add: c_def y_def)
    finally have "(\<lambda>k. (y^2)^k / of_nat (2*(k+n)+1)) sums ?d" by simp
  } note sums' = this
  moreover from norm_y' have "(\<lambda>k. (y^2)^k / of_nat (2*n+1)) sums (1 / (1 - y^2) / of_nat (2*n+1))"
    by (intro sums_divide geometric_sums) (simp_all add: norm_power)
  ultimately have "?d \<le> (1 / (1 - y^2) / of_nat (2*n+1))" by (rule sums_le)
  moreover have "c * (ln x - (\<Sum>k<n. 2 * y ^ (2 * k + 1) / real_of_nat (2 * k + 1))) \<ge> 0"
    by (intro sums_le[OF _ sums_zero sums']) simp_all
  ultimately show ?thesis unfolding c_def by simp
qed

lemma
  fixes n :: nat and x :: real
  defines "y \<equiv> (x-1)/(x+1)"
  defines "approx \<equiv> (\<Sum>k<n. 2*y^(2*k+1) / of_nat (2*k+1))"
  defines "d \<equiv> y^(2*n+1) / (1 - y^2) / of_nat (2*n+1)"
  assumes x: "x > 1"
  shows   ln_approx_bounds: "ln x \<in> {approx..approx + 2*d}"
  and     ln_approx_abs:    "abs (ln x - (approx + d)) \<le> d"
proof -
  define c where "c = 2*y^(2*n+1)"
  from x have c_pos: "c > 0" unfolding c_def y_def
    by (intro mult_pos_pos zero_less_power) simp_all
  have A: "inverse c * (ln x - (\<Sum>k<n. 2*y^(2*k+1) / of_nat (2*k+1))) \<in>
              {0.. (1 / (1 - y^2) / of_nat (2*n+1))}" using assms unfolding y_def c_def
    by (intro ln_approx_aux) simp_all
  hence "inverse c * (ln x - (\<Sum>k<n. 2*y^(2*k+1)/of_nat (2*k+1))) \<le> (1 / (1-y^2) / of_nat (2*n+1))"
    by simp
  hence "(ln x - (\<Sum>k<n. 2*y^(2*k+1) / of_nat (2*k+1))) / c \<le> (1 / (1 - y^2) / of_nat (2*n+1))"
    by (auto simp add: divide_simps)
  with c_pos have "ln x \<le> c / (1 - y^2) / of_nat (2*n+1) + approx"
    by (subst (asm) pos_divide_le_eq) (simp_all add: mult_ac approx_def)
  moreover {
    from A c_pos have "0 \<le> c * (inverse c * (ln x - (\<Sum>k<n. 2*y^(2*k+1) / of_nat (2*k+1))))"
      by (intro mult_nonneg_nonneg[of c]) simp_all
    also have "\<dots> = (c * inverse c) * (ln x - (\<Sum>k<n. 2*y^(2*k+1) / of_nat (2*k+1)))"
      by (simp add: mult_ac)
    also from c_pos have "c * inverse c = 1" by simp
    finally have "ln x \<ge> approx" by (simp add: approx_def)
  }
  ultimately show "ln x \<in> {approx..approx + 2*d}" by (simp add: c_def d_def)
  thus "abs (ln x - (approx + d)) \<le> d" by auto
qed

end

lemma euler_mascheroni_bounds:
  fixes n :: nat assumes "n \<ge> 1" defines "t \<equiv> harm n - ln (of_nat (Suc n)) :: real"
  shows "euler_mascheroni \<in> {t + inverse (of_nat (2*(n+1)))..t + inverse (of_nat (2*n))}"
  using assms euler_mascheroni_upper[of "n-1"] euler_mascheroni_lower[of "n-1"]
  unfolding t_def by (cases n) (simp_all add: harm_Suc t_def inverse_eq_divide)

lemma euler_mascheroni_bounds':
  fixes n :: nat assumes "n \<ge> 1" "ln (real_of_nat (Suc n)) \<in> {l<..<u}"
  shows "euler_mascheroni \<in>
           {harm n - u + inverse (of_nat (2*(n+1)))<..<harm n - l + inverse (of_nat (2*n))}"
  using euler_mascheroni_bounds[OF assms(1)] assms(2) by auto

text \<open>
  Approximation of @{term "ln 2"}. The lower bound is accurate to about 0.03; the upper
  bound is accurate to about 0.0015.
\<close>
lemma ln2_ge_two_thirds: "2/3 \<le> ln (2::real)"
  and ln2_le_25_over_36: "ln (2::real) \<le> 25/36"
  using ln_approx_bounds[of 2 1, simplified, simplified eval_nat_numeral, simplified] by simp_all

text \<open>
  Approximation of the Euler--Mascheroni constant. The lower bound is accurate to about 0.0015;
  the upper bound is accurate to about 0.015.
\<close>
lemma euler_mascheroni_gt_19_over_33: "(euler_mascheroni :: real) > 19/33" (is ?th1)
  and euler_mascheroni_less_13_over_22: "(euler_mascheroni :: real) < 13/22" (is ?th2)
proof -
  have "ln (real (Suc 7)) = 3 * ln 2" by (simp add: ln_powr [symmetric] powr_numeral)
  also from ln_approx_bounds[of 2 3] have "\<dots> \<in> {3*307/443<..<3*4615/6658}"
    by (simp add: eval_nat_numeral)
  finally have "ln (real (Suc 7)) \<in> \<dots>" .
  from euler_mascheroni_bounds'[OF _ this] have "?th1 \<and> ?th2" by (simp_all add: harm_expand)
  thus ?th1 ?th2 by blast+
qed

end


theory Continuum imports "HOL-Analysis.Continuum_Not_Denumerable" begin

text \<open>
  Denumerable: Capable of being assigned numbers from the natural numbers.

  The empty set is denumerable because it is finite; the rational numbers are, surprisingly,
  denumerable because every possible fraction can be assigned a number.

  Synonym: Countable

  \<^url>\<open>https://en.wiktionary.org/wiki/denumerable\<close>
\<close>

proposition \<open>\<exists>f. \<forall>y :: nat. \<exists>x :: nat. y = f x\<close>
  by iprover

definition triangle :: \<open>nat \<Rightarrow> nat\<close>
  where \<open>triangle n \<equiv> (n * Suc n) div 2\<close>

lemma triangle_0 [simp]: \<open>triangle 0 = 0\<close>
  unfolding triangle_def by simp

lemma triangle_Suc [simp]: \<open>triangle (Suc n) = triangle n + Suc n\<close>
  unfolding triangle_def by simp

definition prod_encode :: \<open>nat \<times> nat \<Rightarrow> nat\<close>
  where \<open>prod_encode \<equiv> \<lambda>(m, n). triangle (m + n) + m\<close>

fun prod_decode_aux :: \<open>nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat\<close>
  where \<open>prod_decode_aux k m = (if k \<ge> m then (m, k - m) else prod_decode_aux (Suc k) (m - Suc k))\<close>

definition prod_decode :: \<open>nat \<Rightarrow> nat \<times> nat\<close>
  where \<open>prod_decode \<equiv> prod_decode_aux 0\<close>

lemma prod_decode_triangle_add: \<open>prod_decode (triangle k + m) = prod_decode_aux k m\<close>
  unfolding prod_decode_def
  by (induct k arbitrary: m) (simp, simp only: triangle_Suc add.assoc, simp)

lemma prod_encode_inverse [simp]: \<open>prod_decode (prod_encode x) = x\<close>
  unfolding prod_encode_def using prod_decode_triangle_add by (cases x) simp

lemma prod_encode_prod_decode_aux: \<open>prod_encode (prod_decode_aux k m) = triangle k + m\<close>
  unfolding prod_encode_def by (induct k m rule: prod_decode_aux.induct) simp

lemma prod_decode_inverse [simp]: \<open>prod_encode (prod_decode n) = n\<close>
  unfolding prod_decode_def by (simp add: prod_encode_prod_decode_aux del: prod_decode_aux.simps)

definition sum_encode :: \<open>nat + nat \<Rightarrow> nat\<close>
  where \<open>sum_encode x \<equiv> case x of Inl a \<Rightarrow> 2 * a | Inr b \<Rightarrow> Suc (2 * b)\<close>

definition sum_decode :: \<open>nat \<Rightarrow> nat + nat\<close>
  where \<open>sum_decode n \<equiv> if even n then Inl (n div 2) else Inr (n div 2)\<close>

lemma sum_encode_inverse [simp]: \<open>sum_decode (sum_encode x) = x\<close>
  unfolding sum_encode_def sum_decode_def by (cases x) simp_all

lemma sum_decode_inverse [simp]: \<open>sum_encode (sum_decode n) = n\<close>
  unfolding sum_encode_def sum_decode_def by simp

definition int_encode :: \<open>int \<Rightarrow> nat\<close>
  where \<open>int_encode i \<equiv> sum_encode (if i \<ge> 0 then Inl (nat i) else Inr (nat (- i - 1)))\<close>

definition int_decode :: \<open>nat \<Rightarrow> int\<close>
  where \<open>int_decode n \<equiv> case sum_decode n of Inl a \<Rightarrow> int a | Inr b \<Rightarrow> - int b - 1\<close>

lemma int_encode_inverse [simp]: \<open>int_decode (int_encode x) = x\<close>
  unfolding int_encode_def int_decode_def by simp

lemma int_decode_inverse [simp]: \<open>int_encode (int_decode n) = n\<close>
  unfolding int_encode_def int_decode_def unfolding sum_encode_def sum_decode_def by simp

theorem int_denum: \<open>\<exists>f :: nat \<Rightarrow> int. surj f\<close>
  unfolding surj_def using int_encode_inverse by metis

corollary \<open>\<exists>f. \<forall>y :: int. \<exists>x :: nat. y = f x\<close>
  using int_denum unfolding surj_def .

definition nat_to_rat_surj :: \<open>nat \<Rightarrow> rat\<close>
  where \<open>nat_to_rat_surj n \<equiv> let (a, b) = prod_decode n in Fract (int_decode a) (int_decode b)\<close>

lemma surj_nat_to_rat_surj: \<open>surj nat_to_rat_surj\<close>
  unfolding surj_def nat_to_rat_surj_def
  using Rat_cases case_prod_conv int_encode_inverse prod_encode_inverse by metis

theorem rat_denum: \<open>\<exists>f :: nat \<Rightarrow> rat. surj f\<close>
  using surj_nat_to_rat_surj by metis

corollary \<open>\<exists>f. \<forall>y :: rat. \<exists>x :: nat. y = f x\<close>
  using rat_denum unfolding surj_def .

text \<open>
  Examples of nondenumerable sets include the real, complex, irrational, and transcendental
  numbers.

  \<^url>\<open>http://mathworld.wolfram.com/CountablyInfinite.html\<close>
\<close>

proposition \<open>\<nexists>f. \<forall>y :: real. \<exists>x :: nat. y = f x\<close>
  using real_non_denum unfolding surj_def .

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_MSortTDIsSort
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function msorttd :: "int list => int list" where
  "msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = (op div) (length (cons2 y (cons2 x2 x3))) 2
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "((msorttd xs) = (isort xs))"
  oops

end


(* original Author: Martin Desharnais
    updated to version 2016 by Michaël Noël Divo
*)
(*<*)
theory Typed_Arithmetic_Expressions
imports Main
  Untyped_Arithmetic_Expressions
begin
(*>*)

section {* Typed Arithmetic Expressions *}
text {* \label{sec:typed-arith-expr} *}

text {* In this section, we revisit the previously formalized arithmetic expression language
(Section~\ref{sec:untyped-arith-expr}) and augment it with static types. Since types are a
characterization external to the definition of terms, we import the theory to reuse its definitions
and theorems. We complete the definitions with the typing relation and prove type safety through the
progress and preservation theorems.
*}

subsection {* Definitions *}

text {*
The language of arithmetic expressions contains two types for Booleans and natural numbers, which we
model using a datatype:
*}

datatype nbtype = Bool | Nat

(* Definition 8.2.1 *)

text {*
The typing relation serves to assign a type to an expression. It is characterized by the following
inference rules:
\setcounter{equation}{0}
\begin{gather}
  \inferrule {}{\text{true} : \text{Bool}} \\[0.8em]
  \inferrule {}{\text{false} : \text{Bool}} \\[0.8em]
  \inferrule {t_1 : \text{Bool} \\ t_2 : \text{T} \\ t_3 : \text{T}}
    {\text{if } t_1 \text{ then } t_2 \text{ else } t_3 : \text{T}} \\[0.8em]
    \inferrule {}{0 : \text{Nat}} \displaybreak\\[0.8em]
  \inferrule {t_1 : \text{Nat}}{\text{succ } t_1 : \text{Nat}} \\[0.8em]
  \inferrule {t_1 : \text{Nat}}{\text{pred } t_1 : \text{Nat}} \\[0.8em]
  \inferrule {t_1 : \text{Nat}}{\text{iszero } t_1 : \text{Bool}}
\end{gather}

The first, second and fourth rules give the type of constants. The third rule requires that both
branches of a conditional have the same type and that the condition is a Boolean. The fifth and
sixth rules state that the successor and predecessor of natural numbers are natural numbers
themselves. Finally, the seventh rule state that the test of equality with zero requires a natural
number and leads a Boolean. We translate these rules in an inductive definition, for which we also
provide the @{text "|:|"} operator as a more conventional notation:
*}

inductive has_type :: "nbterm \<Rightarrow> nbtype \<Rightarrow> bool" (infix "|:|" 150) where
  \<comment> \<open>Rules relating to the type of Booleans\<close>
  has_type_NBTrue:
    "NBTrue |:| Bool" |
  has_type_NBFalse:
    "NBFalse |:| Bool" |
  has_type_NBIf:
    "t1 |:| Bool \<Longrightarrow> t2 |:| T \<Longrightarrow> t3 |:| T \<Longrightarrow> NBIf t1 t2 t3 |:| T" |

  \<comment> \<open>Rules relating to the type of natural numbers\<close>
  has_type_NBZero:
    "NBZero |:| Nat" |
  has_type_NBSucc:
    "t |:| Nat \<Longrightarrow> NBSucc t |:| Nat" |
  has_type_NBPred:
    "t |:| Nat \<Longrightarrow> NBPred t |:| Nat" |
  has_type_NBIs_zero:
    "t |:| Nat \<Longrightarrow> NBIs_zero t |:| Bool"

(* Lemma 8.2.2 *)

text {*
The inversion of the typing relation gives us information on types for specific terms:
*}

lemma inversion_of_typing_relation:
  "NBTrue |:| R \<Longrightarrow> R = Bool"
  "NBFalse |:| R \<Longrightarrow> R = Bool"
  "NBIf t1 t2 t3 |:| R \<Longrightarrow> t1 |:| Bool \<and> t2 |:| R \<and> t3 |:| R"
  "NBZero |:| R \<Longrightarrow> R = Nat"
  "NBSucc t |:| R \<Longrightarrow> R = Nat \<and> t |:| Nat"
  "NBPred t |:| R \<Longrightarrow> R = Nat \<and> t |:| Nat"
  "NBIs_zero t |:| R \<Longrightarrow> R = Bool \<and> t |:| Nat"
by (auto elim: has_type.cases)

(* Theorem 8.2.4 *)

text {*
In the typed arithmetic language, every term @{term t} has at most one type. That is, if @{term t}
is typable, then its type is unique:
*}

theorem uniqueness_of_types:
  "t |:| T \<Longrightarrow> t |:| T' \<Longrightarrow> T = T'"
by (induction t T rule: has_type.induct) (auto dest: inversion_of_typing_relation)

subsection {* Safety = Progress + Preservation *}

text {*
The most basic property a type system must provide is \emph{safety}, also called \emph{soundness}:
the evaluation of a well-typed term will not reach a state whose semantics is undefined. Since our
\emph{operational semantics} is based the of the evaluation relation and the value predicate, every
term that does not fit in one or the other has no defined semantics.

An example of an undefined state is @{term "NBSucc NBTrue"}: there is no further evaluation
step possible but it is not a value neither. In our current language, there is nothing we can do
with this term.
*}

(* Lemma 8.3.1 *)

text {*
Another usefull lemma is the canonical form of values which, for well typed terms, give us
information on the nature of the terms:
*}

lemma canonical_form:
  "is_value_NB v \<Longrightarrow> v |:| Bool \<Longrightarrow> v = NBTrue \<or> v = NBFalse"
  "is_value_NB v \<Longrightarrow> v |:| Nat \<Longrightarrow> is_numeric_value_NB v"
by (auto elim: has_type.cases is_value_NB.cases is_numeric_value_NB.cases)

(* Theorem 8.3.2 *)

text {*
The safety of a type system can be shown in two step: progress and preservation. Progress means that
a well-typed term is not stuck, i.e. either it is a value or it can take a step according to the
evaluation rules.
*}

theorem progress:
  "t |:| T \<Longrightarrow> is_value_NB t \<or> (\<exists>t'. eval1_NB t t')"
proof (induction t T rule: has_type.induct)
  case (has_type_NBPred t)
  thus ?case
    by (auto intro: eval1_NB.intros is_numeric_value_NB.cases dest: canonical_form)
next
  case (has_type_NBIs_zero t)
  thus ?case
    by (auto intro: eval1_NB.intros is_numeric_value_NB.cases dest: canonical_form)
qed (auto
  intro: eval1_NB.intros is_value_NB.intros is_numeric_value_NB.intros
  dest: canonical_form)

(* Theorem 8.3.3 *)

text {*
Preservation means that if a well-typed term takes a step of evaluation, then the resulting term is
also well-typed.
*}

theorem preservation: "t |:| T \<Longrightarrow> eval1_NB t t' \<Longrightarrow> t' |:| T"
proof (induction t T arbitrary: t' rule: has_type.induct)
  case (has_type_NBIf t1 t2 T t3)
  from has_type_NBIf.prems has_type_NBIf.IH has_type_NBIf.hyps show ?case
    by (auto intro: has_type.intros elim: eval1_NB.cases)
qed (auto
  intro: has_type.intros
  dest: inversion_of_typing_relation
  elim: eval1_NB.cases)

(*<*)
end
(*>*)