section {* Finite sets: extra functions and properties *}

theory FSet_extra
imports
  "~~/src/HOL/Library/FSet"
  "~~/src/HOL/Library/Countable_Set_Type"
begin

setup_lifting type_definition_fset

notation fempty ("\<lbrace>\<rbrace>")
notation fset ("\<langle>_\<rangle>\<^sub>f")
notation fminus (infixl "-\<^sub>f" 65)

syntax
  "_FinFset" :: "args => 'a fset"    ("\<lbrace>(_)\<rbrace>")

translations
  "\<lbrace>x, xs\<rbrace>" == "CONST finsert x \<lbrace>xs\<rbrace>"
  "\<lbrace>x\<rbrace>" == "CONST finsert x \<lbrace>\<rbrace>"

term "fBall"

syntax
  "_fBall" :: "pttrn => 'a fset => bool => bool" ("(3\<forall> _|\<in>|_./ _)" [0, 0, 10] 10)
  "_fBex"  :: "pttrn => 'a fset => bool => bool" ("(3\<exists> _|\<in>|_./ _)" [0, 0, 10] 10)

translations
  "\<forall> x|\<in>|A. P" == "CONST fBall A (%x. P)"
  "\<exists> x|\<in>|A. P" == "CONST fBex A (%x. P)"

definition FUnion :: "'a fset fset \<Rightarrow> 'a fset" ("\<Union>\<^sub>f_" [90] 90) where
"FUnion xs = Abs_fset (\<Union>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"

definition FInter :: "'a fset fset \<Rightarrow> 'a fset" ("\<Inter>\<^sub>f_" [90] 90) where
"FInter xs = Abs_fset (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"

text {* Finite power set *}

definition FinPow :: "'a fset \<Rightarrow> 'a fset fset" where
"FinPow xs = Abs_fset (Abs_fset ` Pow \<langle>xs\<rangle>\<^sub>f)"

text {* Set of all finite subsets of a set *}

definition Fow :: "'a set \<Rightarrow> 'a fset set" where
"Fow A = {x. \<langle>x\<rangle>\<^sub>f \<subseteq> A}"

declare Abs_fset_inverse [simp]

lemma fset_intro:
  "fset x = fset y \<Longrightarrow> x = y"
  by (simp add:fset_inject)

lemma fset_elim:
  "\<lbrakk> x = y; fset x = fset y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto)

lemma fmember_intro:
  "\<lbrakk> x \<in> fset(xs) \<rbrakk> \<Longrightarrow> x |\<in>| xs"
  by (metis fmember.rep_eq)

lemma fmember_elim:
  "\<lbrakk> x |\<in>| xs; x \<in> fset(xs) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (metis fmember.rep_eq)

lemma fnmember_intro [intro]:
  "\<lbrakk> x \<notin> fset(xs) \<rbrakk> \<Longrightarrow> x |\<notin>| xs"
  by (metis fmember.rep_eq)

lemma fnmember_elim [elim]:
  "\<lbrakk> x |\<notin>| xs; x \<notin> fset(xs) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (metis fmember.rep_eq)

lemma fsubset_intro [intro]:
  "\<langle>xs\<rangle>\<^sub>f \<subseteq> \<langle>ys\<rangle>\<^sub>f \<Longrightarrow> xs |\<subseteq>| ys"
  by (metis less_eq_fset.rep_eq)

lemma fsubset_elim [elim]:
  "\<lbrakk> xs |\<subseteq>| ys; \<langle>xs\<rangle>\<^sub>f \<subseteq> \<langle>ys\<rangle>\<^sub>f \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (metis less_eq_fset.rep_eq)

lemma fBall_intro [intro]:
  "Ball \<langle>A\<rangle>\<^sub>f P \<Longrightarrow> fBall A P"
  by (metis (poly_guards_query) fBallI fmember.rep_eq)

lemma fBall_elim [elim]:
  "\<lbrakk> fBall A P; Ball \<langle>A\<rangle>\<^sub>f P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (metis fBallE fmember.rep_eq)

lift_definition finset :: "'a list \<Rightarrow> 'a fset" is set ..

context linorder
begin

lemma sorted_list_of_set_inj:
  "\<lbrakk> finite xs; finite ys; sorted_list_of_set xs = sorted_list_of_set ys \<rbrakk>
   \<Longrightarrow> xs = ys"
  apply (simp add:sorted_list_of_set_def)
  apply (induct xs rule:finite_induct)
  apply (induct ys rule:finite_induct)
  apply (simp_all)
  apply (metis finite.insertI insert_not_empty sorted_list_of_set_def sorted_list_of_set_empty sorted_list_of_set_eq_Nil_iff)
  apply (metis finite.insertI finite_list set_remdups set_sort sorted_list_of_set_def sorted_list_of_set_sort_remdups)
done

definition flist :: "'a fset \<Rightarrow> 'a list" where
"flist xs = sorted_list_of_set (fset xs)"

lemma flist_inj: "inj flist"
  apply (simp add:flist_def inj_on_def)
  apply (clarify)
  apply (subgoal_tac "fset x = fset y")
  apply (simp add:fset_inject)
  apply (rule sorted_list_of_set_inj, simp_all)
done

lemma flist_props [simp]:
  "sorted (flist xs)"
  "distinct (flist xs)"
  by (simp_all add:flist_def)

lemma flist_empty [simp]:
  "flist \<lbrace>\<rbrace> = []"
  by (simp add:flist_def)

lemma flist_inv [simp]: "finset (flist xs) = xs"
  by (simp add:finset_def flist_def fset_inverse)

lemma flist_set [simp]: "set (flist xs) = fset xs"
  by (simp add:finset_def flist_def fset_inverse)

lemma fset_inv [simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> flist (finset xs) = xs"
  apply (simp add:finset_def flist_def fset_inverse)
  apply (metis finset.abs_eq finset.rep_eq local.sorted_list_of_set_sort_remdups local.sorted_sort_id remdups_id_iff_distinct)
done

lemma fcard_flist:
  "fcard xs = length (flist xs)"
  apply (simp add:fcard_def)
  apply (fold flist_set)
  apply (unfold distinct_card[OF flist_props(2)])
  apply (rule refl)
done

lemma flist_nth:
  "i < fcard vs \<Longrightarrow> flist vs ! i |\<in>| vs"
  apply (simp add: fmember_def flist_def fcard_def)
  apply (metis distinct_card finite_fset nth_mem sorted_list_of_set)
done

definition fmax :: "'a fset \<Rightarrow> 'a" where
"fmax xs = (if (xs = \<lbrace>\<rbrace>) then undefined else last (flist xs))"

end

definition flists :: "'a fset \<Rightarrow> 'a list set" where
"flists A = {xs. distinct xs \<and> finset xs = A}"

lemma flists_nonempty: "\<exists> xs. xs \<in> flists A"
  apply (simp add: flists_def)
  apply (metis Abs_fset_cases Abs_fset_inverse finite_distinct_list finite_fset finset.rep_eq)
done

lemma flists_elem_uniq: "\<lbrakk> x \<in> flists A; x \<in> flists B \<rbrakk> \<Longrightarrow> A = B"
  by (simp add: flists_def)

definition flist_arb :: "'a fset \<Rightarrow> 'a list" where
"flist_arb A = (SOME xs. xs \<in> flists A)"

lemma flist_arb_distinct [simp]: "distinct (flist_arb A)"
  by (metis (mono_tags) flist_arb_def flists_def flists_nonempty mem_Collect_eq someI_ex)

lemma flist_arb_inv [simp]: "finset (flist_arb A) = A"
  by (metis (mono_tags) flist_arb_def flists_def flists_nonempty mem_Collect_eq someI_ex)

lemma flist_arb_inj:
  "inj flist_arb"
  by (metis flist_arb_inv injI)

lemma flist_arb_lists: "flist_arb ` Fow A \<subseteq> lists A"
  apply (auto)
  using Fow_def finset.rep_eq apply fastforce
done

lemma countable_Fow:
  fixes A :: "'a set"
  assumes "countable A"
  shows "countable (Fow A)"
proof -
  from assms obtain to_nat_list :: "'a list \<Rightarrow> nat" where "inj_on to_nat_list (lists A)"
    by blast
  thus ?thesis
    apply (simp add: countable_def)
    apply (rule_tac x="to_nat_list \<circ> flist_arb" in exI)
    apply (rule comp_inj_on)
    apply (metis flist_arb_inv inj_on_def)
    apply (simp add: flist_arb_lists subset_inj_on)
  done
qed

definition flub :: "'a fset set \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
"flub A t = (if (\<forall> a\<in>A. a |\<subseteq>| t) then Abs_fset (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else t)"

lemma finite_Union_subsets:
  "\<lbrakk> \<forall> a \<in> A. a \<subseteq> b; finite b \<rbrakk> \<Longrightarrow> finite (\<Union>A)"
  by (metis Sup_le_iff finite_subset)

lemma finite_UN_subsets:
  "\<lbrakk> \<forall> a \<in> A. B a \<subseteq> b; finite b \<rbrakk> \<Longrightarrow> finite (\<Union>a\<in>A. B a)"
  by (metis UN_subset_iff finite_subset)

lemma flub_rep_eq:
  "\<langle>flub A t\<rangle>\<^sub>f = (if (\<forall> a\<in>A. a |\<subseteq>| t) then (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else \<langle>t\<rangle>\<^sub>f)"
  apply (subgoal_tac "(if (\<forall> a\<in>A. a |\<subseteq>| t) then (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else \<langle>t\<rangle>\<^sub>f) \<in> {x. finite x}")
  apply (auto simp add:flub_def Abs_fset_inverse)
  apply (rule finite_UN_subsets[of _ _ "\<langle>t\<rangle>\<^sub>f"])
  apply (auto)
done

definition fglb :: "'a fset set \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
"fglb A t = (if (A = {}) then t else Abs_fset (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f))"

lemma fglb_rep_eq:
  "\<langle>fglb A t\<rangle>\<^sub>f = (if (A = {}) then \<langle>t\<rangle>\<^sub>f else (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f))"
  apply (subgoal_tac "(if (A = {}) then \<langle>t\<rangle>\<^sub>f else (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f)) \<in> {x. finite x}")
  apply (metis Abs_fset_inverse fglb_def)
  apply (auto)
  apply (metis finite_INT finite_fset)
done

lemma FinPow_rep_eq [simp]:
  "fset (FinPow xs) = {ys. ys |\<subseteq>| xs}"
  apply (subgoal_tac "finite (Abs_fset ` Pow \<langle>xs\<rangle>\<^sub>f)")
  apply (auto simp add:Abs_fset_inverse fmember_def FinPow_def)
  apply (subgoal_tac "finite xa")
  apply (auto simp add:Abs_fset_inverse)
  apply (metis finite_fset finite_subset)
  apply (metis (full_types) Pow_iff fset_inverse imageI less_eq_fset.rep_eq)
done

lemma FUnion_rep_eq [simp]:
  "\<langle>\<Union>\<^sub>f xs\<rangle>\<^sub>f = (\<Union>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
  by (simp add:FUnion_def Abs_fset_inverse)

lemma FInter_rep_eq [simp]:
  "xs \<noteq> \<lbrace>\<rbrace> \<Longrightarrow> \<langle>\<Inter>\<^sub>f xs\<rangle>\<^sub>f = (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
  apply (simp add:FInter_def)
  apply (subgoal_tac "finite (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)")
  apply (simp add:Abs_fset_inverse)
  apply (metis (poly_guards_query) bot_fset.rep_eq fglb_rep_eq finite_fset fset_inverse)
done

lemma FUnion_empty [simp]:
  "\<Union>\<^sub>f \<lbrace>\<rbrace> = \<lbrace>\<rbrace>"
  by (auto simp add:FUnion_def fmember_def Abs_fset_inverse)

lemma FinPow_member [simp]:
  "xs |\<in>| FinPow xs"
  by (auto simp add:fmember_def)

lemma FUnion_FinPow [simp]:
  "\<Union>\<^sub>f (FinPow x) = x"
  by (auto simp add:fmember_def less_eq_fset_def)

lemma Fow_mem [iff]: "x \<in> Fow A \<longleftrightarrow> \<langle>x\<rangle>\<^sub>f \<subseteq> A"
  by (auto simp add:Fow_def)

lemma Fow_UNIV [simp]: "Fow UNIV = UNIV"
  by (simp add:Fow_def)

lift_definition FMax :: "('a::linorder) fset \<Rightarrow> 'a" is "Max" .

end


theory prop_52
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  fun append :: "Nat list => Nat list => Nat list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "Nat list => Nat list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster equal2 count append rev *)

lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

lemma lemma_pa [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes rev.simps)

lemma lemma_paa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes rev.simps)

lemma lemma_pab [thy_expl]: "append (rev x5) (rev y5) = rev (append y5 x5)"
by (hipster_induct_schemes rev.simps append.simps list.exhaust)

(*trivial
hipster count*)
(*hipster count append rev equal2*)
lemma lemma_ac [thy_expl]: "rev (rev x1) = x1"
by (hipster_induct_schemes count.simps append.simps rev.simps equal2.simps)

lemma unknown [thy_expl]: "count x (append y z) = count x (append z y)"
oops

lemma unknown [thy_expl]: "count x (rev y) = count x y"
oops

lemma unknown [thy_expl]: "count (count x y) (append z xa) =
count (count x y) (append xa z)"
oops

lemma unknown [thy_expl]: "count (count x y) (append z y) =
count (count x y) (append y z)"
oops

lemma unknown [thy_expl]: "count (count x y) (rev z) = count (count x y) z"
oops

lemma unknown [thy_expl]: "count (count x y) (append y z) =
count (count x y) (append z y)"
oops

lemma unknown [thy_expl]: "count (S x) (append y z) = count (S x) (append z y)"
oops

lemma unknown [thy_expl]: "count Z (append x y) = count Z (append y x)"
oops

lemma unknown [thy_expl]: "count (count x y) (rev y) = count (count x y) y"
oops

lemma unknown [thy_expl]: "count (S x) (rev y) = count (S x) y"
oops

lemma unknown [thy_expl]: "count Z (rev x) = count Z x"
oops

lemma unknown [thy_expl]: "count (count Z x) (append y z) =
count (count Z x) (append z y)"
oops

lemma unknown [thy_expl]: "count (count Z x) (append y x) =
count (count Z x) (append x y)"
oops

lemma unknown [thy_expl]: "count (count Z x) (rev y) = count (count Z x) y"
oops

lemma unknown [thy_expl]: "count (count Z x) (append x y) =
count (count Z x) (append y x)"
oops

lemma unknown [thy_expl]: "count (S Z) (append x y) = count (S Z) (append y x)"
oops

lemma unknown [thy_expl]: "count (count Z x) (rev x) = count (count Z x) x"
oops

lemma unknown [thy_expl]: "count (S Z) (rev x) = count (S Z) x"
oops

(*hipster_cond equal2 count append rev*)
lemma lemma_ad [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps count.simps append.simps)

lemma missed: "equal2 x z \<Longrightarrow> count x (Cons2 z xs) = S (count z xs)"
by (hipster_induct_schemes count.simps equal2.simps)

lemma missed': "\<not> equal2 x z \<Longrightarrow> count x (Cons2 z xs) = count x xs"
by (hipster_induct_simp_metis count.simps equal2.simps)

lemma missed2: "S (count x (append z ys)) = count x (append z (Cons2 x ys))"
by hipster_induct_schemes

lemma aux2: "\<not> equal2 x za \<Longrightarrow> count x (append z ys) = count x (append z (Cons2 za ys))"
by hipster_induct_schemes

(*hipster count append*) (*discovered, though*)
lemma could_not [thy_expl]: "count x (append y z) = count x (append z y)"
by (hipster_induct_schemes equal2.simps count.simps append.simps missed2 aux2)

(*hipster append count*)
(*hipster count rev*)

  theorem x0 :
    "(count n xs) = (count n (rev xs))"
    by (hipster_induct_schemes rev.simps count.simps append.simps)
(*
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Binary Exponentiation\<close>

text \<open>This theory defines the standard algorithm for binary exponentiation, or
  exponentiation by squaring.\<close>
theory Binary_Exponentiation
imports
  Main
begin

declare Euclidean_Rings.divmod_nat_def[termination_simp]

context monoid_mult
begin
fun binary_power :: "'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "binary_power x n = (if n = 0 then 1 else
    let (d,r) = Euclidean_Rings.divmod_nat n 2;
       rec = binary_power (x * x) d in
    if r = 0 then rec else rec * x)"

lemma binary_power[simp]: "binary_power = (^)"
proof (intro ext)
  fix x n
  show "binary_power x n = x ^ n"
  proof (induct x n rule: binary_power.induct)
    case (1 x n)
    show ?case
    proof (cases "n = 0")
      case False
      note IH = 1[OF False]
      obtain d r where n2: "Euclidean_Rings.divmod_nat n 2 = (d,r)" by force
      from Euclidean_Rings.divmod_nat_def[of n 2] n2 have dr: "d = n div 2" "r = n mod 2" by auto
      hence r: "r = 0 \<or> r = 1" by auto
      let ?rec = "binary_power (x * x) d"
      have "binary_power x n = (if r = 0 then ?rec else ?rec * x)"
        unfolding binary_power.simps[of x n] n2 using False by auto
      also have "\<dots> = ?rec * x ^ r" using r by (cases "r = 0", auto)
      also have "?rec = (x * x) ^ d"
        by (rule IH[OF _ refl], simp add: n2)
      also have "\<dots> = x ^ (d + d)" unfolding power_add
        using power2_eq_square power_even_eq power_mult by auto
      also have "\<dots> * x ^ r = x ^ (d + d + r)"
        by (simp add: power_add)
      also have "d + d + r = n" unfolding dr by presburger
      finally show ?thesis .
    qed auto
  qed
qed

lemma binary_power_code_unfold[code_unfold]: "(^) = binary_power"
  by simp

declare binary_power.simps[simp del]
end
end


theory multisets_continued

(* N. Peltier - http://membres-lig.imag.fr/peltier/ *)

imports Main "HOL-Library.Multiset"

begin

subsection \<open>Multisets\<close>

text \<open>We use the Multiset theory provided in Isabelle. We prove some additional
(mostly trivial) lemmata.\<close>

lemma mset_set_inclusion:
  assumes "finite E2"
  assumes "E1 \<subset> E2"
  shows "mset_set E1 \<subset># (mset_set E2)"
proof (rule ccontr)
  let ?s1 = "mset_set E1"
  let ?s2 = "mset_set E2"
  assume "\<not> ?s1 \<subset># ?s2"
  from assms(1) and assms(2) have "finite E1" using finite_subset less_imp_le by auto
  from \<open>\<not> ?s1 \<subset># ?s2\<close> obtain x where "(count ?s1 x > count ?s2 x)" using subseteq_mset_def [of ?s1 ?s2]
    by (metis assms(1) assms(2) finite_set_mset_mset_set finite_subset less_imp_le
      less_le not_le_imp_less subset_mset.le_less)
  from this have "count ?s1 x > 0" by linarith
  from this and \<open>finite E1\<close> have "count ?s1 x = 1" and "x \<in> E1" using subseteq_mset_def by auto
  from this and assms(2) have "x \<in> E2" by auto
  from this and \<open>finite E2\<close> have "count ?s2 x = 1" by auto
  from this and \<open>count ?s1 x = 1\<close> and \<open>(count ?s1 x > count ?s2 x)\<close> show False by auto
qed

lemma mset_ordering_addition:
  assumes "A = B + C"
  shows "B \<subseteq># A"
  using assms by simp

lemma equal_image_mset:
  assumes "\<forall>x \<in> E. (f x) = (g x)"
  shows "{# (f x). x \<in># (mset_set E) #} = {# (g x). x \<in># (mset_set E)  #}"
by (meson assms count_eq_zero_iff count_mset_set(3) image_mset_cong)

lemma multiset_order_inclusion:
  assumes "E \<subset># F"
  assumes "trans r"
  shows "(E,F) \<in> (mult r)"
proof -
  let ?G = "F-E"
  from assms(1) have "F = E +?G"
    by (simp add: subset_mset.add_diff_inverse subset_mset_def)
  from this assms(1) have "?G \<noteq> {#}"
    by fastforce
  have "E = E + {#}" by auto
  from this \<open>F = E +?G\<close>  \<open>?G \<noteq> {#}\<close> assms(2) show ?thesis  using one_step_implies_mult [of ?G "{#}" r E] by auto
qed

lemma multiset_order_inclusion_eq:
  assumes "E \<subseteq># F"
  assumes "trans r"
  shows "E = F \<or> (E,F) \<in> (mult r)"
proof (cases)
  assume "E = F"
  then show ?thesis by auto
next
  assume "E \<noteq> F"
  from this and assms(1) have "E \<subset># F" by auto
  from this assms(2) and multiset_order_inclusion show ?thesis by auto
qed

lemma image_mset_ordering:
  assumes "M1 = {# (f1 u). u \<in># L #}"
  assumes "M2 = {# (f2 u). u \<in># L #}"
  assumes "\<forall>u. (u \<in># L \<longrightarrow> (((f1 u), (f2 u)) \<in> r \<or> (f1 u) = (f2 u)))"
  assumes "\<exists>u. (u \<in># L \<and> ((f1 u), (f2 u)) \<in> r)"
  assumes "irrefl r"
  shows "( (M1,M2) \<in> (mult r) )"
proof -
  let ?L' = "{# u \<in># L.  (f1 u) = (f2 u) #}"
  let ?L'' = "{# u \<in># L.  (f1 u) \<noteq> (f2 u) #}"
  have "L = ?L' + ?L''" by (simp)
  from assms(3) have "\<forall>u. (u \<in># ?L'' \<longrightarrow> ((f1 u),(f2 u)) \<in> r)" by auto
  let ?M1' = "{# (f1 u). u \<in># ?L' #}"
  let ?M2' = "{# (f2 u). u \<in># ?L' #}"
  have "?M1' = ?M2'"
    by (metis (mono_tags, lifting) mem_Collect_eq multiset.map_cong0 set_mset_filter)
  let ?M1'' = "{# (f1 u). u \<in># ?L'' #}"
  let ?M2'' = "{# (f2 u). u \<in># ?L'' #}"
  from \<open>L = ?L' + ?L''\<close> have "M1 = ?M1' + ?M1''" by (metis assms(1) image_mset_union)
  from \<open>L = ?L' + ?L''\<close> have "M2 = ?M2' + ?M2''" by (metis assms(2) image_mset_union)
  have dom: "(\<forall>k \<in> set_mset ?M1''. \<exists>j \<in> set_mset ?M2''. (k, j) \<in> r)"
  proof
    fix k assume "k \<in> set_mset ?M1''"
    from this obtain u where "k = (f1 u)" and "u \<in># ?L''" by auto
    from \<open>u \<in># ?L''\<close> have "(f2 u) \<in># ?M2''" by simp
    from \<open>\<forall>u. (u \<in># ?L'' \<longrightarrow> ((f1 u),(f2 u)) \<in> r)\<close> and \<open>u \<in># ?L''\<close>
      have "((f1 u),(f2 u)) \<in> r" by auto
    from this and \<open>k = (f1 u)\<close> and \<open>(f2 u) \<in> set_mset ?M2''\<close>
      show "\<exists>j \<in> set_mset ?M2''. (k, j) \<in> r" by auto
  qed
  have "?L'' \<noteq> {#}"
  proof -
    from assms(4) obtain u where "u \<in># L" and "( (f1 u),(f2 u) ) \<in> r" by auto
    from assms(5) \<open>( (f1 u),(f2 u) ) \<in> r\<close> have "( (f1 u) \<noteq> (f2 u) )"
      unfolding irrefl_def by fastforce
    from \<open>u \<in># L\<close> \<open>( (f1 u) \<noteq> (f2 u) )\<close> have "u \<in># ?L''" by auto
    from this show ?thesis by force
  qed
  from this have  "?M2'' \<noteq> {#}" by auto
  from this and dom and \<open>M1 = ?M1' + ?M1''\<close> \<open>M2 = ?M2' + ?M2''\<close> \<open>?M1'=?M2'\<close>
  show "(M1,M2) \<in> (mult r)" by (simp add: one_step_implies_mult)
qed

lemma image_mset_ordering_eq:
  assumes "M1 = {# (f1 u). u \<in># L #}"
  assumes "M2 = {# (f2 u). u \<in># L #}"
  assumes "\<forall>u. (u \<in># L \<longrightarrow> (((f1 u), (f2 u)) \<in> r \<or> (f1 u) = (f2 u)))"
  shows "(M1 = M2) \<or> ( (M1,M2) \<in> (mult r) )"
proof (cases)
  assume "M1 = M2" then show ?thesis by auto
  next assume "M1 \<noteq> M2"
  let ?L' = "{# u \<in># L.  (f1 u) = (f2 u) #}"
  let ?L'' = "{# u \<in># L.  (f1 u) \<noteq> (f2 u) #}"
  have "L = ?L' + ?L''" by (simp)
  from assms(3) have "\<forall>u. (u \<in># ?L'' \<longrightarrow> ((f1 u),(f2 u)) \<in> r)" by auto
  let ?M1' = "{# (f1 u). u \<in># ?L' #}"
  let ?M2' = "{# (f2 u). u \<in># ?L' #}"
  have "?M1' = ?M2'"
    by (metis (mono_tags, lifting) mem_Collect_eq multiset.map_cong0 set_mset_filter)
  let ?M1'' = "{# (f1 u). u \<in># ?L'' #}"
  let ?M2'' = "{# (f2 u). u \<in># ?L'' #}"
  from \<open>L = ?L' + ?L''\<close> have "M1 = ?M1' + ?M1''" by (metis assms(1) image_mset_union)
  from \<open>L = ?L' + ?L''\<close> have "M2 = ?M2' + ?M2''" by (metis assms(2) image_mset_union)
  have dom: "(\<forall>k \<in> set_mset ?M1''. \<exists>j \<in> set_mset ?M2''. (k, j) \<in> r)"
  proof
    fix k assume "k \<in> set_mset ?M1''"
    from this obtain u where "k = (f1 u)" and "u \<in># ?L''" by auto
    from \<open>u \<in># ?L''\<close> have "(f2 u) \<in># ?M2''" by simp
    from \<open>\<forall>u. (u \<in># ?L'' \<longrightarrow> ((f1 u),(f2 u)) \<in> r)\<close> and \<open>u \<in># ?L''\<close>
      have "((f1 u),(f2 u)) \<in> r" by auto
    from this and \<open>k = (f1 u)\<close> and \<open>(f2 u) \<in> set_mset ?M2''\<close>
      show "\<exists>j \<in> set_mset ?M2''. (k, j) \<in> r" by auto
  qed
  from \<open>M1 \<noteq> M2\<close> have  "?M2'' \<noteq> {#}"
    using \<open>M1 = image_mset f1 {# u \<in># L. f1 u = f2 u#} + image_mset f1 {# u \<in># L. f1 u \<noteq> f2 u#}\<close> \<open>M2 = image_mset f2 {# u \<in># L. f1 u = f2 u#} + image_mset f2 {# u \<in># L. f1 u \<noteq> f2 u#}\<close> \<open>image_mset f1 {# u \<in># L. f1 u = f2 u#} = image_mset f2 {# u \<in># L. f1 u = f2 u#}\<close> by auto
  from this and dom and \<open>M1 = ?M1' + ?M1''\<close> \<open>M2 = ?M2' + ?M2''\<close> \<open>?M1'=?M2'\<close>
  have "(M1,M2) \<in> (mult r)" by (simp add: one_step_implies_mult)
  from this show ?thesis by auto
qed

lemma mult1_def_lemma :
  assumes "M = M0 + {#a#} \<and> N = M0 + K \<and> (\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r)"
  shows "(N,M) \<in> (mult1 r)"
proof -
  from assms(1) show ?thesis using mult1_def [of r] by auto
qed

lemma mset_ordering_add1:
  assumes "(E1,E2) \<in> (mult r)"
  shows "(E1,E2 + {# a #}) \<in> (mult r)"
proof -
  have i: "(E2,E2 + {# a #}) \<in> (mult1 r)" using mult1_def_lemma [of "E2 + {# a #}" E2 a E2 "{#}" r]
    by auto
  have i: "(E2,E2 + {# a #}) \<in> (mult1 r)" using mult1_def_lemma [of "E2 + {# a #}" E2 a E2 "{#}" r]
    by auto
  from assms(1) have "(E1,E2) \<in> (mult1 r)\<^sup>+" using mult_def by auto
  from this and i have "(E1,E2 + {# a #}) \<in> (mult1 r)\<^sup>+" by auto
  then show ?thesis using mult_def by auto
qed

lemma mset_ordering_singleton:
  assumes "\<forall>x. (x \<in># E1 \<longrightarrow> (x,a) \<in> r)"
  shows "(E1, {# a #}) \<in> (mult r)"
proof -
  let ?K = "E1"
  let ?M0 = "{#}"
  have i: "E1 = ?M0 + ?K" by auto
  have ii: "{# a #} = ?M0 + {# a #}" by auto
  from assms(1) have iii: "\<forall>x. (x \<in># ?K \<longrightarrow> (x,a) \<in> r)" by auto
  from i and ii and iii show ?thesis using mult1_def_lemma [of "{# a #}"  ?M0 a E1 ?K r] mult_def by auto
qed

lemma monotonic_fun_mult1:
  assumes "\<And> t s. ((t,s) \<in> r \<Longrightarrow> ((f t), (f s)) \<in> r)"
  assumes "(E1,E2) \<in> (mult1 r)"
  shows "({# (f x). x \<in># E1 #},{# (f x). x \<in># E2 #}) \<in>  (mult1 r)"
proof -
  let ?E1 = "{# (f x). x \<in># E1 #}"
  let ?E2 = "{# (f x). x \<in># E2 #}"
  from assms(2) obtain M0 a K where "E2 = M0 + {#a#}" and "E1 = M0 + K" and "(\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r)"
    unfolding mult1_def [of r]  by auto
  let ?K = "{# (f x). x \<in># K #}"
  let ?M0 = "{# (f x). x \<in># M0 #}"
  from \<open>E2 = M0 + {#a#}\<close> have "?E2 = ?M0 + {# (f a) #}" by simp
  from \<open>E1 = M0 + K\<close> have "?E1 = ?M0 + ?K" by simp
  have "(\<forall>b. b \<in># ?K \<longrightarrow> (b, (f a)) \<in> r)"
  proof ((rule allI),(rule impI))
    fix b assume "b  \<in># ?K"
    from \<open>b  \<in># ?K\<close> obtain b' where "b = (f b')" and "b' \<in># K"
      by (auto simp: insert_DiffM2 msed_map_invR union_single_eq_member)
    from \<open>b' \<in># K\<close> and \<open>(\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r)\<close> have "(b',a) \<in> r" by auto
    from assms(1) and this and \<open>b = (f b')\<close> show "(b, (f a)) \<in> r" by auto
  qed
  from \<open>?E1 = ?M0 + ?K\<close> and \<open>?E2 = ?M0 + {# (f a) #}\<close> and \<open>(\<forall>b. b \<in># ?K \<longrightarrow> (b, (f a)) \<in> r)\<close>
    show "(?E1,?E2) \<in>  (mult1 r)" by (metis mult1_def_lemma)
qed

lemma monotonic_fun_mult:
  assumes "\<And> t s. ((t,s) \<in> r \<Longrightarrow> ((f t), (f s)) \<in> r)"
  assumes "(E1,E2) \<in> (mult r)"
  shows "({# (f x). x \<in># E1 #},{# (f x). x \<in># E2 #}) \<in>  (mult r)"
proof -
  let ?E1 = "{# (f x). x \<in># E1 #}"
  let ?E2 = "{# (f x). x \<in># E2 #}"
  let ?P = "\<lambda>x. (?E1,{# (f y). y \<in># x #}) \<in> (mult r)"
  show ?thesis
  proof (rule trancl_induct [of E1 E2 "(mult1 r)" ?P])
    from assms(1) show "(E1, E2) \<in> (mult1 r)\<^sup>+" using assms(2) mult_def by blast
  next
    fix x assume "(E1, x) \<in> mult1 r"
    have "(image_mset f E1, image_mset f x) \<in> mult1 r"
      by (simp add: \<open>(E1, x) \<in> mult1 r\<close> assms(1) monotonic_fun_mult1)
    from this show "(image_mset f E1, image_mset f x) \<in> mult r" by (simp add: mult_def)
  next
    fix x z assume "(E1, x) \<in> (mult1 r)\<^sup>+"
      "(x, z) \<in> mult1 r" and "(image_mset f E1, image_mset f x) \<in> mult r"
    from \<open>(x, z) \<in> mult1 r\<close> have "(image_mset f x, image_mset f z) \<in> mult1 r"
      by (simp add: assms(1) monotonic_fun_mult1)
    from this and \<open>(image_mset f E1, image_mset f x) \<in> mult r\<close>
      show "(image_mset f E1, image_mset f z) \<in> mult r"
      using mult_def trancl.trancl_into_trancl by fastforce
  qed
qed

lemma mset_set_insert_eq:
  assumes "finite E"
  shows "mset_set (E \<union> { x }) \<subseteq># mset_set E + {# x #}"
proof (rule ccontr)
  assume "\<not> ?thesis"
  from this obtain y where "(count (mset_set (E \<union> { x })) y)
    > (count (mset_set E + {# x #}) y)"
    by (meson leI subseteq_mset_def)
  from assms(1) have "finite (E \<union> { x })" by auto
  have "(count (mset_set E + {# x #}) y) = (count (mset_set E) y) + (count {# x #} y)" by auto
  have "x \<noteq> y"
  proof
    assume "x = y"
    then have "y \<in> E \<union> { x }" by auto
    from \<open>finite (E \<union> { x })\<close> this have "(count (mset_set (E \<union> { x })) y) = 1"
      using count_mset_set(1) by auto
    from this and \<open>(count (mset_set (E \<union> { x })) y) > (count (mset_set E + {# x #}) y)\<close> have
      "(count (mset_set E + {# x #}) y) = 0" by auto
    from \<open>(count (mset_set E + {# x #}) y) = 0\<close> have "count {# x #} y = 0" by auto
    from \<open>x = y\<close> have "count {# x #} y = 1" using count_mset_set by auto
    from this and \<open>count {# x #} y = 0\<close> show False by auto
  qed
  have "y \<notin> E"
  proof
    assume "y \<in> E"
    then have "y \<in> E \<union> { x }" by auto
    from \<open>finite (E \<union> { x })\<close> this have "(count (mset_set (E \<union> { x })) y) = 1"
      using count_mset_set(1) by auto
    from this and \<open>(count (mset_set (E \<union> { x })) y) > (count (mset_set E + {# x #}) y)\<close> have
      "(count (mset_set E + {# x #}) y) = 0" by auto
    from \<open>(count (mset_set E + {# x #}) y) = 0\<close> have "count (mset_set E) y = 0" by (simp split: if_splits)
    from \<open>y \<in> E\<close> \<open>finite E\<close> have "count (mset_set E) y = 1" using count_mset_set(1) by auto
    from this and \<open>count (mset_set E) y = 0\<close> show False by auto
  qed
  from this and \<open>x \<noteq> y\<close> have "y \<notin> E \<union> { x }" by auto
  from this have "(count (mset_set (E \<union> { x })) y) = 0" by auto
  from this and \<open>(count (mset_set (E \<union> { x })) y)
    > (count (mset_set E + {# x #}) y)\<close> show False by auto
qed

lemma mset_set_insert:
  assumes "x \<notin> E"
  assumes "finite E"
  shows "mset_set (E \<union> { x }) = mset_set E + {# x #}"
proof (rule ccontr)
  assume "\<not> ?thesis"
  from this obtain y where "(count (mset_set (E \<union> { x })) y)
    \<noteq> (count (mset_set E + {# x #}) y)" by (meson multiset_eqI)
  have "(count (mset_set E + {# x #}) y) = (count (mset_set E) y) + (count {# x #} y)" by auto
  from assms(2) have "finite (E \<union> { x })" by auto
  have "x \<noteq> y"
  proof
    assume "x = y"
    then have "y \<in> E \<union> { x }" by auto
    from \<open>finite (E \<union> { x })\<close> this have "(count (mset_set (E \<union> { x })) y) = 1"
      using count_mset_set(1) by auto
    from \<open>x = y\<close> have "count {# x #} y = 1" using count_mset_set by auto
    from \<open>x = y\<close> \<open>x \<notin> E\<close> have "(count (mset_set E) y) = 0"  using count_mset_set by auto
    from \<open>count {# x #} y = 1\<close> \<open>(count (mset_set E) y) = 0\<close>
      \<open>(count (mset_set E + {# x #}) y) = (count (mset_set E) y) + (count {# x #} y)\<close>
      have "(count (mset_set E + {# x #}) y) = 1" by auto
    from this and \<open>(count (mset_set (E \<union> { x })) y) = 1\<close> and \<open>(count (mset_set (E \<union> { x })) y)
    \<noteq> (count (mset_set E + {# x #}) y)\<close> show False by auto
  qed
  from \<open>x \<noteq> y\<close> have "count {# x #} y = 0" using count_mset_set by auto
  have "y \<notin> E"
  proof
    assume "y \<in> E"
    then have "y \<in> E \<union> { x }" by auto
    from \<open>finite (E \<union> { x })\<close> this have "(count (mset_set (E \<union> { x })) y) = 1"
      using count_mset_set(1) by auto
    from assms(2) \<open>y \<in> E\<close> have "(count (mset_set E) y) = 1"  using count_mset_set by auto
    from \<open>count {# x #} y = 0\<close> \<open>(count (mset_set E) y) = 1\<close>
      \<open>(count (mset_set E + {# x #}) y) = (count (mset_set E) y) + (count {# x #} y)\<close>
      have "(count (mset_set E + {# x #}) y) = 1" by auto
    from this and \<open>(count (mset_set (E \<union> { x })) y) = 1\<close> and \<open>(count (mset_set (E \<union> { x })) y)
    \<noteq> (count (mset_set E + {# x #}) y)\<close> show False by auto
  qed
  from this and \<open>x \<noteq> y\<close> have "y \<notin> E \<union> { x }" by auto
  from this have "(count (mset_set (E \<union> { x })) y) = 0" by auto
  from \<open>y \<notin> E\<close> have "(count (mset_set E) y) = 0" using count_mset_set by auto
  from \<open>count {# x #} y = 0\<close> \<open>(count (mset_set E) y) = 0\<close>
      \<open>(count (mset_set E + {# x #}) y) = (count (mset_set E) y) + (count {# x #} y)\<close>
      have "(count (mset_set E + {# x #}) y) = 0" by auto
   from this and \<open>(count (mset_set (E \<union> { x })) y) = 0\<close> and \<open>(count (mset_set (E \<union> { x })) y)
    \<noteq> (count (mset_set E + {# x #}) y)\<close> show False by auto
qed

lemma mset_image_comp:
  shows "{# (f x). x \<in># {# (g x). x \<in># E #} #} = {# (f (g x)). x \<in># E #}"
   by (simp add: image_mset.compositionality comp_def)

lemma mset_set_mset_image:
  shows "\<And> E. card E = N \<Longrightarrow> finite E \<Longrightarrow> mset_set (g ` E) \<subseteq>#  {# (g x). x \<in># mset_set (E) #}"
proof (induction N)
  case 0
    assume "card E = 0"
    assume "finite E"
    from this and \<open>card E = 0\<close> have "E = {}" by auto
    then show "mset_set (g ` E) \<subseteq>#  {# (g x). x \<in># mset_set (E) #}" by auto
next
  case (Suc N)
    assume "card E = (Suc N)"
    assume "finite E"
    from this and \<open>card E = (Suc N)\<close> have "E \<noteq> {}" by auto
    from this obtain x where "x \<in> E" by auto
    let ?E = "E - { x }"
    from \<open>finite E\<close> \<open>card E = (Suc N)\<close> and \<open>x \<in> E\<close> have "card ?E = N" by auto
    from \<open>finite E\<close> have "finite ?E" by auto
    from this and "Suc.IH" [of ?E] and \<open>card ?E = N\<close>
      have ind: "mset_set (g ` ?E) \<subseteq>#  {# (g x). x \<in># mset_set (?E) #}" by force
    from \<open>x \<in> E\<close> have "E = ?E \<union> { x }" by auto
    have "x \<notin> ?E" by auto
    from \<open>finite ?E\<close> \<open>E = ?E \<union> { x }\<close> and \<open>x \<notin> ?E\<close> have "mset_set (?E \<union> { x }) = mset_set ?E + {# x #}"
      using mset_set_insert [of x ?E] by auto
    from this have
    "{# (g x). x \<in># mset_set (?E \<union> { x }) #} = {# (g x). x \<in># mset_set ?E #} + {# (g x) #}"
      by auto
    have "(g ` (?E \<union> { x }) = (g ` ?E) \<union> { g x })" by auto
    from this have i: "mset_set (g ` (?E \<union> { x })) = mset_set ( (g ` ?E) \<union> { g x } )" by auto
    from \<open>finite ?E\<close> have "finite (g ` ?E)" by auto
    from this have "mset_set ( (g ` ?E) \<union> { g x } ) \<subseteq># mset_set (g ` ?E) + {# (g x) #}"
        using  mset_set_insert_eq [of "(g ` ?E)" "(g x)" ] by meson
    from this i have ii: "mset_set (g ` (?E \<union> { x })) \<subseteq># mset_set (g ` ?E) + {# (g x) #}" by auto
    from ind have "mset_set (g ` ?E) + {# (g x) #} \<subseteq>#  {# (g x). x \<in># mset_set (?E) #} + {# (g x) #}"
      using Multiset.subset_mset.add_right_mono by metis
    from this and ii have "mset_set (g ` (?E \<union> { x })) \<subseteq># {# (g x). x \<in># mset_set (?E) #} + {# (g x) #}"
      using Multiset.subset_mset.order.trans [of "mset_set (g ` (?E \<union> { x }))" ] by metis
    from this and \<open>E = ?E \<union> { x }\<close> \<open>{# (g x). x \<in># mset_set (?E \<union> { x }) #} = {# (g x). x \<in># mset_set ?E #} + {# (g x) #}\<close>
     show "mset_set (g ` E) \<subseteq># {# (g x). x \<in># mset_set E #}"
      by metis
qed

lemma split_mset_set:
  assumes "C = C1 \<union> C2"
  assumes "C1 \<inter> C2 = {}"
  assumes "finite C1"
  assumes "finite C2"
  shows "(mset_set C) = (mset_set C1) + (mset_set C2)"
proof (rule ccontr)
  assume "(mset_set C) \<noteq> (mset_set C1) + (mset_set C2)"
  then obtain x where "count (mset_set C) x \<noteq> count ((mset_set C1) + (mset_set C2)) x"
    by (meson multiset_eqI)
  from assms(3) assms(4) assms(1) have "finite C" by auto

  have "count ((mset_set C1) + (mset_set C2)) x = (count (mset_set C1) x) + (count (mset_set C2) x)"
    by auto
  from this and \<open>count (mset_set C) x \<noteq> count ((mset_set C1) + (mset_set C2)) x\<close> have
    "count (mset_set C) x \<noteq> (count (mset_set C1) x) + (count (mset_set C2) x)" by auto
  have "x \<in> C1 \<or> x \<in> C2"
  proof (rule ccontr)
    assume "\<not> (x \<in> C1 \<or> x \<in> C2)"
    then have "x \<notin> C1" and "x\<notin> C2" by auto
    from assms(1) \<open>x \<notin> C1\<close> and \<open>x\<notin> C2\<close> have "x \<notin> C" by auto
    from \<open>x \<notin> C1\<close> have "(count (mset_set C1) x) = 0" by auto
    from \<open>x \<notin> C2\<close> have "(count (mset_set C2) x) = 0" by auto
    from \<open>x \<notin> C\<close> have "(count (mset_set C) x) = 0" by auto
    from \<open>(count (mset_set C1) x) = 0\<close> \<open>(count (mset_set C2) x) = 0\<close>
      \<open>(count (mset_set C) x) = 0\<close>
      \<open>count (mset_set C) x \<noteq> (count (mset_set C1) x) + (count (mset_set C2) x)\<close>
      show False by auto
  qed

  have "(x \<notin> C1 \<or> x \<in> C2)"
  proof (rule ccontr)
    assume "\<not> (x \<notin> C1 \<or> x \<in> C2)"
    then have "x \<in> C1" and " x\<notin> C2" by auto
    from assms(1) \<open>x \<in> C1\<close> have "x \<in> C" by auto
    from assms(3) \<open>x \<in> C1\<close> have "(count (mset_set C1) x) = 1" by auto
    from \<open>x \<notin> C2\<close> have "(count (mset_set C2) x) = 0" by auto
    from assms(3) assms(4) assms(1) have "finite C" by auto
    from \<open>finite C\<close> \<open>x \<in> C\<close> have "(count (mset_set C) x) = 1" by auto
    from \<open>(count (mset_set C1) x) = 1\<close> \<open>(count (mset_set C2) x) = 0\<close>
      \<open>(count (mset_set C) x) = 1\<close>
      \<open>count (mset_set C) x \<noteq> (count (mset_set C1) x) + (count (mset_set C2) x)\<close>
      show False by auto
  qed
  have "(x \<notin> C2 \<or> x \<in> C1)"
  proof (rule ccontr)
    assume "\<not> (x \<notin> C2 \<or> x \<in> C1)"
    then have "x \<in> C2" and " x\<notin> C1" by auto
    from assms(1) \<open>x \<in> C2\<close> have "x \<in> C" by auto
    from assms(4) \<open>x \<in> C2\<close> have "(count (mset_set C2) x) = 1" by auto
    from \<open>x \<notin> C1\<close> have "(count (mset_set C1) x) = 0" by auto
    from \<open>finite C\<close> \<open>x \<in> C\<close> have "(count (mset_set C) x) = 1" by auto
    from \<open>(count (mset_set C2) x) = 1\<close> \<open>(count (mset_set C1) x) = 0\<close>
      \<open>(count (mset_set C) x) = 1\<close>
      \<open>count (mset_set C) x \<noteq> (count (mset_set C1) x) + (count (mset_set C2) x)\<close>
      show False by auto
  qed
  from \<open>x \<in> C1 \<or> x \<in> C2\<close> \<open>(x \<notin> C1 \<or> x \<in> C2)\<close> \<open>(x \<notin> C2 \<or> x \<in> C1)\<close>
    have "x \<in> C1 \<and> x \<in> C2" by blast
  from this and assms(2) show False by auto
qed

lemma image_mset_thm:
  assumes "E = {# (f x). x \<in># E' #}"
  assumes "x \<in># E"
  shows "\<exists> y. ((y \<in># E') \<and> x = (f y))"
using assms by auto

lemma split_image_mset:
  assumes "M = M1 + M2"
  shows "{# (f x). x \<in># M #} = {# (f x). x \<in># M1 #} + {# (f x). x \<in># M2 #}"
by (simp add: assms)

end


(* Author: Lukas Koller *)
theory MinSpanningTree
  imports Main tsp.Misc tsp.CompleteGraph tsp.WeightedGraph
begin

section \<open>Connected Graphs\<close>

definition "is_connected E \<equiv> \<forall>u\<in>Vs E.\<forall>v\<in>Vs E. u \<in> connected_component E v"

lemma is_connectedI:
  "(\<And>u v. u\<in>Vs E \<Longrightarrow> v\<in>Vs E \<Longrightarrow> u \<in> connected_component E v) \<Longrightarrow> is_connected E"
  unfolding is_connected_def by auto

lemma is_connectedI2:
  assumes "\<And>u v. u\<in>Vs E \<Longrightarrow> v\<in>Vs E \<Longrightarrow> u \<noteq> v \<Longrightarrow> u \<in> connected_component E v"
  shows "is_connected E"
proof (rule is_connectedI)
  fix u v
  assume "u \<in> Vs E" "v \<in> Vs E"
  thus "u \<in> connected_component E v"
    using assms by (cases "u = v") (auto simp: in_own_connected_component)
qed

lemma is_connectedE: "is_connected E \<Longrightarrow> u \<in> Vs E \<Longrightarrow> v \<in> Vs E \<Longrightarrow> u \<in> connected_component E v"
  unfolding is_connected_def by auto

lemma is_connectedE2:
  assumes "is_connected E" "u \<in> Vs E" "v \<in> Vs E" "u \<noteq> v"
  obtains P where "walk_betw E u P v"
  using assms[unfolded is_connected_def connected_component_def] by fastforce

context compl_graph_abs
begin

lemma is_connected: "is_connected E"
proof (intro is_connectedI2)
  fix u v
  assume "u \<in> Vs E" "v \<in> Vs E" "u \<noteq> v"
  moreover hence "{v,u} \<in> E"
    by (auto intro: edge_in_E_intro)
  ultimately show "u \<in> connected_component E v"
    by (subst insert_absorb[symmetric]) (auto intro: in_con_comp_insert)
qed

end

lemma path_connected:
  assumes "path E P"
  shows "is_connected (set (edges_of_path P))" (is "is_connected ?E\<^sub>P")
proof (rule is_connectedI)
  fix u v
  assume "u \<in> Vs ?E\<^sub>P" "v \<in> Vs ?E\<^sub>P"
  then have "u \<in> set P" "v \<in> set P"
    using edges_of_path_Vs[of P] by auto
  then obtain i\<^sub>u i\<^sub>v where u_v_simps: "u = P ! i\<^sub>u" "i\<^sub>u < length P" "v = P ! i\<^sub>v" "i\<^sub>v < length P"
    using set_conv_nth[of P] by auto
  consider "i\<^sub>u = i\<^sub>v" | "i\<^sub>u < i\<^sub>v" | "i\<^sub>v < i\<^sub>u"
    by linarith
  thus "u \<in> connected_component ?E\<^sub>P v"
  proof cases
    assume "i\<^sub>u = i\<^sub>v"
    thus ?thesis
      using u_v_simps in_own_connected_component[of "P ! i\<^sub>u" ?E\<^sub>P] by auto
  next
    assume "i\<^sub>u < i\<^sub>v"
    then obtain P' where "walk_betw ?E\<^sub>P u P' v"
      using assms u_v_simps by (auto elim: walk_of_pathE[of E P i\<^sub>u i\<^sub>v])
    thus ?thesis
      unfolding connected_component_def using walk_symmetric[of ?E\<^sub>P u P' v] by auto
  next
    assume "i\<^sub>v < i\<^sub>u"
    thus ?thesis
      unfolding connected_component_def using assms u_v_simps walk_on_path[of E P i\<^sub>v i\<^sub>u] by auto
  qed
qed

lemma connected_bridge:
  assumes "is_connected X" "X' \<subseteq> X" "Vs X' \<noteq> {}" "Vs X' \<subset> Vs X"
  obtains u v where "{u,v} \<in> X" "u \<in> Vs X'" "v \<in> Vs X - Vs X'"
proof -
  obtain u v where "u \<in> Vs X'" "v \<in> Vs X - Vs X'"
    using assms by auto
  moreover hence "u \<in> Vs X" "v \<in> Vs X" "u \<noteq> v"
    using assms calculation by auto
  moreover then obtain P where "walk_betw X u P v"
    using assms is_connectedE2[of X u v] by auto
  moreover have "set P \<subseteq> Vs X' \<union> (Vs X - Vs X')"
    using calculation walk_in_Vs[of X u P v] by auto
  moreover have "set (edges_of_path P) \<subseteq> X"
    using calculation path_edges_subset[OF walk_between_nonempty_path(1), of X u P v] by auto
  ultimately obtain u v where "{u,v} \<in> X" "u \<in> Vs X'" "v \<in> Vs X - Vs X'"
    by (elim walk_split[of X u P v "Vs X'" "Vs X - Vs X'"]) fastforce+
  thus ?thesis
    using that by auto
qed

section \<open>Simple Paths\<close>

definition "is_simple P \<equiv> distinct (edges_of_path P)"

lemma is_simpleI: "distinct (edges_of_path P) \<Longrightarrow> is_simple P"
  unfolding is_simple_def by auto

lemma is_simpleE: "is_simple P \<Longrightarrow> distinct (edges_of_path P)"
  unfolding is_simple_def by auto

lemma is_simpleI2: "distinct P \<Longrightarrow> is_simple P"
  using distinct_edges_of_vpath by (auto intro: is_simpleI)

lemma simple_path_rev: "is_simple P \<Longrightarrow> is_simple (rev P)"
  using edges_of_path_rev[of P] distinct_rev[of "edges_of_path P"] by (auto simp: is_simple_def)

lemma simple_path_cons: "is_simple (v#P) \<Longrightarrow> is_simple P"
  unfolding is_simple_def using distinct_edges_of_paths_cons[of v P] by auto

lemma is_simple_rev_neq:
  assumes "is_simple P" "length P > 2"
  shows "P \<noteq> rev P"
  using assms
proof (induction P rule: list0123.induct)
  case (4 u v w P)
  show ?case
  proof (rule ccontr)
    assume "\<not> u#v#w#P \<noteq> rev (u#v#w#P)"
    hence "edges_of_path (u#v#w#P) = rev (edges_of_path (u#v#w#P))"
      by (auto simp: edges_of_path_rev)
    thus "False"
      using 4 rev_hd_last_eq[of "edges_of_path (u#v#w#P)"]
        distinct_hd_last_neq[OF is_simpleE[of "u#v#w#P"]] by auto
  qed
qed auto

lemma is_simple_rotate:
  assumes "is_simple (u#P\<^sub>1 @ v#P\<^sub>2 @ [u])" (is "is_simple ?P")
  shows "is_simple (v#P\<^sub>2 @ u#P\<^sub>1 @ [v])" (is "is_simple ?P'")
proof (rule is_simpleI; rule card_distinct)
  have "card (set (edges_of_path ?P')) = card (set (edges_of_path ?P))"
    by (auto simp: edges_of_path_rotate)
  also have "... = length (edges_of_path ?P)"
    apply (rule distinct_card)
    using assms by (auto elim: is_simpleE)
  also have "... = length (edges_of_path ?P')"
    by (auto simp: length_edges_of_path_rotate)
  finally show "card (set (edges_of_path ?P')) = length (edges_of_path ?P')" .
qed

section \<open>Acyclic Graphs\<close>

text \<open>Definition for a cycle in a graph. A cycle is a vertex-path, thus a cycle needs to contain
at least one edge, otherwise the singleton path \<open>[v]\<close> is a cycle. Therefore, no graph would be
acyclic.\<close>
definition "is_cycle E C \<equiv> (\<exists>v. walk_betw E v C v) \<and> is_simple C \<and> length (edges_of_path C) > 0"

lemma is_cycleI:
  "is_simple C \<Longrightarrow> length (edges_of_path C) > 0 \<Longrightarrow> walk_betw E v C v \<Longrightarrow> is_cycle E C"
  unfolding is_cycle_def by auto

lemma is_cycleE:
  assumes "is_cycle E C"
  obtains v where "is_simple C" "length (edges_of_path C) > 0" "walk_betw E v C v"
  using assms[unfolded is_cycle_def] by auto

lemma is_cycleE_hd:
  assumes "is_cycle E C"
  shows "is_simple C" "length (edges_of_path C) > 0" "walk_betw E (hd C) C (hd C)"
proof -
  show "is_simple C" "0 < length (edges_of_path C)"
    using assms by (auto elim: is_cycleE)
  obtain v where "walk_betw E v C v"
    using assms by (auto elim: is_cycleE)
  moreover hence "v = hd C"
    by (auto simp: walk_between_nonempty_path)
  ultimately show "walk_betw E (hd C) C (hd C)"
    by auto
qed

lemma cycle_non_nil: "is_cycle E C \<Longrightarrow> C \<noteq> []"
  by (auto elim: is_cycleE walk_nonempty)

lemma cycle_hd_last_eq:
  assumes "is_cycle E C"
  shows "hd C = last C"
proof -
  obtain v where "walk_betw E v C v"
    using assms by (auto elim: is_cycleE)
  hence "hd C = v" "last C = v"
    by (auto elim: walk_between_nonempty_path)
  thus ?thesis
    by (auto elim: walk_between_nonempty_path)
qed

lemma cycle_edges_subset:
  assumes "is_cycle E C"
  shows "set (edges_of_path C) \<subseteq> E"
proof -
  obtain v where "walk_betw E v C v"
    using assms by (auto elim: is_cycleE)
  thus ?thesis
    by (rule path_edges_subset[OF walk_between_nonempty_path(1)])
qed

context graph_abs
begin

lemma cycle_length:
  assumes "is_cycle E C"
  shows "length C > 2"
  using assms
proof (induction C rule: list0123.induct)
  case (3 u v)
  then obtain v' where "is_simple [u,v]" "length (edges_of_path [u,v]) > 0"
    "walk_betw E v' [u,v] v'"
    by (auto elim: is_cycleE)
  hence "u = v'" "v = v'" "path E [u,v]"
    using walk_between_nonempty_path[of _ _ "[u,v]"] by auto
  hence "u = v" "{u,v} \<in> E"
    by (auto elim: path.cases)
  thus ?case
    using graph by auto
qed (auto elim: is_cycleE)

lemma cycle_edge_length:
  assumes "is_cycle E C"
  shows "length (edges_of_path C) > 1"
  using edges_of_path_length[of C] cycle_length[OF assms] by auto

lemma cycle_edges_hd_last_neq:
  assumes "is_cycle E C"
  shows "hd (edges_of_path C) \<noteq> last (edges_of_path C)" (is "?e\<^sub>1 \<noteq> ?e\<^sub>2")
  using assms cycle_edge_length distinct_hd_last_neq[OF is_simpleE] by (auto elim: is_cycleE)

lemma cycle_path_split:
  assumes "is_cycle E C" "v \<in> set C" "v \<noteq> hd C"
  obtains u P\<^sub>1 P\<^sub>2 where "C = u#P\<^sub>1 @ v#P\<^sub>2 @ [u]"
proof -
  obtain u where "walk_betw E u C u"
    using assms by (auto elim: is_cycleE)
  moreover hence "u = hd C"
    by (auto simp: walk_between_nonempty_path)
  moreover hence "u \<noteq> v"
    using assms by auto
  moreover obtain P\<^sub>1 P\<^sub>2 where "C = u#P\<^sub>1 @ v#P\<^sub>2 @ [u]"
    using assms graph calculation walk_path_split[of (* E *) u C v] by auto
  ultimately show ?thesis
    using that by blast
qed

lemma cycle_rotate:
  assumes "is_cycle E C" "v \<in> set C"
  obtains C' where "is_cycle E C'" "walk_betw E v C' v"
    "set (edges_of_path C) = set (edges_of_path C')"
proof cases
  assume "v = hd C"
  hence "is_cycle E C" "walk_betw E v C v"
    using assms by (auto elim: is_cycleE_hd)
  thus ?thesis
    using that by auto
next
  assume "v \<noteq> hd C"
  then obtain u P\<^sub>1 P\<^sub>2 where [simp]: "C = u#P\<^sub>1 @ v#P\<^sub>2 @ [u]"
    using assms by (elim cycle_path_split) auto
  let ?C'="v#P\<^sub>2 @ u#P\<^sub>1 @ [v]"
  have "path E C" "is_simple C" "length (edges_of_path C) > 0"
    using assms by (auto elim: is_cycleE walk_between_nonempty_path)
  moreover hence "walk_betw E v ?C' v"
    using path_rotate by (fastforce intro: nonempty_path_walk_between)+
  moreover have "is_simple ?C'" "length (edges_of_path ?C') > 0"
    using calculation is_simple_rotate[of u P\<^sub>1 v P\<^sub>2] length_edges_of_path_rotate[of u P\<^sub>1 v P\<^sub>2]
    by auto
  moreover have "is_cycle E ?C'"
    using calculation by (auto intro: is_cycleI)
  moreover have "set (edges_of_path C) = set (edges_of_path ?C')"
    using edges_of_path_rotate by fastforce
  ultimately show ?thesis using that by auto
qed (* TODO: might be able to simplify proof with \<open>Misc.walk_rotate\<close>. Need to show \<open>is_simple\<close>. *)

lemma cycle_edges_for_v:
  assumes "is_cycle E C" "v \<in> set C"
  obtains e\<^sub>1 e\<^sub>2 where "e\<^sub>1 \<noteq> e\<^sub>2" "e\<^sub>1 \<in> set (edges_of_path C)" "v \<in> e\<^sub>1"
    "e\<^sub>2 \<in> set (edges_of_path C)" "v \<in> e\<^sub>2"
proof -
  obtain C' where "is_cycle E C'" "walk_betw E v C' v"
    "set (edges_of_path C) = set (edges_of_path C')"
    using cycle_rotate[OF assms] by auto
  moreover hence "v = hd C'" "v = last C'" "length C' > 2" "edges_of_path C' \<noteq> []"
    using assms graph cycle_length walk_between_nonempty_path[of E v C' v] cycle_edge_length[of C']
    by auto
  moreover obtain e\<^sub>1 e\<^sub>2 where "e\<^sub>1 = hd (edges_of_path C')" "e\<^sub>2 = last (edges_of_path C')"
    by auto
  moreover hence "e\<^sub>1 \<in> set (edges_of_path C')" "e\<^sub>2 \<in> set (edges_of_path C')"
    using calculation hd_in_set[of C'] last_in_set[of C'] by auto
  moreover hence "e\<^sub>1 \<in> set (edges_of_path C)" "e\<^sub>2 \<in> set (edges_of_path C)"
    using calculation by auto
  moreover have "v \<in> e\<^sub>1" "v \<in> e\<^sub>2"
    using calculation last_v_in_last_e[of C'] hd_v_in_hd_e[of C'] by auto
  moreover have "e\<^sub>1 \<noteq> e\<^sub>2"
    using assms graph calculation cycle_edges_hd_last_neq by auto
  ultimately show ?thesis
    using that by auto
qed

lemma cycle_degree:
  assumes "is_cycle E C" "v \<in> set C"
  shows "degree E v \<ge> 2"
proof -
  obtain e\<^sub>1 e\<^sub>2 where "e\<^sub>1 \<noteq> e\<^sub>2" "e\<^sub>1 \<in> set (edges_of_path C)" "v \<in> e\<^sub>1"
    "e\<^sub>2 \<in> set (edges_of_path C)" "v \<in> e\<^sub>2"
    using cycle_edges_for_v[OF assms] by auto
  moreover have "set (edges_of_path C) \<subseteq> E"
    using assms cycle_edges_subset by auto
  moreover have "{e \<in> {e\<^sub>1,e\<^sub>2}. v \<in> e} = {e\<^sub>1,e\<^sub>2}" "{e\<^sub>1,e\<^sub>2} \<subseteq> {e \<in> E. v \<in> e}"
    using calculation by auto
  moreover have "finite {e\<^sub>1,e\<^sub>2}" "card {e\<^sub>1,e\<^sub>2} = 2"
    using assms calculation by auto
  moreover hence "card' {e\<^sub>1,e\<^sub>2} = 2"
    using card'_finite_nat[of "{e\<^sub>1,e\<^sub>2}"] by auto
  moreover hence "degree {e\<^sub>1,e\<^sub>2} v = 2"
    unfolding degree_def2 using calculation by auto
  ultimately show ?thesis
    using subset_edges_less_degree[of "{e\<^sub>1,e\<^sub>2}" E v] by auto
qed

end

definition "is_acyclic E \<equiv> \<nexists>C. is_cycle E C"

lemma is_acyclicI: "(\<nexists>C. is_cycle E C) \<Longrightarrow> is_acyclic E"
  unfolding is_acyclic_def by auto

lemma is_acyclicE:
  assumes "is_acyclic E"
  shows "\<nexists>C. is_cycle E C"
  using assms[unfolded is_acyclic_def] by auto

lemma not_acyclicE:
  assumes "\<not> is_acyclic E"
  obtains C where "is_cycle E C"
  using assms[unfolded is_acyclic_def] by auto

context graph_abs
begin

lemma not_acyclicE2:
  assumes "\<not> is_acyclic E"
  obtains u v P P' where "is_simple P" "walk_betw E u P v"
    "is_simple P'" "walk_betw E u P' v" "P \<noteq> P'"
proof -
  obtain C where "is_cycle E C"
    using assms by (auto elim: not_acyclicE)
  moreover then obtain v where "is_simple C" "walk_betw E v C v"
    by (auto elim: is_cycleE)
  moreover hence "is_simple (rev C)" "walk_betw E v (rev C) v"
    using walk_symmetric[of E v C v] simple_path_rev by auto
  moreover hence "C \<noteq> rev C"
    using assms calculation is_simple_rev_neq[OF _ cycle_length] by auto
  ultimately show thesis
    using that by auto
qed

lemma degree_edges_of_path_hd_leq_1:
  assumes "distinct P"
  shows "degree (set (edges_of_path P)) (hd P) \<le> 1" (is "degree ?E\<^sub>P (hd P) \<le> 1")
  using assms
proof (induction P rule: list012.induct) (* induction just for case distinction *)
  case (3 u v P)
  then show ?case
    using degree_edges_of_path_hd by fastforce
qed auto

end

context path_edges_subgraph_abs
begin

lemma non_acyclic_path_not_distinct:
  assumes "\<not> is_acyclic E\<^sub>P"
  shows "\<not> distinct P"
proof
  assume "distinct P"

  obtain C where cycle_C: "is_cycle E\<^sub>P C"
    using assms by (auto elim: not_acyclicE)
  hence "length C > 2"
    using E\<^sub>P.E\<^sub>2.cycle_length by auto
  hence "Vs (set (edges_of_path C)) \<noteq> {}" (is "Vs ?E\<^sub>C \<noteq> {}")
    using vs_edges_path_eq[of C] by (auto simp: set_empty[of C])
  then obtain e where "e \<in> ?E\<^sub>C"
    by (auto elim: vs_member_elim)
  moreover then obtain u v where "e = {u,v}"
    by (auto elim: v_in_edge_in_path_inj)
  ultimately have "{u,v} \<in> ?E\<^sub>C"
    by auto
  moreover have "?E\<^sub>C \<subseteq> E\<^sub>P"
    by (metis cycle_C cycle_edges_subset)
  moreover have "{u,v} \<in> E\<^sub>P"
    using calculation by auto
  moreover have "u \<in> set P" "v \<in> set P"
    using calculation v_in_edge_in_path_gen[of \<open>{u,v}\<close>] by auto
  moreover have "u \<noteq> v"
    using calculation graph_E\<^sub>P by auto
  moreover have "2 \<le> card (set P)"
    using calculation card_mono[of "set P" "{u,v}"] by auto
  ultimately have "length P > 1"
    using card_length[of P] by auto

  consider "Vs ?E\<^sub>C = Vs E\<^sub>P" | "Vs ?E\<^sub>C \<subset> Vs E\<^sub>P"
    using \<open>?E\<^sub>C \<subseteq> E\<^sub>P\<close> Vs_subset[of ?E\<^sub>C E\<^sub>P] by auto
  thus "False"
  proof cases
    assume "Vs ?E\<^sub>C = Vs E\<^sub>P"
    moreover have "hd P \<in> hd (edges_of_path P)"
      using \<open>length P > 1\<close> hd_v_in_hd_e[of P] by auto
    moreover have "hd (edges_of_path P) \<in> E\<^sub>P"
      using \<open>length P > 1\<close> edges_of_path_length[of P] by (intro hd_in_set) auto
    moreover have "hd P \<in> Vs E\<^sub>P"
      using calculation by (auto intro: vs_member_intro)
    ultimately have "hd P \<in> Vs ?E\<^sub>C"
      by auto
    hence "hd P \<in> set C"
      using v_in_edge_in_path_gen by (fastforce elim: vs_member_elim)

    have "degree E\<^sub>P (hd P) \<le> 1"
      using \<open>distinct P\<close> degree_edges_of_path_hd_leq_1[of P] by auto
    moreover have "degree E\<^sub>P (hd P) \<ge> 2"
      using \<open>hd P \<in> set C\<close> E\<^sub>P.E\<^sub>2.cycle_degree[OF cycle_C] by auto (* TODO: fix sublocale lemma names *)
    ultimately have  "enat 2 \<le> enat 1"
      by (metis numeral_eq_enat one_enat_def dual_order.trans)
    thus ?thesis
      using enat_ord_simps by auto
  next
    assume "Vs ?E\<^sub>C \<subset> Vs E\<^sub>P"
    moreover have "is_connected E\<^sub>P"
      using path path_connected by auto
    ultimately obtain u v where "{u,v} \<in> E\<^sub>P" "u \<in> Vs ?E\<^sub>C" "v \<in> Vs E\<^sub>P - Vs ?E\<^sub>C"
      using \<open>Vs ?E\<^sub>C \<noteq> {}\<close> \<open>?E\<^sub>C \<subseteq> E\<^sub>P\<close> connected_bridge[of E\<^sub>P ?E\<^sub>C] by auto
    moreover hence "u \<in> set C" "v \<notin> Vs ?E\<^sub>C" "u \<in> set P"
      using vs_member_elim[of _ ?E\<^sub>C] v_in_edge_in_path_gen[of _ C]
            v_in_edge_in_path_gen[of "{u,v}" P u] by auto
    moreover hence "{u,v} \<notin> ?E\<^sub>C"
      using v_in_edge_in_path[of v u C] insert_commute by auto
    moreover then obtain e\<^sub>1 e\<^sub>2 where "e\<^sub>1 \<noteq> e\<^sub>2" "e\<^sub>1 \<in> ?E\<^sub>C" "u \<in> e\<^sub>1" "e\<^sub>2 \<in> ?E\<^sub>C" "u \<in> e\<^sub>2"
      using cycle_C calculation E\<^sub>P.E\<^sub>2.cycle_edges_for_v[of C u] by auto
    moreover hence "e\<^sub>1 \<in> E\<^sub>P" "e\<^sub>1 \<noteq> {u,v}" "e\<^sub>2 \<in> E\<^sub>P" "e\<^sub>2 \<noteq> {u,v}"
      using \<open>?E\<^sub>C \<subseteq> E\<^sub>P\<close> calculation by auto
    moreover hence "{{u,v},e\<^sub>1,e\<^sub>2} \<subseteq> E\<^sub>P" "card' {{u,v},e\<^sub>1,e\<^sub>2} = 3"
      using calculation by auto
    moreover have "degree {{u,v},e\<^sub>1,e\<^sub>2} u = 3"
      unfolding degree_def using calculation by auto
    ultimately have "degree E\<^sub>P u \<ge> 3"
      using subset_edges_less_degree[of "{{u,v},e\<^sub>1,e\<^sub>2}" E\<^sub>P u] by auto
    hence "enat 3 \<le> enat 2"
      using degree_edges_of_path_leq_2[OF \<open>distinct P\<close> \<open>length P > 1\<close> \<open>u \<in> set P\<close>]
      by (metis numeral_eq_enat dual_order.trans) (* TODO: clean up \<open>enat\<close> stuff *)
    thus ?thesis
      using enat_ord_simps by auto
  qed
qed

end

context graph_abs
begin

lemma non_acyclic_path_not_distinct:
  "path E P \<Longrightarrow> \<not> is_acyclic (set (edges_of_path P)) \<Longrightarrow> \<not> distinct P"
  by (intro path_edges_subgraph_abs.non_acyclic_path_not_distinct) unfold_locales

lemma distinct_path_is_acyclic:
  "path E P \<Longrightarrow> distinct P \<Longrightarrow> is_acyclic (set (edges_of_path P))"
  using non_acyclic_path_not_distinct by auto

end

section \<open>Trees\<close>

definition "is_tree T \<equiv> is_connected T \<and> is_acyclic T"

lemma is_treeI: "is_connected T \<Longrightarrow> is_acyclic T \<Longrightarrow> is_tree T"
  unfolding is_tree_def by auto

lemma is_treeE:
  assumes "is_tree T"
  shows "is_connected T" "is_acyclic T"
  using assms[unfolded is_tree_def] by auto

section \<open>Spanning Trees\<close>

definition "is_st E T \<equiv> T \<subseteq> E \<and> Vs E = Vs T \<and> is_tree T"

lemma is_stI: "T \<subseteq> E \<Longrightarrow> Vs E = Vs T \<Longrightarrow> is_tree T \<Longrightarrow> is_st E T"
  unfolding is_st_def by auto

lemma is_stE:
  assumes "is_st E T"
  shows "T \<subseteq> E" "Vs E = Vs T" "is_tree T"
  using assms[unfolded is_st_def] by auto

context graph_abs
begin

lemma st_is_graph:
  assumes "is_st E T"
  shows "graph_invar T"
  using assms by (intro graph_subset[OF graph is_stE(1)])

lemma st_card_Vs:
  assumes "is_st E T"
  obtains "T = {}" | "card (Vs T) \<ge> 2"
proof cases
  assume "T \<noteq> {}"
  moreover have "graph_invar T"
    using assms by (intro graph_subset[OF graph]) (elim is_stE)
  ultimately have "card (Vs T) \<ge> 2"
    by (intro card_vertices_ge2)
  thus ?thesis
    using that by auto
qed auto

end

abbreviation "cost_of_st c T \<equiv> sum c T"

section \<open>Minimum Spanning Tree\<close>

definition "is_mst E c T \<equiv> is_st E T \<and> (\<forall>T'. is_st E T' \<longrightarrow> cost_of_st c T \<le> cost_of_st c T')"

lemma is_mstI:
  assumes "is_st E T" "\<And>T'. is_st E T' \<Longrightarrow> cost_of_st c T \<le> cost_of_st c T'"
  shows "is_mst E c T"
  using assms by (auto simp: is_mst_def)

lemma is_mstE:
  assumes "is_mst E c T"
  shows "is_st E T" "\<And>T'. is_st E T' \<Longrightarrow> cost_of_st c T \<le> cost_of_st c T'"
  using assms[unfolded is_mst_def] by auto

lemma is_mstE2:
  assumes "is_mst E c T"
  shows "T \<subseteq> E" "Vs E = Vs T" "is_tree T" "\<And>T'. is_st E T' \<Longrightarrow> cost_of_st c T \<le> cost_of_st c T'"
  using assms is_mstE is_stE by fastforce+

context w_graph_abs
begin

abbreviation "cost_of_st\<^sub>c T \<equiv> sum c T"

lemma mst_eq_cost:
  assumes "is_mst E c T\<^sub>1" "is_mst E c T\<^sub>2"
  shows "cost_of_st\<^sub>c T\<^sub>1 = cost_of_st\<^sub>c T\<^sub>2"
proof (rule antisym)
  have "is_st E T\<^sub>1" and "is_st E T\<^sub>2"
    using assms by (auto elim: is_mstE)
  show "cost_of_st c T\<^sub>1 \<le> cost_of_st c T\<^sub>2" and "cost_of_st c T\<^sub>2 \<le> cost_of_st c T\<^sub>1"
    using assms by (auto elim: is_mstE)
qed

end

locale mst =
  w_graph_abs E c for E :: "'a set set" and c +
  fixes comp_mst :: "('a set \<Rightarrow> 'b) \<Rightarrow> 'a set set \<Rightarrow> 'a set set"
  assumes mst: "\<And>E. is_connected E \<Longrightarrow> is_mst E c (comp_mst c E)"
begin

end

end


(* Author: Hauke Brinkop and Tobias Nipkow *)

section \<open>Pairing Heaps\<close>

subsection \<open>Binary Tree Representation\<close>

theory Pairing_Heap_Tree_Analysis
imports
  Pairing_Heap.Pairing_Heap_Tree
  Amortized_Framework
  Priority_Queue_ops_merge
  Lemmas_log
begin

text
\<open>Verification of logarithmic bounds on the amortized complexity of
pairing heaps \<^cite>\<open>"FredmanSST86" and "Brinkop"\<close>.\<close>

fun len :: "'a tree \<Rightarrow> nat" where
  "len Leaf = 0"
| "len (Node _ _ r) = 1 + len r"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
  "\<Phi> Leaf = 0"
| "\<Phi> (Node l x r) = log 2 (size (Node l x r)) + \<Phi> l + \<Phi> r"

lemma link_size[simp]: "size (link hp) = size hp"
  by (cases hp rule: link.cases) simp_all

lemma size_pass\<^sub>1: "size (pass\<^sub>1 hp) = size hp"
  by (induct hp rule: pass\<^sub>1.induct) simp_all

lemma size_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> size (merge h1 h2) = size h1 + size h2"
  by (simp split: tree.splits)

lemma \<Delta>\<Phi>_insert: "is_root hp \<Longrightarrow> \<Phi> (insert x hp) - \<Phi> hp \<le> log 2  (size hp + 1)"
  by (simp split: tree.splits)

lemma \<Delta>\<Phi>_merge:
  assumes "h1 = Node hs1 x1 Leaf" "h2 = Node hs2 x2 Leaf"
  shows "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 \<le> log 2 (size h1 + size h2) + 1"
proof -
  let ?hs = "Node hs1 x1 (Node hs2 x2 Leaf)"
  have "\<Phi> (merge h1 h2) = \<Phi> (link ?hs)" using assms by simp
  also have "\<dots> = \<Phi> hs1 + \<Phi> hs2 + log 2 (size hs1 + size hs2 + 1) + log 2 (size hs1 + size hs2 + 2)"
    by (simp add: algebra_simps)
  also have "\<dots> = \<Phi> hs1 + \<Phi> hs2 + log 2 (size hs1 + size hs2 + 1) + log 2 (size h1 + size h2)"
     using assms by simp
  finally have "\<Phi> (merge h1 h2) = \<dots>" .
  have "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 =
   log 2 (size hs1 + size hs2 + 1) + log 2 (size h1 + size h2)
   - log 2 (size hs1 + 1) - log 2 (size hs2 + 1)"
     using assms by (simp add: algebra_simps)
  also have "\<dots> \<le> log 2 (size h1 + size h2) + 1"
    using ld_le_2ld[of "size hs1" "size hs2"] assms by (simp add: algebra_simps)
  finally show ?thesis .
qed

fun ub_pass\<^sub>1 :: "'a tree \<Rightarrow> real" where
  "ub_pass\<^sub>1 (Node _ _ Leaf) = 0"
| "ub_pass\<^sub>1 (Node hs1 _ (Node hs2 _ Leaf)) = 2*log 2 (size hs1 + size hs2 + 2)"
| "ub_pass\<^sub>1 (Node hs1 _ (Node hs2 _ hs)) = 2*log 2 (size hs1 + size hs2 + size hs + 2)
    - 2*log 2 (size hs) - 2 + ub_pass\<^sub>1 hs"

lemma \<Delta>\<Phi>_pass1_ub_pass1: "hs \<noteq> Leaf \<Longrightarrow> \<Phi> (pass\<^sub>1 hs) - \<Phi> hs  \<le> ub_pass\<^sub>1 hs"
proof (induction hs rule: ub_pass\<^sub>1.induct)
  case (2 lx x ly y)
  have "log 2  (size lx + size ly + 1) - log 2  (size ly + 1)
    \<le> log 2 (size lx + size ly + 1)" by simp
  also have "\<dots> \<le> log 2 (size lx + size ly + 2)" by simp
  also have "\<dots> \<le> 2*\<dots>" by simp
  finally show ?case by (simp add: algebra_simps)
next
  case (3 lx x ly y lz z rz)
  let ?ry = "Node lz z rz"
  let ?rx = "Node ly y ?ry"
  let ?h = "Node lx x ?rx"
  let ?t ="log 2 (size lx + size ly + 1) - log 2 (size ly + size ?ry + 1)"
  have "\<Phi> (pass\<^sub>1 ?h) - \<Phi> ?h \<le> ?t + ub_pass\<^sub>1 ?ry"
    using "3.IH" by (simp add: size_pass\<^sub>1 algebra_simps)
  moreover have "log 2 (size lx + size ly + 1) + 2 * log 2 (size ?ry) + 2
    \<le> 2 * log 2 (size ?h) + log 2 (size ly + size ?ry + 1)" (is "?l \<le> ?r")
  proof -
    have "?l \<le> 2 * log 2 (size lx + size ly + size ?ry + 1) + log 2 (size ?ry)"
      using ld_sum_inequality [of "size lx + size ly + 1" "size ?ry"] by simp
    also have "\<dots> \<le> 2 * log 2 (size lx + size ly + size ?ry + 2) + log 2 (size ?ry)"
      by simp
    also have "\<dots> \<le> ?r" by simp
    finally show ?thesis .
  qed
  ultimately show ?case by simp
qed simp_all

lemma \<Delta>\<Phi>_pass1: assumes "hs \<noteq> Leaf"
  shows "\<Phi> (pass\<^sub>1 hs) - \<Phi> hs \<le> 2*log 2 (size hs) - len hs + 2"
proof -
  from assms have "ub_pass\<^sub>1 hs \<le> 2*log 2 (size hs) - len hs + 2"
    by (induct hs rule: ub_pass\<^sub>1.induct) (simp_all add: algebra_simps)
  thus ?thesis using \<Delta>\<Phi>_pass1_ub_pass1 [OF assms] order_trans by blast
qed

lemma \<Delta>\<Phi>_pass2: "hs \<noteq> Leaf \<Longrightarrow> \<Phi> (pass\<^sub>2 hs) - \<Phi> hs \<le> log 2 (size hs)"
proof (induction hs)
  case (Node lx x rx)
  thus ?case
  proof (cases rx)
    case 1: (Node ly y ry)
    let ?h = "Node lx x rx"
    obtain la a where 2: "pass\<^sub>2 rx = Node la a Leaf"
      using pass\<^sub>2_struct 1 by force
    hence 3: "size rx = size \<dots>" using size_pass\<^sub>2 by metis
    have link: "\<Phi>(link(Node lx x (pass\<^sub>2 rx))) - \<Phi> lx - \<Phi> (pass\<^sub>2 rx) =
          log 2 (size lx + size rx + 1) + log 2 (size lx + size rx) - log 2 (size rx)"
      using 2 3 by (simp add: algebra_simps)
    have "\<Phi> (pass\<^sub>2 ?h) - \<Phi> ?h =
        \<Phi> (link (Node lx x (pass\<^sub>2 rx))) - \<Phi> lx - \<Phi> rx - log 2 (size lx + size rx + 1)"
      by (simp)
    also have "\<dots> = \<Phi> (pass\<^sub>2 rx) - \<Phi> rx + log 2 (size lx + size rx) - log 2 (size rx)"
      using link by linarith
    also have "\<dots> \<le> log 2 (size lx + size rx)"
      using Node.IH 1 by simp
    also have "\<dots> \<le> log 2 (size ?h)" using 1 by simp
    finally show ?thesis .
  qed simp
qed simp
(*
lemma \<Delta>\<Phi>_mergepairs: assumes "hs \<noteq> Leaf"
  shows "\<Phi> (merge_pairs hs) - \<Phi> hs \<le> 3 * log 2 (size hs) - len hs + 2"
proof -
  have "pass\<^sub>1 hs \<noteq> Leaf" by (metis assms eq_size_0 size_pass\<^sub>1)
  with assms \<Delta>\<Phi>_pass1[of hs] \<Delta>\<Phi>_pass2[of "pass\<^sub>1 hs"]
  show ?thesis by (auto simp add: size_pass\<^sub>1 pass12_merge_pairs)
qed
*)
lemma \<Delta>\<Phi>_del_min: assumes "hs \<noteq> Leaf"
shows "\<Phi> (del_min (Node hs x Leaf)) - \<Phi> (Node hs x Leaf)
  \<le> 3*log 2 (size hs) - len hs + 2"
proof -
  let ?h = "Node hs x Leaf"
  let ?\<Delta>\<Phi>\<^sub>1 = "\<Phi> hs - \<Phi> ?h"
  let ?\<Delta>\<Phi>\<^sub>2 = "\<Phi>(pass\<^sub>2(pass\<^sub>1 hs)) - \<Phi> hs"
  let ?\<Delta>\<Phi> = "\<Phi> (del_min ?h) - \<Phi> ?h"
  have "\<Phi>(pass\<^sub>2(pass\<^sub>1 hs)) - \<Phi> (pass\<^sub>1 hs) \<le> log 2  (size hs)"
    using \<Delta>\<Phi>_pass2 [of "pass\<^sub>1 hs"] assms by(metis eq_size_0 size_pass\<^sub>1)
  moreover have "\<Phi> (pass\<^sub>1 hs) - \<Phi> hs \<le>  2*\<dots> - len hs + 2"
    by(rule \<Delta>\<Phi>_pass1[OF assms])
  moreover have "?\<Delta>\<Phi> \<le> ?\<Delta>\<Phi>\<^sub>2" by simp
  ultimately show ?thesis using assms by linarith
qed

lemma is_root_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> is_root (merge h1 h2)"
by (simp split: tree.splits)

lemma is_root_insert: "is_root h \<Longrightarrow> is_root (insert x h)"
by (simp split: tree.splits)

lemma is_root_del_min:
  assumes "is_root h" shows "is_root (del_min h)"
proof (cases h)
  case [simp]: (Node lx x rx)
  have "rx = Leaf" using assms by simp
  thus ?thesis
  proof (cases lx)
    case (Node ly y ry)
    then obtain la a ra where "pass\<^sub>1 lx = Node a la ra"
      using pass\<^sub>1_struct by blast
    moreover obtain lb b where "pass\<^sub>2 \<dots> = Node b lb Leaf"
      using pass\<^sub>2_struct by blast
    ultimately show ?thesis using assms by simp
  qed simp
qed simp

lemma pass\<^sub>1_len: "len (pass\<^sub>1 h) \<le> len h"
by (induct h rule: pass\<^sub>1.induct) simp_all

fun exec :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec Del_min [h] = del_min h" |
"exec (Insert x) [h] = insert x h" |
"exec Merge [h1,h2] = merge h1 h2"

fun T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 :: "'a tree \<Rightarrow> nat" where
  "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 Leaf = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (Node _ _ Leaf) = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (Node _ _ (Node _ _ ry)) = T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 ry + 1"

fun T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 :: "'a tree \<Rightarrow> nat" where
  "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 Leaf = 1"
| "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (Node _ _ rx) = T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 rx + 1"

fun cost :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
  "cost Empty [] = 1"
| "cost Del_min [Leaf] = 1"
| "cost Del_min [Node lx _  _] = T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 lx) + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 lx"
| "cost (Insert a) _ = 1"
| "cost Merge _ = 1"

fun U :: "'a :: linorder op \<Rightarrow> 'a tree list \<Rightarrow> real" where
  "U Empty [] = 1"
| "U (Insert a) [h] = log 2 (size h + 1) + 1"
| "U Del_min [h] = 3*log 2 (size h + 1) + 4"
| "U Merge [h1,h2] = log 2 (size h1 + size h2 + 1) + 2"

interpretation Amortized
where arity = arity and exec = exec and cost = cost and inv = is_root
and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (1 _ f) thus ?case using is_root_insert is_root_del_min is_root_merge
    by (cases f) (auto simp: numeral_eq_Suc)
next
  case (2 s) show ?case by (induct s) simp_all
next
  case (3 ss f) show ?case
  proof (cases f)
    case Empty with 3 show ?thesis by(auto)
  next
    case (Insert x)
    then obtain h where "ss = [h]" "is_root h" using 3 by auto
    thus ?thesis using Insert \<Delta>\<Phi>_insert 3 by auto
  next
    case [simp]: (Del_min)
    then obtain h where [simp]: "ss = [h]" using 3 by auto
    show ?thesis
    proof (cases h)
      case [simp]: (Node lx x rx)
      have "T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 lx) + T\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 lx \<le> len lx + 2"
        by (induct lx rule: pass\<^sub>1.induct) simp_all
      hence "cost f ss \<le> \<dots>" by simp
      moreover have "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size h + 1) - len lx + 2"
      proof (cases lx)
        case [simp]: (Node ly y ry)
        have "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size lx) - len lx + 2"
          using  \<Delta>\<Phi>_del_min[of "lx" "x"] 3 by simp
        also have "\<dots> \<le> 3*log 2 (size h + 1) - len lx + 2" by fastforce
        finally show ?thesis by blast
      qed (insert 3, simp)
      ultimately show ?thesis by auto
    qed simp
  next
    case [simp]: Merge
    then obtain h1 h2 where [simp]: "ss = [h1,h2]" and 1: "is_root h1" "is_root h2"
      using 3 by (auto simp: numeral_eq_Suc)
    show ?thesis
    proof (cases h1)
      case Leaf thus ?thesis by (cases h2) auto
    next
      case h1: Node
      show ?thesis
      proof (cases h2)
        case Leaf thus ?thesis using h1 by simp
      next
        case h2: Node
        have "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 \<le> log 2 (real (size h1 + size h2)) + 1"
          apply(rule \<Delta>\<Phi>_merge) using h1 h2 1 by auto
        also have "\<dots> \<le> log 2 (size h1 + size h2 + 1) + 1" by (simp add: h1)
        finally show ?thesis by(simp add: algebra_simps)
      qed
    qed
  qed
qed

end


section \<open>Parity of list append\<close>

theory Parity_Extras
imports Parity_Inversions
begin

primrec
  occ :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
where
  "occ [] x = 0"
| "occ (y # ys) x = occ ys x + (if x = y then 1 else 0)"

lemma occ_member: "x \<in> set xs = (occ xs x > 0)"
  by (induct xs) auto

lemma append_occ:
  "occ (xs @ ys) x = occ xs x + occ ys x"
  by (induct xs) auto

lemma filter_le_empty:
  fixes x :: nat
  shows "\<forall> y \<in> set ys. x \<le> y \<Longrightarrow> [y \<leftarrow> ys . y < x] = []"
  by (rule filter_False) (auto simp: not_less)

lemma sorted_parity: "sorted xs \<Longrightarrow> parity xs"
  by (induct rule: sorted.induct) (auto simp: filter_le_empty)

lemma parity_app:
  "parity (xs @ ys) \<longleftrightarrow> parity xs = parity ys = even (\<Sum>x\<leftarrow>xs. length [y \<leftarrow> ys . x > y])"
  by (induct xs) auto

lemma concat_cons_cons: "concat (xs # ys # zss) = (xs @ ys) @ concat zss"
  by simp

lemma occ_nil_eq:
  assumes "occ xs = occ []"
  shows "xs = []"
  proof (cases xs)
    case (Cons x xs) show ?thesis
      using fun_cong[where x=x, OF assms] unfolding Cons by simp
  qed auto

lemma sum_list_cong:
  fixes f g :: "nat \<Rightarrow> nat"
  assumes "occ xs = occ ys" "\<And>x. x \<in> set xs \<Longrightarrow> f x = g x"
  shows "(\<Sum>x\<leftarrow>xs. f x) = (\<Sum>y\<leftarrow>ys. g y)"
  using assms
  proof (induct xs arbitrary: ys)
    case Nil show ?case unfolding occ_nil_eq[OF Nil(1)[symmetric]] by simp
  next
    case (Cons x xs)
    obtain ps qs where decomp: "ys = ps @ x # qs"
      by (metis Cons(2) list.set_intros(1) occ_member split_list)
    have occ: "\<And>z. occ xs z = occ (ps @ qs) z"
      using fun_cong[OF Cons(2)] unfolding decomp
      by (simp add: append_occ)
    thus ?case using Cons(1,3) unfolding decomp by auto
  qed

lemma length_filter_sum_list:
  "length [x \<leftarrow> xs . p x] = sum_list [ if p x then 1 else 0 . x \<leftarrow> xs ]"
  by (induct xs) auto

lemma length_filter_cong:
  assumes "occ xs = occ ys" "\<And>x. x \<in> set xs \<Longrightarrow> p x = q x"
  shows "length [x \<leftarrow> xs . p x] = length [y \<leftarrow> ys . q y]"
  unfolding length_filter_sum_list by (rule sum_list_cong) (auto simp: assms)

context
  fixes xs xs' ys ys' :: "nat list"
  assumes occ: "occ xs = occ xs'" "occ ys = occ ys'"
begin

lemma sum_list_filter_length_cong:
  "(\<Sum>x\<leftarrow>xs. length [y\<leftarrow>ys . y < x]) = (\<Sum>x\<leftarrow>xs'. length [y\<leftarrow>ys' . y < x])"
  by (intro sum_list_cong occ length_filter_cong refl)

lemma parity_app_eq:
  "parity (xs @ ys) = parity (xs' @ ys') \<longleftrightarrow> (parity xs = parity xs') = (parity ys = parity ys')"
  by (auto simp: parity_app sum_list_filter_length_cong)

end

lemmas parity_app_eq_left
  = parity_app_eq[of xs xs ys ys' for xs ys ys', simplified]

lemmas parity_app_eq_right
  = parity_app_eq[of xs xs' ys ys for xs xs' ys, simplified]

end


section \<open>Optimizations for Code Integer\<close>
theory Optimize_Integer
imports
  Complex_Main
  "HOL-Library.Code_Target_Numeral"
begin

text \<open>shallowly embed log and power\<close>

definition log2::"int \<Rightarrow> int"
  where "log2 a = floor (log 2 (of_int a))"

context includes integer.lifting begin

lift_definition log2_integer :: "integer \<Rightarrow> integer"
  is "log2 :: int \<Rightarrow> int"
  .

end

code_printing
  constant "log2_integer :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.log2"

definition power_int::"int \<Rightarrow> int \<Rightarrow> int"
  where "power_int a b = a ^ (nat b)"

context includes integer.lifting begin

lift_definition power_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "power_int :: int \<Rightarrow> int \<Rightarrow> int"
  .

end

code_printing
  constant "power_integer :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.pow ((_), (_))"

lemma [code]: "power_int (int_of_integer a) (int_of_integer b) = int_of_integer (power_integer a b)"
  by (simp add: power_integer.rep_eq)

end


theory "FMap-Nominal-Unused"
  imports "FMap-Nominal" "FMap-Unused"
begin

subsubsection {* Finite maps have finite support *}

lemma map_between_finite:
  assumes "finite A"
  and "finite B"
  shows "finite {m. dom m = A \<and> ran m = B}"
proof (rule finite_imageD[OF finite_subset])
  def f  \<equiv> "\<lambda> m. (\<lambda> x \<in> A. (the (m x) :: 'b))"
  def g  \<equiv> "\<lambda> f x. (if x \<in> A then Some (f x :: 'b) else None)"
  show "f ` {m. dom m = A \<and> ran m = B} \<subseteq> extensional_funcset A B"
    by (auto simp add: extensional_funcset_def ran_def f_def)
  show "finite (extensional_funcset A B)"
    by (rule finite_PiE[OF assms])
  show "inj_on f {m. dom m = A \<and> ran m = B}"
    apply(rule inj_on_inverseI[of _ g])
    unfolding f_def g_def
    apply (auto simp add: dom_def fun_eq_iff)
    by (metis not_Some_eq)
qed

lemma perm_finite: "finite (dom m2) \<Longrightarrow> finite {m1. dom m1 = dom m2 \<and> ran m1 = ran m2}"
  by (rule map_between_finite[OF _ finite_range])

lemma supp_map_union:
  assumes "finite (dom (m:: 'a::fs \<rightharpoonup> 'b::fs))"
  shows  "supp m = (supp (dom m) \<union> supp (ran m))"
proof-
have "finite (ran m)" using assms by (rule finite_range)
{
  fix x

  let ?f = "(\<lambda>b . (x \<rightleftharpoons> b) \<bullet> m)"

  assume "x \<notin> supp (ran m)" and "x \<notin> supp (dom m)"

  { fix m'
    assume "dom m = dom m'" and "ran m = ran m'"
    assume "m' \<noteq> m"
    then obtain d where "m' d \<noteq> m d" by auto
    hence "d \<in> dom m" and "d \<in> dom m'" using `dom m = dom m'` by (auto simp add: dom_def)

    have "x \<notin> supp d" using `finite (dom m)` `x \<notin> supp (dom m)` `d \<in> dom m`
      by (metis supp_set_elem_finite)

    have "{b. ?f b d = m' d} = {b. (x \<rightleftharpoons> b) \<bullet> m ( (x \<rightleftharpoons> b) \<bullet> d) = m' d}"
      by (metis (hide_lams, no_types) Nominal2_Base.swap_commute eqvt_bound eqvt_lambda permute_swap_cancel2)
    also have "... =  (\<Union> d' \<in> dom m . {b . (x \<rightleftharpoons> b) \<bullet> d = d' \<and> (x \<rightleftharpoons> b) \<bullet> m d' = m' d})"
      using `d \<in> dom m'` `dom m = dom m'`
      apply auto
      apply (metis Some_eqvt domD domI permute_fun_app_eq permute_self permute_swap_cancel swap_eqvt)
      apply (metis permute_self permute_swap_cancel swap_eqvt)
      apply (metis permute_self permute_swap_cancel swap_eqvt)
      done
    finally
    have "finite ({b. ?f b d = m' d})"
      apply (rule ssubst)
      proof
        fix d'
        assume "d' \<in> dom m"

        have "d \<noteq> d' \<or> m d' \<noteq> m' d"
          using `m' d \<noteq> m d` by auto
        moreover
        { assume  "d \<noteq> d'"
          hence "finite {b . (x \<rightleftharpoons> b) \<bullet> d = d'}" using `x \<notin> supp d`
            by (auto elim!: finite_subset[rotated] simp add: supp_def)
        }
        moreover
        { assume  "d = d'" and "m d' \<noteq> m' d"

          have "the (m d') \<in> ran m" using `d' \<in> dom m`
            by (auto simp add: ran_def)
          hence "x \<notin> supp (the (m d'))" using `finite (ran m)` `ran m = ran m'` `x \<notin> supp (ran m)`
            by (metis supp_set_elem_finite)
          hence "x \<notin> supp (m d')" using `d' \<in> dom m`
            by (auto simp add: ran_def supp_Some)
          hence "finite {b. (x \<rightleftharpoons> b) \<bullet> m d' = m' d}" using `m d' \<noteq> m' d`
            by (auto elim!: finite_subset[rotated] simp add: supp_def)
        }
        ultimately
        have "finite {b . (x \<rightleftharpoons> b) \<bullet> d = d'} \<or> finite {b. (x \<rightleftharpoons> b) \<bullet> m d' = m' d}" by auto
        thus "finite {b . (x \<rightleftharpoons> b) \<bullet> d = d' \<and> (x \<rightleftharpoons> b) \<bullet> m d' = m' d}" by auto
      next
        show "finite (dom m)" by fact
      qed
    hence "finite ({b. ?f b = m'})"
      by (auto elim: finite_subset[rotated])
  }
  moreover
    have "finite {m'. dom m' = dom m \<and> ran m' = ran m}" using perm_finite[OF `finite (dom m)`] .
    hence "finite {m'. dom m' = dom m \<and> ran m' = ran m \<and> m' \<noteq> m}"
      by (auto elim!: finite_subset[rotated])
  ultimately
  have "finite (\<Union> {{b. (x \<rightleftharpoons> b) \<bullet> m = m'} | m'. dom m' = dom m \<and> ran m' = ran m \<and> m' \<noteq> m})"
    by auto
  hence "finite {b. dom (?f b) = dom m \<and> ran (?f b) = ran m \<and> ?f b \<noteq> m}"
    apply (auto elim!: finite_subset[rotated])
    by (metis (lifting, full_types) mem_Collect_eq)

  with `x \<notin> supp (ran m)` and `x \<notin> supp (dom m)`
  have "x \<notin> supp m"
    unfolding supp_def
    apply simp
    apply (rule finite_subset[of _ "
          {b. dom ((x \<rightleftharpoons> b) \<bullet> m) \<noteq> dom m} \<union> {b. ran ((x \<rightleftharpoons> b) \<bullet> m) \<noteq> ran m}
              \<union> {b. dom (?f b) = dom m \<and> ran (?f b) = ran m \<and> ?f b \<noteq> m}"])
    by auto
} moreover
{ fix x
  have "{b. (x \<rightleftharpoons> b) \<bullet> dom m \<noteq> dom m} \<subseteq> {b. (x \<rightleftharpoons> b) \<bullet> m \<noteq> m}" by auto
  hence "x \<in> supp (dom m) \<Longrightarrow> x \<in> supp m"
  by (auto elim!: infinite_super simp add: supp_def)
} moreover
{ fix x
  have "{b. (x \<rightleftharpoons> b) \<bullet> ran m \<noteq> ran m} \<subseteq> {b. (x \<rightleftharpoons> b) \<bullet> m \<noteq> m}" by auto
  hence "x \<in> supp (ran m) \<Longrightarrow> x \<in> supp m"
  by (auto elim!: infinite_super simp add: supp_def)
} ultimately
show ?thesis by auto
qed

lemma supp_fmap_transfer[transfer_rule]:
  "(pcr_fmap op= op= ===> op =) supp supp"
  unfolding supp_def[abs_def] by transfer_prover

lemma supp_fmap:
  "supp (m:: 'a::fs f\<rightharpoonup> 'b::fs) = (supp (fdom m) \<union> supp (fran m))"
by transfer(erule supp_map_union)

instance "fmap" :: (fs,fs) fs
  by (default, auto intro: finite_sets_supp simp add: supp_fmap)

subsubsection {* Freshness and support *}

lemma supp_fmap_pure:
  fixes \<rho> :: "'a::fs f\<rightharpoonup> 'b::pure"
  shows "supp \<rho> = supp (fdom \<rho>)"
  by (metis supp_fmap Un_empty_right pure_supp)

lemma fresh_fmap_pure:
  fixes \<rho> :: "'a::at_base f\<rightharpoonup> 'b::pure"
  shows "atom a \<sharp> \<rho> \<longleftrightarrow> a \<notin> fdom \<rho>"
  by (auto simp add: fresh_def supp_fmap_pure supp_finite_set_at_base)

lemma fresh_fdom[simp]: "atom x \<sharp> (f :: 'a::at_base f\<rightharpoonup> 'b::fs) \<Longrightarrow> x \<notin> fdom f"
  apply (subst (asm) fresh_def)
  apply (simp  add: supp_fmap)
  apply (subst (asm) (1 2) fresh_def[symmetric])
  apply (simp add: fresh_finite_set_at_base[OF finite_fdom] pure_fresh)
  done

lemma supp_fmap_upd[simp]:
  "supp (m((x::'a::fs) f\<mapsto> v::'b::fs)) = supp (fmap_delete x m) \<union> supp x \<union> supp v"
  apply (subst (1 2) supp_fmap)
  apply (subst (1 2 3 4) supp_of_finite_sets)
  apply simp_all[4]
  apply auto
  done

lemma supp_fmap_restr_subset:
  fixes m :: "'a::fs f\<rightharpoonup> 'b::fs"
  shows "supp (m f|` S) \<subseteq> supp m"
  apply (induction m)
  apply simp
  apply (case_tac "x \<in> S")
  apply auto
  done

lemma fresh_fmap_restr_subset:
  fixes m :: "'a::fs f\<rightharpoonup> 'b::fs"
  shows "a \<sharp> m \<Longrightarrow> a \<sharp> m f|` S"
  using supp_fmap_restr_subset
  by (auto simp add: fresh_def)

lemma fresh_fmap_upd_eq:
  "a \<sharp> m((x::'a::fs) f\<mapsto> v::'b::fs) \<longleftrightarrow> (a \<sharp> (fmap_delete x m) \<and> a \<sharp> x \<and> a \<sharp> v)"
  unfolding fresh_def by simp

lemma fresh_lookup:
  fixes m :: "'a::fs f\<rightharpoonup> 'b::fs"
  shows "atom x \<sharp> m \<Longrightarrow> lookup m y = Some v \<Longrightarrow> atom x \<sharp> v"
  by (induction m)
     (auto simp add: lookup_fmap_upd_eq fresh_fmap_upd_eq split:if_splits)

lemma fresh_lookup_fdom:
  fixes m :: "'a::fs f\<rightharpoonup> 'b::fs"
  shows "a \<sharp> m \<Longrightarrow> x \<in> fdom m \<Longrightarrow> a \<sharp> m f! x"
  by (metis (full_types) fmap_upd_noop fresh_fmap_upd_eq)

lemma fresh_star_fmap_upd_eq:
  "a \<sharp>* m((x::'a::fs) f\<mapsto> v::'b::fs) \<longleftrightarrow> (a \<sharp>* (fmap_delete x m) \<and> a \<sharp>* x \<and> a \<sharp>* v)"
by (metis fresh_fmap_upd_eq fresh_star_def)

lemma supp_fmap_delete_subset:
  "supp (fmap_delete x m) \<subseteq> supp (m :: 'a::at_base f\<rightharpoonup> 'b::fs)"
  by (auto simp add: supp_fmap simp del: fdom_fmap_delete
        dest: set_mp[OF supp_mono[OF finite_fdom fdom_fmap_delete_subset]]
        dest: set_mp[OF supp_mono[OF finite_fran fran_fmap_delete_subset]])

lemma fresh_fmap_delete_subset:
  "a \<sharp>  (m :: 'a::at_base f\<rightharpoonup> 'b::fs) \<Longrightarrow> a \<sharp> fmap_delete x m"
  using supp_fmap_delete_subset
  by (auto simp add: fresh_def)

lemma fresh_fmap_copy_subset:
  "a \<sharp> (m :: 'a::at_base f\<rightharpoonup> 'b::fs) \<Longrightarrow> a \<sharp> y \<Longrightarrow> a \<sharp> fmap_copy m x y"
  by (auto simp add: fresh_def supp_fmap supp_of_finite_insert  simp del: fdom_fmap_copy
        dest: set_mp[OF supp_mono[OF iffD2[OF finite_insert, OF finite_fdom] fdom_fmap_copy_subset]]
        dest: set_mp[OF supp_mono[OF finite_fran fran_fmap_copy_subset]])

lemma fresh_fun_merge_subset:
  "a \<sharp> (m1 :: 'a::at_base f\<rightharpoonup> 'b::fs) \<Longrightarrow> a \<sharp> m2 \<Longrightarrow> a \<sharp> m1 f++ m2"
  by (auto simp add: fresh_def supp_fmap supp_of_finite_insert supp_of_finite_union
      dest: set_mp[OF supp_mono[OF finite_UnI[OF finite_fran finite_fran] fran_fun_merge_subset]])

end