(* Author: Alexander Maletzky *)

section \<open>31-Bit Machine Integers\<close>

theory Int31
  imports "HOL-Library.Code_Target_Numeral" Signature_Groebner.Prelims Print
begin

subsection \<open>Carrier Sets for Arbitrary Bit-Size\<close>

definition int_carrier :: "nat \<Rightarrow> int set"
  where "int_carrier n = {a. - (2 ^ n) \<le> a \<and> a < 2 ^ n}"

definition sym_interval :: "nat \<Rightarrow> (int set) \<Rightarrow> bool"
  where "sym_interval n A \<longleftrightarrow> (A \<subseteq> int_carrier n \<and> (\<forall>a\<in>A. \<forall>b. abs b \<le> abs a \<longrightarrow> b \<in> A))"

abbreviation uminus_dom :: "nat \<Rightarrow> int set"
  where "uminus_dom n \<equiv> {a. abs a \<in> int_carrier n}"

abbreviation plus_dom :: "nat \<Rightarrow> int set"
  where "plus_dom n \<equiv> {a. 2 * abs a \<in> int_carrier n}"

abbreviation times_dom :: "nat \<Rightarrow> int set"
  where "times_dom n \<equiv> {a. a ^ 2 \<in> int_carrier n}"

subsubsection \<open>@{const sym_interval}\<close>

lemma sym_intervalD:
  assumes "sym_interval n A"
  shows "A \<subseteq> int_carrier n" and "\<And>a b. a \<in> A \<Longrightarrow> abs b \<le> abs a \<Longrightarrow> b \<in> A"
  using assms by (simp_all add: sym_interval_def)

lemma sym_interval_closed_sgn:
  assumes "sym_interval n A" and "a \<in> A"
  shows "sgn a \<in> A"
proof -
  have "abs (sgn a) \<le> abs a" by auto
  with assms show ?thesis by (rule sym_intervalD)
qed

lemma sym_interval_closed_abs:
  assumes "sym_interval n A" and "a \<in> A"
  shows "abs a \<in> A"
proof -
  have "abs (abs a) \<le> abs a" by simp
  with assms show ?thesis by (rule sym_intervalD)
qed

lemma sym_interval_closed_uminus:
  assumes "sym_interval n A" and "a \<in> A"
  shows "- a \<in> A"
proof -
  have "abs (- a) \<le> abs a" by simp
  with assms show ?thesis by (rule sym_intervalD)
qed

lemma sym_interval_closed_divide:
  assumes "sym_interval n A" and "a \<in> A"
  shows "a div b \<in> A"
proof (cases "a = 0")
  case True
  hence "a div b = a" by simp
  show ?thesis unfolding \<open>a div b = a\<close> by (fact assms(2))
next
  case False
  have 1: "nat \<bar>a\<bar> div nat \<bar>b\<bar> \<le> nat \<bar>a\<bar>" by (fact div_le_dividend)
  hence 2: "int (nat \<bar>a\<bar> div nat \<bar>b\<bar>) \<le> \<bar>a\<bar>" by linarith
  have "abs (a div b) \<le> abs a"
  proof (simp add: divide_int_def 2, intro impI)
    assume "\<not> b dvd a"
    have "nat \<bar>a\<bar> div nat \<bar>b\<bar> \<noteq> nat \<bar>a\<bar>"
    proof
      from False have "0 < nat (abs a)" by simp
      moreover assume "nat \<bar>a\<bar> div nat \<bar>b\<bar> = nat \<bar>a\<bar>"
      ultimately have "nat (abs b) = 1" by (simp only: div_eq_dividend_iff)
      hence "abs b = 1" by simp
      hence "abs b dvd abs a" by simp
      hence "b dvd a" by simp
      with \<open>\<not> b dvd a\<close> show False ..
    qed
    with 1 have "nat \<bar>a\<bar> div nat \<bar>b\<bar> < nat \<bar>a\<bar>" by (rule le_neq_implies_less)
    thus "1 + int (nat \<bar>a\<bar> div nat \<bar>b\<bar>) \<le> \<bar>a\<bar>" by linarith
  qed
  with assms show ?thesis by (rule sym_intervalD)
qed

lemma sym_interval_closed_modulo:
  assumes "sym_interval n A" and "a \<in> A" and "b \<in> A"
    \<comment>\<open>Instead of @{prop "a \<in> A"} one could also require @{prop "b \<noteq> 0"}, using @{thm mod_le_divisor}.\<close>
  shows "a mod b \<in> A"
proof -
  have "nat \<bar>a\<bar> mod nat \<bar>b\<bar> \<le> nat \<bar>a\<bar>" by (fact mod_less_eq_dividend)
  hence "int (nat \<bar>a\<bar> mod nat \<bar>b\<bar>) \<le> \<bar>a\<bar>" by linarith
  also have "... \<le> max \<bar>a\<bar> \<bar>b\<bar>" by simp
  finally have *: "int (nat \<bar>a\<bar> mod nat \<bar>b\<bar>) \<le> max \<bar>a\<bar> \<bar>b\<bar>" .
  have "abs (a mod b) \<le> max (abs a) (abs b)"
  proof (simp add: modulo_int_def abs_mult * abs_diff_le_iff diff_le_eq, intro impI conjI)
    note *
    also have "... \<le> \<bar>b\<bar> + max \<bar>a\<bar> \<bar>b\<bar>" by simp
    finally show "int (nat \<bar>a\<bar> mod nat \<bar>b\<bar>) \<le> \<bar>b\<bar> + max \<bar>a\<bar> \<bar>b\<bar>" .
  next
    show "\<bar>b\<bar> \<le> int (nat \<bar>a\<bar> mod nat \<bar>b\<bar>) + max \<bar>a\<bar> \<bar>b\<bar>" by simp
  next
    have "0 \<le> \<bar>a\<bar>" by simp
    also have "... \<le> max \<bar>a\<bar> \<bar>b\<bar>" by simp
    finally show "0 \<le> max \<bar>a\<bar> \<bar>b\<bar>" .
  qed
  hence "abs (a mod b) \<le> abs a \<or> abs (a mod b) \<le> abs b" by auto
  thus ?thesis
  proof
    assume "\<bar>a mod b\<bar> \<le> \<bar>a\<bar>"
    with assms(1, 2) show ?thesis by (rule sym_intervalD)
  next
    assume "\<bar>a mod b\<bar> \<le> \<bar>b\<bar>"
    with assms(1, 3) show ?thesis by (rule sym_intervalD)
  qed
qed

lemma sym_interval_closed_gcd:
  assumes "sym_interval n A" and "a \<in> A" and "b \<in> A"
  shows "gcd a b \<in> A"
proof (cases "a = 0")
  case True
  hence "abs (gcd a b) \<le> abs b" by simp
  with assms(1, 3) show ?thesis by (rule sym_intervalD)
next
  case False
  hence "0 < abs a" by simp
  hence "gcd (abs a) b \<le> abs a" by (rule gcd_le1_int)
  hence "abs (gcd a b) \<le> abs a" by simp
  with assms(1, 2) show ?thesis by (rule sym_intervalD)
qed

subsubsection \<open>Other\<close>

lemma zero_in_int_carrier: "0 \<in> int_carrier n"
  by (simp add: int_carrier_def)

lemma int_carrier_le: "a \<in> int_carrier n \<Longrightarrow> - (2 ^ n) \<le> b \<Longrightarrow> b \<le> a \<Longrightarrow> b \<in> int_carrier n"
  by (auto simp: int_carrier_def)

lemma uminus_domI: "abs a < 2 ^ n \<Longrightarrow> a \<in> uminus_dom n"
  by (auto simp: int_carrier_def)

lemma uminus_domD:
  assumes "a \<in> uminus_dom n"
  shows "- (2 ^ n) < a" and "a < 2 ^ n"
  using assms by (auto simp: int_carrier_def)

lemma uminus_dom_subset_int_carrier: "a \<in> uminus_dom n \<Longrightarrow> a \<in> int_carrier n"
  by (auto simp: int_carrier_def)

lemma sym_interval_uminus_dom [simp]: "sym_interval n (uminus_dom n)"
  unfolding sym_interval_def
proof (intro conjI ballI allI impI)
  from uminus_dom_subset_int_carrier show "uminus_dom n \<subseteq> int_carrier n" ..
next
  fix a b :: int
  assume "a \<in> uminus_dom n"
  hence "abs a < 2 ^ n" by (simp add: int_carrier_def)
  assume "abs b \<le> abs a"
  also have "... < 2 ^ n" by fact
  finally show "b \<in> uminus_dom n" by (rule uminus_domI)
qed

lemma plus_domI: "2 * abs a < 2 ^ n \<Longrightarrow> a \<in> plus_dom n"
  by (auto simp: int_carrier_def)

lemma plus_domD:
  assumes "a \<in> plus_dom n"
  shows "- (2 ^ n) < 2 * a" and "2 * a < 2 ^ n"
  using assms by (auto simp: int_carrier_def)

lemma plus_dom_subset_uminus_dom: "a \<in> plus_dom n \<Longrightarrow> a \<in> uminus_dom n"
  by (auto simp: int_carrier_def)

corollary plus_dom_subset_int_carrier: "a \<in> plus_dom n \<Longrightarrow> a \<in> int_carrier n"
  by (intro uminus_dom_subset_int_carrier plus_dom_subset_uminus_dom)

lemma sym_interval_plus_dom [simp]: "sym_interval n (plus_dom n)"
  unfolding sym_interval_def
proof (intro conjI ballI allI impI)
  from plus_dom_subset_int_carrier show "plus_dom n \<subseteq> int_carrier n" ..
next
  fix a b :: int
  assume "a \<in> plus_dom n"
  hence "2 * abs a < 2 ^ n" by (simp add: int_carrier_def)
  assume "abs b \<le> abs a"
  hence "2 * abs b \<le> 2 * abs a" by simp
  also have "... < 2 ^ n" by fact
  finally show "b \<in> plus_dom n" by (rule plus_domI)
qed

lemma times_domI: "a ^ 2 < 2 ^ n \<Longrightarrow> a \<in> times_dom n"
  by (simp add: int_carrier_def) (smt power2_less_0)

lemma times_domD:
  assumes "a \<in> times_dom n"
  shows "- (2 ^ n) < a ^ 2" and "a ^ 2 < 2 ^ n"
  using assms by (simp_all add: int_carrier_def) (smt zero_le_power2)

lemma times_dom_subset_plus_dom:
  assumes "1 < n" and "a \<in> times_dom n"
  shows "a \<in> plus_dom n"
proof (cases "abs a < 2")
  case True
  hence "2 * abs a \<le> 2" by simp
  also from assms(1) have "... < 2 ^ n" by (smt power_one_right power_strict_increasing)
  finally show ?thesis by (rule plus_domI)
next
  case False
  show ?thesis
  proof (simp, rule int_carrier_le)
    from assms(2) show "a ^ 2 \<in> int_carrier n" by simp
  next
    show "- (2 ^ n) \<le> 2 * \<bar>a\<bar>" by (smt zero_less_power)
  next
    from False have "2 \<le> abs a" by simp
    moreover have "0 \<le> abs a" by simp
    ultimately have "abs a * 2 \<le> abs a * abs a" by (rule mult_left_mono)
    thus "2 * abs a \<le> a ^ 2" by (simp add: power_def)
  qed
qed

lemma times_dom_subset_uminus_dom:
  assumes "a \<in> times_dom n"
  shows "a \<in> uminus_dom n"
proof -
  have rl: "b \<le> b ^ 2" for b::int by (smt self_le_power zero_le_power2 zero_less_numeral)
  hence "- a \<le> (- a) ^ 2" .
  also have "... = a ^ 2" by simp
  finally have "- (a ^ 2) \<le> a" by simp
  from assms have "a ^ 2 < 2 ^ n" by (rule times_domD)
  hence "- (2 ^ n) < - (a ^ 2)" by simp
  also have "... \<le> a" by fact
  finally have 1: "- (2 ^ n) < a" .
  note rl
  also from assms have "a ^ 2 < 2 ^ n" by (rule times_domD)
  finally show ?thesis using 1 by (auto simp: int_carrier_def)
qed

corollary times_dom_subset_int_carrier: "a \<in> times_dom n \<Longrightarrow> a \<in> int_carrier n"
  by (intro uminus_dom_subset_int_carrier times_dom_subset_uminus_dom)

lemma sym_interval_times_dom [simp]: "sym_interval n (times_dom n)"
  unfolding sym_interval_def
proof (intro conjI allI ballI impI)
  from times_dom_subset_int_carrier show "times_dom n \<subseteq> int_carrier n" ..
next
  fix a b :: int
  assume "a \<in> times_dom n"
  hence "a ^ 2 < 2 ^ n" by (rule times_domD)
  assume "abs b \<le> abs a"
  moreover have "0 \<le> abs b" by simp
  ultimately have "abs b ^ 2 \<le> abs a ^ 2" by (rule power_mono)
  hence "b ^ 2 \<le> a ^ 2" by simp
  also have "... < 2 ^ n" by fact
  finally show "b \<in> times_dom n" by (rule times_domI)
qed

lemma uminus_dom_closed_plus:
  assumes "a \<in> plus_dom n" and "b \<in> plus_dom n"
  shows "a + b \<in> uminus_dom n"
proof (cases "a \<le> b")
  case True
  from assms(1) have "- (2 ^ n) < 2 * a" by (rule plus_domD)
  also from True have "... \<le> a + b" by simp
  finally have 1: "- (2 ^ n) < a + b" .
  from True have "a + b \<le> 2 * b" by simp
  also from assms(2) have "... < 2 ^ n" by (rule plus_domD)
  finally show ?thesis using 1 by (auto simp: int_carrier_def)
next
  case False
  from assms(2) have "- (2 ^ n) < 2 * b" by (rule plus_domD)
  also from False have "... \<le> a + b" by simp
  finally have 1: "- (2 ^ n) < a + b" .
  from False have "a + b \<le> 2 * a" by simp
  also from assms(1) have "... < 2 ^ n" by (rule plus_domD)
  finally show ?thesis using 1 by (auto simp: int_carrier_def)
qed

corollary int_carrier_closed_plus: "a \<in> plus_dom n \<Longrightarrow> b \<in> plus_dom n \<Longrightarrow> a + b \<in> int_carrier n"
  by (intro uminus_dom_subset_int_carrier uminus_dom_closed_plus)

lemma uminus_dom_closed_minus:
  assumes "a \<in> plus_dom n" and "b \<in> plus_dom n"
  shows "a - b \<in> uminus_dom n"
proof -
  from sym_interval_plus_dom assms(2) have "- b \<in> plus_dom n" by (rule sym_interval_closed_uminus)
  with assms(1) have "a + (- b) \<in> uminus_dom n" by (rule uminus_dom_closed_plus)
  thus ?thesis by simp
qed

corollary int_carrier_closed_minus: "a \<in> plus_dom n \<Longrightarrow> b \<in> plus_dom n \<Longrightarrow> a - b \<in> int_carrier n"
  by (intro uminus_dom_subset_int_carrier uminus_dom_closed_minus)

lemma uminus_dom_closed_times:
  assumes "a \<in> times_dom n" and "b \<in> times_dom n"
  shows "a * b \<in> uminus_dom n"
proof -
  have "abs (a * b) < 2 ^ n"
  proof (cases "abs a \<le> abs b")
    case True
    moreover have "0 \<le> abs b" by simp
    ultimately have "abs b * abs a \<le> abs b * abs b" by (rule mult_left_mono)
    hence "abs (a * b) \<le> b ^ 2" by (simp add: ac_simps abs_mult power_def)
    also from assms(2) have "... < 2 ^ n" by (rule times_domD)
    finally show "abs (a * b) < 2 ^ n" .
  next
    case False
    hence "abs b \<le> abs a" by simp
    moreover have "0 \<le> abs a" by simp
    ultimately have "abs a * abs b \<le> abs a * abs a" by (rule mult_left_mono)
    hence "abs (a * b) \<le> a ^ 2" by (simp add: abs_mult power_def)
    also from assms(1) have "... < 2 ^ n" by (rule times_domD)
    finally show "abs (a * b) < 2 ^ n" .
  qed
  thus ?thesis by (rule uminus_domI)
qed

corollary int_carrier_closed_times: "a \<in> times_dom n \<Longrightarrow> b \<in> times_dom n \<Longrightarrow> a * b \<in> int_carrier n"
  by (intro uminus_dom_subset_int_carrier uminus_dom_closed_times)

subsection \<open>Abstract Type of \<open>n\<close>-Bit Integers\<close>

locale intN =
  fixes n :: nat
    and int_of_intN :: "'a \<Rightarrow> int"
    and intN_of_int :: "int \<Rightarrow> 'a"
  assumes n_gr_one: "1 < n"
    and int_of_intN_inverse: "intN_of_int (int_of_intN x) = x"
    and intN_of_int_inverse: "a \<in> int_carrier n \<Longrightarrow> int_of_intN (intN_of_int a) = a"
begin

definition integer_of_intN :: "'a \<Rightarrow> integer"
  where "integer_of_intN = integer_of_int \<circ> int_of_intN"

definition intN_of_integer :: "integer \<Rightarrow> 'a"
  where "intN_of_integer = intN_of_int \<circ> int_of_integer"

lemma int_of_intN_code: "int_of_intN a = int_of_integer (integer_of_intN a)"
  by (simp add: integer_of_intN_def)

lemma intN_of_int_code: "intN_of_int a = intN_of_integer (integer_of_int a)"
  by (simp add: intN_of_integer_def)

lemma int_of_intN_inject:
  assumes "int_of_intN x = int_of_intN y"
  shows "x = y"
proof -
  have "x = intN_of_int (int_of_intN x)" by (simp only: int_of_intN_inverse)
  also from assms have "... = intN_of_int (int_of_intN y)" by simp
  also have "... = y" by (simp only: int_of_intN_inverse)
  finally show ?thesis .
qed

lemma inj_int_of_intN: "inj int_of_intN"
  by (simp add: inj_def int_of_intN_inject)

subsubsection \<open>Order\<close>

definition less_eq_intN :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<le>n" 50)
  where "less_eq_intN = (\<lambda>x y. int_of_intN x \<le> int_of_intN y)"

definition less_intN :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "<n" 50)
  where "less_intN = (\<lambda>x y. int_of_intN x < int_of_intN y)"

lemma linorder_intN: "class.linorder (\<le>n) (<n)"
  by standard (auto simp: less_eq_intN_def less_intN_def dest: int_of_intN_inject)

subsubsection \<open>Sign, Abs\<close>

definition sym_intervalN :: "'a set \<Rightarrow> bool"
  where "sym_intervalN A \<longleftrightarrow> sym_interval n (int_of_intN ` A)"

definition sgn_intN :: "'a \<Rightarrow> 'a"
  where "sgn_intN = (\<lambda>x. intN_of_int (sgn (int_of_intN x)))"

definition abs_intN :: "'a \<Rightarrow> 'a"
  where "abs_intN = (\<lambda>x. intN_of_int (abs (int_of_intN x)))"

lemma int_of_intN_sgn: "int_of_intN (sgn_intN x) = sgn (int_of_intN x)"
  unfolding sgn_intN_def
  by (rule intN_of_int_inverse, simp add: zsgn_def int_carrier_def)
    (smt n_gr_one power_one_right power_strict_increasing)

lemma
  assumes "x \<in> A" and "sym_intervalN A"
  shows int_of_intN_abs: "int_of_intN (abs_intN x) = abs (int_of_intN x)"
    and sym_intervalN_closed_abs: "abs_intN x \<in> A"
proof -
  from assms(2) have 1: "sym_interval n (int_of_intN ` A)" by (simp only: sym_intervalN_def)
  moreover from assms(1) have 2: "int_of_intN x \<in> int_of_intN ` A" by (rule imageI)
  moreover have "abs (abs (int_of_intN x)) \<le> abs (int_of_intN x)" by simp
  ultimately have "abs (int_of_intN x) \<in> int_of_intN ` A" by (rule sym_intervalD)
  also from 1 have "... \<subseteq> int_carrier n" by (rule sym_intervalD)
  finally show "int_of_intN (abs_intN x) = abs (int_of_intN x)"
    unfolding abs_intN_def by (rule intN_of_int_inverse)
  also from 1 2 have "... \<in> int_of_intN ` A" by (rule sym_interval_closed_abs)
  finally show "abs_intN x \<in> A" using inj_int_of_intN by (simp only: inj_image_mem_iff)
qed

subsubsection \<open>Addition\<close>

definition uminus_domN :: "'a set"
  where "uminus_domN = intN_of_int ` uminus_dom n"

definition plus_domN :: "'a set"
  where "plus_domN = intN_of_int ` plus_dom n"

lemma int_of_intN_uminus_dom: "int_of_intN ` uminus_domN = uminus_dom n"
proof -
  have "int_of_intN ` uminus_domN = (\<lambda>a. int_of_intN (intN_of_int a)) ` uminus_dom n"
    by (simp only: uminus_domN_def image_image)
  also from refl have "... = (\<lambda>a. a) ` uminus_dom n"
  proof (rule image_cong)
    fix a
    assume "a \<in> uminus_dom n"
    hence "a \<in> int_carrier n" by (rule uminus_dom_subset_int_carrier)
    thus "int_of_intN (intN_of_int a) = a" by (rule intN_of_int_inverse)
  qed
  finally show ?thesis by simp
qed

lemma uminus_domN_iff: "x \<in> uminus_domN \<longleftrightarrow> int_of_intN x \<in> uminus_dom n"
proof
  assume "x \<in> uminus_domN"
  hence "int_of_intN x \<in> int_of_intN ` uminus_domN" by (rule imageI)
  thus "int_of_intN x \<in> uminus_dom n" by (simp only: int_of_intN_uminus_dom)
next
  assume "int_of_intN x \<in> uminus_dom n"
  hence "intN_of_int (int_of_intN x) \<in> intN_of_int ` uminus_dom n" by (rule imageI)
  thus "x \<in> uminus_domN" by (simp only: uminus_domN_def int_of_intN_inverse)
qed

lemma sym_interval_uminus_domN [simp]: "sym_intervalN uminus_domN"
  by (simp add: sym_intervalN_def int_of_intN_uminus_dom)

lemma int_of_intN_plus_dom: "int_of_intN ` plus_domN = plus_dom n"
proof -
  have "int_of_intN ` plus_domN = (\<lambda>a. int_of_intN (intN_of_int a)) ` plus_dom n"
    by (simp only: plus_domN_def image_image)
  also from refl have "... = (\<lambda>a. a) ` plus_dom n"
  proof (rule image_cong)
    fix a
    assume "a \<in> plus_dom n"
    hence "a \<in> int_carrier n" by (rule plus_dom_subset_int_carrier)
    thus "int_of_intN (intN_of_int a) = a" by (rule intN_of_int_inverse)
  qed
  finally show ?thesis by simp
qed

lemma plus_domN_iff: "x \<in> plus_domN \<longleftrightarrow> int_of_intN x \<in> plus_dom n"
proof
  assume "x \<in> plus_domN"
  hence "int_of_intN x \<in> int_of_intN ` plus_domN" by (rule imageI)
  thus "int_of_intN x \<in> plus_dom n" by (simp only: int_of_intN_plus_dom)
next
  assume "int_of_intN x \<in> plus_dom n"
  hence "intN_of_int (int_of_intN x) \<in> intN_of_int ` plus_dom n" by (rule imageI)
  thus "x \<in> plus_domN" by (simp only: plus_domN_def int_of_intN_inverse)
qed

lemma sym_interval_plus_domN [simp]: "sym_intervalN plus_domN"
  by (simp add: sym_intervalN_def int_of_intN_plus_dom)

lemma plus_dom_subset_uminus_domN: "plus_domN \<subseteq> uminus_domN"
  unfolding plus_domN_def uminus_domN_def
  by (rule image_mono, rule, rule plus_dom_subset_uminus_dom)

definition zero_intN :: 'a ("0n")
  where "zero_intN = intN_of_int 0"

lemma int_of_intN_zero: "int_of_intN 0n = 0"
  unfolding zero_intN_def using zero_in_int_carrier by (rule intN_of_int_inverse)

lemma intN_of_int_zero: "intN_of_int 0 = 0n"
  by (simp only: int_of_intN_zero[symmetric] int_of_intN_inverse)

definition plus_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+n" 65)
  where "plus_intN = (\<lambda>x y. intN_of_int (int_of_intN x + int_of_intN y))"

lemma int_of_intN_plus:
  assumes "x \<in> plus_domN" and "y \<in> plus_domN"
  shows "int_of_intN (x +n y) = int_of_intN x + int_of_intN y"
  unfolding plus_intN_def
proof (rule intN_of_int_inverse, rule int_carrier_closed_plus)
  from assms(1) show "int_of_intN x \<in> plus_dom n" by (simp only: plus_domN_iff)
next
  from assms(2) show "int_of_intN y \<in> plus_dom n" by (simp only: plus_domN_iff)
qed

lemma uminus_domN_closed_plus:
  assumes "x \<in> plus_domN" and "y \<in> plus_domN"
  shows "x +n y \<in> uminus_domN"
proof -
  from assms(1) have "int_of_intN x \<in> plus_dom n" by (simp only: plus_domN_iff)
  moreover from assms(2) have "int_of_intN y \<in> plus_dom n" by (simp only: plus_domN_iff)
  ultimately have "int_of_intN x + int_of_intN y \<in> uminus_dom n" by (rule uminus_dom_closed_plus)
  with assms show ?thesis by (simp add: int_of_intN_plus uminus_domN_iff)
qed

lemma plus_intN_zero_neutr [simp]: "x +n 0n = x" "0n +n x = x"
  by (simp_all add: plus_intN_def int_of_intN_zero int_of_intN_inverse)

lemma plus_intN_comm [ac_simps]: "x +n y = y +n x"
  by (simp add: plus_intN_def ac_simps int_of_intN_inverse)

definition uminus_intN :: "'a \<Rightarrow> 'a" ("-n _" [81] 80)
  where "uminus_intN = (\<lambda>x. intN_of_int (- int_of_intN x))"

lemma
  assumes "a \<in> A" and "sym_intervalN A"
  shows int_of_intN_uminus: "int_of_intN (-n a) = - (int_of_intN a)"
    and sym_intervalN_closed_uminus: "-n a \<in> A"
proof -
  from assms(2) have 1: "sym_interval n (int_of_intN ` A)" by (simp only: sym_intervalN_def)
  moreover from assms(1) have 2: "int_of_intN a \<in> int_of_intN ` A" by (rule imageI)
  moreover have "abs (- int_of_intN a) \<le> abs (int_of_intN a)" by simp
  ultimately have "- int_of_intN a \<in> int_of_intN ` A" by (rule sym_intervalD)
  also from 1 have "... \<subseteq> int_carrier n" by (rule sym_intervalD)
  finally show "int_of_intN (-n a) = - (int_of_intN a)"
    unfolding uminus_intN_def by (rule intN_of_int_inverse)
  also from 1 2 have "... \<in> int_of_intN ` A" by (rule sym_interval_closed_uminus)
  finally show "-n a \<in> A" using inj_int_of_intN by (simp only: inj_image_mem_iff)
qed

lemma uminus_zero_intN [simp]: "-n 0n = 0n"
  by (simp add: uminus_intN_def int_of_intN_zero intN_of_int_zero)

definition minus_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "-n" 65)
  where "minus_intN = (\<lambda>x y. intN_of_int (int_of_intN x - int_of_intN y))"

lemma int_of_intN_minus:
  assumes "x \<in> plus_domN" and "y \<in> plus_domN"
  shows "int_of_intN (x -n y) = int_of_intN x - int_of_intN y"
  unfolding minus_intN_def
proof (rule intN_of_int_inverse, rule int_carrier_closed_minus)
  from assms(1) show "int_of_intN x \<in> plus_dom n" by (simp only: plus_domN_iff)
next
  from assms(2) show "int_of_intN y \<in> plus_dom n" by (simp only: plus_domN_iff)
qed

lemma uminus_domN_closed_minus:
  assumes "x \<in> plus_domN" and "y \<in> plus_domN"
  shows "x -n y \<in> uminus_domN"
proof -
  from assms(1) have "int_of_intN x \<in> plus_dom n" by (simp only: plus_domN_iff)
  moreover from assms(2) have "int_of_intN y \<in> plus_dom n" by (simp only: plus_domN_iff)
  ultimately have "int_of_intN x - int_of_intN y \<in> uminus_dom n" by (rule uminus_dom_closed_minus)
  with assms show ?thesis by (simp add: int_of_intN_minus uminus_domN_iff)
qed

lemma minus_intN_zero_neutr [simp]: "x -n 0n = x"
  by (simp add: minus_intN_def int_of_intN_zero int_of_intN_inverse)

lemma minus_intN_inverse [simp]: "x -n x = 0n"
  by (simp add: minus_intN_def intN_of_int_zero)

lemma add_uminus_conv_diff_intN:
  assumes "x \<in> plus_domN" and "y \<in> plus_domN"
  shows "x +n (-n y) = x -n y"
proof (rule int_of_intN_inject)
  from assms(2) sym_interval_plus_domN have "-n y \<in> plus_domN"
    by (rule sym_intervalN_closed_uminus)
  with assms show "int_of_intN (x +n (-n y)) = int_of_intN (x -n y)"
    by (auto simp: int_of_intN_plus int_of_intN_minus int_of_intN_uminus)
qed

lemma uminus_plusN:
  assumes "x \<in> plus_domN" and "y \<in> plus_domN"
  shows "-n (x +n y) = (-n x) +n (-n y)"
proof (rule int_of_intN_inject)
  from assms have "x +n y \<in> uminus_domN" by (rule uminus_domN_closed_plus)
  moreover from assms(1) sym_interval_plus_domN have "-n x \<in> plus_domN"
    by (rule sym_intervalN_closed_uminus)
  moreover from assms(2) sym_interval_plus_domN have "-n y \<in> plus_domN"
    by (rule sym_intervalN_closed_uminus)
  ultimately show "int_of_intN (-n (x +n y)) = int_of_intN (-n x +n -n y)" using assms
    by (simp add: int_of_intN_uminus int_of_intN_plus)
qed

subsubsection \<open>Multiplication\<close>

definition times_domN :: "'a set"
  where "times_domN = intN_of_int ` times_dom n"

lemma int_of_intN_times_dom: "int_of_intN ` times_domN = times_dom n"
proof -
  have "int_of_intN ` times_domN = (\<lambda>a. int_of_intN (intN_of_int a)) ` times_dom n"
    by (simp only: times_domN_def image_image)
  also from refl have "... = (\<lambda>a. a) ` times_dom n"
  proof (rule image_cong)
    fix a
    assume "a \<in> times_dom n"
    hence "a \<in> int_carrier n" by (rule times_dom_subset_int_carrier)
    thus "int_of_intN (intN_of_int a) = a" by (rule intN_of_int_inverse)
  qed
  finally show ?thesis by simp
qed

lemma times_domN_iff: "x \<in> times_domN \<longleftrightarrow> int_of_intN x \<in> times_dom n"
proof
  assume "x \<in> times_domN"
  hence "int_of_intN x \<in> int_of_intN ` times_domN" by (rule imageI)
  thus "int_of_intN x \<in> times_dom n" by (simp only: int_of_intN_times_dom)
next
  assume "int_of_intN x \<in> times_dom n"
  hence "intN_of_int (int_of_intN x) \<in> intN_of_int ` times_dom n" by (rule imageI)
  thus "x \<in> times_domN" by (simp only: times_domN_def int_of_intN_inverse)
qed

lemma sym_interval_times_domN [simp]: "sym_intervalN times_domN"
  by (simp add: sym_intervalN_def int_of_intN_times_dom)

lemma times_dom_subset_plus_domN: "times_domN \<subseteq> plus_domN"
  unfolding times_domN_def plus_domN_def
proof (rule image_mono, rule)
  fix a
  assume "a \<in> times_dom n"
  with n_gr_one show "a \<in> plus_dom n" by (rule times_dom_subset_plus_dom)
qed

definition one_intN :: 'a ("1n")
  where "one_intN = intN_of_int 1"

lemma int_of_intN_one: "int_of_intN 1n = 1"
  unfolding one_intN_def
  by (rule intN_of_int_inverse, simp add: int_carrier_def)
    (smt n_gr_one one_le_power power_strict_increasing)

lemma intN_of_int_one: "intN_of_int 1 = 1n"
  by (simp add: int_of_intN_one[symmetric] int_of_intN_inverse)

definition times_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*n" 70)
  where "times_intN = (\<lambda>x y. intN_of_int (int_of_intN x * int_of_intN y))"

lemma int_of_intN_times:
  assumes "x \<in> times_domN" and "y \<in> times_domN"
  shows "int_of_intN (x *n y) = int_of_intN x * int_of_intN y"
  unfolding times_intN_def
proof (rule intN_of_int_inverse, rule int_carrier_closed_times)
  from assms(1) show "int_of_intN x \<in> times_dom n" by (simp only: times_domN_iff)
next
  from assms(2) show "int_of_intN y \<in> times_dom n" by (simp only: times_domN_iff)
qed

lemma uminus_domN_closed_times:
  assumes "x \<in> times_domN" and "y \<in> times_domN"
  shows "x *n y \<in> uminus_domN"
proof -
  from assms(1) have "int_of_intN x \<in> times_dom n" by (simp only: times_domN_iff)
  moreover from assms(2) have "int_of_intN y \<in> times_dom n" by (simp only: times_domN_iff)
  ultimately have "int_of_intN x * int_of_intN y \<in> uminus_dom n" by (rule uminus_dom_closed_times)
  with assms show ?thesis by (simp add: int_of_intN_times uminus_domN_iff)
qed

lemma times_intN_zero_annihil [simp]: "x *n 0n = 0n" "0n *n x = 0n"
  by (simp_all add: times_intN_def int_of_intN_zero intN_of_int_zero)

lemma times_intN_one_neutr [simp]: "x *n 1n = x" "1n *n x = x"
  by (simp_all add: times_intN_def int_of_intN_one int_of_intN_inverse)

lemma times_intN_comm [ac_simps]: "x *n y = y *n x"
  by (simp add: times_intN_def ac_simps int_of_intN_inverse)

lemma times_uminusN_left:
  assumes "x \<in> times_domN" and "y \<in> times_domN"
  shows "-n x *n y = -n (x *n y)"
proof (rule int_of_intN_inject)
  from assms have "x *n y \<in> uminus_domN" by (rule uminus_domN_closed_times)
  moreover from assms(1) sym_interval_times_domN have "-n x \<in> times_domN"
    by (rule sym_intervalN_closed_uminus)
  moreover from assms(2) sym_interval_times_domN have "-n y \<in> times_domN"
    by (rule sym_intervalN_closed_uminus)
  ultimately show "int_of_intN (-n x *n y) = int_of_intN (-n (x *n y))" using assms
    by (simp add: int_of_intN_uminus int_of_intN_times)
qed

corollary times_uminusN_right: "x \<in> times_domN \<Longrightarrow> y \<in> times_domN \<Longrightarrow> x *n (-n y) = -n (x *n y)"
  by (simp add: times_uminusN_left times_intN_comm[of x])

lemma uminus_times_uminusN: "x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> sym_intervalN A \<Longrightarrow> (-n x) *n (-n y) = x *n y"
  by (simp add: times_intN_def int_of_intN_uminus)

definition divide_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "divn" 70)
  where "divide_intN = (\<lambda>x y. if y = 0n then undefined else intN_of_int (int_of_intN x div int_of_intN y))"

lemma
  assumes "x \<in> A" and "y \<noteq> 0n" and "sym_intervalN A"
  shows int_of_intN_divide: "int_of_intN (x divn y) = int_of_intN x div int_of_intN y"
    and sym_intervalN_closed_divide: "x divn y \<in> A"
proof -
  from assms(3) have 1: "sym_interval n (int_of_intN ` A)" by (simp only: sym_intervalN_def)
  moreover from assms(1) have 2: "int_of_intN x \<in> int_of_intN ` A" by (rule imageI)
  ultimately have "int_of_intN x div int_of_intN y \<in> int_of_intN ` A"
    by (rule sym_interval_closed_divide)
  also from 1 have "... \<subseteq> int_carrier n" by (rule sym_intervalD)
  finally have "int_of_intN (intN_of_int (int_of_intN x div int_of_intN y)) =
                int_of_intN x div int_of_intN y"
    by (rule intN_of_int_inverse)
  with assms(2) show "int_of_intN (x divn y) = int_of_intN x div int_of_intN y"
    by (simp add: divide_intN_def)
  also from 1 2 have "... \<in> int_of_intN ` A" by (rule sym_interval_closed_divide)
  finally show "x divn y \<in> A" using inj_int_of_intN by (simp only: inj_image_mem_iff)
qed

definition modulo_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "modn" 70)
  where "modulo_intN = (\<lambda>x y. if y = 0n then undefined else intN_of_int (int_of_intN x mod int_of_intN y))"

lemma
  assumes "x \<in> A" and "y \<in> A" and "y \<noteq> 0n" and "sym_intervalN A"
  shows int_of_intN_modulo: "int_of_intN (x modn y) = int_of_intN x mod int_of_intN y"
    and sym_intervalN_closed_modulo: "x modn y \<in> A"
proof -
  from assms(4) have 1: "sym_interval n (int_of_intN ` A)" by (simp only: sym_intervalN_def)
  moreover from assms(1) have 2: "int_of_intN x \<in> int_of_intN ` A" by (rule imageI)
  moreover from assms(2) have 3: "int_of_intN y \<in> int_of_intN ` A" by (rule imageI)
  ultimately have "int_of_intN x mod int_of_intN y \<in> int_of_intN ` A"
    by (rule sym_interval_closed_modulo)
  also from 1 have "... \<subseteq> int_carrier n" by (rule sym_intervalD)
  finally have "int_of_intN (intN_of_int (int_of_intN x mod int_of_intN y)) =
                int_of_intN x mod int_of_intN y"
    by (rule intN_of_int_inverse)
  with assms(3) show "int_of_intN (x modn y) = int_of_intN x mod int_of_intN y"
    by (simp add: modulo_intN_def)
  also from 1 2 3 have "... \<in> int_of_intN ` A" by (rule sym_interval_closed_modulo)
  finally show "x modn y \<in> A" using inj_int_of_intN by (simp only: inj_image_mem_iff)
qed

definition gcd_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "gcd_intN = (\<lambda>x y. intN_of_int (gcd (int_of_intN x) (int_of_intN y)))"

definition lcm_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "lcm_intN = (\<lambda>x y. intN_of_int (lcm (int_of_intN x) (int_of_intN y)))"

lemma
  assumes "x \<in> A" and "y \<in> A" and "sym_intervalN A"
  shows int_of_intN_gcd: "int_of_intN (gcd_intN x y) = gcd (int_of_intN x) (int_of_intN y)"
    and sym_intervalN_closed_gcd: "gcd_intN x y \<in> A"
proof -
  from assms(3) have 1: "sym_interval n (int_of_intN ` A)" by (simp only: sym_intervalN_def)
  moreover from assms(1) have 2: "int_of_intN x \<in> int_of_intN ` A" by (rule imageI)
  moreover from assms(2) have 3: "int_of_intN y \<in> int_of_intN ` A" by (rule imageI)
  ultimately have "gcd (int_of_intN x) (int_of_intN y) \<in> int_of_intN ` A"
    by (rule sym_interval_closed_gcd)
  also from 1 have "... \<subseteq> int_carrier n" by (rule sym_intervalD)
  finally have "int_of_intN (intN_of_int (gcd (int_of_intN x) (int_of_intN y))) =
                gcd (int_of_intN x) (int_of_intN y)"
    by (rule intN_of_int_inverse)
  with assms(3) show "int_of_intN (gcd_intN x y) = gcd (int_of_intN x) (int_of_intN y)"
    by (simp add: gcd_intN_def)
  also from 1 2 3 have "... \<in> int_of_intN ` A" by (rule sym_interval_closed_gcd)
  finally show "gcd_intN x y \<in> A" using inj_int_of_intN by (simp only: inj_image_mem_iff)
qed

subsubsection \<open>Extended Euclidean Algorithm\<close>

fun euclid_ext_aux_intN_pred :: "('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) \<Rightarrow> bool"
  where "euclid_ext_aux_intN_pred (_, _, _, _, _, r) = (r = 0n)"

fun euclid_ext_aux_intN_base :: "('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) \<Rightarrow> (('a \<times> 'a) \<times> 'a)"
  where "euclid_ext_aux_intN_base (s', _, t', _, r', _) = ((s', t'), r')"

fun euclid_ext_aux_intN_step :: "('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a)"
  where "euclid_ext_aux_intN_step (s', s, t', t, r', r) =
            (let q = r' divn r in (s, s' -n q *n s, t, t' -n q *n t, r, r' modn r))"

definition euclid_ext_aux_intN :: "('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) \<Rightarrow> (('a \<times> 'a) \<times> 'a)"
  where "euclid_ext_aux_intN = tailrec.fun euclid_ext_aux_intN_pred euclid_ext_aux_intN_base euclid_ext_aux_intN_step"

definition euclid_ext_aux_intN_dom :: "('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) \<Rightarrow> bool"
  where "euclid_ext_aux_intN_dom = tailrec.dom euclid_ext_aux_intN_pred euclid_ext_aux_intN_step"

lemma euclid_ext_aux_intN_code [code]:
  "euclid_ext_aux_intN (s', s, t', t, r', r) = (
     if r = 0n then ((s', t'), r')
     else let q = r' divn r in euclid_ext_aux_intN (s, s' -n q *n s, t, t' -n q *n t, r, r' modn r))"
  by (simp add: euclid_ext_aux_intN_def tailrec.simps[where x="(s', s, t', t, r', r)"] Let_def)

lemma euclid_ext_aux_intN_domI_aux:
  assumes "fst (snd (snd (snd (snd args)))) \<in> A" and "snd (snd (snd (snd (snd args)))) \<in> A"
    and "sym_intervalN A"
  shows "euclid_ext_aux_intN_dom args"
  using wf_measure[of "\<lambda>(_, _, _, _, _, a). nat (int_of_intN (abs_intN a))"] assms(1, 2)
proof (induct args)
  case (less args)
  obtain s' s t' t r' r where args: "args = (s', s, t', t, r', r)" using prod.exhaust by metis
  have 1: "euclid_ext_aux_intN_dom (s0', s0, t0', t0, r0', r0)"
    if "nat (int_of_intN (abs_intN r0)) < nat (int_of_intN (abs_intN r))" and "r0' \<in> A" and "r0 \<in> A"
    for s0' s0 t0' t0 r0' r0
    using less(1) that by (simp add: args)
  from less(2) have "r' \<in> A" by (simp add: args)
  from less(3) have "r \<in> A" by (simp add: args)
  show ?case unfolding args euclid_ext_aux_intN_dom_def
  proof (rule tailrec.domI)
    assume "\<not> euclid_ext_aux_intN_pred (s', s, t', t, r', r)"
    hence "r \<noteq> 0n" by simp
    have "int_of_intN r \<noteq> 0"
    proof
      assume "int_of_intN r = 0"
      hence "intN_of_int (int_of_intN r) = intN_of_int 0" by (rule arg_cong)
      hence "r = 0n" by (simp only: int_of_intN_inverse intN_of_int_zero)
      with \<open>r \<noteq> 0n\<close> show False ..
    qed
    have "euclid_ext_aux_intN_dom (s, s' -n r' divn r *n s, t, t' -n r' divn r *n t, r, r' modn r)"
    proof (rule 1)
      from \<open>r' \<in> A\<close> \<open>r \<in> A\<close> \<open>r \<noteq> 0n\<close> assms(3) have "r' modn r \<in> A"
        and eq1: "int_of_intN (r' modn r) = int_of_intN r' mod int_of_intN r"
        by (rule sym_intervalN_closed_modulo, rule int_of_intN_modulo)
      from this(1) show "r' modn r \<in> A" .
      hence "int_of_intN (abs_intN (r' modn r)) = abs (int_of_intN (r' modn r))" using assms(3)
        by (rule int_of_intN_abs)
      also have "... = abs (int_of_intN r' mod int_of_intN r)" by (simp only: eq1)
      finally have "int_of_intN (abs_intN (r' modn r)) = abs (int_of_intN r' mod int_of_intN r)" .
      moreover from \<open>r \<in> A\<close> assms(3) have "int_of_intN (abs_intN r) = abs (int_of_intN r)"
        by (rule int_of_intN_abs)
      ultimately show "nat (int_of_intN (abs_intN (r' modn r))) < nat (int_of_intN (abs_intN r))"
        using \<open>int_of_intN r \<noteq> 0\<close> by (simp add: abs_mod_less)
    qed fact
    thus "tailrec.dom euclid_ext_aux_intN_pred euclid_ext_aux_intN_step (euclid_ext_aux_intN_step (s', s, t', t, r', r))"
      by (simp add: euclid_ext_aux_intN_dom_def Let_def)
  qed
qed

corollary euclid_ext_aux_intN_domI:
  assumes "r' \<in> A" and "r \<in> A" and "sym_intervalN A"
  shows "euclid_ext_aux_intN_dom (s', s, t', t, r', r)"
  using _ _ assms(3) by (rule euclid_ext_aux_intN_domI_aux) (simp_all add: assms)

lemma euclid_ext_aux_intN_induct [consumes 1, case_names step]:
  assumes "euclid_ext_aux_intN_dom (s', s, t', t, r', r)"
    and "(\<And>s' s t' t r' r. euclid_ext_aux_intN_dom (s', s, t', t, r', r) \<Longrightarrow>
            (\<And>q. r \<noteq> 0n \<Longrightarrow> q = r' divn r \<Longrightarrow> P (s, s' -n q *n s, t, t' -n q *n t, r, r' modn r)) \<Longrightarrow>
            P (s', s, t', t, r', r))"
  shows "P (s', s, t', t, r', r)"
  using assms(1) unfolding euclid_ext_aux_intN_dom_def
proof (rule tailrec.pinduct)
  fix x :: "'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a"
  obtain s0' s0 t0' t0 r0' r0 where x: "x = (s0', s0, t0', t0, r0', r0)" using prod.exhaust by metis
  assume 1: "tailrec.dom euclid_ext_aux_intN_pred euclid_ext_aux_intN_step x"
  assume 2: "\<not> euclid_ext_aux_intN_pred x \<Longrightarrow> P (euclid_ext_aux_intN_step x)"
  show "P x" unfolding x
  proof (rule assms(2))
    from 1 show "euclid_ext_aux_intN_dom (s0', s0, t0', t0, r0', r0)"
      by (simp only: euclid_ext_aux_intN_dom_def x)
  next
    fix q
    assume "r0 \<noteq> 0n" and q: "q = r0' divn r0"
    from this(1) have "\<not> euclid_ext_aux_intN_pred x" by (simp add: x)
    thus "P (s0, s0' -n q *n s0, t0, t0' -n q *n t0, r0, r0' modn r0)" unfolding q sorry
  qed
qed

definition inverse_intN :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "inverse_intN p a = fst (fst (euclid_ext_aux_intN (1n, 0n, 0n, 1n, a, p))) modn p"

end (* intN *)

subsection \<open>Type of 31-Bit Integers\<close>

typedef int31 = "int_carrier 31"
  morphisms int_of_int31 Int31
  using zero_in_int_carrier ..

subsubsection \<open>Type-Class Instances\<close>

instantiation int31 :: equal
begin

definition equal_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> bool" where "equal_int31 = (=)"

instance by standard (simp only: equal_int31_def)

end

instantiation int31 :: ord
begin

definition less_eq_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> bool"
  where "less_eq_int31 = (\<lambda>x y. int_of_int31 x \<le> int_of_int31 y)"

definition less_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> bool"
  where "less_int31 = (\<lambda>x y. int_of_int31 x < int_of_int31 y)"

instance ..

end

instantiation int31 :: sgn
begin

definition sgn_int31 :: "int31 \<Rightarrow> int31"
  where "sgn_int31 = (\<lambda>x. Int31 (sgn (int_of_int31 x)))"

instance ..

end

instantiation int31 :: abs
begin

definition abs_int31 :: "int31 \<Rightarrow> int31"
  where "abs_int31 = (\<lambda>x. Int31 (abs (int_of_int31 x)))"

instance ..

end

instantiation int31 :: zero
begin

definition zero_int31 :: int31
  where "zero_int31 = Int31 0"

instance ..

end

instantiation int31 :: plus
begin

definition plus_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> int31"
  where "plus_int31 = (\<lambda>x y. Int31 (int_of_int31 x + int_of_int31 y))"

instance ..

end

instantiation int31 :: uminus
begin

definition uminus_int31 :: "int31 \<Rightarrow> int31"
  where "uminus_int31 = (\<lambda>x. Int31 (- int_of_int31 x))"

instance ..

end

instantiation int31 :: minus
begin

definition minus_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> int31"
  where "minus_int31 = (\<lambda>x y. Int31 (int_of_int31 x - int_of_int31 y))"

instance ..

end

instantiation int31 :: one
begin

definition one_int31 :: int31
  where "one_int31 = Int31 1"

instance ..

end

instantiation int31 :: times
begin

definition times_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> int31"
  where "times_int31 = (\<lambda>x y. Int31 (int_of_int31 x * int_of_int31 y))"

instance ..

end

instantiation int31 :: divide
begin

definition divide_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> int31"
  where "divide_int31 = (\<lambda>x y. if y = 0 then undefined else Int31 (int_of_int31 x div int_of_int31 y))"

instance ..

end

instantiation int31 :: modulo
begin

definition modulo_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> int31"
  where "modulo_int31 = (\<lambda>x y. if y = 0 then undefined else Int31 (int_of_int31 x mod int_of_int31 y))"

instance ..

end

instantiation int31 :: gcd
begin

definition gcd_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> int31"
  where "gcd_int31 = (\<lambda>x y. Int31 (gcd (int_of_int31 x) (int_of_int31 y)))"

definition lcm_int31 :: "int31 \<Rightarrow> int31 \<Rightarrow> int31"
  where "lcm_int31 = (\<lambda>x y. Int31 (lcm (int_of_int31 x) (int_of_int31 y)))"

instance ..

end

subsubsection \<open>Interpretation of @{locale intN}\<close>

global_interpretation int31: intN 31 int_of_int31 Int31
  rewrites "int31.less_eq_intN = (\<le>)"
    and "int31.less_intN = (<)"
    and "int31.sgn_intN = sgn"
    and "int31.abs_intN = abs"
    and "int31.zero_intN = 0"
    and "int31.plus_intN = (+)"
    and "int31.uminus_intN = uminus"
    and "int31.minus_intN = (-)"
    and "int31.one_intN = 1"
    and "int31.times_intN = (*)"
    and "int31.divide_intN = (div)"
    and "int31.modulo_intN = (mod)"
    and "int31.gcd_intN = gcd"
    and "int31.lcm_intN = lcm"
  defines integer_of_int31 = int31.integer_of_intN
    and int31_of_integer = int31.intN_of_integer
    and euclid_ext_aux_int31 = int31.euclid_ext_aux_intN
    and inverse_int31 = int31.inverse_intN
proof -
  interpret i31: intN 31 int_of_int31 Int31
    by unfold_locales (simp_all add: int_of_int31_inverse Int31_inverse)
  show "intN 31 int_of_int31 Int31" ..
  show "i31.less_eq_intN = (\<le>)" by (simp only: i31.less_eq_intN_def less_eq_int31_def)
  show "i31.less_intN = (<)" by (simp only: i31.less_intN_def less_int31_def)
  show "i31.sgn_intN = sgn" by (simp only: i31.sgn_intN_def sgn_int31_def)
  show "i31.abs_intN = abs" by (simp only: i31.abs_intN_def abs_int31_def)
  show "i31.zero_intN = 0" by (simp only: i31.zero_intN_def zero_int31_def)
  show "i31.plus_intN = (+)" by (simp only: i31.plus_intN_def plus_int31_def)
  show "i31.uminus_intN = uminus" by (simp only: i31.uminus_intN_def uminus_int31_def)
  show "i31.minus_intN = (-)" by (simp only: i31.minus_intN_def minus_int31_def)
  show "i31.one_intN = 1" by (simp only: i31.one_intN_def one_int31_def)
  show "i31.times_intN = (*)" by (simp only: i31.times_intN_def times_int31_def)
  show "i31.divide_intN = (div)"
    by (simp only: i31.divide_intN_def divide_int31_def i31.zero_intN_def zero_int31_def)
  show "i31.modulo_intN = (mod)"
    by (simp only: i31.modulo_intN_def modulo_int31_def i31.zero_intN_def zero_int31_def)
  show "i31.gcd_intN = gcd" by (simp only: i31.gcd_intN_def gcd_int31_def)
  show "i31.lcm_intN = lcm" by (simp only: i31.lcm_intN_def lcm_int31_def)
qed

lemmas [code_unfold] = int31.intN_of_int_code int31.int_of_intN_code

instance int31 :: linorder
  using int31.linorder_intN by (rule Orderings.class.Orderings.linorder.of_class.intro)

instantiation int31 :: term_of
begin

definition term_of_int31 :: "int31 \<Rightarrow> term"
  where "term_of_int31 = (\<lambda>x. term_of_class.term_of (integer_of_int31 x))"

instance ..

end

thm int31.int_of_intN_abs int31.sym_intervalN_closed_abs

thm int31.int_of_intN_zero int31.intN_of_int_zero
thm int31.int_of_intN_plus int31.plus_intN_zero_neutr int31.plus_intN_comm
thm int31.int_of_intN_uminus int31.sym_intervalN_closed_uminus int31.uminus_zero_intN
thm int31.int_of_intN_minus int31.minus_intN_zero_neutr int31.minus_intN_inverse
    int31.add_uminus_conv_diff_intN

thm int31.int_of_intN_one int31.intN_of_int_one
thm int31.int_of_intN_times int31.times_intN_zero_annihil int31.times_intN_one_neutr
    int31.times_intN_comm int31.times_uminusN_left int31.times_uminusN_right
    int31.uminus_times_uminusN
thm int31.int_of_intN_divide
thm int31.int_of_intN_modulo

thm int31.int_of_intN_gcd

subsection \<open>Code Generation\<close>

code_printing
  type_constructor int31 \<rightharpoonup>
    (SML) "Int31.int" |
  constant "plus :: int31 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "!((_ : Int31.int) + _)" |
  constant "minus :: int31 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "!((_ : Int31.int) - _)" |
  constant "uminus :: int31 \<Rightarrow> _" \<rightharpoonup>
    (SML) "(~)" |
  constant "times :: int31 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "!((_ : Int31.int) * _)" |
  constant "divide :: int31 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "!(Int31.div ((_ : Int31.int), _))" |
  constant "modulo :: int31 \<Rightarrow> _" \<rightharpoonup>
    (SML) "!(Int31.mod ((_ : Int31.int), _))" |
  constant "0 :: int31" \<rightharpoonup>
    (SML) "!(0 : Int31.int)" |
  constant "1 :: int31" \<rightharpoonup>
    (SML) "!(1 : Int31.int)" |
  constant "HOL.equal :: int31 \<Rightarrow> _" \<rightharpoonup>
    (SML) "!((_ : Int31.int) = _)" |
  constant "integer_of_int31" \<rightharpoonup>
    (SML) "IntInf.fromInt (Int31.toInt _)" |
  constant "int31_of_integer" \<rightharpoonup>
    (SML) "Int31.fromInt (IntInf.toInt _)"

declare [[code drop:
      "uminus :: int31 \<Rightarrow> _"
      "plus :: int31 \<Rightarrow> _"
      "minus :: int31 \<Rightarrow> _"
      "times :: int31 \<Rightarrow> _"
      "divide :: int31 \<Rightarrow> _"
      "modulo :: int31 \<Rightarrow> _"
      "abs :: int31 \<Rightarrow> _"
      "gcd :: int31 \<Rightarrow> _"
      "lcm :: int31 \<Rightarrow> _"
      "int31_of_integer"
      "integer_of_int31"]]

value [code] "- Int31 1"

value [code] "(Int31 32003) div (Int31 537)"

value [code] "timing (((divide (Int31 32003)) ^^ 1000000) (Int31 5637))"

value [code] "(Int31 32003) = (Int31 5637)"

value [code] "timing (inverse_int31 (Int31 32003) ((Int31 32002) * (inverse_int31 (Int31 32003) (Int31 5637))))"

export_code "euclid_ext_aux_int31" in SML module_name Euclid

value [code] "timing (((inverse_int31 (Int31 32003)) ^^ 100000) (Int31 5637))"

value [code] "1 div (1::int31)"

end


(*<*)
theory As_Let_Extension
imports
   Main
   "HOL-Eisbach.Eisbach"
   "HOL-Eisbach.Eisbach_Tools"
   "List-Index.List_Index"
   "List_extra"
begin
(*>*)

section{* Ascription and Let Binding  *}

text{*
  This section will present the extended lambda calculus with ascription and let binding, and some examples
*}

datatype ltype =
  Bool |
  T (num:nat) |
  Unit |
  Fun (domain: ltype) (codomain: ltype) (infixr "\<rightarrow>" 225)

datatype lterm =
  LTrue |
  LFalse |
  LIf (bool_expr: lterm) (then_expr: lterm) (else_expr: lterm) |
  LVar nat |
  LAbs (arg_type: ltype) (body: lterm) |
  LApp lterm lterm |
  unit |
  Seq (fp: lterm) (sp: lterm) ("(_;;_)" [100,50] 200) |
  AS lterm ltype ("_/ as/ _" [100,150] 200) |
  LetBinder lterm lterm ("Let/ (_)/ in/ (_)" [120,150] 250)

primrec shift_L :: "int \<Rightarrow> nat \<Rightarrow> lterm \<Rightarrow> lterm" where
  "shift_L d c LTrue = LTrue" |
  "shift_L d c LFalse = LFalse" |
  "shift_L d c (LIf t1 t2 t3) = LIf (shift_L d c t1) (shift_L d c t2) (shift_L d c t3)" |
  "shift_L d c (LVar k) = LVar (if k < c then k else nat (int k + d))" |
  "shift_L d c (LAbs T' t) = LAbs T' (shift_L d (Suc c) t)" |
  "shift_L d c (LApp t1 t2) = LApp (shift_L d c t1) (shift_L d c t2)" |
  "shift_L d c unit = unit" |
  "shift_L d c (Seq t1 t2) = Seq (shift_L d c t1) (shift_L d c t2)" |
  "shift_L d c (t as A) = (shift_L d c t) as A" |
  "shift_L d c (Let t in t1) = Let (shift_L d c t) in (shift_L d (Suc c) t1)"

primrec subst_L :: "nat \<Rightarrow> lterm \<Rightarrow> lterm \<Rightarrow> lterm" where
  "subst_L j s LTrue = LTrue" |
  "subst_L j s LFalse = LFalse" |
  "subst_L j s (LIf t1 t2 t3) = LIf (subst_L j s t1) (subst_L j s t2) (subst_L j s t3)" |
  "subst_L j s (LVar k) = (if k = j then s else LVar k)" |
  "subst_L j s (LAbs T' t) = LAbs T' (subst_L (Suc j) (shift_L 1 0 s) t)" |
  "subst_L j s (LApp t1 t2) = LApp (subst_L j s t1) (subst_L j s t2)" |
  "subst_L j s unit = unit" |
  "subst_L j s (Seq t1 t2) = Seq (subst_L j s t1) (subst_L j s t2)" |
  "subst_L j s (t as A) = (subst_L j s t) as A" |
  "subst_L j s (Let t in t1) =
  (Let (subst_L j s t) in (subst_L (Suc j) (shift_L 1 0 s) t1))"

inductive is_value_L :: "lterm \<Rightarrow> bool" where
  "is_value_L LTrue" |
  "is_value_L LFalse" |
  "is_value_L (LAbs T' t)" |
  "is_value_L unit"

primrec FV :: "lterm \<Rightarrow> nat set" where
  "FV LTrue = {}" |
  "FV LFalse = {}" |
  "FV (LIf t1 t2 t3) = FV t1 \<union> FV t2 \<union> FV t3" |
  "FV (LVar x) = {x}" |
  "FV (LAbs T1 t) = image (\<lambda>x. x - 1) (FV t - {0})" |
  "FV (LApp t1 t2) = FV t1 \<union> FV t2" |
  "FV unit = {}" |
  "FV (Seq t1 t2) = FV t1 \<union> FV t2" |
  "FV (t as A) = FV t" |
  "FV (Let t in t1) =
    FV t \<union> image (\<lambda>x. x - 1) (FV t1 - {0})"

inductive eval1_L :: "lterm \<Rightarrow> lterm \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of Booleans\<close>
  eval1_LIf_LTrue:
    "eval1_L (LIf LTrue t2 t3) t2" |
  eval1_LIf_LFalse:
    "eval1_L (LIf LFalse t2 t3) t3" |
  eval1_LIf:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LIf t1 t2 t3) (LIf t1' t2 t3)" |

  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_LApp1:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LApp t1 t2) (LApp t1' t2)" |
  eval1_LApp2:
    "is_value_L v1 \<Longrightarrow> eval1_L t2 t2' \<Longrightarrow> eval1_L (LApp v1 t2) (LApp v1 t2')" |
  eval1_LApp_LAbs:
    "is_value_L v2 \<Longrightarrow> eval1_L (LApp (LAbs T' t12) v2)
      (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 v2) t12))" |

  \<comment> \<open>Rules relating to evaluation of sequence\<close>

  eval1_L_Seq:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (Seq t1 t2) (Seq t1' t2)" |
  eval1_L_Seq_Next:
    "eval1_L (Seq unit t2) t2" |

  \<comment> \<open>Rules relating to evaluation of ascription\<close>
  eval1_L_Ascribe:
    "is_value_L v \<Longrightarrow> eval1_L (v as A) v" |
  eval1_L_Ascribe1:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (t1 as A) (t1' as A)" |

  \<comment> \<open>Rules relating to evaluation of letbinder\<close>
  eval1_L_LetV:
    "is_value_L v1 \<Longrightarrow> eval1_L (Let v1 in t2) (subst_L 0 v1 t2)" |
  eval1_L_Let:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (Let t1 in t2) (Let t1' in t2)"

type_synonym lcontext = "ltype list"

notation Nil ("\<emptyset>")
abbreviation cons :: "lcontext \<Rightarrow> ltype \<Rightarrow> lcontext" (infixl "|,|" 200) where
  "cons \<Gamma> T' \<equiv> T' # \<Gamma>"
abbreviation elem' :: "(nat \<times> ltype) \<Rightarrow> lcontext \<Rightarrow> bool" (infix "|\<in>|" 200) where
  "elem' p \<Gamma> \<equiv> fst p < length \<Gamma> \<and> snd p = nth \<Gamma> (fst p)"

inductive has_type_L :: "lcontext \<Rightarrow> lterm \<Rightarrow> ltype \<Rightarrow> bool" ("((_)/ \<turnstile> (_)/ |:| (_))" [150, 150, 150] 150) where
  \<comment> \<open>Rules relating to the type of Booleans\<close>
  has_type_LTrue:
    "\<Gamma> \<turnstile> LTrue |:| Bool" |
  has_type_LFalse:
    "\<Gamma> \<turnstile> LFalse |:| Bool" |
  has_type_LIf:
    "\<Gamma> \<turnstile> t1 |:| Bool \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T' \<Longrightarrow> \<Gamma> \<turnstile> t3 |:| T' \<Longrightarrow> \<Gamma> \<turnstile> (LIf t1 t2 t3) |:| T'" |

  \<comment> \<open>Rules relating to the type of the constructs of the $\lambda$-calculus\<close>
  has_type_LVar:
    "(x, T') |\<in>| \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> (LVar x) |:| (T')" |
  has_type_LAbs:
    "(\<Gamma> |,| T1) \<turnstile> t2 |:| T2 \<Longrightarrow> \<Gamma> \<turnstile> (LAbs T1 t2) |:| (T1 \<rightarrow> T2)" |
  has_type_LApp:
    "\<Gamma> \<turnstile> t1 |:| (T11 \<rightarrow> T12) \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T11 \<Longrightarrow> \<Gamma> \<turnstile> (LApp t1 t2) |:| T12" |
  has_type_LUnit:
    "\<Gamma> \<turnstile> unit |:| Unit " |
  has_type_LSeq:
    "\<Gamma> \<turnstile> t1 |:| Unit \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| A \<Longrightarrow> \<Gamma> \<turnstile> (Seq t1 t2) |:| A" |
  has_type_LAscribe:
    "\<Gamma> \<turnstile> t1 |:| A \<Longrightarrow> \<Gamma> \<turnstile> t1 as A |:| A" |
  has_type_Let:
    "\<Gamma> \<turnstile> t1 |:| A \<Longrightarrow>(\<Gamma>|,|A) \<turnstile> t2 |:| B \<Longrightarrow> \<Gamma> \<turnstile> Let t1 in t2 |:| B"

lemma inversion:
  "\<Gamma> \<turnstile> LTrue |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile> LFalse |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile> LIf t1 t2 t3 |:| R \<Longrightarrow> \<Gamma> \<turnstile> t1 |:| Bool \<and> \<Gamma> \<turnstile> t2 |:| R \<and> \<Gamma> \<turnstile> t3 |:| R"
  "\<Gamma> \<turnstile> LVar x |:| R \<Longrightarrow> (x, R) |\<in>| \<Gamma>"
  "\<Gamma> \<turnstile> LAbs T1 t2 |:| R \<Longrightarrow> \<exists>R2. R = T1 \<rightarrow> R2 \<and> \<Gamma> |,| T1 \<turnstile> t2 |:| R2"
  "\<Gamma> \<turnstile> LApp t1 t2 |:| R \<Longrightarrow> \<exists>T11. \<Gamma> \<turnstile> t1 |:| T11 \<rightarrow> R \<and> \<Gamma> \<turnstile> t2 |:| T11"
  "\<Gamma> \<turnstile> unit |:| R \<Longrightarrow> R = Unit"
  "\<Gamma> \<turnstile> Seq t1 t2 |:| R \<Longrightarrow> \<exists>A. R = A \<and> \<Gamma> \<turnstile> t2 |:| A \<and> \<Gamma> \<turnstile> t1 |:| Unit"
  "\<Gamma> \<turnstile> t as A |:| R \<Longrightarrow> R = A"
  "\<Gamma> \<turnstile> Let t in t1 |:| R \<Longrightarrow> \<exists>A B. R = B \<and> \<Gamma> \<turnstile> t |:| A \<and> (\<Gamma>|,|A) \<turnstile> t1 |:| B"
by (auto elim: has_type_L.cases)

lemma canonical_forms:
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| Bool \<Longrightarrow> v = LTrue \<or> v = LFalse"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t. v = LAbs T1 t"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| Unit \<Longrightarrow> v = unit"
by (auto elim: has_type_L.cases is_value_L.cases)

lemma weakening:
  "\<Gamma> \<turnstile> t |:| A \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> insert_nth n S \<Gamma> \<turnstile> shift_L 1 n t |:| A"
proof (induction \<Gamma> t A arbitrary: n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t2 T2)
    from has_type_LAbs.prems has_type_LAbs.hyps
      has_type_LAbs.IH[where n="Suc n"] show ?case
      by (auto intro: has_type_L.intros(5))
next
  case (has_type_Let \<Gamma> t A t1 B)
    then show ?case
      using has_type_L.intros(10)
      by fastforce
qed (auto simp: nth_append min_def intro: has_type_L.intros)

subsection{* Ascription*}

(*Exercise 11.4.1*)
text{* Instead of adding As as instruction of our lambda calculus, we can use the following derived form*}

abbreviation AS_D :: "lterm \<Rightarrow> ltype \<Rightarrow> lterm" (infix "asE" 200) where
"t asE A \<equiv> LApp (LAbs A (LVar 0)) t"

lemma eval1_L_asE:
  "eval1_L t1 t2 \<Longrightarrow> eval1_L (t1 asE A) (t2 asE A)"
by (auto intro: eval1_LApp2 "is_value_L.intros"(3))

lemma shift_shift_invert: "a>0 \<Longrightarrow> shift_L (-a) b (shift_L a b t) = t"
by (induction t arbitrary: a b, auto)

lemma eval1_L_asE1:
  "is_value_L t1 \<Longrightarrow> eval1_L (t1 asE A) t1"
using eval1_LApp_LAbs[of t1 A "LVar 0"] shift_shift_invert[of 1 0 t1]
by auto

end


theory Test_Exam imports SeCaV begin

(* REPLACE $$$$$ WITH LEMMA/PROOF *)

lemma  \<open>\<tturnstile>
  [
    Imp (Neg (Neg (Pre 0 [])))  (Pre 0 [])
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Neg (Neg (Pre 0 []))),
      (Pre 0 [])
    ]
    \<close>
    using that by simp
  with Neg have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 []),
      Pre 0 []

    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [],
      Neg  (Pre 0 [])

    ]
    \<close>
    using that by simp

  with Basic show ?thesis
    by simp
qed

lemma \<open>\<tturnstile>
  [
    Imp (Uni (Pre 0 [Var 0])) (Con (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []]))
  ]
  \<close>
proof -
     from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])) ,
      (Con (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []]))
    ]
    \<close>
     using that by simp

  with Ext have ?thesis if \<open>\<tturnstile>
    [

      Con (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []]),
      Neg (Uni (Pre 0 [Var 0]))
    ]
    \<close>
    using that by simp
  with BetaCon have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0 []],
     Neg (Uni (Pre 0 [Var 0]))
    ]
    \<close> and  \<open>\<tturnstile>
    [
      Pre 0 [Fun 1 []] ,
     Neg (Uni (Pre 0 [Var 0]))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])),
      Pre 0 [Fun 0 []]
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])),
      Pre 0 [Fun 1 []]
    ]
    \<close>
    using that by simp
  with GammaUni have ?thesis if \<open>\<tturnstile>
  [
      Neg (Pre 0 [Fun 0 []]),
      Pre 0 [Fun 0 []]

    ]
    \<close> and  \<open>\<tturnstile>
    [
     Neg (Pre 0 [Fun 1[]]),
      Pre 0 [Fun 1 []]
    ]
    \<close>
    using that by simp

  with Ext have ?thesis if \<open>\<tturnstile>
  [      Pre 0 [Fun 0 []],
      Neg (Pre 0 [Fun 0 []])

    ]
    \<close> and  \<open>\<tturnstile>
    [
    Pre 0 [Fun 1 []],
     Neg (Pre 0 [Fun 1[]])

    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp

qed

proposition \<open>p a \<longrightarrow> (\<exists>x. p x)\<close> by metis
lemma \<open>\<tturnstile>
  [
    Imp (Pre 0 [Fun 0[]]) (Exi (Pre 0 [ Var 0]))
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0[]]),
      Exi (Pre 0 [ Var 0])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
       Exi (Pre 0 [ Var 0]),
       Neg (Pre 0 [Fun 0[]])
    ]
    \<close>
    using that by simp
 with GammaExi have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [ Fun 0[]],
      Neg (Pre 0 [Fun 0[]])

    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

proposition \<open>(\<forall>x y. p x y) \<longrightarrow> (\<forall>x. p x x)\<close> by metis
lemma \<open>\<tturnstile>
  [
    Imp (Uni (Uni (Pre 0 [Var 0, Var 1]))) (Uni (Pre 0 [ Var 0,Var 0]))
  ]
  \<close>
proof -
 from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Uni (Uni (Pre 0 [Var 0, Var 1]))),
      Uni (Pre 0 [ Var 0,Var 0])
    ]
    \<close>
   using that by simp

  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Uni (Pre 0 [ Var 0,Var 0]),
      Neg (Uni (Uni (Pre 0 [Var 0, Var 1])))
    ]
    \<close>
    using that by simp
 with DeltaUni have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [ Fun 0 [],Fun 0 []],
      Neg (Uni (Uni (Pre 0 [Var 0, Var 1])))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
       Neg (Uni (Uni (Pre 0 [Var 0, Var 1]))),
       Pre 0 [ Fun 0 [],Fun 0 []]
    ]
    \<close>
    using that by simp
with GammaUni[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0 [], Fun 0 []]),
       Pre 0 [ Fun 0 [],Fun 0 []]
    ]
    \<close>
    using that by simp
 with Ext have ?thesis if \<open>\<tturnstile>
    [
            Pre 0 [ Fun 0 [],Fun 0 []]  ,
         Neg (Pre 0 [Fun 0 [], Fun 0 []])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

proposition \<open>p a \<and> (p a \<longrightarrow> (\<forall>x. p x)) \<longrightarrow> (\<forall>x. p x)\<close> by metis
lemma \<open>\<tturnstile>
  [
  Imp
    (Con (Pre 0 [Fun 0 []])  (Imp (Pre 0 [Fun 0 []]) (Uni (Pre 0 [Var 0]))))
    (Uni (Pre 0 [Var 0]))
  ]
  \<close>
proof -
   from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg  (Con (Pre 0 [Fun 0 []])  (Imp (Pre 0 [Fun 0 []]) (Uni (Pre 0 [Var 0])))),
      Uni (Pre 0 [Var 0])
    ]
    \<close>
     using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
        Neg  (Con (Pre 0 [Fun 0 []])  (Imp (Pre 0 [Fun 0 []]) (Uni (Pre 0 [Var 0])))),
        Uni (Pre 0 [Var 0])
    ]
    \<close>
    using that by simp
  with AlphaCon have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0 []]),
      Neg (Imp (Pre 0 [Fun 0 []]) (Uni (Pre 0 [Var 0]))),
        Uni (Pre 0 [Var 0])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
        Neg (Imp (Pre 0 [Fun 0 []]) (Uni (Pre 0 [Var 0]))),
        Neg (Pre 0 [Fun 0 []]),
        Uni (Pre 0 [Var 0])
    ]
    \<close>
    using that by simp

  with BetaImp have ?thesis if \<open>\<tturnstile>
    [
        Pre 0 [Fun 0 []],
        Neg (Pre 0 [Fun 0 []]),
        Uni (Pre 0 [Var 0])
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])),
        Neg (Pre 0 [Fun 0 []]),
        Uni (Pre 0 [Var 0])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
        Pre 0 [Fun 0 []],
        Neg (Pre 0 [Fun 0 []])
    ]
    \<close> and \<open>\<tturnstile>
    [
        Uni (Pre 0 [Var 0]),
        Neg (Uni (Pre 0 [Var 0]))
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

end


(*  Title:      HOL/Typedef.thy
    Author:     Markus Wenzel, TU Munich
*)

section \<open>HOL type definitions\<close>

theory Typedef
imports Set
keywords
  "typedef" :: thy_goal_defn and
  "morphisms" :: quasi_command
begin

locale type_definition =
  fixes Rep and Abs and A
  assumes Rep: "Rep x \<in> A"
    and Rep_inverse: "Abs (Rep x) = x"
    and Abs_inverse: "y \<in> A \<Longrightarrow> Rep (Abs y) = y"
  \<comment> \<open>This will be axiomatized for each typedef!\<close>
begin

lemma Rep_inject: "Rep x = Rep y \<longleftrightarrow> x = y"
proof
  assume "Rep x = Rep y"
  then have "Abs (Rep x) = Abs (Rep y)" by (simp only:)
  moreover have "Abs (Rep x) = x" by (rule Rep_inverse)
  moreover have "Abs (Rep y) = y" by (rule Rep_inverse)
  ultimately show "x = y" by simp
next
  assume "x = y"
  then show "Rep x = Rep y" by (simp only:)
qed

lemma Abs_inject:
  assumes "x \<in> A" and "y \<in> A"
  shows "Abs x = Abs y \<longleftrightarrow> x = y"
proof
  assume "Abs x = Abs y"
  then have "Rep (Abs x) = Rep (Abs y)" by (simp only:)
  moreover from \<open>x \<in> A\<close> have "Rep (Abs x) = x" by (rule Abs_inverse)
  moreover from \<open>y \<in> A\<close> have "Rep (Abs y) = y" by (rule Abs_inverse)
  ultimately show "x = y" by simp
next
  assume "x = y"
  then show "Abs x = Abs y" by (simp only:)
qed

lemma Rep_cases [cases set]:
  assumes "y \<in> A"
    and hyp: "\<And>x. y = Rep x \<Longrightarrow> P"
  shows P
proof (rule hyp)
  from \<open>y \<in> A\<close> have "Rep (Abs y) = y" by (rule Abs_inverse)
  then show "y = Rep (Abs y)" ..
qed

lemma Abs_cases [cases type]:
  assumes r: "\<And>y. x = Abs y \<Longrightarrow> y \<in> A \<Longrightarrow> P"
  shows P
proof (rule r)
  have "Abs (Rep x) = x" by (rule Rep_inverse)
  then show "x = Abs (Rep x)" ..
  show "Rep x \<in> A" by (rule Rep)
qed

lemma Rep_induct [induct set]:
  assumes y: "y \<in> A"
    and hyp: "\<And>x. P (Rep x)"
  shows "P y"
proof -
  have "P (Rep (Abs y))" by (rule hyp)
  moreover from y have "Rep (Abs y) = y" by (rule Abs_inverse)
  ultimately show "P y" by simp
qed

lemma Abs_induct [induct type]:
  assumes r: "\<And>y. y \<in> A \<Longrightarrow> P (Abs y)"
  shows "P x"
proof -
  have "Rep x \<in> A" by (rule Rep)
  then have "P (Abs (Rep x))" by (rule r)
  moreover have "Abs (Rep x) = x" by (rule Rep_inverse)
  ultimately show "P x" by simp
qed

lemma Rep_range: "range Rep = A"
proof
  show "range Rep \<subseteq> A" using Rep by (auto simp add: image_def)
  show "A \<subseteq> range Rep"
  proof
    fix x assume "x \<in> A"
    then have "x = Rep (Abs x)" by (rule Abs_inverse [symmetric])
    then show "x \<in> range Rep" by (rule range_eqI)
  qed
qed

lemma Abs_image: "Abs ` A = UNIV"
proof
  show "Abs ` A \<subseteq> UNIV" by (rule subset_UNIV)
  show "UNIV \<subseteq> Abs ` A"
  proof
    fix x
    have "x = Abs (Rep x)" by (rule Rep_inverse [symmetric])
    moreover have "Rep x \<in> A" by (rule Rep)
    ultimately show "x \<in> Abs ` A" by (rule image_eqI)
  qed
qed

end

ML_file \<open>Tools/typedef.ML\<close>

end


text
\<open>This theory formalizes some of the results appearing in the paper "Stellar Consensus By Reduction"\cite{disc_paper}.
We prove static properties of personal Byzantine quorum systems and Stellar quorum systems.\<close>

theory Stellar_Quorums
  imports Main
begin

section "Personal Byzantine quorum systems"

locale personal_quorums =
  fixes quorum_of :: "'node \<Rightarrow> 'node set \<Rightarrow> bool"
  assumes quorum_assm:"\<And> p p' . \<lbrakk>quorum_of p Q; p' \<in> Q\<rbrakk> \<Longrightarrow> quorum_of p' Q"
    \<comment> \<open>In other words, a quorum (of some participant) is a quorum of all its members.\<close>
begin

definition blocks where
  \<comment> \<open>Set @{term R} blocks participant @{term p}.\<close>
  "blocks R p \<equiv> \<forall> Q . quorum_of p Q \<longrightarrow> Q \<inter> R \<noteq> {}"

abbreviation blocked_by where "blocked_by R \<equiv> {p . blocks R p}"

lemma blocked_blocked_subset_blocked:
  "blocked_by (blocked_by R) \<subseteq> blocked_by R"
proof -
  have False if "p \<in> blocked_by (blocked_by R)" and "p \<notin> blocked_by R" for p
  proof -
    have "Q \<inter> blocked_by R \<noteq> {}" if "quorum_of p Q" for Q
      using \<open>p \<in> blocked_by (blocked_by R)\<close> that unfolding blocks_def by auto
    have "Q \<inter> R \<noteq> {}" if " quorum_of p Q" for Q
    proof -
      obtain p' where "p' \<in> blocked_by R" and "p' \<in> Q"
        by (meson Int_emptyI \<open>\<And>Q. quorum_of p Q \<Longrightarrow> Q \<inter> blocked_by R \<noteq> {}\<close> \<open>quorum_of p Q\<close>)
      hence "quorum_of p' Q"
        using quorum_assm that by blast
      with \<open>p' \<in> blocked_by R\<close> show "Q \<inter> R \<noteq> {}"
        using blocks_def by auto
    qed
    hence "p \<in> blocked_by R" by (simp add: blocks_def)
    thus False using that(2) by auto
  qed
  thus "blocked_by (blocked_by R) \<subseteq> blocked_by R"
    by blast
qed

end

text \<open>We now add the set of correct participants to the model.\<close>

locale with_w = personal_quorums quorum_of for quorum_of  :: "'node \<Rightarrow> 'node set \<Rightarrow> bool" +
  fixes W::"'node set" \<comment> \<open>@{term W} is the set of correct participants\<close>
begin

abbreviation B where "B \<equiv> -W"
  \<comment> \<open>@{term B} is the set of malicious participants.\<close>

definition quorum_of_set where "quorum_of_set S Q \<equiv> \<exists> p \<in> S . quorum_of p Q"

subsection "The set of participants not blocked by malicious participants"

definition L where "L \<equiv> W - (blocked_by B)"

lemma l2: "p \<in> L \<Longrightarrow> \<exists> Q  \<subseteq> W. quorum_of p Q"
  unfolding L_def blocks_def using DiffD2 by auto

lemma l3: \<comment>  \<open>If a participant is not blocked by the malicious participants, then it has a quorum consisting exclusively of correct
participants which are not blocked by the malicious participants.\<close>
  assumes "p \<in> L" shows "\<exists> Q \<subseteq> L . quorum_of p Q"
proof -
  have False if "\<And> Q . quorum_of p Q \<Longrightarrow> Q \<inter> (-L) \<noteq> {}"
  proof -
    obtain Q where "quorum_of p Q" and "Q \<subseteq> W"
      using l2 \<open>p \<in> L\<close> by auto
    have "Q \<inter> (-L) \<noteq> {}"  using that \<open>quorum_of p Q\<close> by simp
    obtain p' where "p' \<in> Q \<inter> (-L)" and "quorum_of p' Q"
      using \<open>Q \<inter> - L \<noteq> {}\<close> \<open>quorum_of p Q\<close> inf.left_idem quorum_assm by fastforce
    hence "Q \<inter> B \<noteq> {}" unfolding L_def
      using CollectD Compl_Diff_eq Int_iff inf_le1 personal_quorums.blocks_def personal_quorums_axioms subset_empty by fastforce
    thus False using \<open>Q \<subseteq> W\<close> by auto
  qed
  thus ?thesis by (metis disjoint_eq_subset_Compl double_complement)
qed

subsection "Consensus clusters and intact sets"

definition is_intertwined where
  \<comment> \<open>This definition is not used in this theory,
    but we include it to formalize the notion of intertwined set appearing in the DISC paper.\<close>
  "is_intertwined S \<equiv> S \<subseteq> W
    \<and> (\<forall> Q Q' . quorum_of_set S Q \<and> quorum_of_set S Q' \<longrightarrow> W \<inter> Q \<inter> Q' \<noteq> {})"

definition is_cons_cluster where
  \<comment> \<open>Consensus clusters\<close>
  "is_cons_cluster C \<equiv> C \<subseteq> W \<and> (\<forall> p \<in> C . \<exists> Q \<subseteq> C . quorum_of p Q)
      \<and> (\<forall> Q Q' . quorum_of_set C Q \<and> quorum_of_set C Q' \<longrightarrow> W \<inter> Q \<inter> Q' \<noteq> {})"

definition strong_consensus_cluster where
  "strong_consensus_cluster I \<equiv> I \<subseteq> W \<and> (\<forall> p \<in> I . \<exists> Q \<subseteq> I . quorum_of p Q)
      \<and> (\<forall> Q Q' . quorum_of_set I Q \<and> quorum_of_set I Q' \<longrightarrow> I \<inter> Q \<inter> Q' \<noteq> {})"

lemma strong_consensus_cluster_imp_cons_cluster:
\<comment> \<open>Every intact set is a consensus cluster\<close>
  shows "strong_consensus_cluster I \<Longrightarrow> is_cons_cluster I"
  unfolding strong_consensus_cluster_def is_cons_cluster_def
  by blast

lemma cons_cluster_neq_cons_cluster:
  \<comment> \<open>Some consensus clusters are not strong consensus clusters and have no superset that is a strong consensus cluster.\<close>
  shows "is_cons_cluster I \<and> (\<forall> J . I \<subseteq> J \<longrightarrow> \<not>strong_consensus_cluster J)" nitpick[falsify=false, card 'node=3, expect=genuine]
  oops

text \<open>Next we show that the union of two consensus clusters that intersect is a consensus cluster.\<close>

theorem cluster_union:
  assumes "is_cons_cluster C\<^sub>1" and "is_cons_cluster C\<^sub>2" and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}"
  shows "is_cons_cluster (C\<^sub>1\<union> C\<^sub>2)"
proof -
  have "C\<^sub>1 \<union> C\<^sub>2 \<subseteq> W"
    using assms(1) assms(2) is_cons_cluster_def by auto
  moreover
  have "\<forall> p \<in> (C\<^sub>1\<union>C\<^sub>2) . \<exists> Q \<subseteq> (C\<^sub>1\<union>C\<^sub>2) . quorum_of p Q"
    using \<open>is_cons_cluster C\<^sub>1\<close> \<open>is_cons_cluster C\<^sub>2\<close> unfolding is_cons_cluster_def
    by (meson UnE le_supI1 le_supI2)
  moreover
  have "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}"
    if "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1" and "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2"
    for Q\<^sub>1 Q\<^sub>2
  proof -
    have "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
      using \<open>is_cons_cluster C\<^sub>1\<close> \<open>is_cons_cluster C\<^sub>2\<close> \<open>quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1\<close> \<open>quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2\<close> that
      unfolding quorum_of_set_def is_cons_cluster_def by metis
    moreover
    have \<open>W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}\<close>  if "is_cons_cluster C\<^sub>1" and "is_cons_cluster C\<^sub>2"
      and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}" and "quorum_of_set C\<^sub>1 Q\<^sub>1" and "quorum_of_set C\<^sub>2 Q\<^sub>2"
    for C\<^sub>1 C\<^sub>2 \<comment> \<open>We generalize to avoid repeating the argument twice\<close>
    proof -
      obtain p Q where "quorum_of p Q" and "p \<in> C\<^sub>1 \<inter> C\<^sub>2" and "Q \<subseteq> C\<^sub>2"
        using \<open>C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}\<close> \<open>is_cons_cluster C\<^sub>2\<close> unfolding is_cons_cluster_def by blast
      have "Q \<inter> Q\<^sub>1 \<noteq> {}" using \<open>is_cons_cluster C\<^sub>1\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> \<open>quorum_of p Q\<close> \<open>p \<in> C\<^sub>1 \<inter> C\<^sub>2\<close>
        unfolding is_cons_cluster_def quorum_of_set_def
        by (metis Int_assoc Int_iff inf_bot_right)
      hence "quorum_of_set C\<^sub>2 Q\<^sub>1"  using \<open>Q \<subseteq> C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> quorum_assm unfolding quorum_of_set_def by blast
      thus "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" using \<open>is_cons_cluster C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>2 Q\<^sub>2\<close>
        unfolding is_cons_cluster_def by blast
    qed
    ultimately show ?thesis using assms that unfolding quorum_of_set_def by auto
  qed
  ultimately show ?thesis using assms
    unfolding is_cons_cluster_def by simp
qed

text \<open>Similarly, the union of two strong consensus clusters is a strong consensus cluster.\<close>
lemma strong_cluster_union:
  assumes "strong_consensus_cluster C\<^sub>1" and "strong_consensus_cluster C\<^sub>2" and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}"
  shows "strong_consensus_cluster (C\<^sub>1\<union> C\<^sub>2)"
proof -
  have "C\<^sub>1 \<union> C\<^sub>2 \<subseteq> W"
    using assms(1) assms(2) strong_consensus_cluster_def by auto
  moreover
  have "\<forall> p \<in> (C\<^sub>1\<union>C\<^sub>2) . \<exists> Q \<subseteq> (C\<^sub>1\<union>C\<^sub>2) . quorum_of p Q"
    using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> unfolding strong_consensus_cluster_def
    by (meson UnE le_supI1 le_supI2)
  moreover
  have "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}"
    if "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1" and "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2"
    for Q\<^sub>1 Q\<^sub>2
  proof -
    have "C \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
      using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> that
      unfolding quorum_of_set_def strong_consensus_cluster_def by metis
    hence "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
      by (metis Int_Un_distrib2 disjoint_eq_subset_Compl sup.boundedE that)
    moreover
    have \<open>(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}\<close>  if "strong_consensus_cluster C\<^sub>1" and "strong_consensus_cluster C\<^sub>2"
      and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}" and "quorum_of_set C\<^sub>1 Q\<^sub>1" and "quorum_of_set C\<^sub>2 Q\<^sub>2"
    for C\<^sub>1 C\<^sub>2 \<comment> \<open>We generalize to avoid repeating the argument twice\<close>
    proof -
      obtain p Q where "quorum_of p Q" and "p \<in> C\<^sub>1 \<inter> C\<^sub>2" and "Q \<subseteq> C\<^sub>2"
        using \<open>C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> unfolding strong_consensus_cluster_def by blast
      have "Q \<inter> Q\<^sub>1 \<noteq> {}" using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> \<open>quorum_of p Q\<close> \<open>p \<in> C\<^sub>1 \<inter> C\<^sub>2\<close>
        unfolding strong_consensus_cluster_def quorum_of_set_def
        by (metis Int_assoc Int_iff inf_bot_right)
      hence "quorum_of_set C\<^sub>2 Q\<^sub>1"  using \<open>Q \<subseteq> C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> quorum_assm unfolding quorum_of_set_def by blast
      thus "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" using \<open>strong_consensus_cluster C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>2 Q\<^sub>2\<close>
        unfolding strong_consensus_cluster_def by blast
    qed
    ultimately show ?thesis using assms that unfolding quorum_of_set_def by auto
  qed
  ultimately show ?thesis using assms
    unfolding strong_consensus_cluster_def by simp
qed

end

section "Stellar quorum systems"

locale stellar =
  fixes slices :: "'node \<Rightarrow> 'node set set" \<comment> \<open>the quorum slices\<close>
    and W :: "'node set" \<comment> \<open>the well-behaved nodes\<close>
  assumes slices_ne:"\<And>p . p \<in> W \<Longrightarrow> slices p \<noteq> {}"
begin

definition quorum where
  "quorum Q \<equiv> \<forall> p \<in> Q \<inter> W . (\<exists> Sl \<in> slices p . Sl \<subseteq> Q)"

definition quorum_of where "quorum_of p Q \<equiv> quorum Q \<and> (p \<notin> W \<or> (\<exists> Sl \<in> slices p . Sl \<subseteq> Q))"
  \<comment> \<open>TODO: @{term "p\<notin>W"} needed?\<close>

lemma quorum_union:"quorum Q \<Longrightarrow> quorum Q' \<Longrightarrow> quorum (Q \<union> Q')"
  unfolding quorum_def
  by (metis IntE Int_iff UnE inf_sup_aci(1) sup.coboundedI1 sup.coboundedI2)

lemma l1:
  assumes "\<And> p . p \<in> S \<Longrightarrow> \<exists> Q \<subseteq> S . quorum_of p Q" and "p\<in> S"
  shows "quorum_of p S" using assms unfolding quorum_of_def quorum_def
  by (meson Int_iff subset_trans)

lemma is_pbqs:
  assumes "quorum_of p Q" and "p' \<in> Q"
  shows "quorum_of p' Q"
  \<comment> \<open>This is the property required of a PBQS.\<close>
  using assms
  by (simp add: quorum_def quorum_of_def)

interpretation with_w quorum_of
  \<comment> \<open>Stellar quorums form a personal quorum system.\<close>
  unfolding with_w_def personal_quorums_def
  quorum_def quorum_of_def by simp

lemma quorum_is_quorum_of_some_slice:
  assumes "quorum_of p Q" and "p \<in> W"
  obtains S where "S \<in> slices p" and "S \<subseteq> Q"
    and "\<And> p' . p' \<in> S \<inter> W \<Longrightarrow> quorum_of p' Q"
  using assms unfolding quorum_def quorum_of_def by fastforce

lemma "is_cons_cluster C \<Longrightarrow> quorum C"
  \<comment> \<open>Every consensus cluster is a quorum.\<close>
  unfolding is_cons_cluster_def
  by (metis inf.order_iff l1 quorum_of_def stellar.quorum_def stellar_axioms)

subsection \<open>Properties of blocking sets\<close>

inductive blocking_min where
  \<comment> \<open>This is the set of correct participants that are eventually blocked by a set @{term R} when byzantine processors do not take steps.\<close>
  "\<lbrakk>p \<in> W; \<forall> Sl \<in> slices p . \<exists> q \<in> Sl\<inter>W . q \<in> R \<or> blocking_min R q\<rbrakk> \<Longrightarrow> blocking_min R p"
inductive_cases blocking_min_elim:"blocking_min R p"

inductive blocking_max where
  \<comment> \<open>This is the set of participants that are eventually blocked by a set @{term R} when byzantine processors help epidemic propagation.\<close>
  "\<lbrakk>p \<in> W; \<forall> Sl \<in> slices p . \<exists> q \<in> Sl . q \<in> R\<union>B \<or> blocking_max R q\<rbrakk> \<Longrightarrow> blocking_max R p"
inductive_cases "blocking_max R p"

text \<open>Next we show that if @{term \<open>R\<close>} blocks @{term \<open>p\<close>} and @{term p} belongs to a consensus cluster @{term S}, then @{term \<open>R \<inter> S \<noteq> {}\<close>}.\<close>

text \<open>We first prove two auxiliary lemmas:\<close>

lemma cons_cluster_wb:"p \<in> C \<Longrightarrow> is_cons_cluster C \<Longrightarrow> p\<in>W"
  using is_cons_cluster_def  by fastforce

lemma cons_cluster_has_ne_slices:
  assumes "is_cons_cluster C" and "p\<in>C"
    and "Sl \<in> slices p"
  shows "Sl \<noteq> {}"
  using assms unfolding is_cons_cluster_def quorum_of_set_def quorum_of_def quorum_def
  by (metis empty_iff inf_bot_left inf_bot_right subset_refl)

lemma cons_cluster_has_cons_cluster_slice:
  assumes "is_cons_cluster C" and "p\<in>C"
  obtains Sl where "Sl \<in> slices p" and "Sl \<subseteq> C"
  using assms unfolding is_cons_cluster_def quorum_of_set_def quorum_of_def quorum_def
  by (metis Int_commute  empty_iff inf.order_iff  inf_bot_right le_infI1)

theorem blocking_max_intersects_intact:
  \<comment> \<open>if @{term \<open>R\<close>} blocks @{term \<open>p\<close>} when malicious participants help epidemic propagation,
and @{term p} belongs to a consensus cluster @{term C}, then @{term \<open>R \<inter> C \<noteq> {}\<close>}\<close>
  assumes  "blocking_max R p" and "is_cons_cluster C" and "p \<in> C"
  shows "R \<inter> C \<noteq> {}" using assms
proof (induct)
  case (1 p R)
  obtain Sl where "Sl \<in> slices p" and "Sl \<subseteq> C" using cons_cluster_has_cons_cluster_slice
    using "1.prems" by blast
  moreover have "Sl \<subseteq> W" using assms(2) calculation(2) is_cons_cluster_def by auto
  ultimately show ?case
    using "1.hyps" assms(2) by fastforce
qed

text \<open>Now we show that if @{term \<open>p \<in> C\<close>}, @{term C} is a consensus cluster, and quorum @{term Q} is such that @{term \<open>Q \<inter> C \<noteq> {}\<close>},
    then @{term \<open>Q \<inter> W\<close>} blocks @{term p}.

We start by defining the set of participants reachable from a participant through correct participants.
Their union trivially forms a quorum.
Moreover, if @{term p} is not blocked by a set @{term R},
then we show that the set of participants reachable from @{term p} and not blocked by @{term R} forms a quorum disjoint from @{term R}.
It follows that if @{term p } is a member of a consensus cluster @{term C} and @{term Q} is a quorum of a member of @{term C}, then @{term "Q\<inter>W"}
 must block @{term p}, as otherwise quorum intersection would be violated. \<close>

inductive not_blocked for p R where
  "\<lbrakk>Sl \<in> slices p; \<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q; q \<in> Sl\<rbrakk> \<Longrightarrow> not_blocked p R q"
| "\<lbrakk>not_blocked p R p'; p' \<in> W; Sl \<in> slices p'; \<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q; q \<in> Sl\<rbrakk> \<Longrightarrow> not_blocked p R q"
inductive_cases not_blocked_cases:"not_blocked p R q"

lemma l4:
  fixes Q p R
  defines "Q \<equiv> {q . not_blocked p R q}"
  shows "quorum Q"
proof -
  have "\<exists> S \<in> slices n . S \<subseteq> Q" if "n\<in>Q\<inter>W" for n
  proof-
    have "not_blocked p R n" using assms that by blast
    hence "n \<notin> R" and "\<not>blocking_min R n" by (metis Int_iff not_blocked.simps that)+
    thus ?thesis  using blocking_min.intros not_blocked.intros(2) that unfolding Q_def
      by (simp; metis mem_Collect_eq subsetI)
  qed
  thus ?thesis by (simp add: quorum_def)
qed

lemma l5:
  fixes Q p R
  defines "Q \<equiv> {q . not_blocked p R q}"
  assumes  "\<not>blocking_min R p" and \<open>p\<in>C\<close> and \<open>is_cons_cluster C\<close>
  shows "quorum_of p Q"
proof -
  have "p\<in>W"
    using assms(3,4) cons_cluster_wb by blast
  obtain Sl where "Sl \<in> slices p" and "\<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q"
    by (meson \<open>p \<in> W\<close> assms(2) blocking_min.intros)
  hence "Sl \<subseteq> Q" unfolding Q_def using not_blocked.intros(1) by blast
  with l4 \<open>Sl \<in> slices p\<close> show "quorum_of p Q"
    using Q_def  quorum_of_def by blast
qed

lemma cons_cluster_ne_slices:
  assumes "is_cons_cluster C" and "p\<in>C" and "Sl \<in> slices p"
  shows "Sl\<noteq>{}"
  using assms cons_cluster_has_ne_slices cons_cluster_wb stellar.quorum_of_def stellar_axioms by fastforce

lemma l6:
  fixes Q p R
  defines "Q \<equiv> {q . not_blocked p R q}"
  shows "Q \<inter> R \<inter> W = {}"
proof -
  have "q \<notin> R" if "not_blocked p R q" and "q\<in> W" for q using that
    by (metis Int_iff not_blocked.simps)
  thus ?thesis unfolding Q_def by auto
qed

theorem quorum_blocks_cons_cluster:
  assumes "quorum_of_set C Q" and "p\<in>C" and "is_cons_cluster C"
  shows "blocking_min (Q \<inter> W) p"
proof (rule ccontr)
  assume "\<not> blocking_min (Q \<inter> W) p"
  have "p\<in>W" using assms(2,3) is_cons_cluster_def by auto
  define Q' where "Q' \<equiv> {q . not_blocked p (Q\<inter>W) q}"
  have "quorum_of p Q'" using Q'_def \<open>\<not> blocking_min (Q \<inter> W) p\<close> assms(2) assms(3) l5(1) by blast
  moreover have "Q' \<inter> Q \<inter> W = {}"
    using Q'_def l6 by fastforce
  ultimately show False using assms unfolding is_cons_cluster_def
    by (metis Int_commute inf_sup_aci(2) quorum_of_set_def)
qed

subsection \<open>Reachability through a set\<close>

text \<open>Here we define the part of a quorum @{term Q} of @{term p} that is reachable through correct
participants from @{term p}. We show that if @{term p} and @{term p'} are members of the same consensus cluster and @{term Q} is a quorum of @{term p}
 and @{term Q'} is a quorum of @{term p'},
then the intersection @{term "Q\<inter>Q'\<inter>W"} is reachable from both @{term p} and @{term p'} through the consensus cluster.\<close>

inductive reachable_through for p S where
  "reachable_through p S p"
| "\<lbrakk>reachable_through p S p'; p' \<in> W; Sl \<in> slices p'; Sl \<subseteq> S; p'' \<in> Sl\<rbrakk> \<Longrightarrow> reachable_through p S p''"

definition truncation where "truncation p S \<equiv> {p' . reachable_through p S p'}"

lemma l13:
  assumes "quorum_of p Q" and "p \<in> W" and "reachable_through p Q p'"
  shows "quorum_of p' Q"
  using assms using quorum_assm reachable_through.cases
  by (metis is_pbqs subset_iff)

lemma l14:
  assumes "quorum_of p Q" and "p \<in> W"
  shows "quorum (truncation p Q)"
proof -
  have "\<exists> S \<in> slices p' . \<forall> q \<in> S . reachable_through p Q q" if "reachable_through p Q p'" and "p' \<in> W" for p'
    by (meson assms l13 quorum_is_quorum_of_some_slice stellar.reachable_through.intros(2) stellar_axioms that)
  thus ?thesis
    by (metis IntE mem_Collect_eq stellar.quorum_def stellar_axioms subsetI truncation_def)
qed

lemma l15:
  assumes "is_cons_cluster I" and "quorum_of p Q" and "quorum_of p' Q'" and "p \<in> I" and "p' \<in> I" and "Q \<inter> Q' \<inter> W \<noteq> {}"
  shows "W \<inter> (truncation p Q) \<inter> (truncation p' Q') \<noteq> {}"
proof -
  have "quorum (truncation p Q)" and "quorum (truncation p' Q')" using l14 assms is_cons_cluster_def by auto
  moreover have "quorum_of_set I (truncation p Q)" and "quorum_of_set I (truncation p' Q')"
    by (metis IntI assms(4,5) calculation mem_Collect_eq quorum_def quorum_of_def quorum_of_set_def reachable_through.intros(1) truncation_def)+
  moreover note \<open>is_cons_cluster I\<close>
  ultimately show ?thesis unfolding is_cons_cluster_def by auto
qed

end

subsection "Elementary quorums"

text \<open>In this section we define the notion of elementary quorum, which is a quorum that has no strict subset that is a quorum.
  It follows directly from the definition that every finite quorum contains an elementary quorum. Moreover, we show
that if @{term Q} is an elementary quorum and @{term n\<^sub>1} and @{term n\<^sub>2} are members of @{term Q}, then @{term n\<^sub>2} is reachable from @{term n\<^sub>1}
in the directed graph over participants defined as the set of edges @{term "(n,m)"} such that @{term m} is a member of a slice of @{term n}.
This lemma is used in the companion paper to show that probabilistic leader-election is feasible.\<close>

locale elementary = stellar
begin

definition elementary where
  "elementary s \<equiv> quorum s \<and> (\<forall> s' . s' \<subset> s \<longrightarrow> \<not>quorum s')"

lemma finite_subset_wf:
  shows "wf {(X, Y). X \<subset> Y \<and> finite Y}"
  by (metis finite_psubset_def wf_finite_psubset)

lemma quorum_contains_elementary:
  assumes "finite s" and  "\<not> elementary s" and "quorum s"
  shows "\<exists> s' . s' \<subset> s \<and> elementary s'" using assms
proof (induct s rule:wf_induct[where ?r="{(X, Y). X \<subset> Y \<and> finite Y}"])
  case 1
  then show ?case using finite_subset_wf by simp
next
  case (2 x)
  then show ?case
    by (metis (full_types) elementary_def finite_psubset_def finite_subset in_finite_psubset less_le psubset_trans)
qed

inductive path where
  "path []"
| "\<And> x . path [x]"
| "\<And> l n . \<lbrakk>path l; S \<in> Q (hd l); n \<in> S\<rbrakk> \<Longrightarrow> path (n#l)"

theorem elementary_connected:
  assumes "elementary s" and "n\<^sub>1 \<in> s" and "n\<^sub>2 \<in> s" and "n\<^sub>1 \<in> W" and "n\<^sub>2 \<in> W"
  shows "\<exists> l . hd (rev l) = n\<^sub>1 \<and> hd l = n\<^sub>2 \<and> path l" (is ?P)
proof -
  { assume "\<not>?P"
    define x where "x \<equiv> {n \<in> s . \<exists> l . l \<noteq> [] \<and> hd (rev l) = n\<^sub>1 \<and> hd l = n \<and> path l}"
    have "n\<^sub>2 \<notin> x" using \<open>\<not>?P\<close> x_def by auto
    have "n\<^sub>1 \<in> x" unfolding x_def using assms(2) path.intros(2) by force
    have "quorum x"
    proof -
      { fix n
        assume "n \<in> x"
        have "\<exists> S . S \<in> slices n \<and> S \<subseteq> x"
        proof -
          obtain S where "S \<in> slices n" and "S \<subseteq> s" using \<open>elementary s\<close> \<open>n \<in> x\<close> unfolding x_def
            by (force simp add:elementary_def quorum_def)
          have "S \<subseteq> x"
          proof -
            { assume "\<not> S \<subseteq> x"
              obtain m where "m \<in> S" and "m \<notin> x" using \<open>\<not> S \<subseteq> x\<close> by auto
              obtain l' where "hd (rev l') = n\<^sub>1" and "hd l' = n" and "path l'" and "l' \<noteq> []"
                using \<open>n \<in> x\<close> x_def by blast
              have "path (m # l')" using \<open>path l'\<close> \<open>m\<in> S\<close> \<open>S \<in> slices n\<close> \<open>hd l' = n\<close>
                using path.intros(3) by fastforce
              moreover have "hd (rev (m # l')) = n\<^sub>1" using \<open>hd (rev l') = n\<^sub>1\<close> \<open>l' \<noteq> []\<close> by auto
              ultimately have "m \<in> x" using \<open>m \<in> S\<close> \<open>S \<subseteq> s\<close> x_def by auto
              hence False using \<open>m \<notin> x\<close> by blast }
            thus ?thesis by blast
          qed
          thus ?thesis
            using \<open>S \<in> slices n\<close> by blast
        qed }
      thus ?thesis by (meson Int_iff quorum_def)
    qed
    moreover have "x \<subset> s"
      using \<open>n\<^sub>2 \<notin> x\<close> assms(3) x_def by blast
    ultimately have False using \<open>elementary s\<close>
      using elementary_def by auto
  }
  thus ?P by blast
qed

end

subsection \<open>The intact sets of the Stellar Whitepaper\<close>

definition project where
  "project slices S n \<equiv> {Sl \<inter> S | Sl . Sl \<in> slices n}"
  \<comment> \<open>Projecting on @{term S} is the same as deleting the complement of @{term S}, where deleting is understood as in the Stellar Whitepaper.\<close>

subsubsection \<open>Intact and the Cascade Theorem\<close>

locale intact = \<comment> \<open>Here we fix an intact set @{term I} and prove the cascade theorem.\<close>
  orig:stellar slices W
  + proj:stellar "project slices I" W \<comment> \<open>We consider the projection of the system on @{term I}.\<close>
  for slices W I +  \<comment> \<open>An intact set is a set @{term I} satisfying the three assumptions below:\<close>
  assumes intact_wb:"I \<subseteq> W"
    and q_avail:"orig.quorum I" \<comment> \<open>@{term I} is a quorum in the original system.\<close>
    and q_inter:"\<And> Q Q' . \<lbrakk>proj.quorum Q; proj.quorum Q'; Q \<inter> I \<noteq> {}; Q' \<inter> I \<noteq> {}\<rbrakk>  \<Longrightarrow> Q \<inter> Q' \<inter> I \<noteq> {}"
    \<comment> \<open>Any two sets that intersect @{term I} and that are quorums in the projected system intersect in @{term I}.
Note that requiring that @{text \<open>Q \<inter> Q' \<noteq> {}\<close>} instead of @{text \<open>Q \<inter> Q' \<inter> I \<noteq> {}\<close>} would be equivalent.\<close>
begin

theorem blocking_safe: \<comment> \<open>A set that blocks an intact node contains an intact node.
If this were not the case, quorum availability would trivially be violated.\<close>
  fixes S n
  assumes "n\<in>I" and "\<forall> Sl\<in> slices n .Sl\<inter>S \<noteq> {}"
  shows "S \<inter> I \<noteq> {}"
  using assms q_avail intact_wb unfolding orig.quorum_def
  by auto (metis inf.absorb_iff2 inf_assoc inf_bot_right inf_sup_aci(1))

theorem cascade:
\<comment> \<open>If @{term U} is a quorum of an intact node and @{term S} is a super-set of @{term U}, then either @{term S} includes
all intact nodes or there is an intact node outside of @{term S} which is blocked by the intact members of @{term S}.
This shows that, in SCP, once the intact members of a quorum accept a statement,
a cascading effect occurs and all intact nodes eventually accept it regardless of what befouled and faulty nodes do.\<close>
  fixes U S
  assumes "orig.quorum U" and "U \<inter> I \<noteq> {}" and "U \<subseteq> S"
  obtains "I \<subseteq> S" | "\<exists> n \<in> I - S . \<forall> Sl \<in> slices n . Sl \<inter> S \<inter> I \<noteq> {}"
proof -
  have False if 1:"\<forall> n \<in> I - S . \<exists> Sl \<in> slices n . Sl \<inter> S \<inter> I = {}" and 2:"\<not>(I \<subseteq> S)"
  proof -
    text \<open>First we show that @{term \<open>I-S\<close>} is a quorum in the projected system. This is immediate from the definition of quorum and assumption 1.\<close>
    have "proj.quorum (I-S)" using 1
      unfolding proj.quorum_def project_def
      by (auto; smt DiffI Diff_Compl Diff_Int_distrib Diff_eq Diff_eq_empty_iff Int_commute)
    text \<open>Then we show that U is also a quorum in the projected system:\<close>
    moreover have "proj.quorum U" using \<open>orig.quorum U\<close>
      unfolding proj.quorum_def orig.quorum_def project_def
      by (simp; meson Int_commute inf.coboundedI2)
    text \<open>Since quorums of @{term I} must intersect, we get a contradiction:\<close>
    ultimately show False using \<open>U \<subseteq> S\<close> \<open>U \<inter> I \<noteq> {}\<close> \<open>\<not>(I\<subseteq>S)\<close> q_inter by auto
  qed
  thus ?thesis using that by blast
qed

end

subsubsection "The Union Theorem"

text \<open>Here we prove that the union of two intact sets that intersect is intact.
This implies that maximal intact sets are disjoint.\<close>

locale intersecting_intact =
  i1:intact slices W I\<^sub>1 + i2:intact slices W I\<^sub>2 \<comment> \<open>We fix two intersecting intact sets @{term I\<^sub>1} and @{term I\<^sub>2}.\<close>
  + proj:stellar "project slices (I\<^sub>1\<union>I\<^sub>2)" W \<comment> \<open>We consider the projection of the system on @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>}.\<close>
  for slices W I\<^sub>1 I\<^sub>2 +
assumes inter:"I\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}"
begin

theorem union_quorum: "i1.orig.quorum (I\<^sub>1\<union>I\<^sub>2)" \<comment> \<open>@{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} is a quorum in the original system.\<close>
  using i1.intact_axioms i2.intact_axioms
  unfolding  intact_def stellar_def intact_axioms_def i1.orig.quorum_def
  by (metis Int_iff Un_iff le_supI1 le_supI2)

theorem union_quorum_intersection:
  assumes "proj.quorum Q\<^sub>1" and "proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}" and "Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
  shows "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    \<comment> \<open>Any two sets that intersect @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} and that are quorums in the system projected on @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} intersect in @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>}.\<close>
proof -
  text \<open>First we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} are quorums in the projections on @{term I\<^sub>1} and @{term I\<^sub>2}.\<close>
  have "i1.proj.quorum Q\<^sub>1" using \<open>proj.quorum Q\<^sub>1\<close>
    unfolding i1.proj.quorum_def proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  moreover have "i2.proj.quorum Q\<^sub>2" using \<open>proj.quorum Q\<^sub>2\<close>
    unfolding i2.proj.quorum_def proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  moreover have "i2.proj.quorum Q\<^sub>1" using \<open>proj.quorum Q\<^sub>1\<close>
    unfolding proj.quorum_def i2.proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  moreover have "i1.proj.quorum Q\<^sub>2" using \<open>proj.quorum Q\<^sub>2\<close>
    unfolding proj.quorum_def i1.proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  text \<open>Next we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} intersect if they are quorums of, respectively, @{term I\<^sub>1} and @{term I\<^sub>2}.
This is the only interesting part of the proof.\<close>
  moreover have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    if "i1.proj.quorum Q\<^sub>1" and "i2.proj.quorum Q\<^sub>2" and "i2.proj.quorum Q\<^sub>1"
      and "Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}"
    for Q\<^sub>1 Q\<^sub>2
  proof -
    have "i1.proj.quorum I\<^sub>2"
    proof -
      have "i1.orig.quorum I\<^sub>2" by (simp add: i2.q_avail)
      thus ?thesis unfolding i1.orig.quorum_def i1.proj.quorum_def project_def
        by auto (meson Int_commute Int_iff inf_le2 subset_trans)
    qed
    moreover note \<open>i1.proj.quorum Q\<^sub>1\<close>
    ultimately have "Q\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}" using i1.q_inter inter \<open>Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}\<close> by blast

    moreover note \<open>i2.proj.quorum Q\<^sub>2\<close>
    moreover note \<open>i2.proj.quorum Q\<^sub>1\<close>
    ultimately have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}" using i2.q_inter \<open>Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}\<close> by blast
    thus ?thesis by (simp add: inf_sup_distrib1)
  qed
  text \<open>Next  we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} intersect if they are quorums of the same intact set. This is obvious.\<close>
  moreover
  have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    if "i1.proj.quorum Q\<^sub>1" and "i1.proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>1 \<noteq> {}"
    for Q\<^sub>1 Q\<^sub>2
    by (simp add: Int_Un_distrib i1.q_inter that)
  moreover
  have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    if "i2.proj.quorum Q\<^sub>1" and "i2.proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}"
    for Q\<^sub>1 Q\<^sub>2
    by (simp add: Int_Un_distrib i2.q_inter that)
  text \<open>Finally we have covered all the cases and get the final result:\<close>
  ultimately
  show ?thesis
    by (smt Int_Un_distrib Int_commute assms(3,4) sup_bot.right_neutral)
qed

end

end