section \<open>The Reals as Dedekind Sections of Positive Rationals\<close>

text \<open>Fundamentals of Abstract Analysis [Gleason, p. 121] provides some of the definitions.\<close>

theory Dedekind_Real
imports Complex_Main
begin

lemma add_eq_exists: "\<exists>x. a+x = (b::'a::ab_group_add)"
  by (rule_tac x="b-a" in exI, simp)

subsection \<open>Dedekind cuts or sections\<close>

definition
  cut :: "rat set \<Rightarrow> bool" where
  "cut A \<equiv> {} \<subset> A \<and> A \<subset> {0<..} \<and>
            (\<forall>y \<in> A. ((\<forall>z. 0<z \<and> z < y \<longrightarrow> z \<in> A) \<and> (\<exists>u \<in> A. y < u)))"

lemma cut_of_rat:
  assumes q: "0 < q" shows "cut {r::rat. 0 < r \<and> r < q}" (is "cut ?A")
proof -
  from q have pos: "?A \<subset> {0<..}" by force
  have nonempty: "{} \<subset> ?A"
  proof
    show "{} \<subseteq> ?A" by simp
    show "{} \<noteq> ?A"
      using field_lbound_gt_zero q by auto
  qed
  show ?thesis
    by (simp add: cut_def pos nonempty,
        blast dest: dense intro: order_less_trans)
qed

typedef preal = "Collect cut"
  by (blast intro: cut_of_rat [OF zero_less_one])

lemma Abs_preal_induct [induct type: preal]:
  "(\<And>x. cut x \<Longrightarrow> P (Abs_preal x)) \<Longrightarrow> P x"
  using Abs_preal_induct [of P x] by simp

lemma cut_Rep_preal [simp]: "cut (Rep_preal x)"
  using Rep_preal [of x] by simp

definition
  psup :: "preal set \<Rightarrow> preal" where
  "psup P = Abs_preal (\<Union>X \<in> P. Rep_preal X)"

definition
  add_set :: "[rat set,rat set] \<Rightarrow> rat set" where
  "add_set A B = {w. \<exists>x \<in> A. \<exists>y \<in> B. w = x + y}"

definition
  diff_set :: "[rat set,rat set] \<Rightarrow> rat set" where
  "diff_set A B = {w. \<exists>x. 0 < w \<and> 0 < x \<and> x \<notin> B \<and> x + w \<in> A}"

definition
  mult_set :: "[rat set,rat set] \<Rightarrow> rat set" where
  "mult_set A B = {w. \<exists>x \<in> A. \<exists>y \<in> B. w = x * y}"

definition
  inverse_set :: "rat set \<Rightarrow> rat set" where
  "inverse_set A \<equiv> {x. \<exists>y. 0 < x \<and> x < y \<and> inverse y \<notin> A}"

instantiation preal :: "{ord, plus, minus, times, inverse, one}"
begin

definition
  preal_less_def:
    "r < s \<equiv> Rep_preal r < Rep_preal s"

definition
  preal_le_def:
    "r \<le> s \<equiv> Rep_preal r \<subseteq> Rep_preal s"

definition
  preal_add_def:
    "r + s \<equiv> Abs_preal (add_set (Rep_preal r) (Rep_preal s))"

definition
  preal_diff_def:
    "r - s \<equiv> Abs_preal (diff_set (Rep_preal r) (Rep_preal s))"

definition
  preal_mult_def:
    "r * s \<equiv> Abs_preal (mult_set (Rep_preal r) (Rep_preal s))"

definition
  preal_inverse_def:
    "inverse r \<equiv> Abs_preal (inverse_set (Rep_preal r))"

definition "r div s = r * inverse (s::preal)"

definition
  preal_one_def:
    "1 \<equiv> Abs_preal {x. 0 < x \<and> x < 1}"

instance ..

end

text\<open>Reduces equality on abstractions to equality on representatives\<close>
declare Abs_preal_inject [simp]
declare Abs_preal_inverse [simp]

lemma rat_mem_preal: "0 < q \<Longrightarrow> cut {r::rat. 0 < r \<and> r < q}"
by (simp add: cut_of_rat)

lemma preal_nonempty: "cut A \<Longrightarrow> \<exists>x\<in>A. 0 < x"
  unfolding cut_def [abs_def] by blast

lemma preal_Ex_mem: "cut A \<Longrightarrow> \<exists>x. x \<in> A"
  using preal_nonempty by blast

lemma preal_exists_bound: "cut A \<Longrightarrow> \<exists>x. 0 < x \<and> x \<notin> A"
  using Dedekind_Real.cut_def by fastforce

lemma preal_exists_greater: "\<lbrakk>cut A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>u \<in> A. y < u"
  unfolding cut_def [abs_def] by blast

lemma preal_downwards_closed: "\<lbrakk>cut A; y \<in> A; 0 < z; z < y\<rbrakk> \<Longrightarrow> z \<in> A"
  unfolding cut_def [abs_def] by blast

text\<open>Relaxing the final premise\<close>
lemma preal_downwards_closed': "\<lbrakk>cut A; y \<in> A; 0 < z; z \<le> y\<rbrakk> \<Longrightarrow> z \<in> A"
  using less_eq_rat_def preal_downwards_closed by blast

text\<open>A positive fraction not in a positive real is an upper bound.
 Gleason p. 122 - Remark (1)\<close>

lemma not_in_preal_ub:
  assumes A: "cut A"
    and notx: "x \<notin> A"
    and y: "y \<in> A"
    and pos: "0 < x"
  shows "y < x"
proof (cases rule: linorder_cases)
  assume "x<y"
  with notx show ?thesis
    by (simp add:  preal_downwards_closed [OF A y] pos)
next
  assume "x=y"
  with notx and y show ?thesis by simp
next
  assume "y<x"
  thus ?thesis .
qed

text \<open>preal lemmas instantiated to \<^term>\<open>Rep_preal X\<close>\<close>

lemma mem_Rep_preal_Ex: "\<exists>x. x \<in> Rep_preal X"
thm preal_Ex_mem
by (rule preal_Ex_mem [OF cut_Rep_preal])

lemma Rep_preal_exists_bound: "\<exists>x>0. x \<notin> Rep_preal X"
by (rule preal_exists_bound [OF cut_Rep_preal])

lemmas not_in_Rep_preal_ub = not_in_preal_ub [OF cut_Rep_preal]

subsection\<open>Properties of Ordering\<close>

instance preal :: order
proof
  fix w :: preal
  show "w \<le> w" by (simp add: preal_le_def)
next
  fix i j k :: preal
  assume "i \<le> j" and "j \<le> k"
  then show "i \<le> k" by (simp add: preal_le_def)
next
  fix z w :: preal
  assume "z \<le> w" and "w \<le> z"
  then show "z = w" by (simp add: preal_le_def Rep_preal_inject)
next
  fix z w :: preal
  show "z < w \<longleftrightarrow> z \<le> w \<and> \<not> w \<le> z"
  by (auto simp: preal_le_def preal_less_def Rep_preal_inject)
qed

lemma preal_imp_pos: "\<lbrakk>cut A; r \<in> A\<rbrakk> \<Longrightarrow> 0 < r"
  by (auto simp: cut_def)

instance preal :: linorder
proof
  fix x y :: preal
  show "x \<le> y \<or> y \<le> x"
    unfolding preal_le_def
    by (meson cut_Rep_preal not_in_preal_ub preal_downwards_closed preal_imp_pos subsetI)
qed

instantiation preal :: distrib_lattice
begin

definition
  "(inf :: preal \<Rightarrow> preal \<Rightarrow> preal) = min"

definition
  "(sup :: preal \<Rightarrow> preal \<Rightarrow> preal) = max"

instance
  by intro_classes
    (auto simp: inf_preal_def sup_preal_def max_min_distrib2)

end

subsection\<open>Properties of Addition\<close>

lemma preal_add_commute: "(x::preal) + y = y + x"
  unfolding preal_add_def add_set_def
  by (metis (no_types, opaque_lifting) add.commute)

text\<open>Lemmas for proving that addition of two positive reals gives
 a positive real\<close>

lemma mem_add_set:
  assumes "cut A" "cut B"
  shows "cut (add_set A B)"
proof -
  have "{} \<subset> add_set A B"
    using assms by (force simp: add_set_def dest: preal_nonempty)
  moreover
  obtain q where "q > 0" "q \<notin> add_set A B"
  proof -
    obtain a b where "a > 0" "a \<notin> A" "b > 0" "b \<notin> B" "\<And>x. x \<in> A \<Longrightarrow> x < a" "\<And>y. y \<in> B \<Longrightarrow> y < b"
      by (meson assms preal_exists_bound not_in_preal_ub)
    with assms have "a+b \<notin> add_set A B"
      by (fastforce simp add: add_set_def)
    then show thesis
      using \<open>0 < a\<close> \<open>0 < b\<close> add_pos_pos that by blast
  qed
  then have "add_set A B \<subset> {0<..}"
    unfolding add_set_def
    using preal_imp_pos [OF \<open>cut A\<close>] preal_imp_pos [OF \<open>cut B\<close>]  by fastforce
  moreover have "z \<in> add_set A B"
    if u: "u \<in> add_set A B" and "0 < z" "z < u" for u z
    using u unfolding add_set_def
  proof (clarify)
    fix x::rat and y::rat
    assume ueq: "u = x + y" and x: "x \<in> A" and y:"y \<in> B"
    have xpos [simp]: "x > 0" and ypos [simp]: "y > 0"
      using assms preal_imp_pos x y by blast+
    have xypos [simp]: "x+y > 0" by (simp add: pos_add_strict)
    let ?f = "z/(x+y)"
    have fless: "?f < 1"
      using divide_less_eq_1_pos \<open>z < u\<close> ueq xypos by blast
    show "\<exists>x' \<in> A. \<exists>y'\<in>B. z = x' + y'"
    proof (intro bexI)
      show "z = x*?f + y*?f"
        by (simp add: distrib_right [symmetric] divide_inverse ac_simps order_less_imp_not_eq2)
    next
      show "y * ?f \<in> B"
      proof (rule preal_downwards_closed [OF \<open>cut B\<close> y])
        show "0 < y * ?f"
          by (simp add: \<open>0 < z\<close>)
      next
        show "y * ?f < y"
          by (insert mult_strict_left_mono [OF fless ypos], simp)
      qed
    next
      show "x * ?f \<in> A"
      proof (rule preal_downwards_closed [OF \<open>cut A\<close> x])
        show "0 < x * ?f"
          by (simp add: \<open>0 < z\<close>)
      next
        show "x * ?f < x"
          by (insert mult_strict_left_mono [OF fless xpos], simp)
      qed
    qed
  qed
  moreover
  have "\<And>y. y \<in> add_set A B \<Longrightarrow> \<exists>u \<in> add_set A B. y < u"
    unfolding add_set_def using preal_exists_greater assms by fastforce
  ultimately show ?thesis
    by (simp add: Dedekind_Real.cut_def)
qed

lemma preal_add_assoc: "((x::preal) + y) + z = x + (y + z)"
  apply (simp add: preal_add_def mem_add_set)
  apply (force simp: add_set_def ac_simps)
  done

instance preal :: ab_semigroup_add
proof
  fix a b c :: preal
  show "(a + b) + c = a + (b + c)" by (rule preal_add_assoc)
  show "a + b = b + a" by (rule preal_add_commute)
qed

subsection\<open>Properties of Multiplication\<close>

text\<open>Proofs essentially same as for addition\<close>

lemma preal_mult_commute: "(x::preal) * y = y * x"
  unfolding preal_mult_def mult_set_def
  by (metis (no_types, opaque_lifting) mult.commute)

text\<open>Multiplication of two positive reals gives a positive real.\<close>

lemma mem_mult_set:
  assumes "cut A" "cut B"
  shows "cut (mult_set A B)"
proof -
  have "{} \<subset> mult_set A B"
    using assms
      by (force simp: mult_set_def dest: preal_nonempty)
    moreover
    obtain q where "q > 0" "q \<notin> mult_set A B"
    proof -
      obtain x y where x [simp]: "0 < x" "x \<notin> A" and y [simp]: "0 < y" "y \<notin> B"
        using preal_exists_bound assms by blast
      show thesis
      proof
        show "0 < x*y" by simp
        show "x * y \<notin> mult_set A B"
        proof -
          {
            fix u::rat and v::rat
            assume u: "u \<in> A" and v: "v \<in> B" and xy: "x*y = u*v"
            moreover have "u<x" and "v<y" using assms x y u v by (blast dest: not_in_preal_ub)+
            moreover have "0\<le>v"
              using less_imp_le preal_imp_pos assms x y u v by blast
            moreover have "u*v < x*y"
                using assms x \<open>u < x\<close> \<open>v < y\<close> \<open>0 \<le> v\<close> by (blast intro: mult_strict_mono)
            ultimately have False by force
          }
          thus ?thesis by (auto simp: mult_set_def)
        qed
      qed
    qed
  then have "mult_set A B \<subset> {0<..}"
    unfolding mult_set_def
    using preal_imp_pos [OF \<open>cut A\<close>] preal_imp_pos [OF \<open>cut B\<close>]  by fastforce
  moreover have "z \<in> mult_set A B"
    if u: "u \<in> mult_set A B" and "0 < z" "z < u" for u z
    using u unfolding mult_set_def
  proof (clarify)
    fix x::rat and y::rat
    assume ueq: "u = x * y" and x: "x \<in> A" and y: "y \<in> B"
    have [simp]: "y > 0"
      using \<open>cut B\<close> preal_imp_pos y by blast
    show "\<exists>x' \<in> A. \<exists>y' \<in> B. z = x' * y'"
    proof
      have "z = (z/y)*y"
          by (simp add: divide_inverse mult.commute [of y] mult.assoc order_less_imp_not_eq2)
      then show "\<exists>y'\<in>B. z = (z/y) * y'"
        using y by blast
    next
      show "z/y \<in> A"
      proof (rule preal_downwards_closed [OF \<open>cut A\<close> x])
        show "0 < z/y"
          by (simp add: \<open>0 < z\<close>)
        show "z/y < x"
          using \<open>0 < y\<close> pos_divide_less_eq \<open>z < u\<close> ueq by blast
      qed
    qed
  qed
  moreover have "\<And>y. y \<in> mult_set A B \<Longrightarrow> \<exists>u \<in> mult_set A B. y < u"
    apply (simp add: mult_set_def)
    by (metis preal_exists_greater mult_strict_right_mono preal_imp_pos assms)
  ultimately show ?thesis
    by (simp add: Dedekind_Real.cut_def)
qed

lemma preal_mult_assoc: "((x::preal) * y) * z = x * (y * z)"
  apply (simp add: preal_mult_def mem_mult_set Rep_preal)
  apply (simp add: mult_set_def)
  apply (metis (no_types, opaque_lifting) ab_semigroup_mult_class.mult_ac(1))
  done

instance preal :: ab_semigroup_mult
proof
  fix a b c :: preal
  show "(a * b) * c = a * (b * c)" by (rule preal_mult_assoc)
  show "a * b = b * a" by (rule preal_mult_commute)
qed

text\<open>Positive real 1 is the multiplicative identity element\<close>

lemma preal_mult_1: "(1::preal) * z = z"
proof (induct z)
  fix A :: "rat set"
  assume A: "cut A"
  have "{w. \<exists>u. 0 < u \<and> u < 1 \<and> (\<exists>v \<in> A. w = u * v)} = A" (is "?lhs = A")
  proof
    show "?lhs \<subseteq> A"
    proof clarify
      fix x::rat and u::rat and v::rat
      assume upos: "0<u" and "u<1" and v: "v \<in> A"
      have vpos: "0<v" by (rule preal_imp_pos [OF A v])
      hence "u*v < 1*v" by (simp only: mult_strict_right_mono upos \<open>u < 1\<close> v)
      thus "u * v \<in> A"
        by (force intro: preal_downwards_closed [OF A v] mult_pos_pos  upos vpos)
    qed
  next
    show "A \<subseteq> ?lhs"
    proof clarify
      fix x::rat
      assume x: "x \<in> A"
      have xpos: "0<x" by (rule preal_imp_pos [OF A x])
      from preal_exists_greater [OF A x]
      obtain v where v: "v \<in> A" and xlessv: "x < v" ..
      have vpos: "0<v" by (rule preal_imp_pos [OF A v])
      show "\<exists>u. 0 < u \<and> u < 1 \<and> (\<exists>v\<in>A. x = u * v)"
      proof (intro exI conjI)
        show "0 < x/v"
          by (simp add: zero_less_divide_iff xpos vpos)
        show "x / v < 1"
          by (simp add: pos_divide_less_eq vpos xlessv)
        have "x = (x/v)*v"
            by (simp add: divide_inverse mult.assoc vpos order_less_imp_not_eq2)
        then show "\<exists>v'\<in>A. x = (x / v) * v'"
          using v by blast
      qed
    qed
  qed
  thus "1 * Abs_preal A = Abs_preal A"
    by (simp add: preal_one_def preal_mult_def mult_set_def rat_mem_preal A)
qed

instance preal :: comm_monoid_mult
  by intro_classes (rule preal_mult_1)

subsection\<open>Distribution of Multiplication across Addition\<close>

lemma mem_Rep_preal_add_iff:
  "(z \<in> Rep_preal(r+s)) = (\<exists>x \<in> Rep_preal r. \<exists>y \<in> Rep_preal s. z = x + y)"
  apply (simp add: preal_add_def mem_add_set Rep_preal)
  apply (simp add: add_set_def)
  done

lemma mem_Rep_preal_mult_iff:
  "(z \<in> Rep_preal(r*s)) = (\<exists>x \<in> Rep_preal r. \<exists>y \<in> Rep_preal s. z = x * y)"
  apply (simp add: preal_mult_def mem_mult_set Rep_preal)
  apply (simp add: mult_set_def)
  done

lemma distrib_subset1:
  "Rep_preal (w * (x + y)) \<subseteq> Rep_preal (w * x + w * y)"
  by (force simp: Bex_def mem_Rep_preal_add_iff mem_Rep_preal_mult_iff distrib_left)

lemma preal_add_mult_distrib_mean:
  assumes a: "a \<in> Rep_preal w"
    and b: "b \<in> Rep_preal w"
    and d: "d \<in> Rep_preal x"
    and e: "e \<in> Rep_preal y"
  shows "\<exists>c \<in> Rep_preal w. a * d + b * e = c * (d + e)"
proof
  let ?c = "(a*d + b*e)/(d+e)"
  have [simp]: "0<a" "0<b" "0<d" "0<e" "0<d+e"
    by (blast intro: preal_imp_pos [OF cut_Rep_preal] a b d e pos_add_strict)+
  have cpos: "0 < ?c"
    by (simp add: zero_less_divide_iff zero_less_mult_iff pos_add_strict)
  show "a * d + b * e = ?c * (d + e)"
    by (simp add: divide_inverse mult.assoc order_less_imp_not_eq2)
  show "?c \<in> Rep_preal w"
  proof (cases rule: linorder_le_cases)
    assume "a \<le> b"
    hence "?c \<le> b"
      by (simp add: pos_divide_le_eq distrib_left mult_right_mono
                    order_less_imp_le)
    thus ?thesis by (rule preal_downwards_closed' [OF cut_Rep_preal b cpos])
  next
    assume "b \<le> a"
    hence "?c \<le> a"
      by (simp add: pos_divide_le_eq distrib_left mult_right_mono
                    order_less_imp_le)
    thus ?thesis by (rule preal_downwards_closed' [OF cut_Rep_preal a cpos])
  qed
qed

lemma distrib_subset2:
  "Rep_preal (w * x + w * y) \<subseteq> Rep_preal (w * (x + y))"
  apply (clarsimp simp: mem_Rep_preal_add_iff mem_Rep_preal_mult_iff)
  using mem_Rep_preal_add_iff preal_add_mult_distrib_mean by blast

lemma preal_add_mult_distrib2: "(w * ((x::preal) + y)) = (w * x) + (w * y)"
  by (metis Rep_preal_inverse distrib_subset1 distrib_subset2 subset_antisym)

lemma preal_add_mult_distrib: "(((x::preal) + y) * w) = (x * w) + (y * w)"
  by (simp add: preal_mult_commute preal_add_mult_distrib2)

instance preal :: comm_semiring
  by intro_classes (rule preal_add_mult_distrib)

subsection\<open>Existence of Inverse, a Positive Real\<close>

lemma mem_inverse_set:
  assumes "cut A" shows "cut (inverse_set A)"
proof -
  have "\<exists>x y. 0 < x \<and> x < y \<and> inverse y \<notin> A"
  proof -
    from preal_exists_bound [OF \<open>cut A\<close>]
    obtain x where [simp]: "0<x" "x \<notin> A" by blast
    show ?thesis
    proof (intro exI conjI)
      show "0 < inverse (x+1)"
        by (simp add: order_less_trans [OF _ less_add_one])
      show "inverse(x+1) < inverse x"
        by (simp add: less_imp_inverse_less less_add_one)
      show "inverse (inverse x) \<notin> A"
        by (simp add: order_less_imp_not_eq2)
    qed
  qed
  then have "{} \<subset> inverse_set A"
    using inverse_set_def by fastforce
  moreover obtain q where "q > 0" "q \<notin> inverse_set A"
  proof -
    from preal_nonempty [OF \<open>cut A\<close>]
    obtain x where x: "x \<in> A" and  xpos [simp]: "0<x" ..
    show ?thesis
    proof
      show "0 < inverse x" by simp
      show "inverse x \<notin> inverse_set A"
      proof -
        { fix y::rat
          assume ygt: "inverse x < y"
          have [simp]: "0 < y" by (simp add: order_less_trans [OF _ ygt])
          have iyless: "inverse y < x"
            by (simp add: inverse_less_imp_less [of x] ygt)
          have "inverse y \<in> A"
            by (simp add: preal_downwards_closed [OF \<open>cut A\<close> x] iyless)}
        thus ?thesis by (auto simp: inverse_set_def)
      qed
    qed
  qed
  moreover have "inverse_set A \<subset> {0<..}"
    using calculation inverse_set_def by blast
  moreover have "z \<in> inverse_set A"
    if u: "u \<in> inverse_set A" and "0 < z" "z < u" for u z
    using u that less_trans unfolding inverse_set_def by auto
  moreover have "\<And>y. y \<in> inverse_set A \<Longrightarrow> \<exists>u \<in> inverse_set A. y < u"
    by (simp add: inverse_set_def) (meson dense less_trans)
  ultimately show ?thesis
    by (simp add: Dedekind_Real.cut_def)
qed

subsection\<open>Gleason's Lemma 9-3.4, page 122\<close>

lemma Gleason9_34_exists:
  assumes A: "cut A"
    and "\<forall>x\<in>A. x + u \<in> A"
    and "0 \<le> z"
  shows "\<exists>b\<in>A. b + (of_int z) * u \<in> A"
proof (cases z rule: int_cases)
  case (nonneg n)
  show ?thesis
  proof (simp add: nonneg, induct n)
    case 0
    from preal_nonempty [OF A]
    show ?case  by force
  next
    case (Suc k)
    then obtain b where b: "b \<in> A" "b + of_nat k * u \<in> A" ..
    hence "b + of_int (int k)*u + u \<in> A" by (simp add: assms)
    thus ?case by (force simp: algebra_simps b)
  qed
next
  case (neg n)
  with assms show ?thesis by simp
qed

lemma Gleason9_34_contra:
  assumes A: "cut A"
    shows "\<lbrakk>\<forall>x\<in>A. x + u \<in> A; 0 < u; 0 < y; y \<notin> A\<rbrakk> \<Longrightarrow> False"
proof (induct u, induct y)
  fix a::int and b::int
  fix c::int and d::int
  assume bpos [simp]: "0 < b"
    and dpos [simp]: "0 < d"
    and closed: "\<forall>x\<in>A. x + (Fract c d) \<in> A"
    and upos: "0 < Fract c d"
    and ypos: "0 < Fract a b"
    and notin: "Fract a b \<notin> A"
  have cpos [simp]: "0 < c"
    by (simp add: zero_less_Fract_iff [OF dpos, symmetric] upos)
  have apos [simp]: "0 < a"
    by (simp add: zero_less_Fract_iff [OF bpos, symmetric] ypos)
  let ?k = "a*d"
  have frle: "Fract a b \<le> Fract ?k 1 * (Fract c d)"
  proof -
    have "?thesis = ((a * d * b * d) \<le> c * b * (a * d * b * d))"
      by (simp add: order_less_imp_not_eq2 ac_simps)
    moreover
    have "(1 * (a * d * b * d)) \<le> c * b * (a * d * b * d)"
      by (rule mult_mono,
          simp_all add: int_one_le_iff_zero_less zero_less_mult_iff
                        order_less_imp_le)
    ultimately
    show ?thesis by simp
  qed
  have k: "0 \<le> ?k" by (simp add: order_less_imp_le zero_less_mult_iff)
  from Gleason9_34_exists [OF A closed k]
  obtain z where z: "z \<in> A"
             and mem: "z + of_int ?k * Fract c d \<in> A" ..
  have less: "z + of_int ?k * Fract c d < Fract a b"
    by (rule not_in_preal_ub [OF A notin mem ypos])
  have "0<z" by (rule preal_imp_pos [OF A z])
  with frle and less show False by (simp add: Fract_of_int_eq)
qed

lemma Gleason9_34:
  assumes "cut A" "0 < u"
  shows "\<exists>r \<in> A. r + u \<notin> A"
  using assms Gleason9_34_contra preal_exists_bound by blast

subsection\<open>Gleason's Lemma 9-3.6\<close>

lemma lemma_gleason9_36:
  assumes A: "cut A"
    and x: "1 < x"
  shows "\<exists>r \<in> A. r*x \<notin> A"
proof -
  from preal_nonempty [OF A]
  obtain y where y: "y \<in> A" and  ypos: "0<y" ..
  show ?thesis
  proof (rule classical)
    assume "~(\<exists>r\<in>A. r * x \<notin> A)"
    with y have ymem: "y * x \<in> A" by blast
    from ypos mult_strict_left_mono [OF x]
    have yless: "y < y*x" by simp
    let ?d = "y*x - y"
    from yless have dpos: "0 < ?d" and eq: "y + ?d = y*x" by auto
    from Gleason9_34 [OF A dpos]
    obtain r where r: "r\<in>A" and notin: "r + ?d \<notin> A" ..
    have rpos: "0<r" by (rule preal_imp_pos [OF A r])
    with dpos have rdpos: "0 < r + ?d" by arith
    have "~ (r + ?d \<le> y + ?d)"
    proof
      assume le: "r + ?d \<le> y + ?d"
      from ymem have yd: "y + ?d \<in> A" by (simp add: eq)
      have "r + ?d \<in> A" by (rule preal_downwards_closed' [OF A yd rdpos le])
      with notin show False by simp
    qed
    hence "y < r" by simp
    with ypos have  dless: "?d < (r * ?d)/y"
      using dpos less_divide_eq_1 by fastforce
    have "r + ?d < r*x"
    proof -
      have "r + ?d < r + (r * ?d)/y" by (simp add: dless)
      also from ypos have "\<dots> = (r/y) * (y + ?d)"
        by (simp only: algebra_simps divide_inverse, simp)
      also have "\<dots> = r*x" using ypos
        by simp
      finally show "r + ?d < r*x" .
    qed
    with r notin rdpos
    show "\<exists>r\<in>A. r * x \<notin> A" by (blast dest:  preal_downwards_closed [OF A])
  qed
qed

subsection\<open>Existence of Inverse: Part 2\<close>

lemma mem_Rep_preal_inverse_iff:
  "(z \<in> Rep_preal(inverse r)) \<longleftrightarrow> (0 < z \<and> (\<exists>y. z < y \<and> inverse y \<notin> Rep_preal r))"
  apply (simp add: preal_inverse_def mem_inverse_set Rep_preal)
  apply (simp add: inverse_set_def)
  done

lemma Rep_preal_one:
     "Rep_preal 1 = {x. 0 < x \<and> x < 1}"
by (simp add: preal_one_def rat_mem_preal)

lemma subset_inverse_mult_lemma:
  assumes xpos: "0 < x" and xless: "x < 1"
  shows "\<exists>v u y. 0 < v \<and> v < y \<and> inverse y \<notin> Rep_preal R \<and>
    u \<in> Rep_preal R \<and> x = v * u"
proof -
  from xpos and xless have "1 < inverse x" by (simp add: one_less_inverse_iff)
  from lemma_gleason9_36 [OF cut_Rep_preal this]
  obtain t where t: "t \<in> Rep_preal R"
             and notin: "t * (inverse x) \<notin> Rep_preal R" ..
  have rpos: "0<t" by (rule preal_imp_pos [OF cut_Rep_preal t])
  from preal_exists_greater [OF cut_Rep_preal t]
  obtain u where u: "u \<in> Rep_preal R" and rless: "t < u" ..
  have upos: "0<u" by (rule preal_imp_pos [OF cut_Rep_preal u])
  show ?thesis
  proof (intro exI conjI)
    show "0 < x/u" using xpos upos
      by (simp add: zero_less_divide_iff)
    show "x/u < x/t" using xpos upos rpos
      by (simp add: divide_inverse mult_less_cancel_left rless)
    show "inverse (x / t) \<notin> Rep_preal R" using notin
      by (simp add: divide_inverse mult.commute)
    show "u \<in> Rep_preal R" by (rule u)
    show "x = x / u * u" using upos
      by (simp add: divide_inverse mult.commute)
  qed
qed

lemma subset_inverse_mult:
     "Rep_preal 1 \<subseteq> Rep_preal(inverse r * r)"
  by (force simp: Rep_preal_one mem_Rep_preal_inverse_iff mem_Rep_preal_mult_iff dest: subset_inverse_mult_lemma)

lemma inverse_mult_subset: "Rep_preal(inverse r * r) \<subseteq> Rep_preal 1"
  proof -
  have "0 < u * v" if "v \<in> Rep_preal r" "0 < u" "u < t" for u v t :: rat
    using that by (simp add: zero_less_mult_iff preal_imp_pos [OF cut_Rep_preal])
  moreover have "t * q < 1"
    if "q \<in> Rep_preal r" "0 < t" "t < y" "inverse y \<notin> Rep_preal r"
    for t q y :: rat
  proof -
    have "q < inverse y"
      using not_in_Rep_preal_ub that by auto
    hence "t * q < t/y"
      using that by (simp add: divide_inverse mult_less_cancel_left)
    also have "\<dots> \<le> 1"
      using that by (simp add: pos_divide_le_eq)
    finally show ?thesis .
  qed
  ultimately show ?thesis
    by (auto simp: Rep_preal_one mem_Rep_preal_inverse_iff mem_Rep_preal_mult_iff)
qed

lemma preal_mult_inverse: "inverse r * r = (1::preal)"
  by (meson Rep_preal_inject inverse_mult_subset subset_antisym subset_inverse_mult)

lemma preal_mult_inverse_right: "r * inverse r = (1::preal)"
  using preal_mult_commute preal_mult_inverse by auto

text\<open>Theorems needing \<open>Gleason9_34\<close>\<close>

lemma Rep_preal_self_subset: "Rep_preal (r) \<subseteq> Rep_preal(r + s)"
proof
  fix x
  assume x: "x \<in> Rep_preal r"
  obtain y where y: "y \<in> Rep_preal s" and "y > 0"
    using Rep_preal preal_nonempty by blast
  have ry: "x+y \<in> Rep_preal(r + s)" using x y
    by (auto simp: mem_Rep_preal_add_iff)
  then show "x \<in> Rep_preal(r + s)"
    by (meson \<open>0 < y\<close> add_less_same_cancel1 not_in_Rep_preal_ub order.asym preal_imp_pos [OF cut_Rep_preal x])
qed

lemma Rep_preal_sum_not_subset: "~ Rep_preal (r + s) \<subseteq> Rep_preal(r)"
proof -
  obtain y where y: "y \<in> Rep_preal s" and "y > 0"
    using Rep_preal preal_nonempty by blast
  obtain x where "x \<in> Rep_preal r" and notin: "x + y \<notin> Rep_preal r"
    using Dedekind_Real.Rep_preal Gleason9_34 \<open>0 < y\<close> by blast
  then have "x + y \<in> Rep_preal (r + s)" using y
    by (auto simp: mem_Rep_preal_add_iff)
  thus ?thesis using notin by blast
qed

text\<open>at last, Gleason prop. 9-3.5(iii) page 123\<close>
proposition preal_self_less_add_left: "(r::preal) < r + s"
  by (meson Rep_preal_sum_not_subset not_less preal_le_def)

subsection\<open>Subtraction for Positive Reals\<close>

text\<open>gleason prop. 9-3.5(iv), page 123: proving \<^prop>\<open>a < b \<Longrightarrow> \<exists>d. a + d = b\<close>.
We define the claimed \<^term>\<open>D\<close> and show that it is a positive real\<close>

lemma mem_diff_set:
  assumes "r < s"
  shows "cut (diff_set (Rep_preal s) (Rep_preal r))"
proof -
  obtain p where "Rep_preal r \<subseteq> Rep_preal s" "p \<in> Rep_preal s" "p \<notin> Rep_preal r"
    using assms unfolding preal_less_def by auto
  then have "{} \<subset> diff_set (Rep_preal s) (Rep_preal r)"
    apply (simp add: diff_set_def psubset_eq)
    by (metis cut_Rep_preal add_eq_exists less_add_same_cancel1 preal_exists_greater preal_imp_pos)
  moreover
  obtain q where "q > 0" "q \<notin> Rep_preal s"
    using Rep_preal_exists_bound by blast
  then have qnot: "q \<notin> diff_set (Rep_preal s) (Rep_preal r)"
    by (auto simp: diff_set_def dest: cut_Rep_preal [THEN preal_downwards_closed])
  moreover have "diff_set (Rep_preal s) (Rep_preal r) \<subset> {0<..}" (is "?lhs < ?rhs")
    using \<open>0 < q\<close> diff_set_def qnot by blast
  moreover have "z \<in> diff_set (Rep_preal s) (Rep_preal r)"
    if u: "u \<in> diff_set (Rep_preal s) (Rep_preal r)" and "0 < z" "z < u" for u z
    using u that less_trans Rep_preal unfolding diff_set_def Dedekind_Real.cut_def by auto
  moreover have "\<exists>u \<in> diff_set (Rep_preal s) (Rep_preal r). y < u"
    if y: "y \<in> diff_set (Rep_preal s) (Rep_preal r)" for y
  proof -
    obtain a b where "0 < a" "0 < b" "a \<notin> Rep_preal r" "a + y + b \<in> Rep_preal s"
      using y
      by (simp add: diff_set_def) (metis cut_Rep_preal add_eq_exists less_add_same_cancel1 preal_exists_greater)
    then have "a + (y + b) \<in> Rep_preal s"
      by (simp add: add.assoc)
    then have "y + b \<in> diff_set (Rep_preal s) (Rep_preal r)"
      using \<open>0 < a\<close> \<open>0 < b\<close> \<open>a \<notin> Rep_preal r\<close> y
      by (auto simp: diff_set_def)
    then show ?thesis
      using \<open>0 < b\<close> less_add_same_cancel1 by blast
  qed
  ultimately show ?thesis
    by (simp add: Dedekind_Real.cut_def)
qed

lemma mem_Rep_preal_diff_iff:
  "r < s \<Longrightarrow>
       (z \<in> Rep_preal (s - r)) \<longleftrightarrow>
       (\<exists>x. 0 < x \<and> 0 < z \<and> x \<notin> Rep_preal r \<and> x + z \<in> Rep_preal s)"
  apply (simp add: preal_diff_def mem_diff_set Rep_preal)
  apply (force simp: diff_set_def)
  done

proposition less_add_left:
  fixes r::preal
  assumes "r < s"
  shows "r + (s-r) = s"
proof -
  have "a + b \<in> Rep_preal s"
    if "a \<in> Rep_preal r" "c + b \<in> Rep_preal s" "c \<notin> Rep_preal r"
    and "0 < b" "0 < c" for a b c
    by (meson cut_Rep_preal add_less_imp_less_right add_pos_pos not_in_Rep_preal_ub preal_downwards_closed preal_imp_pos that)
  then have "r + (s-r) \<le> s"
    using assms mem_Rep_preal_add_iff mem_Rep_preal_diff_iff preal_le_def by auto
  have "x \<in> Rep_preal (r + (s - r))" if "x \<in> Rep_preal s" for x
  proof (cases "x \<in> Rep_preal r")
    case True
    then show ?thesis
      using Rep_preal_self_subset by blast
  next
    case False
    have "\<exists>u v z. 0 < v \<and> 0 < z \<and> u \<in> Rep_preal r \<and> z \<notin> Rep_preal r \<and> z + v \<in> Rep_preal s \<and> x = u + v"
      if x: "x \<in> Rep_preal s"
    proof -
      have xpos: "x > 0"
        using Rep_preal preal_imp_pos that by blast
      obtain e where epos: "0 < e" and xe: "x + e \<in> Rep_preal s"
        by (metis cut_Rep_preal x add_eq_exists less_add_same_cancel1 preal_exists_greater)
      from  Gleason9_34 [OF cut_Rep_preal epos]
      obtain u where r: "u \<in> Rep_preal r" and notin: "u + e \<notin> Rep_preal r" ..
      with x False xpos have rless: "u < x" by (blast intro: not_in_Rep_preal_ub)
      from add_eq_exists [of u x]
      obtain y where eq: "x = u+y" by auto
      show ?thesis
      proof (intro exI conjI)
        show "u + e \<notin> Rep_preal r" by (rule notin)
        show "u + e + y \<in> Rep_preal s" using xe eq by (simp add: ac_simps)
        show "0 < u + e"
          using epos preal_imp_pos [OF cut_Rep_preal r] by simp
      qed (use r rless eq in auto)
    qed
    then show ?thesis
      using assms mem_Rep_preal_add_iff mem_Rep_preal_diff_iff that by blast
  qed
  then have "s \<le> r + (s-r)"
    by (auto simp: preal_le_def)
  then show ?thesis
    by (simp add: \<open>r + (s - r) \<le> s\<close> antisym)
qed

lemma preal_add_less2_mono1: "r < (s::preal) \<Longrightarrow> r + t < s + t"
  by (metis add.assoc add.commute less_add_left preal_self_less_add_left)

lemma preal_add_less2_mono2: "r < (s::preal) \<Longrightarrow> t + r < t + s"
  by (auto intro: preal_add_less2_mono1 simp add: preal_add_commute [of t])

lemma preal_add_right_less_cancel: "r + t < s + t \<Longrightarrow> r < (s::preal)"
  by (metis linorder_cases order.asym preal_add_less2_mono1)

lemma preal_add_left_less_cancel: "t + r < t + s \<Longrightarrow> r < (s::preal)"
  by (auto elim: preal_add_right_less_cancel simp add: preal_add_commute [of t])

lemma preal_add_less_cancel_left [simp]: "(t + (r::preal) < t + s) \<longleftrightarrow> (r < s)"
  by (blast intro: preal_add_less2_mono2 preal_add_left_less_cancel)

lemma preal_add_less_cancel_right [simp]: "((r::preal) + t < s + t) = (r < s)"
  using preal_add_less_cancel_left [symmetric, of r s t] by (simp add: ac_simps)

lemma preal_add_le_cancel_left [simp]: "(t + (r::preal) \<le> t + s) = (r \<le> s)"
  by (simp add: linorder_not_less [symmetric])

lemma preal_add_le_cancel_right [simp]: "((r::preal) + t \<le> s + t) = (r \<le> s)"
  using preal_add_le_cancel_left [symmetric, of r s t] by (simp add: ac_simps)

lemma preal_add_right_cancel: "(r::preal) + t = s + t \<Longrightarrow> r = s"
  by (metis less_irrefl linorder_cases preal_add_less_cancel_right)

lemma preal_add_left_cancel: "c + a = c + b \<Longrightarrow> a = (b::preal)"
  by (auto intro: preal_add_right_cancel simp add: preal_add_commute)

instance preal :: linordered_ab_semigroup_add
proof
  fix a b c :: preal
  show "a \<le> b \<Longrightarrow> c + a \<le> c + b" by (simp only: preal_add_le_cancel_left)
qed

subsection\<open>Completeness of type \<^typ>\<open>preal\<close>\<close>

text\<open>Prove that supremum is a cut\<close>

text\<open>Part 1 of Dedekind sections definition\<close>

lemma preal_sup:
  assumes le: "\<And>X. X \<in> P \<Longrightarrow> X \<le> Y" and "P \<noteq> {}"
  shows "cut (\<Union>X \<in> P. Rep_preal(X))"
proof -
  have "{} \<subset> (\<Union>X \<in> P. Rep_preal(X))"
    using \<open>P \<noteq> {}\<close> mem_Rep_preal_Ex by fastforce
  moreover
  obtain q where "q > 0" and "q \<notin> (\<Union>X \<in> P. Rep_preal(X))"
    using Rep_preal_exists_bound [of Y] le by (auto simp: preal_le_def)
  then have "(\<Union>X \<in> P. Rep_preal(X)) \<subset> {0<..}"
    using cut_Rep_preal preal_imp_pos by force
  moreover
  have "\<And>u z. \<lbrakk>u \<in> (\<Union>X \<in> P. Rep_preal(X)); 0 < z; z < u\<rbrakk> \<Longrightarrow> z \<in> (\<Union>X \<in> P. Rep_preal(X))"
    by (auto elim: cut_Rep_preal [THEN preal_downwards_closed])
  moreover
  have "\<And>y. y \<in> (\<Union>X \<in> P. Rep_preal(X)) \<Longrightarrow> \<exists>u \<in> (\<Union>X \<in> P. Rep_preal(X)). y < u"
    by (blast dest: cut_Rep_preal [THEN preal_exists_greater])
  ultimately show ?thesis
    by (simp add: Dedekind_Real.cut_def)
qed

lemma preal_psup_le:
     "\<lbrakk>\<And>X. X \<in> P \<Longrightarrow> X \<le> Y;  x \<in> P\<rbrakk> \<Longrightarrow> x \<le> psup P"
  using preal_sup [of P Y] unfolding preal_le_def psup_def by fastforce

lemma psup_le_ub: "\<lbrakk>\<And>X. X \<in> P \<Longrightarrow> X \<le> Y; P \<noteq> {}\<rbrakk> \<Longrightarrow> psup P \<le> Y"
  using preal_sup [of P Y] by (simp add: SUP_least preal_le_def psup_def)

text\<open>Supremum property\<close>
proposition preal_complete:
  assumes le: "\<And>X. X \<in> P \<Longrightarrow> X \<le> Y" and "P \<noteq> {}"
  shows "(\<exists>X \<in> P. Z < X) \<longleftrightarrow> (Z < psup P)" (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    using preal_sup [OF assms] preal_less_def psup_def by auto
next
  assume ?rhs
  then show ?lhs
    by (meson \<open>P \<noteq> {}\<close> not_less psup_le_ub)
qed

subsection \<open>Defining the Reals from the Positive Reals\<close>

text \<open>Here we do quotients the old-fashioned way\<close>

definition
  realrel   ::  "((preal * preal) * (preal * preal)) set" where
  "realrel = {p. \<exists>x1 y1 x2 y2. p = ((x1,y1),(x2,y2)) \<and> x1+y2 = x2+y1}"

definition "Real = UNIV//realrel"

typedef real = Real
  morphisms Rep_Real Abs_Real
  unfolding Real_def by (auto simp: quotient_def)

text \<open>This doesn't involve the overloaded "real" function: users don't see it\<close>
definition
  real_of_preal :: "preal \<Rightarrow> real" where
  "real_of_preal m = Abs_Real (realrel `` {(m + 1, 1)})"

instantiation real :: "{zero, one, plus, minus, uminus, times, inverse, ord, abs, sgn}"
begin

definition
  real_zero_def: "0 = Abs_Real(realrel``{(1, 1)})"

definition
  real_one_def: "1 = Abs_Real(realrel``{(1 + 1, 1)})"

definition
  real_add_def: "z + w =
       the_elem (\<Union>(x,y) \<in> Rep_Real z. \<Union>(u,v) \<in> Rep_Real w.
                 { Abs_Real(realrel``{(x+u, y+v)}) })"

definition
  real_minus_def: "- r =  the_elem (\<Union>(x,y) \<in> Rep_Real r. { Abs_Real(realrel``{(y,x)}) })"

definition
  real_diff_def: "r - (s::real) = r + - s"

definition
  real_mult_def:
    "z * w =
       the_elem (\<Union>(x,y) \<in> Rep_Real z. \<Union>(u,v) \<in> Rep_Real w.
                 { Abs_Real(realrel``{(x*u + y*v, x*v + y*u)}) })"

definition
  real_inverse_def: "inverse (r::real) \<equiv> (THE s. (r = 0 \<and> s = 0) \<or> s * r = 1)"

definition
  real_divide_def: "r div (s::real) \<equiv> r * inverse s"

definition
  real_le_def: "z \<le> (w::real) \<equiv>
    (\<exists>x y u v. x+v \<le> u+y \<and> (x,y) \<in> Rep_Real z \<and> (u,v) \<in> Rep_Real w)"

definition
  real_less_def: "x < (y::real) \<equiv> x \<le> y \<and> x \<noteq> y"

definition
  real_abs_def: "\<bar>r::real\<bar> = (if r < 0 then - r else r)"

definition
  real_sgn_def: "sgn (x::real) = (if x=0 then 0 else if 0<x then 1 else - 1)"

instance ..

end

subsection \<open>Equivalence relation over positive reals\<close>

lemma realrel_iff [simp]: "(((x1,y1),(x2,y2)) \<in> realrel) = (x1 + y2 = x2 + y1)"
  by (simp add: realrel_def)

lemma preal_trans_lemma:
  assumes "x + y1 = x1 + y" and "x + y2 = x2 + y"
  shows "x1 + y2 = x2 + (y1::preal)"
  by (metis add.left_commute assms preal_add_left_cancel)

lemma equiv_realrel: "equiv UNIV realrel"
  by (auto simp: equiv_def refl_on_def sym_def trans_def realrel_def intro: dest: preal_trans_lemma)

text\<open>Reduces equality of equivalence classes to the \<^term>\<open>realrel\<close> relation:
  \<^term>\<open>(realrel `` {x} = realrel `` {y}) = ((x,y) \<in> realrel)\<close>\<close>
lemmas equiv_realrel_iff [simp] =
       eq_equiv_class_iff [OF equiv_realrel UNIV_I UNIV_I]

lemma realrel_in_real [simp]: "realrel``{(x,y)} \<in> Real"
  by (simp add: Real_def realrel_def quotient_def, blast)

declare Abs_Real_inject [simp] Abs_Real_inverse [simp]

text\<open>Case analysis on the representation of a real number as an equivalence
      class of pairs of positive reals.\<close>
lemma eq_Abs_Real [case_names Abs_Real, cases type: real]:
     "(\<And>x y. z = Abs_Real(realrel``{(x,y)}) \<Longrightarrow> P) \<Longrightarrow> P"
  by (metis Rep_Real_inverse prod.exhaust  Rep_Real [of z, unfolded Real_def, THEN quotientE])

subsection \<open>Addition and Subtraction\<close>

lemma real_add:
     "Abs_Real (realrel``{(x,y)}) + Abs_Real (realrel``{(u,v)}) =
      Abs_Real (realrel``{(x+u, y+v)})"
proof -
  have "(\<lambda>z w. (\<lambda>(x,y). (\<lambda>(u,v). {Abs_Real (realrel `` {(x+u, y+v)})}) w) z)
        respects2 realrel"
  by (clarsimp simp: congruent2_def) (metis add.left_commute preal_add_assoc)
  thus ?thesis
    by (simp add: real_add_def UN_UN_split_split_eq UN_equiv_class2 [OF equiv_realrel equiv_realrel])
qed

lemma real_minus: "- Abs_Real(realrel``{(x,y)}) = Abs_Real(realrel `` {(y,x)})"
proof -
  have "(\<lambda>(x,y). {Abs_Real (realrel``{(y,x)})}) respects realrel"
    by (auto simp: congruent_def add.commute)
  thus ?thesis
    by (simp add: real_minus_def UN_equiv_class [OF equiv_realrel])
qed

instance real :: ab_group_add
proof
  fix x y z :: real
  show "(x + y) + z = x + (y + z)"
    by (cases x, cases y, cases z, simp add: real_add add.assoc)
  show "x + y = y + x"
    by (cases x, cases y, simp add: real_add add.commute)
  show "0 + x = x"
    by (cases x, simp add: real_add real_zero_def ac_simps)
  show "- x + x = 0"
    by (cases x, simp add: real_minus real_add real_zero_def add.commute)
  show "x - y = x + - y"
    by (simp add: real_diff_def)
qed

subsection \<open>Multiplication\<close>

lemma real_mult_congruent2_lemma:
     "!!(x1::preal). \<lbrakk>x1 + y2 = x2 + y1\<rbrakk> \<Longrightarrow>
          x * x1 + y * y1 + (x * y2 + y * x2) =
          x * x2 + y * y2 + (x * y1 + y * x1)"
  by (metis (no_types, opaque_lifting) add.left_commute preal_add_commute preal_add_mult_distrib2)

lemma real_mult_congruent2:
  "(\<lambda>p1 p2.
        (\<lambda>(x1,y1). (\<lambda>(x2,y2).
          { Abs_Real (realrel``{(x1*x2 + y1*y2, x1*y2+y1*x2)}) }) p2) p1)
     respects2 realrel"
  apply (rule congruent2_commuteI [OF equiv_realrel])
  by (auto simp: mult.commute add.commute combine_common_factor preal_add_assoc preal_add_commute)

lemma real_mult:
  "Abs_Real((realrel``{(x1,y1)})) * Abs_Real((realrel``{(x2,y2)})) =
   Abs_Real(realrel `` {(x1*x2+y1*y2,x1*y2+y1*x2)})"
  by (simp add: real_mult_def UN_UN_split_split_eq
      UN_equiv_class2 [OF equiv_realrel equiv_realrel real_mult_congruent2])

lemma real_mult_commute: "(z::real) * w = w * z"
by (cases z, cases w, simp add: real_mult ac_simps)

lemma real_mult_assoc: "((z1::real) * z2) * z3 = z1 * (z2 * z3)"
  by (cases z1, cases z2, cases z3) (simp add: real_mult algebra_simps)

lemma real_mult_1: "(1::real) * z = z"
  by (cases z) (simp add: real_mult real_one_def algebra_simps)

lemma real_add_mult_distrib: "((z1::real) + z2) * w = (z1 * w) + (z2 * w)"
  by (cases z1, cases z2, cases w) (simp add: real_add real_mult algebra_simps)

text\<open>one and zero are distinct\<close>
lemma real_zero_not_eq_one: "0 \<noteq> (1::real)"
proof -
  have "(1::preal) < 1 + 1"
    by (simp add: preal_self_less_add_left)
  then show ?thesis
    by (simp add: real_zero_def real_one_def neq_iff)
qed

instance real :: comm_ring_1
proof
  fix x y z :: real
  show "(x * y) * z = x * (y * z)" by (rule real_mult_assoc)
  show "x * y = y * x" by (rule real_mult_commute)
  show "1 * x = x" by (rule real_mult_1)
  show "(x + y) * z = x * z + y * z" by (rule real_add_mult_distrib)
  show "0 \<noteq> (1::real)" by (rule real_zero_not_eq_one)
qed

subsection \<open>Inverse and Division\<close>

lemma real_zero_iff: "Abs_Real (realrel `` {(x, x)}) = 0"
  by (simp add: real_zero_def add.commute)

lemma real_mult_inverse_left_ex:
  assumes "x \<noteq> 0" obtains y::real where "y*x = 1"
proof (cases x)
  case (Abs_Real u v)
  show ?thesis
  proof (cases u v rule: linorder_cases)
    case less
    then have "v * inverse (v - u) = 1 + u * inverse (v - u)"
      using less_add_left [of u v]
      by (metis preal_add_commute preal_add_mult_distrib preal_mult_inverse_right)
    then have "Abs_Real (realrel``{(1, inverse (v-u) + 1)}) * x - 1 = 0"
      by (simp add: Abs_Real real_mult preal_mult_inverse_right real_one_def) (simp add: algebra_simps)
    with that show thesis by auto
  next
    case equal
    then show ?thesis
      using Abs_Real assms real_zero_iff by blast
  next
    case greater
    then have "u * inverse (u - v) = 1 + v * inverse (u - v)"
      using less_add_left [of v u] by (metis add.commute distrib_right preal_mult_inverse_right)
    then have "Abs_Real (realrel``{(inverse (u-v) + 1, 1)}) * x - 1 = 0"
      by (simp add: Abs_Real real_mult preal_mult_inverse_right real_one_def) (simp add: algebra_simps)
    with that show thesis by auto
  qed
qed

lemma real_mult_inverse_left:
  fixes x :: real
  assumes "x \<noteq> 0" shows "inverse x * x = 1"
proof -
  obtain y where "y*x = 1"
    using assms real_mult_inverse_left_ex by blast
  then have "(THE s. s * x = 1) * x = 1"
  proof (rule theI)
    show "y' = y" if "y' * x = 1" for y'
      by (metis \<open>y * x = 1\<close> mult.left_commute mult.right_neutral that)
  qed
  then show ?thesis
    using assms real_inverse_def by auto
qed

subsection\<open>The Real Numbers form a Field\<close>

instance real :: field
proof
  fix x y z :: real
  show "x \<noteq> 0 \<Longrightarrow> inverse x * x = 1" by (rule real_mult_inverse_left)
  show "x / y = x * inverse y" by (simp add: real_divide_def)
  show "inverse 0 = (0::real)" by (simp add: real_inverse_def)
qed

subsection\<open>The \<open>\<le>\<close> Ordering\<close>

lemma real_le_refl: "w \<le> (w::real)"
  by (cases w, force simp: real_le_def)

text\<open>The arithmetic decision procedure is not set up for type preal.
  This lemma is currently unused, but it could simplify the proofs of the
  following two lemmas.\<close>
lemma preal_eq_le_imp_le:
  assumes eq: "a+b = c+d" and le: "c \<le> a"
  shows "b \<le> (d::preal)"
proof -
  from le have "c+d \<le> a+d" by simp
  hence "a+b \<le> a+d" by (simp add: eq)
  thus "b \<le> d" by simp
qed

lemma real_le_lemma:
  assumes l: "u1 + v2 \<le> u2 + v1"
    and "x1 + v1 = u1 + y1"
    and "x2 + v2 = u2 + y2"
  shows "x1 + y2 \<le> x2 + (y1::preal)"
proof -
  have "(x1+v1) + (u2+y2) = (u1+y1) + (x2+v2)" by (simp add: assms)
  hence "(x1+y2) + (u2+v1) = (x2+y1) + (u1+v2)" by (simp add: ac_simps)
  also have "\<dots> \<le> (x2+y1) + (u2+v1)" by (simp add: assms)
  finally show ?thesis by simp
qed

lemma real_le:
  "Abs_Real(realrel``{(x1,y1)}) \<le> Abs_Real(realrel``{(x2,y2)})  \<longleftrightarrow>  x1 + y2 \<le> x2 + y1"
  unfolding real_le_def by (auto intro: real_le_lemma)

lemma real_le_antisym: "\<lbrakk>z \<le> w; w \<le> z\<rbrakk> \<Longrightarrow> z = (w::real)"
  by (cases z, cases w, simp add: real_le)

lemma real_trans_lemma:
  assumes "x + v \<le> u + y"
    and "u + v' \<le> u' + v"
    and "x2 + v2 = u2 + y2"
  shows "x + v' \<le> u' + (y::preal)"
proof -
  have "(x+v') + (u+v) = (x+v) + (u+v')" by (simp add: ac_simps)
  also have "\<dots> \<le> (u+y) + (u+v')" by (simp add: assms)
  also have "\<dots> \<le> (u+y) + (u'+v)" by (simp add: assms)
  also have "\<dots> = (u'+y) + (u+v)"  by (simp add: ac_simps)
  finally show ?thesis by simp
qed

lemma real_le_trans: "\<lbrakk>i \<le> j; j \<le> k\<rbrakk> \<Longrightarrow> i \<le> (k::real)"
  by (cases i, cases j, cases k) (auto simp: real_le intro: real_trans_lemma)

instance real :: order
proof
  show "u < v \<longleftrightarrow> u \<le> v \<and> \<not> v \<le> u" for u v::real
    by (auto simp: real_less_def intro: real_le_antisym)
qed (auto intro: real_le_refl real_le_trans real_le_antisym)

instance real :: linorder
proof
  show "x \<le> y \<or> y \<le> x" for x y :: real
    by (meson eq_refl le_cases real_le_def)
qed

instantiation real :: distrib_lattice
begin

definition
  "(inf :: real \<Rightarrow> real \<Rightarrow> real) = min"

definition
  "(sup :: real \<Rightarrow> real \<Rightarrow> real) = max"

instance
  by standard (auto simp: inf_real_def sup_real_def max_min_distrib2)

end

subsection\<open>The Reals Form an Ordered Field\<close>

lemma real_le_eq_diff: "(x \<le> y) \<longleftrightarrow> (x-y \<le> (0::real))"
  by (cases x, cases y) (simp add: real_le real_zero_def real_diff_def real_add real_minus preal_add_commute)

lemma real_add_left_mono:
  assumes le: "x \<le> y" shows "z + x \<le> z + (y::real)"
proof -
  have "z + x - (z + y) = (z + -z) + (x - y)"
    by (simp add: algebra_simps)
  with le show ?thesis
    by (simp add: real_le_eq_diff[of x] real_le_eq_diff[of "z+x"])
qed

lemma real_sum_gt_zero_less: "(0 < s + (-w::real)) \<Longrightarrow> (w < s)"
  by (simp add: linorder_not_le [symmetric] real_le_eq_diff [of s])

lemma real_less_sum_gt_zero: "(w < s) \<Longrightarrow> (0 < s + (-w::real))"
  by (simp add: linorder_not_le [symmetric] real_le_eq_diff [of s])

lemma real_mult_order:
  fixes x y::real
  assumes "0 < x" "0 < y"
  shows "0 < x * y"
  proof (cases x, cases y)
  show "0 < x * y"
    if x: "x = Abs_Real (Dedekind_Real.realrel `` {(x1, x2)})"
      and y: "y = Abs_Real (Dedekind_Real.realrel `` {(y1, y2)})"
    for x1 x2 y1 y2
  proof -
    have "x2 < x1" "y2 < y1"
      using assms not_le real_zero_def real_le x y
      by (metis preal_add_le_cancel_left real_zero_iff)+
    then obtain xd yd where "x1 = x2 + xd" "y1 = y2 + yd"
      using less_add_left by metis
    then have "\<not> (x * y \<le> 0)"
      apply (simp add: x y real_mult real_zero_def real_le)
      apply (simp add: not_le algebra_simps preal_self_less_add_left)
      done
    then show ?thesis
      by auto
  qed
qed

lemma real_mult_less_mono2: "\<lbrakk>(0::real) < z; x < y\<rbrakk> \<Longrightarrow> z * x < z * y"
  by (metis add_uminus_conv_diff real_less_sum_gt_zero real_mult_order real_sum_gt_zero_less right_diff_distrib')

instance real :: linordered_field
proof
  fix x y z :: real
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y" by (rule real_add_left_mono)
  show "\<bar>x\<bar> = (if x < 0 then -x else x)" by (simp only: real_abs_def)
  show "sgn x = (if x=0 then 0 else if 0<x then 1 else - 1)"
    by (simp only: real_sgn_def)
  show "z * x < z * y" if "x < y" "0 < z"
    by (simp add: real_mult_less_mono2 that)
qed

subsection \<open>Completeness of the reals\<close>

text\<open>The function \<^term>\<open>real_of_preal\<close> requires many proofs, but it seems
to be essential for proving completeness of the reals from that of the
positive reals.\<close>

lemma real_of_preal_add:
  "real_of_preal ((x::preal) + y) = real_of_preal x + real_of_preal y"
  by (simp add: real_of_preal_def real_add algebra_simps)

lemma real_of_preal_mult:
  "real_of_preal ((x::preal) * y) = real_of_preal x * real_of_preal y"
  by (simp add: real_of_preal_def real_mult algebra_simps)

text\<open>Gleason prop 9-4.4 p 127\<close>
lemma real_of_preal_trichotomy:
  "\<exists>m. (x::real) = real_of_preal m \<or> x = 0 \<or> x = -(real_of_preal m)"
proof (cases x)
  case (Abs_Real u v)
  show ?thesis
  proof (cases u v rule: linorder_cases)
    case less
    then show ?thesis
      using less_add_left
      apply (simp add: Abs_Real real_of_preal_def real_minus real_zero_def)
      by (metis preal_add_assoc preal_add_commute)
  next
    case equal
    then show ?thesis
      using Abs_Real real_zero_iff by blast
  next
    case greater
    then show ?thesis
      using less_add_left
      apply (simp add: Abs_Real real_of_preal_def real_minus real_zero_def)
      by (metis preal_add_assoc preal_add_commute)
  qed
qed

lemma real_of_preal_less_iff [simp]:
  "(real_of_preal m1 < real_of_preal m2) = (m1 < m2)"
  by (metis not_less preal_add_less_cancel_right real_le real_of_preal_def)

lemma real_of_preal_le_iff [simp]:
  "(real_of_preal m1 \<le> real_of_preal m2) = (m1 \<le> m2)"
  by (simp add: linorder_not_less [symmetric])

lemma real_of_preal_zero_less [simp]: "0 < real_of_preal m"
  by (metis less_add_same_cancel2 preal_self_less_add_left real_of_preal_add real_of_preal_less_iff)

subsection\<open>Theorems About the Ordering\<close>

lemma real_gt_zero_preal_Ex: "(0 < x) \<longleftrightarrow> (\<exists>y. x = real_of_preal y)"
  using order.asym real_of_preal_trichotomy by fastforce

subsection \<open>Completeness of Positive Reals\<close>

text \<open>
  Supremum property for the set of positive reals

  Let \<open>P\<close> be a non-empty set of positive reals, with an upper
  bound \<open>y\<close>.  Then \<open>P\<close> has a least upper bound
  (written \<open>S\<close>).

  FIXME: Can the premise be weakened to \<open>\<forall>x \<in> P. x\<le> y\<close>?
\<close>

lemma posreal_complete:
  assumes positive_P: "\<forall>x \<in> P. (0::real) < x"
    and not_empty_P: "\<exists>x. x \<in> P"
    and upper_bound_Ex: "\<exists>y. \<forall>x \<in> P. x<y"
  shows "\<exists>s. \<forall>y. (\<exists>x \<in> P. y < x) = (y < s)"
proof (rule exI, rule allI)
  fix y
  let ?pP = "{w. real_of_preal w \<in> P}"

  show "(\<exists>x\<in>P. y < x) = (y < real_of_preal (psup ?pP))"
  proof (cases "0 < y")
    assume neg_y: "\<not> 0 < y"
    show ?thesis
    proof
      assume "\<exists>x\<in>P. y < x"
      thus "y < real_of_preal (psup ?pP)"
        by (metis dual_order.strict_trans neg_y not_less_iff_gr_or_eq real_of_preal_zero_less)
    next
      assume "y < real_of_preal (psup ?pP)"
      obtain "x" where x_in_P: "x \<in> P" using not_empty_P ..
      thus "\<exists>x \<in> P. y < x" using x_in_P
        using neg_y not_less_iff_gr_or_eq positive_P by fastforce
    qed
  next
    assume pos_y: "0 < y"
    then obtain py where y_is_py: "y = real_of_preal py"
      by (auto simp: real_gt_zero_preal_Ex)

    obtain a where "a \<in> P" using not_empty_P ..
    with positive_P have a_pos: "0 < a" ..
    then obtain pa where "a = real_of_preal pa"
      by (auto simp: real_gt_zero_preal_Ex)
    hence "pa \<in> ?pP" using \<open>a \<in> P\<close> by auto
    hence pP_not_empty: "?pP \<noteq> {}" by auto

    obtain sup where sup: "\<forall>x \<in> P. x < sup"
      using upper_bound_Ex ..
    from this and \<open>a \<in> P\<close> have "a < sup" ..
    hence "0 < sup" using a_pos by arith
    then obtain possup where "sup = real_of_preal possup"
      by (auto simp: real_gt_zero_preal_Ex)
    hence "\<forall>X \<in> ?pP. X \<le> possup"
      using sup by auto
    with pP_not_empty have psup: "\<And>Z. (\<exists>X \<in> ?pP. Z < X) = (Z < psup ?pP)"
      by (meson preal_complete)
    show ?thesis
    proof
      assume "\<exists>x \<in> P. y < x"
      then obtain x where x_in_P: "x \<in> P" and y_less_x: "y < x" ..
      hence "0 < x" using pos_y by arith
      then obtain px where x_is_px: "x = real_of_preal px"
        by (auto simp: real_gt_zero_preal_Ex)

      have py_less_X: "\<exists>X \<in> ?pP. py < X"
      proof
        show "py < px" using y_is_py and x_is_px and y_less_x
          by simp
        show "px \<in> ?pP" using x_in_P and x_is_px by simp
      qed

      have "(\<exists>X \<in> ?pP. py < X) \<Longrightarrow> (py < psup ?pP)"
        using psup by simp
      hence "py < psup ?pP" using py_less_X by simp
      thus "y < real_of_preal (psup {w. real_of_preal w \<in> P})"
        using y_is_py and pos_y by simp
    next
      assume y_less_psup: "y < real_of_preal (psup ?pP)"

      hence "py < psup ?pP" using y_is_py
        by simp
      then obtain "X" where py_less_X: "py < X" and X_in_pP: "X \<in> ?pP"
        using psup by auto
      then obtain x where x_is_X: "x = real_of_preal X"
        by (simp add: real_gt_zero_preal_Ex)
      hence "y < x" using py_less_X and y_is_py
        by simp
      moreover have "x \<in> P"
        using x_is_X and X_in_pP by simp
      ultimately show "\<exists> x \<in> P. y < x" ..
    qed
  qed
qed

subsection \<open>Completeness\<close>

lemma reals_complete:
  fixes S :: "real set"
  assumes notempty_S: "\<exists>X. X \<in> S"
    and exists_Ub: "bdd_above S"
  shows "\<exists>x. (\<forall>s\<in>S. s \<le> x) \<and> (\<forall>y. (\<forall>s\<in>S. s \<le> y) \<longrightarrow> x \<le> y)"
proof -
  obtain X where X_in_S: "X \<in> S" using notempty_S ..
  obtain Y where Y_isUb: "\<forall>s\<in>S. s \<le> Y"
    using exists_Ub by (auto simp: bdd_above_def)
  let ?SHIFT = "{z. \<exists>x \<in>S. z = x + (-X) + 1} \<inter> {x. 0 < x}"

  {
    fix x
    assume S_le_x: "\<forall>s\<in>S. s \<le> x"
    {
      fix s
      assume "s \<in> {z. \<exists>x\<in>S. z = x + - X + 1}"
      hence "\<exists> x \<in> S. s = x + -X + 1" ..
      then obtain x1 where x1: "x1 \<in> S" "s = x1 + (-X) + 1" ..
      then have "x1 \<le> x" using S_le_x by simp
      with x1 have "s \<le> x + - X + 1" by arith
    }
    then have "\<forall>s\<in>?SHIFT. s \<le> x + (-X) + 1"
      by auto
  } note S_Ub_is_SHIFT_Ub = this

  have *: "\<forall>s\<in>?SHIFT. s \<le> Y + (-X) + 1" using Y_isUb by (rule S_Ub_is_SHIFT_Ub)
  have "\<forall>s\<in>?SHIFT. s < Y + (-X) + 2"
  proof
    fix s assume "s\<in>?SHIFT"
    with * have "s \<le> Y + (-X) + 1" by simp
    also have "\<dots> < Y + (-X) + 2" by simp
    finally show "s < Y + (-X) + 2" .
  qed
  moreover have "\<forall>y \<in> ?SHIFT. 0 < y" by auto
  moreover have shifted_not_empty: "\<exists>u. u \<in> ?SHIFT"
    using X_in_S and Y_isUb by auto
  ultimately obtain t where t_is_Lub: "\<forall>y. (\<exists>x\<in>?SHIFT. y < x) = (y < t)"
    using posreal_complete [of ?SHIFT] unfolding bdd_above_def by blast

  show ?thesis
  proof
    show "(\<forall>s\<in>S. s \<le> (t + X + (-1))) \<and> (\<forall>y. (\<forall>s\<in>S. s \<le> y) \<longrightarrow> (t + X + (-1)) \<le> y)"
    proof safe
      fix x
      assume "\<forall>s\<in>S. s \<le> x"
      hence "\<forall>s\<in>?SHIFT. s \<le> x + (-X) + 1"
        using S_Ub_is_SHIFT_Ub by simp
      then have "\<not> x + (-X) + 1 < t"
        by (subst t_is_Lub[rule_format, symmetric]) (simp add: not_less)
      thus "t + X + -1 \<le> x" by arith
    next
      fix y
      assume y_in_S: "y \<in> S"
      obtain "u" where u_in_shift: "u \<in> ?SHIFT" using shifted_not_empty ..
      hence "\<exists> x \<in> S. u = x + - X + 1" by simp
      then obtain "x" where x_and_u: "u = x + - X + 1" ..
      have u_le_t: "u \<le> t"
      proof (rule dense_le)
        fix x assume "x < u" then have "x < t"
          using u_in_shift t_is_Lub by auto
        then show "x \<le> t"  by simp
      qed

      show "y \<le> t + X + -1"
      proof cases
        assume "y \<le> x"
        moreover have "x = u + X + - 1" using x_and_u by arith
        moreover have "u + X + - 1  \<le> t + X + -1" using u_le_t by arith
        ultimately show "y  \<le> t + X + -1" by arith
      next
        assume "~(y \<le> x)"
        hence x_less_y: "x < y" by arith

        have "x + (-X) + 1 \<in> ?SHIFT" using x_and_u and u_in_shift by simp
        hence "0 < x + (-X) + 1" by simp
        hence "0 < y + (-X) + 1" using x_less_y by arith
        hence *: "y + (-X) + 1 \<in> ?SHIFT" using y_in_S by simp
        have "y + (-X) + 1 \<le> t"
        proof (rule dense_le)
          fix x assume "x < y + (-X) + 1" then have "x < t"
            using * t_is_Lub by auto
          then show "x \<le> t"  by simp
        qed
        thus ?thesis by simp
      qed
    qed
  qed
qed

subsection \<open>The Archimedean Property of the Reals\<close>

theorem reals_Archimedean:
  fixes x :: real
  assumes x_pos: "0 < x"
  shows "\<exists>n. inverse (of_nat (Suc n)) < x"
proof (rule ccontr)
  assume contr: "\<not> ?thesis"
  have "\<forall>n. x * of_nat (Suc n) \<le> 1"
  proof
    fix n
    from contr have "x \<le> inverse (of_nat (Suc n))"
      by (simp add: linorder_not_less)
    hence "x \<le> (1 / (of_nat (Suc n)))"
      by (simp add: inverse_eq_divide)
    moreover have "(0::real) \<le> of_nat (Suc n)"
      by (rule of_nat_0_le_iff)
    ultimately have "x * of_nat (Suc n) \<le> (1 / of_nat (Suc n)) * of_nat (Suc n)"
      by (rule mult_right_mono)
    thus "x * of_nat (Suc n) \<le> 1" by (simp del: of_nat_Suc)
  qed
  hence 2: "bdd_above {z. \<exists>n. z = x * (of_nat (Suc n))}"
    by (auto intro!: bdd_aboveI[of _ 1])
  have 1: "\<exists>X. X \<in> {z. \<exists>n. z = x* (of_nat (Suc n))}" by auto
  obtain t where
    upper: "\<And>z. z \<in> {z. \<exists>n. z = x * of_nat (Suc n)} \<Longrightarrow> z \<le> t" and
    least: "\<And>y. (\<And>a. a \<in> {z. \<exists>n. z = x * of_nat (Suc n)} \<Longrightarrow> a \<le> y) \<Longrightarrow> t \<le> y"
    using reals_complete[OF 1 2] by auto

  have "t \<le> t + - x"
  proof (rule least)
    fix a assume a: "a \<in> {z. \<exists>n. z = x * (of_nat (Suc n))}"
    have "\<forall>n::nat. x * of_nat n \<le> t + - x"
    proof
      fix n
      have "x * of_nat (Suc n) \<le> t"
        by (simp add: upper)
      hence  "x * (of_nat n) + x \<le> t"
        by (simp add: distrib_left)
      thus  "x * (of_nat n) \<le> t + - x" by arith
    qed    hence "\<forall>m. x * of_nat (Suc m) \<le> t + - x" by (simp del: of_nat_Suc)
    with a show "a \<le> t + - x"
      by auto
  qed
  thus False using x_pos by arith
qed

text \<open>
  There must be other proofs, e.g. \<open>Suc\<close> of the largest
  integer in the cut representing \<open>x\<close>.
\<close>

lemma reals_Archimedean2: "\<exists>n. (x::real) < of_nat (n::nat)"
proof cases
  assume "x \<le> 0"
  hence "x < of_nat (1::nat)" by simp
  thus ?thesis ..
next
  assume "\<not> x \<le> 0"
  hence x_greater_zero: "0 < x" by simp
  hence "0 < inverse x" by simp
  then obtain n where "inverse (of_nat (Suc n)) < inverse x"
    using reals_Archimedean by blast
  hence "inverse (of_nat (Suc n)) * x < inverse x * x"
    using x_greater_zero by (rule mult_strict_right_mono)
  hence "inverse (of_nat (Suc n)) * x < 1"
    using x_greater_zero by simp
  hence "of_nat (Suc n) * (inverse (of_nat (Suc n)) * x) < of_nat (Suc n) * 1"
    by (rule mult_strict_left_mono) (simp del: of_nat_Suc)
  hence "x < of_nat (Suc n)"
    by (simp add: algebra_simps del: of_nat_Suc)
  thus "\<exists>(n::nat). x < of_nat n" ..
qed

instance real :: archimedean_field
proof
  fix r :: real
  obtain n :: nat where "r < of_nat n"
    using reals_Archimedean2 ..
  then have "r \<le> of_int (int n)"
    by simp
  then show "\<exists>z. r \<le> of_int z" ..
qed

end


theory Chapter2
  imports Complex_Main
begin

(* Exercise 2.1 *)
value "1 + (2 :: nat)"
value "1 + (2 :: int)"
value "1 - (2 :: nat)"
value "1 - (2 :: int)"

(* Exercise 2.3 *)
fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count x Nil = 0"
| "count x (Cons y ys) = (if x = y then 1 + count x ys else count x ys)"

theorem count_le_len [simp]: "count x xs \<le> length xs"
  apply (induction xs)
   apply (auto)
  done

(* Exercise 2.4 *)
fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc Nil x = (Cons x Nil)"
| "snoc (Cons y ys) x = (Cons y (snoc ys x))"

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse Nil = Nil"
| "reverse (Cons x xs) = (snoc (reverse xs) x)"

lemma reverse_cons [simp]: "reverse (snoc xs a) = Cons a (reverse xs)"
  apply (induction xs)
   apply (auto)
  done

theorem reverse_reverse [simp]: "reverse (reverse xs) = xs"
  apply (induction xs)
   apply (auto)
  done

(* Exercise 2.5 *)
fun sum_upto :: "nat \<Rightarrow> nat" where
  "sum_upto n = (if n = 0 then 0 else n + (sum_upto (n - 1)))"

theorem sum_upto_n [simp]: "sum_upto n = n * (n + 1) div 2"
  apply (induction n)
   apply (auto)
  done

(*********************************)

datatype 'a tree = Tip | Node "'a tree" 'a " 'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror Tip = Tip"
| "mirror (Node l a r) = Node (mirror r) a (mirror l)"

lemma "mirror (mirror t) = t"
  apply (induction t)
   apply (auto)
  done

datatype 'a option = None | Some 'a

fun lookup :: "('a * 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" where
  "lookup [] x = None"
| "lookup ((a, b) # ps) x = (if a = x then Some b else lookup ps x)"

(* Exercise 2.6 *)
fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = []"
| "contents (Node l a r) = (contents l @ a # contents r)"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
  "sum_tree Tip = 0"
| "sum_tree (Node l a r) = (sum_tree l + a + sum_tree r)"

fun sum_list :: "nat list \<Rightarrow> nat" where
  "sum_list [] = 0"
| "sum_list (x # xs) = x + sum_list xs"

lemma sum_list_app [simp]: "sum_list (xs @ ys) = sum_list xs + sum_list ys"
  apply (induction xs)
   apply (auto)
  done

theorem sum_tree_correct : "sum_tree t = sum_list (contents t)"
  apply (induction t)
   apply (auto)
  done

(* Exercise 2.7 *)
datatype 'a tree2 = Tip 'a | Node "'a tree2" 'a "'a tree2"

fun mirror2 :: "'a tree2 \<Rightarrow> 'a tree2" where
  "mirror2 (Tip x) = (Tip x)"
| "mirror2 (Node l a r) = Node (mirror2 r) a (mirror2 l)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order (Tip x) = [x]"
| "pre_order (Node l x r) = x # (pre_order l) @ (pre_order r)"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
  "post_order (Tip x) = [x]"
| "post_order (Node l x r) = (post_order l) @ (post_order r) @ [x]"

theorem tree_traversal : "pre_order (mirror2 t) = rev (post_order t)"
  apply (induction t)
   apply (auto)
  done

(* Exercise 2.8 *)
fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse a [] = []"
| "intersperse a (x # xs) = (x # a # intersperse a xs)"

theorem intersperse_map : "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs)
   apply (auto)
  done

(****************************************)

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev [] ys = ys"
| "itrev (x # xs) ys = itrev xs (x # ys)"

lemma "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary:ys)
   apply (auto)
  done

(* Exercise 2.10 *)
datatype tree0 = Leaf | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Leaf = 1"
| "nodes (Node t1 t2) = 1 + nodes t1 + nodes t2"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t"
| "explode (Suc n) t = explode n (Node t t)"

theorem explode_node : "nodes (explode n t) = 2^n * (nodes t + 1) - 1"
  apply (induction n arbitrary:t)
   apply (auto)
  apply (simp add:algebra_simps)
  done

(* Exercise 2.11 *)
datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var x = x"
| "eval (Const n) _ = n"
| "eval (Add e1 e2) x = (eval e1 x) + (eval e2 x)"
| "eval (Mult e1 e2) x = (eval e1 x) * (eval e2 x)"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] x = 0"
| "evalp (c#cs) x = c + x * (evalp cs x)"

fun list_add :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "list_add [] ys = ys"
| "list_add xs [] = xs"
| "list_add (x#xs) (y#ys) = (x + y) # (list_add xs ys)"

fun list_mult :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "list_mult [] _ = []"
| "list_mult _ [] = []"
| "list_mult (x#xs) ys = list_add (map (\<lambda>n. n * x) ys) (list_mult xs (0 # ys))"

fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [0, 1]"
| "coeffs (Const n) = [n]"
| "coeffs (Add e1 e2) = list_add (coeffs e1) (coeffs e2)"
| "coeffs (Mult e1 e2) = list_mult (coeffs e1) (coeffs e2)"

(* Why doesn't the following work with
   apply (induction l1)
   apply (auto)
   apply (induction l2)
   ...  *)
lemma evalp_add_distr [simp]: "evalp (list_add l1 l2) x = evalp l1 x + evalp l2 x"
  apply (induction rule:list_add.induct)
   apply (auto simp add:algebra_simps)
  done

lemma evalp_map : "evalp (map (\<lambda>n. n * a) l) x = a * evalp l x"
  apply (induction l)
   apply (auto simp add:algebra_simps)
  done

lemma evalp_mult_distr : "evalp (list_mult l1 l2) x = evalp l1 x * evalp l2 x"
  apply (induction rule:list_mult.induct)
  apply (auto)
  apply (simp add:evalp_map)
  apply (simp add:algebra_simps)
  done

theorem coeffs_preserve : "evalp (coeffs e) x = eval e x"
  apply (induction e)
   apply (auto)
   apply (simp add:evalp_add_distr)
   apply (simp add:evalp_mult_distr)
  done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_22
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun max :: "Nat => Nat => Nat" where
  "max (Z) y = y"
| "max (S z) (Z) = S z"
| "max (S z) (S x2) = S (max z x2)"

theorem property0 :
  "((max (max a b) c) = (max a (max b c)))"
(*This nested induction (a \<rightarrow> b \<rightarrow> c) is easy to choose:
  "induct a" because the patter matching of "max" is exclusive on the first argument,
             and "a" is always the first argument of "max" in this case
             and for other first arguments of "max" are non-variable terms.
  We have two innermost "max"es. For one "max" the first argument is "b".
  Starting with induction on "b" also works, but the following proof becomes longer
  because it necessitates induction on the first argument of other "max", which is "a" even for
  the base case.
 *)
  apply(induct a arbitrary: b c)
   apply fastforce
  (* We still have two "max"es: "max (S a) b" and "max b c".
     But the first argument of "max (S a) b" starts with a constructor, on which we cannot induct.
   *)
  apply(induct_tac b)
   apply fastforce
  apply(induct_tac c)(*This can be case_tac*)
  (*Despite the warning "Induction variable occurs also among premises: "c"", it works.*)
  apply fastforce+
  done

theorem property':(*sub-optimal proof with one extra induction step.*)
  "((max (max a b) c) = (max a (max b c)))"
  apply(induct b arbitrary: a c)
  apply(induct_tac a) (*extra induction step.*)
   apply fastforce+
  apply(induct_tac a)
   apply fastforce
  apply(induct_tac c)(*Despite the warning "Induction variable occurs also among premises: "c"", it works.*)
  apply fastforce+
  done

theorem property'':(*bad.*)
  "((max (max a b) c) = (max a (max b c)))"
  apply(induct rule:max.induct)
  nitpick
  oops

end


(*  Title:      HOL/ex/HarmonicSeries.thy
    Author:     Benjamin Porter, 2006
*)

section {* Divergence of the Harmonic Series *}

theory HarmonicSeries
imports Complex_Main
begin

subsection {* Abstract *}

text {* The following document presents a proof of the Divergence of
Harmonic Series theorem formalised in the Isabelle/Isar theorem
proving system.

{\em Theorem:} The series $\sum_{n=1}^{\infty} \frac{1}{n}$ does not
converge to any number.

{\em Informal Proof:}
  The informal proof is based on the following auxillary lemmas:
  \begin{itemize}
  \item{aux: $\sum_{n=2^m-1}^{2^m} \frac{1}{n} \geq \frac{1}{2}$}
  \item{aux2: $\sum_{n=1}^{2^M} \frac{1}{n} = 1 + \sum_{m=1}^{M} \sum_{n=2^m-1}^{2^m} \frac{1}{n}$}
  \end{itemize}

  From {\em aux} and {\em aux2} we can deduce that $\sum_{n=1}^{2^M}
  \frac{1}{n} \geq 1 + \frac{M}{2}$ for all $M$.
  Now for contradiction, assume that $\sum_{n=1}^{\infty} \frac{1}{n}
  = s$ for some $s$. Because $\forall n. \frac{1}{n} > 0$ all the
  partial sums in the series must be less than $s$. However with our
  deduction above we can choose $N > 2*s - 2$ and thus
  $\sum_{n=1}^{2^N} \frac{1}{n} > s$. This leads to a contradiction
  and hence $\sum_{n=1}^{\infty} \frac{1}{n}$ is not summable.
  QED.
*}

subsection {* Formal Proof *}

lemma two_pow_sub:
  "0 < m \<Longrightarrow> (2::nat)^m - 2^(m - 1) = 2^(m - 1)"
  by (induct m) auto

text {* We first prove the following auxillary lemma. This lemma
simply states that the finite sums: $\frac{1}{2}$, $\frac{1}{3} +
\frac{1}{4}$, $\frac{1}{5} + \frac{1}{6} + \frac{1}{7} + \frac{1}{8}$
etc. are all greater than or equal to $\frac{1}{2}$. We do this by
observing that each term in the sum is greater than or equal to the
last term, e.g. $\frac{1}{3} > \frac{1}{4}$ and thus $\frac{1}{3} +
\frac{1}{4} > \frac{1}{4} + \frac{1}{4} = \frac{1}{2}$. *}

lemma harmonic_aux:
  "\<forall>m>0. (\<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n) \<ge> 1/2"
  (is "\<forall>m>0. (\<Sum>n\<in>(?S m). 1/real n) \<ge> 1/2")
proof
  fix m::nat
  obtain tm where tmdef: "tm = (2::nat)^m" by simp
  {
    assume mgt0: "0 < m"
    have "\<And>x. x\<in>(?S m) \<Longrightarrow> 1/(real x) \<ge> 1/(real tm)"
    proof -
      fix x::nat
      assume xs: "x\<in>(?S m)"
      have xgt0: "x>0"
      proof -
        from xs have
          "x \<ge> 2^(m - 1) + 1" by auto
        moreover from mgt0 have
          "2^(m - 1) + 1 \<ge> (1::nat)" by auto
        ultimately have
          "x \<ge> 1" by (rule xtrans)
        thus ?thesis by simp
      qed
      moreover from xs have "x \<le> 2^m" by auto
      ultimately have
        "inverse (real x) \<ge> inverse (real ((2::nat)^m))"
        by (simp del: real_of_nat_power)
      moreover
      from xgt0 have "real x \<noteq> 0" by simp
      then have
        "inverse (real x) = 1 / (real x)"
        by (rule nonzero_inverse_eq_divide)
      moreover from mgt0 have "real tm \<noteq> 0" by (simp add: tmdef)
      then have
        "inverse (real tm) = 1 / (real tm)"
        by (rule nonzero_inverse_eq_divide)
      ultimately show
        "1/(real x) \<ge> 1/(real tm)" by (auto simp add: tmdef)
    qed
    then have
      "(\<Sum>n\<in>(?S m). 1 / real n) \<ge> (\<Sum>n\<in>(?S m). 1/(real tm))"
      by (rule setsum_mono)
    moreover have
      "(\<Sum>n\<in>(?S m). 1/(real tm)) = 1/2"
    proof -
      have
        "(\<Sum>n\<in>(?S m). 1/(real tm)) =
         (1/(real tm))*(\<Sum>n\<in>(?S m). 1)"
        by simp
      also have
        "\<dots> = ((1/(real tm)) * real (card (?S m)))"
        by (simp add: real_of_card real_of_nat_def)
      also have
        "\<dots> = ((1/(real tm)) * real (tm - (2^(m - 1))))"
        by (simp add: tmdef)
      also from mgt0 have
        "\<dots> = ((1/(real tm)) * real ((2::nat)^(m - 1)))"
        by (auto simp: tmdef dest: two_pow_sub)
      also have
        "\<dots> = (real (2::nat))^(m - 1) / (real (2::nat))^m"
        by (simp add: tmdef)
      also from mgt0 have
        "\<dots> = (real (2::nat))^(m - 1) / (real (2::nat))^((m - 1) + 1)"
        by auto
      also have "\<dots> = 1/2" by simp
      finally show ?thesis .
    qed
    ultimately have
      "(\<Sum>n\<in>(?S m). 1 / real n) \<ge> 1/2"
      by - (erule subst)
  }
  thus "0 < m \<longrightarrow> 1 / 2 \<le> (\<Sum>n\<in>(?S m). 1 / real n)" by simp
qed

text {* We then show that the sum of a finite number of terms from the
harmonic series can be regrouped in increasing powers of 2. For
example: $1 + \frac{1}{2} + \frac{1}{3} + \frac{1}{4} + \frac{1}{5} +
\frac{1}{6} + \frac{1}{7} + \frac{1}{8} = 1 + (\frac{1}{2}) +
(\frac{1}{3} + \frac{1}{4}) + (\frac{1}{5} + \frac{1}{6} + \frac{1}{7}
+ \frac{1}{8})$. *}

lemma harmonic_aux2 [rule_format]:
  "0<M \<Longrightarrow> (\<Sum>n\<in>{1..(2::nat)^M}. 1/real n) =
   (1 + (\<Sum>m\<in>{1..M}. \<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n))"
  (is "0<M \<Longrightarrow> ?LHS M = ?RHS M")
proof (induct M)
  case 0 show ?case by simp
next
  case (Suc M)
  have ant: "0 < Suc M" by fact
  {
    have suc: "?LHS (Suc M) = ?RHS (Suc M)"
    proof cases -- "show that LHS = c and RHS = c, and thus LHS = RHS"
      assume mz: "M=0"
      {
        then have
          "?LHS (Suc M) = ?LHS 1" by simp
        also have
          "\<dots> = (\<Sum>n\<in>{(1::nat)..2}. 1/real n)" by simp
        also have
          "\<dots> = ((\<Sum>n\<in>{Suc 1..2}. 1/real n) + 1/(real (1::nat)))"
          by (subst setsum_head)
             (auto simp: atLeastSucAtMost_greaterThanAtMost)
        also have
          "\<dots> = ((\<Sum>n\<in>{2..2::nat}. 1/real n) + 1/(real (1::nat)))"
          by (simp add: eval_nat_numeral)
        also have
          "\<dots> =  1/(real (2::nat)) + 1/(real (1::nat))" by simp
        finally have
          "?LHS (Suc M) = 1/2 + 1" by simp
      }
      moreover
      {
        from mz have
          "?RHS (Suc M) = ?RHS 1" by simp
        also have
          "\<dots> = (\<Sum>n\<in>{((2::nat)^0)+1..2^1}. 1/real n) + 1"
          by simp
        also have
          "\<dots> = (\<Sum>n\<in>{2::nat..2}. 1/real n) + 1"
          by (auto simp: atLeastAtMost_singleton')
        also have
          "\<dots> = 1/2 + 1"
          by simp
        finally have
          "?RHS (Suc M) = 1/2 + 1" by simp
      }
      ultimately show "?LHS (Suc M) = ?RHS (Suc M)" by simp
    next
      assume mnz: "M\<noteq>0"
      then have mgtz: "M>0" by simp
      with Suc have suc:
        "(?LHS M) = (?RHS M)" by blast
      have
        "(?LHS (Suc M)) =
         ((?LHS M) + (\<Sum>n\<in>{(2::nat)^M+1..2^(Suc M)}. 1 / real n))"
      proof -
        have
          "{1..(2::nat)^(Suc M)} =
           {1..(2::nat)^M}\<union>{(2::nat)^M+1..(2::nat)^(Suc M)}"
          by auto
        moreover have
          "{1..(2::nat)^M}\<inter>{(2::nat)^M+1..(2::nat)^(Suc M)} = {}"
          by auto
        moreover have
          "finite {1..(2::nat)^M}" and "finite {(2::nat)^M+1..(2::nat)^(Suc M)}"
          by auto
        ultimately show ?thesis
          by (auto intro: setsum.union_disjoint)
      qed
      moreover
      {
        have
          "(?RHS (Suc M)) =
           (1 + (\<Sum>m\<in>{1..M}.  \<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n) +
           (\<Sum>n\<in>{(2::nat)^(Suc M - 1)+1..2^(Suc M)}. 1/real n))" by simp
        also have
          "\<dots> = (?RHS M) + (\<Sum>n\<in>{(2::nat)^M+1..2^(Suc M)}. 1/real n)"
          by simp
        also from suc have
          "\<dots> = (?LHS M) +  (\<Sum>n\<in>{(2::nat)^M+1..2^(Suc M)}. 1/real n)"
          by simp
        finally have
          "(?RHS (Suc M)) = \<dots>" by simp
      }
      ultimately show "?LHS (Suc M) = ?RHS (Suc M)" by simp
    qed
  }
  thus ?case by simp
qed

text {* Using @{thm [source] harmonic_aux} and @{thm [source] harmonic_aux2} we now show
that each group sum is greater than or equal to $\frac{1}{2}$ and thus
the finite sum is bounded below by a value proportional to the number
of elements we choose. *}

lemma harmonic_aux3 [rule_format]:
  shows "\<forall>(M::nat). (\<Sum>n\<in>{1..(2::nat)^M}. 1 / real n) \<ge> 1 + (real M)/2"
  (is "\<forall>M. ?P M \<ge> _")
proof (rule allI, cases)
  fix M::nat
  assume "M=0"
  then show "?P M \<ge> 1 + (real M)/2" by simp
next
  fix M::nat
  assume "M\<noteq>0"
  then have "M > 0" by simp
  then have
    "(?P M) =
     (1 + (\<Sum>m\<in>{1..M}. \<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n))"
    by (rule harmonic_aux2)
  also have
    "\<dots> \<ge> (1 + (\<Sum>m\<in>{1..M}. 1/2))"
  proof -
    let ?f = "(\<lambda>x. 1/2)"
    let ?g = "(\<lambda>x. (\<Sum>n\<in>{(2::nat)^(x - 1)+1..2^x}. 1/real n))"
    from harmonic_aux have "\<And>x. x\<in>{1..M} \<Longrightarrow> ?f x \<le> ?g x" by simp
    then have "(\<Sum>m\<in>{1..M}. ?g m) \<ge> (\<Sum>m\<in>{1..M}. ?f m)" by (rule setsum_mono)
    thus ?thesis by simp
  qed
  finally have "(?P M) \<ge> (1 + (\<Sum>m\<in>{1..M}. 1/2))" .
  moreover
  {
    have
      "(\<Sum>m\<in>{1..M}. (1::real)/2) = 1/2 * (\<Sum>m\<in>{1..M}. 1)"
      by auto
    also have
      "\<dots> = 1/2*(real (card {1..M}))"
      by (simp only: real_of_card[symmetric])
    also have
      "\<dots> = 1/2*(real M)" by simp
    also have
      "\<dots> = (real M)/2" by simp
    finally have "(\<Sum>m\<in>{1..M}. (1::real)/2) = (real M)/2" .
  }
  ultimately show "(?P M) \<ge> (1 + (real M)/2)" by simp
qed

text {* The final theorem shows that as we take more and more elements
(see @{thm [source] harmonic_aux3}) we get an ever increasing sum. By assuming
the sum converges, the lemma @{thm [source] setsum_less_suminf} ( @{thm
setsum_less_suminf} ) states that each sum is bounded above by the
series' limit. This contradicts our first statement and thus we prove
that the harmonic series is divergent. *}

theorem DivergenceOfHarmonicSeries:
  shows "\<not>summable (\<lambda>n. 1/real (Suc n))"
  (is "\<not>summable ?f")
proof -- "by contradiction"
  let ?s = "suminf ?f" -- "let ?s equal the sum of the harmonic series"
  assume sf: "summable ?f"
  then obtain n::nat where ndef: "n = nat \<lceil>2 * ?s\<rceil>" by simp
  then have ngt: "1 + real n/2 > ?s"
  proof -
    have "\<forall>n. 0 \<le> ?f n" by simp
    with sf have "?s \<ge> 0"
      by (rule suminf_nonneg)
    then have cgt0: "\<lceil>2*?s\<rceil> \<ge> 0" by simp

    from ndef have "n = nat \<lceil>(2*?s)\<rceil>" .
    then have "real n = real (nat \<lceil>2*?s\<rceil>)" by simp
    with cgt0 have "real n = real \<lceil>2*?s\<rceil>"
      by (auto dest: real_nat_eq_real)
    then have "real n \<ge> 2*(?s)" by simp
    then have "real n/2 \<ge> (?s)" by simp
    then show "1 + real n/2 > (?s)" by simp
  qed

  obtain j where jdef: "j = (2::nat)^n" by simp
  have "\<forall>m\<ge>j. 0 < ?f m" by simp
  with sf have "(\<Sum>i<j. ?f i) < ?s" by (rule setsum_less_suminf)
  then have "(\<Sum>i\<in>{Suc 0..<Suc j}. 1/(real i)) < ?s"
    unfolding setsum_shift_bounds_Suc_ivl by (simp add: atLeast0LessThan)
  with jdef have
    "(\<Sum>i\<in>{1..< Suc ((2::nat)^n)}. 1 / (real i)) < ?s" by simp
  then have
    "(\<Sum>i\<in>{1..(2::nat)^n}. 1 / (real i)) < ?s"
    by (simp only: atLeastLessThanSuc_atLeastAtMost)
  moreover from harmonic_aux3 have
    "(\<Sum>i\<in>{1..(2::nat)^n}. 1 / (real i)) \<ge> 1 + real n/2" by simp
  moreover from ngt have "1 + real n/2 > ?s" by simp
  ultimately show False by simp
qed

end


theory  Search_Tree2
imports Search_Tree
begin

lemmas search_tree2_induct = search_tree.induct[where 'a = "'a * 'b", split_format(complete)]

lemmas search_tree2_cases = search_tree.exhaust[where 'a = "'a * 'b", split_format(complete)]

fun inorder :: "('a*'b)search_tree \<Rightarrow> 'a list" where
"inorder Leaf = []" |
"inorder (Node l (a,_) r) = inorder l @ a # inorder r"

fun set_search_tree :: "('a*'b) search_tree \<Rightarrow> 'a set" where
"set_search_tree Leaf = {}" |
"set_search_tree (Node l (a,_) r) = {a} \<union> set_search_tree l \<union> set_search_tree r"

fun bst :: "('a::linorder*'b) search_tree \<Rightarrow> bool" where
"bst Leaf = True" |
"bst (Node l (a, _) r) = ((\<forall>x \<in> set_search_tree l. x < a) \<and> (\<forall>x \<in> set_search_tree r. a < x) \<and> bst l \<and> bst r)"

lemma finite_set_search_tree[simp]: "finite(set_search_tree t)"
by(induction t) auto

lemma eq_set_search_tree_empty[simp]: "set_search_tree t = {} \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma set_inorder[simp]: "set (inorder t) = set_search_tree t"
by (induction t) auto

lemma length_inorder[simp]: "length (inorder t) = size t"
by (induction t) auto

end


theory approach_Feb
  imports Main
begin

definition la :: "nat list" where "la = [1::nat, 2]"
definition lb :: "nat list" where "lb = [3::nat, 4]"
definition lc :: "nat list" where "lc = [5::nat, 6, 7]"
definition ld :: "nat list" where "ld = [8::nat, 9]"

(*BIP Simon*)
value "\<exists>i \<in> set la.\<exists>j \<in> set lb. \<exists>k \<in> set lc. ((P i \<longrightarrow> ((Q j \<and> R k)))
\<and> (\<forall>i1 \<in> set la - {i}.\<not>P i1)
\<and> (\<forall>j1 \<in> set lb - {j}.\<not>Q j1)
\<and> (\<forall>k1 \<in> set lc - {k}.\<not>R k1)
)"

(*BIP Trinh*)
value "(\<forall>i \<in> set la. ((P i \<longrightarrow> (\<exists>j \<in> set lb. \<exists>k \<in> set lc.(Q j \<and> R k)))
\<and> (\<forall>i \<in> set la.(P i \<longrightarrow> (\<forall>i1 \<in> set la - {i}.\<not>P i1)))
\<and> (\<forall>j \<in> set lb.(Q j \<longrightarrow> (\<forall>j1 \<in> set lb - {j}.\<not>Q j1)))
\<and> (\<forall>k \<in> set lc.(R k \<longrightarrow> (\<forall>k1 \<in> set lc - {k}.\<not>R k1)))
))"

(*JavaBIP Simon*)
value "(\<forall>i \<in> set la. ((P i \<longrightarrow> (\<exists>j \<in> set lb. \<exists>k \<in> set lc.(Q j \<and> R k) \<and> (\<forall>j1 \<in> set lb - {j}.\<not>Q j1)
\<and> (\<forall>k1 \<in> set lc - {k}.\<not>R k1)))
\<and> (\<forall>i \<in> set la.(P i \<longrightarrow> (\<forall>i1 \<in> set la - {i}.\<not>P i1)))
\<and> (\<forall>j \<in> set lb.(Q j \<longrightarrow> (\<forall>j1 \<in> set lb - {j}.\<not>Q j1)))
\<and> (\<forall>k \<in> set lc.(R k \<longrightarrow> (\<forall>k1 \<in> set lc - {k}.\<not>R k1)))
))"

lemma btrinh_jvbsimon:"(\<exists>i \<in> set la.\<exists>j \<in> set lb. \<exists>k \<in> set lc. ((P i \<longrightarrow> ((Q j \<and> R k)))
\<and> (\<forall>i1 \<in> set la - {i}.\<not>P i1)
\<and> (\<forall>j1 \<in> set lb - {j}.\<not>Q j1)
\<and> (\<forall>k1 \<in> set lc - {k}.\<not>R k1)
)) \<longleftrightarrow>
(\<forall>i \<in> set la. ((P i \<longrightarrow> (\<exists>j \<in> set lb. \<exists>k \<in> set lc.(Q j \<and> R k)))
\<and> (\<forall>i \<in> set la.(P i \<longrightarrow> (\<forall>i1 \<in> set la - {i}.\<not>P i1)))
\<and> (\<forall>j \<in> set lb.(Q j \<longrightarrow> (\<forall>j1 \<in> set lb - {j}.\<not>Q j1)))
\<and> (\<forall>k \<in> set lc.(R k \<longrightarrow> (\<forall>k1 \<in> set lc - {k}.\<not>R k1)))
))"
  unfolding la_def lb_def lc_def ld_def
  sledgehammer

end


(*  Title:      HOL/Induct/Tree.thy
    Author:     Stefan Berghofer,  TU Muenchen
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section {* Infinitely branching trees *}

theory Tree
imports Main
begin

datatype 'a tree =
    Atom 'a
  | Branch "nat => 'a tree"

primrec map_tree :: "('a => 'b) => 'a tree => 'b tree"
where
  "map_tree f (Atom a) = Atom (f a)"
| "map_tree f (Branch ts) = Branch (\<lambda>x. map_tree f (ts x))"

lemma tree_map_compose: "map_tree g (map_tree f t) = map_tree (g \<circ> f) t"
  by (induct t) simp_all

primrec exists_tree :: "('a => bool) => 'a tree => bool"
where
  "exists_tree P (Atom a) = P a"
| "exists_tree P (Branch ts) = (\<exists>x. exists_tree P (ts x))"

lemma exists_map:
  "(!!x. P x ==> Q (f x)) ==>
    exists_tree P ts ==> exists_tree Q (map_tree f ts)"
  by (induct ts) auto

subsection{*The Brouwer ordinals, as in ZF/Induct/Brouwer.thy.*}

datatype brouwer = Zero | Succ "brouwer" | Lim "nat => brouwer"

text{*Addition of ordinals*}
primrec add :: "[brouwer,brouwer] => brouwer"
where
  "add i Zero = i"
| "add i (Succ j) = Succ (add i j)"
| "add i (Lim f) = Lim (%n. add i (f n))"

text{*Multiplication of ordinals*}
primrec mult :: "[brouwer,brouwer] => brouwer"
where
  "mult i Zero = Zero"
| "mult i (Succ j) = add (mult i j) i"
| "mult i (Lim f) = Lim (%n. mult i (f n))"

lemma add_mult_distrib: "mult i (add j k) = add (mult i j) (mult i k)"
  by (induct k) (auto simp add: add_assoc)

lemma mult_assoc: "mult (mult i j) k = mult i (mult j k)"
  by (induct k) (auto simp add: add_mult_distrib)

text{*We could probably instantiate some axiomatic type classes and use
the standard infix operators.*}

subsection{*A WF Ordering for The Brouwer ordinals (Michael Compton)*}

text{*To use the function package we need an ordering on the Brouwer
  ordinals.  Start with a predecessor relation and form its transitive
  closure. *}

definition brouwer_pred :: "(brouwer * brouwer) set"
  where "brouwer_pred = (\<Union>i. {(m,n). n = Succ m \<or> (EX f. n = Lim f & m = f i)})"

definition brouwer_order :: "(brouwer * brouwer) set"
  where "brouwer_order = brouwer_pred^+"

lemma wf_brouwer_pred: "wf brouwer_pred"
  by(unfold wf_def brouwer_pred_def, clarify, induct_tac x, blast+)

lemma wf_brouwer_order[simp]: "wf brouwer_order"
  by(unfold brouwer_order_def, rule wf_trancl[OF wf_brouwer_pred])

lemma [simp]: "(f n, Lim f) : brouwer_order"
  by(auto simp add: brouwer_order_def brouwer_pred_def)

text{*Example of a general function*}

function add2 :: "brouwer \<Rightarrow> brouwer \<Rightarrow> brouwer"
where
  "add2 i Zero = i"
| "add2 i (Succ j) = Succ (add2 i j)"
| "add2 i (Lim f) = Lim (\<lambda>n. add2 i (f n))"
by pat_completeness auto
termination by (relation "inv_image brouwer_order snd") auto

lemma add2_assoc: "add2 (add2 i j) k = add2 i (add2 j k)"
  by (induct k) auto

end


(*  Title:      HOL/Analysis/Continuum_Not_Denumerable.thy
    Author:     Benjamin Porter, Monash University, NICTA, 2005
    Author:     Johannes Hölzl, TU München
*)

section \<open>Non-Denumerability of the Continuum\<close>

theory Continuum_Not_Denumerable
imports
  Complex_Main
  "HOL-Library.Countable_Set"
begin

subsection\<^marker>\<open>tag unimportant\<close> \<open>Abstract\<close>

text \<open>
  The following document presents a proof that the Continuum is uncountable.
  It is formalised in the Isabelle/Isar theorem proving system.

  \<^bold>\<open>Theorem:\<close> The Continuum \<open>\<real>\<close> is not denumerable. In other words, there does
  not exist a function \<open>f: \<nat> \<Rightarrow> \<real>\<close> such that \<open>f\<close> is surjective.

  \<^bold>\<open>Outline:\<close> An elegant informal proof of this result uses Cantor's
  Diagonalisation argument. The proof presented here is not this one.

  First we formalise some properties of closed intervals, then we prove the
  Nested Interval Property. This property relies on the completeness of the
  Real numbers and is the foundation for our argument. Informally it states
  that an intersection of countable closed intervals (where each successive
  interval is a subset of the last) is non-empty. We then assume a surjective
  function \<open>f: \<nat> \<Rightarrow> \<real>\<close> exists and find a real \<open>x\<close> such that \<open>x\<close> is not in the
  range of \<open>f\<close> by generating a sequence of closed intervals then using the
  Nested Interval Property.
\<close>
text\<^marker>\<open>tag important\<close> \<open>%whitespace\<close>
theorem real_non_denum: "\<nexists>f :: nat \<Rightarrow> real. surj f"
proof
  assume "\<exists>f::nat \<Rightarrow> real. surj f"
  then obtain f :: "nat \<Rightarrow> real" where "surj f" ..

  txt \<open>First we construct a sequence of nested intervals, ignoring \<^term>\<open>range f\<close>.\<close>

  have "a < b \<Longrightarrow> \<exists>ka kb. ka < kb \<and> {ka..kb} \<subseteq> {a..b} \<and> c \<notin> {ka..kb}" for a b c :: real
    by (auto simp add: not_le cong: conj_cong)
      (metis dense le_less_linear less_linear less_trans order_refl)
  then obtain i j where ij:
    "a < b \<Longrightarrow> i a b c < j a b c"
      "a < b \<Longrightarrow> {i a b c .. j a b c} \<subseteq> {a .. b}"
      "a < b \<Longrightarrow> c \<notin> {i a b c .. j a b c}"
    for a b c :: real
    by metis

  define ivl where "ivl =
    rec_nat (f 0 + 1, f 0 + 2) (\<lambda>n x. (i (fst x) (snd x) (f n), j (fst x) (snd x) (f n)))"
  define I where "I n = {fst (ivl n) .. snd (ivl n)}" for n

  have ivl [simp]:
    "ivl 0 = (f 0 + 1, f 0 + 2)"
    "\<And>n. ivl (Suc n) = (i (fst (ivl n)) (snd (ivl n)) (f n), j (fst (ivl n)) (snd (ivl n)) (f n))"
    unfolding ivl_def by simp_all

  txt \<open>This is a decreasing sequence of non-empty intervals.\<close>

  have less: "fst (ivl n) < snd (ivl n)" for n
    by (induct n) (auto intro!: ij)

  have "decseq I"
    unfolding I_def decseq_Suc_iff ivl fst_conv snd_conv
    by (intro ij allI less)

  txt \<open>Now we apply the finite intersection property of compact sets.\<close>

  have "I 0 \<inter> (\<Inter>i. I i) \<noteq> {}"
  proof (rule compact_imp_fip_image)
    fix S :: "nat set"
    assume fin: "finite S"
    have "{} \<subset> I (Max (insert 0 S))"
      unfolding I_def using less[of "Max (insert 0 S)"] by auto
    also have "I (Max (insert 0 S)) \<subseteq> (\<Inter>i\<in>insert 0 S. I i)"
      using fin decseqD[OF \<open>decseq I\<close>, of _ "Max (insert 0 S)"]
      by (auto simp: Max_ge_iff)
    also have "(\<Inter>i\<in>insert 0 S. I i) = I 0 \<inter> (\<Inter>i\<in>S. I i)"
      by auto
    finally show "I 0 \<inter> (\<Inter>i\<in>S. I i) \<noteq> {}"
      by auto
  qed (auto simp: I_def)
  then obtain x where "x \<in> I n" for n
    by blast
  moreover from \<open>surj f\<close> obtain j where "x = f j"
    by blast
  ultimately have "f j \<in> I (Suc j)"
    by blast
  with ij(3)[OF less] show False
    unfolding I_def ivl fst_conv snd_conv by auto
qed

lemma uncountable_UNIV_real: "uncountable (UNIV :: real set)"
  using real_non_denum unfolding uncountable_def by auto

corollary complex_non_denum: "\<nexists>f :: nat \<Rightarrow> complex. surj f"
  by (metis (full_types) Re_complex_of_real comp_surj real_non_denum surj_def)

lemma uncountable_UNIV_complex: "uncountable (UNIV :: complex set)"
  using complex_non_denum unfolding uncountable_def by auto

lemma bij_betw_open_intervals:
  fixes a b c d :: real
  assumes "a < b" "c < d"
  shows "\<exists>f. bij_betw f {a<..<b} {c<..<d}"
proof -
  define f where "f a b c d x = (d - c)/(b - a) * (x - a) + c" for a b c d x :: real
  {
    fix a b c d x :: real
    assume *: "a < b" "c < d" "a < x" "x < b"
    moreover from * have "(d - c) * (x - a) < (d - c) * (b - a)"
      by (intro mult_strict_left_mono) simp_all
    moreover from * have "0 < (d - c) * (x - a) / (b - a)"
      by simp
    ultimately have "f a b c d x < d" "c < f a b c d x"
      by (simp_all add: f_def field_simps)
  }
  with assms have "bij_betw (f a b c d) {a<..<b} {c<..<d}"
    by (intro bij_betw_byWitness[where f'="f c d a b"]) (auto simp: f_def)
  then show ?thesis by auto
qed

lemma bij_betw_tan: "bij_betw tan {-pi/2<..<pi/2} UNIV"
  using arctan_ubound by (intro bij_betw_byWitness[where f'=arctan]) (auto simp: arctan arctan_tan)

lemma uncountable_open_interval: "uncountable {a<..<b} \<longleftrightarrow> a < b" for a b :: real
proof
  show "a < b" if "uncountable {a<..<b}"
    using uncountable_def that by force
  show "uncountable {a<..<b}" if "a < b"
  proof -
    obtain f where "bij_betw f {a <..< b} {-pi/2<..<pi/2}"
      using bij_betw_open_intervals[OF \<open>a < b\<close>, of "-pi/2" "pi/2"] by auto
    then show ?thesis
      by (metis bij_betw_tan uncountable_bij_betw uncountable_UNIV_real)
  qed
qed

lemma uncountable_half_open_interval_1: "uncountable {a..<b} \<longleftrightarrow> a < b" for a b :: real
  apply auto
  using atLeastLessThan_empty_iff
  apply fastforce
  using uncountable_open_interval [of a b]
  apply (metis countable_Un_iff ivl_disj_un_singleton(3))
  done

lemma uncountable_half_open_interval_2: "uncountable {a<..b} \<longleftrightarrow> a < b" for a b :: real
  apply auto
  using atLeastLessThan_empty_iff
  apply fastforce
  using uncountable_open_interval [of a b]
  apply (metis countable_Un_iff ivl_disj_un_singleton(4))
  done

lemma real_interval_avoid_countable_set:
  fixes a b :: real and A :: "real set"
  assumes "a < b" and "countable A"
  shows "\<exists>x\<in>{a<..<b}. x \<notin> A"
proof -
  from \<open>countable A\<close> have *: "countable (A \<inter> {a<..<b})"
    by auto
  with \<open>a < b\<close> have "\<not> countable {a<..<b}"
    by (simp add: uncountable_open_interval)
  with * have "A \<inter> {a<..<b} \<noteq> {a<..<b}"
    by auto
  then have "A \<inter> {a<..<b} \<subset> {a<..<b}"
    by (intro psubsetI) auto
  then have "\<exists>x. x \<in> {a<..<b} - A \<inter> {a<..<b}"
    by (rule psubset_imp_ex_mem)
  then show ?thesis
    by auto
qed

lemma uncountable_closed_interval: "uncountable {a..b} \<longleftrightarrow> a < b" for a b :: real
  using infinite_Icc_iff by (fastforce dest: countable_finite real_interval_avoid_countable_set)

lemma open_minus_countable:
  fixes S A :: "real set"
  assumes "countable A" "S \<noteq> {}" "open S"
  shows "\<exists>x\<in>S. x \<notin> A"
proof -
  obtain x where "x \<in> S"
    using \<open>S \<noteq> {}\<close> by auto
  then obtain e where "0 < e" "{y. dist y x < e} \<subseteq> S"
    using \<open>open S\<close> by (auto simp: open_dist subset_eq)
  moreover have "{y. dist y x < e} = {x - e <..< x + e}"
    by (auto simp: dist_real_def)
  ultimately have "uncountable (S - A)"
    using uncountable_open_interval[of "x - e" "x + e"] \<open>countable A\<close>
    by (intro uncountable_minus_countable) (auto dest: countable_subset)
  then show ?thesis
    unfolding uncountable_def by auto
qed

end


theory implication_subst
  imports Main
    "HOL-Eisbach.Eisbach"
    "fuzzyrule.fuzzyrule"
begin

section "Implication Subst"

text "Here we define a method to do subsitution with implications instead of equalities."

text "The theorem collection pos_cong includes theorems for rewriting.
Each of these theoremy has 2 assumptions.
The first one is the implication to use.
The left hand side of the implication should not contain any negations.
The second one represents the conclusion after rewriting."
named_theorems pos_cong

subsection "Quantifiers"

lemma implication_subst_exists[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> Q x"
    and "\<exists>x. P x"
  shows "\<exists>x. Q x"
  using assms  by blast

lemma implication_subst_not_exists[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> \<not>Q x"
    and "\<not>(\<exists>x. \<not>P x)"
  shows "\<not>(\<exists>x. Q x)"
  using assms  by blast

lemma implication_subst_forall[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> Q x"
    and "\<forall>x. P x"
  shows "\<forall>x. Q x"
  using assms  by blast

lemma implication_subst_not_forall[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> \<not>Q x"
    and "\<not>(\<forall>x. \<not>P x)"
  shows "\<not>(\<forall>x. Q x)"
  using assms  by blast

lemma implication_subst_bexists[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> Q x"
    and "\<exists>x\<in>S. P x"
  shows "\<exists>x\<in>S. Q x"
  using assms by blast

lemma implication_subst_not_bexists[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> \<not>Q x"
    and "\<not>(\<exists>x\<in>S. \<not>P x)"
  shows "\<not>(\<exists>x\<in>S. Q x)"
  using assms  by blast

lemma implication_subst_bforall[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> Q x"
    and "\<forall>x\<in>S. P x"
  shows "\<forall>x\<in>S. Q x"
  using assms  by blast

lemma implication_subst_not_bforall[pos_cong]:
  assumes "\<And>x. P x \<Longrightarrow> \<not>Q x"
    and "\<not>(\<forall>x\<in>S. \<not>P x)"
  shows "\<not>(\<forall>x\<in>S. Q x)"
  using assms  by blast

subsection "Conjunction"

lemma implication_subst_conjl[pos_cong]:
  assumes "P \<Longrightarrow> Q"
 and "P \<and> A"
shows "Q \<and> A"
  using assms  by blast

lemma implication_subst_conjr[pos_cong]:
  assumes "P \<Longrightarrow> Q"
 and "A \<and> P"
shows "A \<and> Q"
  using assms  by blast

lemma implication_subst_not_conjl[pos_cong]:
  assumes "P \<Longrightarrow> \<not>Q"
 and "\<not>(\<not>P \<and> A)"
shows "\<not>(Q \<and> A)"
  using assms  by blast

lemma implication_subst_not_conjr[pos_cong]:
  assumes "P \<Longrightarrow> \<not>Q"
 and "\<not>(A \<and> \<not>P)"
shows "\<not>(A \<and> Q)"
  using assms  by blast

subsection "Double negation"

lemma implication_subst_neg[pos_cong]:
  assumes "P \<Longrightarrow> Q"
    and "P"
  shows "\<not>\<not>Q"
  using assms by auto

subsection "Implication"

lemma implication_subst_impl[pos_cong]:
  assumes "P \<Longrightarrow> \<not>Q"
    and "\<not>P \<longrightarrow> A"
  shows "Q \<longrightarrow> A"
  using assms by auto

lemma implication_subst_impr[pos_cong]:
  assumes "P \<Longrightarrow> Q"
    and "A \<longrightarrow> P"
  shows "A \<longrightarrow> Q"
  using assms by auto

lemma implication_subst_not_impl[pos_cong]:
  assumes "P \<Longrightarrow> Q"
    and "\<not>(P \<longrightarrow> A)"
  shows "\<not>(Q \<longrightarrow> A)"
  using assms by auto

lemma implication_subst_not_impr[pos_cong]:
  assumes "P \<Longrightarrow> \<not>Q"
    and "\<not>(A \<longrightarrow> \<not>P)"
  shows "\<not>(A \<longrightarrow> Q)"
  using assms by auto

subsection "Disjunction"

lemma implication_subst_disj_l[pos_cong]:
  assumes "P \<Longrightarrow> Q"
    and "P \<or> A"
  shows "Q \<or> A"
  using assms by auto

lemma implication_subst_r[pos_cong]:
  assumes "P \<Longrightarrow> Q"
    and "A \<or> P"
  shows "A \<or> Q"
  using assms by auto

lemma implication_subst_not_disj_l[pos_cong]:
  assumes "P \<Longrightarrow> \<not>Q"
    and "\<not>(\<not>P \<or> A)"
  shows "\<not>(Q \<or> A)"
  using assms by auto

lemma implication_subst_not_disj_r[pos_cong]:
  assumes "P \<Longrightarrow> \<not>Q"
    and "\<not>(A \<or> \<not>P)"
  shows "\<not>(A \<or> Q)"
  using assms by auto

method implication_subst_h uses r declares pos_cong = (
      rule r
      | (rule pos_cong, implication_subst_h r: r, assumption))

method implication_subst uses r declares pos_cong =
  (implication_subst_h r: r pos_cong: pos_cong, (unfold not_not)?)

method implication_subst_fuzzy_h uses r declares pos_cong = (
      fuzzy_rule r
      | (rule pos_cong, implication_subst_h r: r, assumption))

method implication_subst_fuzzy uses r declares pos_cong =
  (implication_subst_fuzzy_h r: r pos_cong: pos_cong, (unfold not_not)?)

end