section\<open>Background material in additive combinatorics\<close>

text \<open>This section outlines some background definitions and basic lemmas in additive combinatorics
based on the notes by Gowers \cite{Gowersnotes}. \<close>
(*
  Session: Balog_Szemeredi_Gowers
  Title:   Additive_Combinatorics_Preliminaries.thy
  Authors: Angeliki Koutsoukou-Argyraki, Mantas Bakšys, and Chelsea Edmonds
  Affiliation: University of Cambridge
  Date: August 2022.
*)

theory Additive_Combinatorics_Preliminaries
  imports
    Pluennecke_Ruzsa_Inequality.Pluennecke_Ruzsa_Inequality
begin

subsection\<open>Additive quadruples and additive energy\<close>

context additive_abelian_group

begin

definition additive_quadruple:: "'a \<Rightarrow>'a \<Rightarrow>'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "additive_quadruple a b c d  \<equiv> a \<in> G \<and> b \<in> G \<and> c \<in> G \<and> d \<in> G \<and> a \<oplus> b = c \<oplus> d"

lemma additive_quadruple_aux:
  assumes "additive_quadruple a b c d"
  shows "d = a \<oplus> b \<ominus> c"
  by (metis additive_quadruple_def assms associative commutative inverse_closed invertible
    invertible_right_inverse2)

lemma additive_quadruple_diff:
  assumes "additive_quadruple a b c d"
  shows "a \<ominus> c = d \<ominus> b"
  by (smt (verit, del_insts) additive_quadruple_def assms associative commutative
      composition_closed inverse_closed invertible invertible_inverse_inverse invertible_right_inverse2)

definition additive_quadruple_set:: "'a set \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a) set" where
  "additive_quadruple_set A \<equiv> {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
  additive_quadruple a b c d}"

lemma additive_quadruple_set_sub:
  "additive_quadruple_set A \<subseteq> {(a, b, c, d) | a b c d. d = a \<oplus> b \<ominus> c \<and> a \<in> A \<and> b \<in> A \<and>
    c \<in> A \<and> d \<in> A}" using additive_quadruple_set_def additive_quadruple_def additive_quadruple_aux
  by auto

definition additive_energy:: "'a set \<Rightarrow> real" where
  "additive_energy A \<equiv> card (additive_quadruple_set A) / (card A)^3"

lemma card_ineq_aux_quadruples:
  assumes "finite A"
  shows "card (additive_quadruple_set A) \<le> (card A)^3"

proof-
  define f:: "'a \<times> 'a \<times> 'a \<times> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a" where "f = (\<lambda> (a, b, c, d) . (a, b, c))"
  have hinj: "inj_on f {(a, b, c, d) | a b c d. d = a \<oplus> b \<ominus> c \<and> a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A}"
  unfolding inj_on_def f_def by auto
  moreover have himage: "f ` {(a, b, c, d) | a b c d. d = a \<oplus> b \<ominus> c \<and> a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A} \<subseteq> A \<times> A \<times> A"
    unfolding f_def by auto
  ultimately have "card (additive_quadruple_set A) \<le> card ({(a, b, c, d) | a b c d. d = a \<oplus> b \<ominus> c \<and> a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A})"
    using card_mono inj_on_finite[of "f"] assms additive_quadruple_set_sub finite_SigmaI
    by (metis (no_types, lifting))
  also have "... \<le> card (A \<times> A \<times> A)" using himage hinj assms card_inj_on_le finite_SigmaI
    by (metis (no_types, lifting))
  finally show ?thesis by (simp add: card_cartesian_product power3_eq_cube)
qed

lemma additive_energy_upper_bound: "additive_energy A \<le> 1"

proof (cases "finite A")
  assume hA: "finite A"
  show ?thesis unfolding additive_energy_def using card_ineq_aux_quadruples hA
    card_cartesian_product power3_eq_cube by (simp add: divide_le_eq)
next
  assume "infinite A"
  thus ?thesis unfolding additive_energy_def by simp
qed

subsection\<open>On sums\<close>

definition f_sum:: "'a \<Rightarrow>'a set \<Rightarrow> nat" where
  "f_sum d A \<equiv> card {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}"

lemma pairwise_disjnt_sum_1:
  "pairwise (\<lambda>s t. disjnt ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<oplus> b = d)}) s)
    ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<oplus> b = d)}) t)) (sumset A A)"
  unfolding disjnt_def by (intro pairwiseI) (auto)

lemma pairwise_disjnt_sum_2:
  "pairwise disjnt ((\<lambda> d. {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}) ` (sumset A A))"
  unfolding disjnt_def by (intro pairwiseI) (auto)

lemma sum_Union_span:
  assumes "A \<subseteq> G"
  shows "\<Union> ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<oplus> b = d)}) ` (sumset A A)) = A \<times> A"

proof
  show "\<Union> ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<oplus> b = d)}) ` (sumset A A)) \<subseteq> A \<times> A" by blast
next
  show "A \<times> A \<subseteq> \<Union> ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<oplus> b = d)}) ` (sumset A A))"
  proof (intro subsetI)
    fix x assume hxA: "x \<in> A \<times> A"
    then obtain y z where hxyz: "x = (y, z)" and hy: "y \<in> A" and hz:"z \<in> A" by blast
    show "x \<in> (\<Union>d\<in>(sumset A A).{(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d})"
      using hy hz assms hxA hxyz by auto
  qed
qed

lemma f_sum_le_card:
  assumes "finite A" and "A \<subseteq> G"
  shows "f_sum d A \<le> card A"

proof-
  define f:: "('a \<times> 'a) \<Rightarrow> 'a" where "f \<equiv> (\<lambda> (a, b). a)"
  have "inj_on f {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}"
  unfolding f_def proof (intro inj_onI)
  fix x y assume "x \<in> {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}" and
    "y \<in> {(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}" and
    hcase: "(case x of (a, b) \<Rightarrow> a) = (case y of (a, b) \<Rightarrow> a)"
  then obtain x1 x2 y1 y2 where hx: "x = (x1, x2)" and hy:"y = (y1, y2)" and h1: "x1 \<oplus> x2 = d" and
    h2: "y1 \<oplus> y2 = d" and hx1: "x1 \<in> A" and hx2: "x2 \<in> A" and hy1: "y1 \<in> A" and hy2: "y2 \<in> A" by blast
  have hxsub: "x2 = d \<ominus> x1"
    using h1 hx1 hx2 assms by (metis additive_abelian_group.inverse_closed composition_closed
     additive_abelian_group_axioms commutative invertible invertible_left_inverse2 subsetD)
  have hysub: "y2 = d \<ominus> y1"
    using h2 hy1 hy2 assms by (metis inverse_closed commutative composition_closed hy1 hy2
        invertible invertible_left_inverse2 subset_iff)
  show "x = y" using hx hy hxsub hysub hcase by auto
  qed
  moreover have "f ` {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d} \<subseteq> A" using f_def by auto
  ultimately show ?thesis using card_mono assms f_sum_def card_image[of "f"]
    by (metis (mono_tags, lifting))
qed

lemma f_sum_card:
  assumes "A \<subseteq> G" and hA: "finite A"
  shows "(\<Sum> d \<in> (sumset A A). (f_sum d A)) = (card A)^2"

proof-
  have fin: "\<forall> X \<in> ((\<lambda> d. {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<oplus> b = d) }) ` (sumset A A)). finite X"
  proof
    fix X assume hX: "X \<in> (\<lambda>d. {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}) ` (sumset A A)"
    then obtain d where hXd: "X = {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}" by blast
    show "finite X" using hA hXd finite_subset finite_cartesian_product
      by (smt (verit, best) mem_Collect_eq mem_Sigma_iff rev_finite_subset subrelI)
  qed
  have "(\<Sum>d\<in>(sumset A A). f_sum d A) = card (A \<times> A)"
    unfolding f_sum_def
    using sum_card_image[of "sumset A A" "(\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<oplus> b = d)})"]
      pairwise_disjnt_sum_1 hA finite_sumset card_Union_disjoint[of "((\<lambda>d. {(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = d}) ` sumset A A)"]
      fin pairwise_disjnt_sum_2 hA finite_sumset sum_Union_span assms by auto
  thus ?thesis using card_cartesian_product power2_eq_square by metis
qed

lemma f_sum_card_eq:
  assumes "A \<subseteq> G"
  shows "\<forall> x \<in> sumset A A.  (f_sum x A)^2 =
    card {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}"

proof
  fix x assume "x \<in> sumset A A"
  define C where hC: "C = {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}"
  define f:: "'a \<times> 'a \<times> 'a \<times> 'a \<Rightarrow> ('a \<times> 'a) \<times> ('a \<times> 'a)" where "f = (\<lambda> (a, b, c, d). ((a, b), (c, d)))"
  have hfinj: "inj_on f C" unfolding f_def by (intro inj_onI) (auto)
  have "f ` C = {((a,b), (c,d)) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<oplus> b = x \<and> c \<oplus> d = x}"
  proof
    show "f ` C \<subseteq> {((a, b), (c, d)) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<oplus> b = x \<and> c \<oplus> d = x}"
      unfolding f_def hC by auto
  next
    show "{((a, b), c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<oplus> b = x \<and> c \<oplus> d = x} \<subseteq> f ` C"
    proof
      fix z assume "z \<in> {((a, b), (c, d)) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<oplus> b = x \<and> c \<oplus> d = x}"
      then obtain a b c d where hz: "z = ((a, b), (c, d))" and ha: "a \<in> A" and hb: "b \<in> A" and hc: "c \<in> A" and hd: "d \<in> A"
      and hab: "a \<oplus> b = x" and hcd: "c \<oplus> d = x" by blast
      then have habcd: "(a, b, c, d) \<in> C" using additive_quadruple_def assms hC by auto
      show "z \<in> f ` C" using hz f_def habcd by force
    qed
  qed
  moreover have "{((a, b), c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<oplus> b = x \<and> c \<oplus> d = x} =
    {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = x} \<times> {(c, d) | c d. c \<in> A \<and> d \<in> A \<and> c \<oplus> d = x}" by blast
  ultimately have "card C = card ({(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<oplus> b = x}) ^ 2"
    using hfinj card_image[of "f"]  card_cartesian_product by (metis (no_types, lifting) Sigma_cong power2_eq_square)
  thus "(f_sum x A)^2 = card ({(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x})" using hC f_sum_def by auto
qed

lemma pairwise_disjoint_sum:
  "pairwise (\<lambda>s t. disjnt ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
     additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) s)
     ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
     additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) t)) (sumset A A)"
  unfolding disjnt_def by (intro pairwiseI) (auto)

lemma pairwise_disjnt_quadruple_sum:
  "pairwise disjnt ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) ` (sumset A A))"
  unfolding disjnt_def by (intro pairwiseI) (auto)

lemma quadruple_sum_Union_eq:
   "\<Union> ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) ` (sumset A A)) = additive_quadruple_set A"

proof
  show "(\<Union>x\<in>sumset A A.
    {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and>
    a \<oplus> b = x \<and> c \<oplus> d = x}) \<subseteq> additive_quadruple_set A"
    unfolding additive_quadruple_set_def by (intro Union_least) (auto)
next
  show "additive_quadruple_set A \<subseteq> (\<Union>x\<in>sumset A A.
    {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x})"
  unfolding additive_quadruple_set_def additive_quadruple_def by (intro subsetI) (auto)
qed

lemma f_sum_card_quadruple_set:
  assumes hAG: "A \<subseteq> G" and hA: "finite A"
  shows "(\<Sum> d \<in> (sumset A A). (f_sum d A)^2) = card (additive_quadruple_set A)"

proof-
  have fin: "\<forall> X \<in> ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
   additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) ` (sumset A A)). finite X"
  proof
    fix X assume "X \<in>  (\<lambda>x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
      additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) ` sumset A A"
    then obtain x where hX: "X = {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
      additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}"
      by blast
    show "finite X" using hA hX finite_subset finite_cartesian_product
      by (smt (verit, best) mem_Collect_eq mem_Sigma_iff rev_finite_subset subrelI)
  qed
  have "(\<Sum>d\<in>sumset A A. (f_sum d A)\<^sup>2) =
    card (\<Union> ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) ` (sumset A A)))"
    using f_sum_card_eq hAG sum_card_image[of "sumset A A" "(\<lambda>x. {(a, b, c, d) |a b c d.
      a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x})"]
      pairwise_disjoint_sum card_Union_disjoint[of "(\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and>
      c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<oplus> b = x \<and> c \<oplus> d = x}) ` (sumset A A)"]
      fin pairwise_disjnt_quadruple_sum hA finite_sumset by auto
  then show ?thesis using quadruple_sum_Union_eq by auto
qed

lemma  f_sum_card_quadruple_set_additive_energy: assumes "A \<subseteq> G" and "finite A"
  shows "(\<Sum> d \<in> sumset A A. (f_sum d A)^2) = additive_energy A * (card A)^3"
  using assms f_sum_card_quadruple_set additive_energy_def by force

definition popular_sum:: "'a \<Rightarrow> real \<Rightarrow> 'a set \<Rightarrow> bool" where
  "popular_sum d \<theta> A  \<equiv> f_sum d A \<ge> \<theta> * of_real (card A)"

definition popular_sum_set:: "real \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "popular_sum_set \<theta> A \<equiv> {d \<in> sumset A A. popular_sum d \<theta> A}"

subsection\<open>On differences\<close>

text\<open>The following material is directly analogous to the material given previously on sums.
All definitions and lemmas are the corresponding ones for differences.
E.g. @{term f_diff} corresponds to  @{term f_sum}. \<close>

definition f_diff:: "'a \<Rightarrow>'a set \<Rightarrow> nat" where
  "f_diff d A \<equiv> card {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}"

lemma pairwise_disjnt_diff_1:
  "pairwise (\<lambda>s t. disjnt ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<ominus> b = d)}) s)
    ((\<lambda> d. {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<ominus> b = d)}) t)) (differenceset A A)"
  using disjnt_def by (intro pairwiseI) (auto)

lemma pairwise_disjnt_diff_2:
  "pairwise disjnt ((\<lambda> d. {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}) ` (differenceset A A))"
  unfolding disjnt_def by (intro pairwiseI) (auto)

lemma diff_Union_span:
  assumes "A \<subseteq> G"
  shows "\<Union> ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<ominus> b = d)}) ` (differenceset A A)) = A \<times> A"

proof
  show "\<Union> ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<ominus> b = d)}) ` (differenceset A A)) \<subseteq> A \<times> A"
    by blast
next
  show "A \<times> A \<subseteq> \<Union> ((\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<ominus> b = d)}) ` (differenceset A A))"
  proof (intro subsetI)
    fix x assume hxA: "x \<in> A \<times> A"
    then obtain y z where hxyz: "x = (y, z)" and hy: "y \<in> A" and hz:"z \<in> A" by blast
    show "x \<in> (\<Union>d\<in>(differenceset A A).{(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d})"
      using hy hz assms hxA hxyz by auto
  qed
qed

lemma f_diff_le_card:
  assumes "finite A" and "A \<subseteq> G"
  shows "f_diff d A \<le> card A"

proof-
define f:: "('a \<times> 'a) \<Rightarrow> 'a" where "f \<equiv> (\<lambda> (a, b). a)"
  have "inj_on f {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}"
  unfolding f_def proof (intro inj_onI)
  fix x y assume "x \<in> {(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}" and
    "y \<in> {(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}" and
    hcase: "(case x of (a, b) \<Rightarrow> a) = (case y of (a, b) \<Rightarrow> a)"
  then obtain x1 x2 y1 y2 where hx: "x = (x1, x2)" and hy:"y = (y1, y2)" and h1: "x1 \<ominus> x2 = d" and
    h2: "y1 \<ominus> y2 = d" and hx1: "x1 \<in> A" and hx2: "x2 \<in> A" and hy1: "y1 \<in> A" and hy2: "y2 \<in> A" by blast
  have hxsub: "x2 = x1 \<ominus> d"
    using h1 assms associative commutative composition_closed hx1 hx2
    by (smt (verit, best) inverse_closed invertible invertible_left_inverse2 subset_iff)
  have hysub: "y2 = y1 \<ominus> d"
    using h2 assms associative commutative composition_closed hy1 hy2
    by (smt (verit, best) inverse_closed invertible invertible_left_inverse2 subset_iff)
  show "x = y" using hx hy hxsub hysub hcase by auto
  qed
  moreover have "f ` {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d} \<subseteq> A" using f_def by auto
  ultimately show ?thesis using card_mono assms f_diff_def card_image[of "f"]
    by (metis (mono_tags, lifting))
qed

lemma f_diff_card:
  assumes "A \<subseteq> G" and hA: "finite A"
  shows "(\<Sum> d \<in> (differenceset A A). f_diff d A) = (card A)^2"

proof-
  have fin: "\<forall> X \<in> ((\<lambda> d. {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<ominus> b = d) }) ` (differenceset A A)).
    finite X"
  proof
      fix X assume hX: "X \<in> (\<lambda>d. {(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}) ` (differenceset A A)"
      then obtain d where hXd: "X = {(a, b) | a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}" and
        "d \<in> (differenceset A A)" by blast
      have hXA: "X \<subseteq> A \<times> A" using hXd by blast
      show "finite X" using hXA hA finite_subset by blast
    qed
  have "(\<Sum>d\<in>(differenceset A A). f_diff d A) = card (A \<times> A)"
    unfolding f_diff_def using sum_card_image[of "differenceset A A"
    "(\<lambda> d .{(a, b) | a b. a \<in> A \<and> b \<in> A \<and> (a \<ominus> b = d) })"] pairwise_disjnt_diff_1
    card_Union_disjoint[of "((\<lambda>d. {(a, b) |a b. a \<in> A \<and> b \<in> A \<and> a \<ominus> b = d}) ` differenceset A A)"]
    fin pairwise_disjnt_diff_2 diff_Union_span assms hA finite_minusset finite_sumset by auto
  thus ?thesis using card_cartesian_product power2_eq_square by metis
qed

lemma f_diff_card_eq:
  assumes "A \<subseteq> G"
  shows "\<forall> x \<in> differenceset A A. (f_diff x A)^2 =
    card {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}"

proof
  fix x assume "x \<in> differenceset A A"
  define C where hC: "C= {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x }"
  define f:: "'a \<times> 'a \<times> 'a \<times> 'a \<Rightarrow> ('a \<times> 'a) \<times> ('a \<times> 'a)" where "f = (\<lambda> (a, b, c, d). ((a, c), (d, b)))"
  have hfinj: "inj_on f C" using f_def by (intro inj_onI) (auto)
  have "f ` C = {((a,c), (d,b)) | a b c d.
    a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<ominus> c = x \<and> d \<ominus> b = x}"
  proof
    show "f ` C \<subseteq> {((a, c), (d, b)) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<ominus> c = x \<and> d \<ominus> b = x}"
      unfolding f_def hC by auto
  next
    show "{((a, c), d, b) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<ominus> c = x \<and> d \<ominus> b = x} \<subseteq> f ` C"
    proof
      fix z assume "z \<in> {((a, c), (d, b)) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<ominus> c = x \<and> d \<ominus> b = x}"
      then obtain a b c d where hz: "z = ((a, c), (d, b))" and ha: "a \<in> A" and hb: "b \<in> A" and hc: "c \<in> A" and hd: "d \<in> A"
        and hab: "a \<ominus> c = x" and hcd: "d \<ominus> b = x" by blast
      have "additive_quadruple a b c d"
        using assms by (metis (no_types, lifting) ha hb hc hd additive_quadruple_def associative
        commutative composition_closed hab hcd inverse_closed invertible invertible_right_inverse2 subset_eq)
      then have habcd: "(a, b, c, d) \<in> C" using hab hcd hC ha hb hc hd by blast
      show "z \<in> f ` C" using hz f_def habcd image_iff by fastforce
    qed
  qed
  moreover have "{((a, c), (d, b))|a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> a \<ominus> c = x \<and> d \<ominus> b = x} =
  {(a, c) | a c. a \<in> A \<and> c \<in> A \<and> a \<ominus> c = x} \<times> {(d, b) | d b. d \<in> A \<and> b \<in> A \<and> d \<ominus> b = x}" by blast
  moreover have "card C = card (f ` C)" using hfinj card_image[of "f"] by auto
  ultimately have "card C =  card ({(a, c) | a c. a \<in> A \<and> c \<in> A \<and> a \<ominus> c = x}) ^ 2"
    using hfinj card_image[of "f"] card_cartesian_product Sigma_cong power2_eq_square by (smt (verit, best))
  thus "(f_diff x A)\<^sup>2 = card  {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}"
    using f_diff_def hC by simp
qed

lemma pairwise_disjoint_diff:
  "pairwise (\<lambda>s t. disjnt ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) s)
    ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) t)) (differenceset A A)"
  unfolding disjnt_def by (intro pairwiseI) (auto)

lemma pairwise_disjnt_quadruple_diff:
 "pairwise disjnt ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) ` (differenceset A A))"
  unfolding disjnt_def by (intro pairwiseI) (auto)

lemma quadruple_diff_Union_eq:
  "\<Union> ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) ` (differenceset A A)) =
    additive_quadruple_set A"

proof
  show "(\<Union>x\<in>differenceset A A. {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) \<subseteq> additive_quadruple_set A"
    unfolding additive_quadruple_set_def by (intro Union_least)(auto)
next
  show "additive_quadruple_set A \<subseteq> (\<Union>x\<in>differenceset A A.
    {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x})"
  proof (intro subsetI)
    fix x assume"x \<in> additive_quadruple_set A"
    then obtain x1 x2 x3 x4 where hx: "x = (x1, x2, x3, x4)" and hx1: "x1 \<in> A" and hx2: "x2 \<in> A" and hx3: "x3 \<in> A"
      and hx4: "x4 \<in> A" and hxadd: "additive_quadruple x1 x2 x3 x4"
      using additive_quadruple_set_def by auto
    have hxmem: "(x1, x2, x3, x4) \<in> {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
      additive_quadruple a b c d \<and> a \<ominus> c = x1 \<ominus> x3 \<and> d \<ominus> b = x1 \<ominus> x3}"
      using additive_quadruple_diff hx1 hx2 hx3 hx4 hxadd by auto
    show "x \<in> (\<Union>x\<in>differenceset A A. {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
      additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x})"
      using hx hxmem hx1 hx3 additive_quadruple_def hxadd by auto
  qed
qed

lemma f_diff_card_quadruple_set:
  assumes hAG: "A \<subseteq> G" and hA: "finite A"
  shows "(\<Sum> d \<in> (differenceset A A). (f_diff d A)^2) = card (additive_quadruple_set A)"

proof-
  have fin: "\<forall> X \<in> ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
    additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) ` (differenceset A A)). finite X"
  proof
    fix X assume "X \<in> (\<lambda>x. {(a, b, c, d) |a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
      additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) ` differenceset A A"
    then obtain x where hX: "X = {(a, b, c, d) | a b c d. a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and>
      additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}" and "x \<in> differenceset A A" by blast
    show "finite X" using hX hA finite_subset finite_cartesian_product
      by (smt (verit, best) mem_Collect_eq mem_Sigma_iff rev_finite_subset subrelI) (*slow*)
  qed
  have "(\<Sum>d\<in>differenceset A A. (f_diff d A)\<^sup>2) = card (\<Union> ((\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and>
    b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) ` (differenceset A A)))"
    using f_diff_card_eq hAG sum_card_image[of "differenceset A A" "(\<lambda>x. {(a, b, c, d) |a b c d.
      a \<in> A \<and> b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x})"]
      pairwise_disjoint_diff card_Union_disjoint[of "(\<lambda> x. {(a, b, c, d) | a b c d. a \<in> A \<and>
      b \<in> A \<and> c \<in> A \<and> d \<in> A \<and> additive_quadruple a b c d \<and> a \<ominus> c = x \<and> d \<ominus> b = x}) `
      (differenceset A A)"] fin pairwise_disjnt_quadruple_diff hA finite_minusset finite_sumset by auto
  thus ?thesis using quadruple_diff_Union_eq by auto
qed

lemma f_diff_card_quadruple_set_additive_energy: assumes "A \<subseteq> G" and "finite A"
  shows "(\<Sum> d \<in> differenceset A A. (f_diff d A)^2) = additive_energy A * (card A)^3"
  using assms f_diff_card_quadruple_set additive_energy_def by force

definition popular_diff:: "'a \<Rightarrow> real \<Rightarrow> 'a set \<Rightarrow> bool" where
  "popular_diff d \<theta> A  \<equiv> f_diff d A \<ge> \<theta> * of_real (card A)"

definition popular_diff_set:: "real \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "popular_diff_set \<theta> A \<equiv> {d \<in> differenceset A A. popular_diff d \<theta> A}"

end
end


theory ordered_set_sd
imports Main
begin

definition "sd_ordereded (A::'a set) (f::'a\<Rightarrow>nat) \<equiv> \<forall> e . e\<in> A \<and> f e>0 \<longrightarrow> (\<exists> e'. e'\<in>A \<and> f e' = (f e)-1)"

definition "sd_earlier (A::'a set) (f::'a\<Rightarrow>nat) (u::nat) \<equiv> \<exists>e' . e'\<in>A \<and> f e' = u"

lemma base1: "sd_ordereded A f \<Longrightarrow> e\<in>A \<Longrightarrow> f e > 0 \<Longrightarrow> u = f e \<Longrightarrow> u \<ge> 0 \<Longrightarrow> sd_earlier A f (u-1) "
  apply(simp add: sd_earlier_def sd_ordereded_def)
  done

lemma earlier_elements: "sd_ordereded A f  \<Longrightarrow> e\<in>A \<Longrightarrow> f e > 0 \<Longrightarrow> u < f e \<Longrightarrow> u \<ge> 0 \<Longrightarrow> sd_earlier A f u "
  apply(induction u rule:less_induct)
  apply clarsimp
    by (smt sd_earlier_def base1 diff_Suc_1 le0 strict_inc_induct zero_less_Suc)

lemma "sd_ordereded A f  \<Longrightarrow> e\<in>A \<Longrightarrow> f e  = 25 \<Longrightarrow> sd_earlier A f 14"
  using earlier_elements
  proof -
  assume a1: "f e = 25"
  assume a2: "sd_ordereded A f"
    assume a3: "e \<in> A"
    have "(14 \<noteq> f e \<and> f e \<noteq> 0) \<and> num.Bit1 num.One < num.Bit0 (num.Bit1 num.One)"
      using a1 by force
    then show ?thesis
      using a3 a2 a1 by (metis le0 nat_less_le numeral_le_iff earlier_elements semiring_norm(72) semiring_norm(74))
  qed

end


(*  Title:      HOL/Hoare/SepLogHeap.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM
*)

section \<open>Heap abstractions for Separation Logic\<close>

text \<open>(at the moment only Path and List)\<close>

theory SepLogHeap
  imports MainRLT
begin

type_synonym heap = "(nat \<Rightarrow> nat option)"

text\<open>\<open>Some\<close> means allocated, \<open>None\<close> means
free. Address \<open>0\<close> serves as the null reference.\<close>

subsection "Paths in the heap"

primrec Path :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
where
  "Path h x [] y = (x = y)"
| "Path h x (a#as) y = (x\<noteq>0 \<and> a=x \<and> (\<exists>b. h x = Some b \<and> Path h b as y))"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by (induct as) auto

lemma Path_upd[simp]:
 "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by (induct as) simp_all

subsection "Lists on the heap"

definition List :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool"
  where "List h x as = Path h x as 0"

lemma [simp]: "List h x [] = (x = 0)"
by (simp add: List_def)

lemma [simp]:
 "List h x (a#as) = (x\<noteq>0 \<and> a=x \<and> (\<exists>y. h x = Some y \<and> List h y as))"
by (simp add: List_def)

lemma [simp]: "List h 0 as = (as = [])"
by (cases as) simp_all

lemma List_non_null: "a\<noteq>0 \<Longrightarrow>
 List h a as = (\<exists>b bs. as = a#bs \<and> h a = Some b \<and> List h b bs)"
by (cases as) simp_all

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by (induct as) (auto simp add:List_non_null)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by (blast intro: List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by (induct as) auto

lemma List_hd_not_in_tl[simp]: "List h b as \<Longrightarrow> h a = Some b \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
by (induct as) (auto dest:List_hd_not_in_tl)

lemma list_in_heap: "\<And>p. List h p ps \<Longrightarrow> set ps \<subseteq> dom h"
by (induct ps) auto

lemma list_ortho_sum1[simp]:
 "\<And>p. \<lbrakk> List h1 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

lemma list_ortho_sum2[simp]:
 "\<And>p. \<lbrakk> List h2 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

end


theory S1Demo3 imports Main begin

section{* Predicate logic *}

subsection{* Quantifier reasoning *}

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

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

text{* Intro and elim resoning: *}
lemma "\<exists>y. \<forall>x. P x y \<Longrightarrow> \<forall>x. \<exists>y. P x y"
(* the safe rules first: *)
apply(rule allI)
apply(erule exE)
(* now the unsafe ones: *)
apply(rule_tac x=y in exI)
apply(erule_tac x=x in allE)
apply(assumption)
done

text{* What happens if an unsafe rule is tried too early: *}
lemma "\<exists>y. \<forall>x. P x y \<Longrightarrow> \<forall>x. \<exists>y. P x y"
apply(rule allI)
apply(rule exI)
apply(erule exE)
apply(erule allE)
(* Fails now:
apply(assumption)
*)
oops

subsubsection{* Forward reasoning *}

lemma "A \<and> B \<Longrightarrow> \<not> \<not> A"
thm conjunct1
apply(drule conjunct1)
apply blast
done

subsubsection{* Automation *}

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

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

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

end


section \<open> Design Healthiness Conditions \<close>

theory utp_des_healths
  imports utp_des_core
          utp_des_laws
begin

subsection \<open> H1: No observation is allowed before initiation \<close>

definition H1 :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) des_rel" where
[pred, rel]: "H1(P) = (ok\<^sup>< \<longrightarrow> P)"

expr_ctr H1

lemma H1_idem:
  "H1 (H1 P) = H1(P)"
  by (pred_auto)

lemma H1_monotone:
  "P \<sqsubseteq> Q \<Longrightarrow> H1(P) \<sqsubseteq> H1(Q)"
  by (pred_auto)

lemma H1_Continuous: "Continuous H1"
  by (pred_auto)

lemma H1_below_top:
  "H1(P) \<sqsubseteq> \<top>\<^sub>D"
  by (pred_auto)

lemma H1_design_skip:
  "H1(II) = II\<^sub>D"
  by (pred_auto)

lemma H1_cond: "H1(P \<lhd> b \<rhd> Q) = H1(P) \<lhd> b \<rhd> H1(Q)"
  by (pred_auto)

lemma H1_conj: "H1(P \<and> Q) = (H1(P) \<and> H1(Q))"
  by (pred_auto)

lemma H1_disj: "H1(P \<or> Q) = (H1(P) \<or> H1(Q))"
  by (pred_auto)

lemma design_export_H1: "(P \<turnstile> Q) = (P \<turnstile> H1(Q))"
  by (pred_auto)

text \<open> The H1 algebraic laws are valid only when $\alpha(R)$ is homogeneous. This should maybe be
        generalised. \<close>

theorem H1_algebraic_intro:
  assumes
    "(true\<^sub>h ;; R) = true\<^sub>h"
    "(II\<^sub>D ;; R) = R"
  shows "R is H1"
proof -
  have "R = (II\<^sub>D ;; R)" by (simp add: assms(2))
  also have "... = (H1(II) ;; R)"
    by (simp add: H1_design_skip)
  also have "... = ((ok\<^sup>< \<longrightarrow> II) ;; R)"
    by (simp add: H1_def)
  also have "... = (((\<not> ok\<^sup><) ;; R) \<or> R)"
    by (pred_auto)
  also have "... = ((((\<not> ok\<^sup><) ;; true\<^sub>h) ;; R) \<or> R)"
    by (pred_auto)
  also have "... = (((\<not> (ok\<^sup><)) ;; true\<^sub>h) \<or> R)"
    by (metis assms(1) seqr_assoc)
  also have "... = (ok\<^sup>< \<longrightarrow> R)"
    by (pred_auto)
  finally show ?thesis by (metis H1_def Healthy_def')
qed

lemma nok_not_false:
  "(\<not> ok\<^sup><) \<noteq> false"
  by (pred_auto)

theorem H1_left_zero:
  assumes "P is H1"
  shows "(true ;; P) = true"
proof -
  from assms have "(true ;; P) = true ;; (ok\<^sup>< \<longrightarrow> P)"
    by (simp add: H1_def Healthy_def')
  (* The next step ensures we get the right alphabet for true by copying it *)
  also from assms have "... = (true ;; ((\<not> ok\<^sup><) \<or> P))" (is "_ = (?true ;; _)")
    by (pred_auto; blast)
  also from assms have "... = ((?true ;; (\<not> ok\<^sup><)) \<or> (?true ;; P))"
    by pred_auto
  also from assms have "... = (true \<or> (true ;; P))"
    by pred_auto
  finally show ?thesis
    by pred_auto
qed

theorem H1_left_unit:
  fixes P :: "('\<alpha>, '\<beta>) des_rel"
  assumes "P is H1"
  shows "(II\<^sub>D ;; P) = P"
proof -
  have "(II\<^sub>D ;; P) = ((ok\<^sup>< \<longrightarrow> II) ;; P)"
    by (metis H1_def H1_design_skip)
  also have "... = (((\<not> ok\<^sup><) ;; P) \<or> P)"
    by (pred_auto)
  also from assms have "... = ((((\<not> ok\<^sup><) ;; true\<^sub>h) ;; P) \<or> P)"
    by (pred_auto)
  also have "... = (((\<not> ok\<^sup><) ;; (true\<^sub>h ;; P)) \<or> P)"
    by (simp add: seqr_assoc)
  also from assms have "... = ((ok\<^sup><) \<longrightarrow> P)"
  proof -
    have "((\<not> (ok\<^sup><)) ;; (true\<^sub>h ;; P)) = ((\<not> (ok\<^sup><)) ;; true\<^sub>h)"
      using assms
      by (simp add: H1_left_zero, pred_auto)
    also have "... = (\<not> (ok\<^sup><))"
      by pred_auto
    finally show ?thesis
      by pred_auto
  qed
  finally show ?thesis using assms
    by (simp add: H1_def Healthy_def')
qed

theorem H1_algebraic:
  "P is H1 \<longleftrightarrow> (true\<^sub>h ;; P) = true\<^sub>h \<and> (II\<^sub>D ;; P) = P"
  using H1_algebraic_intro H1_left_unit H1_left_zero by metis

theorem H1_nok_left_zero:
  fixes P :: "'\<alpha> des_hrel"
  assumes "P is H1"
  shows "((\<not> ok\<^sup><) ;; P) = (\<not> ok\<^sup><)"
proof -
  have "((\<not> ok\<^sup><) ;; P) = (((\<not> ok\<^sup><) ;; true\<^sub>h) ;; P)"
    by pred_auto
  also have "... = ((\<not> ok\<^sup><) ;; true\<^sub>h)"
    by (metis H1_left_zero assms seqr_assoc)
  also have "... = (\<not> (ok\<^sup><))"
    by pred_auto
  finally show ?thesis .
qed

lemma H1_design:
  "H1(P \<turnstile> Q) = (P \<turnstile> Q)"
  by (pred_auto)

lemma H1_rdesign:
  "H1(P \<turnstile>\<^sub>r Q) = (P \<turnstile>\<^sub>r Q)"
  by (pred_auto)

lemma H1_choice_closed [closure]:
  "\<lbrakk> P is H1; Q is H1 \<rbrakk> \<Longrightarrow> P \<sqinter> Q is H1"
  by (metis H1_disj Healthy_if Healthy_intro disj_pred_def)

lemma H1_inf_closed [closure]:
  "\<lbrakk> P is H1; Q is H1 \<rbrakk> \<Longrightarrow> P \<squnion> Q is H1"
  by (metis H1_conj Healthy_def' conj_pred_def)

lemma H1_UINF:
  assumes "A \<noteq> {}"
  shows "H1(\<Sqinter> i \<in> A. P(i)) = (\<Sqinter> i \<in> A. H1(P(i)))"
  using assms by (pred_auto)

lemma H1_Sup:
  assumes "A \<noteq> {}" "\<forall> P \<in> A. P is H1"
  shows "(\<Sqinter> A) is H1"
proof -
  from assms(2) have "H1 ` A = A"
    by (auto simp add: Healthy_def rev_image_eqI)
  with H1_UINF[of A id, OF assms(1)] show ?thesis
    by (simp add: Healthy_def)
qed

lemma H1_USUP:
  shows "H1(\<Squnion> i \<in> A. P(i)) = (\<Squnion> i \<in> A. H1(P(i)))"
  by (pred_auto)

lemma H1_Inf [closure]:
  assumes "\<forall> P \<in> A. P is H1"
  shows "(\<Squnion> A) is H1"
proof -
  from assms have "H1 ` A = A"
    by (auto simp add: Healthy_def rev_image_eqI)
  then show ?thesis
    apply (simp add: Healthy_def)
    by (metis H1_USUP image_image)
qed

(*
lemma msubst_H1: "(\<And>x. P x is H1) \<Longrightarrow> P x\<lbrakk>x\<rightarrow>v\<rbrakk> is H1"
  by (rel_auto)
*)

subsection \<open> H2: A specification cannot require non-termination \<close>

definition J :: "'\<alpha> des_hrel" where
[pred]: "J = ((ok\<^sup>< \<longrightarrow> ok\<^sup>>) \<and> II \<up> more\<^sub>L\<^sup>2)\<^sub>e"

definition H2 where
[pred]: "H2 (P) \<equiv> P ;; J"

expr_ctr H2

lemma J_split:
  shows "(P ;; J) = (P\<^sup>f \<or> (P\<^sup>t \<and> ok\<^sup>>))"
proof -
  have "(P ;; J) = (P ;; ((ok\<^sup>< \<longrightarrow> ok\<^sup>>) \<and> II \<up> more\<^sub>L\<^sup>2))\<^sub>e"
    by (simp add: H2_def J_def design_def, pred_auto)
  also have "... = (P ;; ((ok\<^sup>< \<longrightarrow> (ok\<^sup>< \<and> ok\<^sup>>)) \<and> II \<up> more\<^sub>L\<^sup>2))\<^sub>e"
    by (pred_auto)
  also have "... = ((P ;; (\<not> ok\<^sup>< \<and> II \<up> more\<^sub>L\<^sup>2)) \<or> (P ;; (ok\<^sup>< \<and> (II \<up> more\<^sub>L\<^sup>2 \<and> ok\<^sup>>))))"
    by (pred_auto)
  also have "... = (P\<^sup>f \<or> (P\<^sup>t \<and> ok\<^sup>>))"
  proof -
    have "(P ;; (\<not> ok\<^sup>< \<and> II \<up> more\<^sub>L\<^sup>2)) = P\<^sup>f"
    proof -
      have "(P ;; (\<not> ok\<^sup>< \<and> II \<up> more\<^sub>L\<^sup>2)) = ((P \<and> \<not> ok\<^sup>>) ;; II \<up> more\<^sub>L\<^sup>2)"
        by (pred_auto)
      also have "... = (\<exists>ok\<^sup>> \<Zspot> (P \<and> ok\<^sup>> = False)\<^sub>e)"
        by pred_auto
      also have "... = P\<^sup>f"
        by pred_auto
      finally show ?thesis .
    qed
    moreover have "(P ;; (ok\<^sup>< \<and> (II \<up> more\<^sub>L\<^sup>2 \<and> ok\<^sup>>))) = (P\<^sup>t \<and> ok\<^sup>>)"
    proof -
      have "(P ;; (ok\<^sup>< \<and> (II \<up> more\<^sub>L\<^sup>2 \<and> ok\<^sup>>))) = (P ;; (ok\<^sup>< \<and> II))"
        by (pred_auto)
      also have "... = (P\<^sup>t \<and> ok\<^sup>>)"
        by (pred_auto)
      finally show ?thesis .
    qed
    ultimately show ?thesis
      by simp
  qed
  finally show ?thesis .
qed

lemma H2_split:
  shows "H2(P) = (P\<^sup>f \<or> (P\<^sup>t \<and> ok\<^sup>>))"
  by (simp add: H2_def J_split)

theorem H2_equivalence:
  "P is H2 \<longleftrightarrow> `(P\<^sup>f \<longrightarrow> P\<^sup>t)`"
  by (pred_auto, (metis (full_types))+)

(*
proof -
  have "(P = (P ;; J)) \<longleftrightarrow> (P = (P\<^sup>f \<or> (P\<^sup>t \<and> ok\<^sup>>)))"
    by (simp add: J_split)
  also have "... \<longleftrightarrow> `\<lbrakk>(P \<longleftrightarrow> P\<^sup>f \<or> P\<^sup>t \<and> (ok\<^sup>>)\<^sub>e)\<^sup>f \<and> (P \<longleftrightarrow> P\<^sup>f \<or> P\<^sup>t \<and> (ok\<^sup>>)\<^sub>e)\<rbrakk>\<^sub>P`"
    by rel_auto
  also have "... = `\<lbrakk>(P\<^sup>f \<longleftrightarrow> P\<^sup>f) \<and> (P\<^sup>t \<longleftrightarrow> P\<^sup>f \<or> P\<^sup>t)\<rbrakk>\<^sub>P`"
    apply pred_auto
    by metis+
  also have "... = `\<lbrakk>P\<^sup>t \<longleftrightarrow> (P\<^sup>f \<or> P\<^sup>t)\<rbrakk>\<^sub>P`"
    by (pred_auto)
  also have "... = `P\<^sup>f \<longrightarrow> P\<^sup>t`"
    by (pred_auto)
  finally show ?thesis
    using H2_def Healthy_def'
    by (metis (no_types, lifting) SEXP_def conj_refine_left iff_pred_def pred_ba.boolean_algebra.conj_one_right pred_ba.inf_le2 pred_ba.sup.absorb2 pred_ba.sup.orderE pred_impl_laws(5) pred_set rel_eq_iff taut_def true_false_pred_expr(1))
qed
*)

lemma H2_equiv:
  "P is H2 \<longleftrightarrow> P\<^sup>t \<sqsubseteq> P\<^sup>f"
  by (simp add: H2_equivalence pred_refine_iff, expr_simp)

lemma H2_design:
  assumes "$ok\<^sup>> \<sharp> P" "$ok\<^sup>> \<sharp> Q"
  shows "H2(P \<turnstile> Q) = P \<turnstile> Q"
  using assms
  by (simp add: H2_split design_def usubst unrest, pred_auto)

lemma H2_rdesign:
  "H2(P \<turnstile>\<^sub>r Q) = P \<turnstile>\<^sub>r Q"
  by (simp add: H2_design unrest rdesign_def)

theorem J_idem:
  "(J ;; J) = J"
  by (pred_auto)

theorem H2_idem:
  "H2(H2(P)) = H2(P)"
  by (metis H2_def J_idem seqr_assoc)

(*
theorem H2_Continuous: "Continuous H2"
  by (rel_auto)
*)

theorem H2_not_okay: "H2 (\<not>ok\<^sup><) = (\<not>ok\<^sup><)"
proof -
  have "H2 (\<not>ok\<^sup><) = ((\<not>ok\<^sup><)\<^sup>f \<or> ((\<not>ok\<^sup><)\<^sup>t \<and> ok\<^sup>>))"
    by (simp add: H2_split)
  also have "... = (\<not> ok\<^sup>< \<or> (\<not>ok\<^sup><) \<and> ok\<^sup>>)"
    by (pred_auto)
  also have "... = (\<not> ok\<^sup><)"
    by (pred_auto)
  finally show ?thesis .
qed

lemma H2_true: "H2(true) = true"
  by (pred_auto)

lemma H2_choice_closed [closure]:
  "\<lbrakk> P is H2; Q is H2 \<rbrakk> \<Longrightarrow> P \<sqinter> Q is H2"
  by (metis H2_def Healthy_def' disj_pred_def seqr_or_distl)

lemma H2_inf_closed [closure]:
  assumes "P is H2" "Q is H2"
  shows "P \<squnion> Q is H2"
proof -
  have "P \<squnion> Q = (P\<^sup>f \<or> P\<^sup>t \<and> ok\<^sup>>) \<squnion> (Q\<^sup>f \<or> Q\<^sup>t \<and> ok\<^sup>>)"
    by (metis H2_def Healthy_def J_split assms(1) assms(2))
  moreover have "H2(...) = ..."
    by (simp add: H2_split usubst, pred_auto)
  ultimately show ?thesis
    by (simp add: Healthy_def)
qed

lemma H2_USUP:
  shows "H2(\<Sqinter> i \<in> A. P(i)) = (\<Sqinter> i \<in> A. H2(P(i)))"
  by (pred_auto)

theorem H1_H2_commute:
  "H1 (H2 P) = H2 (H1 P)"
proof -
  have "H2 (H1 P) = ((ok\<^sup>< \<longrightarrow> P) ;; J)"
    by (simp add: H1_def H2_def)
  also have "... = ((\<not> ok\<^sup>< \<or> P) ;; J)"
    by (pred_auto)
  also have "... = (((\<not> ok\<^sup><) ;; J) \<or> (P ;; J))"
    by (pred_auto)
  also have "... =  ((H2 (\<not> ok\<^sup><)) \<or> H2(P))"
    by (simp add: H2_def)
  also have "... =  ((\<not> ok\<^sup><) \<or> H2(P))"
    by (pred_auto)
  also have "... = H1(H2(P))"
    by (pred_auto)
  finally show ?thesis by simp
qed

subsection \<open> Designs as $H1$-$H2$ predicates \<close>

abbreviation H1_H2 :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) des_rel" ("\<^bold>H") where
"H1_H2 P \<equiv> H1 (H2 P)"

lemma H1_H2_comp: "\<^bold>H = H1 \<circ> H2"
  by (auto)

theorem H1_H2_eq_design:
  "\<^bold>H(P) = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
proof -
  have "\<^bold>H(P) = (ok\<^sup>< \<longrightarrow> H2(P))"
    by (simp add: H1_def)
  also have "... = (ok\<^sup>< \<longrightarrow> (P\<^sup>f \<or> (P\<^sup>t \<and> ok\<^sup>>)))\<^sub>e"
    by (simp add:H2_split, pred_auto)
  also have "... = (ok\<^sup>< \<and> (\<not> P\<^sup>f) \<longrightarrow> ok\<^sup>> \<and> ok\<^sup>< \<and> P\<^sup>t)\<^sub>e"
    by (pred_auto)
  also have "... = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
    by (pred_auto)
  finally show ?thesis .
qed

theorem H1_H2_is_design:
  assumes "P is H1" "P is H2"
  shows "P = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
  using assms by (metis H1_H2_eq_design Healthy_def)

(*
lemma aext_arestr' [alpha]:
  fixes P :: "'a \<leftrightarrow> 'b"
  assumes "$a \<sharp> P"
  shows "(P \<down> a) \<up> a = P"
  apply rel_auto
  by (rel_simp, metis assms lens_override_def)
*)

theorem H1_H2_eq_rdesign:
  "\<^bold>H(P) = pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
proof -
  have "\<^bold>H(P) = (ok\<^sup>< \<longrightarrow> H2(P))"
    by (simp add: H1_def Healthy_def')
  also have "... = (ok\<^sup>< \<longrightarrow> (P\<^sup>f \<or> (P\<^sup>t \<and> ok\<^sup>>)))"
    by (simp add: H2_split)
  also have "... = (ok\<^sup>< \<and> (\<not> P\<^sup>f) \<longrightarrow> ok\<^sup>> \<and> P\<^sup>t)"
    by (pred_auto)
  also have "... = (ok\<^sup>< \<and> (\<not> P\<^sup>f) \<longrightarrow> ok\<^sup>> \<and> ok\<^sup>< \<and> P\<^sup>t)"
    by (pred_auto)
  also have "... = ((ok\<^sup>< \<and> (pre\<^sub>D(P) \<up> more\<^sub>L\<^sup>2)) \<longrightarrow> ok\<^sup>> \<and> ok\<^sup>< \<and> (post\<^sub>D(P) \<up> more\<^sub>L\<^sup>2))"
    by (simp add: ok_post ok_pre )
  also have "... = (ok\<^sup>< \<and> (pre\<^sub>D(P) \<up> more\<^sub>L\<^sup>2) \<longrightarrow> ok\<^sup>> \<and> (post\<^sub>D(P)\<up> more\<^sub>L\<^sup>2))\<^sub>e"
    by (pred_auto)
  also have "... = pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
    by (simp add: rdesign_def design_def)
  finally show ?thesis .
qed

theorem H1_H2_is_rdesign:
  assumes "P is H1" "P is H2"
  shows "P = pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
  by (metis H1_H2_eq_rdesign Healthy_def assms(1) assms(2))

thm H1_H2_eq_rdesign
thm rdesign_refinement

lemma H1_H2_refinement:
  assumes "P is \<^bold>H" "Q is \<^bold>H"
  shows "P \<sqsubseteq> Q \<longleftrightarrow> (`pre\<^sub>D(P) \<longrightarrow> pre\<^sub>D(Q)` \<and> `pre\<^sub>D(P) \<and> post\<^sub>D(Q) \<longrightarrow> post\<^sub>D(P)`)"
  using assms
  apply (simp only:rdesign_refinement[symmetric])
  by (metis H1_H2_eq_rdesign Healthy_if)

lemma H1_H2_refines:
  assumes "P is \<^bold>H" "Q is \<^bold>H" "P \<sqsubseteq> Q"
  shows "pre\<^sub>D(Q) \<sqsubseteq> pre\<^sub>D(P)" "post\<^sub>D(P) \<sqsubseteq> (pre\<^sub>D(P) \<and> post\<^sub>D(Q))"
  apply (metis assms(3) conj_pred_def design_pre_choice ref_lattice.inf.absorb_iff2 ref_lattice.le_iff_sup)
  apply (metis assms(3) design_post_choice pred_ba.inf_le2 pred_ba.le_supI1 ref_lattice.inf.absorb_iff2)
  done

lemma H1_H2_idempotent: "\<^bold>H (\<^bold>H P) = \<^bold>H P"
  by (simp add: H1_H2_commute H1_idem H2_idem)

lemma H1_H2_Idempotent [closure]: "Idempotent \<^bold>H"
  by (simp add: Idempotent_def H1_H2_idempotent)

(*
lemma H1_H2_monotonic [closure]: "Monotone \<^bold>H"
  by (simp add: H1_monotone H2_def mono_def seqr_mono)

lemma H1_H2_Continuous [closure]: "Continuous \<^bold>H"
  by (simp add: Continuous_comp H1_Continuous H1_H2_comp H2_Continuous)
*)

lemma H1_H2_false: "\<^bold>H false = \<top>\<^sub>D"
  by (pred_auto)

lemma H1_H2_true: "\<^bold>H true = \<bottom>\<^sub>D"
  by (pred_auto)

lemma design_is_H1_H2 [closure]:
  "\<lbrakk> $ok\<^sup>> \<sharp> P; $ok\<^sup>> \<sharp> Q \<rbrakk> \<Longrightarrow> (P \<turnstile> Q) is \<^bold>H"
  by (simp add: H1_design H2_design Healthy_def')

lemma rdesign_is_H1_H2 [closure]:
  "(P \<turnstile>\<^sub>r Q) is \<^bold>H"
  by (simp add: Healthy_def H1_rdesign H2_rdesign)

lemma top_d_is_H1_H2 [closure]: "\<top>\<^sub>D is \<^bold>H"
  by (simp add: rdesign_is_H1_H2 top_d_ndes_def)

lemma bot_d_is_H1_H2 [closure]: "\<bottom>\<^sub>D is \<^bold>H"
  by (metis bot_d_true rdesign_is_H1_H2 true_is_rdesign)

lemma seq_r_H1_H2_closed [closure]:
  assumes "P is \<^bold>H" "Q is \<^bold>H"
  shows "(P ;; Q) is \<^bold>H"
proof -
  obtain P\<^sub>1 P\<^sub>2 where "P = P\<^sub>1 \<turnstile>\<^sub>r P\<^sub>2"
    by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def assms(1))
  moreover obtain Q\<^sub>1 Q\<^sub>2 where "Q = Q\<^sub>1 \<turnstile>\<^sub>r Q\<^sub>2"
   by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def assms(2))
  moreover have "((P\<^sub>1 \<turnstile>\<^sub>r P\<^sub>2) ;; (Q\<^sub>1 \<turnstile>\<^sub>r Q\<^sub>2)) is \<^bold>H"
    by (simp add: rdesign_composition rdesign_is_H1_H2)
  ultimately show ?thesis by simp
qed

lemma H1_H2_left_unit: "P is \<^bold>H \<Longrightarrow> II\<^sub>D ;; P = P"
  by (metis H1_H2_eq_rdesign Healthy_def' rdesign_left_unit)

thm design_is_H1_H2

lemma UINF_H1_H2_closed [closure]:
  assumes "A \<noteq> {}" "\<forall> P \<in> A. P is \<^bold>H"
  shows "(\<Sqinter> A) is H1_H2"
proof -
  from assms have A: "A = H1_H2 ` A"
    by (auto simp add: Healthy_def rev_image_eqI)
  then have "\<Sqinter> (...) = (\<Sqinter> P \<in> A. (\<not> P\<^sup>f) \<turnstile> P\<^sup>t)"
    by (simp add:H1_H2_eq_design)
  also have "... = (\<Squnion> P \<in> A. \<not> P\<^sup>f) \<turnstile> (\<Sqinter> P \<in> A. P\<^sup>t)"
    by (simp add: design_UINF_mem assms)
  also have "... is H1_H2"
  proof -
    have "$ok\<^sup>> \<sharp> (\<Squnion>P\<in>A. \<not> P\<lbrakk>False/ok\<^sup>>\<rbrakk>)"
         "$ok\<^sup>> \<sharp> (\<Sqinter>P \<in> A. P\<^sup>t)"
      by (pred_auto)+
    then show ?thesis
      by (simp add: design_is_H1_H2)
  qed
  ultimately show ?thesis using A by auto
qed

definition design_inf :: "('\<alpha>, '\<beta>) des_rel set \<Rightarrow> ('\<alpha>, '\<beta>) des_rel" ("\<Sqinter>\<^sub>D_" [900] 900) where
"\<Sqinter>\<^sub>D A = (if (A = {}) then \<top>\<^sub>D else \<Sqinter> A)"

abbreviation design_sup :: "('\<alpha>, '\<beta>) des_rel set \<Rightarrow> ('\<alpha>, '\<beta>) des_rel" ("\<Squnion>\<^sub>D_" [900] 900) where
"\<Squnion>\<^sub>D A \<equiv> \<Squnion> A"

lemma design_inf_H1_H2_closed:
  assumes "\<forall> P \<in> A. P is \<^bold>H"
  shows "(\<Sqinter>\<^sub>D A) is \<^bold>H"
  using assms
  by (auto simp add: design_inf_def closure)

lemma design_sup_empty [simp]: "\<Sqinter>\<^sub>D {} = \<top>\<^sub>D"
  by (simp add: design_inf_def)

lemma design_sup_non_empty [simp]: "A \<noteq> {} \<Longrightarrow> \<Sqinter>\<^sub>D A = \<Sqinter> A"
  by (simp add: design_inf_def)

thm design_is_H1_H2

lemma USUP_mem_H1_H2_closed:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is \<^bold>H"
  shows "(\<Squnion> i\<in>A. P i) is \<^bold>H"
proof -
  from assms have "(\<Squnion> i\<in>A. P i) = (\<Squnion> i\<in>A. \<^bold>H(P i))"
    by (simp add:Healthy_def)
  also have "... = (\<Squnion> i\<in>A. (\<not> (P i)\<^sup>f) \<turnstile> (P i)\<^sup>t)"
    by (simp add:H1_H2_eq_design)
  also have "... = (\<Sqinter> i\<in>A. \<not> (P i)\<^sup>f) \<turnstile> (\<Squnion> i\<in>A. (\<not> (@(P i))\<^sup>f \<longrightarrow> (@(P i))\<^sup>t)\<^sub>e)"
    by (simp add: design_USUP_mem, pred_auto)
  also have "... is \<^bold>H"
  proof -
    have "$ok\<^sup>> \<sharp> (\<Sqinter> i\<in>A. \<not> (P i)\<^sup>f)"
         "$ok\<^sup>> \<sharp> (\<Squnion> i\<in>A. (\<not> (@(P i))\<^sup>f \<longrightarrow> (@(P i))\<^sup>t)\<^sub>e)"
      by pred_auto+
    then show ?thesis
      using design_is_H1_H2 by blast
  qed
  ultimately show ?thesis by auto
qed

lemma USUP_ind_H1_H2_closed:
  assumes "\<And> i. P i is \<^bold>H"
  shows "(\<Squnion> i. P i) is \<^bold>H"
  using assms USUP_mem_H1_H2_closed[of UNIV P] by simp

lemma Inf_H1_H2_closed:
  assumes "\<forall> P \<in> A. P is \<^bold>H"
  shows "(\<Squnion> A) is \<^bold>H"
proof -
  from assms have A: "A = \<^bold>H ` A"
    by (auto simp add: Healthy_def rev_image_eqI)
  also have "(\<Squnion> ...) = (\<Squnion> P \<in> A. \<^bold>H(P))"
    by auto
  also have B: "... = (\<Squnion> P \<in> A. (\<not> P\<^sup>f) \<turnstile> P\<^sup>t)"
    by (simp add:H1_H2_eq_design)
  then have C: "... = (\<Sqinter> P \<in> A. \<not> P\<^sup>f) \<turnstile> (\<Squnion> P \<in> A. (\<not> P\<^sup>f \<longrightarrow> P\<^sup>t)\<^sub>e)"
    by (simp add: design_USUP_mem, pred_auto)
  then have "... is \<^bold>H"
  proof -
    have "$ok\<^sup>> \<sharp> (\<Sqinter>P\<in>A. \<not> P\<lbrakk>False/ok\<^sup>>\<rbrakk>)"
         "$ok\<^sup>> \<sharp> \<Squnion>\<^sub>D((\<lambda>P. (\<not> P\<lbrakk>False/ok\<^sup>>\<rbrakk> \<longrightarrow> P\<lbrakk>True/ok\<^sup>>\<rbrakk>)\<^sub>e) ` A)"
      by (pred_auto)+
    then show ?thesis
      using design_is_H1_H2 by auto
  qed
  ultimately show ?thesis using A B C by auto
qed

lemma rdesign_ref_monos:
  assumes "P is \<^bold>H" "Q is \<^bold>H" "P \<sqsubseteq> Q"
  shows "pre\<^sub>D(Q) \<sqsubseteq> pre\<^sub>D(P)" "post\<^sub>D(P) \<sqsubseteq> (pre\<^sub>D(P) \<and> post\<^sub>D(Q))"
proof -
  have r: "P \<sqsubseteq> Q \<longleftrightarrow> (`pre\<^sub>D(P) \<longrightarrow> pre\<^sub>D(Q)` \<and> `pre\<^sub>D(P) \<and> post\<^sub>D(Q) \<longrightarrow> post\<^sub>D(P)`)"
    using assms(3) design_refine_thms(1) design_refine_thms(2) by blast
  from r assms show "pre\<^sub>D(Q) \<sqsubseteq> pre\<^sub>D(P)"
    using H1_H2_refines(1) by blast
  from r assms show "post\<^sub>D(P) \<sqsubseteq> (pre\<^sub>D(P) \<and> post\<^sub>D(Q))"
    using H1_H2_refines(2) by blast
qed

subsection \<open> H3: The design assumption is a precondition \<close>

definition H3 :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) des_rel" where
[pred]: "H3 (P) \<equiv> P ;; II\<^sub>D"

theorem H3_idem:
  "H3(H3(P)) = H3(P)"
  by (metis H3_def design_skip_idem seqr_assoc)

theorem H3_mono:
  "P \<sqsubseteq> Q \<Longrightarrow> H3(P) \<sqsubseteq> H3(Q)"
  by (simp add: H3_def seqr_mono)

(*
theorem H3_Monotonic:
  "Monotonic H3"
  by (simp add: H3_mono mono_def)

theorem H3_Continuous: "Continuous H3"
  by (rel_auto)
*)

theorem design_condition_is_H3:
  assumes "out\<alpha> \<sharp> p"
  shows "(p \<turnstile> Q) is H3"
proof -
  have "((p \<turnstile> Q) ;; II\<^sub>D) = (\<not> ((\<not> p) ;; true)) \<turnstile> (Q\<^sup>t ;; II\<lbrakk>True/ok\<^sup><\<rbrakk>)"
    by (simp add: skip_d_alt_def design_composition_subst unrest assms)
  also have "... = p \<turnstile> (Q\<^sup>t ;; II\<lbrakk>True/ok\<^sup><\<rbrakk>)"
    using assms precond_equiv seqr_true_lemma
    by metis
  also have "... = p \<turnstile> Q"
    by (pred_auto)
  finally show ?thesis
    by (simp add: H3_def Healthy_def')
qed

theorem rdesign_H3_iff_pre:
  "P \<turnstile>\<^sub>r Q is H3 \<longleftrightarrow> P = (P ;; true)"
proof -
  have "(P \<turnstile>\<^sub>r Q) ;; II\<^sub>D = (P \<turnstile>\<^sub>r Q) ;; (true \<turnstile>\<^sub>r II)"
    by (simp add: skip_d_def)
  also have "... = (\<not> ((\<not> P) ;; true) \<and> \<not> (Q ;; (\<not> true))) \<turnstile>\<^sub>r (Q ;; II)"
    by (simp add: rdesign_composition)
  also have "... = (\<not> ((\<not> P) ;; true) \<and> \<not> (Q ;; (\<not> true))) \<turnstile>\<^sub>r Q"
    by (pred_auto)
  also have "... = (\<not> ((\<not> P) ;; true)) \<turnstile>\<^sub>r Q"
    by (pred_auto)
  finally have "P \<turnstile>\<^sub>r Q is H3 \<longleftrightarrow> P \<turnstile>\<^sub>r Q = (\<not> ((\<not> P) ;; true)) \<turnstile>\<^sub>r Q"
    by (metis H3_def Healthy_def')
  also have "... \<longleftrightarrow> P = (\<not> ((\<not> P) ;; true))"
    by (metis rdesign_pre)
  also have "... \<longleftrightarrow> P = (P ;; true)"
    by (simp add: seqr_true_lemma)
  finally show ?thesis .
qed

theorem design_H3_iff_pre:
  assumes "$ok\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> P" "$ok\<^sup>< \<sharp> Q" "$ok\<^sup>> \<sharp> Q"
  shows "P \<turnstile> Q is H3 \<longleftrightarrow> P = (P ;; true)"
proof -
  have "P \<turnstile> Q = (P \<down> more\<^sub>L\<^sup>2) \<turnstile>\<^sub>r (Q \<down> more\<^sub>L\<^sup>2)"
    by (simp add: assms rdesign_def lift_desr_inv)
  moreover hence "(P \<down> more\<^sub>L\<^sup>2) \<turnstile>\<^sub>r (Q \<down> more\<^sub>L\<^sup>2) is H3 \<longleftrightarrow> (P \<down> more\<^sub>L\<^sup>2) = ((P \<down> more\<^sub>L\<^sup>2) ;; true)"
    using rdesign_H3_iff_pre by blast
  ultimately show ?thesis
    by (metis assms(1,2) design_condition_is_H3 lift_desr_inv unrest_out_des_lift utp_rel_laws.precond_equiv)
qed

theorem H1_H3_commute:
  "H1 (H3 P) = H3 (H1 P)"
  by (pred_auto)

lemma skip_d_absorb_J_1:
  "(II\<^sub>D ;; J) = II\<^sub>D"
  by (metis H2_def H2_rdesign skip_d_def)

lemma skip_d_absorb_J_2:
  "(J ;; II\<^sub>D) = II\<^sub>D"
proof -
  have "(J ;; II\<^sub>D) = ((ok\<^sup>< \<longrightarrow> ok\<^sup>>) \<and> II \<up> more\<^sub>L\<^sup>2)\<^sub>e ;; (true \<turnstile> II)"
    by (simp add: J_def skip_d_alt_def)
  also have "... = ((((ok\<^sup>< \<longrightarrow> ok\<^sup>>)\<^sub>e \<and> II \<up> more\<^sub>L\<^sup>2)\<lbrakk>False/ok\<^sup>>\<rbrakk> ;; (true \<turnstile> II)\<lbrakk>False/ok\<^sup><\<rbrakk>)
                  \<or> (((ok\<^sup>< \<longrightarrow> ok\<^sup>>)\<^sub>e \<and> II \<up> more\<^sub>L\<^sup>2)\<lbrakk>True/ok\<^sup>>\<rbrakk> ;; (true \<turnstile> II)\<lbrakk>True/ok\<^sup><\<rbrakk>))"
    by (pred_auto)
  also have "... = ((\<not>ok\<^sup>< \<and> II \<up> more\<^sub>L\<^sup>2 ;; true) \<or> (II \<up> more\<^sub>L\<^sup>2 ;; ok\<^sup>> \<and> II \<up> more\<^sub>L\<^sup>2))"
    by (pred_auto)
  also have "... = II\<^sub>D"
    by (pred_auto)
  finally show ?thesis .
qed

lemma H2_H3_absorb:
  "H2 (H3 P) = H3 P"
  by (metis H2_def H3_def seqr_assoc skip_d_absorb_J_1)

lemma H3_H2_absorb:
  "H3 (H2 P) = H3 P"
  by (metis H2_def H3_def seqr_assoc skip_d_absorb_J_2)

theorem H2_H3_commute:
  "H2 (H3 P) = H3 (H2 P)"
  by (simp add: H2_H3_absorb H3_H2_absorb)

theorem H3_design_pre:
  assumes "$ok\<^sup>< \<sharp> p" "out\<alpha> \<sharp> p" "$ok\<^sup>< \<sharp> Q" "$ok\<^sup>> \<sharp> Q"
  shows "H3(p \<turnstile> Q) = p \<turnstile> Q"
  using assms
  using Healthy_def design_condition_is_H3 by auto

theorem H3_rdesign_pre:
  assumes "out\<alpha> \<sharp> p"
  shows "H3(p \<turnstile>\<^sub>r Q) = p \<turnstile>\<^sub>r Q"
  using assms
  by (simp add: H3_def)

theorem H3_ndesign: "H3(p \<turnstile>\<^sub>n Q) = (p \<turnstile>\<^sub>n Q)"
  by pred_auto

theorem ndesign_is_H3 [closure]: "p \<turnstile>\<^sub>n Q is H3"
  by (simp add: H3_ndesign Healthy_def)

(*
lemma msubst_pre_H3: "(\<And>x. P x is H3) \<Longrightarrow> P x\<lbrakk>x\<rightarrow>\<lceil>v\<rceil>\<^sub><\<rbrakk> is H3"
  by (rel_auto)
*)

subsection \<open> Normal Designs as $H1$-$H3$ predicates \<close>

text \<open> A normal design~\cite{Guttman2010} refers only to initial state variables in the precondition. \<close>

abbreviation H1_H3 :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) des_rel" ("\<^bold>N") where
"H1_H3 p \<equiv> H1 (H3 p)"

lemma H1_H3_comp: "H1_H3 = H1 \<circ> H3"
  by (auto)

theorem H1_H3_is_design:
  assumes "P is H1" "P is H3"
  shows "P = (\<not> P\<^sup>f) \<turnstile> P\<^sup>t"
  by (metis H1_H2_eq_design H2_H3_absorb Healthy_def' assms(1) assms(2))

theorem H1_H3_is_rdesign:
  assumes "P is H1" "P is H3"
  shows "P = pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P)"
  by (metis H1_H2_is_rdesign H2_H3_absorb Healthy_def' assms)

theorem H1_H3_is_normal_design:
  assumes "P is H1" "P is H3"
  shows "P = (pre\<^sub>D(P))\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P)"
  by (metis H1_H3_is_rdesign SEXP_def assms drop_pre_inv rdesign_H3_iff_pre utp_rel.postcond_equiv)

lemma H1_H3_idempotent: "\<^bold>N (\<^bold>N P) = \<^bold>N P"
  by (simp add: H1_H3_commute H1_idem H3_idem)

lemma H1_H3_Idempotent [closure]: "Idempotent \<^bold>N"
  by (simp add: Idempotent_def H1_H3_idempotent)

(*
lemma H1_H3_monotonic [closure]: "Monotonic \<^bold>N"
  by (simp add: H1_monotone H3_mono mono_def)

lemma H1_H3_Continuous [closure]: "Continuous \<^bold>N"
  by (simp add: Continuous_comp H1_Continuous H1_H3_comp H3_Continuous)
*)
lemma H1_H3_false: "\<^bold>N false = \<top>\<^sub>D"
  by (pred_auto)

lemma H1_H3_true: "\<^bold>N true = \<bottom>\<^sub>D"
  by (pred_auto)

lemma H1_H3_intro:
  assumes "P is \<^bold>H" "out\<alpha> \<sharp> pre\<^sub>D(P)"
  shows "P is \<^bold>N"
  by (metis H1_H2_eq_rdesign H1_rdesign H3_rdesign_pre Healthy_def' assms)

lemma H1_H3_left_unit: "P is \<^bold>N \<Longrightarrow> II\<^sub>D ;; P = P"
  by (metis H1_H2_left_unit H1_H3_commute H2_H3_absorb H3_idem Healthy_def)

lemma H1_H3_right_unit: "P is \<^bold>N \<Longrightarrow> P ;; II\<^sub>D = P"
  by (metis H1_H3_commute H3_def H3_idem Healthy_def)

lemma H1_H3_top_left: "P is \<^bold>N \<Longrightarrow> \<top>\<^sub>D ;; P = \<top>\<^sub>D"
  by (metis H1_H2_eq_design H2_H3_absorb Healthy_if design_top_left_zero)

lemma H1_H3_bot_left: "P is \<^bold>N \<Longrightarrow> \<bottom>\<^sub>D ;; P = \<bottom>\<^sub>D"
  by (metis H1_idem H1_left_zero Healthy_def bot_d_true)

lemma H1_H3_impl_H2 [closure]: "P is \<^bold>N \<Longrightarrow> P is \<^bold>H"
  by (metis H1_H2_commute H1_idem H2_H3_absorb Healthy_def')

lemma H1_H3_eq_design_d_comp: "\<^bold>N(P) = ((\<not> P\<^sup>f) \<turnstile> P\<^sup>t) ;; II\<^sub>D"
  by (metis H1_H2_eq_design H1_H3_commute H3_H2_absorb H3_def)

lemma H1_H3_eq_design: "\<^bold>N(P) = (\<not> (P\<^sup>f ;; true)) \<turnstile> P\<^sup>t"
  apply (simp add: H1_H3_eq_design_d_comp skip_d_alt_def)
  apply (subst design_composition_subst)
  by pred_auto+

lemma H3_unrest_out_alpha_nok [unrest]:
  assumes "P is \<^bold>N"
  shows "out\<alpha> \<sharp> P\<^sup>f"
proof -
  have "P = (\<not> (P\<^sup>f ;; true)) \<turnstile> P\<^sup>t"
    by (metis H1_H3_eq_design Healthy_def assms)
  also have "out\<alpha> \<sharp> (...\<^sup>f)"
    by (simp add: design_def usubst unrest, pred_auto)
  ultimately show ?thesis by auto
qed

lemma H3_unrest_out_alpha [unrest]: "P is \<^bold>N \<Longrightarrow> out\<alpha> \<sharp> pre\<^sub>D(P)"
  by (metis H1_H3_commute H1_H3_is_rdesign H1_idem Healthy_def' precond_equiv rdesign_H3_iff_pre)

lemma ndesign_H1_H3 [closure]: "p \<turnstile>\<^sub>n Q is \<^bold>N"
  by (simp add: H1_rdesign H3_def Healthy_def', pred_auto)

lemma ndesign_form: "P is \<^bold>N \<Longrightarrow> ((pre\<^sub>D(P))\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P)) = P"
  by (metis H1_H3_is_normal_design H1_H3_right_unit H3_def Healthy_def)

lemma des_bot_H1_H3 [closure]: "\<bottom>\<^sub>D is \<^bold>N"
  by (metis H1_design H3_def Healthy_def' design_false_pre design_true_left_zero skip_d_alt_def bot_d_def)

lemma des_top_is_H1_H3 [closure]: "\<top>\<^sub>D is \<^bold>N"
  by (metis ndesign_H1_H3 ndesign_miracle)

lemma skip_d_is_H1_H3 [closure]: "II\<^sub>D is \<^bold>N"
  by (simp add: ndesign_H1_H3 skip_d_ndes_def)

lemma seq_r_H1_H3_closed [closure]:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "(P ;; Q) is \<^bold>N"
  by (metis (no_types) H1_H2_eq_design H1_H3_eq_design_d_comp H1_H3_impl_H2 Healthy_def assms(1) assms(2) seq_r_H1_H2_closed seqr_assoc)

lemma dcond_H1_H2_closed [closure]:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "(P \<triangleleft> b \<triangleright>\<^sub>D Q) is \<^bold>N"
  by (metis assms ndesign_H1_H3 ndesign_dcond ndesign_form)

lemma inf_H1_H2_closed [closure]:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "(P \<sqinter> Q) is \<^bold>N"
proof -
  obtain P\<^sub>1 P\<^sub>2 Q\<^sub>1 Q\<^sub>2 where P:"P = (P\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2)" and Q:"Q = (Q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2)"
    by (metis assms ndesign_form)
  have "(P\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2) \<sqinter> (Q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2) = (P\<^sub>1 \<and> Q\<^sub>1) \<turnstile>\<^sub>n (P\<^sub>2 \<or> Q\<^sub>2)"
    by (simp add: ndesign_choice)
  moreover have "... is \<^bold>N"
    by (simp add: ndesign_H1_H3)
  ultimately show ?thesis by (simp add: P Q)
qed

lemma sup_H1_H2_closed [closure]:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "(P \<squnion> Q) is \<^bold>N"
proof -
  obtain P\<^sub>1 P\<^sub>2 Q\<^sub>1 Q\<^sub>2 where P:"P = (P\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2)" and Q:"Q = (Q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2)"
    by (metis assms ndesign_form)
  have "(P\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2) \<squnion> (Q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2) = (P\<^sub>1 \<or> Q\<^sub>1) \<turnstile>\<^sub>n ((P\<^sub>1\<^sup>< \<longrightarrow> P\<^sub>2) \<and> (Q\<^sub>1\<^sup>< \<longrightarrow> Q\<^sub>2))"
    by (simp add: ndesign_inf)
  moreover have "... is \<^bold>N"
    by (simp add: ndesign_H1_H3)
  ultimately show ?thesis by (simp add: P Q)
qed

lemma ndes_seqr_miracle:
  assumes "P is \<^bold>N"
  shows "P ;; \<top>\<^sub>D = (pre\<^sub>D P)\<^sub>< \<turnstile>\<^sub>n false"
proof -
  have "P ;; \<top>\<^sub>D = ((pre\<^sub>D(P))\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P)) ;; (True \<turnstile>\<^sub>n false)"
    by (simp add: assms ndesign_form ndesign_miracle)
  also have "... = (pre\<^sub>D P)\<^sub>< \<turnstile>\<^sub>n false"
    by (simp add: ndesign_composition_wlp wp)
  finally show ?thesis .
qed

lemma ndes_seqr_abort:
  assumes "P is \<^bold>N"
  shows "P ;; \<bottom>\<^sub>D = ((pre\<^sub>D P)\<^sub>< \<and> post\<^sub>D P wlp False) \<turnstile>\<^sub>n false"
proof -
  have "P ;; \<bottom>\<^sub>D = ((pre\<^sub>D(P))\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P)) ;; (False \<turnstile>\<^sub>n false)"
    by (simp add: assms bot_d_true ndesign_false_pre ndesign_form)
  also have "... = ((pre\<^sub>D P)\<^sub>< \<and> post\<^sub>D P wlp False) \<turnstile>\<^sub>n false"
    by (simp add: ndesign_composition_wlp)
  finally show ?thesis .
qed

lemma USUP_ind_H1_H3_closed [closure]:
  "\<lbrakk> \<And> i. P i is \<^bold>N \<rbrakk> \<Longrightarrow> (\<Squnion> i. P i) is \<^bold>N"
  by (rule H1_H3_intro, simp_all add: H1_H3_impl_H2 USUP_ind_H1_H2_closed preD_USUP_ind unrest)

(*
lemma msubst_pre_H1_H3 [closure]: "(\<And>x. P x is \<^bold>N) \<Longrightarrow> P x\<lbrakk>x\<rightarrow>\<lceil>v\<rceil>\<^sub><\<rbrakk> is \<^bold>N"
  by (metis H1_H3_right_unit H3_def Healthy_if Healthy_intro msubst_H1 msubst_pre_H3)
*)

subsection \<open> H4: Feasibility \<close>

definition H4 :: "('\<alpha>, '\<beta>) des_rel \<Rightarrow> ('\<alpha>, '\<beta>) des_rel" where
[pred]: "H4(P) = ((P;;true) \<longrightarrow> P)"

theorem H4_idem:
  "H4(H4(P)) = H4(P)"
  by (pred_auto)

lemma is_H4_alt_def:
  "P is H4 \<longleftrightarrow> (P ;; true) = true"
  by (pred_auto, blast)

end


theory ImageP
imports Relation
begin

subsubsection {* Image of a set under a relation *}

definition ImageP :: "('a \<Rightarrow> 'b \<Rightarrow> bool) => 'a set => 'b set" (infixr "```" 90)
where
  "r ``` s = {y. \<exists>x\<in>s. r x y}"

declare Image_def [no_atp]

lemma ImageP_iff: "(b : r```A) = (EX x:A. r x b)"
  by (simp add: ImageP_def)

lemma ImageP_singleton: "r```{a} = {b. r a b}"
  by (simp add: ImageP_def)

lemma ImageP_singleton_iff [iff]: "(b : r```{a}) = (r a b)"
  by (rule ImageP_iff [THEN trans]) simp

lemma ImagePI [intro,no_atp]: "r a b ==> a : A ==> b : r```A"
  by (unfold ImageP_def) blast

lemma ImagePE [elim!]:
  "b : r ``` A ==> (!!x. r x b ==> x : A ==> P) ==> P"
  by (unfold ImageP_def) (iprover elim!: CollectE bexE)

lemma rev_ImageIP: "a : A ==> r a b ==> b : r ``` A"
  -- {* This version's more effective when we already have the required @{text a} *}
  by blast

lemma ImageP_empty [simp]: "R```{} = {}"
  by blast

(*
lemma ImageP_Id [simp]: "Id ``` A = A"
  by blast

lemma ImageP_Id_on [simp]: "Id_on A ``` B = A \<inter> B"
  by blast
*)

lemma ImageP_Int_subset: "R ``` (A \<inter> B) \<subseteq> R ``` A \<inter> R ``` B"
  by blast

lemma ImageP_Int_eq:
  "single_valuedP (conversep R) ==> R ``` (A \<inter> B) = R ``` A \<inter> R ``` B"
  by (simp add: single_valued_def, blast)

lemma ImageP_Un: "R ``` (A \<union> B) = R ``` A \<union> R ``` B"
  by blast

(*
lemma Un_ImageP: "(R \<union> S) ``` A = R ``` A \<union> S ``` A"
  by blast

lemma Image_subset: "r \<subseteq> A \<times> B ==> r``C \<subseteq> B"
  by (iprover intro!: subsetI elim!: ImageE dest!: subsetD SigmaD2)

lemma Image_eq_UN: "r``B = (\<Union>y\<in> B. r``{y})"
  -- {* NOT suitable for rewriting *}
  by blast

lemma Image_mono: "r' \<subseteq> r ==> A' \<subseteq> A ==> (r' `` A') \<subseteq> (r `` A)"
  by blast

lemma Image_UN: "(r `` (UNION A B)) = (\<Union>x\<in>A. r `` (B x))"
  by blast

lemma Image_INT_subset: "(r `` INTER A B) \<subseteq> (\<Inter>x\<in>A. r `` (B x))"
  by blast

text{*Converse inclusion requires some assumptions*}
lemma Image_INT_eq:
     "[|single_valued (r\<inverse>); A\<noteq>{}|] ==> r `` INTER A B = (\<Inter>x\<in>A. r `` B x)"
apply (rule equalityI)
 apply (rule Image_INT_subset)
apply  (simp add: single_valued_def, blast)
done

lemma Image_subset_eq: "(r``A \<subseteq> B) = (A \<subseteq> - ((r^-1) `` (-B)))"
  by blast

lemma Image_Collect_split [simp]: "{(x, y). P x y} `` A = {y. EX x:A. P x y}"
  by auto
*)

end


(*  Title:      ZF/ZF_Base.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section \<open>Base of Zermelo-Fraenkel Set Theory\<close>

theory Set_Theory
imports First_Order_Logic
begin

subsection \<open>Signature\<close>

declare [[eta_contract = false]]

typedecl i
instance i :: "term" ..

axiomatization mem :: "i \<Rightarrow> i \<Rightarrow> o"  (infixl "\<in>" 50)  \<comment> \<open>membership relation\<close>
  and zero :: "i"  ("0")  \<comment> \<open>the empty set\<close>
  and Pow :: "i \<Rightarrow> i"  \<comment> \<open>power sets\<close>
  and Inf :: "i"  \<comment> \<open>infinite set\<close>
  and Union :: "i \<Rightarrow> i"  ("\<Union>_" [90] 90)
  and PrimReplace :: "i \<Rightarrow> (i \<Rightarrow> i \<Rightarrow> o) \<Rightarrow> i"

abbreviation not_mem :: "[i, i] \<Rightarrow> o"  (infixl "\<notin>" 50)  \<comment> \<open>negated membership relation\<close>
  where "x \<notin> y \<equiv> \<not> (x \<in> y)"

subsection \<open>Bounded Quantifiers\<close>

definition Ball :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
  where "Ball A P \<equiv> (\<forall>x. x\<in>A \<longrightarrow> P x)"

definition Bex :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
  where "Bex A P \<equiv> \<exists>x. x\<in>A \<and> P(x)"

syntax
  "_Ball" :: "[pttrn, i, o] \<Rightarrow> o"  ("(3\<forall>_\<in>_./ _)" 10)
  "_Bex" :: "[pttrn, i, o] \<Rightarrow> o"  ("(3\<exists>_\<in>_./ _)" 10)
translations
  "\<forall>x\<in>A. P" \<rightleftharpoons> "CONST Ball A (\<lambda>x. P)"
  "\<exists>x\<in>A. P" \<rightleftharpoons> "CONST Bex A (\<lambda>x. P)"

subsection \<open>Variations on Replacement\<close>

(* Derived form of replacement, restricting P to its functional part.
   The resulting set (for functional P) is the same as with
   PrimReplace, but the rules are simpler. *)
definition Replace :: "[i, [i, i] \<Rightarrow> o] \<Rightarrow> i"
  where "Replace A P == PrimReplace A (%x y. (\<exists>!z. P x z) & P x y)"

syntax
  "_Replace"  :: "[pttrn, pttrn, i, o] => i"  ("(1{_ ./ _ \<in> _, _})")
translations
  "{y. x\<in>A, Q}" \<rightleftharpoons> "CONST Replace A (\<lambda>x y. Q)"

(* Functional form of replacement -- analgous to ML's map functional *)

definition RepFun :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "RepFun A f == {y . x\<in>A, y=f(x)}"

syntax
  "_RepFun" :: "[i, pttrn, i] => i"  ("(1{_ ./ _ \<in> _})" [51,0,51])
translations
  "{b. x\<in>A}" \<rightleftharpoons> "CONST RepFun A (\<lambda>x. b)"

(* Separation and Pairing can be derived from the Replacement
   and Powerset Axioms using the following definitions. *)
definition Collect :: "[i, i \<Rightarrow> o] \<Rightarrow> i"
  where "Collect A P == {y . x\<in>A, x=y & P x}"

syntax
  "_Collect" :: "[pttrn, i, o] \<Rightarrow> i"  ("(1{_ \<in> _ ./ _})")
translations
  "{x\<in>A. P}" \<rightleftharpoons> "CONST Collect A (\<lambda>x. P)"

subsection \<open>General union and intersection\<close>

definition Inter :: "i => i"  ("\<Inter>_" [90] 90)
  where "\<Inter>(A) == { x\<in>\<Union>(A) . \<forall>y\<in>A. x\<in>y}"

syntax
  "_UNION" :: "[pttrn, i, i] => i"  ("(3\<Union>_\<in>_./ _)" 10)
  "_INTER" :: "[pttrn, i, i] => i"  ("(3\<Inter>_\<in>_./ _)" 10)
translations
  "\<Union>x\<in>A. B" == "CONST Union {B. x\<in>A}"
  "\<Inter>x\<in>A. B" == "CONST Inter {B. x\<in>A}"

subsection \<open>Finite sets and binary operations\<close>

(*Unordered pairs (Upair) express binary union/intersection and cons;
  set enumerations translate as {a,...,z} = cons(a,...,cons(z,0)...)*)

definition Upair :: "[i, i] => i"
  where "Upair a b == {y. x\<in>Pow(Pow(0)), (x=0 & y=a) | (x=Pow(0) & y=b)}"

definition Subset :: "[i, i] \<Rightarrow> o"  (infixl "\<subseteq>" 50)  \<comment> \<open>subset relation\<close>
  where subset_def: "A \<subseteq> B \<equiv> \<forall>x\<in>A. x\<in>B"

definition Diff :: "[i, i] \<Rightarrow> i"  (infixl "-" 65)  \<comment> \<open>set difference\<close>
  where "A - B == { x\<in>A . ~(x\<in>B) }"

definition Un :: "[i, i] \<Rightarrow> i"  (infixl "\<union>" 65)  \<comment> \<open>binary union\<close>
  where "A \<union> B == \<Union>(Upair A B)"

definition Int :: "[i, i] \<Rightarrow> i"  (infixl "\<inter>" 70)  \<comment> \<open>binary intersection\<close>
  where "A \<inter> B == \<Inter>(Upair A B)"

definition cons :: "[i, i] => i"
  where "cons a A == Upair a a \<union> A"

definition succ :: "i => i"
  where "succ i == cons i i"

nonterminal "is"
syntax
  "" :: "i \<Rightarrow> is"  ("_")
  "_Enum" :: "[i, is] \<Rightarrow> is"  ("_,/ _")
  "_Finset" :: "is \<Rightarrow> i"  ("{(_)}")
translations
  "{x, xs}" == "CONST cons x {xs}"
  "{x}" == "CONST cons x 0"

subsection \<open>Axioms\<close>

(* ZF axioms -- see Suppes p.238
   Axioms for Union, Pow and Replace state existence only,
   uniqueness is derivable using extensionality. *)

axiomatization
where
  extension:     "A = B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A" and
  Union_iff:     "A \<in> \<Union>(C) \<longleftrightarrow> (\<exists>B\<in>C. A\<in>B)" and
  Pow_iff:       "A \<in> Pow(B) \<longleftrightarrow> A \<subseteq> B" and

  (*We may name this set, though it is not uniquely defined.*)
  infinity:      "0 \<in> Inf \<and> (\<forall>y\<in>Inf. succ(y) \<in> Inf)" and

  (*This formulation facilitates case analysis on A.*)
  foundation:    "A = 0 \<or> (\<exists>x\<in>A. \<forall>y\<in>x. y\<notin>A)" and

  (*Schema axiom since predicate P is a higher-order variable*)
  replacement:   "(\<forall>x\<in>A. \<forall>y z. P x y \<and> P x z \<longrightarrow> y = z) \<Longrightarrow>
                         b \<in> PrimReplace A P \<longleftrightarrow> (\<exists>x\<in>A. P x b)"

subsection \<open>Definite descriptions -- via Replace over the set "1"\<close>

definition The :: "(i \<Rightarrow> o) \<Rightarrow> i"  (binder "THE " 10)
  where the_def: "The(P)    == \<Union>({y . x \<in> {0}, P(y)})"

definition If :: "[o, i, i] \<Rightarrow> i"  ("(if (_)/ then (_)/ else (_))" [10] 10)
  where if_def: "if P then a else b == THE z. P & z=a | ~P & z=b"

subsection \<open>Ordered Pairing\<close>

(* this "symmetric" definition works better than {{a}, {a,b}} *)
definition Pair :: "[i, i] => i"
  where "Pair a b == {{a,a}, {a,b}}"

definition fst :: "i \<Rightarrow> i"
  where "fst(p) == THE a. \<exists>b. p = Pair a b"

definition snd :: "i \<Rightarrow> i"
  where "snd(p) == THE b. \<exists>a. p = Pair a b"

definition split :: "[[i, i] \<Rightarrow> 'a, i] \<Rightarrow> 'a::{}"  \<comment> \<open>for pattern-matching\<close>
  where "split(c) == \<lambda>p. c (fst p) (snd p)"

(* Patterns -- extends pre-defined type "pttrn" used in abstractions *)
nonterminal patterns
syntax
  "_pattern"  :: "patterns => pttrn"         ("\<langle>_\<rangle>")
  ""          :: "pttrn => patterns"         ("_")
  "_patterns" :: "[pttrn, patterns] => patterns"  ("_,/_")
  "_Tuple"    :: "[i, is] => i"              ("\<langle>(_,/ _)\<rangle>")
translations
  "\<langle>x, y, z\<rangle>"   == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
  "\<langle>x, y\<rangle>"      == "CONST Pair x y"
  "\<lambda>\<langle>x,y,zs\<rangle>.b" == "CONST split(\<lambda>x \<langle>y,zs\<rangle>.b)"
  "\<lambda>\<langle>x,y\<rangle>.b"    == "CONST split(\<lambda>x y. b)"

definition Sigma :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "Sigma A B == \<Union>x\<in>A. \<Union>y\<in>B(x). {\<langle>x,y\<rangle>}"

abbreviation cart_prod :: "[i, i] => i"  (infixr "\<times>" 80)  \<comment> \<open>Cartesian product\<close>
  where "A \<times> B \<equiv> Sigma A (\<lambda>_. B)"

subsection \<open>Relations and Functions\<close>

(*converse of relation r, inverse of function*)
definition converse :: "i \<Rightarrow> i"
  where "converse(r) == {z. w\<in>r, \<exists>x y. w=\<langle>x,y\<rangle> \<and> z=\<langle>y,x\<rangle>}"

definition domain :: "i \<Rightarrow> i"
  where "domain(r) == {x. w\<in>r, \<exists>y. w=\<langle>x,y\<rangle>}"

definition range :: "i \<Rightarrow> i"
  where "range(r) == domain(converse(r))"

definition field :: "i \<Rightarrow> i"
  where "field(r) == domain(r) \<union> range(r)"

definition relation :: "i \<Rightarrow> o"  \<comment> \<open>recognizes sets of pairs\<close>
  where "relation(r) == \<forall>z\<in>r. \<exists>x y. z = \<langle>x,y\<rangle>"

definition "function" :: "i \<Rightarrow> o"  \<comment> \<open>recognizes functions; can have non-pairs\<close>
  where "function(r) == \<forall>x y. \<langle>x,y\<rangle> \<in> r \<longrightarrow> (\<forall>y'. \<langle>x,y'\<rangle> \<in> r \<longrightarrow> y = y')"

definition Image :: "[i, i] \<Rightarrow> i"  (infixl "``" 90)  \<comment> \<open>image\<close>
  where image_def: "r `` A  == {y \<in> range(r). \<exists>x\<in>A. \<langle>x,y\<rangle> \<in> r}"

definition vimage :: "[i, i] \<Rightarrow> i"  (infixl "-``" 90)  \<comment> \<open>inverse image\<close>
  where vimage_def: "r -`` A == converse(r)``A"

(* Restrict the relation r to the domain A *)
definition restrict :: "[i, i] \<Rightarrow> i"
  where "restrict r A == {z \<in> r. \<exists>x\<in>A. \<exists>y. z = \<langle>x,y\<rangle>}"

(* Abstraction, application and Cartesian product of a family of sets *)

definition Lambda :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where lam_def: "Lambda A b == {\<langle>x,b(x)\<rangle>. x\<in>A}"

definition "apply" :: "[i, i] \<Rightarrow> i"  (infixl "`" 90)  \<comment> \<open>function application\<close>
  where "f`a == \<Union>(f``{a})"

definition Pi :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "Pi A B == {f\<in>Pow(Sigma A B). A\<subseteq>domain(f) & function(f)}"

abbreviation function_space :: "[i, i] \<Rightarrow> i"  (infixr "->" 60)  \<comment> \<open>function space\<close>
  where "A -> B \<equiv> Pi A (\<lambda>_. B)"

(* binder syntax *)

syntax
  "_PROD"     :: "[pttrn, i, i] => i"        ("(3\<Prod>_\<in>_./ _)" 10)
  "_SUM"      :: "[pttrn, i, i] => i"        ("(3\<Sum>_\<in>_./ _)" 10)
  "_lam"      :: "[pttrn, i, i] => i"        ("(3\<lambda>_\<in>_./ _)" 10)
translations
  "\<Prod>x\<in>A. B"   == "CONST Pi A (\<lambda>x. B)"
  "\<Sum>x\<in>A. B"   == "CONST Sigma A (\<lambda>x. B)"
  "\<lambda>x\<in>A. f"    == "CONST Lambda A (\<lambda>x. f)"

subsection \<open>ASCII syntax\<close>

notation (ASCII)
  cart_prod       (infixr "*" 80) and
  Int             (infixl "Int" 70) and
  Un              (infixl "Un" 65) and
  function_space  (infixr "\<rightarrow>" 60) and
  Subset          (infixl "<=" 50) and
  mem             (infixl ":" 50) and
  not_mem         (infixl "~:" 50)

syntax (ASCII)
  "_Ball"     :: "[pttrn, i, o] => o"        ("(3ALL _:_./ _)" 10)
  "_Bex"      :: "[pttrn, i, o] => o"        ("(3EX _:_./ _)" 10)
  "_Collect"  :: "[pttrn, i, o] => i"        ("(1{_: _ ./ _})")
  "_Replace"  :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _: _, _})")
  "_RepFun"   :: "[i, pttrn, i] => i"        ("(1{_ ./ _: _})" [51,0,51])
  "_UNION"    :: "[pttrn, i, i] => i"        ("(3UN _:_./ _)" 10)
  "_INTER"    :: "[pttrn, i, i] => i"        ("(3INT _:_./ _)" 10)
  "_PROD"     :: "[pttrn, i, i] => i"        ("(3PROD _:_./ _)" 10)
  "_SUM"      :: "[pttrn, i, i] => i"        ("(3SUM _:_./ _)" 10)
  "_lam"      :: "[pttrn, i, i] => i"        ("(3lam _:_./ _)" 10)
  "_Tuple"    :: "[i, is] => i"              ("<(_,/ _)>")
  "_pattern"  :: "patterns => pttrn"         ("<_>")

subsection \<open>Substitution\<close>

(*Useful examples:  singletonI RS subst_elem,  subst_elem RSN (2,IntI) *)
lemma subst_elem: "[| b\<in>A;  a=b |] ==> a\<in>A"
by (erule ssubst, assumption)

subsection\<open>Bounded universal quantifier\<close>

lemma ballI [intro!]: "[| !!x. x\<in>A ==> P(x) |] ==> \<forall>x\<in>A. P(x)"
by (simp add: Ball_def)

lemmas strip = impI allI ballI

lemma bspec [dest?]: "[| \<forall>x\<in>A. P(x);  x: A |] ==> P(x)"
by (simp add: Ball_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_ballE [elim]:
    "[| \<forall>x\<in>A. P(x);  x\<notin>A ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: Ball_def, blast)

lemma ballE: "[| \<forall>x\<in>A. P(x);  P(x) ==> Q;  x\<notin>A ==> Q |] ==> Q"
by blast

(*Used in the datatype package*)
lemma rev_bspec: "[| x: A;  \<forall>x\<in>A. P(x) |] ==> P(x)"
by (simp add: Ball_def)

(*Trival rewrite rule;   @{term"(\<forall>x\<in>A.P)<->P"} holds only if A is nonempty!*)
lemma ball_triv [simp]: "(\<forall>x\<in>A. P) <-> ((\<exists>x. x\<in>A) \<longrightarrow> P)"
by (simp add: Ball_def)

(*Congruence rule for rewriting*)
lemma ball_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P(x) <-> P'(x) |] ==> (\<forall>x\<in>A. P(x)) <-> (\<forall>x\<in>A'. P'(x))"
by (simp add: Ball_def)

lemma atomize_ball:
    "(!!x. x \<in> A ==> P(x)) == Trueprop (\<forall>x\<in>A. P(x))"
  by (simp only: Ball_def atomize_all atomize_imp)

lemmas [symmetric, rulify] = atomize_ball
  and [symmetric, defn] = atomize_ball

subsection\<open>Bounded existential quantifier\<close>

lemma bexI [intro]: "[| P(x);  x: A |] ==> \<exists>x\<in>A. P(x)"
by (simp add: Bex_def, blast)

(*The best argument order when there is only one @{term"x\<in>A"}*)
lemma rev_bexI: "[| x\<in>A;  P(x) |] ==> \<exists>x\<in>A. P(x)"
by blast

(*Not of the general form for such rules. The existential quanitifer becomes universal. *)
lemma bexCI: "[| \<forall>x\<in>A. ~P(x) ==> P(a);  a: A |] ==> \<exists>x\<in>A. P(x)"
by blast

lemma bexE [elim!]: "[| \<exists>x\<in>A. P(x);  !!x. [| x\<in>A; P(x) |] ==> Q |] ==> Q"
by (simp add: Bex_def, blast)

(*We do not even have @{term"(\<exists>x\<in>A. True) <-> True"} unless @{term"A" is nonempty!!*)
lemma bex_triv [simp]: "(\<exists>x\<in>A. P) <-> ((\<exists>x. x\<in>A) & P)"
by (simp add: Bex_def)

lemma bex_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P(x) <-> P'(x) |]
     ==> (\<exists>x\<in>A. P(x)) <-> (\<exists>x\<in>A'. P'(x))"
by (simp add: Bex_def cong: conj_cong)

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

lemma subsetI [intro!]:
    "(!!x. x\<in>A ==> x\<in>B) ==> A \<subseteq> B"
by (simp add: subset_def)

(*Rule in Modus Ponens style [was called subsetE] *)
lemma subsetD [elim]: "[| A \<subseteq> B;  c\<in>A |] ==> c\<in>B"
apply (unfold subset_def)
apply (erule bspec, assumption)
done

(*Classical elimination rule*)
lemma subsetCE [elim]:
    "[| A \<subseteq> B;  c\<notin>A ==> P;  c\<in>B ==> P |] ==> P"
by (simp add: subset_def, blast)

(*Sometimes useful with premises in this order*)
lemma rev_subsetD: "[| c\<in>A; A<=B |] ==> c\<in>B"
by blast

lemma contra_subsetD: "[| A \<subseteq> B; c \<notin> B |] ==> c \<notin> A"
by blast

lemma rev_contra_subsetD: "[| c \<notin> B;  A \<subseteq> B |] ==> c \<notin> A"
by blast

lemma subset_refl [simp]: "A \<subseteq> A"
by blast

lemma subset_trans: "[| A<=B;  B<=C |] ==> A<=C"
by blast

(*Useful for proving A<=B by rewriting in some cases*)
lemma subset_iff:
     "A<=B <-> (\<forall>x. x\<in>A \<longrightarrow> x\<in>B)"
apply (unfold subset_def Ball_def)
apply (rule iff_refl)
done

text\<open>For calculations\<close>
declare subsetD [trans] rev_subsetD [trans] subset_trans [trans]

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

(*Anti-symmetry of the subset relation*)
lemma equalityI [intro]: "[| A \<subseteq> B;  B \<subseteq> A |] ==> A = B"
by (rule extension [THEN iffD2], rule conjI)

lemma equality_iffI: "(!!x. x\<in>A <-> x\<in>B) ==> A = B"
by (rule equalityI, blast+)

lemmas equalityD1 = extension [THEN iffD1, THEN conjunct1]
lemmas equalityD2 = extension [THEN iffD1, THEN conjunct2]

lemma equalityE: "[| A = B;  [| A<=B; B<=A |] ==> P |]  ==>  P"
by (blast dest: equalityD1 equalityD2)

lemma equalityCE:
    "[| A = B;  [| c\<in>A; c\<in>B |] ==> P;  [| c\<notin>A; c\<notin>B |] ==> P |]  ==>  P"
by (erule equalityE, blast)

lemma equality_iffD:
  "A = B ==> (!!x. x \<in> A <-> x \<in> B)"
  by auto

subsection\<open>Rules for Replace -- the derived form of replacement\<close>

lemma Replace_iff:
    "b \<in> {y. x\<in>A, P x y}  <->  (\<exists>x\<in>A. P x b & (\<forall>y. P x y \<longrightarrow> y=b))"
apply (unfold Replace_def)
apply (rule replacement [THEN iff_trans], blast+)
done

(*Introduction; there must be a unique y such that P(x,y), namely y=b. *)
lemma ReplaceI [intro]:
    "[| P x b;  x: A;  !!y. P x y ==> y=b |] ==>
     b \<in> {y. x\<in>A, P x y}"
by (rule Replace_iff [THEN iffD2], blast)

(*Elimination; may asssume there is a unique y such that P(x,y), namely y=b. *)
lemma ReplaceE:
    "[| b \<in> {y. x\<in>A, P x y};
        !!x. [| x: A;  P x b;  \<forall>y. P x y \<longrightarrow> y=b |] ==> R
     |] ==> R"
by (rule Replace_iff [THEN iffD1, THEN bexE], simp+)

(*As above but without the (generally useless) 3rd assumption*)
lemma ReplaceE2 [elim!]:
    "[| b \<in> {y. x\<in>A, P x y};
        !!x. [| x: A;  P x b |] ==> R
     |] ==> R"
by (erule ReplaceE, blast)

lemma Replace_cong [cong]:
    "[| A=B;  !!x y. x\<in>B ==> P x y <-> Q x y |] ==>
     Replace A P = Replace B Q"
apply (rule equality_iffI)
apply (simp add: Replace_iff)
done

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

lemma RepFunI: "a \<in> A ==> f(a) \<in> {f(x). x\<in>A}"
by (simp add: RepFun_def Replace_iff, blast)

(*Useful for coinduction proofs*)
lemma RepFun_eqI [intro]: "[| b=f(a);  a \<in> A |] ==> b \<in> {f(x). x\<in>A}"
apply (erule ssubst)
apply (erule RepFunI)
done

lemma RepFunE [elim!]:
    "[| b \<in> {f(x). x\<in>A};
        !!x.[| x\<in>A;  b=f(x) |] ==> P |] ==>
     P"
by (simp add: RepFun_def Replace_iff, blast)

lemma RepFun_cong [cong]:
    "[| A=B;  !!x. x\<in>B ==> f(x)=g(x) |] ==> RepFun A f = RepFun B g"
by (simp add: RepFun_def)

lemma RepFun_iff [simp]: "b \<in> {f(x). x\<in>A} <-> (\<exists>x\<in>A. b=f(x))"
by (unfold Bex_def, blast)

lemma triv_RepFun [simp]: "{x. x\<in>A} = A"
by blast

subsection\<open>Rules for Collect -- forming a subset by separation\<close>

(*Separation is derivable from Replacement*)
lemma separation [simp]: "a \<in> {x\<in>A. P(x)} <-> a\<in>A & P(a)"
by (unfold Collect_def, blast)

lemma CollectI [intro!]: "[| a\<in>A;  P(a) |] ==> a \<in> {x\<in>A. P(x)}"
by simp

lemma CollectE [elim!]: "[| a \<in> {x\<in>A. P(x)};  [| a\<in>A; P(a) |] ==> R |] ==> R"
by simp

lemma CollectD1: "a \<in> {x\<in>A. P(x)} ==> a\<in>A"
by (erule CollectE, assumption)

lemma CollectD2: "a \<in> {x\<in>A. P(x)} ==> P(a)"
by (erule CollectE, assumption)

lemma Collect_cong [cong]:
    "[| A=B;  !!x. x\<in>B ==> P(x) <-> Q(x) |]
     ==> Collect A (%x. P(x)) = Collect B (%x. Q(x))"
by (simp add: Collect_def)

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

declare Union_iff [simp]

(*The order of the premises presupposes that C is rigid; A may be flexible*)
lemma UnionI [intro]: "[| B: C;  A: B |] ==> A: \<Union>(C)"
by (simp, blast)

lemma UnionE [elim!]: "[| A \<in> \<Union>(C);  !!B.[| A: B;  B: C |] ==> R |] ==> R"
by (simp, blast)

subsection\<open>Rules for Unions of families\<close>
(* @{term"\<Union>x\<in>A. B(x)"} abbreviates @{term"\<Union>({B(x). x\<in>A})"} *)

lemma UN_iff [simp]: "b \<in> (\<Union>x\<in>A. B(x)) <-> (\<exists>x\<in>A. b \<in> B(x))"
by (simp add: Bex_def, blast)

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma UN_I: "[| a: A;  b: B(a) |] ==> b: (\<Union>x\<in>A. B(x))"
by (simp, blast)

lemma UN_E [elim!]:
    "[| b \<in> (\<Union>x\<in>A. B(x));  !!x.[| x: A;  b: B(x) |] ==> R |] ==> R"
by blast

lemma UN_cong:
    "[| A=B;  !!x. x\<in>B ==> C(x)=D(x) |] ==> (\<Union>x\<in>A. C(x)) = (\<Union>x\<in>B. D(x))"
by simp

(*No "Addcongs [UN_cong]" because @{term\<Union>} is a combination of constants*)

(* UN_E appears before UnionE so that it is tried first, to avoid expensive
  calls to hyp_subst_tac.  Cannot include UN_I as it is unsafe: would enlarge
  the search space.*)

subsection\<open>Rules for the empty set\<close>

(*The set @{term"{x\<in>0. False}"} is empty; by foundation it equals 0
  See Suppes, page 21.*)
lemma not_mem_empty [simp]: "a \<notin> 0"
apply (cut_tac foundation)
apply (best dest: equalityD2)
done

lemmas emptyE [elim!] = not_mem_empty [THEN notE]

lemma empty_subsetI [simp]: "0 \<subseteq> A"
by blast

lemma equals0I: "[| !!y. y\<in>A ==> False |] ==> A=0"
by blast

lemma equals0D [dest]: "A=0 ==> a \<notin> A"
by blast

declare sym [THEN equals0D, dest]

lemma not_emptyI: "a\<in>A ==> A \<noteq> 0"
by blast

lemma not_emptyE:  "[| A \<noteq> 0;  !!x. x\<in>A ==> R |] ==> R"
by blast

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

(*Not obviously useful for proving InterI, InterD, InterE*)
lemma Inter_iff: "A \<in> \<Inter>(C) <-> (\<forall>x\<in>C. A: x) & C\<noteq>0"
by (simp add: Inter_def Ball_def, blast)

(* Intersection is well-behaved only if the family is non-empty! *)
lemma InterI [intro!]:
    "[| !!x. x: C ==> A: x;  C\<noteq>0 |] ==> A \<in> \<Inter>(C)"
by (simp add: Inter_iff)

(*A "destruct" rule -- every B in C contains A as an element, but
  A\<in>B can hold when B\<in>C does not!  This rule is analogous to "spec". *)
lemma InterD [elim, Pure.elim]: "[| A \<in> \<Inter>(C);  B \<in> C |] ==> A \<in> B"
by (unfold Inter_def, blast)

(*"Classical" elimination rule -- does not require exhibiting @{term"B\<in>C"} *)
lemma InterE [elim]:
    "[| A \<in> \<Inter>(C);  B\<notin>C ==> R;  A\<in>B ==> R |] ==> R"
by (simp add: Inter_def, blast)

subsection\<open>Rules for Intersections of families\<close>

(* @{term"\<Inter>x\<in>A. B(x)"} abbreviates @{term"\<Inter>({B(x). x\<in>A})"} *)

lemma INT_iff: "b \<in> (\<Inter>x\<in>A. B(x)) <-> (\<forall>x\<in>A. b \<in> B(x)) & A\<noteq>0"
by (force simp add: Inter_def)

lemma INT_I: "[| !!x. x: A ==> b: B(x);  A\<noteq>0 |] ==> b: (\<Inter>x\<in>A. B(x))"
by blast

lemma INT_E: "[| b \<in> (\<Inter>x\<in>A. B(x));  a: A |] ==> b \<in> B(a)"
by blast

lemma INT_cong:
    "[| A=B;  !!x. x\<in>B ==> C(x)=D(x) |] ==> (\<Inter>x\<in>A. C(x)) = (\<Inter>x\<in>B. D(x))"
by simp

(*No "Addcongs [INT_cong]" because @{term\<Inter>} is a combination of constants*)

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

lemma PowI: "A \<subseteq> B ==> A \<in> Pow(B)"
by (erule Pow_iff [THEN iffD2])

lemma PowD: "A \<in> Pow(B)  ==>  A<=B"
by (erule Pow_iff [THEN iffD1])

declare Pow_iff [iff]

lemmas Pow_bottom = empty_subsetI [THEN PowI]    \<comment>\<open>@{term"0 \<in> Pow(B)"}\<close>
lemmas Pow_top = subset_refl [THEN PowI]         \<comment>\<open>@{term"A \<in> Pow(A)"}\<close>

subsection\<open>Cantor's Theorem: There is no surjection from a set to its powerset.\<close>

(*The search is undirected.  Allowing redundant introduction rules may
  make it diverge.  Variable b represents ANY map, such as
  (lam x\<in>A.b(x)): A->Pow(A). *)
lemma cantor: "\<exists>S \<in> Pow(A). \<forall>x\<in>A. b(x) \<noteq> S"
by (best elim!: equalityCE del: ReplaceI RepFun_eqI)

end


theory P02
imports Main
begin
(*from now on I will mix isar and apply-script proofs and I will also mix step-by-step solving with automation*)
(*find the last but one element of a list*)

(*using a default element in case the list is too small*)
fun p02_1 :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a" where
"p02_1 [] def = def"|
"p02_1 (x#xs) def = (case xs of  [y] \<Rightarrow> x | _  \<Rightarrow>  p02_1 xs def) "

value "p02_1 [] 5 :: int"
value "p02_1 [1] 7 :: int"
value "p02_1 [1,2,3,4,5] 6 :: int"

theorem tp02_1_1 : "p02_1 [] a = a" by auto

theorem tp02_1_2 : "p02_1 [] a = a"
using [[simp_trace_new mode=full]]
apply (subst p02_1.simps)
apply (rule refl)
done

theorem isar_tp02_1_1 : "p02_1 [x] a = a"
using [[simp_trace_new mode=full]]
proof -
show ?thesis by (subst p02_1.simps(2); subst list.case(1); subst p02_1.simps(1); rule refl)
qed

theorem isar_tp02_1_2 : "length ls < 2 \<Longrightarrow> p02_1 ls a = a"
proof (induct ls)
  case Nil
  assume "length [] < 2"
  show "p02_1 [] a = a"  by (subst p02_1.simps(1) ; rule refl)
 next
  case (Cons aa ls)
  fix aa ls
  assume "(length ls < 2 \<Longrightarrow> p02_1 ls a = a)"
  assume "length (aa # ls) < 2"

  show " \<And>aa ls. (length ls < 2 \<Longrightarrow> p02_1 ls a = a) \<Longrightarrow> length (aa # ls) < 2 \<Longrightarrow> p02_1 (aa # ls) a = a" by auto