(*  Title:       Signed (Finite) Multisets
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Signed (Finite) Multisets\<close>

theory Signed_Multiset
imports Multiset_More
abbrevs
  "!z" = "\<^sub>z"
begin

subsection \<open>Definition of Signed Multisets\<close>

definition equiv_zmset :: "'a multiset \<times> 'a multiset \<Rightarrow> 'a multiset \<times> 'a multiset \<Rightarrow> bool" where
  "equiv_zmset = (\<lambda>(Mp, Mn) (Np, Nn). Mp + Nn = Np + Mn)"

quotient_type 'a zmultiset = "'a multiset \<times> 'a multiset" / equiv_zmset
  by (rule equivpI, simp_all add: equiv_zmset_def reflp_def symp_def transp_def)
    (metis multi_union_self_other_eq union_lcomm)

subsection \<open>Basic Operations on Signed Multisets\<close>

instantiation zmultiset :: (type) cancel_comm_monoid_add
begin

lift_definition zero_zmultiset :: "'a zmultiset" is "({#}, {#})" .

abbreviation empty_zmset :: "'a zmultiset" ("{#}\<^sub>z") where
  "empty_zmset \<equiv> 0"

lift_definition minus_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>(Mp, Mn) (Np, Nn). (Mp + Nn, Mn + Np)"
  by (auto simp: equiv_zmset_def union_commute union_lcomm)

lift_definition plus_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>(Mp, Mn) (Np, Nn). (Mp + Np, Mn + Nn)"
  by (auto simp: equiv_zmset_def union_commute union_lcomm)

instance
  by (intro_classes; transfer) (auto simp: equiv_zmset_def)

end

instantiation zmultiset :: (type) group_add
begin

lift_definition uminus_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset" is "\<lambda>(Mp, Mn). (Mn, Mp)"
  by (auto simp: equiv_zmset_def add.commute)

instance
  by (intro_classes; transfer) (auto simp: equiv_zmset_def)

end

lift_definition zcount :: "'a zmultiset \<Rightarrow> 'a \<Rightarrow> int" is
  "\<lambda>(Mp, Mn) x. int (count Mp x) - int (count Mn x)"
  by (auto simp del: of_nat_add simp: equiv_zmset_def fun_eq_iff multiset_eq_iff diff_eq_eq
    diff_add_eq eq_diff_eq of_nat_add[symmetric])

lemma zcount_inject: "zcount M = zcount N \<longleftrightarrow> M = N"
  by transfer (auto simp del: of_nat_add simp: equiv_zmset_def fun_eq_iff multiset_eq_iff
    diff_eq_eq diff_add_eq eq_diff_eq of_nat_add[symmetric])

lemma zmultiset_eq_iff: "M = N \<longleftrightarrow> (\<forall>a. zcount M a = zcount N a)"
  by (simp only: zcount_inject[symmetric] fun_eq_iff)

lemma zmultiset_eqI: "(\<And>x. zcount A x = zcount B x) \<Longrightarrow> A = B"
  using zmultiset_eq_iff by auto

lemma zcount_uminus[simp]: "zcount (- A) x = - zcount A x"
  by transfer auto

lift_definition add_zmset :: "'a \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>x (Mp, Mn). (add_mset x Mp, Mn)"
  by (auto simp: equiv_zmset_def)

syntax
  "_zmultiset" :: "args \<Rightarrow> 'a zmultiset" ("{#(_)#}\<^sub>z")
translations
  "{#x, xs#}\<^sub>z" == "CONST add_zmset x {#xs#}\<^sub>z"
  "{#x#}\<^sub>z" == "CONST add_zmset x {#}\<^sub>z"

lemma zcount_empty[simp]: "zcount {#}\<^sub>z a = 0"
  by transfer auto

lemma zcount_add_zmset[simp]:
  "zcount (add_zmset b A) a = (if b = a then zcount A a + 1 else zcount A a)"
  by transfer auto

lemma zcount_single: "zcount {#b#}\<^sub>z a = (if b = a then 1 else 0)"
  by simp

lemma add_add_same_iff_zmset[simp]: "add_zmset a A = add_zmset a B \<longleftrightarrow> A = B"
  by (auto simp: zmultiset_eq_iff)

lemma add_zmset_commute: "add_zmset x (add_zmset y M) = add_zmset y (add_zmset x M)"
  by (auto simp: zmultiset_eq_iff)

lemma
  singleton_ne_empty_zmset[simp]: "{#x#}\<^sub>z \<noteq> {#}\<^sub>z" and
  empty_ne_singleton_zmset[simp]: "{#}\<^sub>z \<noteq> {#x#}\<^sub>z"
  by (auto dest!: arg_cong2[of _ _ x _ zcount])

lemma
  singleton_ne_uminus_singleton_zmset[simp]: "{#x#}\<^sub>z \<noteq> - {#y#}\<^sub>z" and
  uminus_singleton_ne_singleton_zmset[simp]: "- {#x#}\<^sub>z \<noteq> {#y#}\<^sub>z"
  by (auto dest!: arg_cong2[of _ _ x x zcount] split: if_splits)

subsubsection \<open>Conversion to Set and Membership\<close>

definition set_zmset :: "'a zmultiset \<Rightarrow> 'a set" where
  "set_zmset M = {x. zcount M x \<noteq> 0}"

abbreviation elem_zmset :: "'a \<Rightarrow> 'a zmultiset \<Rightarrow> bool" where
  "elem_zmset a M \<equiv> a \<in> set_zmset M"

notation
  elem_zmset ("'(\<in>#\<^sub>z')") and
  elem_zmset ("(_/ \<in>#\<^sub>z _)" [51, 51] 50)

notation (ASCII)
  elem_zmset ("'(:#z')") and
  elem_zmset ("(_/ :#z _)" [51, 51] 50)

abbreviation not_elem_zmset :: "'a \<Rightarrow> 'a zmultiset \<Rightarrow> bool" where
  "not_elem_zmset a M \<equiv> a \<notin> set_zmset M"

notation
  not_elem_zmset ("'(\<notin>#\<^sub>z')") and
  not_elem_zmset ("(_/ \<notin>#\<^sub>z _)" [51, 51] 50)

notation (ASCII)
  not_elem_zmset ("'(~:#z')") and
  not_elem_zmset ("(_/ ~:#z _)" [51, 51] 50)

context
begin

qualified abbreviation Ball :: "'a zmultiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "Ball M \<equiv> Set.Ball (set_zmset M)"

qualified abbreviation Bex :: "'a zmultiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "Bex M \<equiv> Set.Bex (set_zmset M)"

end

syntax
  "_MBall" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<forall>_\<in>#\<^sub>z_./ _)" [0, 0, 10] 10)
  "_MBex" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>_\<in>#\<^sub>z_./ _)" [0, 0, 10] 10)

syntax (ASCII)
  "_MBall" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<forall>_:#\<^sub>z_./ _)" [0, 0, 10] 10)
  "_MBex" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>_:#\<^sub>z_./ _)" [0, 0, 10] 10)

translations
  "\<forall>x\<in>#\<^sub>zA. P" \<rightleftharpoons> "CONST Signed_Multiset.Ball A (\<lambda>x. P)"
  "\<exists>x\<in>#\<^sub>zA. P" \<rightleftharpoons> "CONST Signed_Multiset.Bex A (\<lambda>x. P)"

lemma zcount_eq_zero_iff: "zcount M x = 0 \<longleftrightarrow> x \<notin>#\<^sub>z M"
  by (auto simp add: set_zmset_def)

lemma not_in_iff_zmset: "x \<notin>#\<^sub>z M \<longleftrightarrow> zcount M x = 0"
  by (auto simp add: zcount_eq_zero_iff)

lemma zcount_ne_zero_iff[simp]: "zcount M x \<noteq> 0 \<longleftrightarrow> x \<in>#\<^sub>z M"
  by (auto simp add: set_zmset_def)

lemma zcount_inI:
  assumes "zcount M x = 0 \<Longrightarrow> False"
  shows "x \<in>#\<^sub>z M"
proof (rule ccontr)
  assume "x \<notin>#\<^sub>z M"
  with assms show False by (simp add: not_in_iff_zmset)
qed

lemma set_zmset_empty[simp]: "set_zmset {#}\<^sub>z = {}"
  by (simp add: set_zmset_def)

lemma set_zmset_single: "set_zmset {#b#}\<^sub>z = {b}"
  by (simp add: set_zmset_def)

lemma set_zmset_eq_empty_iff[simp]: "set_zmset M = {} \<longleftrightarrow> M = {#}\<^sub>z"
  by (auto simp add: zmultiset_eq_iff zcount_eq_zero_iff)

lemma finite_count_ne: "finite {x. count M x \<noteq> count N x}"
proof -
  have "{x. count M x \<noteq> count N x} \<subseteq> set_mset M \<union> set_mset N"
    by (auto simp: not_in_iff)
  moreover have "finite (set_mset M \<union> set_mset N)"
    by (rule finite_UnI[OF finite_set_mset finite_set_mset])
  ultimately show ?thesis
    by (rule finite_subset)
qed

lemma finite_set_zmset[iff]: "finite (set_zmset M)"
  unfolding set_zmset_def by transfer (auto intro: finite_count_ne)

lemma zmultiset_nonemptyE[elim]:
  assumes "A \<noteq> {#}\<^sub>z"
  obtains x where "x \<in>#\<^sub>z A"
proof -
  have "\<exists>x. x \<in>#\<^sub>z A"
    by (rule ccontr) (insert assms, auto)
  with that show ?thesis
    by blast
qed

subsubsection \<open>Union\<close>

lemma zcount_union[simp]: "zcount (M + N) a = zcount M a + zcount N a"
  by transfer auto

lemma union_add_left_zmset[simp]: "add_zmset a A + B = add_zmset a (A + B)"
  by (auto simp: zmultiset_eq_iff)

lemma union_zmset_add_zmset_right[simp]: "A + add_zmset a B = add_zmset a (A + B)"
  by (auto simp: zmultiset_eq_iff)

lemma add_zmset_add_single: \<open>add_zmset a A = A + {#a#}\<^sub>z\<close>
  by (subst union_zmset_add_zmset_right, subst add.comm_neutral) (rule refl)

subsubsection \<open>Difference\<close>

lemma zcount_diff[simp]: "zcount (M - N) a = zcount M a - zcount N a"
  by transfer auto

lemma add_zmset_diff_bothsides: \<open>add_zmset a M - add_zmset a A = M - A\<close>
  by (auto simp: zmultiset_eq_iff)

lemma in_diff_zcount: "a \<in>#\<^sub>z M - N \<longleftrightarrow> zcount N a \<noteq> zcount M a"
  by (fastforce simp: set_zmset_def)

lemma diff_add_zmset:
  fixes M N Q :: "'a zmultiset"
  shows "M - (N + Q) = M - N - Q"
  by (rule sym) (fact diff_diff_add)

lemma insert_Diff_zmset[simp]: "add_zmset x (M - {#x#}\<^sub>z) = M"
  by (clarsimp simp: zmultiset_eq_iff)

lemma diff_union_swap_zmset: "add_zmset b (M - {#a#}\<^sub>z) = add_zmset b M - {#a#}\<^sub>z"
  by (auto simp add: zmultiset_eq_iff)

lemma diff_add_zmset_swap[simp]: "add_zmset b M - A = add_zmset b (M - A)"
  by (auto simp add: zmultiset_eq_iff)

lemma diff_diff_add_zmset[simp]: "(M :: 'a zmultiset) - N - P = M - (N + P)"
  by (rule diff_diff_add)

lemma zmset_add[elim?]:
  obtains B where "A = add_zmset a B"
proof -
  have "A = add_zmset a (A - {#a#}\<^sub>z)"
    by simp
  with that show thesis .
qed

subsubsection \<open>Equality of Signed Multisets\<close>

lemma single_eq_single_zmset[simp]: "{#a#}\<^sub>z = {#b#}\<^sub>z \<longleftrightarrow> a = b"
  by (auto simp add: zmultiset_eq_iff)

lemma multi_self_add_other_not_self_zmset[simp]: "M = add_zmset x M \<longleftrightarrow> False"
  by (auto simp add: zmultiset_eq_iff)

lemma add_zmset_remove_trivial: \<open>add_zmset x M - {#x#}\<^sub>z = M\<close>
  by simp

lemma diff_single_eq_union_zmset: "M - {#x#}\<^sub>z = N \<longleftrightarrow> M = add_zmset x N"
  by auto

lemma union_single_eq_diff_zmset: "add_zmset x M = N \<Longrightarrow> M = N - {#x#}\<^sub>z"
  unfolding add_zmset_add_single[of _ M] by (fact add_implies_diff)

lemma add_zmset_eq_conv_diff:
  "add_zmset a M = add_zmset b N \<longleftrightarrow>
   M = N \<and> a = b \<or> M = add_zmset b (N - {#a#}\<^sub>z) \<and> N = add_zmset a (M - {#b#}\<^sub>z)"
  by (simp add: zmultiset_eq_iff) fastforce

lemma add_zmset_eq_conv_ex:
  "(add_zmset a M = add_zmset b N) =
    (M = N \<and> a = b \<or> (\<exists>K. M = add_zmset b K \<and> N = add_zmset a K))"
  by (auto simp add: add_zmset_eq_conv_diff)

lemma multi_member_split: "\<exists>A. M = add_zmset x A"
  by (rule exI[where x = "M - {#x#}\<^sub>z"]) simp

subsection \<open>Conversions from and to Multisets\<close>

lift_definition zmset_of :: "'a multiset \<Rightarrow> 'a zmultiset" is "\<lambda>f. (Abs_multiset f, {#})" .

lemma zmset_of_inject[simp]: "zmset_of M = zmset_of N \<longleftrightarrow> M = N"
  by (simp add: zmset_of_def, transfer, auto simp: equiv_zmset_def)

lemma zmset_of_empty[simp]: "zmset_of {#} = {#}\<^sub>z"
  by (simp add: zmset_of_def zero_zmultiset_def)

lemma zmset_of_add_mset[simp]: "zmset_of (add_mset x M) = add_zmset x (zmset_of M)"
  by transfer (auto simp: equiv_zmset_def add_mset_def cong: if_cong)

lemma zcount_of_mset[simp]: "zcount (zmset_of M) x = int (count M x)"
  by (induct M) auto

lemma zmset_of_plus: "zmset_of (M + N) = zmset_of M + zmset_of N"
  by (transfer, auto simp: equiv_zmset_def eq_onp_same_args plus_multiset.abs_eq)+

lift_definition mset_pos :: "'a zmultiset \<Rightarrow> 'a multiset" is "\<lambda>(Mp, Mn). count (Mp - Mn)"
  by (clarsimp simp: equiv_zmset_def intro!: arg_cong[of _ _ count])
    (metis add.commute add_diff_cancel_right)

lift_definition mset_neg :: "'a zmultiset \<Rightarrow> 'a multiset" is "\<lambda>(Mp, Mn). count (Mn - Mp)"
  by (clarsimp simp: equiv_zmset_def intro!: arg_cong[of _ _ count])
    (metis add.commute add_diff_cancel_right)

lemma
  zmset_of_inverse[simp]: "mset_pos (zmset_of M) = M" and
  minus_zmset_of_inverse[simp]: "mset_neg (- zmset_of M) = M"
  by (transfer, simp)+

lemma neg_zmset_pos[simp]: "mset_neg (zmset_of M) = {#}"
  by (rule zmset_of_inject[THEN iffD1], simp, transfer, auto simp: equiv_zmset_def)+

lemma
  count_mset_pos[simp]: "count (mset_pos M) x = nat (zcount M x)" and
  count_mset_neg[simp]: "count (mset_neg M) x = nat (- zcount M x)"
  by (transfer; auto)+

lemma
  mset_pos_empty[simp]: "mset_pos {#}\<^sub>z = {#}" and
  mset_neg_empty[simp]: "mset_neg {#}\<^sub>z = {#}"
  by (rule multiset_eqI, simp)+

lemma
  mset_pos_singleton[simp]: "mset_pos {#x#}\<^sub>z = {#x#}" and
  mset_neg_singleton[simp]: "mset_neg {#x#}\<^sub>z = {#}"
  by (rule multiset_eqI, simp)+

lemma
  mset_pos_neg_partition: "M = zmset_of (mset_pos M) - zmset_of (mset_neg M)" and
  mset_pos_as_neg: "zmset_of (mset_pos M) = zmset_of (mset_neg M) + M" and
  mset_neg_as_pos: "zmset_of (mset_neg M) = zmset_of (mset_pos M) - M"
  by (rule zmultiset_eqI, simp)+

lemma mset_pos_uminus[simp]: "mset_pos (- A) = mset_neg A"
  by (rule multiset_eqI) simp

lemma mset_neg_uminus[simp]: "mset_neg (- A) = mset_pos A"
  by (rule multiset_eqI) simp

lemma mset_pos_plus[simp]:
  "mset_pos (A + B) = (mset_pos A - mset_neg B) + (mset_pos B - mset_neg A)"
  by (rule multiset_eqI) simp

lemma mset_neg_plus[simp]:
  "mset_neg (A + B) = (mset_neg A - mset_pos B) + (mset_neg B - mset_pos A)"
  by (rule multiset_eqI) simp

lemma mset_pos_diff[simp]:
  "mset_pos (A - B) = (mset_pos A - mset_pos B) + (mset_neg B - mset_neg A)"
  by (rule mset_pos_plus[of A "- B", simplified])

lemma mset_neg_diff[simp]:
  "mset_neg (A - B) = (mset_neg A - mset_neg B) + (mset_pos B - mset_pos A)"
  by (rule mset_neg_plus[of A "- B", simplified])

lemma mset_pos_neg_dual:
  "mset_pos a + mset_pos b + (mset_neg a - mset_pos b) + (mset_neg b - mset_pos a) =
   mset_neg a + mset_neg b + (mset_pos a - mset_neg b) + (mset_pos b - mset_neg a)"
  using [[linarith_split_limit = 20]] by (rule multiset_eqI) simp

lemma decompose_zmset_of2:
  obtains A B C where
    "M = zmset_of A + C" and
    "N = zmset_of B + C"
proof
  let ?A = "zmset_of (mset_pos M + mset_neg N)"
  let ?B = "zmset_of (mset_pos N + mset_neg M)"
  let ?C = "- (zmset_of (mset_neg M) + zmset_of (mset_neg N))"

  show "M = ?A + ?C"
    by (simp add: zmset_of_plus mset_pos_neg_partition)
  show "N = ?B + ?C"
    by (simp add: zmset_of_plus diff_add_zmset mset_pos_neg_partition)
qed

subsubsection \<open>Pointwise Ordering Induced by @{const zcount}\<close>

definition subseteq_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<subseteq>#\<^sub>z" 50) where
  "A \<subseteq>#\<^sub>z B \<longleftrightarrow> (\<forall>a. zcount A a \<le> zcount B a)"

definition subset_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<subset>#\<^sub>z" 50) where
  "A \<subset>#\<^sub>z B \<longleftrightarrow> A \<subseteq>#\<^sub>z B \<and> A \<noteq> B"

abbreviation (input)
  supseteq_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<supseteq>#\<^sub>z" 50)
where
  "supseteq_zmset A B \<equiv> B \<subseteq>#\<^sub>z A"

abbreviation (input)
  supset_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<supset>#\<^sub>z" 50)
where
  "supset_zmset A B \<equiv> B \<subset>#\<^sub>z A"

notation (input)
  subseteq_zmset (infix "\<subseteq>#\<^sub>z" 50) and
  supseteq_zmset (infix "\<supseteq>#\<^sub>z" 50)

notation (ASCII)
  subseteq_zmset (infix "\<subseteq>#\<^sub>z" 50) and
  subset_zmset (infix "\<subset>#\<^sub>z" 50) and
  supseteq_zmset (infix "\<supseteq>#\<^sub>z" 50) and
  supset_zmset (infix ">#\<^sub>z" 50)

interpretation subset_zmset: ordered_ab_semigroup_add_imp_le "(+)" "(-)" "(\<subseteq>#\<^sub>z)" "(\<subset>#\<^sub>z)"
  by unfold_locales (auto simp add: subset_zmset_def subseteq_zmset_def zmultiset_eq_iff
    intro: order_trans antisym)

interpretation subset_zmset:
  ordered_ab_semigroup_monoid_add_imp_le "(+)" 0 "(-)" "(\<subseteq>#\<^sub>z)" "(\<subset>#\<^sub>z)"
  by unfold_locales

lemma zmset_subset_eqI: "(\<And>a. zcount A a \<le> zcount B a) \<Longrightarrow> A \<subseteq>#\<^sub>z B"
  by (simp add: subseteq_zmset_def)

lemma zmset_subset_eq_zcount: "A \<subseteq>#\<^sub>z B \<Longrightarrow> zcount A a \<le> zcount B a"
  by (simp add: subseteq_zmset_def)

lemma zmset_subset_eq_add_zmset_cancel: \<open>add_zmset a A \<subseteq>#\<^sub>z add_zmset a B \<longleftrightarrow> A \<subseteq>#\<^sub>z B\<close>
  unfolding add_zmset_add_single[of _ A] add_zmset_add_single[of _ B]
  by (rule subset_zmset.add_le_cancel_right)

lemma zmset_subset_eq_zmultiset_union_diff_commute:
  "A - B + C = A + C - B" for A B C :: "'a zmultiset"
  by (simp add: add.commute add_diff_eq)

lemma zmset_subset_eq_insertD: "add_zmset x A \<subseteq>#\<^sub>z B \<Longrightarrow> A \<subset>#\<^sub>z B"
  unfolding subset_zmset_def subseteq_zmset_def
  by (metis (no_types) add.commute add_le_same_cancel2 zcount_add_zmset dual_order.trans le_cases
    le_numeral_extra(2))

lemma zmset_subset_insertD: "add_zmset x A \<subset>#\<^sub>z B \<Longrightarrow> A \<subset>#\<^sub>z B"
  by (rule zmset_subset_eq_insertD) (rule subset_zmset.less_imp_le)

lemma subset_eq_diff_conv_zmset: "A - C \<subseteq>#\<^sub>z B \<longleftrightarrow> A \<subseteq>#\<^sub>z B + C"
  by (simp add: subseteq_zmset_def ordered_ab_group_add_class.diff_le_eq)

lemma multi_psub_of_add_self_zmset[simp]: "A \<subset>#\<^sub>z add_zmset x A"
  by (auto simp: subset_zmset_def subseteq_zmset_def)

lemma multi_psub_self_zmset: "A \<subset>#\<^sub>z A = False"
  by simp

lemma zmset_subset_add_zmset[simp]: "add_zmset x N \<subset>#\<^sub>z add_zmset x M \<longleftrightarrow> N \<subset>#\<^sub>z M"
  unfolding add_zmset_add_single[of _ N] add_zmset_add_single[of _ M]
  by (fact subset_zmset.add_less_cancel_right)

lemma zmset_of_subseteq_iff[simp]: "zmset_of M \<subseteq>#\<^sub>z zmset_of N \<longleftrightarrow> M \<subseteq># N"
  by (simp add: subseteq_zmset_def subseteq_mset_def)

lemma zmset_of_subset_iff[simp]: "zmset_of M \<subset>#\<^sub>z zmset_of N \<longleftrightarrow> M \<subset># N"
  by (simp add: subset_zmset_def subset_mset_def)

lemma
  mset_pos_supset: "A \<subseteq>#\<^sub>z zmset_of (mset_pos A)" and
  mset_neg_supset: "- A \<subseteq>#\<^sub>z zmset_of (mset_neg A)"
  by (auto intro: zmset_subset_eqI)

lemma subset_mset_zmsetE:
  assumes "M \<subset>#\<^sub>z N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A \<subset># B"
  by (metis assms decompose_zmset_of2 subset_zmset.add_less_cancel_right zmset_of_subset_iff)

lemma subseteq_mset_zmsetE:
  assumes "M \<subseteq>#\<^sub>z N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A \<subseteq># B"
  by (metis assms add.commute add.right_neutral subset_mset.order_refl subset_mset_def
    subset_mset_zmsetE subset_zmset_def zmset_of_empty)

subsubsection \<open>Subset is an Order\<close>

interpretation subset_zmset: order "(\<subseteq>#\<^sub>z)" "(\<subset>#\<^sub>z)"
  by unfold_locales

subsection \<open>Replicate and Repeat Operations\<close>

definition replicate_zmset :: "nat \<Rightarrow> 'a \<Rightarrow> 'a zmultiset" where
  "replicate_zmset n x = (add_zmset x ^^ n) {#}\<^sub>z"

lemma replicate_zmset_0[simp]: "replicate_zmset 0 x = {#}\<^sub>z"
  unfolding replicate_zmset_def by simp

lemma replicate_zmset_Suc[simp]: "replicate_zmset (Suc n) x = add_zmset x (replicate_zmset n x)"
  unfolding replicate_zmset_def by (induct n) (auto intro: add.commute)

lemma count_replicate_zmset[simp]:
  "zcount (replicate_zmset n x) y = (if y = x then of_nat n else 0)"
  unfolding replicate_zmset_def by (induct n) auto

fun repeat_zmset :: "nat \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" where
  "repeat_zmset 0 _ = {#}\<^sub>z" |
  "repeat_zmset (Suc n) A = A + repeat_zmset n A"

lemma count_repeat_zmset[simp]: "zcount (repeat_zmset i A) a = of_nat i * zcount A a"
  by (induct i) (auto simp: semiring_normalization_rules(3))

lemma repeat_zmset_right[simp]: "repeat_zmset a (repeat_zmset b A) = repeat_zmset (a * b) A"
  by (auto simp: zmultiset_eq_iff left_diff_distrib')

lemma left_diff_repeat_zmset_distrib':
  \<open>i \<ge> j \<Longrightarrow> repeat_zmset (i - j) u = repeat_zmset i u - repeat_zmset j u\<close>
  by (auto simp: zmultiset_eq_iff int_distrib(3) of_nat_diff)

lemma left_add_mult_distrib_zmset:
  "repeat_zmset i u + (repeat_zmset j u + k) = repeat_zmset (i+j) u + k"
  by (auto simp: zmultiset_eq_iff add_mult_distrib int_distrib(1))

lemma repeat_zmset_distrib: "repeat_zmset (m + n) A = repeat_zmset m A + repeat_zmset n A"
  by (auto simp: zmultiset_eq_iff Nat.add_mult_distrib int_distrib(1))

lemma repeat_zmset_distrib2[simp]:
  "repeat_zmset n (A + B) = repeat_zmset n A + repeat_zmset n B"
  by (auto simp: zmultiset_eq_iff add_mult_distrib2 int_distrib(2))

lemma repeat_zmset_replicate_zmset[simp]: "repeat_zmset n {#a#}\<^sub>z = replicate_zmset n a"
  by (auto simp: zmultiset_eq_iff)

lemma repeat_zmset_distrib_add_zmset[simp]:
  "repeat_zmset n (add_zmset a A) = replicate_zmset n a + repeat_zmset n A"
  by (auto simp: zmultiset_eq_iff int_distrib(2))

lemma repeat_zmset_empty[simp]: "repeat_zmset n {#}\<^sub>z = {#}\<^sub>z"
  by (induct n) simp_all

subsubsection \<open>Filter (with Comprehension Syntax)\<close>

lift_definition filter_zmset :: "('a \<Rightarrow> bool) \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>P (Mp, Mn). (filter_mset P Mp, filter_mset P Mn)"
  by (auto simp del: filter_union_mset simp: equiv_zmset_def filter_union_mset[symmetric])

syntax (ASCII)
  "_MCollect" :: "pttrn \<Rightarrow> 'a zmultiset \<Rightarrow> bool \<Rightarrow> 'a zmultiset" ("(1{#_ :#z _./ _#})")
syntax
  "_MCollect" :: "pttrn \<Rightarrow> 'a zmultiset \<Rightarrow> bool \<Rightarrow> 'a zmultiset" ("(1{#_ \<in>#\<^sub>z _./ _#})")
translations
  "{#x \<in>#\<^sub>z M. P#}" == "CONST filter_zmset (\<lambda>x. P) M"

lemma count_filter_zmset[simp]:
  "zcount (filter_zmset P M) a = (if P a then zcount M a else 0)"
  by transfer auto

lemma filter_empty_zmset[simp]: "filter_zmset P {#}\<^sub>z = {#}\<^sub>z"
  by (rule zmultiset_eqI) simp

lemma filter_single_zmset: "filter_zmset P {#x#}\<^sub>z = (if P x then {#x#}\<^sub>z else {#}\<^sub>z)"
  by (rule zmultiset_eqI) simp

lemma filter_union_zmset[simp]: "filter_zmset P (M + N) = filter_zmset P M + filter_zmset P N"
  by (rule zmultiset_eqI) simp

lemma filter_diff_zmset[simp]: "filter_zmset P (M - N) = filter_zmset P M - filter_zmset P N"
  by (rule zmultiset_eqI) simp

lemma filter_add_zmset[simp]:
  "filter_zmset P (add_zmset x A) =
   (if P x then add_zmset x (filter_zmset P A) else filter_zmset P A)"
  by (auto simp: zmultiset_eq_iff)

lemma zmultiset_filter_mono:
  assumes "A \<subseteq>#\<^sub>z B"
  shows "filter_zmset f A \<subseteq>#\<^sub>z filter_zmset f B"
  using assms by (simp add: subseteq_zmset_def)

lemma filter_filter_zmset: "filter_zmset P (filter_zmset Q M) = {#x \<in># M. Q x \<and> P x#}"
  by (auto simp: zmultiset_eq_iff)

lemma
  filter_zmset_True[simp]: "{#y \<in>#\<^sub>z M. True#} = M" and
  filter_zmset_False[simp]: "{#y \<in>#\<^sub>z M. False#} = {#}\<^sub>z"
  by (auto simp: zmultiset_eq_iff)

subsection \<open>Uncategorized\<close>

lemma multi_drop_mem_not_eq_zmset: "B - {#c#}\<^sub>z \<noteq> B"
  by (simp add: diff_single_eq_union_zmset)

lemma zmultiset_partition: "M = {#x \<in>#\<^sub>z M. P x #} + {#x \<in>#\<^sub>z M. \<not> P x#}"
  by (subst zmultiset_eq_iff) auto

subsection \<open>Image\<close>

definition image_zmset :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a zmultiset \<Rightarrow> 'b zmultiset" where
  "image_zmset f M =
   zmset_of (fold_mset (add_mset \<circ> f) {#} (mset_pos M)) -
   zmset_of (fold_mset (add_mset \<circ> f) {#} (mset_neg M))"

subsection \<open>Multiset Order\<close>

instantiation zmultiset :: (preorder) order
begin

lift_definition less_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" is
  "\<lambda>(Mp, Mn) (Np, Nn). Mp + Nn < Mn + Np"
proof (clarsimp simp: equiv_zmset_def)
  fix A1 B2 B1 A2 C1 D2 D1 C2 :: "'a multiset"
  assume
    ab: "A1 + A2 = B1 + B2" and
    cd: "C1 + C2 = D1 + D2"

  have "A1 + D2 < B2 + C1 \<longleftrightarrow> A1 + A2 + D2 < A2 + B2 + C1"
    by simp
  also have "\<dots> \<longleftrightarrow> B1 + B2 + D2 < A2 + B2 + C1"
    unfolding ab by (rule refl)
  also have "\<dots> \<longleftrightarrow> B1 + D2 < A2 + C1"
    by simp
  also have "\<dots> \<longleftrightarrow> B1 + D1 + D2 < A2 + C1 + D1"
    by simp
  also have "\<dots> \<longleftrightarrow> B1 + C1 + C2 < A2 + C1 + D1"
    using cd by (simp add: add.assoc)
  also have "\<dots> \<longleftrightarrow> B1 + C2 < A2 + D1"
    by simp
  finally show "A1 + D2 < B2 + C1 \<longleftrightarrow> B1 + C2 < A2 + D1"
    by assumption
qed

definition less_eq_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" where
  "less_eq_zmultiset M' M \<longleftrightarrow> M' < M \<or> M' = M"

instance
proof ((intro_classes; unfold less_eq_zmultiset_def; transfer),
    auto simp: equiv_zmset_def union_commute)
  fix A1 B1 D C B2 A2 :: "'a multiset"
  assume ab: "A1 + A2 \<noteq> B1 + B2"

  {
    assume ab1: "A1 + C < B1 + D"

    {
      assume ab2: "D + A2 < C + B2"
      show "A1 + A2 < B1 + B2"
      proof -
        have f1: "\<And>m. D + A2 + m < C + B2 + m"
          using ab2 add_less_cancel_right by blast
        have "\<And>m. C + (A1 + m) < D + (B1 + m)"
          by (simp add: ab1 add.commute)
        then have "D + (A2 + A1) < D + (B1 + B2)"
          using f1 by (metis add.assoc add.commute mset_le_trans)
        then show ?thesis
          by (simp add: add.commute)
      qed
    }
    {
      assume ab2: "D + A2 = C + B2"
      show "A1 + A2 < B1 + B2"
      proof -
        have "\<And>m. C + A1 + m < D + B1 + m"
          by (simp add: ab1 add.commute)
        then have "D + (A2 + A1) < D + (B1 + B2)"
          by (metis (no_types) ab2 add.assoc add.commute)
        then show ?thesis
          by (simp add: add.commute)
      qed
    }
  }

  {
    assume ab1: "A1 + C = B1 + D"

    {
      assume ab2: "D + A2 < C + B2"
      show "A1 + A2 < B1 + B2"
      proof -
        have "A1 + (D + A2) < B1 + (D + B2)"
          by (metis (no_types) ab1 ab2 add.assoc add_less_cancel_left)
        then show ?thesis
          by simp
      qed
    }
    {
      assume ab2: "D + A2 = C + B2"
      have False
        by (metis (no_types) ab ab1 ab2 add.assoc add.commute add_diff_cancel_right')
      thus "A1 + A2 < B1 + B2"
        by sat
    }
  }
qed

end

instance zmultiset :: (preorder) ordered_cancel_comm_monoid_add
  by (intro_classes, unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def)

instance zmultiset :: (preorder) ordered_ab_group_add
  by (intro_classes; transfer; auto simp: equiv_zmset_def)

instantiation zmultiset :: (linorder) distrib_lattice
begin

definition inf_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" where
  "inf_zmultiset A B = (if A < B then A else B)"

definition sup_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" where
  "sup_zmultiset A B = (if B > A then B else A)"

lemma not_lt_iff_ge_zmset: "\<not> x < y \<longleftrightarrow> x \<ge> y" for x y :: "'a zmultiset"
  by (unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def algebra_simps)

instance
  by intro_classes (auto simp: less_eq_zmultiset_def inf_zmultiset_def sup_zmultiset_def
    dest!: not_lt_iff_ge_zmset[THEN iffD1])

end

lemma zmset_of_less: "zmset_of M < zmset_of N \<longleftrightarrow> M < N"
  by (clarsimp simp: zmset_of_def, transfer, simp)+

lemma zmset_of_le: "zmset_of M \<le> zmset_of N \<longleftrightarrow> M \<le> N"
  by (simp_all add: less_eq_zmultiset_def zmset_of_def; transfer; auto simp: equiv_zmset_def)

instance zmultiset :: (preorder) ordered_ab_semigroup_add
  by (intro_classes, unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def)

lemma uminus_add_conv_diff_mset[cancelation_simproc_pre]: \<open>-a + b = b - a\<close> for a :: \<open>'a zmultiset\<close>
  by (simp add: add.commute)

lemma uminus_add_add_uminus[cancelation_simproc_pre]: \<open>b -a + c = b + c - a\<close> for a :: \<open>'a zmultiset\<close>
  by (simp add: uminus_add_conv_diff_mset zmset_subset_eq_zmultiset_union_diff_commute)

lemma add_zmset_eq_add_NO_MATCH[cancelation_simproc_pre]:
  \<open>NO_MATCH {#}\<^sub>z H \<Longrightarrow> add_zmset a H = {#a#}\<^sub>z + H\<close>
  by auto

lemma repeat_zmset_iterate_add: \<open>repeat_zmset n M = iterate_add n M\<close>
  unfolding iterate_add_def by (induction n) auto

declare repeat_zmset_iterate_add[cancelation_simproc_pre]

declare repeat_zmset_iterate_add[symmetric, cancelation_simproc_post]

simproc_setup zmseteq_cancel_numerals
  ("(l::'a zmultiset) + m = n" | "(l::'a zmultiset) = m + n" |
   "add_zmset a m = n" | "m = add_zmset a n" |
   "replicate_zmset p a = n" | "m = replicate_zmset p a" |
   "repeat_zmset p m = n" | "m = repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.eq_cancel\<close>

lemma zmset_subseteq_add_iff1:
  \<open>j \<le> i \<Longrightarrow> (repeat_zmset i u + m \<subseteq>#\<^sub>z repeat_zmset j u + n) = (repeat_zmset (i - j) u + m \<subseteq>#\<^sub>z n)\<close>
  by (simp add: add.commute add_diff_eq left_diff_repeat_zmset_distrib' subset_eq_diff_conv_zmset)

lemma zmset_subseteq_add_iff2:
  \<open>i \<le> j \<Longrightarrow> (repeat_zmset i u + m \<subseteq>#\<^sub>z repeat_zmset j u + n) = (m \<subseteq>#\<^sub>z repeat_zmset (j - i) u + n)\<close>
proof -
  assume "i \<le> j"
  then have "\<And>z. repeat_zmset j (z::'a zmultiset) - repeat_zmset i z = repeat_zmset (j - i) z"
    by (simp add: left_diff_repeat_zmset_distrib')
  then show ?thesis
    by (metis add.commute diff_diff_eq2 subset_eq_diff_conv_zmset)
qed

lemma zmset_subset_add_iff1:
  \<open>j \<le> i \<Longrightarrow> (repeat_zmset i u + m \<subset>#\<^sub>z repeat_zmset j u + n) = (repeat_zmset (i - j) u + m \<subset>#\<^sub>z n)\<close>
  by (simp add: subset_zmset.less_le_not_le zmset_subseteq_add_iff1 zmset_subseteq_add_iff2)

lemma zmset_subset_add_iff2:
  \<open>i \<le> j \<Longrightarrow> (repeat_zmset i u + m \<subset>#\<^sub>z repeat_zmset j u + n) = (m \<subset>#\<^sub>z repeat_zmset (j - i) u + n)\<close>
  by (simp add: subset_zmset.less_le_not_le zmset_subseteq_add_iff1 zmset_subseteq_add_iff2)

ML_file \<open>zmultiset_simprocs.ML\<close>

simproc_setup zmsetsubset_cancel
  ("(l::'a zmultiset) + m \<subset>#\<^sub>z n" | "(l::'a zmultiset) \<subset>#\<^sub>z m + n" |
   "add_zmset a m \<subset>#\<^sub>z n" | "m \<subset>#\<^sub>z add_zmset a n" |
   "replicate_zmset p a \<subset>#\<^sub>z n" | "m \<subset>#\<^sub>z replicate_zmset p a" |
   "repeat_zmset p m \<subset>#\<^sub>z n" | "m \<subset>#\<^sub>z repeat_zmset p m") =
  \<open>fn phi => ZMultiset_Simprocs.subset_cancel_zmsets\<close>

simproc_setup zmsetsubseteq_cancel
  ("(l::'a zmultiset) + m \<subseteq>#\<^sub>z n" | "(l::'a zmultiset) \<subseteq>#\<^sub>z m + n" |
   "add_zmset a m \<subseteq>#\<^sub>z n" | "m \<subseteq>#\<^sub>z add_zmset a n" |
   "replicate_zmset p a \<subseteq>#\<^sub>z n" | "m \<subseteq>#\<^sub>z replicate_zmset p a" |
   "repeat_zmset p m \<subseteq>#\<^sub>z n" | "m \<subseteq>#\<^sub>z repeat_zmset p m") =
  \<open>fn phi => ZMultiset_Simprocs.subseteq_cancel_zmsets\<close>

instance zmultiset :: (preorder) ordered_ab_semigroup_add_imp_le
  by (intro_classes; unfold less_eq_zmultiset_def; transfer; auto)

simproc_setup zmsetless_cancel
  ("(l::'a::preorder zmultiset) + m < n" | "(l::'a zmultiset) < m + n" |
   "add_zmset a m < n" | "m < add_zmset a n" |
   "replicate_zmset p a < n" | "m < replicate_zmset p a" |
   "repeat_zmset p m < n" | "m < repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.less_cancel\<close>

simproc_setup zmsetless_eq_cancel
  ("(l::'a::preorder zmultiset) + m \<le> n" | "(l::'a zmultiset) \<le> m + n" |
   "add_zmset a m \<le> n" | "m \<le> add_zmset a n" |
   "replicate_zmset p a \<le> n" | "m \<le> replicate_zmset p a" |
   "repeat_zmset p m \<le> n" | "m \<le> repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.less_eq_cancel\<close>

simproc_setup zmsetdiff_cancel
  ("n + (l::'a zmultiset)" | "(l::'a zmultiset) - m" |
   "add_zmset a m - n" | "m - add_zmset a n" |
   "replicate_zmset p r - n" | "m - replicate_zmset p r" |
   "repeat_zmset p m - n" | "m - repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.diff_cancel\<close>

instance zmultiset :: (linorder) linordered_cancel_ab_semigroup_add
  by (intro_classes, unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def add.commute)

lemma less_mset_zmsetE:
  assumes "M < N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A < B"
  by (metis add_less_imp_less_right assms decompose_zmset_of2 zmset_of_less)

lemma less_eq_mset_zmsetE:
  assumes "M \<le> N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A \<le> B"
  by (metis add.commute add.right_neutral assms le_neq_trans less_imp_le less_mset_zmsetE order_refl
    zmset_of_empty)

lemma subset_eq_imp_le_zmset: "M \<subseteq>#\<^sub>z N \<Longrightarrow> M \<le> N"
  by (metis (no_types) add_mono_thms_linordered_semiring(3) subset_eq_imp_le_multiset
    subseteq_mset_zmsetE zmset_of_le)

lemma subset_imp_less_zmset: "M \<subset>#\<^sub>z N \<Longrightarrow> M < N"
  by (metis le_neq_trans subset_eq_imp_le_zmset subset_zmset_def)

lemma lt_imp_ex_zcount_lt:
  assumes m_lt_n: "M < N"
  shows "\<exists>y. zcount M y < zcount N y"
proof (rule ccontr, clarsimp)
  assume "\<forall>y. \<not> zcount M y < zcount N y"
  hence "\<forall>y. zcount M y \<ge> zcount N y"
    by (simp add: leI)
  hence "M \<supseteq>#\<^sub>z N"
    by (simp add: zmset_subset_eqI)
  hence "M \<ge> N"
    by (simp add: subset_eq_imp_le_zmset)
  thus False
    using m_lt_n by simp
qed

instance zmultiset :: (preorder) no_top
proof
  fix M :: \<open>'a zmultiset\<close>
  obtain a :: 'a where True by fast
  let ?M = \<open>zmset_of (mset_pos M) + zmset_of (mset_neg M)\<close>
  have \<open>M < add_zmset a ?M + ?M\<close>
    by (subst mset_pos_neg_partition)
      (auto simp: subset_zmset_def subseteq_zmset_def zmultiset_eq_iff
        intro!: subset_imp_less_zmset)
  then show \<open>\<exists>N. M < N\<close>
    by blast
qed

end


(*  Title:      HOL/ex/Groebner_Examples.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section {* Groebner Basis Examples *}

theory Groebner_Examples
imports Groebner_Basis
begin

subsection {* Basic examples *}

lemma
  fixes x :: int
  shows "x ^ 3 = x ^ 3"
  apply (tactic {* ALLGOALS (CONVERSION
    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context})))) *})
  by (rule refl)

lemma
  fixes x :: int
  shows "(x - (-2))^5 = x ^ 5 + (10 * x ^ 4 + (40 * x ^ 3 + (80 * x\<^sup>2 + (80 * x + 32))))"
  apply (tactic {* ALLGOALS (CONVERSION
    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context})))) *})
  by (rule refl)

schematic_lemma
  fixes x :: int
  shows "(x - (-2))^5  * (y - 78) ^ 8 = ?X"
  apply (tactic {* ALLGOALS (CONVERSION
    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context})))) *})
  by (rule refl)

lemma "((-3) ^ (Suc (Suc (Suc 0)))) == (X::'a::{comm_ring_1})"
  apply (simp only: power_Suc power_0)
  apply (simp only: semiring_norm)
  oops

lemma "((x::int) + y)^3 - 1 = (x - z)^2 - 10 \<Longrightarrow> x = z + 3 \<Longrightarrow> x = - y"
  by algebra

lemma "(4::nat) + 4 = 3 + 5"
  by algebra

lemma "(4::int) + 0 = 4"
  apply algebra?
  by simp

lemma
  assumes "a * x\<^sup>2 + b * x + c = (0::int)" and "d * x\<^sup>2 + e * x + f = 0"
  shows "d\<^sup>2 * c\<^sup>2 - 2 * d * c * a * f + a\<^sup>2 * f\<^sup>2 - e * d * b * c - e * b * a * f +
    a * e\<^sup>2 * c + f * d * b\<^sup>2 = 0"
  using assms by algebra

lemma "(x::int)^3  - x^2  - 5*x - 3 = 0 \<longleftrightarrow> (x = 3 \<or> x = -1)"
  by algebra

theorem "x* (x\<^sup>2 - x  - 5) - 3 = (0::int) \<longleftrightarrow> (x = 3 \<or> x = -1)"
  by algebra

lemma
  fixes x::"'a::idom"
  shows "x\<^sup>2*y = x\<^sup>2 & x*y\<^sup>2 = y\<^sup>2 \<longleftrightarrow>  x = 1 & y = 1 | x = 0 & y = 0"
  by algebra

subsection {* Lemmas for Lagrange's theorem *}

definition
  sq :: "'a::times => 'a" where
  "sq x == x*x"

lemma
  fixes x1 :: "'a::{idom}"
  shows
  "(sq x1 + sq x2 + sq x3 + sq x4) * (sq y1 + sq y2 + sq y3 + sq y4) =
    sq (x1*y1 - x2*y2 - x3*y3 - x4*y4)  +
    sq (x1*y2 + x2*y1 + x3*y4 - x4*y3)  +
    sq (x1*y3 - x2*y4 + x3*y1 + x4*y2)  +
    sq (x1*y4 + x2*y3 - x3*y2 + x4*y1)"
  by (algebra add: sq_def)

lemma
  fixes p1 :: "'a::{idom}"
  shows
  "(sq p1 + sq q1 + sq r1 + sq s1 + sq t1 + sq u1 + sq v1 + sq w1) *
   (sq p2 + sq q2 + sq r2 + sq s2 + sq t2 + sq u2 + sq v2 + sq w2)
    = sq (p1*p2 - q1*q2 - r1*r2 - s1*s2 - t1*t2 - u1*u2 - v1*v2 - w1*w2) +
      sq (p1*q2 + q1*p2 + r1*s2 - s1*r2 + t1*u2 - u1*t2 - v1*w2 + w1*v2) +
      sq (p1*r2 - q1*s2 + r1*p2 + s1*q2 + t1*v2 + u1*w2 - v1*t2 - w1*u2) +
      sq (p1*s2 + q1*r2 - r1*q2 + s1*p2 + t1*w2 - u1*v2 + v1*u2 - w1*t2) +
      sq (p1*t2 - q1*u2 - r1*v2 - s1*w2 + t1*p2 + u1*q2 + v1*r2 + w1*s2) +
      sq (p1*u2 + q1*t2 - r1*w2 + s1*v2 - t1*q2 + u1*p2 - v1*s2 + w1*r2) +
      sq (p1*v2 + q1*w2 + r1*t2 - s1*u2 - t1*r2 + u1*s2 + v1*p2 - w1*q2) +
      sq (p1*w2 - q1*v2 + r1*u2 + s1*t2 - t1*s2 - u1*r2 + v1*q2 + w1*p2)"
  by (algebra add: sq_def)

subsection {* Colinearity is invariant by rotation *}

type_synonym point = "int \<times> int"

definition collinear ::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
  "collinear \<equiv> \<lambda>(Ax,Ay) (Bx,By) (Cx,Cy).
    ((Ax - Bx) * (By - Cy) = (Ay - By) * (Bx - Cx))"

lemma collinear_inv_rotation:
  assumes "collinear (Ax, Ay) (Bx, By) (Cx, Cy)" and "c\<^sup>2 + s\<^sup>2 = 1"
  shows "collinear (Ax * c - Ay * s, Ay * c + Ax * s)
    (Bx * c - By * s, By * c + Bx * s) (Cx * c - Cy * s, Cy * c + Cx * s)"
  using assms
  by (algebra add: collinear_def split_def fst_conv snd_conv)

lemma "EX (d::int). a*y - a*x = n*d \<Longrightarrow> EX u v. a*u + n*v = 1 \<Longrightarrow> EX e. y - x = n*e"
  by algebra

end


(*  Title:       Termination of the hydra battle
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2017
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Termination of the Hydra Battle\<close>

theory Hydra_Battle
imports Syntactic_Ordinal
begin

hide_const (open) Nil Cons

text \<open>
The \<open>h\<close> function and its auxiliaries \<open>f\<close> and \<open>d\<close> represent the
hydra battle. The \<open>encode\<close> function converts a hydra (represented as a
Lisp-like tree) to a syntactic ordinal. The definitions follow Dershowitz and
Moser.
\<close>

datatype lisp =
  Nil
| Cons (car: lisp) (cdr: lisp)
where
  "car Nil = Nil"
| "cdr Nil = Nil"

primrec encode :: "lisp \<Rightarrow> hmultiset" where
  "encode Nil = 0"
| "encode (Cons l r) = \<omega>^(encode l) + encode r"

primrec f :: "nat \<Rightarrow> lisp \<Rightarrow> lisp \<Rightarrow> lisp" where
  "f 0 y x = x"
| "f (Suc m) y x = Cons y (f m y x)"

lemma encode_f: "encode (f n y x) = of_nat n * \<omega>^(encode y) + encode x"
  unfolding of_nat_times_\<omega>_exp by (induct n) (auto simp: HMSet_plus[symmetric])

function d :: "nat \<Rightarrow> lisp \<Rightarrow> lisp" where
  "d n x =
   (if car x = Nil then cdr x
    else if car (car x) = Nil then f n (cdr (car x)) (cdr x)
    else Cons (d n (car x)) (cdr x))"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(_, x). size x)", rule wf_measure, rename_tac n x, case_tac x, auto)

declare d.simps[simp del]

function h :: "nat \<Rightarrow> lisp \<Rightarrow> lisp" where
  "h n x = (if x = Nil then Nil else h (n + 1) (d n x))"
  by pat_completeness auto
termination
proof -
  let ?R = "inv_image {(m, n). m < n} (\<lambda>(n, x). encode x)"

  show ?thesis
  proof (relation ?R)
    show "wf ?R"
      by (rule wf_inv_image) (rule wf)
  next
    fix n x
    assume x_cons: "x \<noteq> Nil"
    thus "((n + 1, d n x), n, x) \<in> ?R"
      unfolding inv_image_def mem_Collect_eq prod.case
    proof (induct x)
      case (Cons l r)
      note ihl = this(1)
      show ?case
      proof (subst d.simps, simp, intro conjI impI)
        assume l_cons: "l \<noteq> Nil"
        {
          assume "car l = Nil"
          show "encode (f n (cdr l) r) < \<omega>^(encode l) + encode r"
            using l_cons by (cases l) (auto simp: encode_f[unfolded of_nat_times_\<omega>_exp])
        }
        {
          show "encode (d n l) < encode l"
            by (rule ihl[OF l_cons])
        }
      qed
    qed simp
  qed
qed

declare h.simps[simp del]

end


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

section \<open>Verification of functional Selection Sort\<close>

theory SelectionSort_Functional
imports RemoveMax
begin

subsection \<open>Defining data structure\<close>

text\<open>Selection sort works with list and that is the reason why {\em
  Collection} should be interpreted as list.\<close>

interpretation Collection "[]" "\<lambda> l. l = []" id mset
by (unfold_locales, auto)

subsection \<open>Defining function remove\_max\<close>

text\<open>The following is definition of {\em remove\_max} function.
The idea is very well known -- assume that the maximum element is the
first one and then compare with each element of the list. Function
{\em f} is one step in iteration, it compares current maximum {\em m}
with one element {\em x}, if it is bigger then {\em m} stays current
maximum and {\em x} is added in the resulting list, otherwise {\em x}
is current maximum and {\em m} is added in the resulting
list.
\<close>

fun f where "f (m, l) x = (if x \<ge> m then (x, m#l) else (m, x#l))"

definition remove_max where
  "remove_max l = foldl f (hd l, []) (tl l)"

lemma max_Max_commute:
  "finite A \<Longrightarrow> max (Max (insert m A)) x = max m (Max (insert x A))"
  apply (cases "A = {}", simp)
  by (metis Max_insert max.commute max.left_commute)

text\<open>The function really returned the
maximum value.\<close>

lemma remove_max_max_lemma:
  shows "fst (foldl f (m, t) l) =  Max (set (m # l))"
proof (induct l arbitrary: m t rule: rev_induct)
  case (snoc x xs)
  let ?a = "foldl f (m, t) xs"
  let ?m' = "fst ?a" and ?t' = "snd ?a"
  have "fst (foldl f (m, t) (xs @ [x])) = max ?m' x"
    by (cases ?a) (auto simp add: max_def)
  thus ?case
    using snoc
    by (simp add: max_Max_commute)
qed simp

lemma remove_max_max:
  assumes "l \<noteq> []" "(m, l') = remove_max l"
  shows "m = Max (set l)"
using assms
unfolding remove_max_def
using remove_max_max_lemma[of "hd l" "[]" "tl l"]
using fst_conv[of m l']
by simp

text\<open>Nothing new is added in the list and noting is deleted
from the list except the maximum element.\<close>

lemma remove_max_mset_lemma:
  assumes "(m, l') = foldl f (m', t') l"
  shows "mset (m # l') = mset (m' # t' @ l)"
using assms
proof (induct l arbitrary: l' m m' t' rule: rev_induct)
  case (snoc x xs)
  let ?a = "foldl f (m', t') xs"
  let ?m' = "fst ?a" and ?t' = "snd ?a"
  have "mset (?m' # ?t') = mset (m' # t' @ xs)"
    using snoc(1)[of ?m' ?t' m' t']
    by simp
  thus ?case
    using snoc(2)
    apply (cases "?a")
    by (auto split: if_split_asm)
qed simp

lemma remove_max_mset:
  assumes "l \<noteq> []" "(m, l') = remove_max l"
  shows "add_mset m (mset l') = mset l"
using assms
unfolding remove_max_def
using remove_max_mset_lemma[of m l' "hd l" "[]" "tl l"]
by auto

definition ssf_ssort' where
  [simp, code del]: "ssf_ssort' = RemoveMax.ssort' (\<lambda> l. l = []) remove_max"
definition ssf_ssort where
  [simp, code del]: "ssf_ssort = RemoveMax.ssort (\<lambda> l. l = []) id remove_max"

interpretation SSRemoveMax:
  RemoveMax "[]" "\<lambda> l. l = []" id mset remove_max "\<lambda> _. True"
  rewrites
 "RemoveMax.ssort' (\<lambda> l. l = []) remove_max = ssf_ssort'" and
 "RemoveMax.ssort (\<lambda> l. l = []) id remove_max = ssf_ssort"
using remove_max_max
by (unfold_locales, auto simp add: remove_max_mset)

end


section \<open> Guarded Recursion \<close>

theory utp_rdes_guarded
  imports utp_rdes_productive
begin

subsection \<open> Traces with a size measure \<close>

text \<open> Guarded recursion relies on our ability to measure the trace's size, in order to see if it
  is decreasing on each iteration. Thus, we here equip the trace algebra with the @{term size}
  function that provides this. \<close>

class size_trace = trace + size +
  assumes
    size_zero: "size 0 = 0" and
    size_nzero: "s > 0 \<Longrightarrow> size(s) > 0" and
    size_plus: "size (s + t) = size(s) + size(t)"
  \<comment> \<open> These axioms may be stronger than necessary. In particular, @{thm size_nzero} requires that
       a non-empty trace have a positive size. But this may not be the case with all trace models
       and is possibly more restrictive than necessary. In future we will explore weakening. \<close>
begin

lemma size_mono: "s \<le> t \<Longrightarrow> size(s) \<le> size(t)"
  by (metis le_add1 local.diff_add_cancel_left' local.size_plus)

lemma size_strict_mono: "s < t \<Longrightarrow> size(s) < size(t)"
  by (metis cancel_ab_semigroup_add_class.add_diff_cancel_left' local.diff_add_cancel_left' local.less_iff local.minus_gr_zero_iff local.size_nzero local.size_plus zero_less_diff)

lemma trace_strict_prefixE: "xs < ys \<Longrightarrow> (\<And>zs. \<lbrakk> ys = xs + zs; size(zs) > 0 \<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  by (metis local.diff_add_cancel_left' local.less_iff local.minus_gr_zero_iff local.size_nzero)

lemma size_minus_trace: "y \<le> x \<Longrightarrow> size(x - y) = size(x) - size(y)"
  by (metis diff_add_inverse local.diff_add_cancel_left' local.size_plus)

end

text \<open> Both natural numbers and lists are measurable trace algebras. \<close>

instance nat :: size_trace
  by (intro_classes, simp_all)

instance list :: (type) size_trace
  by (intro_classes, simp_all add: less_list_def' plus_list_def prefix_length_less)

syntax
  "_usize"      :: "logic \<Rightarrow> logic" ("size\<^sub>u'(_')")

translations
  "size\<^sub>u(t)" == "CONST uop CONST size t"

subsection \<open> Guardedness \<close>

definition gvrt :: "(('t::size_trace,'\<alpha>) rp \<times> ('t,'\<alpha>) rp) chain" where
[upred_defs]: "gvrt(n) \<equiv> ($tr \<le>\<^sub>u $tr\<acute> \<and> size\<^sub>u(&tt) <\<^sub>u \<guillemotleft>n\<guillemotright>)"

lemma gvrt_chain: "chain gvrt"
  apply (simp add: chain_def, safe)
  apply (rel_simp)
  apply (rel_simp)+
done

lemma gvrt_limit: "\<Sqinter> (range gvrt) = ($tr \<le>\<^sub>u $tr\<acute>)"
  by (rel_auto)

definition Guarded :: "(('t::size_trace,'\<alpha>) hrel_rp \<Rightarrow> ('t,'\<alpha>) hrel_rp) \<Rightarrow> bool" where
[upred_defs]: "Guarded(F) = (\<forall> X n. (F(X) \<and> gvrt(n+1)) = (F(X \<and> gvrt(n)) \<and> gvrt(n+1)))"

lemma GuardedI: "\<lbrakk> \<And> X n. (F(X) \<and> gvrt(n+1)) = (F(X \<and> gvrt(n)) \<and> gvrt(n+1)) \<rbrakk> \<Longrightarrow> Guarded F"
  by (simp add: Guarded_def)

text \<open> Guarded reactive designs yield unique fixed-points. \<close>

theorem guarded_fp_uniq:
  assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>SRD\<rbrakk>\<^sub>H" "Guarded F"
  shows "\<mu> F = \<nu> F"
proof -
  have "constr F gvrt"
    using assms
    by (auto simp add: constr_def gvrt_chain Guarded_def tcontr_alt_def')
  hence "($tr \<le>\<^sub>u $tr\<acute> \<and> \<mu> F) = ($tr \<le>\<^sub>u $tr\<acute> \<and> \<nu> F)"
    apply (rule constr_fp_uniq)
     apply (simp add: assms)
    using gvrt_limit apply blast
    done
  moreover have "($tr \<le>\<^sub>u $tr\<acute> \<and> \<mu> F) = \<mu> F"
  proof -
    have "\<mu> F is R1"
      by (rule SRD_healths(1), rule Healthy_mu, simp_all add: assms)
    thus ?thesis
      by (metis Healthy_def R1_def conj_comm)
  qed
  moreover have "($tr \<le>\<^sub>u $tr\<acute> \<and> \<nu> F) = \<nu> F"
  proof -
    have "\<nu> F is R1"
      by (rule SRD_healths(1), rule Healthy_nu, simp_all add: assms)
    thus ?thesis
      by (metis Healthy_def R1_def conj_comm)
  qed
  ultimately show ?thesis
    by (simp)
qed

lemma Guarded_const [closure]: "Guarded (\<lambda> X. P)"
  by (simp add: Guarded_def)

lemma UINF_Guarded [closure]:
  assumes  "\<And> P. P \<in> A \<Longrightarrow> Guarded P"
  shows "Guarded (\<lambda> X. \<Sqinter>P\<in>A \<bullet> P(X))"
proof (rule GuardedI)
  fix X n
  have "\<And> Y. ((\<Sqinter>P\<in>A \<bullet> P Y) \<and> gvrt(n+1)) = ((\<Sqinter>P\<in>A \<bullet> (P Y \<and> gvrt(n+1))) \<and> gvrt(n+1))"
  proof -
    fix Y
    let ?lhs = "((\<Sqinter>P\<in>A \<bullet> P Y) \<and> gvrt(n+1))" and ?rhs = "((\<Sqinter>P\<in>A \<bullet> (P Y \<and> gvrt(n+1))) \<and> gvrt(n+1))"
    have a:"?lhs\<lbrakk>false/$ok\<rbrakk> = ?rhs\<lbrakk>false/$ok\<rbrakk>"
      by (rel_auto)
    have b:"?lhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>true/$wait\<rbrakk> = ?rhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>true/$wait\<rbrakk>"
      by (rel_auto)
    have c:"?lhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>false/$wait\<rbrakk> = ?rhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>false/$wait\<rbrakk>"
      by (rel_auto)
    show "?lhs = ?rhs"
      using a b c
      by (rule_tac bool_eq_splitI[of "in_var ok"], simp, rule_tac bool_eq_splitI[of "in_var wait"], simp_all)
  qed
  moreover have "((\<Sqinter>P\<in>A \<bullet> (P X \<and> gvrt(n+1))) \<and> gvrt(n+1)) =  ((\<Sqinter>P\<in>A \<bullet> (P (X \<and> gvrt(n)) \<and> gvrt(n+1))) \<and> gvrt(n+1))"
  proof -
    have "(\<Sqinter>P\<in>A \<bullet> (P X \<and> gvrt(n+1))) = (\<Sqinter>P\<in>A \<bullet> (P (X \<and> gvrt(n)) \<and> gvrt(n+1)))"
    proof (rule UINF_cong)
      fix P assume "P \<in> A"
      thus "(P X \<and> gvrt(n+1)) = (P (X \<and> gvrt(n)) \<and> gvrt(n+1))"
        using Guarded_def assms by blast
    qed
    thus ?thesis by simp
  qed
  ultimately show "((\<Sqinter>P\<in>A \<bullet> P X) \<and> gvrt(n+1)) = ((\<Sqinter>P\<in>A \<bullet> (P (X \<and> gvrt(n)))) \<and> gvrt(n+1))"
    by simp
qed

lemma intChoice_Guarded [closure]:
  assumes "Guarded P" "Guarded Q"
  shows "Guarded (\<lambda> X. P(X) \<sqinter> Q(X))"
proof -
  have "Guarded (\<lambda> X. \<Sqinter>F\<in>{P,Q} \<bullet> F(X))"
    by (rule UINF_Guarded, auto simp add: assms)
  thus ?thesis
    by (simp)
qed

lemma cond_srea_Guarded [closure]:
  assumes "Guarded P" "Guarded Q"
  shows "Guarded (\<lambda> X. P(X) \<triangleleft> b \<triangleright>\<^sub>R Q(X))"
  using assms by (rel_auto)

text \<open> A tail recursive reactive design with a productive body is guarded. \<close>

lemma Guarded_if_Productive [closure]:
  fixes P :: "('s, 't::size_trace,'\<alpha>) hrel_rsp"
  assumes "P is NSRD" "P is Productive"
  shows "Guarded (\<lambda> X. P ;; SRD(X))"
proof (clarsimp simp add: Guarded_def)
  \<comment> \<open> We split the proof into three cases corresponding to valuations for ok, wait, and wait'
        respectively. \<close>
  fix X n
  have a:"(P ;; SRD(X) \<and> gvrt (Suc n))\<lbrakk>false/$ok\<rbrakk> =
        (P ;; SRD(X \<and> gvrt n) \<and> gvrt (Suc n))\<lbrakk>false/$ok\<rbrakk>"
    by (simp add: usubst closure SRD_left_zero_1 assms)
  have b:"((P ;; SRD(X) \<and> gvrt (Suc n))\<lbrakk>true/$ok\<rbrakk>)\<lbrakk>true/$wait\<rbrakk> =
          ((P ;; SRD(X \<and> gvrt n) \<and> gvrt (Suc n))\<lbrakk>true/$ok\<rbrakk>)\<lbrakk>true/$wait\<rbrakk>"
    by (simp add: usubst closure SRD_left_zero_2 assms)
  have c:"((P ;; SRD(X) \<and> gvrt (Suc n))\<lbrakk>true/$ok\<rbrakk>)\<lbrakk>false/$wait\<rbrakk> =
          ((P ;; SRD(X \<and> gvrt n) \<and> gvrt (Suc n))\<lbrakk>true/$ok\<rbrakk>)\<lbrakk>false/$wait\<rbrakk>"
  proof -
    have 1:"(P\<lbrakk>true/$wait\<acute>\<rbrakk> ;; (SRD X)\<lbrakk>true/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk> =
          (P\<lbrakk>true/$wait\<acute>\<rbrakk> ;; (SRD (X \<and> gvrt n))\<lbrakk>true/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
      by (metis (no_types, lifting) Healthy_def R3h_wait_true SRD_healths(3) SRD_idem)
    have 2:"(P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD X)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk> =
          (P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD (X \<and> gvrt n))\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
    proof -
      have exp:"\<And> Y::('s, 't,'\<alpha>) hrel_rsp. (P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk> =
                  ((((\<not>\<^sub>r pre\<^sub>R P) ;; (SRD(Y))\<lbrakk>false/$wait\<rbrakk> \<or> (post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; (SRD Y)\<lbrakk>true,false/$ok,$wait\<rbrakk>))
                     \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
      proof -
        fix Y :: "('s, 't,'\<alpha>) hrel_rsp"

        have "(P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk> =
              ((\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> (post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
          by (metis (no_types) Healthy_def Productive_form assms(1) assms(2) NSRD_is_SRD)
        also have "... =
             ((R1(R2c(pre\<^sub>R(P) \<Rightarrow> ($ok\<acute> \<and> post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>))))\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
          by (simp add: RHS_def R1_def R2c_def R2s_def R3h_def RD1_def RD2_def usubst unrest assms closure design_def)
        also have "... =
             (((\<not>\<^sub>r pre\<^sub>R(P) \<or> ($ok\<acute> \<and> post\<^sub>R(P) \<and> $tr <\<^sub>u $tr\<acute>)))\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
          by (simp add: impl_alt_def R2c_disj R1_disj R2c_not  assms closure R2c_and
              R2c_preR rea_not_def R1_extend_conj' R2c_ok' R2c_post_SRD R1_tr_less_tr' R2c_tr_less_tr')
        also have "... =
             ((((\<not>\<^sub>r pre\<^sub>R P) ;; (SRD(Y))\<lbrakk>false/$wait\<rbrakk> \<or> ($ok\<acute> \<and> post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk>)) \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
          by (simp add: usubst unrest assms closure seqr_or_distl NSRD_neg_pre_left_zero)
        also have "... =
             ((((\<not>\<^sub>r pre\<^sub>R P) ;; (SRD(Y))\<lbrakk>false/$wait\<rbrakk> \<or> (post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; (SRD Y)\<lbrakk>true,false/$ok,$wait\<rbrakk>)) \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
        proof -
          have "($ok\<acute> \<and> post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk> =
                ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) \<and> $ok\<acute> =\<^sub>u true) ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk>"
            by (rel_blast)
          also have "... = (post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr)\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk>\<lbrakk>true/$ok\<rbrakk>"
            using seqr_left_one_point[of ok "(post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr)" True "(SRD Y)\<lbrakk>false/$wait\<rbrakk>"]
            by (simp add: true_alt_def[THEN sym])
          finally show ?thesis by (simp add: usubst unrest)
        qed
        finally
        show "(P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD Y)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk> =
                 ((((\<not>\<^sub>r pre\<^sub>R P) ;; (SRD(Y))\<lbrakk>false/$wait\<rbrakk> \<or> (post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; (SRD Y)\<lbrakk>true,false/$ok,$wait\<rbrakk>))
                 \<and> gvrt (Suc n))\<lbrakk>true,false/$ok,$wait\<rbrakk>" .
      qed

      have 1:"((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; (SRD X)\<lbrakk>true,false/$ok,$wait\<rbrakk> \<and> gvrt (Suc n)) =
              ((post\<^sub>R P \<and> $tr\<acute> >\<^sub>u $tr) ;; (SRD (X \<and> gvrt n))\<lbrakk>true,false/$ok,$wait\<rbrakk> \<and> gvrt (Suc n))"
        apply (rel_auto)
         apply (rename_tac tr st more ok wait tr' st' more' tr\<^sub>0 st\<^sub>0 more\<^sub>0 ok')
         apply (rule_tac x="tr\<^sub>0" in exI, rule_tac x="st\<^sub>0" in exI, rule_tac x="more\<^sub>0" in exI)
         apply (simp)
         apply (erule trace_strict_prefixE)
         apply (rename_tac tr st ref ok wait tr' st' ref' tr\<^sub>0 st\<^sub>0 ref\<^sub>0 ok' zs)
         apply (rule_tac x="False" in exI)
         apply (simp add: size_minus_trace)
         apply (subgoal_tac "size(tr) < size(tr\<^sub>0)")
          apply (simp add: less_diff_conv2 size_mono)
        using size_strict_mono apply blast
        apply (rename_tac tr st more ok wait tr' st' more' tr\<^sub>0 st\<^sub>0 more\<^sub>0 ok')
        apply (rule_tac x="tr\<^sub>0" in exI, rule_tac x="st\<^sub>0" in exI, rule_tac x="more\<^sub>0" in exI)
        apply (simp)
        apply (erule trace_strict_prefixE)
        apply (rename_tac tr st more ok wait tr' st' more' tr\<^sub>0 st\<^sub>0 more\<^sub>0 ok' zs)
        apply (auto simp add: size_minus_trace)
        apply (subgoal_tac "size(tr) < size(tr\<^sub>0)")
         apply (simp add: less_diff_conv2 size_mono)
        using size_strict_mono apply blast
        done
      have 2:"(\<not>\<^sub>r pre\<^sub>R P) ;; (SRD X)\<lbrakk>false/$wait\<rbrakk> = (\<not>\<^sub>r pre\<^sub>R P) ;; (SRD(X \<and> gvrt n))\<lbrakk>false/$wait\<rbrakk>"
        by (simp add: NSRD_neg_pre_left_zero closure assms SRD_healths)
      show ?thesis
        by (simp add: exp 1 2 utp_pred_laws.inf_sup_distrib2)
    qed

    show ?thesis
    proof -
      have "(P ;; (SRD X) \<and> gvrt (n+1))\<lbrakk>true,false/$ok,$wait\<rbrakk> =
          ((P\<lbrakk>true/$wait\<acute>\<rbrakk> ;; (SRD X)\<lbrakk>true/$wait\<rbrakk> \<and> gvrt (n+1))\<lbrakk>true,false/$ok,$wait\<rbrakk> \<or>
          (P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD X)\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (n+1))\<lbrakk>true,false/$ok,$wait\<rbrakk>)"
        by (subst seqr_bool_split[of wait], simp_all add: usubst utp_pred_laws.distrib(4))

      also
      have "... = ((P\<lbrakk>true/$wait\<acute>\<rbrakk> ;; (SRD (X \<and> gvrt n))\<lbrakk>true/$wait\<rbrakk> \<and> gvrt (n+1))\<lbrakk>true,false/$ok,$wait\<rbrakk> \<or>
                 (P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD (X \<and> gvrt n))\<lbrakk>false/$wait\<rbrakk> \<and> gvrt (n+1))\<lbrakk>true,false/$ok,$wait\<rbrakk>)"
        by (simp add: 1 2)

      also
      have "... = ((P\<lbrakk>true/$wait\<acute>\<rbrakk> ;; (SRD (X \<and> gvrt n))\<lbrakk>true/$wait\<rbrakk> \<or>
                    P\<lbrakk>false/$wait\<acute>\<rbrakk> ;; (SRD (X \<and> gvrt n))\<lbrakk>false/$wait\<rbrakk>) \<and> gvrt (n+1))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
        by (simp add: usubst utp_pred_laws.distrib(4))

      also have "... = (P ;; (SRD (X \<and> gvrt n)) \<and> gvrt (n+1))\<lbrakk>true,false/$ok,$wait\<rbrakk>"
        by (subst seqr_bool_split[of wait], simp_all add: usubst)
      finally show ?thesis by (simp add: usubst)
    qed

  qed
  show "(P ;; SRD(X) \<and> gvrt (Suc n)) = (P ;; SRD(X \<and> gvrt n) \<and> gvrt (Suc n))"
    apply (rule_tac bool_eq_splitI[of "in_var ok"])
      apply (simp_all add: a)
    apply (rule_tac bool_eq_splitI[of "in_var wait"])
      apply (simp_all add: b c)
  done
qed

subsection \<open> Tail recursive fixed-point calculations \<close>

declare upred_semiring.power_Suc [simp]

lemma mu_csp_form_1 [rdes]:
  fixes P :: "('s, 't::size_trace,'\<alpha>) hrel_rsp"
  assumes "P is NSRD" "P is Productive"
  shows "(\<mu> X \<bullet> P ;; SRD(X)) = (\<Sqinter>i \<bullet> P \<^bold>^ (i+1)) ;; Miracle"
proof -
  have 1:"Continuous (\<lambda>X. P ;; SRD X)"
    using SRD_Continuous
    by (clarsimp simp add: Continuous_def seq_SUP_distl[THEN sym], drule_tac x="A" in spec, simp)
  have 2: "(\<lambda>X. P ;; SRD X) \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>SRD\<rbrakk>\<^sub>H"
    by (blast intro: funcsetI closure assms)
  with 1 2 have "(\<mu> X \<bullet> P ;; SRD(X)) = (\<nu> X \<bullet> P ;; SRD(X))"
    by (simp add: guarded_fp_uniq Guarded_if_Productive[OF assms] funcsetI closure)
  also have "... = (\<Sqinter>i. ((\<lambda>X. P ;; SRD X) ^^ i) false)"
    by (simp add: sup_continuous_lfp 1 sup_continuous_Continuous false_upred_def)
  also have "... = ((\<lambda>X. P ;; SRD X) ^^ 0) false \<sqinter> (\<Sqinter>i. ((\<lambda>X. P ;; SRD X) ^^ (i+1)) false)"
    by (subst Sup_power_expand, simp)
  also have "... = (\<Sqinter>i. ((\<lambda>X. P ;; SRD X) ^^ (i+1)) false)"
    by (simp)
  also have "... = (\<Sqinter>i. P \<^bold>^ (i+1) ;; Miracle)"
  proof (rule SUP_cong, simp_all)
    fix i
    show "P ;; SRD (((\<lambda>X. P ;; SRD X) ^^ i) false) = (P ;; P \<^bold>^ i) ;; Miracle"
    proof (induct i)
      case 0
      then show ?case
        by (simp, metis srdes_theory.healthy_top)
    next
      case (Suc i)
      then show ?case
        by (simp add: Healthy_if NSRD_is_SRD SRD_power_comp SRD_seqr_closure assms(1) seqr_assoc[THEN sym] srdes_theory.top_closed)
    qed
  qed
  also have "... = (\<Sqinter>i. P \<^bold>^ (i+1)) ;; Miracle"
    by (simp add: seq_Sup_distr)
  finally show ?thesis
    by (simp add: UINF_as_Sup_collect)
qed

lemma mu_csp_form_NSRD [closure]:
  fixes P :: "('s, 't::size_trace,'\<alpha>) hrel_rsp"
  assumes "P is NSRD" "P is Productive"
  shows "(\<mu> X \<bullet> P ;; SRD(X)) is NSRD"
  by (simp add: mu_csp_form_1 assms closure)

lemma mu_csp_form_1':
  fixes P :: "('s, 't::size_trace,'\<alpha>) hrel_rsp"
  assumes "P is NSRD" "P is Productive"
  shows "(\<mu> X \<bullet> P ;; SRD(X)) = (P ;; P\<^sup>\<star>) ;; Miracle"
proof -
  have "(\<mu> X \<bullet> P ;; SRD(X)) = (\<Sqinter> i\<in>UNIV \<bullet> P ;; P \<^bold>^ i) ;; Miracle"
    by (simp add: mu_csp_form_1 assms closure ustar_def)
  also have "... = (P ;; P\<^sup>\<star>) ;; Miracle"
    by (simp only: seq_UINF_distl[THEN sym], simp add: ustar_def)
  finally show ?thesis .
qed

declare upred_semiring.power_Suc [simp del]

end


theory mbc_properties
  imports embedding
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Properties of paraconsistent logic mbC \<close>

abbreviation neg :: "wo\<Rightarrow>wo" ("\<^bold>\<not>_" [54] 55) where "\<^bold>\<not>\<phi> \<equiv> \<^bold>\<not>\<^sup>p\<phi>" (* negation is paraconsistent*)
abbreviation circ :: "wo\<Rightarrow>wo" ("\<^bold>\<circ>_" [54] 55) where "\<^bold>\<circ>\<phi> \<equiv> \<^bold>\<circ>\<^sup>m\<^sup>b\<^sup>c\<phi>" (* logic is (R)mbC *)

(* (1) *)
lemma "[a \<^bold>\<and> \<^bold>\<not>a \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>\<^bold>\<circ>a]" by simp
lemma "[\<^bold>\<not>\<^bold>\<circ>a \<^bold>\<turnstile>\<^sub>l a \<^bold>\<and> \<^bold>\<not>a]" nitpick oops (* countermodel found *)

(* (2) *)
lemma "[\<^bold>\<circ>a \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>(a \<^bold>\<and> \<^bold>\<not>a)]" by simp
lemma "[\<^bold>\<not>(a \<^bold>\<and> \<^bold>\<not>a) \<^bold>\<turnstile>\<^sub>l \<^bold>\<circ>a]" nitpick oops (* countermodel found *)

(* (3) *)
lemma "[\<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile>\<^sub>l a \<^bold>\<or> b]" by blast
lemma "[a \<^bold>\<or> b \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>a \<^bold>\<rightarrow> b]" nitpick oops (* countermodel found *)

(* (4) *)
lemma "[\<^bold>\<circ>a, a \<^bold>\<or> b  \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>a \<^bold>\<rightarrow> b]" by simp

(* (5) *)
lemma "[a \<^bold>\<rightarrow> b \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" nitpick oops (* countermodel found *)
lemma "[\<^bold>\<circ>b, a \<^bold>\<rightarrow> b \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" by blast

(* (6) *)
lemma "[a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile>\<^sub>l b \<^bold>\<rightarrow> \<^bold>\<not>a]" nitpick oops (* countermodel found *)
lemma "[\<^bold>\<circ>b, a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile>\<^sub>l b \<^bold>\<rightarrow> \<^bold>\<not>a]" by blast

(* (7) *)
lemma "[\<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>b \<^bold>\<rightarrow> a]" nitpick oops (* countermodel found *)
lemma "[\<^bold>\<circ>b, \<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile>\<^sub>l \<^bold>\<not>b \<^bold>\<rightarrow> a]" by blast

(* (8) *)
lemma "[\<^bold>\<not>a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile>\<^sub>l b \<^bold>\<rightarrow> a]" nitpick oops (* countermodel found *)
lemma "[\<^bold>\<circ>b, \<^bold>\<not>a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile>\<^sub>l b \<^bold>\<rightarrow> a]" by blast

end


(* Title:  Euler.thy
   Author: Lars Noschinski, TU München
*)
theory Euler imports
  Arc_Walk
  Digraph_Component
  Digraph_Isomorphism
begin

section {* Euler Trails in Digraphs *}

text {*
  In this section we prove the well-known theorem characterizing the
  existence of an Euler Trail in an directed graph
*}

subsection {* Trails and Euler Trails *}

definition (in pre_digraph) euler_trail :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "euler_trail u p v \<equiv> trail u p v \<and> set p = arcs G \<and> set (awalk_verts u p) = verts G"

context wf_digraph begin

(* XXX move; notused*)

(* XXX move; notused*)
lemma (in fin_digraph) trails_finite: "finite {p. \<exists>u v. trail u p v}"
proof -
  have "{p. \<exists>u v. trail u p v} \<subseteq> {p. distinct p \<and> set p \<subseteq> arcs G}"
    by (auto simp: trail_def)
  with finite_arcs finite_distinct show ?thesis by (blast intro: finite_subset)
qed
(* XXX: simplify apath_finite proof? *)

lemma rotate_awalkE:
  assumes "awalk u p u" "w \<in> set (awalk_verts u p)"
  obtains q r where "p = q @ r" "awalk w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
proof -
  from assms obtain q r where A: "p = q @ r" and A': "awalk u q w" "awalk w r u"
    by atomize_elim (rule awalk_decomp)

  then have B: "awalk w (r @ q) w" by auto

  have C: "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
    using `awalk u p u` A A' by (auto simp: set_awalk_verts_append)

  from A B C show ?thesis ..
qed

lemma rotate_trailE:
  assumes "trail u p u" "w \<in> set (awalk_verts u p)"
  obtains q r where "p = q @ r" "trail w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
  using assms by - (rule rotate_awalkE[where u=u and p=p and w=w], auto simp: trail_def)

lemma rotate_trailE':
  assumes "trail u p u" "w \<in> set (awalk_verts u p)"
  obtains q where "trail w q w" "set q = set p" "set (awalk_verts w q) = set (awalk_verts u p)"
proof -
  from assms obtain q r where "p = q @ r" "trail w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
    by (rule rotate_trailE)
  then have "set (r @ q) = set p" by auto
  show ?thesis by (rule that) fact+
qed

lemma sym_reachableI_in_awalk:
  assumes walk: "awalk u p v" and
    w1: "w1 \<in> set (awalk_verts u p)" and w2: "w2 \<in> set (awalk_verts u p)"
  shows "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2"
proof -
  from walk w1 obtain q r where "p = q @ r" "awalk u q w1" "awalk w1 r v"
    by (atomize_elim) (rule awalk_decomp)
  then have w2_in: "w2 \<in> set (awalk_verts u q) \<union> set (awalk_verts w1 r)"
    using w2 by (auto simp: set_awalk_verts_append)

  show ?thesis
  proof cases
    assume A: "w2 \<in> set (awalk_verts u q)"
    obtain s where "awalk w2 s w1"
      using awalk_decomp[OF `awalk u q w1` A] by blast
    then have "w2 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w1"
      by (intro reachable_awalkI reachable_mk_symmetricI)
    with symmetric_mk_symmetric show ?thesis by (rule symmetric_reachable)
  next
    assume "w2 \<notin> set (awalk_verts u q)"
    then have A: "w2 \<in> set (awalk_verts w1 r)"
      using w2_in by blast
    obtain s where "awalk w1 s w2"
      using awalk_decomp[OF `awalk w1 r v` A] by blast
    then show "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2"
      by (intro reachable_awalkI reachable_mk_symmetricI)
  qed
qed

lemma euler_imp_connected:
  assumes "euler_trail u p v" shows "connected G"
proof -
  { have "verts G \<noteq> {}" using assms unfolding euler_trail_def trail_def by auto }
  moreover
  { fix w1 w2 assume "w1 \<in> verts G" "w2 \<in> verts G"
    then have "awalk u p v " "w1 \<in> set (awalk_verts u p)" "w2 \<in> set (awalk_verts u p)"
      using assms by (auto simp: euler_trail_def trail_def)
    then have "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2" by (rule sym_reachableI_in_awalk) }
  ultimately show "connected G" by (rule connectedI)
qed

end

subsection {* Arc Balance of Walks *}

context pre_digraph begin

(* XXX change order of arguments? *)
definition arc_set_balance :: "'a \<Rightarrow> 'b set \<Rightarrow> int" where
  "arc_set_balance w A = int (card (in_arcs G w \<inter> A)) - int (card (out_arcs G w \<inter> A))"

definition  arc_set_balanced :: "'a \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> bool" where
  "arc_set_balanced u A v \<equiv>
      if u = v then (\<forall>w \<in> verts G. arc_set_balance w A = 0)
      else (\<forall>w \<in> verts G. (w \<noteq> u \<and> w \<noteq> v) \<longrightarrow> arc_set_balance w A = 0)
        \<and> arc_set_balance u A = -1
        \<and> arc_set_balance v A = 1"

abbreviation arc_balance :: "'a \<Rightarrow> 'b awalk \<Rightarrow> int" where
  "arc_balance w p \<equiv> arc_set_balance w (set p)"

abbreviation arc_balanced :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "arc_balanced u p v \<equiv> arc_set_balanced u (set p) v"

lemma arc_set_balanced_all:
  "arc_set_balanced u (arcs G) v =
      (if u = v then (\<forall>w \<in> verts G. in_degree G w = out_degree G w)
      else (\<forall>w \<in> verts G. (w \<noteq> u \<and> w \<noteq> v) \<longrightarrow> in_degree G w = out_degree G w)
        \<and> in_degree G u + 1 = out_degree G u
        \<and> out_degree G v + 1 = in_degree G v)"
  unfolding arc_set_balanced_def arc_set_balance_def in_degree_def out_degree_def by auto

end

context wf_digraph begin

(* XXX tune assumption? e \<notin> set es oder so? *)
lemma arc_balance_Cons:
  assumes "trail u (e # es) v"
  shows "arc_set_balance w (insert e (set es)) = arc_set_balance w {e} + arc_balance w es"
proof -
  from assms have "e \<notin> set es" "e \<in> arcs G" by (auto simp: trail_def)

  with `e \<notin> set es` show ?thesis
    apply (cases "w = tail G e")
    apply (case_tac [!] "w = head G e")
    apply (auto simp: arc_set_balance_def)
    done
qed

lemma arc_balancedI_trail:
  assumes "trail u p v" shows "arc_balanced u p v"
  using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by (auto simp: arc_set_balanced_def arc_set_balance_def trail_def)
next
  case (Cons e es)
  then have "arc_balanced (head G e) es v" "u = tail G e" "e \<in> arcs G"
    by (auto simp: awalk_Cons_iff trail_def)
  moreover
  have "\<And>w. arc_balance w [e] = (if w = tail G e \<and> tail G e \<noteq> head G e then -1
      else if w = head G e \<and> tail G e \<noteq> head G e then 1 else 0)"
      using `e \<in> _` by (case_tac "w = tail G e") (auto simp: arc_set_balance_def)
  ultimately show ?case
    by (auto simp: arc_set_balanced_def arc_balance_Cons[OF `trail u _ _`])
qed

lemma trail_arc_balanceE:
  assumes "trail u p v"
  obtains "\<And>w. \<lbrakk> u = v \<or> (w \<noteq> u \<and> w \<noteq> v); w \<in> verts G \<rbrakk>
      \<Longrightarrow> arc_balance w p = 0"
    and "\<lbrakk> u \<noteq> v \<rbrakk> \<Longrightarrow> arc_balance u p = - 1"
    and "\<lbrakk> u \<noteq> v \<rbrakk> \<Longrightarrow> arc_balance v p = 1"
  using arc_balancedI_trail[OF assms] unfolding arc_set_balanced_def by (intro that) (metis,presburger+)

end

subsection {* Closed Euler Trails *}

lemma (in wf_digraph) awalk_vertex_props:
  assumes "awalk u p v" "p \<noteq> []"
  assumes "\<And>w. w \<in> set (awalk_verts u p) \<Longrightarrow> P w \<or> Q w"
  assumes "P u" "Q v"
  shows "\<exists>e \<in> set p. P (tail G e) \<and> Q (head G e)"
  using assms(2,1,3-)
proof (induct p arbitrary: u rule: list_nonempty_induct)
  case (cons e es)
  show ?case
  proof (cases "P (tail G e) \<and> Q (head G e)")
    case False
    then have "P (head G e) \<or> Q (head G e)"
      using cons.prems(1) cons.prems(2)[of "head G e"]
      by (auto simp: awalk_Cons_iff set_awalk_verts)
    then have "P (tail G e) \<and> P (head G e)"
      using False using cons.prems(1,3) by auto

    then have "\<exists>e \<in> set es. P (tail G e) \<and> Q (head G e)"
      using cons by (auto intro: cons simp: awalk_Cons_iff)
    then show ?thesis by auto
  qed auto
qed (simp add: awalk_simps)

lemma (in wf_digraph) connected_verts:
  assumes "connected G" "arcs G \<noteq> {}"
  shows "verts G = tail G ` arcs G \<union> head G ` arcs G"
proof -
  { assume "verts G = {}" then have ?thesis by (auto dest: tail_in_verts) }
  moreover
  { assume "\<exists>v. verts G = {v}"
    then obtain v where "verts G = {v}" by (auto simp: card_Suc_eq)
    moreover
    with `arcs G \<noteq> {}` obtain e where "e \<in> arcs G" "tail G e = v" "head G e = v"
      by (auto dest: tail_in_verts head_in_verts)
    moreover have "tail G ` arcs G \<union> head G ` arcs G \<subseteq> verts G" by auto
    ultimately have ?thesis by auto }
  moreover
  { assume A: "\<exists>u v. u \<in> verts G \<and> v \<in> verts G \<and> u \<noteq> v"
    { fix u assume "u \<in> verts G"

      interpret S: pair_wf_digraph "mk_symmetric G" by rule
      from A obtain v where "v \<in> verts G" "u \<noteq> v" by blast
      then obtain p where "S.awalk u p v"
        using `connected G` `u \<in> verts G` by (auto elim: connected_awalkE)
      with `u \<noteq> v` obtain e where "e \<in> parcs (mk_symmetric G)" "fst e = u"
        by (metis S.awalk_Cons_iff S.awalk_empty_ends list_exhaust2)
      then obtain e' where "tail G e' = u \<or> head G e' = u" "e' \<in> arcs G"
        by (force simp: parcs_mk_symmetric)
      then have "u \<in> tail G ` arcs G \<union> head G `arcs G" by auto }
    then have ?thesis by auto }
  ultimately show ?thesis by blast
qed

lemma (in wf_digraph) connected_arcs_empty:
  assumes "connected G" "arcs G = {}" "verts G \<noteq> {}" obtains v where "verts G = {v}"
proof (atomize_elim, rule ccontr)
  assume A: "\<not> (\<exists>v. verts G = {v})"

  interpret S: pair_wf_digraph "mk_symmetric G" by rule

  from `verts G \<noteq> {}` obtain u where "u \<in> verts G" by auto
  with A obtain v where "v \<in> verts G" "u \<noteq> v" by auto

  from `connected G` `u \<in> verts G` `v \<in> verts G`
  obtain p where "S.awalk u p v"
    using `connected G` `u \<in> verts G` by (auto elim: connected_awalkE)
  with `u \<noteq> v` obtain e where "e \<in> parcs (mk_symmetric G)"
    by (metis S.awalk_Cons_iff S.awalk_empty_ends list_exhaust2)
  with `arcs G = {}` show False
    by (auto simp: parcs_mk_symmetric)
qed

lemma (in wf_digraph) euler_trail_conv_connected:
  assumes "connected G"
  shows "euler_trail u p v \<longleftrightarrow> trail u p v \<and> set p = arcs G" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?R show ?L
  proof cases
    assume "p = []" with assms `?R` show ?thesis
      by (auto simp: euler_trail_def trail_def awalk_def elim: connected_arcs_empty)
  next
    assume "p \<noteq> []" then have "arcs G \<noteq> {}" using `?R` by auto
    with assms `?R` `p \<noteq> []` show ?thesis
      by (auto simp: euler_trail_def trail_def set_awalk_verts_not_Nil connected_verts)
  qed
qed (simp add: euler_trail_def)

lemma (in wf_digraph) awalk_connected:
  assumes "connected G" "awalk u p v" "set p \<noteq> arcs G"
  shows "\<exists>e. e \<in> arcs G - set p \<and> (tail G e \<in> set (awalk_verts u p) \<or> head G e \<in> set (awalk_verts u p))"
proof (rule ccontr)
  assume A: "\<not>?thesis"

  obtain e where "e \<in> arcs G - set p"
    using assms by (auto simp: trail_def)
  with A have "tail G e \<notin> set (awalk_verts u p)" "tail G e \<in> verts G"
    by auto

  interpret S: pair_wf_digraph "mk_symmetric G" ..

  have "u \<in> verts G" using `awalk u p v` by (auto simp: awalk_hd_in_verts)
  with `tail G e \<in> _` and `connected G`
  obtain q where q: "S.awalk u q (tail G e)"
    by (auto elim: connected_awalkE)

  have "u \<in> set (awalk_verts u p)"
    using `awalk u p v` by (auto simp: set_awalk_verts)

  have "q \<noteq> []" using `u \<in> set _` `tail G e \<notin> _` q by auto

  have "\<exists>e \<in> set q. fst e \<in> set (awalk_verts u p) \<and> snd e \<notin> set (awalk_verts u p)"
    by (rule S.awalk_vertex_props[OF `S.awalk _ _ _` `q \<noteq> []`]) (auto simp: `u \<in> set _` `tail G e \<notin> _`)
  then obtain se' where se': "se' \<in> set q" "fst se' \<in> set (awalk_verts u p)" "snd se' \<notin> set (awalk_verts u p)"
    by auto

  from se' have "se' \<in> parcs (mk_symmetric G)" using q by auto
  then obtain e' where "e' \<in> arcs G" "(tail G e' = fst se' \<and> head G e' = snd se') \<or> (tail G e' = snd se' \<and> head G e' = fst se')"
    by (auto simp: parcs_mk_symmetric)
  moreover
  then have "e' \<notin> set p" using se' `awalk u p v`
    by (auto dest: awalk_verts_arc2 awalk_verts_arc1)
  ultimately show False using se'
    using A by auto
qed

lemma (in wf_digraph) trail_connected:
  assumes "connected G" "trail u p v" "set p \<noteq> arcs G"
  shows "\<exists>e. e \<in> arcs G - set p \<and> (tail G e \<in> set (awalk_verts u p) \<or> head G e \<in> set (awalk_verts u p))"
  using assms by (intro awalk_connected) (auto simp: trail_def)

theorem (in fin_digraph) closed_euler1:
  assumes con: "connected G"
  assumes deg: "\<And>u. u \<in> verts G \<Longrightarrow> in_degree G u = out_degree G u"
  shows "\<exists>u p. euler_trail u p u"
proof -
  from con obtain u where "u \<in> verts G" by (auto simp: connected_def strongly_connected_def)
  then have "trail u [] u" by (auto simp: trail_def awalk_simps)
  moreover
  { fix u p v assume  "trail u p v"
    then have "\<exists>u' p' v'. euler_trail u' p' v'"
    proof (induct "card (arcs G) - length p" arbitrary: u p v)
      case 0
      then have "u \<in> verts G" by (auto simp: trail_def)

      have "set p \<subseteq> arcs G" using `trail u p v` by (auto simp: trail_def)
      with 0 have "set p = arcs G"
        by (auto simp: trail_def distinct_card[symmetric] card_seteq)
      then have "euler_trail u p v"
        using 0 by (simp add: euler_trail_conv_connected[OF con])
      then show ?case by blast
    next
      case (Suc n)
      then have neq: "set p \<noteq> arcs G" "u \<in> verts G"
        by (auto simp: trail_def distinct_card[symmetric])

      show ?case
      proof (cases "u = v")
        assume "u \<noteq> v"
        then have "arc_balance u p = -1"
          using Suc neq by (auto elim: trail_arc_balanceE)
        then have "card (in_arcs G u \<inter> set p) < card (out_arcs G u \<inter> set p)"
          unfolding arc_set_balance_def by auto
        also have "\<dots> \<le> card (out_arcs G u)"
          by (rule card_mono) auto
        finally have "card (in_arcs G u \<inter> set p) < card (in_arcs G u)"
          using deg[OF `u \<in> _`] unfolding out_degree_def in_degree_def by simp
        then have "in_arcs G u - set p \<noteq> {}"
          by (auto dest: card_psubset[rotated 2])
        then obtain a where "a \<in> arcs G" "head G a = u" "a \<notin> set p"
          by (auto simp: in_arcs_def)
        then have *: "trail (tail G a) (a # p) v"
          using Suc by (auto simp: trail_def awalk_simps)
        then show ?thesis
          using Suc by (intro Suc) auto
      next
        assume "u = v"
        with neq con Suc
        obtain a where a_in: "a \<in> arcs G - set p"
            and a_end: "(tail G a \<in> set (awalk_verts u p) \<or> head G a \<in> set (awalk_verts u p))"
          by (atomize_elim) (rule trail_connected)
        have "trail u p u" using Suc `u = v` by simp
        show ?case
        proof (cases "tail G a \<in> set (awalk_verts u p)")
          case True
          with `trail u p u` obtain q where q: "set p = set q" "trail (tail G a) q (tail G a)"
            by (rule rotate_trailE') blast
          with True a_in have *: "trail (tail G a) (q @ [a]) (head G a)"
            by (fastforce simp: trail_def awalk_simps )
          moreover
          from q Suc have "length q = length p"
            by (simp add: trail_def distinct_card[symmetric])
          ultimately
          show ?thesis using Suc  by (intro Suc) auto
        next
          case False
          with a_end have "head G a \<in> set (awalk_verts u p)" by blast
          with `trail u p u` obtain q where q: "set p = set q" "trail (head G a) q (head G a)"
            by (rule rotate_trailE') blast
          with False a_in have *: "trail (tail G a) (a # q) (head G a)"
            by (fastforce simp: trail_def awalk_simps )
          moreover
          from q Suc have "length q = length p"
            by (simp add: trail_def distinct_card[symmetric])
          ultimately
          show ?thesis using Suc by (intro Suc) auto
        qed
      qed
    qed }
  ultimately obtain u p v where et: "euler_trail u p v" by blast
  moreover
  have "u = v"
  proof -
    have "arc_balanced u p v"
      using `euler_trail u p v` by (auto simp: euler_trail_def dest: arc_balancedI_trail)
    then show ?thesis
      using `euler_trail u p v` deg
      by (auto simp add: euler_trail_def trail_def arc_set_balanced_all split: split_if_asm)
  qed
  ultimately show ?thesis by blast
qed

lemma (in wf_digraph) closed_euler_imp_eq_degree:
  assumes "euler_trail u p u"
  assumes "v \<in> verts G"
  shows "in_degree G v = out_degree G v"
proof -
  from assms have "arc_balanced u p u" "set p = arcs G"
    unfolding euler_trail_def by (auto dest: arc_balancedI_trail)
  with assms have "arc_balance v p = 0"
    unfolding arc_set_balanced_def by auto
  moreover
  from `set p = _` have "in_arcs G v \<inter> set p = in_arcs G v" "out_arcs G v \<inter> set p = out_arcs G v"
    by (auto intro: in_arcs_in_arcs out_arcs_in_arcs)
  ultimately
  show ?thesis unfolding arc_set_balance_def in_degree_def out_degree_def by auto
qed

theorem (in fin_digraph) closed_euler2:
  assumes "euler_trail u p u"
  shows "connected G"
    and "\<And>u. u \<in> verts G \<Longrightarrow> in_degree G u = out_degree G u" (is "\<And>u. _ \<Longrightarrow> ?eq_deg u")
proof -
  from assms show "connected G" by (rule euler_imp_connected)
next
  fix v assume A: "v \<in> verts G"
  with assms show "?eq_deg v" by (rule closed_euler_imp_eq_degree)
qed

corollary (in fin_digraph) closed_euler:
  "(\<exists>u p. euler_trail u p u) \<longleftrightarrow> connected G \<and> (\<forall>u \<in> verts G. in_degree G u = out_degree G u)"
  by (auto dest: closed_euler1 closed_euler2)

subsection {* Open euler trails *}

text {*
  Intuitively, a graph has an open euler trail if and only if it is possible to add
  an arc such that the resulting graph has a closed euler trail. However, this is
  not true in our formalization, as the arc type @{typ 'b} might be finite:

  Consider for example the graph
  @{term "\<lparr> verts = {0,1}, arcs = {()}, tail = \<lambda>_. 0, head = \<lambda>_. 1 \<rparr>"}. This graph
  obviously has an open euler trail, but we cannot add another arc, as we already
  exhausted the universe.

  However, for each @{term "fin_digraph G"} there exist an isomorphic graph
  @{term H} with arc type @{typ "'a \<times> nat \<times> 'a"}. Hence, we first characterize
  the existence of euler trail for the infinite arc type @{typ "'a \<times> nat \<times> 'a"}
  and transfer that result back to arbitrary arc types.
*}

lemma open_euler_infinite_label:
  fixes G :: "('a, 'a \<times> nat \<times> 'a) pre_digraph"
  assumes "fin_digraph G"
  assumes [simp]: "tail G = fst" "head G = snd o snd"
  assumes con: "connected G"
  assumes uv: "u \<in> verts G" "v \<in> verts G"
  assumes deg: "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
  assumes deg_in: "in_degree G u + 1 = out_degree G u"
  assumes deg_out: "out_degree G v + 1 = in_degree G v"
  shows "\<exists>p. pre_digraph.euler_trail G u p v"
proof -
  def [simp]: label \<equiv> "fst o snd :: 'a \<times> nat \<times> 'a \<Rightarrow> nat"

  interpret fin_digraph G by fact

  have "finite (label ` arcs G)" by auto
  moreover have "\<not>finite (UNIV :: nat set)" by blast
  ultimately obtain l where "l \<notin> label ` arcs G" by atomize_elim (rule ex_new_if_finite)

  from deg_in deg_out have "u \<noteq> v" by auto

  let ?e = "(v,l,u)"

  have e_notin:"?e \<notin> arcs G"
    using `l \<notin> _` by (auto simp: image_def)

  let ?H = "add_arc ?e"
    -- "We define a graph which has an closed euler trail"

  have [simp]: "verts ?H = verts G" using uv by simp
  have [intro]: "\<And>a. compatible (add_arc a) G" by (simp add: compatible_def)

  interpret H: fin_digraph "add_arc a" for a
    where "tail (add_arc a) = tail G" and "head (add_arc a) = head G"
      and "pre_digraph.cas (add_arc a) = cas"
      and "pre_digraph.awalk_verts (add_arc a) = awalk_verts"
      by unfold_locales (auto dest: wellformed intro: compatible_cas compatible_awalk_verts
          simp: verts_add_arc_conv)

  have "\<exists>u p. H.euler_trail ?e u p u"
  proof (rule H.closed_euler1)
    show "connected ?H"
    proof (rule H.connectedI)
      interpret sH: pair_fin_digraph "mk_symmetric ?H" ..
      fix u v assume "u \<in> verts ?H" "v \<in> verts ?H"
      with con have "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v" by (auto simp: connected_def)
      moreover
      have "subgraph G ?H" by (auto simp: subgraph_def) unfold_locales
      ultimately show "u \<rightarrow>\<^sup>*\<^bsub>with_proj (mk_symmetric ?H)\<^esub> v"
        by (blast intro: sH.reachable_mono subgraph_mk_symmetric)
    qed (simp add: verts_add_arc_conv)
  next
    fix w assume "w \<in> verts ?H"
    then show "in_degree ?H w = out_degree ?H w"
      using deg deg_in deg_out e_notin
      apply (cases "w = u")
      apply (case_tac [!] "w = v")
      by (auto simp: in_degree_add_arc_iff out_degree_add_arc_iff)
  qed

  then obtain w p where Het: "H.euler_trail ?e w p w" by blast
  then have "?e \<in> set p" by (auto simp: pre_digraph.euler_trail_def)
  then obtain q r where p_decomp: "p = q @ [?e] @ r"
    by (auto simp: in_set_conv_decomp)
    -- "We show now that removing the additional arc of @{term ?H}
      from p yields an euler trail in G "

  have "euler_trail u (r @ q) v"
  proof (unfold euler_trail_conv_connected[OF con], intro conjI)
    from Het have Ht': "H.trail ?e v (?e # r @ q) v"
      unfolding p_decomp H.euler_trail_def H.trail_def
      by (auto simp: p_decomp H.awalk_Cons_iff)
    then have "H.trail ?e u (r @ q) v" "?e \<notin> set (r @ q)"
      by (auto simp: H.trail_def H.awalk_Cons_iff)
    then show t': "trail u (r @ q) v"
      by (auto simp: trail_def H.trail_def awalk_def H.awalk_def)

    show "set (r @ q) = arcs G"
    proof -
      have "arcs G = arcs ?H - {?e}" using e_notin by auto
      also have "arcs ?H = set p" using Het
        by (auto simp: pre_digraph.euler_trail_def pre_digraph.trail_def)
      finally show ?thesis using `?e \<notin> set _` by (auto simp: p_decomp)
    qed
  qed
  then show ?thesis by blast
qed

context wf_digraph begin

lemma trail_app_isoI:
  assumes t: "trail u p v"
    and hom: "digraph_isomorphism hom"
  shows "pre_digraph.trail (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from t hom have i: "inj_on (iso_arcs hom) (set p)"
     unfolding trail_def digraph_isomorphism_def by (auto dest:subset_inj_on[where A="set p"])
  then have "distinct (map (iso_arcs hom) p) = distinct p"
    by (auto simp: distinct_map dest: inj_onD)
  with t hom show ?thesis
    by (auto simp: pre_digraph.trail_def awalk_app_isoI)
qed

lemma euler_trail_app_isoI:
  assumes t: "euler_trail u p v"
    and hom: "digraph_isomorphism hom"
  shows "pre_digraph.euler_trail (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
proof -
  from t have "awalk u p v" by (auto simp: euler_trail_def trail_def)
  with assms show ?thesis
    by (simp add: pre_digraph.euler_trail_def trail_app_isoI awalk_verts_app_iso_eq)
qed

end

context fin_digraph begin

(* XXX: We can get rid of "u \<in> verts G" "v \<in> verts G" here and in @{thm open_euler_infinite_label} *)
theorem open_euler1:
  assumes "connected G"
  assumes "u \<in> verts G" "v \<in> verts G"
  assumes "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
  assumes "in_degree G u + 1 = out_degree G u"
  assumes "out_degree G v + 1 = in_degree G v"
  shows "\<exists>p. euler_trail u p v"
proof -
  obtain f and n :: nat where "f ` arcs G = {i. i < n}"
      and i: "inj_on f (arcs G)"
    by atomize_elim (rule finite_imp_inj_to_nat_seg, auto)

  def iso_f \<equiv> "\<lparr> iso_verts = id, iso_arcs = (\<lambda>a. (tail G a, f a, head G a)),
    head = snd o snd, tail = fst \<rparr>"
  have [simp]: "iso_verts iso_f = id" "iso_head iso_f = snd o snd" "iso_tail iso_f = fst"
    unfolding iso_f_def by auto
  have di_iso_f: "digraph_isomorphism iso_f" unfolding digraph_isomorphism_def iso_f_def
    by (auto intro: inj_onI dest: inj_onD[OF i])

  let ?iso_g = "inv_iso iso_f"
  have [simp]: "\<And>u. u \<in> verts G \<Longrightarrow> iso_verts ?iso_g u = u"
    by (auto simp: inv_iso_def fun_eq_iff the_inv_into_f_eq)

  let ?H = "app_iso iso_f G"
  interpret H: fin_digraph ?H using di_iso_f ..

  have "\<exists>p. H.euler_trail u p v"
    using di_iso_f assms i
    by (intro open_euler_infinite_label) (auto simp: connectedI_app_iso app_iso_eq)
  then obtain p where Het: "H.euler_trail u p v" by blast

  have "pre_digraph.euler_trail (app_iso ?iso_g ?H) (iso_verts ?iso_g u) (map (iso_arcs ?iso_g) p) (iso_verts ?iso_g v)"
    using Het by (intro H.euler_trail_app_isoI digraph_isomorphism_invI di_iso_f)
  then show ?thesis using di_iso_f `u \<in> _` `v \<in> _` by simp rule
qed

theorem open_euler2:
  assumes et: "euler_trail u p v" and "u \<noteq> v"
  shows "connected G \<and>
    (\<forall>w \<in> verts G. u \<noteq> w \<longrightarrow> v \<noteq> w \<longrightarrow> in_degree G w = out_degree G w) \<and>
    in_degree G u + 1 = out_degree G u \<and>
    out_degree G v + 1 = in_degree G v"
proof -
  from et have *: "trail u p v" "u \<in> verts G" "v \<in> verts G"
    by (auto simp: euler_trail_def trail_def awalk_hd_in_verts)

  from et have [simp]: "\<And>u. card (in_arcs G u \<inter> set p) = in_degree G u"
      "\<And>u. card (out_arcs G u \<inter> set p) = out_degree G u"
    by (auto simp: in_degree_def out_degree_def euler_trail_def intro: arg_cong[where f=card])

  from assms * show ?thesis
    by (auto simp: arc_set_balance_def elim: trail_arc_balanceE
        intro: euler_imp_connected)
qed

corollary open_euler:
  "(\<exists>u p v. euler_trail u p v \<and> u \<noteq> v) \<longleftrightarrow>
    connected G \<and> (\<exists>u v. u \<in> verts G \<and> v \<in> verts G \<and>
      (\<forall>w \<in> verts G. u \<noteq> w \<longrightarrow> v \<noteq> w \<longrightarrow> in_degree G w = out_degree G w) \<and>
      in_degree G u + 1 = out_degree G u \<and>
      out_degree G v + 1 = in_degree G v)" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then obtain u p v where *: "euler_trail u p v" "u \<noteq> v"
    by auto
  then have "u \<in> verts G" "v \<in> verts G"
    by (auto simp: euler_trail_def trail_def awalk_hd_in_verts)
  then show ?R using open_euler2[OF *] by blast
next
  assume ?R
  then obtain u v where *:
    "connected G" "u \<in> verts G" "v \<in> verts G"
    "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
    "in_degree G u + 1 = out_degree G u"
    "out_degree G v + 1 = in_degree G v"
    by blast
  then have "u \<noteq> v" by auto
  from * show ?L by (metis open_euler1 `u \<noteq> v`)
qed

end

end