theory Section4
imports Main "~~/src/HOL/Library/Order_Relation" "~~/src/HOL/Library/Zorn"

begin

(* Section 4.1 *)

typedecl p

datatype Lit = P p ("_." 500) | Not p ("_`")

fun complement :: "Lit \<Rightarrow> Lit" ("_\<acute>" 300) where
  "(p`)\<acute> = (p.)"
| "(p.)\<acute> = (p`)"

datatype formula = All Lit Lit ("All _ are _ ") | Some Lit Lit ("Some _ are _")

lemma "(p.)\<acute> = (p`)" by (rule complement.simps(2))

lemma complement_involutive[simp] : "x\<acute>\<acute> = x"
  by (metis Lit.exhaust complement.simps(1) complement.simps(2))
(*declare [[show_types]]*)

type_synonym 'a model = "p \<Rightarrow>'a set"

fun modelOnLit :: "'a model \<Rightarrow> Lit \<Rightarrow>'a set" where
  "modelOnLit M (x`) = (UNIV::'a set) - M (x)"
 |"modelOnLit M (x.) = M (x)"

fun M_satisfies :: "'a model \<Rightarrow> formula \<Rightarrow> bool" ("_ \<Turnstile> _")
where
  "M_satisfies M (All x are y) = (modelOnLit M x \<subseteq> modelOnLit M y)"
| "M_satisfies M (Some x are y) = (\<exists>e. e \<in> modelOnLit M x \<inter> modelOnLit M y)"

lemma
 assumes "M \<Turnstile> All (p.) are (q`)"
 shows "M p \<inter> M q = {}" (* eqivalent to saying M \<Turnstile> No p are q *)
proof -
  from assms have "M p \<subseteq> modelOnLit M (q`)"
    by simp
  then have "M p \<subseteq> ( UNIV - M q )"
    by simp
  then show ?thesis by auto
qed

inductive derarg :: "formula set \<Rightarrow> formula \<Rightarrow> bool" ("_ \<turnstile> _")
  for hs
  where
  axiom: "hs \<turnstile> All X are X"
| some1: "hs \<turnstile> Some X are Y \<Longrightarrow> hs \<turnstile> Some X are X"
| some2: "hs \<turnstile> Some X are Y \<Longrightarrow> hs \<turnstile> Some Y are X"
| barbara: "\<lbrakk>hs \<turnstile> All X are Y; hs \<turnstile> All Y are Z\<rbrakk> \<Longrightarrow> hs \<turnstile> All X are Z"
| darii: "\<lbrakk>hs \<turnstile> All Y are Z; hs \<turnstile> Some X are Y\<rbrakk> \<Longrightarrow> hs \<turnstile> Some X are Z"
| zero: "hs \<turnstile> All X  are (X\<acute>) \<Longrightarrow> hs \<turnstile> All X are Y"
| one: "hs \<turnstile> All (Y\<acute>) are Y \<Longrightarrow> hs \<turnstile> All X are Y"
| antitone: "hs \<turnstile> All Y are (X\<acute>) \<Longrightarrow> hs \<turnstile> All X are (Y\<acute>)"
| x: "\<lbrakk>hs \<turnstile> All X are Y; hs \<turnstile> Some X are (Y\<acute>)\<rbrakk> \<Longrightarrow> hs \<turnstile> _"
| ass: "f \<in> hs \<Longrightarrow> hs \<turnstile> f"

lemma "{Some (p`) are (q.)} \<turnstile> Some (q.) are (q.)"
proof -
  have "{Some (p`) are (q.)} \<turnstile> Some (q.) are (p`)" by (simp add: ass derarg.some2)
  then show ?thesis by (simp add: derarg.some1)
qed

(* section 4.2 *)

(* preorder on Lit induced by set of formulas G *)
fun less_equal_Lit :: "Lit \<Rightarrow> formula set \<Rightarrow> Lit \<Rightarrow> bool" ("_ \<lesssim> _ _")  where
  "less_equal_Lit x G y = (G \<turnstile> All x are y)"

(* TT: export the theorems for trans and refl, since they are useful in the following *)
lemma less_equal_Lit_refl [simp]:
  "\<And>x G. x \<lesssim>G x"
  by (metis axiom less_equal_Lit.elims(3))

lemma less_equal_Lit_trans:
  "\<And>x G y z. x \<lesssim>G y \<Longrightarrow> y \<lesssim>G z \<Longrightarrow> x \<lesssim>G z"
  by (metis barbara less_equal_Lit.simps(1))

lemma less_equal_Lit_ass [simp] :
  "(All x are y) \<in> G \<Longrightarrow> less_equal_Lit x G y"
  by (metis ass less_equal_Lit.simps(1))

lemma less_equal_Lit_antitone :
  "\<And>G x y. (x \<lesssim>G y) \<longleftrightarrow> ((y\<acute>) \<lesssim>G (x\<acute>))"
by (metis antitone complement_involutive less_equal_Lit.simps)

lemma prop_2_1:
  fixes G
  defines R_def: "R \<equiv> { (x, y). less_equal_Lit x G y }"
  shows "preorder_on UNIV R"
proof -
  have "refl R"
    by (simp add: refl_on_def R_def) (metis axiom)
  have "trans R"
    by (metis assms less_equal_Lit_trans mem_Collect_eq old.prod.case transI)
  with `refl R` show ?thesis by (simp add: preorder_on_def)
qed

(* equivalence relation induced by the preorder *)
(* should we rename equiv_Lit to equal_Lit? - cant there is an automatically generated definition called equal_Lit *)
definition equiv_Lit :: "Lit \<Rightarrow> formula set \<Rightarrow> Lit \<Rightarrow> bool" ("_ \<approx>_ _")  where
  "equiv_Lit x G y \<equiv> less_equal_Lit x G y \<and> less_equal_Lit y G x"

lemma equiv_Lit_refl [simp]:
  "\<And>G x. x \<approx>G x"
unfolding equiv_Lit_def by (metis less_equal_Lit_refl)

lemma equiv_Lit_antitone:
  "\<And>G x y. (x \<approx>G y) \<longleftrightarrow> ((x\<acute>) \<approx>G (y\<acute>))"
by (metis antitone complement_involutive equiv_Lit_def less_equal_Lit.simps)

definition Lit_poset_eqclass :: "Lit \<Rightarrow> formula set \<Rightarrow> Lit set" ("[[_]]_") where
  "Lit_poset_eqclass x G \<equiv> {y. x \<approx>G y}"

lemma Lit_poset_eqclass_membership : "\<And>x G. x \<in> [[x]]G"
  unfolding Lit_poset_eqclass_def by (metis equiv_Lit_refl mem_Collect_eq)

lemma Lit_poset_eqclass_equivalence [simp]: "\<And>x G y. x \<approx>G y \<Longrightarrow> ([[x]]G) = ([[y]]G)"
  unfolding Lit_poset_eqclass_def equiv_Lit_def
  by (metis less_equal_Lit_trans)

datatype lit_mod_elt = Zero_rep | One_rep | Equiv "Lit set"

definition Lit_mod :: "formula set \<Rightarrow> lit_mod_elt set" where
   "Lit_mod G = { Equiv ([[x]]G) | x. x \<in> UNIV }"

definition Lit_mod_plus_cond :: "formula set => bool" where
  "Lit_mod_plus_cond G \<equiv> \<exists> p. (p \<lesssim>G (p\<acute>))"

definition Lit_mod_plus :: "formula set \<Rightarrow> lit_mod_elt set" where
  "Lit_mod_plus G \<equiv> if Lit_mod_plus_cond G then Lit_mod G else
  ((Lit_mod G) \<union> {Zero_rep, One_rep})"

definition zero :: "formula set \<Rightarrow> lit_mod_elt" where
  "zero G \<equiv> if Lit_mod_plus_cond G then Equiv([[SOME p. (p \<lesssim>G (p\<acute>))]]G) else Zero_rep"

lemma Lit_mod_intro[simp] : "\<And>x. ( Equiv [[x]]G) \<in> Lit_mod G"
unfolding Lit_mod_def
by (metis (lifting, mono_tags) UNIV_I mem_Collect_eq)

lemma Lit_mod_plus_intro[simp] : "\<And>x. ( Equiv [[x]]G) \<in> Lit_mod_plus G"
unfolding Lit_mod_plus_def by fastforce

lemma Lit_mod_intro2[simp] : "\<And>x. x \<in> Lit_mod G \<Longrightarrow> \<exists>y. x = (Equiv [[y]]G)"
unfolding Lit_mod_def
proof -
  fix x
  assume "x \<in> {(Equiv [[x]]G) |x. x \<in> UNIV}"
  hence "\<exists>xa. x = (Equiv [[xa]]G) \<and> xa \<in> UNIV"
    by fastforce
  thus "\<exists>y. x = (Equiv [[y]]G)"
    by simp
qed

fun less_equal_Lit_poset_eqclass :: "lit_mod_elt \<Rightarrow> formula set \<Rightarrow> lit_mod_elt \<Rightarrow> bool" ("_ \<lesssim>._ _" 400) where
  "less_equal_Lit_poset_eqclass (Equiv a) G (Equiv b) = (\<exists>aa \<in> a. \<exists>bb \<in> b. (aa \<lesssim>G bb))"
  | "less_equal_Lit_poset_eqclass Zero_rep G _ = True"
  | "less_equal_Lit_poset_eqclass _ G One_rep = True"
  | "less_equal_Lit_poset_eqclass One_rep G _ = False"
  | "less_equal_Lit_poset_eqclass _ G Zero_rep = False"

lemma less_equal_Lit_poset_eqclass_simp[simp] :
  "(a \<lesssim>G b) \<longleftrightarrow> (Equiv ([[a]]G) \<lesssim>.G (Equiv [[b]]G))"
proof -
  {
    assume "a \<lesssim>G b"
    have "Equiv ([[a]]G) \<lesssim>.G (Equiv [[b]]G)"
      by (metis Lit_poset_eqclass_membership `a \<lesssim> G b` less_equal_Lit_poset_eqclass.simps(1))
  }
  {
    assume "Equiv ([[a]]G) \<lesssim>.G (Equiv [[b]]G)"
    have 1: "\<exists>aa \<in> ([[a]]G). \<exists>bb \<in> ([[b]]G). (aa \<lesssim>G bb)"
      by (metis `(Equiv [[a]]G) \<lesssim>.G (Equiv [[b]]G)` less_equal_Lit_poset_eqclass.simps(1))
    have "\<forall>x \<in> ([[a]]G). (a \<lesssim>G x)" "\<forall>y \<in> ([[b]]G). (b \<lesssim>G y)"
      by (metis Lit_poset_eqclass_def equiv_Lit_def mem_Collect_eq)+
    with 1 have "a \<lesssim>G b"
      by (metis Lit_poset_eqclass_def equiv_Lit_def less_equal_Lit_trans mem_Collect_eq)
  }
  thus ?thesis
    by (metis `a \<lesssim> G b \<Longrightarrow> (Equiv [[a]]G) \<lesssim>.G (Equiv [[b]]G)`)
qed

lemma less_equal_Lit_poset_eqclass_simp2[simp] :
  "\<And>x G. (Equiv [[x]]G) \<lesssim>.G (Equiv [[x]]G)"
unfolding Lit_poset_eqclass_def
by (metis equiv_Lit_def equiv_Lit_refl less_equal_Lit_poset_eqclass.simps(1) mem_Collect_eq)

lemma zero_less_equal_Lit_poset_eqclass:
  fixes G p
  assumes "p \<lesssim>G (p\<acute>)"
  shows "\<forall>q. ((Equiv [[p]]G) \<lesssim>.G (Equiv [[q]]G))"
proof -
  from assms have "\<forall>q. (p \<lesssim>G q)"
    by (metis less_equal_Lit.simps zero)
  then show ?thesis by (metis less_equal_Lit_poset_eqclass_simp)
qed

lemma 10[simp]:
  fixes G x a
  assumes "(Equiv x) \<in> Lit_mod_plus G"
  and "a \<in> x"
  shows "(Equiv [[a]]G) = (Equiv x)"
proof -
  from assms(1) have "\<exists>a. (Equiv x) = (Equiv [[a]]G)"
    by (metis Lit_mod_intro2 Lit_mod_plus_def UnE insertE lit_mod_elt.distinct(3) lit_mod_elt.distinct(5) singleton_iff)
  {
    fix l
    assume "x \<equiv> [[l]]G"
    have "a \<approx>G l"
      by (metis Lit_poset_eqclass_def `x \<equiv> [[l]]G` assms(2) equiv_Lit_def mem_Collect_eq)
    have ?thesis
      by (metis Lit_poset_eqclass_equivalence `a \<approx> G l` `x \<equiv> [[l]]G`)
  }
  thus ?thesis
    by (metis `\<exists>a. Equiv x = Equiv [[a]]G` lit_mod_elt.inject)
qed

(*lemma 11:
  fixes G l
  defines "a \<equiv> ([[l]]G)"
  shows "a = \<Union>{ ([[y]]G) | y. y \<in> a }"
proof -
  have 1: "\<forall>x \<in> a. ([[x]]G) = a"
    by (metis Lit_poset_eqclass_def Lit_poset_eqclass_equivalence assms mem_Collect_eq)
  then have "\<Union>{ ([[y]]G) | y. y \<in> a } \<subseteq> a" by fast
  with 1 assms show ?thesis
    by (metis (lifting, mono_tags) Union_upper mem_Collect_eq subsetI subset_antisym)
qed
*)
(*lemma
  fixes G l x
  defines "a \<equiv> (Lit_poset_eqclass G l)"
  assumes "x \<in> a"
  shows "(Lit_poset_eqclass x G) = \<Union>{ (Lit_poset_eqclass G y) | y. y \<in> a }"
using 10[of x G l]
using 11[of G l]
by (metis assms)*)

fun complement_Lit_poset_eqclass :: "lit_mod_elt \<Rightarrow> formula set \<Rightarrow> lit_mod_elt" (infix ".\<acute>" 400)  where
  "(Equiv a).\<acute>G = Equiv([[(SOME p. (p \<in> a))\<acute>]]G)"
  | "Zero_rep.\<acute>G = One_rep"
  | "One_rep.\<acute>G = Zero_rep"

definition one :: "formula set \<Rightarrow> lit_mod_elt" where
  "one G \<equiv> zero G .\<acute>G"

lemma complement_Lit_poset_eqclass_equivalence:
  fixes G x a b
  assumes "(Equiv x) \<in> Lit_mod_plus G"
  and "a \<in> x"
  and "b \<in> x"
  shows "(Equiv [[a\<acute>]]G) = (Equiv [[b\<acute>]]G)"
proof -
  have "a \<approx>G b"
    by (metis "10" Lit_poset_eqclass_def assms(1) assms(2) assms(3) lit_mod_elt.inject mem_Collect_eq)
  then have "(a\<acute>) \<approx>G (b\<acute>)" by (metis equiv_Lit_antitone)
  thus ?thesis by force
qed

lemma complement_Lit_poset_eqclass_simp:
  fixes G x a
  assumes "(Equiv x) \<in> Lit_mod_plus G"
  and "a \<in> x"
  shows "(Equiv [[a\<acute>]]G) = (Equiv x).\<acute>G"
by (metis (lifting) assms(1) assms(2) complement_Lit_poset_eqclass.simps(1) complement_Lit_poset_eqclass_equivalence someI)

lemma complement_Lit_poset_eqclass_simp2 [simp]: "\<And>x G. Equiv [[x\<acute>]]G \<equiv> (Equiv [[x]]G).\<acute>G"
proof -
  fix x :: Lit and G :: "formula set"
  have "(Equiv [[x]]G).\<acute>G = Equiv [[(x\<acute>)]]G"
    by (metis Lit_mod_intro Lit_mod_plus_def Lit_poset_eqclass_def UnI1 complement_Lit_poset_eqclass_simp equiv_Lit_refl mem_Collect_eq)
  thus "(Equiv [[x\<acute>]]G) \<equiv> (Equiv [[x]]G).\<acute>G"
    using Lit_poset_eqclass_def by simp
qed

lemma Lit_poset_eqclass_reflexive:
  fixes G x
  assumes "x \<in> Lit_mod_plus G"
  shows "x \<lesssim>.G x"
proof (cases x)
  case Zero_rep
  thus ?thesis by simp
next
  case One_rep
  thus ?thesis by simp
next
  case Equiv
  obtain y where "x \<equiv> Equiv y" by (metis Equiv)
  have 1: "\<forall>a \<in> y. (Equiv [[a]]G) = x" by (metis "10" `x \<equiv> Equiv y` assms)
  have "\<forall>a \<in> y. (a \<lesssim>G a)" by (metis less_equal_Lit_refl)
  then have "\<forall>a \<in> y. ((Equiv [[a]]G) \<lesssim>.G (Equiv [[a]]G))" by (metis less_equal_Lit_poset_eqclass_simp2)
  obtain a where "(Equiv [[a]]G) = x" "((Equiv [[a]]G) \<lesssim>.G (Equiv [[a]]G))"
    by (metis Equiv Lit_mod_intro2 Lit_mod_plus_def Un_insert_right assms insert_iff less_equal_Lit_poset_eqclass_simp2 lit_mod_elt.distinct(3) lit_mod_elt.distinct(5) sup_bot_right)
  thus ?thesis by fast
qed

lemma Lit_poset_eqclass_trans:
  fixes G x y z
  assumes "x \<in> Lit_mod_plus G"
  and "y \<in> Lit_mod_plus G"
  and "z \<in> Lit_mod_plus G"
  and "(x \<lesssim>.G y)"
  and "(y \<lesssim>.G z)"
  shows "(x \<lesssim>.G z)"
proof (cases x)
  case Zero_rep
  thus ?thesis by simp
next
  case One_rep
  thus ?thesis
    by (metis assms(4) assms(5) less_equal_Lit_poset_eqclass.elims(2) lit_mod_elt.distinct(1) lit_mod_elt.distinct(5))
next
  case Equiv
  note Equiv_x = Equiv
  thus ?thesis
  proof (cases y)
    case Zero_rep
    have False by (metis Equiv Zero_rep assms(4) less_equal_Lit_poset_eqclass.simps(7))
    thus ?thesis ..
  next
    case One_rep
    thus ?thesis
      by (metis Equiv assms(5) less_equal_Lit_poset_eqclass.simps(4) less_equal_Lit_poset_eqclass.simps(5) less_equal_Lit_poset_eqclass.simps(6) lit_mod_elt.exhaust)
  next
    case Equiv
    note Equiv_y = Equiv
    thus ?thesis
    proof (cases z)
      case Zero_rep
      have False by (metis Equiv_y Zero_rep assms(5) less_equal_Lit_poset_eqclass.simps(7))
      thus ?thesis ..
    next
      case One_rep
      thus ?thesis by (metis Equiv_x less_equal_Lit_poset_eqclass.simps(4))
    next
      case Equiv
      note Equiv_z = Equiv
      obtain e f g where "x \<equiv> Equiv e" "y \<equiv> Equiv f" "z \<equiv> Equiv g"
        by (metis Equiv_x Equiv_y Equiv_z)
      then have 1 : "\<forall>a \<in> e. \<forall>b \<in> f. (a \<lesssim>G b)"
      proof -
        obtain a b where "a \<in> e" "b \<in> f"
          by (metis `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(4) less_equal_Lit_poset_eqclass.simps(1))
        then have "Equiv ([[a]]G) = x" "Equiv ([[b]]G) = y"
          using "10" \<open>x \<equiv> Equiv e\<close> assms(1) apply blast
          using \<open>b \<in> f\<close> \<open>y \<equiv> Equiv f\<close> assms(2) by auto
        then have "(Equiv ([[a]]G)) \<lesssim>.G (Equiv ([[b]]G))" by (metis assms(4))
        then have  "a \<lesssim>G b" by (metis less_equal_Lit_poset_eqclass_simp)
        thus ?thesis by (metis Lit_poset_eqclass_def Lit_poset_eqclass_equivalence `x \<equiv> Equiv e` `y \<equiv> Equiv f` `(Equiv [[a]]G) = x` `(Equiv [[b]]G) = y` less_equal_Lit_poset_eqclass_simp lit_mod_elt.inject mem_Collect_eq)
      qed
      have 2 : "\<forall>a \<in> f. \<forall>b \<in> g. (a \<lesssim>G b)"
      proof -
        obtain b c where "b \<in> f" "c \<in> g"
          by (metis `z \<equiv> Equiv g` `y \<equiv> Equiv f` assms(5) less_equal_Lit_poset_eqclass.simps(1))
        then have "Equiv ([[b]]G) = y" "Equiv ([[c]]G) = z"
          by (metis "10" `y \<equiv> Equiv f` assms(2)) (metis "10" `c \<in> g` `z \<equiv> Equiv g` assms(3))
        then have "(Equiv ([[b]]G)) \<lesssim>.G (Equiv ([[c]]G))" by (metis assms(5))
        then have  "b \<lesssim>G c" by (metis less_equal_Lit_poset_eqclass_simp)
        thus ?thesis by (metis Lit_poset_eqclass_def Lit_poset_eqclass_equivalence `y \<equiv> Equiv f` `z \<equiv> Equiv g` `(Equiv [[b]]G) = y` `(Equiv [[c]]G) = z` assms(5) less_equal_Lit_poset_eqclass_simp lit_mod_elt.inject mem_Collect_eq)
      qed

      from 1 2 have "\<forall>a \<in> e. \<forall>b \<in> g. (a \<lesssim>G b)"
        by (metis `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(4) ex_in_conv less_equal_Lit_poset_eqclass.simps(1) less_equal_Lit_trans)
      thus ?thesis
        by (metis `x \<equiv> Equiv e` `y \<equiv> Equiv f` `z \<equiv> Equiv g` assms(4) assms(5) less_equal_Lit_poset_eqclass.simps(1))
    qed
  qed
qed

lemma Lit_poset_eqclass_antisym:
  fixes G x y
  assumes "x \<in> Lit_mod_plus G"
  and "y \<in> Lit_mod_plus G"
  and "(x \<lesssim>.G y)"
  and "(y \<lesssim>.G x)"
  shows "x = y"
proof (cases x)
  case Zero_rep
  thus ?thesis by (metis assms(4) less_equal_Lit_poset_eqclass.simps(5) less_equal_Lit_poset_eqclass.simps(7) lit_mod_elt.exhaust)
next
  case One_rep
  thus ?thesis by (metis assms(3) less_equal_Lit_poset_eqclass.simps(5) less_equal_Lit_poset_eqclass.simps(6) lit_mod_elt.exhaust)
next
  case Equiv
  note Equiv_x = Equiv
  thus ?thesis
  proof (cases y)
    case Zero_rep
    thus ?thesis by (metis Equiv_x assms(3) less_equal_Lit_poset_eqclass.simps(7))
  next
    case One_rep
    thus ?thesis by (metis Equiv_x assms(4) less_equal_Lit_poset_eqclass.simps(6))
  next
    case Equiv
    note Equiv_y = Equiv
    obtain e f where "x \<equiv> Equiv e" "y \<equiv> Equiv f" by (metis Equiv_x Equiv_y)
    have 1 : "\<forall>a \<in> e. \<forall>b \<in> f. (a \<lesssim>G b)"
      by (metis "10" `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(1) assms(2) assms(3) less_equal_Lit_poset_eqclass_simp lit_mod_elt.inject)

    have 2 : "\<forall>a \<in> f. \<forall>b \<in> e. (a \<lesssim>G b)"
      by (metis "10" `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(1) assms(2) assms(4) less_equal_Lit_poset_eqclass_simp lit_mod_elt.inject)

    from 1 2 have "\<forall>a \<in> e. \<forall>b \<in> f. (a \<approx>G b)" by (metis equiv_Lit_def)
    then have "\<forall>a \<in> e. \<forall>b \<in> f. (Equiv [[a]]G) = (Equiv [[b]]G)" by force
    thus ?thesis
      by (metis "10" `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(1) assms(2) assms(3) less_equal_Lit_poset_eqclass.elims(2) lit_mod_elt.distinct(3) lit_mod_elt.distinct(5) lit_mod_elt.inject)
  qed
qed

lemma Lit_eqclass_partial_order:
  fixes G
  defines R_def: "R \<equiv> { (x, y). x \<in> Lit_mod_plus G \<and> y \<in> Lit_mod_plus G \<and> (x \<lesssim>.G y) }"
  shows "partial_order_on (Lit_mod_plus G) R"
proof -
  have "refl_on (Lit_mod_plus G) R"
    unfolding refl_on_def
    by (metis (lifting) Lit_poset_eqclass_reflexive SigmaI assms mem_Collect_eq split_conv subrelI)

  have "trans R"
    unfolding trans_def
    using Lit_poset_eqclass_trans assms by blast

  have "antisym R"
    unfolding antisym_def
      by (metis (lifting) Lit_poset_eqclass_antisym assms mem_Collect_eq split_conv)

  with `refl_on (Lit_mod_plus G) R` `trans R` show ?thesis by (metis partial_order_on_def preorder_on_def)
qed

lemma Lit_eqclass_antitone :
  fixes G x y
  assumes "x \<in> Lit_mod_plus G"
  and "y \<in> Lit_mod_plus G"
  shows "(x \<lesssim>.G y) \<longleftrightarrow> ((y.\<acute>G) \<lesssim>.G (x.\<acute>G))"
proof (cases x)
  case Zero_rep
  thus ?thesis by (metis complement_Lit_poset_eqclass.simps(2) less_equal_Lit_poset_eqclass.elims(3) less_equal_Lit_poset_eqclass.simps(2) less_equal_Lit_poset_eqclass.simps(3) less_equal_Lit_poset_eqclass.simps(4) lit_mod_elt.distinct(1))
next
  case One_rep
  thus ?thesis by (metis complement_Lit_poset_eqclass.simps(1) complement_Lit_poset_eqclass.simps(2) complement_Lit_poset_eqclass.simps(3) less_equal_Lit_poset_eqclass.elims(2) less_equal_Lit_poset_eqclass.elims(3) lit_mod_elt.distinct(1) lit_mod_elt.distinct(5))
next
  case Equiv
  note Equiv_x = Equiv
  thus ?thesis
  proof (cases y)
    case Zero_rep
    thus ?thesis by (metis Equiv_x complement_Lit_poset_eqclass.simps(1) complement_Lit_poset_eqclass.simps(2) less_equal_Lit_poset_eqclass.elims(2) less_equal_Lit_poset_eqclass.simps(7) lit_mod_elt.distinct(1) lit_mod_elt.distinct(5))
  next
    case One_rep
    thus ?thesis by (metis Equiv_x complement_Lit_poset_eqclass.simps(3) less_equal_Lit_poset_eqclass.simps(2) less_equal_Lit_poset_eqclass.simps(4))
  next
    case Equiv
    note Equiv_y = Equiv

    obtain e f where "x \<equiv> Equiv e" "y \<equiv> Equiv f"
      by (metis Equiv_x Equiv_y)
    have 1: "\<forall>a \<in> e. (Equiv [[a]]G) = x" by (metis "10" `x \<equiv> Equiv e` assms(1))
    have 2: "\<forall>a \<in> f. (Equiv [[a]]G) = y" by (metis "10" `y \<equiv> Equiv f` assms(2))
    have "\<forall>a \<in> e. \<forall>b \<in> f. (a \<lesssim>G b) \<longleftrightarrow> ((b\<acute>) \<lesssim>G (a\<acute>))" by (metis less_equal_Lit_antitone)
    then have "\<forall>a \<in> e. \<forall>b \<in> f. ((Equiv [[a]]G) \<lesssim>.G (Equiv [[b]]G)) \<longleftrightarrow> ((Equiv [[(b\<acute>)]]G) \<lesssim>.G (Equiv [[(a\<acute>)]]G))" by (metis less_equal_Lit_poset_eqclass_simp)
    then have 3: "\<forall>a \<in> e. \<forall>b \<in> f. ((Equiv [[a]]G) \<lesssim>.G (Equiv [[b]]G)) \<longleftrightarrow> (((Equiv [[b]]G).\<acute>G) \<lesssim>.G ((Equiv [[a]]G).\<acute>G))" by (metis complement_Lit_poset_eqclass_simp2)
    then obtain a b where "((Equiv [[a]]G) \<lesssim>.G (Equiv [[b]]G)) \<longleftrightarrow> (((Equiv [[b]]G).\<acute>G) \<lesssim>.G ((Equiv [[a]]G).\<acute>G))" "(Equiv [[a]]G) = x" "(Equiv [[b]]G) = y"
      by (metis "1" "2" Lit_poset_eqclass_reflexive `x \<equiv> Equiv e` `y \<equiv> Equiv f` all_not_in_conv assms(1) assms(2) complement_Lit_poset_eqclass_simp2 equals0I less_equal_Lit_poset_eqclass.simps(1))
    thus ?thesis by fast
  qed
qed

lemma Lit_eqclass_involutive :
  fixes G x
  assumes "x \<in> Lit_mod_plus G"
  shows "((x.\<acute>G).\<acute>G) = x"
proof (cases x)
  case Zero_rep
  thus ?thesis by simp
next
  case One_rep
  thus ?thesis by simp
next
  case Equiv
  then have "x \<in> Lit_mod G"
    by (metis "10" Lit_mod_intro Lit_poset_eqclass_reflexive assms less_equal_Lit_poset_eqclass.simps(1))
  thus ?thesis by (metis Lit_mod_intro2 complement_Lit_poset_eqclass_simp2 complement_involutive)
qed

lemma Lit_eqclass_complement_in_Lit_mod:
  fixes G x
  assumes "x \<in> Lit_mod G"
  shows "(x.\<acute>G) \<in> Lit_mod G"
by (metis Lit_mod_intro Lit_mod_intro2 assms complement_Lit_poset_eqclass_simp2)

lemma zero_less_than_all:
  fixes G x
  assumes "x \<in> Lit_mod_plus G"
  shows "(zero G \<lesssim>.G x)"
proof -
  {
    assume "\<not>Lit_mod_plus_cond G"
    have ?thesis by (metis `\<not> Lit_mod_plus_cond G` less_equal_Lit_poset_eqclass.simps(2) zero_def)
  }
  {
    assume "Lit_mod_plus_cond G"
    obtain p where "zero G = p" by simp
    then obtain q where "(Equiv [[q]]G) = p" by (metis `Lit_mod_plus_cond G` zero_def)
    then have "(Equiv [[q]]G) = (Equiv [[SOME p. (p \<lesssim> G (p\<acute>))]]G)" by (metis `Lit_mod_plus_cond G` `zero G = p` zero_def)
    then have "q \<lesssim>G (q\<acute>)"
      by (metis (lifting, no_types) Lit_mod_plus_cond_def Lit_poset_eqclass_def Lit_poset_eqclass_membership `(Equiv [[q]]G) = p` `Lit_mod_plus_cond G` complement_involutive empty_Collect_eq equiv_Lit_antitone equiv_Lit_def less_equal_Lit.elims(2) less_equal_Lit.elims(3) less_equal_Lit_trans lit_mod_elt.inject mem_Collect_eq one someI_ex)
    then have ?thesis
      by (metis Lit_mod_intro2 Lit_mod_plus_def `zero G = p` `(Equiv [[q]]G) = p` `Lit_mod_plus_cond G` assms zero_less_equal_Lit_poset_eqclass)
  }
  thus ?thesis by (metis `\<not> Lit_mod_plus_cond G \<Longrightarrow> zero G \<lesssim>.G x`)
qed

lemma all_zero_Eqclasses:
  fixes G a
  assumes "Lit_mod_plus_cond G"
  and "a \<lesssim>G (a\<acute>)"
  shows "(Equiv [[a]]G) = zero G"
proof (rule ccontr)
  assume "(Equiv [[a]]G) \<noteq> zero G"
  then show False
    by (metis Lit_mod_intro Lit_mod_plus_def Lit_poset_eqclass_antisym assms(1) assms(2) zero_def zero_less_equal_Lit_poset_eqclass zero_less_than_all)
qed

lemma Lit_eqiv_class_complement_inconsistency :
  fixes G x y
  assumes "x \<in> Lit_mod_plus G"
  and "y \<in> Lit_mod_plus G"
  and "(x \<lesssim>.G y)"
  and "(x \<lesssim>.G (y.\<acute>G))"
  shows "x = zero G"
proof (cases x)
  case Zero_rep
  thus ?thesis by (metis Lit_eqclass_complement_in_Lit_mod Lit_mod_intro2 Lit_mod_plus_def assms(1) complement_Lit_poset_eqclass.simps(2) lit_mod_elt.distinct(5) zero_def)
next
  case One_rep
  thus ?thesis by (metis assms(3) assms(4) complement_Lit_poset_eqclass.simps(3) less_equal_Lit_poset_eqclass.elims(2) lit_mod_elt.distinct(1) lit_mod_elt.distinct(5))
next
  case Equiv
  note Equiv_x = Equiv
  thus ?thesis
  proof (cases y)
    case Zero_rep
    thus ?thesis by (metis Equiv_x assms(3) less_equal_Lit_poset_eqclass.simps(7))
  next
    case One_rep
    thus ?thesis by (metis Equiv_x assms(4) complement_Lit_poset_eqclass.simps(3) less_equal_Lit_poset_eqclass.simps(7))
  next
    case Equiv
    note Equiv_y = Equiv
    obtain e f where "x \<equiv> Equiv e" "y \<equiv> Equiv f" by (metis Equiv_x Equiv_y)
    have "\<forall>a \<in> e. \<forall>b \<in> f. (a \<lesssim>G b)"
      by (metis "10" `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(1) assms(2) assms(3) less_equal_Lit_poset_eqclass_simp lit_mod_elt.inject)
    have "\<forall>a \<in> e. \<forall>b \<in> f. (a \<lesssim>G (b\<acute>))"
      by (metis "10" `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(1) assms(2) assms(4) complement_Lit_poset_eqclass_simp less_equal_Lit_poset_eqclass_simp lit_mod_elt.inject)
    then obtain a b where "(a \<lesssim>G b)" "(a \<lesssim>G (b\<acute>))" "a \<in> e" "b \<in> f"
      by (metis `x \<equiv> Equiv e` `y \<equiv> Equiv f` assms(3) less_equal_Lit_poset_eqclass.simps(1))
    have "b \<lesssim>G (a\<acute>)" by (metis `a \<lesssim> G (b\<acute>)` antitone less_equal_Lit.simps)
    have "a \<lesssim>G (a\<acute>)" by (metis `a \<lesssim> G b` `b \<lesssim> G (a\<acute>)` less_equal_Lit_trans)
    have "Lit_mod_plus_cond G"
      unfolding Lit_mod_plus_cond_def by (metis `a \<lesssim> G (a\<acute>)`)
    then have "zero G = (Equiv [[a]]G)" by (metis `a \<lesssim> G (a\<acute>)` all_zero_Eqclasses)
    thus ?thesis by (metis "10" `a \<in> e` `x \<equiv> Equiv e` assms(1))
  qed
qed

lemma Lit_eqclass_in_Lit_mod_plus:
  fixes G x
  assumes "x \<in> Lit_mod_plus G"
  shows "x.\<acute>G \<in> Lit_mod_plus G"
proof (cases x)
  case Zero_rep
  thus ?thesis by (metis (mono_tags) Lit_eqclass_complement_in_Lit_mod Lit_mod_plus_def Un_insert_right assms complement_Lit_poset_eqclass.simps(2) insertI1 insert_commute)
next
  case One_rep
  thus ?thesis by (metis Lit_eqclass_complement_in_Lit_mod Lit_mod_plus_def Un_absorb assms complement_Lit_poset_eqclass.simps(3) insert_subset le_iff_sup sup.boundedE)
next
  case Equiv
  thus ?thesis by (metis Lit_mod_plus_intro complement_Lit_poset_eqclass.simps(1))
qed

lemma zero_in_Lit_mod_plus[simp]:
  fixes G
  shows "zero G \<in> Lit_mod_plus G"
proof -
{
  assume "\<not>Lit_mod_plus_cond G"
  then have "zero G = Zero_rep" by (metis zero_def)
  have ?thesis by (metis Lit_mod_plus_def Un_upper2 `\<not> Lit_mod_plus_cond G` `zero G = Zero_rep` insert_subset)
}
{
  assume "Lit_mod_plus_cond G"
  then have "zero G = Equiv [[SOME p. (p \<lesssim> G (p\<acute>))]]G" by (metis zero_def)
  have ?thesis by (metis Lit_mod_plus_intro `zero G = Equiv [[SOME p. (p \<lesssim> G (p\<acute>))]]G`)
}
  thus ?thesis by (metis `\<not> Lit_mod_plus_cond G \<Longrightarrow> zero G \<in> Lit_mod_plus G`)
qed

lemma one_in_Lit_mod_plus[simp]:
  fixes G
  shows "one G \<in> Lit_mod_plus G"
unfolding one_def by (metis Lit_eqclass_in_Lit_mod_plus zero_in_Lit_mod_plus)

definition up_closed :: "lit_mod_elt set \<Rightarrow> formula set \<Rightarrow> bool" where
  "up_closed A G \<equiv> \<forall>v \<in> A. (\<forall>w \<in> Lit_mod_plus G. (v \<lesssim>.G w) \<longrightarrow> w \<in> A)"

definition complete :: "lit_mod_elt set \<Rightarrow> formula set \<Rightarrow> bool" where
  "complete A G \<equiv> \<forall>v \<in> Lit_mod_plus G. v \<in> A \<or> (v.\<acute>G) \<in> A"

definition consistent :: "lit_mod_elt set \<Rightarrow> formula set \<Rightarrow> bool" where
  "consistent A G \<equiv> \<forall>v \<in> A. \<not>(v \<in> A \<and> (v.\<acute>G) \<in> A)"

definition "points G \<equiv> {S. S \<subseteq> Lit_mod_plus G \<and> up_closed S G \<and> complete S G \<and> consistent S G}"

lemma zeroisone:
    assumes "G \<equiv> {Some (q.) are (q`)}"
    shows " zero G = one G"
proof -
  have "G\<turnstile> All (q.) are (q`)"
    by (metis (mono_tags) ass assms axiom complement.simps(1) insert_compr mem_Collect_eq some2 the_elem_eq x)
  have "G\<turnstile> All (q`) are (q.)"
    by (metis (full_types) ass assms axiom complement.simps(1) complement_involutive insertI1 x)
  have "zero G = Equiv [[q.]] G"
    by (metis Lit_mod_plus_cond_def `G \<turnstile> All q. are (q\`)` all_zero_Eqclasses complement.simps(1) complement_involutive less_equal_Lit.elims(3))
  have "zero G = Equiv [[q`]] G"
    by (metis Lit_mod_plus_cond_def `G \<turnstile> All (q\`) are (q.)` all_zero_Eqclasses complement.simps(1) less_equal_Lit.elims(3))
  thus ?thesis
    by (metis `zero G = Equiv [[q.]]G` complement.simps(2) complement_Lit_poset_eqclass_simp2 one_def)
qed

lemma falseiszero:
  assumes "G \<equiv> {All (q.) are (q`)}"
  shows "(case (zero G) of (Equiv z) \<Rightarrow> (q.)\<in> z)"
(*ak nitpick finds a false counterexample *)
proof -
  have "Lit_mod_plus_cond G"
    unfolding Lit_mod_plus_cond_def
      by (metis (mono_tags) ass assms complement.simps(1) complement_involutive insertI1 less_equal_Lit.elims(3) the_elem_eq)
  have "(q.) \<lesssim>G ((q.)\<acute>)"
    by (metis assms complement.simps(2) insertI1 less_equal_Lit_ass)
  then have "zero G = Equiv [[q.]]G"
    unfolding zero_def by (metis (lifting) Lit_mod_plus_cond_def all_zero_Eqclasses someI)
  have "(q.) \<in> [[q.]]G" by (metis Lit_poset_eqclass_membership)
  thus ?thesis
by (metis `zero G = Equiv [[q.]]G` lit_mod_elt.simps(10))
qed

definition consistent2 :: "lit_mod_elt set \<Rightarrow> formula set \<Rightarrow> bool" where
  "consistent2 S G \<equiv> ( \<forall>x \<in> S. \<forall>y \<in> S. \<not>(x \<lesssim>.G (y.\<acute>G)) )"

lemma l4_1_aux :
  fixes G S
  assumes "S \<subseteq> Lit_mod_plus G"
  shows "consistent2 S G \<Longrightarrow> consistent S G"
proof -
  assume "consistent2 S G"

  have "consistent S G"
    unfolding consistent_def
    proof (rule ccontr)
      assume "\<not> (\<forall>x \<in> S. \<not> (x \<in> S \<and> x.\<acute>G \<in> S))"
      then have "\<exists>x \<in> S. x \<in> S  \<and> x.\<acute>G \<in> S" by blast
      then obtain x where "x \<in> S  \<and> x.\<acute>G \<in> S" by fast
      then have "\<not> (x \<lesssim>.G x)"
        by (metis Lit_eqclass_antitone `consistent2 S G` assms consistent2_def set_rev_mp)
      have "(x \<lesssim>.G x)"
        by (metis Lit_poset_eqclass_reflexive `x \<in> S \<and> x .\<acute> G \<in> S` assms in_mono)
      then show False by (metis `\<not> (x \<lesssim>.G x)`)
    qed
  thus ?thesis by simp
qed

lemma l4_1 :
  fixes G S_0
  assumes "S_0 \<subseteq> Lit_mod_plus G"
  and "points G \<noteq> {}"
  shows "( \<exists>S \<in> points G. S_0 \<subseteq> S ) \<longleftrightarrow> (consistent2 S_0 G)"
proof -
  {
    assume "\<exists>S \<in> points G. S_0 \<subseteq> S"
    have "\<forall>x \<in> S_0. \<forall>y \<in> S_0. \<not>(x \<lesssim>.G (y.\<acute>G))"
    proof (rule ccontr)
      assume "\<not> (\<forall>x \<in> S_0. \<forall>y \<in> S_0. \<not>(x \<lesssim>.G (y.\<acute>G)))"
      then have "\<exists>x \<in> S_0. \<exists>y \<in> S_0. (x \<lesssim>.G (y.\<acute>G))" by fast
      then obtain x y where "(x \<lesssim>.G (y.\<acute>G))" "x \<in> S_0" "y \<in> S_0" by force

      obtain S where S_0_sub_S: "S_0 \<subseteq> S" "S \<in> points G" by (metis `\<exists>S\<in>points G. S_0 \<subseteq> S`)
      {
        have "S \<notin> points G"
        proof (rule ccontr)
          assume "\<not>(S \<notin> points G)"
          have "(y.\<acute>G) \<in> S"
          proof -
            have f1: "\<And>v. S_0 \<subseteq> v \<longrightarrow> y \<in> v"
              by (metis (lifting) `y \<in> S_0` in_mono)
            have "\<And>v. S_0 \<subseteq> v \<longrightarrow> x \<in> v"
              by (metis (lifting) `x \<in> S_0` in_mono)
            hence "x \<in> S"
              using S_0_sub_S(1) subset_trans by simp
            hence "x \<in> S \<and> y .\<acute> G \<in> Lit_mod_plus G \<and> up_closed S G"
              using f1 Lit_eqclass_in_Lit_mod_plus S_0_sub_S(2) assms(1) points_def by simp
            hence "\<exists>w u. w \<in> S \<and> y.\<acute>G \<in> Lit_mod_plus u \<and> (w \<lesssim>.u y.\<acute>G) \<and> up_closed S u"
              by (metis (lifting) `x \<lesssim>.G y .\<acute> G`)
            thus "y .\<acute> G \<in> S"
              using up_closed_def by auto
          qed

          have "y \<in> S" by (metis S_0_sub_S(1) `y \<in> S_0` in_mono)
          then show False by (metis (lifting) S_0_sub_S(2) `y .\<acute> G \<in> S` consistent_def mem_Collect_eq points_def)
        qed
      }
      then show False by (metis S_0_sub_S(2))
    qed
  }
  {
    assume "consistent2 S_0 G"
    then have "\<forall>x \<in> S_0. \<forall>y \<in> S_0. \<not>(x \<lesssim>.G (y.\<acute>G))" by (metis consistent2_def)
    {
      assume "S_0 = {}"
      have "( \<exists>S \<in> points G. S_0 \<subseteq> S )" by (metis Collect_mem_eq `S_0 = {}` assms(2) empty_Collect_eq empty_subsetI)
    }
    {
      assume "S_0 \<noteq> {}"
      define A where "A = {x. S_0 \<subseteq> x \<and> x \<subseteq> Lit_mod_plus G \<and> consistent2 x G}"

      have "\<forall>C \<in> chains A. \<exists>U\<in>A. \<forall>X\<in>C. X \<subseteq> U"
      proof rule
        fix C
        assume "C \<in> chains A"
        show  "\<exists>U\<in>A. \<forall>X\<in>C. X \<subseteq> U"
        proof (simp add: A_def)
        {
          assume "C \<noteq> {}"
          define U where "U = \<Union>C"
          obtain x where "x \<in> C" by (metis Collect_mem_eq `C \<noteq> {}` empty_Collect_eq)
          then have "S_0 \<subseteq> x" by (metis (mono_tags) A_def `C \<in> chains A` chainsD2 mem_Collect_eq set_rev_mp)
          then have "S_0 \<subseteq> U" by (metis (full_types) U_def Union_upper `x \<in> C` subset_trans)

          have "\<Union>C \<subseteq> Lit_mod_plus G"
            by (metis (lifting) A_def Sup_le_iff `C \<in> chains A` chainsD2 mem_Collect_eq set_rev_mp)

          have "consistent2 (\<Union>C) G"
            unfolding consistent2_def
            proof auto
              fix y and x and ya and yb
              assume a1: "y \<in> C"
              assume a2: "x \<in> y"
              assume a3: "ya \<in> C"
              assume a4: "yb \<in> ya"
              assume a5: "x \<lesssim>.G yb .\<acute> G"
              show False by (metis (lifting, mono_tags) A_def `C \<in> chains A` a1 a2 a3 a4 a5 chainsD chainsD2 consistent2_def mem_Collect_eq subsetD)
            qed

          have "\<exists>U\<in>A. \<forall>X\<in>C. X \<subseteq> U" by (metis (lifting) A_def U_def Union_upper `S_0 \<subseteq> U` `\<Union>C \<subseteq> Lit_mod_plus G` `consistent2 (\<Union>C) G` mem_Collect_eq)
        }
        {
          assume "C = {}"
          define U where "U = S_0"
          have "\<exists>U\<in>A. \<forall>X\<in>C. X \<subseteq> U" by (metis (lifting) A_def `C = {}` `consistent2 S_0 G` all_not_in_conv assms(1) empty_Collect_eq eq_iff)
        }
          thus "\<exists>U. S_0 \<subseteq> U \<and> U \<subseteq> Lit_mod_plus G \<and> consistent2 U G \<and> (\<forall>X\<in>C. X \<subseteq> U)"
            by (metis (lifting) A_def `C \<noteq> {} \<Longrightarrow> \<exists>U\<in>A. \<forall>X\<in>C. X \<subseteq> U` mem_Collect_eq)
        qed
      qed
      then have "\<exists>M \<in> A. \<forall>X \<in> A. M \<subseteq> X \<longrightarrow> X = M" by (metis Zorn_Lemma2)
      then obtain S_1 where "S_1 \<in> A" "\<forall>X \<in> A. S_1 \<subseteq> X \<longrightarrow> X = S_1" by force

      then have "consistent2 S_1 G"
        by (metis (lifting, no_types) A_def mem_Collect_eq)
      have S_1_in_Lit_mod : "S_1 \<subseteq> Lit_mod_plus G" by (metis (lifting, no_types) A_def `S_1 \<in> A` mem_Collect_eq)
      define S where "S = { (q::lit_mod_elt). q \<in> Lit_mod_plus G \<and> (\<exists>p \<in> S_1. (p \<lesssim>.G q))}"

      have "\<forall>x \<in> S. (\<exists>y \<in> S_1. (y \<lesssim>.G x))"
        proof -
          { fix sk\<^sub>0 :: lit_mod_elt
            have ff1: "sk\<^sub>0 \<in> {uu. \<exists>x. x \<in> S_1 \<and> (x \<lesssim>.G uu)} \<or> sk\<^sub>0 \<notin> S \<or> (\<exists>x\<^sub>1. x\<^sub>1 \<in> S_1 \<and> (x\<^sub>1 \<lesssim>.G sk\<^sub>0))"
              using S_def by blast
            have "sk\<^sub>0 \<notin> S \<or> (\<exists>x\<^sub>1. x\<^sub>1 \<in> S_1 \<and> (x\<^sub>1 \<lesssim>.G sk\<^sub>0))"
              using ff1 by fastforce }
          thus "\<forall>x\<in>S. \<exists>y\<in>S_1. (y \<lesssim>.G x)"
            by blast
        qed

      have S_in_Lit_mod_plus : "S \<subseteq> Lit_mod_plus G"
        by (metis (lifting, no_types) S_def mem_Collect_eq subsetI)

      have "S_0 \<subseteq> S_1" by (metis (lifting, no_types) A_def `S_1 \<in> A` mem_Collect_eq)
      have "S_1 \<subseteq> S"
        unfolding S_def by (metis (lifting, mono_tags) Lit_poset_eqclass_reflexive S_1_in_Lit_mod S_def in_mono mem_Collect_eq subsetI)
      then have "S_0 \<subseteq> S" by (metis `S_0 \<subseteq> S_1` dual_order.trans)

      have "S_1 \<noteq> {}" by (metis `S_0 \<noteq> {}` `S_0 \<subseteq> S_1` subset_empty)

      have "one G \<in> S"
        proof -
          obtain x where "x \<in> S_1" by (metis `S_1 \<noteq> {}` ex_in_conv)

          then have "x \<in> Lit_mod_plus G" by (metis (full_types) S_1_in_Lit_mod in_mono)
          have "x \<lesssim>.G (one G)"
            proof -
            {
              assume "\<not>Lit_mod_plus_cond G"
              then have "one G = One_rep" by (metis Lit_eqiv_class_complement_inconsistency Lit_mod_plus_def Un_insert_right complement_Lit_poset_eqclass.simps(2) insertCI less_equal_Lit_poset_eqclass.simps(2) one_def)
              then have ?thesis by (metis (full_types) Lit_eqclass_antitone `x \<in> Lit_mod_plus G` complement_Lit_poset_eqclass.simps(3) less_equal_Lit_poset_eqclass.simps(2) one_in_Lit_mod_plus)
            }
            {
              assume "Lit_mod_plus_cond G"
              then have "zero G = Equiv [[SOME p. (p \<lesssim> G (p\<acute>))]]G" by (metis zero_def)
              then have "(zero G) \<lesssim>.G x.\<acute>G" by (metis (full_types) Lit_eqclass_in_Lit_mod_plus `x \<in> Lit_mod_plus G` zero_less_than_all)
              then have ?thesis by (metis Lit_eqclass_antitone Lit_eqclass_in_Lit_mod_plus Lit_eqclass_involutive `x \<in> Lit_mod_plus G` one_def zero_in_Lit_mod_plus)
            }
              thus ?thesis by (metis `\<not> Lit_mod_plus_cond G \<Longrightarrow> x \<lesssim>.G (one G)`)
            qed
            then have "\<exists>p\<in>S_1. (p \<lesssim>.G (one G))" by (metis `x \<in> S_1`)
            show ?thesis by (metis (lifting, no_types) S_def `\<exists>p\<in>S_1. (p \<lesssim>.G (one G))` mem_Collect_eq one_in_Lit_mod_plus)
          qed

      have "up_closed S G"
        unfolding up_closed_def
        proof auto
          fix x y
          assume "x \<in> S" and "y \<in> Lit_mod_plus G" and "x \<lesssim>.G y"

          { assume "x \<in> S_1"
          have "y \<in> S"
            unfolding S_def by (metis (lifting, no_types) `x \<in> S_1` `x \<lesssim>.G y` `y \<in> Lit_mod_plus G` mem_Collect_eq) }
          { assume "x \<notin> S_1"
          then have "\<exists>a \<in> S_1. (a \<lesssim>.G x)" by (metis `x \<in> S` `\<forall>x\<in>S. \<exists>y\<in>S_1. (y \<lesssim>.G x)`)
          then have "y \<in> S"
            unfolding S_def
            using Lit_poset_eqclass_trans S_1_in_Lit_mod S_in_Lit_mod_plus \<open>x \<in> S\<close> \<open>x \<lesssim>.G y\<close> \<open>y \<in> Lit_mod_plus G\<close> by blast }
          thus "y \<in> S" by (metis `x \<in> S_1 \<Longrightarrow> y \<in> S`)
        qed

      have "consistent S G"
      proof (rule ccontr)
        assume "\<not> consistent S G"
        then obtain r where "r \<in> S" "r.\<acute>G \<in> S" by (metis (full_types) consistent_def)
        then obtain q_1 q_2 where "q_1 \<in> S_1" "q_1 \<lesssim>.G r" "q_2 \<in> S_1" "q_2 \<lesssim>.G r.\<acute>G" by (metis `\<forall>x\<in>S. \<exists>y\<in>S_1. (y \<lesssim>.G x)`)
        then have 1: "r \<lesssim>.G q_2.\<acute>G" by (metis (full_types) Lit_eqclass_antitone Lit_eqclass_involutive S_1_in_Lit_mod S_in_Lit_mod_plus `r.\<acute>G \<in> S` `r \<in> S` in_mono)
        have 2: "r \<in> Lit_mod_plus G" by (metis S_in_Lit_mod_plus `r \<in> S` in_mono)
        have "q_1 \<in> Lit_mod_plus G" "q_2 \<in> Lit_mod_plus G" by (metis S_1_in_Lit_mod `q_1 \<in> S_1` set_rev_mp) (metis S_1_in_Lit_mod `q_2 \<in> S_1` set_rev_mp)
        then have "q_2.\<acute>G \<in> Lit_mod_plus G" by (metis Lit_eqclass_in_Lit_mod_plus)
        with 1 2 `q_1 \<lesssim>.G r` have "q_1 \<lesssim>.G q_2.\<acute>G" by (metis Lit_poset_eqclass_trans `q_1 \<in> Lit_mod_plus G`)
        then have "q_2.\<acute>G \<in> S_1" by (metis `q_1 \<in> S_1` `q_2 \<in> S_1` `consistent2 S_1 G` consistent2_def)
        then show False by (metis S_1_in_Lit_mod `q_2 \<in> S_1` `consistent2 S_1 G` consistent_def l4_1_aux)
      qed

      have "complete S G"
        unfolding complete_def
      proof (rule ccontr)
        assume "\<not> (\<forall>x\<in>Lit_mod_plus G. x \<in> S \<or> x.\<acute>G \<in> S)"
        then have "\<exists>x \<in> Lit_mod_plus G. x \<notin> S \<and> x.\<acute>G \<notin> S" by blast
        then obtain r where "r \<in> Lit_mod_plus G" "r \<notin> S \<and> r.\<acute>G \<notin> S" by force

        have "consistent2 (S_1 \<union> {r}) G"
          proof (rule ccontr)
            assume "\<not> consistent2 (S_1 \<union> {r}) G"
            then have "\<exists>x \<in> (S_1 \<union> {r}). \<exists>y \<in> (S_1 \<union> {r}). (x \<lesssim>.G y.\<acute>G)"
              by (metis (mono_tags) consistent2_def)
            then obtain x y where "x \<in> (S_1 \<union> {r})" "y \<in> (S_1 \<union> {r})" "(x \<lesssim>.G y.\<acute>G)" by blast
            have "x \<in> Lit_mod_plus G" "y \<in> Lit_mod_plus G"
              by (metis (full_types) S_1_in_Lit_mod Un_iff `r \<in> Lit_mod_plus G` `x \<in> S_1 \<union> {r}` empty_iff in_mono insert_iff)
                 (metis (full_types) S_1_in_Lit_mod Un_iff `r \<in> Lit_mod_plus G` `y \<in> S_1 \<union> {r}` empty_iff in_mono insert_iff)
            {
              assume "x = r" "y \<noteq> r"
              then have "r \<lesssim>.G y.\<acute>G" by (metis `x \<lesssim>.G y .\<acute> G`)
              then have "y \<lesssim>.G r.\<acute>G" by (metis (mono_tags) Lit_eqclass_antitone Lit_eqclass_in_Lit_mod_plus Lit_eqclass_involutive `r \<in> Lit_mod_plus G` `x = r` `x \<lesssim>.G y .\<acute> G` `y \<in> Lit_mod_plus G`)
              have "y \<in> S_1" by (metis Un_iff `y \<in> S_1 \<union> {r}` `y \<noteq> r` singleton_iff)
              then have "r.\<acute>G \<in> S" by (metis (lifting, no_types) Lit_eqclass_in_Lit_mod_plus S_def `r \<in> Lit_mod_plus G` `y \<lesssim>.G r .\<acute> G` mem_Collect_eq)
              then have False by (metis `r \<notin> S \<and> r .\<acute> G \<notin> S`)
            }
            {
              assume "x \<noteq> r" "y = r"
              then have "x \<lesssim>.G r.\<acute>G" by (metis `x \<lesssim>.G y .\<acute> G`)
              have "x \<in> S_1" by (metis Un_iff `x \<in> S_1 \<union> {r}` `x \<noteq> r` singleton_iff)
              then have "r.\<acute>G \<in> S" by (metis (lifting, no_types) Lit_eqclass_in_Lit_mod_plus S_def `r \<in> Lit_mod_plus G` `x \<lesssim>.G r .\<acute> G` mem_Collect_eq)
              then have False by (metis `r \<notin> S \<and> r .\<acute> G \<notin> S`)
            }
            {
              assume "x = r" "y = r"
              then have "r \<lesssim>.G r.\<acute>G" by (metis `x \<lesssim>.G y.\<acute>G`)
              then have "r = zero G" by (metis Lit_eqiv_class_complement_inconsistency Lit_poset_eqclass_reflexive `r \<in> Lit_mod_plus G`)
              then have False by (metis `r \<notin> S \<and> r .\<acute> G \<notin> S` `one G \<in> S` one_def)
            }
            {
              assume "x \<noteq> r" "y \<noteq> r"
              then have "x \<in> S_1" "y \<in> S_1"
                by (metis Un_iff `x \<in> S_1 \<union> {r}` singleton_iff)
                   (metis Un_iff `y \<in> S_1 \<union> {r}` `y \<noteq> r` singleton_iff)
              then have "x \<lesssim>.G y.\<acute>G" by (metis `x \<lesssim>.G y .\<acute> G`)
              then have False by (metis `x \<in> S_1` `y \<in> S_1` `consistent2 S_1 G` consistent2_def)
            }
            then show False by (metis `\<lbrakk>x = r; y = r\<rbrakk> \<Longrightarrow> False` `\<lbrakk>x = r; y \<noteq> r\<rbrakk> \<Longrightarrow> False` `\<lbrakk>x \<noteq> r; y = r\<rbrakk> \<Longrightarrow> False`)
          qed

        have "S_0 \<subseteq> (S_1 \<union> {r})" by (metis `S_0 \<subseteq> S_1` sup.coboundedI1)
        have "(S_1 \<union> {r}) \<subseteq> Lit_mod_plus G" by (metis S_1_in_Lit_mod Un_empty_right Un_insert_right `r \<in> Lit_mod_plus G` insert_subset)
        then have "(S_1 \<union> {r}) \<in> A"
          unfolding A_def by (metis (lifting) `S_0 \<subseteq> S_1 \<union> {r}` `consistent2 (S_1 \<union> {r}) G` mem_Collect_eq)
        then show False
          by (metis Un_absorb Un_empty_right Un_insert_right `r \<notin> S \<and> r .\<acute> G \<notin> S` `S_1 \<subseteq> S` `\<forall>X\<in>A. S_1 \<subseteq> X \<longrightarrow> X = S_1` insert_subset subset_Un_eq)
      qed

      have "S \<in> points G"
        unfolding points_def
        by (metis (lifting, no_types) S_in_Lit_mod_plus `complete S G` `consistent S G` `up_closed S G` mem_Collect_eq)
      have "( \<exists>S \<in> points G. S_0 \<subseteq> S )" by (metis `S \<in> points G` `S_0 \<subseteq> S`)
    }
    then have "\<exists>S\<in>points G. S_0 \<subseteq> S" by (metis `S_0 = {} \<Longrightarrow> \<exists>S\<in>points G. S_0 \<subseteq> S`)
  }
  thus ?thesis by (metis `\<exists>S\<in>points G. S_0 \<subseteq> S \<Longrightarrow> \<forall>x\<in>S_0. \<forall>y\<in>S_0. \<not> (x \<lesssim>.G y.\<acute>G)` consistent2_def)
qed
(*declare [[show_types]]*)

end


(* Author: Tobias Nipkow *)

section \<open>Function \textit{isin} for Tree2\<close>

theory Isin2
imports
  Tree2
  Cmp
  Set_by_Ordered
begin

fun isin :: "('a::linorder,'b) tree \<Rightarrow> 'a \<Rightarrow> bool" where
"isin Leaf x = False" |
"isin (Node _ l a r) x =
  (case cmp x a of
     LT \<Rightarrow> isin l x |
     EQ \<Rightarrow> True |
     GT \<Rightarrow> isin r x)"

lemma "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems(inorder t))"
by (induction t) (auto simp: elems_simps1)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems(inorder t))"
by (induction t) (auto simp: elems_simps2)

end


(*  Title:     HOL/Inequalities.thy
    Author:    Tobias Nipkow
    Author:    Johannes Hölzl
*)

theory Inequalities
  imports Real_Vector_Spaces
begin

lemma Sum_Icc_int: "(m::int) \<le> n \<Longrightarrow> \<Sum> {m..n} = (n*(n+1) - m*(m-1)) div 2"
proof(induct i == "nat(n-m)" arbitrary: m n)
  case 0
  hence "m = n" by arith
  thus ?case by (simp add: algebra_simps)
next
  case (Suc i)
  have 0: "i = nat((n-1) - m)" "m \<le> n-1" using Suc(2,3) by arith+
  have "\<Sum> {m..n} = \<Sum> {m..1+(n-1)}" by simp
  also have "\<dots> = \<Sum> {m..n-1} + n" using \<open>m \<le> n\<close>
    by(subst atLeastAtMostPlus1_int_conv) simp_all
  also have "\<dots> = ((n-1)*(n-1+1) - m*(m-1)) div 2 + n"
    by(simp add: Suc(1)[OF 0])
  also have "\<dots> = ((n-1)*(n-1+1) - m*(m-1) + 2*n) div 2" by simp
  also have "\<dots> = (n*(n+1) - m*(m-1)) div 2" by(simp add: algebra_simps)
  finally show ?case .
qed

lemma Sum_Icc_nat: assumes "(m::nat) \<le> n"
shows "\<Sum> {m..n} = (n*(n+1) - m*(m-1)) div 2"
proof -
  have "m*(m-1) \<le> n*(n + 1)"
   using assms by (meson diff_le_self order_trans le_add1 mult_le_mono)
  hence "int(\<Sum> {m..n}) = int((n*(n+1) - m*(m-1)) div 2)" using assms
    by (auto simp: Sum_Icc_int[transferred, OF assms] zdiv_int of_nat_mult simp del: of_nat_sum
          split: zdiff_int_split)
  thus ?thesis
    using of_nat_eq_iff by blast
qed

lemma Sum_Ico_nat: assumes "(m::nat) \<le> n"
shows "\<Sum> {m..<n} = (n*(n-1) - m*(m-1)) div 2"
proof cases
  assume "m < n"
  hence "{m..<n} = {m..n-1}" by auto
  hence "\<Sum>{m..<n} = \<Sum>{m..n-1}" by simp
  also have "\<dots> = (n*(n-1) - m*(m-1)) div 2"
    using assms \<open>m < n\<close> by (simp add: Sum_Icc_nat mult.commute)
  finally show ?thesis .
next
  assume "\<not> m < n" with assms show ?thesis by simp
qed

lemma Chebyshev_sum_upper:
  fixes a b::"nat \<Rightarrow> 'a::linordered_idom"
  assumes "\<And>i j. i \<le> j \<Longrightarrow> j < n \<Longrightarrow> a i \<le> a j"
  assumes "\<And>i j. i \<le> j \<Longrightarrow> j < n \<Longrightarrow> b i \<ge> b j"
  shows "of_nat n * (\<Sum>k=0..<n. a k * b k) \<le> (\<Sum>k=0..<n. a k) * (\<Sum>k=0..<n. b k)"
proof -
  let ?S = "(\<Sum>j=0..<n. (\<Sum>k=0..<n. (a j - a k) * (b j - b k)))"
  have "2 * (of_nat n * (\<Sum>j=0..<n. (a j * b j)) - (\<Sum>j=0..<n. b j) * (\<Sum>k=0..<n. a k)) = ?S"
    by (simp only: one_add_one[symmetric] algebra_simps)
      (simp add: algebra_simps sum_subtractf sum.distrib sum.commute[of "\<lambda>i j. a i * b j"] sum_distrib_left)
  also
  { fix i j::nat assume "i<n" "j<n"
    hence "a i - a j \<le> 0 \<and> b i - b j \<ge> 0 \<or> a i - a j \<ge> 0 \<and> b i - b j \<le> 0"
      using assms by (cases "i \<le> j") (auto simp: algebra_simps)
  } then have "?S \<le> 0"
    by (auto intro!: sum_nonpos simp: mult_le_0_iff)
  finally show ?thesis by (simp add: algebra_simps)
qed

lemma Chebyshev_sum_upper_nat:
  fixes a b :: "nat \<Rightarrow> nat"
  shows "(\<And>i j. \<lbrakk> i\<le>j; j<n \<rbrakk> \<Longrightarrow> a i \<le> a j) \<Longrightarrow>
         (\<And>i j. \<lbrakk> i\<le>j; j<n \<rbrakk> \<Longrightarrow> b i \<ge> b j) \<Longrightarrow>
    n * (\<Sum>i=0..<n. a i * b i) \<le> (\<Sum>i=0..<n. a i) * (\<Sum>i=0..<n. b i)"
using Chebyshev_sum_upper[where 'a=real, of n a b]
by (simp del: of_nat_mult of_nat_sum  add: of_nat_mult[symmetric] of_nat_sum[symmetric])

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
begin

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

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

definition\<^marker>\<open>tag important\<close> 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 abs_harm [simp]: "(abs (harm n) :: real) = harm n"
  using harm_nonneg[of n] by (rule abs_of_nonneg)

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)

theorem 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)

lemma harm_at_top: "filterlim (harm :: nat \<Rightarrow> real) at_top sequentially"
proof (rule filterlim_at_top_mono)
  show "eventually (\<lambda>n. harm n \<ge> ln (real (Suc n))) at_top"
    using ln_le_harm by (intro always_eventually allI) (simp_all add: add_ac)
  show "filterlim (\<lambda>n. ln (real (Suc n))) at_top sequentially"
    by (intro filterlim_compose[OF ln_at_top] filterlim_compose[OF filterlim_real_sequentially]
              filterlim_Suc)
qed

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)

lemma harm_ge_ln: "harm n \<ge> ln (real n + 1)"
proof -
  have "ln (n + 1) = (\<Sum>j<n. ln (real (Suc j + 1)) - ln (real (j + 1)))"
    by (subst sum_lessThan_telescope) auto
  also have "\<dots> \<le> (\<Sum>j<n. 1 / (Suc j))"
  proof (intro sum_mono, clarify)
    fix j assume j: "j < n"
    have "\<exists>\<xi>. \<xi> > real j + 1 \<and> \<xi> < real j + 2 \<and>
            ln (real j + 2) - ln (real j + 1) = (real j + 2 - (real j + 1)) * (1 / \<xi>)"
      by (intro MVT2) (auto intro!: derivative_eq_intros)
    then obtain \<xi> :: real
      where \<xi>: "\<xi> \<in> {real j + 1..real j + 2}" "ln (real j + 2) - ln (real j + 1) = 1 / \<xi>"
      by auto
    note \<xi>(2)
    also have "1 / \<xi> \<le> 1 / (Suc j)"
      using \<xi>(1) by (auto simp: field_simps)
    finally show "ln (real (Suc j + 1)) - ln (real (j + 1)) \<le> 1 / (Suc j)"
      by (simp add: add_ac)
  qed
  also have "\<dots> = harm n"
    by (simp add: harm_altdef field_simps)
  finally show ?thesis by (simp add: add_ac)
qed

lemma decseq_harm_diff_ln: "decseq (\<lambda>n. harm (Suc n) - ln (Suc n))"
proof (rule decseq_SucI)
  fix m :: nat
  define n where "n = Suc m"
  have "n > 0" by (simp add: n_def)
  have "convex_on {0<..} (\<lambda>x :: real. -ln x)"
    by (rule convex_on_realI[where f' = "\<lambda>x. -1/x"])
       (auto intro!: derivative_eq_intros simp: field_simps)
  hence "(-1 / (n + 1)) * (real n - real (n + 1)) \<le> (- ln (real n)) - (-ln (real (n + 1)))"
    using \<open>n > 0\<close> by (intro convex_on_imp_above_tangent[where A = "{0<..}"])
                     (auto intro!: derivative_eq_intros simp: interior_open)
  thus "harm (Suc n) - ln (Suc n) \<le> harm n - ln n"
    by (auto simp: harm_Suc field_simps)
qed

lemma euler_mascheroni_sequence_nonneg:
  assumes "n > 0"
  shows   "harm n - ln (real n) \<ge> (0 :: real)"
proof -
  have "ln (real n) \<le> ln (real n + 1)"
    using assms by simp
  also have "\<dots> \<le> harm n"
    by (rule harm_ge_ln)
  finally show ?thesis by simp
qed

lemma euler_mascheroni_convergent: "convergent (\<lambda>n. harm n - ln n)"
proof -
  have "harm (Suc n) - ln (real (Suc n)) \<ge> 0" for n :: nat
    using euler_mascheroni_sequence_nonneg[of "Suc n"] by simp
  hence "convergent (\<lambda>n. harm (Suc n) - ln (Suc n))"
    by (intro Bseq_monoseq_convergent decseq_bounded[of _ 0] decseq_harm_diff_ln decseq_imp_monoseq)
       auto
  thus ?thesis
    by (subst (asm) convergent_Suc_iff)
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)"
  using decseqD[OF decseq_harm_diff_ln, of "m - 1" "n - 1"] by simp

lemma\<^marker>\<open>tag important\<close> 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

theorem 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: strict_mono_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 (blast intro: 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 "(*) (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: strict_mono_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\<^marker>\<open>tag unimportant\<close> \<open>Bounds on the Euler-Mascheroni constant\<close>
(* TODO: perhaps move this section away to remove unnecessary dependency on integration *)

(* 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"
  let ?f = "\<lambda>t. (t - x) * f' + inverse x"
  let ?F = "\<lambda>t. (t - x)^2 * f' / 2 + t * inverse x"

  have deriv: "\<exists>D. ((\<lambda>x. ?F x - ln x) has_field_derivative D) (at \<xi>) \<and> D \<ge> 0"
    if "\<xi> \<ge> x" "\<xi> \<le> x + a" for \<xi>
  proof -
    from that assms have t: "0 \<le> (\<xi> - x) / a" "(\<xi> - x) / a \<le> 1" by simp_all
    have "inverse \<xi> = inverse ((1 - (\<xi> - x) / a) *\<^sub>R x + ((\<xi> - x) / a) *\<^sub>R (x + a))" (is "_ = ?A")
      using assms 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 - (\<xi> - x) / a) * inverse x + (\<xi> - x) / a * inverse (x + a)" by simp
    also have "\<dots> = (\<xi> - x) * f' + inverse x" using assms
      by (simp add: f'_def divide_simps) (simp add: field_simps)
    finally have "?f \<xi> - 1 / \<xi> \<ge> 0" by (simp add: field_simps)
    moreover have "((\<lambda>x. ?F x - ln x) has_field_derivative ?f \<xi> - 1 / \<xi>) (at \<xi>)"
      using that assms by (auto intro!: derivative_eq_intros simp: field_simps)
    ultimately show ?thesis by blast
  qed
  have "?F x - ln x \<le> ?F (x + a) - ln (x + a)"
    by (rule DERIV_nonneg_imp_nondecreasing[of x "x + a", OF _ deriv]) (use assms in auto)
  thus ?thesis
    using assms by (simp add: f'_def divide_simps) (simp add: algebra_simps power2_eq_square)?
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"
  let ?f = "\<lambda>t. (t - m) * f' + inverse m"

  have deriv: "\<exists>D. ((\<lambda>x. ln x - ?F x) has_field_derivative D) (at \<xi>) \<and> D \<ge> 0"
    if "\<xi> \<ge> x" "\<xi> \<le> y" for \<xi>
  proof -
    from that assms have "inverse \<xi> - inverse m \<ge> f' * (\<xi> - 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)
    hence "1 / \<xi> - ?f \<xi> \<ge> 0" by (simp add: field_simps f'_def)
    moreover have "((\<lambda>x. ln x - ?F x) has_field_derivative 1 / \<xi> - ?f \<xi>) (at \<xi>)"
      using that assms m by (auto intro!: derivative_eq_intros simp: field_simps)
    ultimately show ?thesis by blast
  qed
  have "ln x - ?F x \<le> ln y - ?F y"
    by (rule DERIV_nonneg_imp_nondecreasing[of x y, OF _ deriv]) (use assms in auto)
  hence "ln y - ln x \<ge> ?F y - ?F x"
    by (simp add: algebra_simps)
  also have "?F y - ?F x = ?A"
    using assms by (simp add: f'_def m_def divide_simps) (simp add: algebra_simps power2_eq_square)
  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: field_split_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>\<open>ln 2\<close>. 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])
  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


(*  Title:      HOL/Hull.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
    Author:     Johannes Hölzl, VU Amsterdam
*)

theory Hull
  imports Main
begin

subsection \<open>A generic notion of the convex, affine, conic hull, or closed "hull".\<close>

definition hull :: "('a set \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "hull" 75)
  where "S hull s = \<Inter>{t. S t \<and> s \<subseteq> t}"

lemma hull_same: "S s \<Longrightarrow> S hull s = s"
  unfolding hull_def by auto

lemma hull_in: "(\<And>T. Ball T S \<Longrightarrow> S (\<Inter>T)) \<Longrightarrow> S (S hull s)"
  unfolding hull_def Ball_def by auto

lemma hull_eq: "(\<And>T. Ball T S \<Longrightarrow> S (\<Inter>T)) \<Longrightarrow> (S hull s) = s \<longleftrightarrow> S s"
  using hull_same[of S s] hull_in[of S s] by metis

lemma hull_hull [simp]: "S hull (S hull s) = S hull s"
  unfolding hull_def by blast

lemma hull_subset[intro]: "s \<subseteq> (S hull s)"
  unfolding hull_def by blast

lemma hull_mono: "s \<subseteq> t \<Longrightarrow> (S hull s) \<subseteq> (S hull t)"
  unfolding hull_def by blast

lemma hull_antimono: "\<forall>x. S x \<longrightarrow> T x \<Longrightarrow> (T hull s) \<subseteq> (S hull s)"
  unfolding hull_def by blast

lemma hull_minimal: "s \<subseteq> t \<Longrightarrow> S t \<Longrightarrow> (S hull s) \<subseteq> t"
  unfolding hull_def by blast

lemma subset_hull: "S t \<Longrightarrow> S hull s \<subseteq> t \<longleftrightarrow> s \<subseteq> t"
  unfolding hull_def by blast

lemma hull_UNIV [simp]: "S hull UNIV = UNIV"
  unfolding hull_def by auto

lemma hull_unique: "s \<subseteq> t \<Longrightarrow> S t \<Longrightarrow> (\<And>t'. s \<subseteq> t' \<Longrightarrow> S t' \<Longrightarrow> t \<subseteq> t') \<Longrightarrow> (S hull s = t)"
  unfolding hull_def by auto

lemma hull_induct: "\<lbrakk>a \<in> Q hull S; \<And>x. x\<in> S \<Longrightarrow> P x; Q {x. P x}\<rbrakk> \<Longrightarrow> P a"
  using hull_minimal[of S "{x. P x}" Q]
  by (auto simp add: subset_eq)

lemma hull_inc: "x \<in> S \<Longrightarrow> x \<in> P hull S"
  by (metis hull_subset subset_eq)

lemma hull_Un_subset: "(S hull s) \<union> (S hull t) \<subseteq> (S hull (s \<union> t))"
  unfolding Un_subset_iff by (metis hull_mono Un_upper1 Un_upper2)

lemma hull_Un:
  assumes T: "\<And>T. Ball T S \<Longrightarrow> S (\<Inter>T)"
  shows "S hull (s \<union> t) = S hull (S hull s \<union> S hull t)"
  apply (rule equalityI)
  apply (meson hull_mono hull_subset sup.mono)
  by (metis hull_Un_subset hull_hull hull_mono)

lemma hull_Un_left: "P hull (S \<union> T) = P hull (P hull S \<union> T)"
  apply (rule equalityI)
   apply (simp add: Un_commute hull_mono hull_subset sup.coboundedI2)
  by (metis Un_subset_iff hull_hull hull_mono hull_subset)

lemma hull_Un_right: "P hull (S \<union> T) = P hull (S \<union> P hull T)"
  by (metis hull_Un_left sup.commute)

lemma hull_insert:
   "P hull (insert a S) = P hull (insert a (P hull S))"
  by (metis hull_Un_right insert_is_Un)

lemma hull_redundant_eq: "a \<in> (S hull s) \<longleftrightarrow> S hull (insert a s) = S hull s"
  unfolding hull_def by blast

lemma hull_redundant: "a \<in> (S hull s) \<Longrightarrow> S hull (insert a s) = S hull s"
  by (metis hull_redundant_eq)

end


section \<open> Unrestriction \<close>

theory utp_unrest
  imports utp_expr_insts
begin

subsection \<open> Definitions and Core Syntax \<close>

text \<open> Unrestriction is an encoding of semantic freshness that allows us to reason about the
  presence of variables in predicates without being concerned with abstract syntax trees.
  An expression $p$ is unrestricted by lens $x$, written $x \mathop{\sharp} p$, if
  altering the value of $x$ has no effect on the valuation of $p$. This is a sufficient
  notion to prove many laws that would ordinarily rely on an \emph{fv} function.

  Unrestriction was first defined in the work of Marcel Oliveira~\cite{Oliveira2005-PHD,Oliveira07} in his
  UTP mechanisation in \emph{ProofPowerZ}. Our definition modifies his in that our variables
  are semantically characterised as lenses, and supported by the lens laws, rather than named
  syntactic entities. We effectively fuse the ideas from both Feliachi~\cite{Feliachi2010} and
  Oliveira's~\cite{Oliveira07} mechanisations of the UTP, the former being also purely semantic
  in nature.

  We first set up overloaded syntax for unrestriction, as several concepts will have this
  defined. \<close>

consts
  unrest :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

syntax
  "_unrest" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<sharp>" 20)

translations
  "_unrest x p" == "CONST unrest x p"
  "_unrest (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_unrest (x +\<^sub>L y) P"

text \<open> Our syntax translations support both variables and variable sets such that we can write down
  predicates like @{term "&x \<sharp> P"} and also @{term "{&x,&y,&z} \<sharp> P"}.

  We set up a simple tactic for discharging unrestriction conjectures using a simplification set. \<close>

named_theorems unrest
method unrest_tac = (simp add: unrest)?

text \<open> Unrestriction for expressions is defined as a lifted construct using the underlying lens
  operations. It states that lens $x$ is unrestricted by expression $e$ provided that, for any
  state-space binding $b$ and variable valuation $v$, the value which the expression evaluates
  to is unaltered if we set $x$ to $v$ in $b$. In other words, we cannot effect the behaviour
  of $e$ by changing $x$. Thus $e$ does not observe the portion of state-space characterised
  by $x$. We add this definition to our overloaded constant. \<close>

lift_definition unrest_uexpr :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> bool"
is "\<lambda> x e. \<forall> b v. e (put\<^bsub>x\<^esub> b v) = e b" .

adhoc_overloading
  unrest unrest_uexpr

lemma unrest_expr_alt_def:
  "weak_lens x \<Longrightarrow> (x \<sharp> P) = (\<forall> b b'. \<lbrakk>P\<rbrakk>\<^sub>e (b \<oplus>\<^sub>L b' on x) = \<lbrakk>P\<rbrakk>\<^sub>e b)"
  by (transfer, metis lens_override_def weak_lens.put_get)

subsection \<open> Unrestriction laws \<close>

text \<open> We now prove unrestriction laws for the key constructs of our expression model. Many
  of these depend on lens properties and so variously employ the assumptions @{term mwb_lens} and
  @{term vwb_lens}, depending on the number of assumptions from the lenses theory is required.

  Firstly, we prove a general property -- if $x$ and $y$ are both unrestricted in $P$, then their composition
  is also unrestricted in $P$. One can interpret the composition here as a union -- if the two sets
  of variables $x$ and $y$ are unrestricted, then so is their union. \<close>

lemma unrest_var_comp [unrest]:
  "\<lbrakk> x \<sharp> P; y \<sharp> P \<rbrakk> \<Longrightarrow> x;y \<sharp> P"
  by (transfer, simp add: lens_defs)

lemma unrest_svar [unrest]: "(&x \<sharp> P) \<longleftrightarrow> (x \<sharp> P)"
  by (transfer, simp add: lens_defs)

text \<open> No lens is restricted by a literal, since it returns the same value for any state binding. \<close>

lemma unrest_lit [unrest]: "x \<sharp> \<guillemotleft>v\<guillemotright>"
  by (transfer, simp)

text \<open> If one lens is smaller than another, then any unrestriction on the larger lens implies
  unrestriction on the smaller. \<close>

lemma unrest_sublens:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<sharp> P" "y \<subseteq>\<^sub>L x"
  shows "y \<sharp> P"
  using assms
  by (transfer, metis (no_types, lifting) lens.select_convs(2) lens_comp_def sublens_def)

text \<open> If two lenses are equivalent, and thus they characterise the same state-space regions,
  then clearly unrestrictions over them are equivalent. \<close>

lemma unrest_equiv:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "mwb_lens y" "x \<approx>\<^sub>L y" "x \<sharp> P"
  shows "y \<sharp> P"
  by (metis assms lens_equiv_def sublens_pres_mwb sublens_put_put unrest_uexpr.rep_eq)

text \<open> If we can show that an expression is unrestricted on a bijective lens, then is unrestricted
  on the entire state-space. \<close>

lemma bij_lens_unrest_all:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "bij_lens X" "X \<sharp> P"
  shows "\<Sigma> \<sharp> P"
  using assms bij_lens_equiv_id lens_equiv_def unrest_sublens by blast

lemma bij_lens_unrest_all_eq:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "bij_lens X"
  shows "(\<Sigma> \<sharp> P) \<longleftrightarrow> (X \<sharp> P)"
  by (meson assms bij_lens_equiv_id lens_equiv_def unrest_sublens)

text \<open> If an expression is unrestricted by all variables, then it is unrestricted by any variable \<close>

lemma unrest_all_var:
  fixes e :: "('a, '\<alpha>) uexpr"
  assumes "\<Sigma> \<sharp> e"
  shows "x \<sharp> e"
  by (metis assms id_lens_def lens.simps(2) unrest_uexpr.rep_eq)

text \<open> We can split an unrestriction composed by lens plus \<close>

lemma unrest_plus_split:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<bowtie> y" "vwb_lens x" "vwb_lens y"
  shows "unrest (x +\<^sub>L y) P \<longleftrightarrow> (x \<sharp> P) \<and> (y \<sharp> P)"
  using assms
  by (meson lens_plus_right_sublens lens_plus_ub sublens_refl unrest_sublens unrest_var_comp vwb_lens_wb)

text \<open> The following laws demonstrate the primary motivation for lens independence: a variable
  expression is unrestricted by another variable only when the two variables are independent.
  Lens independence thus effectively allows us to semantically characterise when two variables,
  or sets of variables, are different. \<close>

lemma unrest_var [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> y \<sharp> var x"
  by (transfer, auto)

lemma unrest_iuvar [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y \<sharp> $x"
  by (simp add: unrest_var)

lemma unrest_ouvar [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y\<acute> \<sharp> $x\<acute>"
  by (simp add: unrest_var)

text \<open> The following laws follow automatically from independence of input and output variables. \<close>

lemma unrest_iuvar_ouvar [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "mwb_lens y"
  shows "$x \<sharp> $y\<acute>"
  by (metis prod.collapse unrest_uexpr.rep_eq var.rep_eq var_lookup_out var_update_in)

lemma unrest_ouvar_iuvar [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "mwb_lens y"
  shows "$x\<acute> \<sharp> $y"
  by (metis prod.collapse unrest_uexpr.rep_eq var.rep_eq var_lookup_in var_update_out)

text \<open> Unrestriction distributes through the various function lifting expression constructs;
  this allows us to prove unrestrictions for the majority of the expression language. \<close>

lemma unrest_uop [unrest]: "x \<sharp> e \<Longrightarrow> x \<sharp> uop f e"
  by (transfer, simp)

lemma unrest_bop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> bop f u v"
  by (transfer, simp)

lemma unrest_trop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w \<rbrakk> \<Longrightarrow> x \<sharp> trop f u v w"
  by (transfer, simp)

lemma unrest_qtop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w; x \<sharp> y \<rbrakk> \<Longrightarrow> x \<sharp> qtop f u v w y"
  by (transfer, simp)

text \<open> For convenience, we also prove unrestriction rules for the bespoke operators on equality,
  numbers, arithmetic etc. \<close>

lemma unrest_eq [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u =\<^sub>u v"
  by (simp add: eq_upred_def, transfer, simp)

lemma unrest_zero [unrest]: "x \<sharp> 0"
  by (simp add: unrest_lit zero_uexpr_def)

lemma unrest_one [unrest]: "x \<sharp> 1"
  by (simp add: one_uexpr_def unrest_lit)

lemma unrest_numeral [unrest]: "x \<sharp> (numeral n)"
  by (simp add: numeral_uexpr_simp unrest_lit)

lemma unrest_sgn [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> sgn u"
  by (simp add: sgn_uexpr_def unrest_uop)

lemma unrest_abs [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> abs u"
  by (simp add: abs_uexpr_def unrest_uop)

lemma unrest_plus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u + v"
  by (simp add: plus_uexpr_def unrest)

lemma unrest_uminus [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> - u"
  by (simp add: uminus_uexpr_def unrest)

lemma unrest_minus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u - v"
  by (simp add: minus_uexpr_def unrest)

lemma unrest_times [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u * v"
  by (simp add: times_uexpr_def unrest)

lemma unrest_divide [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u / v"
  by (simp add: divide_uexpr_def unrest)

lemma unrest_case_prod [unrest]: "\<lbrakk> \<And> i j. x \<sharp> P i j \<rbrakk> \<Longrightarrow> x \<sharp> case_prod P v"
  by (simp add: prod.split_sel_asm)

text \<open> For a $\lambda$-term we need to show that the characteristic function expression does
  not restrict $v$ for any input value $x$. \<close>

lemma unrest_ulambda [unrest]:
  "\<lbrakk> \<And> x. v \<sharp> F x \<rbrakk> \<Longrightarrow> v \<sharp> (\<lambda> x \<bullet> F x)"
  by (transfer, simp)

end