(*
  File:    Pell_Algorithm.thy
  Author:  Manuel Eberl, TU München

  Some executable but not too efficient algorithms for computing solutions to Pell's equation.
*)
subsection \<open>Executable code\<close>
theory Pell_Algorithm
imports
  Pell
  Efficient_Discrete_Sqrt
  "HOL-Library.Discrete"
  "HOL-Library.While_Combinator"
  "HOL-Library.Stream"
begin

subsubsection \<open>Efficient computation of powers by squaring\<close>

text \<open>
  The following is a tail-recursive implementation of exponentiation by squaring.
  It works for any binary operation \<open>f\<close> that fulfils \<open>f x (f x z) = f (f x x) z\<close>, i.\,e.\
  some weak form of associativity.
\<close>

context
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
begin

function efficient_power :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "efficient_power y x 0 = y"
| "efficient_power y x (Suc 0) = f x y"
| "n \<noteq> 0 \<Longrightarrow> even n \<Longrightarrow> efficient_power y x n = efficient_power y (f x x) (n div 2)"
| "n \<noteq> 1 \<Longrightarrow> odd n \<Longrightarrow> efficient_power y x n = efficient_power (f x y) (f x x) (n div 2)"
  by force+
termination by (relation "measure (snd \<circ> snd)") (auto elim: oddE)

lemma efficient_power_code [code]:
  "efficient_power y x n =
     (if n = 0 then y
      else if n = 1 then f x y
      else if even n then efficient_power y (f x x) (n div 2)
      else efficient_power (f x y) (f x x) (n div 2))"
  by (induction y x n rule: efficient_power.induct) auto

lemma efficient_power_correct:
  assumes "\<And>x z. f x (f x z) = f (f x x) z"
  shows   "efficient_power y x n = (f x ^^ n) y"
proof -
  have [simp]: "f ^^ 2 = (\<lambda>x. f (f x))" for f :: "'a \<Rightarrow> 'a"
    by (simp add: eval_nat_numeral o_def)
  show ?thesis
    by (induction y x n rule: efficient_power.induct)
       (auto elim!: evenE oddE simp: funpow_mult [symmetric] funpow_Suc_right assms
             simp del: funpow.simps(2))
qed

end

subsubsection \<open>Multiplication and powers of solutions\<close>

text \<open>
  We define versions of Pell solution multiplication and exponentiation specialised
  to natural numbers, both for efficiency reasons and to circumvent the problem of
  generating code for definitions made inside locales.
\<close>
fun pell_mul_nat :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> _" where
  "pell_mul_nat D (a, b) (x, y) = (a * x + D * b * y, a * y + b * x)"

lemma (in pell) pell_mul_nat_correct [simp]: "pell_mul_nat D = pell.pell_mul D"
  by (auto simp add: pell_mul_def fun_eq_iff)

definition efficient_pell_power :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
  "efficient_pell_power D z n = efficient_power (pell_mul_nat D) (1, 0) z n"

lemma efficient_pell_power_correct [simp]:
  "efficient_pell_power D z n = (pell_mul_nat D z ^^ n) (1, 0)"
  unfolding efficient_pell_power_def
  by (intro efficient_power_correct) (auto simp: algebra_simps)

subsubsection \<open>Finding the fundamental solution\<close>

text \<open>
  In the following, we set up a very simple algorithm for computing the fundamental
  solution \<open>(x, y)\<close>. We try inreasing values for \<open>y\<close> until $1 + Dy^2$ is a perfect
  square, which we check using an efficient square-detection algorithm. This is efficient
  enough to work on some interesting small examples.

  Much better algorithms (typically based on the continued fraction expansion of $\sqrt{D}$)
  are available, but they are also considerably more complicated.
\<close>

lemma Discrete_sqrt_square_is_square:
  assumes "is_square n"
  shows   "Discrete.sqrt n ^ 2 = n"
  using assms unfolding is_nth_power_def by force

definition find_fund_sol_step :: "nat \<Rightarrow> nat \<times> nat + nat \<times> nat \<Rightarrow> _" where
  "find_fund_sol_step D = (\<lambda>Inl (y, y') \<Rightarrow>
     (case get_nat_sqrt y' of
        Some x \<Rightarrow> Inr (x, y)
      | None \<Rightarrow> Inl (y + 1, y' + D * (2 * y + 1))))"

definition find_fund_sol where
  "find_fund_sol D =
     (if square_test D then
        (0, 0)
      else
        sum.projr (while sum.isl (find_fund_sol_step D) (Inl (1, 1 + D))))"

lemma fund_sol_code:
  assumes "\<not>is_square (D :: nat)"
  shows   "pell.fund_sol D = sum.projr (while isl (find_fund_sol_step D) (Inl (Suc 0, Suc D)))"
proof -
  from assms interpret pell D by unfold_locales
  note [simp] = find_fund_sol_step_def
  define f where "f = find_fund_sol_step D"
  define P :: "nat \<Rightarrow> bool" where "P = (\<lambda>y. y > 0 \<and> is_square (y^2 * D + 1))"
  define Q :: "nat \<times> nat \<Rightarrow> bool" where
    "Q = (\<lambda>(x,y). P y \<and> (\<forall>y'\<in>{0<..<y}. \<not>P y') \<and> x = Discrete.sqrt (y^2 * D + 1))"
  define R :: "nat \<times> nat + nat \<times> nat \<Rightarrow> bool"
    where "R = (\<lambda>s. case s of
                      Inl (m, m') \<Rightarrow> m > 0 \<and> (m' = m^2 * D + 1) \<and> (\<forall>y\<in>{0<..<m}. \<not>is_square (y^2 * D + 1))
                    | Inr x \<Rightarrow> Q x)"
  define rel :: "((nat \<times> nat + nat \<times> nat) \<times> (nat \<times> nat + nat \<times> nat)) set"
    where "rel = {(A,B). (case (A, B) of
                           (Inl (m, _), Inl (m', _)) \<Rightarrow> m' > 0 \<and> m > m' \<and> m \<le> snd fund_sol
                         | (Inr _, Inl (m', _)) \<Rightarrow> m' \<le> snd fund_sol
                         | _ \<Rightarrow> False) \<and> A = f B}"
  obtain x y where xy: "sum.projr (while isl f (Inl (Suc 0, Suc D))) = (x, y)"
    by (cases "sum.projr (while isl f (Inl (Suc 0, Suc D)))")

  have neq_fund_solI: "y \<noteq> snd fund_sol" if "\<not> is_square (Suc (y\<^sup>2 * D))" for y
  proof
    assume "y = snd fund_sol"
    with fund_sol_is_nontriv_solution have "Suc (y\<^sup>2 * D) = fst fund_sol ^ 2"
      by (simp add: nontriv_solution_def case_prod_unfold)
    hence "is_square (Suc (y\<^sup>2 * D))" by simp
    with that show False by contradiction
  qed

  have "case_sum (\<lambda>_. False) Q (while sum.isl f (Inl (m, m^2 * D + 1)))"
    if "\<forall>y\<in>{0<..<m}. \<not>is_square (y^2 * D + 1)" "m > 0" for m
  proof (rule while_rule[where b = sum.isl])
    show "R (Inl (m, m\<^sup>2 * D + 1))"
      using that by (auto simp: R_def)
  next
    fix s assume "R s" "isl s"
    thus "R (f s)"
      by (auto simp: not_less_less_Suc_eq Q_def P_def R_def f_def get_nat_sqrt_def
                     power2_eq_square algebra_simps split: sum.splits prod.splits)
  next
    fix s assume "R s" "\<not>isl s"
    thus "case s of Inl _ \<Rightarrow> False | Inr x \<Rightarrow> Q x"
      by (auto simp: R_def split: sum.splits)
  next
    fix s assume s: "R s" "isl s"
    show "(f s, s) \<in> rel"
    proof (cases s)
      case [simp]: (Inl s')
      obtain a b where [simp]: "s' = (a, b)" by (cases s')
      from s have *: "a > 0" "b = Suc (a\<^sup>2 * D)" "\<And>y. y \<in> {0<..<a} \<Longrightarrow> \<not> is_square (Suc (y\<^sup>2 * D))"
        by (auto simp: R_def)

      have "a < snd fund_sol" if **: "\<not> is_square (Suc (a\<^sup>2 * D))"
      proof -
        from neq_fund_solI have "y' \<noteq> snd fund_sol" if "y' \<in> {0<..<Suc a}" for y'
          using * ** that by (cases "y' = a") auto
        moreover have "snd fund_sol \<noteq> 0" using fund_sol_is_nontriv_solution
          by (intro notI, cases fund_sol) (auto simp: nontriv_solution_altdef)
        ultimately have "\<forall>y'\<le>a. y' \<noteq> snd fund_sol" by (auto simp: less_Suc_eq_le)
        thus "snd fund_sol > a" by (cases "a < snd fund_sol") (auto simp: not_less)
      qed
      moreover have "a \<le> snd fund_sol"
      proof -
        have "\<forall>y'\<in>{0<..<a}. y' \<noteq> snd fund_sol" using neq_fund_solI *
          by (auto simp: less_Suc_eq_le)
        moreover have "snd fund_sol \<noteq> 0" using fund_sol_is_nontriv_solution
          by (intro notI, cases fund_sol) (auto simp: nontriv_solution_altdef)
        ultimately have "\<forall>y'<a. y' \<noteq> snd fund_sol" by (auto simp: less_Suc_eq_le)
        thus "snd fund_sol \<ge> a" by (cases "a \<le> snd fund_sol") (auto simp: not_less)
      qed
      ultimately show ?thesis using *
        by (auto simp: f_def get_nat_sqrt_def rel_def)
    qed (insert s, auto)
  next
    define rel'
      where "rel' = {(y, x). (case x of Inl (m, _) \<Rightarrow> m \<le> snd fund_sol | Inr _ \<Rightarrow> False) \<and> y = f x}"
    have "wf rel'" unfolding rel'_def
      by (rule wf_if_measure[where f = "\<lambda>z. case z of Inl (m, _) \<Rightarrow> Suc (snd fund_sol) - m | _ \<Rightarrow> 0"])
         (auto split: prod.splits sum.splits simp: f_def get_nat_sqrt_def)
    moreover have "rel \<subseteq> rel'"
    proof safe
      fix w z assume "(w, z) \<in> rel"
      thus "(w, z) \<in> rel'" by (cases w; cases z) (auto simp: rel_def rel'_def)
    qed
    ultimately show "wf rel" by (rule wf_subset)
  qed
  from this[of 1] and xy have *: "Q (x, y)"
    by (auto split: sum.splits)

  from * have "is_square (Suc (y\<^sup>2 * D))" by (simp add: Q_def P_def)
  with * have "x\<^sup>2 = Suc (y\<^sup>2 * D)" "y > 0"
    by (auto simp: Q_def P_def Discrete_sqrt_square_is_square)
  hence "nontriv_solution (x, y)"
    by (auto simp: nontriv_solution_def)
  from this have "snd fund_sol \<le> snd (x, y)"
    by (rule fund_sol_minimal'')
  moreover have "snd fund_sol \<ge> y"
  proof -
    from * have "(\<forall>y'\<in>{0<..<y}. \<not> is_square (Suc (y'\<^sup>2 * D)))"
      by (simp add: Q_def P_def)
    with neq_fund_solI have "(\<forall>y'\<in>{0<..<y}. y' \<noteq> snd fund_sol)"
      by auto
    moreover have "snd fund_sol \<noteq> 0"
      using fund_sol_is_nontriv_solution
      by (cases fund_sol) (auto intro!: Nat.gr0I simp: nontriv_solution_altdef)
    ultimately have "(\<forall>y'<y. y' \<noteq> snd fund_sol)" by auto
    thus "snd fund_sol \<ge> y" by (cases "snd fund_sol \<ge> y") (auto simp: not_less)
  qed
  ultimately have "snd fund_sol = y" by simp
  with solutions_linorder_strict[of x y "fst fund_sol" "snd fund_sol"]
       fund_sol_is_nontriv_solution \<open>nontriv_solution (x, y)\<close>
    have "fst fund_sol = x" by (cases fund_sol) (auto simp: nontriv_solution_altdef)
  with \<open>snd fund_sol = y\<close> have "fund_sol = (x, y)"
    by (cases fund_sol) simp
  with xy show ?thesis by (simp add: f_def)
qed

lemma find_fund_sol_correct: "find_fund_sol D = (if is_square D then (0, 0) else pell.fund_sol D)"
  by (simp add: find_fund_sol_def fund_sol_code square_test_correct)

subsubsection \<open>The infinite list of all solutions\<close>

definition pell_solutions :: "nat \<Rightarrow> (nat \<times> nat) stream" where
  "pell_solutions D = (let z = find_fund_sol D in siterate (pell_mul_nat D z) (1, 0))"

lemma (in pell) "snth (pell_solutions D) n = nth_solution n"
  by (simp add: pell_solutions_def Let_def find_fund_sol_correct nonsquare_D nth_solution_def
                pell_power_def pell_mul_commutes[of _ fund_sol])

subsubsection \<open>Computing the $n$-th solution\<close>

definition find_nth_solution :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
  "find_nth_solution D n =
     (if is_square D then (0, 0) else
        let z = sum.projr (while isl (find_fund_sol_step D) (Inl (Suc 0, Suc D)))
        in  efficient_pell_power D z n)"

lemma (in pell) find_nth_solution_correct: "find_nth_solution D n = nth_solution n"
  by (simp add: find_nth_solution_def nonsquare_D nth_solution_def fund_sol_code
                pell_power_def pell_mul_commutes[of _ "projr _"])

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_49
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x2) (Z) = False"
| "y (S x2) (S y22) = y x2 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y2 = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert z (nil2) = cons2 z (nil2)"
| "insert z (cons2 z2 xs) =
     (if t2 z z2 then cons2 z (cons2 z2 xs) else cons2 z2 (insert z xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y2 xs) = insert y2 (isort xs)"

theorem property0 :
  "((elem z (isort y2)) ==> (elem z y2))"
  oops

end


theory Padic_Field_Topology
  imports Padic_Fields
begin

(**************************************************************************************************)
(**************************************************************************************************)
section\<open>Topology of $p$-adic Fields\<close>
(**************************************************************************************************)
(**************************************************************************************************)

text\<open>
  In this section we develop some basic properties of the topology on the $p$-adics. Open and
  closed sets are defined, convex subsets of the value group are characterized.
\<close>
type_synonym padic_univ_poly = "nat \<Rightarrow> padic_number"

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>$p$-adic Balls\<close>
(**************************************************************************************************)
(**************************************************************************************************)

context padic_fields
begin

definition c_ball :: "int \<Rightarrow> padic_number \<Rightarrow> padic_number set" ("B\<^bsub>_\<^esub>[_]") where
"c_ball n c = {x \<in> carrier Q\<^sub>p. val (x \<ominus> c) \<ge> n}"

lemma c_ballI:
  assumes "x \<in> carrier Q\<^sub>p"
  assumes " val (x \<ominus> c) \<ge> n"
  shows "x \<in> c_ball n c"
  using assms c_ball_def
  by blast

lemma c_ballE:
  assumes "x \<in> c_ball n c"
  shows "x \<in> carrier Q\<^sub>p"
        " val (x \<ominus> c) \<ge> n"
  using assms c_ball_def apply blast
    using assms c_ball_def by blast

lemma c_ball_in_Qp:
  "B\<^bsub>n\<^esub>[c] \<subseteq> carrier Q\<^sub>p"
  unfolding c_ball_def
  by blast

definition
q_ball :: "nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> padic_number \<Rightarrow> padic_number set" where
"q_ball n k m c = {x \<in> carrier Q\<^sub>p. (ac n (x \<ominus> c) = k \<and> (ord (x \<ominus> c)) = m) }"

lemma q_ballI:
  assumes "x \<in> carrier Q\<^sub>p"
  assumes "ac n (x \<ominus> c) = k"
  assumes "(ord (x \<ominus> c)) = m"
  shows "x \<in> q_ball n k m c"
  using assms q_ball_def
  by blast

lemma q_ballE:
  assumes "x \<in> q_ball n k m c "
  shows "x \<in> carrier Q\<^sub>p"

  using assms q_ball_def by blast

lemma q_ballE':
  assumes "x \<in> q_ball n k m c "
  shows  "ac n (x \<ominus> c) = k"
        "(ord (x \<ominus> c)) = m"
  using assms q_ball_def apply blast
  using assms q_ball_def by blast

lemma q_ball_in_Qp:
  "q_ball n k m c  \<subseteq> carrier Q\<^sub>p"
  unfolding q_ball_def by blast

lemma ac_ord_prop:
  assumes "a \<in> nonzero Q\<^sub>p"
  assumes "b \<in> nonzero Q\<^sub>p"
  assumes "ord a = ord b"
  assumes "ord a = n"
  assumes "ac m a = ac m b"
  assumes "m > 0"
  shows "val (a \<ominus> b) \<ge> m + n "
proof-
  have 0: "a = (\<pp>[^]n) \<otimes> \<iota> (angular_component a)"
    using angular_component_factors_x assms(1) assms(4) by blast
  have 1: "b = (\<pp>[^]n) \<otimes> \<iota> (angular_component b)"
    using angular_component_factors_x assms(4) assms(2) assms(3)
    by presburger
  have 2: "a \<ominus>b = (\<pp>[^]n) \<otimes> \<iota> (angular_component a) \<ominus>
                     (\<pp>[^]n) \<otimes> \<iota> (angular_component b) "
    using 0 1 by auto
  have 3: "a \<ominus>b = (\<pp>[^]n) \<otimes>( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b))"
  proof-
    have 30: "(\<pp>[^]n) \<in> carrier Q\<^sub>p"
      by (simp add: p_intpow_closed(1))
    have 31: " \<iota> (angular_component a)  \<in> carrier Q\<^sub>p"
      using Zp.nonzero_one_closed angular_component_closed assms(1) frac_closed local.inc_def
      by presburger
    have 32: " \<iota> (angular_component b)  \<in> carrier Q\<^sub>p"
      using Zp.nonzero_one_closed angular_component_closed assms(2) frac_closed local.inc_def
      by presburger
    show ?thesis
      using 2 30 31 32 ring.ring_simprules(23)[of Q\<^sub>p "(\<pp>[^]n)"]
      unfolding a_minus_def
      by (metis Qp.domain_axioms cring.cring_simprules(25) cring.cring_simprules(29)
          cring.cring_simprules(3) domain.axioms(1))
  qed
  have 4: "a \<ominus>b = (\<pp>[^]n) \<otimes>( \<iota> ((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>  (angular_component b)))"
    using 3
    by (simp add: angular_component_closed assms(1) assms(2) inc_of_diff)
  have 5: "val_Zp ((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>  (angular_component b)) \<ge>  m "
  proof-
    have "((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub> (angular_component b)) m = 0"
      using assms(5)
      unfolding ac_def
      using Q\<^sub>p_def Qp.nonzero_memE(2) angular_component_closed assms(1) assms(2) residue_of_diff'
      by auto
    then show ?thesis
      using  Zp.minus_closed angular_component_closed assms(1) assms(2) ord_Zp_geq val_Zp_def val_ord_Zp
      by auto
  qed
  have 6: "val (a \<ominus> b) \<ge> n + val ( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b))"
    using 3 Qp.minus_closed angular_component_closed assms(1) assms(2) inc_closed
        ord_p_pow_int p_intpow_closed(1) p_intpow_closed(2) val_mult val_ord
    by simp
  have 7: "n + val ( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b))
          = n + val_Zp ((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>  (angular_component b))"
    using Zp.minus_closed angular_component_closed assms(1) assms(2) inc_of_diff val_of_inc
    by simp
  have 8: "n + val_Zp ( (angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>(angular_component b))
                \<ge> n + m"
    using 5
    by (metis add_mono_thms_linordered_semiring(2) plus_eint_simps(1))
  then have 9: "n + val ( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b))
                \<ge> n + m"
    using "7" by presburger
  then show ?thesis
    by (metis (no_types, opaque_lifting) "6" add.commute order_trans plus_eint_simps(1))
qed

lemma c_ball_q_ball:
  assumes "b \<in> nonzero Q\<^sub>p"
  assumes "n > 0"
  assumes "k = ac n b"
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "d \<in> q_ball n k m c"
  shows "q_ball n k m c = c_ball (m + n) d"
proof
  show "q_ball n k m c \<subseteq> B\<^bsub>m + int n\<^esub>[d]"
  proof
    fix x
    assume A0: "x \<in> q_ball n k m c"
    show "x \<in> B\<^bsub>m + int n\<^esub>[d]"
    proof-
      have A1: "(ac n (x \<ominus> c) = k \<and> (ord (x \<ominus> c)) = m)"
        using A0 q_ball_def
        by blast
      have "val (x \<ominus> d) \<ge> m + n"
      proof-
        have A2: "(ac n (d \<ominus> c) = k \<and> (ord (d \<ominus> c)) = m)"
          using assms(5) q_ball_def
          by blast
        have A3: "(x \<ominus> c) \<in> nonzero Q\<^sub>p"
        proof-
          have "k \<noteq>0"
            using A2 assms(1) assms(3) assms(5) ac_units[of b n]
            by (metis One_nat_def Suc_le_eq assms(2) zero_not_in_residue_units)
          then show ?thesis
            by (smt A0 Qp.domain_axioms ac_def assms(4) cring.cring_simprules(4) domain.axioms(1)
              mem_Collect_eq not_nonzero_Qp q_ball_def)
        qed
        have A4: "(d \<ominus> c) \<in> nonzero Q\<^sub>p"
        proof-
          have "k \<noteq>0"
            using A2 assms(1) assms(3) assms(5) ac_units[of b n]
            by (metis One_nat_def Suc_le_eq assms(2) zero_not_in_residue_units)
          then show ?thesis
            by (metis (no_types, lifting) A2 Qp.domain_axioms ac_def assms(4) assms(5)
                cring.cring_simprules(4) domain.axioms(1) mem_Collect_eq not_nonzero_Qp q_ball_def)
        qed
        then have " val ((x \<ominus> c) \<ominus>(d \<ominus> c)) \<ge>  n + m"
          using ac_ord_prop[of "(x \<ominus> c)" "(d \<ominus> c)" m n ] A1 A2 assms A3
          by simp
        then show ?thesis
          by (smt A0 Qp_diff_diff assms(4) assms(5) q_ballE)
      qed
      then show ?thesis
        by (metis (no_types, lifting) A0 c_ball_def mem_Collect_eq q_ball_def)
    qed
  qed
  show "B\<^bsub>m + int n\<^esub>[d] \<subseteq> q_ball n k m c"
  proof
    fix x
    assume A: "x \<in> B\<^bsub>m + int n\<^esub>[d]"
    show "x \<in> q_ball n k m c"
    proof-
      have A0: "val (x \<ominus> d) \<ge> m + n"
        using A c_ball_def
        by blast
      have A1: "ord (d \<ominus> c) = m"
        using assms(5) q_ball_def
        by blast
      have A2: "ac n (d \<ominus> c) = k"
        using assms(5) q_ball_def
        by blast
      have A3: "(d \<ominus> c) \<noteq> \<zero>"
        using A2 assms
        by (metis ac_def ac_units le_eq_less_or_eq le_neq_implies_less less_one nat_le_linear
            padic_integers.zero_not_in_residue_units padic_integers_def prime zero_less_iff_neq_zero)
      have A4: "val (d \<ominus> c) =m"
        by (simp add: A1 A3 val_def)
      have A5: "val (x \<ominus> d) > val (d \<ominus> c)"
        by (smt A0 A4 assms(2) eint_ord_code(4) eint_ord_simps(1) eint_ord_simps(2) of_nat_0_less_iff val_def)
      have A6: "val ((x \<ominus> d) \<oplus> (d \<ominus> c)) = m"
        using A4 A0 A5
        by (metis (mono_tags, opaque_lifting) A Qp.minus_closed assms(4) assms(5)
            c_ballE(1) q_ballE val_ultrametric_noteq)
      have A7: "val (x \<ominus> c) = m"
      proof-
        have "(x \<ominus> d) \<oplus> (d \<ominus> c) = ((x \<ominus> d) \<oplus> d) \<ominus> c"
          by (metis (no_types, lifting) A Qp.domain_axioms a_minus_def assms(4) assms(5)
              c_ball_def cring.cring_simprules(3) cring.cring_simprules(4)
              cring.cring_simprules(7) domain.axioms(1) mem_Collect_eq q_ball_def)
        have "(x \<ominus> d) \<oplus> (d \<ominus> c) = (x \<oplus> (\<ominus> d \<oplus> d)) \<ominus> c"
          by (metis (no_types, opaque_lifting) A Qp.add.l_cancel_one Qp.add.m_comm Qp.l_neg
              Qp.minus_closed Qp.plus_diff_simp Qp.zero_closed assms(4) assms(5)
              c_ballE(1) q_ballE)
        then show ?thesis
          by (metis (no_types, lifting) A A6 Qp.domain_axioms assms(5) c_ball_def
              cring.cring_simprules(16) cring.cring_simprules(9) domain.axioms(1)
              mem_Collect_eq q_ball_def)
      qed
      have A8: "ac n (x \<ominus> c) = ac n (d \<ominus> c)"
      proof-
        have A80: "(x \<ominus> c) \<in> nonzero Q\<^sub>p"
          by (metis (no_types, lifting) A A4 A5 A7 Qp.domain_axioms
              assms(4) cring.cring_simprules(4) domain.axioms(1)
              mem_Collect_eq c_ball_def val_nonzero)
        have A81: "(d \<ominus> c) \<in> nonzero Q\<^sub>p"
          by (metis (no_types, lifting) A3 Qp.domain_axioms assms(4) assms(5)
              cring.cring_simprules(4) domain.axioms(1) mem_Collect_eq not_nonzero_Qp q_ball_def)
        have A82: "n + m= val (x \<ominus> c) + n"
          by (simp add: A7)
        show ?thesis
          using A0 A4 A7 ac_val[of "(x \<ominus> c)" "(d \<ominus> c)" n] A A80 A81 Qp_diff_diff assms(4) assms(5) c_ballE(1) q_ballE
          by auto
      qed
      show ?thesis using A8 A3 A7 A2 q_ball_def[of n k m c] q_ballI[of x n c k m]
        by (metis (no_types, lifting) A A4 A5 Qp.minus_closed assms(4) c_ballE(1) eint.inject val_nonzero val_ord)
    qed
  qed
qed

definition is_ball :: "padic_number set \<Rightarrow> bool" where
"is_ball B = (\<exists>(m::int). \<exists> c \<in> carrier Q\<^sub>p. (B = B\<^bsub>m\<^esub>[c]))"

lemma is_ball_imp_in_Qp:
  assumes "is_ball B"
  shows "B \<subseteq> carrier Q\<^sub>p"
  unfolding is_ball_def
  using assms c_ball_in_Qp is_ball_def
  by auto

lemma c_ball_centers:
  assumes "is_ball B"
  assumes "B = B\<^bsub>n\<^esub>[c]"
  assumes "d \<in> B"
  assumes "c \<in> carrier Q\<^sub>p"
  shows "B = B\<^bsub>n\<^esub>[d]"
proof
  show "B \<subseteq> B\<^bsub>n\<^esub>[d]"
  proof
    fix x
    assume A0: "x \<in> B"
    have "val (x \<ominus> d) \<ge> n"
    proof-
      have A00: "val (x \<ominus> c) \<ge> n"
        using A0 assms(2) c_ballE(2) by blast
      have A01: "val (d \<ominus> c) \<ge> n"
        using assms(2) assms(3) c_ballE(2) by blast
      then show ?thesis
        using Qp_isosceles[of x c d "n"] assms A0 A00 c_ballE(1)
        by blast
    qed
    then show "x \<in> B\<^bsub>n\<^esub>[d]"
      using A0 assms(1) c_ballI is_ball_imp_in_Qp
      by blast
  qed
  show "B\<^bsub>n\<^esub>[d] \<subseteq> B"
  proof
    fix x
    assume "x \<in> B\<^bsub>n\<^esub>[d]"
    show "x \<in> B"
      using Qp_isosceles[of x d c "n"]
            assms
      unfolding c_ball_def
      by (metis (no_types, lifting) Qp.domain_axioms Qp_isosceles \<open>x \<in> B\<^bsub>n\<^esub>[d]\<close>
          a_minus_def assms(2) c_ballE(2) c_ballI cring.cring_simprules(17) domain.axioms(1)
          c_ballE(1))
  qed
qed

lemma c_ball_center_in:
  assumes "is_ball B"
  assumes "B = B\<^bsub>n\<^esub>[c]"
  assumes "c \<in> carrier Q\<^sub>p"
  shows "c \<in> B"
  using assms  unfolding c_ball_def
  by (metis (no_types, lifting) Qp.r_right_minus_eq assms(2) c_ballI eint_ord_code(3) local.val_zero)

text \<open>Every point a has a point b of distance exactly n away from it.\<close>
lemma dist_nonempty:
  assumes "a \<in> carrier Q\<^sub>p"
  shows "\<exists>b \<in> carrier Q\<^sub>p. val (b \<ominus> a) = eint n"
proof-
  obtain b where b_def: "b = (\<pp> [^] n) \<oplus> a"
    by simp
  have "val (b \<ominus>a) = n"
    using b_def assms
    by (metis (no_types, lifting) Qp.domain_axioms a_minus_def cring.cring_simprules(16)
        cring.cring_simprules(17) cring.cring_simprules(3) cring.cring_simprules(7)
        domain.axioms(1) ord_p_pow_int p_intpow_closed(1) p_intpow_closed(2) val_ord)
  then show ?thesis
    by (metis Qp.domain_axioms assms b_def cring.cring_simprules(1) domain.axioms(1) p_intpow_closed(1))
qed

lemma dist_nonempty':
  assumes "a \<in> carrier Q\<^sub>p"
  shows "\<exists>b \<in> carrier Q\<^sub>p. val (b \<ominus> a) = \<alpha>"
proof(cases "\<alpha> = \<infinity>")
  case True
  then have "val (a \<ominus> a) = \<alpha>"
    using assms
    by (metis Qp.r_right_minus_eq local.val_zero)
  then show ?thesis
    using assms
    by blast
next
  case False
  then obtain n where n_def: "eint n = \<alpha>"
    by blast
  then show ?thesis
    using assms dist_nonempty[of a n]
    by blast
qed

lemma ball_rad_0:
  assumes "is_ball B"
  assumes "B\<^bsub>m\<^esub>[c] \<subseteq> B\<^bsub>n\<^esub>[c]"
  assumes "c \<in> carrier Q\<^sub>p"
  shows "n \<le> m"
proof-
  obtain b where b_def: "b \<in> carrier Q\<^sub>p \<and> val (b \<ominus>c) = m"
    by (meson assms(3) dist_nonempty)
  then have "b \<in> B\<^bsub>n\<^esub>[c]"
    using assms c_ballI
    by auto

  then have "m \<ge> n"
    using Q\<^sub>p_def Zp_def b_def c_ballE(2) padic_integers_axioms
    by force
  then show ?thesis
    by (simp )
qed

lemma ball_rad:
  assumes "is_ball B"
  assumes "B = B\<^bsub>n\<^esub>[c]"
  assumes "B = B\<^bsub>m\<^esub>[c]"
  assumes "c \<in> carrier Q\<^sub>p"
  shows "n = m"
proof-
  have 0: "n \<ge>m"
    using assms ball_rad_0
    by (metis order_refl)
  have 1: "m \<ge>n"
    using assms ball_rad_0
    by (metis order_refl)
  show ?thesis
    using 0 1
    by auto
qed

definition radius :: "padic_number set \<Rightarrow> int" ("rad") where
"radius B = (SOME n. (\<exists>c \<in> carrier Q\<^sub>p . B = B\<^bsub>n\<^esub>[c]))"

lemma radius_of_ball:
  assumes "is_ball B"
  assumes "c \<in> B"
  shows "B = B\<^bsub>rad B\<^esub>[c]"
proof-
  obtain d m where d_m_def: "d \<in> carrier Q\<^sub>p \<and>  B = B\<^bsub>m\<^esub>[d]"
    using assms(1) is_ball_def
    by blast
  then have "B = B\<^bsub>m\<^esub>[c]"
    using assms(1) assms(2) c_ball_centers by blast
  then have "rad B = m"
  proof-
    have "\<exists>n. (\<exists>c \<in> carrier Q\<^sub>p . B = B\<^bsub>n\<^esub>[c])"
      using d_m_def by blast
    then have "(\<exists>c \<in> carrier Q\<^sub>p . B = B\<^bsub>rad B\<^esub>[c])"
      using radius_def[of B]
      by (smt someI_ex)
    then show ?thesis
      using radius_def ball_rad[of B m ]
      by (metis (mono_tags, lifting) \<open>B = B\<^bsub>m\<^esub>[c]\<close> assms(1) assms(2) c_ballE(1) c_ball_centers)
  qed
  then show ?thesis
    using \<open>B = B\<^bsub>m\<^esub>[c]\<close> by blast
qed

lemma ball_rad':
  assumes "is_ball B"
  assumes "B = B\<^bsub>n\<^esub>[c]"
  assumes "B = B\<^bsub>m\<^esub>[d]"
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "d \<in> carrier Q\<^sub>p"
  shows "n = m"
  by (metis assms(1) assms(2) assms(3) assms(4) assms(5) ball_rad c_ball_center_in c_ball_centers)

lemma nested_balls:
  assumes "is_ball B"
  assumes "B = B\<^bsub>n\<^esub>[c]"
  assumes "B' = B\<^bsub>m\<^esub>[c]"
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "d \<in> carrier Q\<^sub>p"
  shows "n \<ge>m \<longleftrightarrow> B \<subseteq> B'"
proof
  show "m \<le> n \<Longrightarrow> B \<subseteq> B'"
  proof
    assume A0: "m \<le>n"
    then have A0': "m \<le> n"
      by (simp add: )
    fix x
    assume A1: "x \<in> B"
    show "x \<in> B'"
      using assms c_ballI[of x m c] A0' A1 c_ballE(2)[of x n c]  c_ball_in_Qp
      by (meson c_ballE(1) dual_order.trans eint_ord_simps(1))
  qed
  show "B \<subseteq> B' \<Longrightarrow> m \<le> n"
    using assms(1) assms(2) assms(3) assms(4) ball_rad_0
    by blast
qed

lemma nested_balls':
  assumes "is_ball B"
  assumes "is_ball B'"
  assumes "B \<inter> B' \<noteq> {}"
  shows "B \<subseteq> B' \<or> B' \<subseteq> B"
proof-
  obtain b where b_def: "b \<in> B \<inter> B'"
    using assms(3) by blast
  show "B \<subseteq> B' \<or> B' \<subseteq> B"
  proof-
    have "\<not> B \<subseteq> B' \<Longrightarrow> B' \<subseteq> B"
    proof-
      assume A: "\<not> B \<subseteq> B' "
      have 0: "B = B\<^bsub>rad B\<^esub>[b]"
        using assms(1) b_def radius_of_ball by auto
      have 1: "B' = B\<^bsub>rad B'\<^esub>[b]"
        using assms(2) b_def radius_of_ball by auto
      show "B' \<subseteq> B" using 0 1 A nested_balls
        by (smt IntD2 Q\<^sub>p_def Zp_def assms(1) assms(2) b_def
            c_ballE(1) padic_integers_axioms)
    qed
    then show ?thesis by blast
  qed
qed

definition is_bounded:: "padic_number set \<Rightarrow> bool" where
"is_bounded S = (\<exists>n. \<exists>c \<in> carrier Q\<^sub>p. S \<subseteq> B\<^bsub>n\<^esub>[c] )"

lemma empty_is_bounded:
"is_bounded {}"
  unfolding is_bounded_def
  by blast

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>$p$-adic Open Sets\<close>
(**************************************************************************************************)
(**************************************************************************************************)

definition is_open:: "padic_number set \<Rightarrow> bool" where
"is_open U \<equiv> (U \<subseteq> carrier Q\<^sub>p) \<and> (\<forall>c \<in> U. \<exists>n. B\<^bsub>n\<^esub>[c]\<subseteq> U )"

lemma is_openI:
  assumes "U \<subseteq>carrier Q\<^sub>p"
  assumes "\<And>c. c \<in> U \<Longrightarrow> \<exists>n. B\<^bsub>n\<^esub>[c]\<subseteq> U"
  shows "is_open U"
  by (simp add: assms(1) assms(2) is_open_def)

lemma ball_is_open:
  assumes "is_ball B"
  shows "is_open B"
  by (metis (mono_tags, lifting) assms is_ball_imp_in_Qp is_open_def radius_of_ball subset_iff)

lemma is_open_imp_in_Qp:
  assumes "is_open U"
  shows "U \<subseteq> carrier Q\<^sub>p"
  using assms unfolding is_open_def
  by linarith

lemma is_open_imp_in_Qp':
  assumes "is_open U"
  assumes " x \<in> U"
  shows "x \<in> carrier Q\<^sub>p"
  using assms(1) assms(2) is_open_imp_in_Qp
  by blast

text\<open>
  Owing to the total disconnectedness of the $p$-adic field, every open set can be decomposed
  into a disjoint union of balls which are maximal with respect to containment in that set.
  This unique decomposition is occasionally useful.
\<close>

definition is_max_ball_of ::"padic_number set \<Rightarrow> padic_number set  \<Rightarrow> bool" where
"is_max_ball_of U B \<equiv> (is_ball B) \<and> (B \<subseteq> U) \<and> (\<forall>B'. ((is_ball B') \<and> (B' \<subseteq> U) \<and> B \<subseteq> B') \<longrightarrow> B' \<subseteq> B)"

lemma is_max_ball_ofI:
  assumes "U \<subseteq> carrier Q\<^sub>p"
  assumes "(B\<^bsub>m\<^esub>[c]) \<subseteq> U"
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "\<forall>m'. m' < m \<longrightarrow> \<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
  shows "is_max_ball_of U (B\<^bsub>m\<^esub>[c])"
proof(rule ccontr)
  assume " \<not> is_max_ball_of U B\<^bsub>m\<^esub>[c]"
  then have "\<not> (\<forall>B'. is_ball B' \<and> B' \<subseteq> U \<and> B\<^bsub>m\<^esub>[c] \<subseteq> B'\<longrightarrow> B' \<subseteq> B\<^bsub>m\<^esub>[c])"
    using assms is_max_ball_of_def[of U "B\<^bsub>m\<^esub>[c]" ]
    unfolding is_ball_def
    by blast
  then obtain B' where B'_def: "is_ball B' \<and> B' \<subseteq> U \<and> B\<^bsub>m\<^esub>[c] \<subseteq> B' \<and> \<not> B' \<subseteq> B\<^bsub>m\<^esub>[c]"
  by auto
  obtain n where n_def: "B' = B\<^bsub>n\<^esub>[c]"
    by (meson B'_def assms(3) c_ball_center_in is_ball_def radius_of_ball subset_iff)
  then show False
    using assms
    by (smt B'_def Q\<^sub>p_def Zp_def ball_rad_0 padic_integers_axioms)
qed

lemma int_prop:
  fixes P:: "int \<Rightarrow> bool"
  assumes "P n"
  assumes "\<forall>m. m \<le>N \<longrightarrow> \<not> P m"
  shows  "\<exists>n. P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge>n)"
proof-
  have "n > N"
    by (meson assms(1) assms(2) not_less)
  obtain k::nat  where k_def: "k = nat (n - N)"
    by blast
  obtain l::nat where l_def: "l = (LEAST M.  P (N + int M))"
    by simp
  have 0: " P (N + int l)"
    by (metis (full_types) LeastI \<open>N < n\<close> assms(1) l_def zless_iff_Suc_zadd)
  have 1: "l > 0"
    using "0" assms(2) of_nat_0_less_iff by fastforce
  have 2: "\<And>M. M < l \<longrightarrow> \<not> P (N + M)"
    by (metis Least_le l_def less_le_trans nat_less_le)
  obtain n where n_def: "n = (N + int l)"
    by simp
  have "P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge> n)"
  proof-
    have "P n"
      by (simp add: "0" n_def)
    have "(\<forall>n'. P n'\<longrightarrow> n' \<ge> n)"
    proof
      fix n'
      show "P n' \<longrightarrow> n \<le> n'"
      proof
        assume "P n'"
        show  "n \<le>n'"
        proof(rule ccontr)
          assume " \<not> n \<le> n'"
          then have C: "n' < n"
            by auto
          show "False"
          proof(cases "n' \<ge> N")
            case True
            obtain M where M_def: "nat (n' - N) = M"
              by simp
            then have M0: "n' = N + int M "
              using True by linarith
            have M1: "M < l"
              using n_def C M0
              by linarith
            then show ?thesis using 2 M_def M0 M1
              using \<open>P n'\<close> by auto
          next
            case False
            then show ?thesis using assms
              using \<open>P n'\<close> by auto
          qed
        qed
      qed
    qed
    then show ?thesis
      using \<open>P n\<close> by blast
  qed
  then show ?thesis by blast
qed

lemma open_max_ball:
  assumes  "is_open U"
  assumes  "U \<noteq> carrier Q\<^sub>p"
  assumes "c \<in> U"
  shows "\<exists>B. is_max_ball_of U B \<and> c \<in> B"
proof-
  obtain B where B_def: "is_ball B \<and> B \<subseteq> U \<and> c \<in> B"
    by (meson assms(1) assms(3) c_ball_center_in is_ball_def is_open_imp_in_Qp' is_open_def padic_integers_axioms)
  show P: "\<exists>B. is_max_ball_of U B \<and> c \<in> B"
  proof(rule ccontr)
    assume C: "\<nexists>B. is_max_ball_of U B \<and> c \<in> B"
    show False
    proof-
      have C': "\<forall>B. c \<in> B \<longrightarrow> \<not>  is_max_ball_of U B "
        using C
        by auto
      have C'': "\<forall>N. \<exists>m <N. B\<^bsub>m\<^esub>[c] \<subseteq> U "
      proof
        fix N
        show "\<exists>m<N. B\<^bsub>m\<^esub>[c] \<subseteq> U"
        proof(rule  ccontr)
          assume A: "\<not> (\<exists>m<N. B\<^bsub>m\<^esub>[c] \<subseteq> U)"
          obtain P where P_def: "P = (\<lambda> n. \<exists>m<n. B\<^bsub>m\<^esub>[c] \<subseteq> U)"
            by simp
          have A0: "\<exists>n. P n"
            by (metis B_def P_def gt_ex radius_of_ball)
          have A1: "\<forall>m. m \<le>N \<longrightarrow> \<not> P m"
            using A P_def by auto
          have A2: "\<exists>n. P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge>n)"
            using A0 A1 int_prop
            by auto
          obtain n where n_def: " P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge>n)"
            using A2 by blast
          have " B\<^bsub>n\<^esub>[c] \<subseteq> U"
            by (smt B_def P_def c_ball_def is_ball_def mem_Collect_eq n_def nested_balls order_trans)
          obtain m where m_def: "m < n \<and>B\<^bsub>m\<^esub>[c] \<subseteq> U"
            using P_def n_def by blast
          have "m = n-1"
          proof-
            have "P (m +1)"
              using P_def m_def
              by auto
            then have "m + 1 \<ge> n"
              using n_def by blast
            then show ?thesis using m_def by auto
          qed
          have "\<forall>m'. m' < m \<longrightarrow> \<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
          proof
            fix m'
            show " m' < m \<longrightarrow> \<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
            proof
              assume "m' < m"
              show "\<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
              proof
                assume "B\<^bsub>m'\<^esub>[c] \<subseteq> U"
                then have "P (m' + 1)"
                  using P_def by auto
                have "m'+ 1 < n"
                  using \<open>m = n - 1\<close> \<open>m' < m\<close> by linarith
                then show False
                  using n_def \<open>P (m' + 1)\<close> by auto
              qed
            qed
          qed
          then have "is_max_ball_of U B\<^bsub>m\<^esub>[c]"
            using is_max_ball_ofI  assms(1) assms(3) is_open_imp_in_Qp is_open_imp_in_Qp' m_def
            by presburger
          then show False
            using C assms(1) assms(3) c_ball_center_in is_open_imp_in_Qp'
              is_max_ball_of_def padic_integers_axioms
            by blast
        qed
      qed
      have "U = carrier Q\<^sub>p"
      proof
        show "carrier Q\<^sub>p \<subseteq> U"
        proof
          fix x
          assume "x \<in> carrier Q\<^sub>p"
          show "x \<in> U"
          proof(cases "x = c")
            case True
            then show ?thesis using assms by auto
          next
            case False
            obtain m where m_def: "eint m = val(x \<ominus> c)"
              using False
              by (metis (no_types, opaque_lifting) Qp_diff_diff Qp.domain_axioms \<open>x \<in> carrier Q\<^sub>p\<close> a_minus_def
                  assms(1) assms(3) cring.cring_simprules(16) cring.cring_simprules(17)
                  cring.cring_simprules(4) domain.axioms(1) is_open_imp_in_Qp' val_def val_minus)
            obtain m' where m'_def: "m' < m \<and>  B\<^bsub>m'\<^esub>[c] \<subseteq> U "
              using C''
              by blast
            have "val (x \<ominus> c) \<ge> m'"
              by (metis eint_ord_simps(1) less_imp_le m'_def m_def)
            then have "x \<in> B\<^bsub>m'\<^esub>[c]"
              using \<open>x \<in> carrier Q\<^sub>p\<close> c_ballI by blast
            then show "x \<in> U"
              using m'_def by blast
          qed
        qed
        show "U \<subseteq> carrier Q\<^sub>p "
          using assms
          by (simp add: is_open_imp_in_Qp)
      qed
      then show False using assms by auto
    qed
  qed
qed

definition interior where
  "interior U = {a. \<exists>B. is_open B \<and> B \<subseteq> U \<and> a \<in> B}"

lemma interior_subset:
  assumes "U \<subseteq> carrier Q\<^sub>p"
  shows "interior U \<subseteq> U"
proof
  fix x
  assume "x \<in> interior U"
  show "x \<in> U"
  proof-
    obtain B where B_def: "is_open B \<and> B \<subseteq> U \<and> x \<in> B"
      using \<open>x \<in> interior U\<close> interior_def
      by auto
    then show "x \<in> U"
      by blast
  qed
qed

lemma interior_open:
  assumes "U \<subseteq> carrier Q\<^sub>p"
  shows "is_open (interior U)"
proof(rule is_openI)
  show "interior U \<subseteq> carrier Q\<^sub>p"
    using assms interior_subset by blast
  show "\<And>c. c \<in> interior U \<Longrightarrow> \<exists>n. B\<^bsub>n\<^esub>[c] \<subseteq> interior U"
  proof-
    fix c
    assume "c \<in> interior U"
    show "\<exists>n. B\<^bsub>n\<^esub>[c] \<subseteq> interior U"
    proof-
    obtain B where B_def: "is_open B \<and> B \<subseteq> U \<and> c \<in> B"
      using \<open>c \<in> interior U\<close> interior_def padic_integers_axioms
      by auto
    then show ?thesis
    proof -
      obtain ii :: "((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set \<Rightarrow> ((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set set \<Rightarrow> int"
        where
        "B\<^bsub>ii c B\<^esub>[c] \<subseteq> B"
        by (meson B_def is_open_def)
      then show ?thesis
        using B_def interior_def padic_integers_axioms by auto
qed
  qed
  qed
qed

lemma interiorI:
  assumes "W \<subseteq> U"
  assumes "is_open W"
  shows "W \<subseteq> interior U"
  using assms(1) assms(2) interior_def by blast

lemma max_ball_interior:
  assumes "U \<subseteq> carrier Q\<^sub>p"
  assumes "is_max_ball_of (interior U) B"
  shows "is_max_ball_of U B"
proof(rule ccontr)
  assume C: " \<not> is_max_ball_of U B"
  then obtain B' where B'_def: "is_ball B' \<and> B' \<subseteq> U \<and> B \<subseteq> B' \<and> B \<noteq> B'"
    by (metis (no_types, lifting) assms(1) assms(2) dual_order.trans
        interior_subset is_max_ball_of_def )
  then have "B' \<subseteq> interior U"
    using interior_def padic_integers_axioms ball_is_open
    by auto
  then show False using assms B'_def is_max_ball_of_def[of "interior U" "B"]
    by blast
qed

lemma ball_in_max_ball:
  assumes  "U \<subseteq> carrier Q\<^sub>p"
  assumes  "U \<noteq> carrier Q\<^sub>p"
  assumes "c \<in> U"
  assumes "\<exists>B. B \<subseteq> U \<and> is_ball B \<and> c \<in> B"
  shows "\<exists>B'. is_max_ball_of U B' \<and> c \<in> B'"
proof-
  obtain B where " B \<subseteq> U \<and> is_ball B \<and> c \<in> B"
    using assms(4)
    by blast
  then have 0: "B \<subseteq> interior U"
    using ball_is_open interior_def by blast
  have 1: "c \<in> interior U"
    using "0" \<open>B \<subseteq> U \<and> is_ball B \<and> c \<in> B\<close> by blast
  then have "\<exists>B'. is_max_ball_of (interior U) B' \<and> c \<in> B'"
    using open_max_ball[of "interior U" c] assms(1) assms(2) interior_open interior_subset
    by blast
  then show ?thesis
    using assms(1) max_ball_interior
    by blast
qed

lemma ball_in_max_ball':
  assumes  "U \<subseteq> carrier Q\<^sub>p"
  assumes  "U \<noteq> carrier Q\<^sub>p"
  assumes "B \<subseteq> U \<and> is_ball B"
  shows "\<exists>B'. is_max_ball_of U B' \<and> B \<subseteq> B'"
proof-
  obtain c where c_def: "c \<in> B"
    by (metis assms(3) c_ball_center_in is_ball_def)
  obtain B' where B'_def: " is_max_ball_of U B' \<and> c \<in> B'"
    using assms ball_in_max_ball[of U c] c_def
    by blast
  then show ?thesis
    by (meson assms(3) c_def disjoint_iff_not_equal nested_balls'
        is_max_ball_of_def padic_integers_axioms)
qed

lemma max_balls_disjoint:
  assumes "U \<subseteq> carrier Q\<^sub>p"
  assumes "is_max_ball_of U B"
  assumes "is_max_ball_of U B'"
  assumes "B \<noteq>B'"
  shows "B \<inter> B' = {}"
  by (meson assms(2) assms(3) assms(4) nested_balls' is_max_ball_of_def
      padic_integers_axioms subset_antisym)

definition max_balls :: "padic_number set \<Rightarrow> padic_number set set" where
"max_balls U = {B. is_max_ball_of U B }"

lemma max_balls_interior:
  assumes "U \<subseteq> carrier Q\<^sub>p"
  assumes "U \<noteq> carrier Q\<^sub>p"
  shows "interior U = {x \<in> carrier Q\<^sub>p. (\<exists>B \<in> (max_balls U). x \<in> B)}"
proof
  show "interior U \<subseteq> {x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B}"
  proof
    fix x
    assume A: " x \<in> interior U"
    show "x \<in> {x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B}"
      by (metis (mono_tags, lifting) A assms(1) assms(2) interior_open
          interior_subset is_open_imp_in_Qp' max_ball_interior max_balls_def
          mem_Collect_eq open_max_ball subset_antisym)
  qed
  show "{x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B} \<subseteq> interior U"
  proof
    fix x
    assume A: " x \<in> {x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B} "
    show "x \<in> interior U"
    proof-
      obtain B where B_def: "B\<in>max_balls U \<and> x \<in> B"
        using A by blast
      then have "B \<subseteq> interior U"
        by (metis (no_types, lifting) interior_def is_max_ball_of_def mem_Collect_eq
            ball_is_open max_balls_def subsetI)
      then show ?thesis
        using B_def by blast
    qed
  qed
qed

lemma max_balls_interior':
  assumes "U \<subseteq> carrier Q\<^sub>p"
  assumes "U \<noteq> carrier Q\<^sub>p"
  assumes "B \<in> max_balls U"
  shows "B \<subseteq> interior U"
  using assms(1) assms(2) assms(3) is_max_ball_of_def max_balls_interior
        max_balls_def padic_integers_axioms
  by auto

lemma max_balls_interior'':
  assumes "U \<subseteq> carrier Q\<^sub>p"
  assumes "U \<noteq> carrier Q\<^sub>p"
  assumes "a \<in> interior U"
  shows "\<exists>B \<in> max_balls U. a \<in> B"
  using assms(1) assms(2) assms(3) max_balls_interior
  by blast

lemma open_interior:
  assumes "is_open U"
  shows "interior U = U"
  unfolding interior_def using assms
  by blast

lemma interior_idempotent:
  assumes "U \<subseteq> carrier Q\<^sub>p"
  shows "interior (interior U) = interior U"
  using assms interior_open[of U] open_interior[of "interior U"]
  by auto

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>Convex Subsets of the Value Group\<close>
(**************************************************************************************************)
(**************************************************************************************************)

text\<open>
  The content of this section will be useful for defining and reasoning about $p$-adic cells in the
  proof of Macintyre's theorem. It is proved that every convex set in the extended integers is
  either an open ray, a closed ray, a closed interval, or a left-closed interval.\<close>

definition is_convex :: "eint set \<Rightarrow> bool" where
"is_convex A = (\<forall> x \<in> A. \<forall>y \<in> A. \<forall>c. x \<le> c \<and> c \<le> y \<longrightarrow> c \<in> A)"

lemma is_convexI:
  assumes "\<And>x y c. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> c \<and> c \<le>y \<Longrightarrow> c \<in> A"
  shows "is_convex  A"
  unfolding is_convex_def
  using assms
  by blast

lemma is_convexE:
  assumes "is_convex A"
  assumes "x \<in> A"
  assumes "y \<in> A"
  assumes "x \<le> a"
  assumes "a \<le> y"
  shows "a \<in> A"
  using assms is_convex_def
  by blast

lemma empty_convex:
"is_convex {}"
  apply(rule is_convexI)
  by blast

lemma UNIV_convex:
"is_convex UNIV"
  apply(rule is_convexI)
  by blast

definition closed_interval ("I[_ _]") where
  "closed_interval \<alpha> \<beta> = {a . \<alpha> \<le> a \<and>  a \<le> \<beta>}"

lemma closed_interval_is_convex:
  assumes "A = closed_interval \<alpha> \<beta>"
  shows "is_convex A"
  apply(rule is_convexI)
  using assms unfolding closed_interval_def
  by auto

lemma empty_closed_interval:
"{} = closed_interval \<infinity> (eint 1)"
  unfolding closed_interval_def
  by auto

definition left_closed_interval  where
"left_closed_interval \<alpha> \<beta> = {a . \<alpha> \<le>  a \<and>  a < \<beta>}"

lemma left_closed_interval_is_convex:
  assumes "A = left_closed_interval \<alpha> \<beta>"
  shows "is_convex A"
  apply(rule is_convexI)
  using assms unfolding left_closed_interval_def
  using leD order.trans by auto

definition closed_ray where
"closed_ray \<alpha> \<beta>  = {a .   a \<le> \<beta> }"

lemma closed_ray_is_convex:
  assumes "A = closed_ray \<alpha> \<beta>"
  shows "is_convex A"
  apply(rule is_convexI)
  using assms unfolding closed_ray_def
  by auto

lemma UNIV_closed_ray:
"(UNIV::eint set)= closed_ray \<alpha> \<infinity>"
  unfolding closed_ray_def
  by simp

definition open_ray :: "eint \<Rightarrow> eint \<Rightarrow> eint set" where
"open_ray \<alpha> \<beta>  = {a .   a < \<beta> }"

lemma open_ray_is_convex:
  assumes "A = open_ray \<alpha> \<beta>"
  shows "is_convex A"
  apply(rule is_convexI)
  using assms unfolding open_ray_def
  using leD by auto

lemma open_rayE:
  assumes "a < \<beta>"
  shows "a \<in> open_ray \<alpha> \<beta>"
  unfolding open_ray_def using assms
  by blast

lemma value_group_is_open_ray:
"UNIV - {\<infinity>} = open_ray \<alpha> \<infinity>"
proof
  show "UNIV - {\<infinity>} \<subseteq> open_ray \<alpha> \<infinity>"
    using open_rayE[of _ \<alpha> "\<infinity>"]
    by (simp add: open_rayE subset_eq)
  show "open_ray \<alpha> \<infinity> \<subseteq> UNIV - {\<infinity>}"
    unfolding open_ray_def
    by blast
qed

text\<open>
  This is a predicate which identifies a certain kind of set-valued function on the extended
  integers. Convex conditions will be important in the definition of $p$-adic cells later, and
  it will be proved that every convex set is induced by a convex condition.\<close>
definition is_convex_condition :: "(eint \<Rightarrow> eint \<Rightarrow> eint set) \<Rightarrow> bool"
  where "is_convex_condition I \<equiv>
              I = closed_interval \<or> I = left_closed_interval \<or> I = closed_ray \<or> I = open_ray"

lemma convex_condition_imp_convex:
  assumes "is_convex_condition I"
  shows "is_convex (I \<alpha> \<beta>)"
  using assms
  unfolding is_convex_condition_def
  by (meson closed_interval_is_convex closed_ray_is_convex left_closed_interval_is_convex open_ray_is_convex)

lemma bounded_order:
  assumes "(a::eint) < \<infinity>"
  assumes  "b \<le>  a"
  obtains k::nat where  "a = b + k"
proof-
  obtain m::int where m_def: "a = m"
    using assms(1) less_infinityE by blast
  obtain n::int where n_def: "b = n"
    using assms(2) eint_ile m_def by blast
  have 0: "a - b =  eint (m - n)"
    by (simp add: m_def n_def)
  then have "a = b + nat (m - n)"
    using assms m_def n_def
    by simp
  thus ?thesis
    using that by blast
qed

text\<open>Every convex set is given by a convex condition\<close>
lemma convex_imp_convex_condition:
  assumes "is_convex A"
  shows "\<exists> I \<alpha> \<beta>. is_convex_condition I \<and> A = (I \<alpha> \<beta>)"
proof(cases "\<exists> a \<in> A. \<forall> b \<in> A. a \<le> b")
  case True
  then obtain \<alpha> where alpha_def: "\<alpha> \<in> A \<and> (\<forall> b \<in> A. \<alpha> \<le> b)"
    by blast
  then show ?thesis
  proof(cases "\<exists> a \<in> A. \<forall> b \<in> A. b \<le> a")
    case True
    then obtain \<beta> where beta_def: "\<beta> \<in> A \<and> (\<forall> b \<in> A. b \<le> \<beta>)"
      by blast
    have "A = closed_interval \<alpha> \<beta>"
      unfolding closed_interval_def
      using alpha_def beta_def assms is_convexE[of A \<alpha> \<beta>]
      by blast
    then show ?thesis
      using is_convex_condition_def
      by blast
  next
    case False
    have F0: "\<forall>a. \<alpha> \<le> a \<and> a < \<infinity> \<longrightarrow> a \<in> A"
    proof(rule ccontr)
      assume A: "\<not> (\<forall>a. a \<ge> \<alpha> \<and> a < \<infinity> \<longrightarrow> a \<in> A)"
      then obtain a where a_def: " \<alpha> \<le> a \<and> a < \<infinity> \<and> a \<notin> A"
        by blast
      obtain n where n_def: "\<alpha> = eint n"
        using False alpha_def by force
      obtain m where m_def: "a = eint m"
        using a_def less_infinityE by blast
      have "\<forall>k::nat. \<exists>c. (\<alpha> + eint (int k)) < c \<and> c \<in> A"
      proof fix k
        show "\<exists>c>\<alpha> + eint (int k). c \<in> A"
          apply(induction k)
           using False alpha_def le_less_linear zero_eint_def apply fastforce
        proof- fix k
          assume IH: "\<exists>c>\<alpha> + eint (int k). c \<in> A"
          then obtain c where c_def: "c>\<alpha> + eint (int k) \<and> c \<in> A"
            by blast
          then obtain c' where c'_def: "c' \<in> A \<and> c < c'"
            using False
            by (meson le_less_linear)
          then have "(\<alpha> + eint (int (Suc k))) \<le> c'"
          proof-
            have 0: "eint (int (Suc k)) = eint (int k) + eint 1"
              by simp
            have "\<alpha> + eint (int k) \<le>c'"
              by (meson c'_def c_def le_less le_less_trans)
            then have 1: "(\<alpha> + eint (int k)) < c'"
              using c'_def c_def le_less_trans
              by auto
            have 2: "\<alpha> + eint (int k) + eint 1 = \<alpha> + eint (int (Suc k))"
              using 0
              by (simp add: n_def)
            then show "(\<alpha> + eint (int (Suc k))) \<le> c'"
              by (metis "1" ileI1 one_eint_def)
          qed
          then show "\<exists>c>\<alpha> + eint (int (Suc k)). c \<in> A"
            using False c'_def not_less by fastforce
        qed
      qed
      obtain k where k_def: "k = a - \<alpha>"
        using a_def n_def
        by blast
      hence "k \<ge> 0"
        using a_def n_def
        by (metis alpha_def eint_minus_le le_less)
      hence 0: "\<exists>n::nat. k = n"
        using a_def n_def  k_def
        by (metis eint.distinct(2) eint_0_iff(2) eint_add_cancel_fact eint_ord_simps(1) fromeint.cases m_def nonneg_int_cases plus_eint_simps(3))
      have 1: "a = \<alpha> + k"
        using k_def a_def n_def
        by simp
      then obtain c where "c \<in> A \<and> a < c"
        by (metis "0" \<open>\<forall>k. \<exists>c>\<alpha> + eint (int k). c \<in> A\<close> the_eint.simps)
      then have "a \<in> A"
        using is_convexE[of A \<alpha> a c] a_def alpha_def assms is_convexE
        by (meson linear not_less)
      then show False
        using a_def by blast
    qed
    have "A = closed_interval \<alpha>  \<infinity> \<or> A = left_closed_interval \<alpha> \<infinity>"
      apply(cases "\<infinity> \<in> A")
      using False eint_ord_code(3) apply blast
    proof-
      assume A0: "\<infinity> \<notin> A "
      have "A = left_closed_interval \<alpha> \<infinity>"
      proof
        show "A \<subseteq> left_closed_interval \<alpha> \<infinity>"
          unfolding left_closed_interval_def
          using alpha_def A0
          by (metis (mono_tags, lifting) False eint_ord_code(3) le_less_linear less_le_trans mem_Collect_eq subsetI)
        show "left_closed_interval \<alpha> \<infinity> \<subseteq> A"
          unfolding left_closed_interval_def
          using alpha_def A0 F0
          by blast
      qed
      then show ?thesis
        by blast
    qed
    then show ?thesis
      unfolding is_convex_condition_def
      by blast
  qed
next
  case False
  show ?thesis apply(cases "A = {}")
    using empty_closed_interval is_convex_condition_def apply blast
  proof-
    assume A0: "A \<noteq> {}"
    have "A \<noteq> {\<infinity>}"
      using False
      by blast
    then obtain \<alpha> where alpha_def: "\<alpha> \<in> A \<and> \<alpha> \<noteq>\<infinity>"
      using A0
      by fastforce
    have A1: "\<And>k::nat. \<exists> b \<in> A. b + eint (int k) \<le> \<alpha>"
    proof- fix k
      show " \<exists> b \<in> A. b + eint (int k) \<le> \<alpha>"
      proof(induction k)
        case 0
        then have "\<alpha> + eint (int 0) = \<alpha>"
          by (simp add: zero_eint_def)
        then show ?case
          using alpha_def by auto
      next
        case (Suc k) fix k
        assume IH: "\<exists>b\<in>A. \<alpha> \<ge> b + eint (int k)"
        show "\<exists>b\<in>A. \<alpha> \<ge> b + eint (int (Suc k))"
        proof-
          obtain b where b_def: "b \<in> A \<and> \<alpha> \<ge> b + eint (int k)"
            using IH by blast
          then obtain c where c_def: "c \<in> A \<and> c < b"
            using False le_less_linear by blast
          have 0: "(c + eint (int (Suc k))) < (b + eint (int (Suc k)))"
            using c_def
            by simp
          have 1: "b + eint (int (Suc k)) =  (b + eint (int k)) + eint 1"
            by simp
          then show ?thesis
            by (metis "0" b_def c_def eSuc_ile_mono ileI1 le_less one_eint_def)
        qed
      qed
    qed
    show ?thesis
    proof(cases "\<exists> a \<in> A. \<forall> b \<in> A. b \<le> a")
      case True
      then obtain \<beta> where beta_def: "\<beta> \<in> A \<and> (\<forall> b \<in> A. b \<le> \<beta>)"
        by blast
      have "A = closed_ray \<alpha> \<beta>"
        unfolding closed_ray_def
      proof
        show "A \<subseteq> {a. \<beta> \<ge> a}"
          using assms beta_def
          by blast
        show "{a. \<beta> \<ge> a} \<subseteq> A"
        proof fix x assume "x \<in> {a. \<beta> \<ge> a}"
          then have 0: "\<beta> \<ge> x" by blast
          show "x \<in> A"
          proof(cases "x \<le> \<alpha>")
            case True
            obtain n where n_def: "\<alpha>= eint n"
              using alpha_def
              by blast
            obtain m where m_def: "x = eint m"
              using True eint_ile n_def by blast
            have 1: "m \<le> n"
              using  True m_def n_def
              by simp
            have 2: "eint (int (nat (n - m))) = eint (n - m)"
              by (simp add: "1")
            then obtain b where b_def: "b \<in> A \<and> b + eint (n - m) \<le> \<alpha>"
              using  A1[of "nat (n - m)"]
              by (metis)
            then have "b + eint (n - m) \<le> x + eint (n - m)"
              using b_def
              by (simp add: m_def n_def)
            then have "b \<le> x"
              by auto
            then show ?thesis
              using "0" assms b_def beta_def is_convex_def
              by blast
          next
            case False
            then show ?thesis
              using "0" alpha_def assms beta_def is_convexE
              by (meson linear)
          qed
        qed
      qed
      then show ?thesis
        using is_convex_condition_def
        by blast
    next
      case f: False
      have F0: "\<forall>a. \<alpha> \<le> a \<and> a < \<infinity> \<longrightarrow> a \<in> A"
      proof(rule ccontr)
      assume A: "\<not> (\<forall>a. a \<ge> \<alpha> \<and> a < \<infinity> \<longrightarrow> a \<in> A)"
      then obtain a where a_def: " \<alpha> \<le> a \<and> a < \<infinity> \<and> a \<notin> A"
        by blast
      obtain n where n_def: "\<alpha> = eint n"
        using alpha_def by blast
      obtain m where m_def: "a = eint m"
        using a_def less_infinityE by blast
      have 0: "\<forall>k::nat. \<exists>c. (\<alpha> + eint (int k)) < c \<and> c \<in> A"
      proof fix k
        show "\<exists>c>\<alpha> + eint (int k). c \<in> A"
          apply(induction k)
           using alpha_def f le_less_linear apply fastforce
        proof- fix k
          assume IH: "\<exists>c>\<alpha> + eint (int k). c \<in> A"
          then obtain c where c_def: "c>\<alpha> + eint (int k) \<and> c \<in> A"
            by blast
          then obtain c' where c'_def: "c' \<in> A \<and> c < c'"
            using False f le_less_linear by blast
          then have "(\<alpha> + eint (int (Suc k))) \<le> c'"
          proof-
            have 0: "eint (int (Suc k)) = eint (int k) + eint 1"
              by simp
            have "\<alpha> + eint (int k) \<le>c'"
              using c_def c'_def dual_order.strict_trans le_less by blast
            then have 1: "(\<alpha> + eint (int k)) < c'"
              using c'_def c_def le_less_trans by auto
            have 2: "\<alpha> + eint (int k) + eint 1 = \<alpha> + eint (int (Suc k))"
              using 0 by (simp add: n_def)
            then show "(\<alpha> + eint (int (Suc k))) \<le> c'"
              by (metis "1" ileI1 one_eint_def)
          qed
          then show "\<exists>c>\<alpha> + eint (int (Suc k)). c \<in> A"
            using False c'_def
            by (smt c_def eSuc_eint iadd_Suc_right ileI1 le_less of_nat_Suc)
        qed
      qed
      obtain k::nat where "a = \<alpha> + eint (int k)"
        using bounded_order a_def
        by blast
      then obtain c where "c \<in> A \<and> a <c"
        using 0 by blast
      then have "a \<in> A"
        using is_convexE[of A \<alpha> a c] a_def alpha_def assms is_convexE
        by (meson linear not_less)
      then show False
        using a_def by blast
      qed
      have "A = UNIV - {\<infinity>}"
      proof
        show "A \<subseteq> UNIV - {\<infinity>}"
          using f by auto
        show "UNIV - {\<infinity>} \<subseteq> A"
        proof fix x ::eint
          assume A: "x \<in> UNIV - {\<infinity>}"
          show "x \<in> A"
          proof(cases "x \<le> \<alpha>")
            case True
            obtain k::nat where k_def: "x + k = \<alpha>"
              by (metis True alpha_def bounded_order eint_ord_simps(4))
            obtain c where c_def: "c \<in> A \<and> c + k = \<alpha>"
              by (metis A1 True add.commute alpha_def assms eint_add_left_cancel_le is_convexE k_def not_eint_eq)
            have "x = c"
              using k_def c_def
              by auto
            thus ?thesis
              by (simp add: c_def)
          next
            case False
            thus ?thesis
              using A F0 by auto
          qed
        qed
      qed
    then show ?thesis
      by (meson is_convex_condition_def value_group_is_open_ray)
   qed
 qed
qed

lemma ex_val_less:
  shows "\<exists> (\<alpha>::eint). \<alpha> < \<beta>"
  apply(induction \<beta>)
  using eint_ord_simps(2) lt_ex apply blast
  using eint_ord_simps(4) by blast

lemma ex_dist_less:
  assumes "c \<in> carrier Q\<^sub>p"
  shows "\<exists> a \<in> carrier Q\<^sub>p. val (a \<ominus> c) < \<beta>"
  using ex_val_less[of \<beta>] assms
  by (metis dist_nonempty' ex_val_less)
end
end


theory week03A_demo imports Main begin

-- ------------------------------------

text {* Quantifier reasoning *}

text{* A successful proof: *}
lemma "\<forall>a. \<exists>b. a = b"
  (*TODO*)
  apply (rule allI)
  apply (rule_tac x = "a" in exI)
  apply (rule refl)
  oops

text{* An unsuccessful proof: *}
lemma "\<exists>y. \<forall>x. x = y"
apply(rule exI)
apply(rule allI) thm refl
apply(rule refl)
  sorry

text{* Intro and elim reasoning: *}
lemma "\<exists>b. \<forall>a. P a b \<Longrightarrow> \<forall>a. \<exists>b. P a b"
 (* TODO *)
 (* the safe rules first! *)
 (* (check what happens if you use unsafe rule too early) *)
  apply(rule allI)
  apply(erule exE)
  apply(rule_tac x = "b" in exI)
  apply(erule_tac x = "a" in allE)
  apply assumption
  oops

text {* Instantiation in more detail: *}

text{* Instantiating allE: *}
lemma "\<forall>x. P x \<Longrightarrow> P 37"
  thm allE
  (*TODO*)
  apply (erule_tac x = "37" in allE)
  apply assumption
  done

text{* Instantiating exI: *}
lemma "\<exists>n. P (f n) \<Longrightarrow> \<exists>m. P m"
  apply (erule exE)
  apply (rule_tac x = "f n" in exI)
  apply assumption
  done

text{* Instantiation removes ambiguity: *}
lemma "\<lbrakk> A \<and> B; C \<and> D \<rbrakk> \<Longrightarrow> D"
apply(erule_tac P = "C" and Q="D" in conjE)
(* without instantiation, the wrong one is chosen (first) *)
apply assumption
done

text {* Instantiation with "where" and "of" *}

thm conjI
thm conjI [of "A" "B"]
thm conjI [where Q = "f x"]

-- ----------------------------------------------

text{* Renaming parameters: *}apply

lemma "\<And>x y z. P x y z"
apply(rename_tac a b)
oops

lemma "\<forall>x. P x \<Longrightarrow> \<forall>x. \<forall>x. P x"
apply(rule allI)
apply(rule allI)
apply(rename_tac y)
apply(erule_tac x=y in allE)
apply assumption
done

text {* Forward reasoning: drule/frule/OF/THEN*}

lemma "A \<and> B \<Longrightarrow> \<not> \<not> A"
thm conjunct1
apply (drule conjunct1)
apply (rule notI)
apply (erule notE)
apply assumption
done

lemma "\<forall>x. P x \<Longrightarrow> P t \<and> P t'"
  thm spec
  thm allE
(*TODO*)
  apply (frule_tac x = "t" in spec)
  apply (drule_tac x = "t'" in spec)
  apply (rule conjI)
   apply assumption
  apply assumption
  done

thm dvd_add dvd_refl
thm dvd_add [OF dvd_refl]
thm dvd_add [OF dvd_refl dvd_refl]

-- ---------------------------------------------

text {* Epsilon *}

lemma "(\<exists>x. P x) = P (SOME x. P x)"
(*TODO*)
  apply (rule iffI)
   apply (erule exE) thm someI
   apply (rule_tac x = "x" in someI)
   apply assumption
  apply (rule_tac x = "SOME x. P x" in exI)
  apply assumption
  oops

text {* Automation *}

lemma "\<forall>x y. P x y \<and> Q x y \<and> R x y"
apply (intro allI conjI)
oops

lemma "\<forall>x y. P x y \<and> Q x y \<and> R x y"
apply clarify
oops

lemma "\<forall>x y. P x y \<and> Q x y \<and> R x y"
apply safe
oops

lemma "\<exists>y. \<forall> x. P x y \<Longrightarrow> \<forall>x. \<exists>y. P x y"
apply blast
done

lemma "\<exists>y. \<forall>x. P x y \<Longrightarrow> \<forall>x. \<exists>y. P x y"
apply fast
done

-- ---------------------------------------------

text {* Exercises *}

-- "Quantifier scope is important:"
lemma "(\<forall>x. P x \<longrightarrow> Q) = ((\<exists>x. P x) \<longrightarrow> Q)"
  apply (rule iffI)
   apply (rule impI)
   apply (erule exE)
   apply (erule_tac x = "x" in allE)
   apply (erule impE)
    apply assumption
   apply assumption
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply (rule_tac x = "x" in exI)
   apply assumption
  apply assumption
  done

text {*
   Derive the axiom of choice from the SOME operator (using the rule someI), i.e.
   using only the rules: allI, allE, exI, exE and someI; with only the
   proof methods: rule, erule, rule_tac, erule_tac and assumption, prove:
*}

thm someI

lemma choice:
  "\<forall>x. \<exists>y. R x y \<Longrightarrow> \<exists> f. \<forall>x. R x (f x)"
  apply (rule classical)
  apply (rule_tac x = "f" in exI)
  apply (rule allI)
  apply (erule notE)
  apply simp
  apply (fast elim: someI)
  done

end


(*  Title:      HOL/ex/BinEx.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section \<open>Binary arithmetic examples\<close>

theory BinEx
imports Complex_Main
begin

subsection \<open>Regression Testing for Cancellation Simprocs\<close>

lemma "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = (uu::int)"
apply simp  oops

lemma "2*u = (u::int)"
apply simp  oops

lemma "(i + j + 12 + (k::int)) - 15 = y"
apply simp  oops

lemma "(i + j + 12 + (k::int)) - 5 = y"
apply simp  oops

lemma "y - b < (b::int)"
apply simp  oops

lemma "y - (3*b + c) < (b::int) - 2*c"
apply simp  oops

lemma "(2*x - (u*v) + y) - v*3*u = (w::int)"
apply simp  oops

lemma "(2*x*u*v + (u*v)*4 + y) - v*u*4 = (w::int)"
apply simp  oops

lemma "(2*x*u*v + (u*v)*4 + y) - v*u = (w::int)"
apply simp  oops

lemma "u*v - (x*u*v + (u*v)*4 + y) = (w::int)"
apply simp  oops

lemma "(i + j + 12 + (k::int)) = u + 15 + y"
apply simp  oops

lemma "(i + j*2 + 12 + (k::int)) = j + 5 + y"
apply simp  oops

lemma "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + (vv::int)"
apply simp  oops

lemma "a + -(b+c) + b = (d::int)"
apply simp  oops

lemma "a + -(b+c) - b = (d::int)"
apply simp  oops

(*negative numerals*)
lemma "(i + j + -2 + (k::int)) - (u + 5 + y) = zz"
apply simp  oops

lemma "(i + j + -3 + (k::int)) < u + 5 + y"
apply simp  oops

lemma "(i + j + 3 + (k::int)) < u + -6 + y"
apply simp  oops

lemma "(i + j + -12 + (k::int)) - 15 = y"
apply simp  oops

lemma "(i + j + 12 + (k::int)) - -15 = y"
apply simp  oops

lemma "(i + j + -12 + (k::int)) - -15 = y"
apply simp  oops

lemma "- (2*i) + 3  + (2*i + 4) = (0::int)"
apply simp  oops

(*Tobias's example dated 2015-03-02*)
lemma "(pi * (real u * 2) = pi * (real (xa v) * - 2))"
apply simp oops

subsection \<open>Arithmetic Method Tests\<close>

lemma "!!a::int. [| a <= b; c <= d; x+y<z |] ==> a+c <= b+d"
by arith

lemma "!!a::int. [| a < b; c < d |] ==> a-d+ 2 <= b+(-c)"
by arith

lemma "!!a::int. [| a < b; c < d |] ==> a+c+ 1 < b+d"
by arith

lemma "!!a::int. [| a <= b; b+b <= c |] ==> a+a <= c"
by arith

lemma "!!a::int. [| a+b <= i+j; a<=b; i<=j |] ==> a+a <= j+j"
by arith

lemma "!!a::int. [| a+b < i+j; a<b; i<j |] ==> a+a - - (- 1) < j+j - 3"
by arith

lemma "!!a::int. a+b+c <= i+j+k & a<=b & b<=c & i<=j & j<=k --> a+a+a <= k+k+k"
by arith

lemma "!!a::int. [| a+b+c+d <= i+j+k+l; a<=b; b<=c; c<=d; i<=j; j<=k; k<=l |]
      ==> a <= l"
by arith

lemma "!!a::int. [| a+b+c+d <= i+j+k+l; a<=b; b<=c; c<=d; i<=j; j<=k; k<=l |]
      ==> a+a+a+a <= l+l+l+l"
by arith

lemma "!!a::int. [| a+b+c+d <= i+j+k+l; a<=b; b<=c; c<=d; i<=j; j<=k; k<=l |]
      ==> a+a+a+a+a <= l+l+l+l+i"
by arith

lemma "!!a::int. [| a+b+c+d <= i+j+k+l; a<=b; b<=c; c<=d; i<=j; j<=k; k<=l |]
      ==> a+a+a+a+a+a <= l+l+l+l+i+l"
by arith

lemma "!!a::int. [| a+b+c+d <= i+j+k+l; a<=b; b<=c; c<=d; i<=j; j<=k; k<=l |]
      ==> 6*a <= 5*l+i"
by arith

subsection \<open>The Integers\<close>

text \<open>Addition\<close>

lemma "(13::int) + 19 = 32"
  by simp

lemma "(1234::int) + 5678 = 6912"
  by simp

lemma "(1359::int) + -2468 = -1109"
  by simp

lemma "(93746::int) + -46375 = 47371"
  by simp

text \<open>\medskip Negation\<close>

lemma "- (65745::int) = -65745"
  by simp

lemma "- (-54321::int) = 54321"
  by simp

text \<open>\medskip Multiplication\<close>

lemma "(13::int) * 19 = 247"
  by simp

lemma "(-84::int) * 51 = -4284"
  by simp

lemma "(255::int) * 255 = 65025"
  by simp

lemma "(1359::int) * -2468 = -3354012"
  by simp

lemma "(89::int) * 10 \<noteq> 889"
  by simp

lemma "(13::int) < 18 - 4"
  by simp

lemma "(-345::int) < -242 + -100"
  by simp

lemma "(13557456::int) < 18678654"
  by simp

lemma "(999999::int) \<le> (1000001 + 1) - 2"
  by simp

lemma "(1234567::int) \<le> 1234567"
  by simp

text\<open>No integer overflow!\<close>
lemma "1234567 * (1234567::int) < 1234567*1234567*1234567"
  by simp

text \<open>\medskip Quotient and Remainder\<close>

lemma "(10::int) div 3 = 3"
  by simp

lemma "(10::int) mod 3 = 1"
  by simp

text \<open>A negative divisor\<close>

lemma "(10::int) div -3 = -4"
  by simp

lemma "(10::int) mod -3 = -2"
  by simp

text \<open>
  A negative dividend\footnote{The definition agrees with mathematical
  convention and with ML, but not with the hardware of most computers}
\<close>

lemma "(-10::int) div 3 = -4"
  by simp

lemma "(-10::int) mod 3 = 2"
  by simp

text \<open>A negative dividend \emph{and} divisor\<close>

lemma "(-10::int) div -3 = 3"
  by simp

lemma "(-10::int) mod -3 = -1"
  by simp

text \<open>A few bigger examples\<close>

lemma "(8452::int) mod 3 = 1"
  by simp

lemma "(59485::int) div 434 = 137"
  by simp

lemma "(1000006::int) mod 10 = 6"
  by simp

text \<open>\medskip Division by shifting\<close>

lemma "10000000 div 2 = (5000000::int)"
  by simp

lemma "10000001 mod 2 = (1::int)"
  by simp

lemma "10000055 div 32 = (312501::int)"
  by simp

lemma "10000055 mod 32 = (23::int)"
  by simp

lemma "100094 div 144 = (695::int)"
  by simp

lemma "100094 mod 144 = (14::int)"
  by simp

text \<open>\medskip Powers\<close>

lemma "2 ^ 10 = (1024::int)"
  by simp

lemma "(- 3) ^ 7 = (-2187::int)"
  by simp

lemma "13 ^ 7 = (62748517::int)"
  by simp

lemma "3 ^ 15 = (14348907::int)"
  by simp

lemma "(- 5) ^ 11 = (-48828125::int)"
  by simp

subsection \<open>The Natural Numbers\<close>

text \<open>Successor\<close>

lemma "Suc 99999 = 100000"
  by simp

text \<open>\medskip Addition\<close>

lemma "(13::nat) + 19 = 32"
  by simp

lemma "(1234::nat) + 5678 = 6912"
  by simp

lemma "(973646::nat) + 6475 = 980121"
  by simp

text \<open>\medskip Subtraction\<close>

lemma "(32::nat) - 14 = 18"
  by simp

lemma "(14::nat) - 15 = 0"
  by simp

lemma "(14::nat) - 1576644 = 0"
  by simp

lemma "(48273776::nat) - 3873737 = 44400039"
  by simp

text \<open>\medskip Multiplication\<close>

lemma "(12::nat) * 11 = 132"
  by simp

lemma "(647::nat) * 3643 = 2357021"
  by simp

text \<open>\medskip Quotient and Remainder\<close>

lemma "(10::nat) div 3 = 3"
  by simp

lemma "(10::nat) mod 3 = 1"
  by simp

lemma "(10000::nat) div 9 = 1111"
  by simp

lemma "(10000::nat) mod 9 = 1"
  by simp

lemma "(10000::nat) div 16 = 625"
  by simp

lemma "(10000::nat) mod 16 = 0"
  by simp

text \<open>\medskip Powers\<close>

lemma "2 ^ 12 = (4096::nat)"
  by simp

lemma "3 ^ 10 = (59049::nat)"
  by simp

lemma "12 ^ 7 = (35831808::nat)"
  by simp

lemma "3 ^ 14 = (4782969::nat)"
  by simp

lemma "5 ^ 11 = (48828125::nat)"
  by simp

text \<open>\medskip Testing the cancellation of complementary terms\<close>

lemma "y + (x + -x) = (0::int) + y"
  by simp

lemma "y + (-x + (- y + x)) = (0::int)"
  by simp

lemma "-x + (y + (- y + x)) = (0::int)"
  by simp

lemma "x + (x + (- x + (- x + (- y + - z)))) = (0::int) - y - z"
  by simp

lemma "x + x - x - x - y - z = (0::int) - y - z"
  by simp

lemma "x + y + z - (x + z) = y - (0::int)"
  by simp

lemma "x + (y + (y + (y + (-x + -x)))) = (0::int) + y - x + y + y"
  by simp

lemma "x + (y + (y + (y + (-y + -x)))) = y + (0::int) + y"
  by simp

lemma "x + y - x + z - x - y - z + x < (1::int)"
  by simp

subsection\<open>Real Arithmetic\<close>

subsubsection \<open>Addition\<close>

lemma "(1359::real) + -2468 = -1109"
by simp

lemma "(93746::real) + -46375 = 47371"
by simp

subsubsection \<open>Negation\<close>

lemma "- (65745::real) = -65745"
by simp

lemma "- (-54321::real) = 54321"
by simp

subsubsection \<open>Multiplication\<close>

lemma "(-84::real) * 51 = -4284"
by simp

lemma "(255::real) * 255 = 65025"
by simp

lemma "(1359::real) * -2468 = -3354012"
by simp

subsubsection \<open>Inequalities\<close>

lemma "(89::real) * 10 \<noteq> 889"
by simp

lemma "(13::real) < 18 - 4"
by simp

lemma "(-345::real) < -242 + -100"
by simp

lemma "(13557456::real) < 18678654"
by simp

lemma "(999999::real) \<le> (1000001 + 1) - 2"
by simp

lemma "(1234567::real) \<le> 1234567"
by simp

subsubsection \<open>Powers\<close>

lemma "2 ^ 15 = (32768::real)"
by simp

lemma "(- 3) ^ 7 = (-2187::real)"
by simp

lemma "13 ^ 7 = (62748517::real)"
by simp

lemma "3 ^ 15 = (14348907::real)"
by simp

lemma "(- 5) ^ 11 = (-48828125::real)"
by simp

subsubsection \<open>Tests\<close>

lemma "(x + y = x) = (y = (0::real))"
by arith

lemma "(x + y = y) = (x = (0::real))"
by arith

lemma "(x + y = (0::real)) = (x = -y)"
by arith

lemma "(x + y = (0::real)) = (y = -x)"
by arith

lemma "((x + y) < (x + z)) = (y < (z::real))"
by arith

lemma "((x + z) < (y + z)) = (x < (y::real))"
by arith

lemma "(\<not> x < y) = (y \<le> (x::real))"
by arith

lemma "\<not> (x < y \<and> y < (x::real))"
by arith

lemma "(x::real) < y ==> \<not> y < x"
by arith

lemma "((x::real) \<noteq> y) = (x < y \<or> y < x)"
by arith

lemma "(\<not> x \<le> y) = (y < (x::real))"
by arith

lemma "x \<le> y \<or> y \<le> (x::real)"
by arith

lemma "x \<le> y \<or> y < (x::real)"
by arith

lemma "x < y \<or> y \<le> (x::real)"
by arith

lemma "x \<le> (x::real)"
by arith

lemma "((x::real) \<le> y) = (x < y \<or> x = y)"
by arith

lemma "((x::real) \<le> y \<and> y \<le> x) = (x = y)"
by arith

lemma "\<not>(x < y \<and> y \<le> (x::real))"
by arith

lemma "\<not>(x \<le> y \<and> y < (x::real))"
by arith

lemma "(-x < (0::real)) = (0 < x)"
by arith

lemma "((0::real) < -x) = (x < 0)"
by arith

lemma "(-x \<le> (0::real)) = (0 \<le> x)"
by arith

lemma "((0::real) \<le> -x) = (x \<le> 0)"
by arith

lemma "(x::real) = y \<or> x < y \<or> y < x"
by arith

lemma "(x::real) = 0 \<or> 0 < x \<or> 0 < -x"
by arith

lemma "(0::real) \<le> x \<or> 0 \<le> -x"
by arith

lemma "((x::real) + y \<le> x + z) = (y \<le> z)"
by arith

lemma "((x::real) + z \<le> y + z) = (x \<le> y)"
by arith

lemma "(w::real) < x \<and> y < z ==> w + y < x + z"
by arith

lemma "(w::real) \<le> x \<and> y \<le> z ==> w + y \<le> x + z"
by arith

lemma "(0::real) \<le> x \<and> 0 \<le> y ==> 0 \<le> x + y"
by arith

lemma "(0::real) < x \<and> 0 < y ==> 0 < x + y"
by arith

lemma "(-x < y) = (0 < x + (y::real))"
by arith

lemma "(x < -y) = (x + y < (0::real))"
by arith

lemma "(y < x + -z) = (y + z < (x::real))"
by arith

lemma "(x + -y < z) = (x < z + (y::real))"
by arith

lemma "x \<le> y ==> x < y + (1::real)"
by arith

lemma "(x - y) + y = (x::real)"
by arith

lemma "y + (x - y) = (x::real)"
by arith

lemma "x - x = (0::real)"
by arith

lemma "(x - y = 0) = (x = (y::real))"
by arith

lemma "((0::real) \<le> x + x) = (0 \<le> x)"
by arith

lemma "(-x \<le> x) = ((0::real) \<le> x)"
by arith

lemma "(x \<le> -x) = (x \<le> (0::real))"
by arith

lemma "(-x = (0::real)) = (x = 0)"
by arith

lemma "-(x - y) = y - (x::real)"
by arith

lemma "((0::real) < x - y) = (y < x)"
by arith

lemma "((0::real) \<le> x - y) = (y \<le> x)"
by arith

lemma "(x + y) - x = (y::real)"
by arith

lemma "(-x = y) = (x = (-y::real))"
by arith

lemma "x < (y::real) ==> \<not>(x = y)"
by arith

lemma "(x \<le> x + y) = ((0::real) \<le> y)"
by arith

lemma "(y \<le> x + y) = ((0::real) \<le> x)"
by arith

lemma "(x < x + y) = ((0::real) < y)"
by arith

lemma "(y < x + y) = ((0::real) < x)"
by arith

lemma "(x - y) - x = (-y::real)"
by arith

lemma "(x + y < z) = (x < z - (y::real))"
by arith

lemma "(x - y < z) = (x < z + (y::real))"
by arith

lemma "(x < y - z) = (x + z < (y::real))"
by arith

lemma "(x \<le> y - z) = (x + z \<le> (y::real))"
by arith

lemma "(x - y \<le> z) = (x \<le> z + (y::real))"
by arith

lemma "(-x < -y) = (y < (x::real))"
by arith

lemma "(-x \<le> -y) = (y \<le> (x::real))"
by arith

lemma "(a + b) - (c + d) = (a - c) + (b - (d::real))"
by arith

lemma "(0::real) - x = -x"
by arith

lemma "x - (0::real) = x"
by arith

lemma "w \<le> x \<and> y < z ==> w + y < x + (z::real)"
by arith

lemma "w < x \<and> y \<le> z ==> w + y < x + (z::real)"
by arith

lemma "(0::real) \<le> x \<and> 0 < y ==> 0 < x + (y::real)"
by arith

lemma "(0::real) < x \<and> 0 \<le> y ==> 0 < x + y"
by arith

lemma "-x - y = -(x + (y::real))"
by arith

lemma "x - (-y) = x + (y::real)"
by arith

lemma "-x - -y = y - (x::real)"
by arith

lemma "(a - b) + (b - c) = a - (c::real)"
by arith

lemma "(x = y - z) = (x + z = (y::real))"
by arith

lemma "(x - y = z) = (x = z + (y::real))"
by arith

lemma "x - (x - y) = (y::real)"
by arith

lemma "x - (x + y) = -(y::real)"
by arith

lemma "x = y ==> x \<le> (y::real)"
by arith

lemma "(0::real) < x ==> \<not>(x = 0)"
by arith

lemma "(x + y) * (x - y) = (x * x) - (y * y)"
  oops

lemma "(-x = -y) = (x = (y::real))"
by arith

lemma "(-x < -y) = (y < (x::real))"
by arith

lemma "!!a::real. a \<le> b ==> c \<le> d ==> x + y < z ==> a + c \<le> b + d"
by linarith

lemma "!!a::real. a < b ==> c < d ==> a - d \<le> b + (-c)"
by linarith

lemma "!!a::real. a \<le> b ==> b + b \<le> c ==> a + a \<le> c"
by linarith

lemma "!!a::real. a + b \<le> i + j ==> a \<le> b ==> i \<le> j ==> a + a \<le> j + j"
by linarith

lemma "!!a::real. a + b < i + j ==> a < b ==> i < j ==> a + a < j + j"
by linarith

lemma "!!a::real. a + b + c \<le> i + j + k \<and> a \<le> b \<and> b \<le> c \<and> i \<le> j \<and> j \<le> k --> a + a + a \<le> k + k + k"
by arith

lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
    ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a \<le> l"
by linarith

lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
    ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a \<le> l + l + l + l"
by linarith

lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
    ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a + a \<le> l + l + l + l + i"
by linarith

lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
    ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a + a + a \<le> l + l + l + l + i + l"
by linarith

subsection\<open>Complex Arithmetic\<close>

lemma "(1359 + 93746*\<i>) - (2468 + 46375*\<i>) = -1109 + 47371*\<i>"
by simp

lemma "- (65745 + -47371*\<i>) = -65745 + 47371*\<i>"
by simp

text\<open>Multiplication requires distributive laws.  Perhaps versions instantiated
to literal constants should be added to the simpset.\<close>

lemma "(1 + \<i>) * (1 - \<i>) = 2"
by (simp add: ring_distribs)

lemma "(1 + 2*\<i>) * (1 + 3*\<i>) = -5 + 5*\<i>"
by (simp add: ring_distribs)

lemma "(-84 + 255*\<i>) + (51 * 255*\<i>) = -84 + 13260 * \<i>"
by (simp add: ring_distribs)

text\<open>No inequalities or linear arithmetic: the complex numbers are unordered!\<close>

text\<open>No powers (not supported yet)\<close>

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Elementary Column Operations\<close>

text \<open>We define elementary column operations and also combine them with elementary
  row operations. These combined operations are the basis to perform operations which
  preserve similarity of matrices. They are applied later on to convert upper triangular
  matrices into Jordan normal form.\<close>

theory Column_Operations
imports
  Gauss_Jordan_Elimination
begin

definition mat_multcol :: "nat \<Rightarrow> 'a :: semiring_1 \<Rightarrow> 'a mat \<Rightarrow> 'a mat" ("multcol") where
  "multcol k a A = mat (dim_row A) (dim_col A)
     (\<lambda> (i,j). if k = j then a * A $$ (i,j) else A $$ (i,j))"

definition mat_swapcols :: "nat \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" ("swapcols")where
  "swapcols k l A = mat (dim_row A) (dim_col A)
    (\<lambda> (i,j). if k = j then A $$ (i,l) else if l = j then A $$ (i,k) else A $$ (i,j))"

definition mat_addcol_vec :: "nat \<Rightarrow> 'a :: plus vec \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
  "mat_addcol_vec k v A = mat (dim_row A) (dim_col A)
    (\<lambda> (i,j). if k = j then v $ i + A $$ (i,j) else A $$ (i,j))"

definition mat_addcol :: "'a :: semiring_1 \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" ("addcol") where
  "addcol a k l A = mat (dim_row A) (dim_col A)
    (\<lambda> (i,j). if k = j then a * A $$ (i,l) + A $$ (i,j) else A $$ (i,j))"

lemma index_mat_multcol[simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> multcol k a A $$ (i,j) = (if k = j then a * A $$ (i,j) else A $$ (i,j))"
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> multcol j a A $$ (i,j) = a * A $$ (i,j)"
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> k \<noteq> j \<Longrightarrow> multcol k a A $$ (i,j) = A $$ (i,j)"
  "dim_row (multcol k a A) = dim_row A" "dim_col (multcol k a A) = dim_col A"
  unfolding mat_multcol_def by auto

lemma index_mat_swapcols[simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> swapcols k l A $$ (i,j) = (if k = j then A $$ (i,l) else
    if l = j then A $$ (i,k) else A $$ (i,j))"
  "dim_row (swapcols k l A) = dim_row A" "dim_col (swapcols k l A) = dim_col A"
  unfolding mat_swapcols_def by auto

lemma index_mat_addcol[simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> addcol a k l A $$ (i,j) = (if k = j then
    a * A $$ (i,l) + A $$ (i,j) else A $$ (i,j))"
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> addcol a j l A $$ (i,j) = a * A $$(i,l) + A$$(i,j)"
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> k \<noteq> j \<Longrightarrow> addcol a k l A $$ (i,j) = A $$(i,j)"
  "dim_row (addcol a k l A) = dim_row A" "dim_col (addcol a k l A) = dim_col A"
  unfolding mat_addcol_def by auto

text \<open>Each column-operation can be seen as a multiplication of
  an elementary matrix from the right\<close>

lemma col_addrow:
  "l \<noteq> i \<Longrightarrow> i < n \<Longrightarrow> col (addrow_mat n a k l) i = unit_vec n i"
  "k < n \<Longrightarrow> l < n \<Longrightarrow> col (addrow_mat n a k l) l = a \<cdot>\<^sub>v unit_vec n k + unit_vec n l"
  by (rule eq_vecI, auto)

lemma col_addcol[simp]:
  "k < dim_col A \<Longrightarrow> l < dim_col A \<Longrightarrow> col (addcol a k l A) k = a \<cdot>\<^sub>v col A l + col A k"
  by (rule eq_vecI;simp)

lemma addcol_mat: assumes A: "A \<in> carrier_mat nr n"
  and k: "k < n"
  shows "addcol (a :: 'a :: comm_semiring_1) l k A = A * addrow_mat n a k l"
  by (rule eq_matI, insert A k, auto simp: col_addrow
  scalar_prod_add_distrib[of _ n] scalar_prod_smult_distrib[of _ n])

lemma col_multrow:  "k \<noteq> i \<Longrightarrow> i < n \<Longrightarrow> col (multrow_mat n k a) i = unit_vec n i"
  "k < n \<Longrightarrow> col (multrow_mat n k a) k = a \<cdot>\<^sub>v unit_vec n k"
  by (rule eq_vecI, auto)

lemma multcol_mat: assumes A: "(A :: 'a :: comm_ring_1 mat) \<in> carrier_mat nr n"
  shows "multcol k a A = A * multrow_mat n k a"
  by (rule eq_matI, insert A, auto simp: col_multrow smult_scalar_prod_distrib[of _ n])

lemma col_swaprows:
  "l < n \<Longrightarrow> col (swaprows_mat n l l) l = unit_vec n l"
  "i \<noteq> k \<Longrightarrow> i \<noteq> l \<Longrightarrow> i < n \<Longrightarrow> col (swaprows_mat n k l) i = unit_vec n i"
  "k < n \<Longrightarrow> l < n \<Longrightarrow> col (swaprows_mat n k l) l = unit_vec n k"
  "k < n \<Longrightarrow> l < n \<Longrightarrow> col (swaprows_mat n k l) k = unit_vec n l"
  by (rule eq_vecI, auto)

lemma swapcols_mat: assumes A: "A \<in> carrier_mat nr n" and k: "k < n" "l < n"
  shows "swapcols k l A = A * swaprows_mat n k l"
  by (rule eq_matI, insert A k, auto simp: col_swaprows)

text \<open>Combining row and column-operations yields similarity transformations.\<close>

definition add_col_sub_row :: "'a :: ring_1 \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"  where
  "add_col_sub_row a k l A = addrow (- a) k l (addcol a l k A)"

definition mult_col_div_row :: "'a :: field \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
  "mult_col_div_row a k A = multrow k (inverse a) (multcol k a A)"

definition swap_cols_rows :: "nat \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
  "swap_cols_rows k l A = swaprows k l (swapcols k l A)"

lemma add_col_sub_row_carrier[simp]:
  "dim_row (add_col_sub_row a k l A) = dim_row A"
  "dim_col (add_col_sub_row a k l A) = dim_col A"
  "A \<in> carrier_mat n n \<Longrightarrow> add_col_sub_row a k l A \<in> carrier_mat n n"
  unfolding add_col_sub_row_def carrier_mat_def by auto

lemma add_col_sub_index_row[simp]:
  "i < dim_row A \<Longrightarrow> i < dim_col A \<Longrightarrow> j < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> l < dim_row A
    \<Longrightarrow> add_col_sub_row a k l A $$ (i,j) = (if
      i = k \<and> j = l then A $$ (i, j) + a * A $$ (i, i) - a * a * A $$ (j, i) - a * A $$ (j, j) else if
      i = k \<and> j \<noteq> l then A $$ (i, j) - a * A $$ (l, j) else if
      i \<noteq> k \<and> j = l then A $$ (i, j) + a * A $$ (i, k) else A $$ (i,j))"
  unfolding add_col_sub_row_def by (auto simp: field_simps)

lemma mult_col_div_index_row[simp]:
  "i < dim_row A \<Longrightarrow> i < dim_col A \<Longrightarrow> j < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> a \<noteq> 0
    \<Longrightarrow> mult_col_div_row a k A $$ (i,j) = (if
      i = k \<and> j \<noteq> i then inverse a * A $$ (i, j) else if
      j = k \<and> j \<noteq> i then a * A $$ (i, j) else A $$ (i,j))"
  unfolding mult_col_div_row_def by auto

lemma mult_col_div_row_carrier[simp]:
  "dim_row (mult_col_div_row a k A) = dim_row A"
  "dim_col (mult_col_div_row a k A) = dim_col A"
  "A \<in> carrier_mat n n \<Longrightarrow> mult_col_div_row a k A \<in> carrier_mat n n"
  unfolding mult_col_div_row_def carrier_mat_def by auto

lemma swap_cols_rows_carrier[simp]:
  "dim_row (swap_cols_rows k l A) = dim_row A"
  "dim_col (swap_cols_rows k l A) = dim_col A"
  "A \<in> carrier_mat n n \<Longrightarrow> swap_cols_rows k l A \<in> carrier_mat n n"
  unfolding swap_cols_rows_def carrier_mat_def by auto

lemma swap_cols_rows_index[simp]:
  "i < dim_row A \<Longrightarrow> i < dim_col A \<Longrightarrow> j < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> a < dim_row A \<Longrightarrow> b < dim_row A
    \<Longrightarrow> swap_cols_rows a b A $$ (i,j) = A $$ (if i = a then b else if i = b then a else i,
     if j = a then b else if j = b then a else j)"
  unfolding swap_cols_rows_def
  by auto

lemma add_col_sub_row_similar: assumes A: "A \<in> carrier_mat n n" and kl: "k < n" "l < n" "k \<noteq> l"
  shows "similar_mat (add_col_sub_row a k l A) (A :: 'a :: comm_ring_1 mat)"
proof (rule similar_matI)
  let ?P = "addrow_mat n (-a) k l"
  let ?Q = "addrow_mat n a k l"
  let ?B = "add_col_sub_row a k l A"
  show carr: "{?B, A, ?P, ?Q} \<subseteq> carrier_mat n n" using A by auto
  show "?Q * ?P = 1\<^sub>m n" by (rule addrow_mat_inv[OF kl])
  show "?P * ?Q = 1\<^sub>m n" using addrow_mat_inv[OF kl, of "-a"] by simp
  have col: "addcol a l k A = A * ?Q"
    by (rule addcol_mat[OF A kl(1)])
  have "?B = ?P * (A * ?Q)" unfolding add_col_sub_row_def col
    by (rule addrow_mat[OF _ kl(2), of _ n], insert A, simp)
  thus "?B = ?P * A * ?Q" using carr by (simp add: assoc_mult_mat[of _ n n _ n _ n])
qed

lemma mult_col_div_row_similar: assumes A: "A \<in> carrier_mat n n" and ak: "k < n" "a \<noteq> 0"
  shows "similar_mat (mult_col_div_row a k A) A"
proof (rule similar_matI)
  let ?P = "multrow_mat n k (inverse a)"
  let ?Q = "multrow_mat n k a"
  let ?B = "mult_col_div_row a k A"
  show carr: "{?B, A, ?P, ?Q} \<subseteq> carrier_mat n n" using A by auto
  show "?Q * ?P = 1\<^sub>m n" by (rule multrow_mat_inv[OF ak])
  show "?P * ?Q = 1\<^sub>m n" using multrow_mat_inv[OF ak(1), of "inverse a"] ak(2) by simp
  have col: "multcol k a A = A * ?Q"
    by (rule multcol_mat[OF A])
  have "?B = ?P * (A * ?Q)" unfolding mult_col_div_row_def col
    by (rule multrow_mat[of _ n n], insert A, simp)
  thus "?B = ?P * A * ?Q" using carr by (simp add: assoc_mult_mat[of _ n n _ n _ n])
qed

lemma swap_cols_rows_similar: assumes A: "A \<in> carrier_mat n n" and kl: "k < n" "l < n"
  shows "similar_mat (swap_cols_rows k l A) A"
proof (rule similar_matI)
  let ?P = "swaprows_mat n k l"
  let ?B = "swap_cols_rows k l A"
  show carr: "{?B, A, ?P, ?P} \<subseteq> carrier_mat n n" using A by auto
  show "?P * ?P = 1\<^sub>m n" by (rule swaprows_mat_inv[OF kl])
  show "?P * ?P = 1\<^sub>m n" by fact
  have col: "swapcols k l A = A * ?P"
    by (rule swapcols_mat[OF A kl])
  have "?B = ?P * (A * ?P)" unfolding swap_cols_rows_def col
    by (rule swaprows_mat[of _ n n ], insert A kl, auto)
  thus "?B = ?P * A * ?P" using carr by (simp add: assoc_mult_mat[of _ n n _ n _ n])
qed

(* THIS LINE SEPARATES AFP-ENTRY FROM NEWER DEVELOPMENTS *)

lemma swapcols_carrier[simp]: "(swapcols l k A \<in> carrier_mat n m) = (A \<in> carrier_mat n m)"
  unfolding mat_swapcols_def carrier_mat_def by auto

fun swap_row_to_front :: "'a mat \<Rightarrow> nat \<Rightarrow> 'a mat" where
  "swap_row_to_front A 0 = A"
| "swap_row_to_front A (Suc I) = swap_row_to_front (swaprows I (Suc I) A) I"

fun swap_col_to_front :: "'a mat \<Rightarrow> nat \<Rightarrow> 'a mat" where
  "swap_col_to_front A 0 = A"
| "swap_col_to_front A (Suc I) = swap_col_to_front (swapcols I (Suc I) A) I"

lemma swap_row_to_front_result: "A \<in> carrier_mat n m \<Longrightarrow> I < n \<Longrightarrow> swap_row_to_front A I =
  mat n m (\<lambda> (i,j). if i = 0 then A $$ (I,j)
  else if i \<le> I then A $$ (i - 1, j) else A $$ (i,j))"
proof (induct I arbitrary: A)
  case 0
  thus ?case
    by (intro eq_matI, auto)
next
  case (Suc I A)
  from Suc(3) have I: "I < n" by auto
  let ?I = "Suc I"
  let ?A = "swaprows I ?I A"
  have AA: "?A \<in> carrier_mat n m" using Suc(2) by simp
  have "swap_row_to_front A (Suc I) = swap_row_to_front ?A I" by simp
  also have "\<dots> = mat n m
   (\<lambda>(i, j). if i = 0 then ?A $$ (I, j)
       else if i \<le> I then ?A $$ (i - 1, j) else ?A $$ (i, j))"
     using Suc(1)[OF AA I] by simp
  also have "\<dots> = mat n m
   (\<lambda>(i, j). if i = 0 then A $$ (?I, j)
       else if i \<le> ?I then A $$ (i - 1, j) else A $$ (i, j))"
    by (rule eq_matI, insert I Suc(2), auto)
  finally show ?case .
qed

lemma swap_col_to_front_result: "A \<in> carrier_mat n m \<Longrightarrow> J < m \<Longrightarrow> swap_col_to_front A J =
  mat n m (\<lambda> (i,j). if j = 0 then A $$ (i,J)
  else if j \<le> J then A $$ (i, j-1) else A $$ (i,j))"
proof (induct J arbitrary: A)
  case 0
  thus ?case
    by (intro eq_matI, auto)
next
  case (Suc J A)
  from Suc(3) have J: "J < m" by auto
  let ?J = "Suc J"
  let ?A = "swapcols J ?J A"
  have AA: "?A \<in> carrier_mat n m" using Suc(2) by simp
  have "swap_col_to_front A (Suc J) = swap_col_to_front ?A J" by simp
  also have "\<dots> = mat n m
   (\<lambda>(i, j). if j = 0 then ?A $$ (i, J)
          else if j \<le> J then ?A $$ (i, j - 1) else ?A $$ (i, j))"
     using Suc(1)[OF AA J] by simp
  also have "\<dots> = mat n m
   (\<lambda>(i, j). if j = 0 then A $$ (i, ?J)
          else if j \<le> ?J then A $$ (i, j - 1) else A $$ (i, j))"
    by (rule eq_matI, insert J Suc(2), auto)
  finally show ?case .
qed

lemma swapcols_is_transp_swap_rows: assumes A: "A \<in> carrier_mat n m" "k < m" "l < m"
  shows "swapcols k l A = transpose_mat (swaprows k l (transpose_mat A))"
  using assms by (intro eq_matI, auto)

end