(*  Title:      HOL/Library/Extended_Nat.thy
    Author:     David von Oheimb, TU Muenchen;  Florian Haftmann, TU Muenchen
    Contributions: David Trachtenherz, TU Muenchen
*)

section {* Extended natural numbers (i.e. with infinity) *}

theory Extended_Nat
imports Main Countable
begin

class infinity =
  fixes infinity :: "'a"

notation (xsymbols)
  infinity  ("\<infinity>")

notation (HTML output)
  infinity  ("\<infinity>")

subsection {* Type definition *}

text {*
  We extend the standard natural numbers by a special value indicating
  infinity.
*}

typedef enat = "UNIV :: nat option set" ..

text {* TODO: introduce enat as coinductive datatype, enat is just @{const of_nat} *}

definition enat :: "nat \<Rightarrow> enat" where
  "enat n = Abs_enat (Some n)"

instantiation enat :: infinity
begin
  definition "\<infinity> = Abs_enat None"
  instance proof qed
end

instance enat :: countable
proof
  show "\<exists>to_nat::enat \<Rightarrow> nat. inj to_nat"
    by (rule exI[of _ "to_nat \<circ> Rep_enat"]) (simp add: inj_on_def Rep_enat_inject)
qed

old_rep_datatype enat "\<infinity> :: enat"
proof -
  fix P i assume "\<And>j. P (enat j)" "P \<infinity>"
  then show "P i"
  proof induct
    case (Abs_enat y) then show ?case
      by (cases y rule: option.exhaust)
         (auto simp: enat_def infinity_enat_def)
  qed
qed (auto simp add: enat_def infinity_enat_def Abs_enat_inject)

declare [[coercion "enat::nat\<Rightarrow>enat"]]

lemmas enat2_cases = enat.exhaust[case_product enat.exhaust]
lemmas enat3_cases = enat.exhaust[case_product enat.exhaust enat.exhaust]

lemma not_infinity_eq [iff]: "(x \<noteq> \<infinity>) = (\<exists>i. x = enat i)"
  by (cases x) auto

lemma not_enat_eq [iff]: "(\<forall>y. x \<noteq> enat y) = (x = \<infinity>)"
  by (cases x) auto

primrec the_enat :: "enat \<Rightarrow> nat"
  where "the_enat (enat n) = n"

subsection {* Constructors and numbers *}

instantiation enat :: "{zero, one}"
begin

definition
  "0 = enat 0"

definition
  "1 = enat 1"

instance ..

end

definition eSuc :: "enat \<Rightarrow> enat" where
  "eSuc i = (case i of enat n \<Rightarrow> enat (Suc n) | \<infinity> \<Rightarrow> \<infinity>)"

lemma enat_0 [code_post]: "enat 0 = 0"
  by (simp add: zero_enat_def)

lemma enat_1 [code_post]: "enat 1 = 1"
  by (simp add: one_enat_def)

lemma enat_0_iff: "enat x = 0 \<longleftrightarrow> x = 0" "0 = enat x \<longleftrightarrow> x = 0"
  by (auto simp add: zero_enat_def)

lemma enat_1_iff: "enat x = 1 \<longleftrightarrow> x = 1" "1 = enat x \<longleftrightarrow> x = 1"
  by (auto simp add: one_enat_def)

lemma one_eSuc: "1 = eSuc 0"
  by (simp add: zero_enat_def one_enat_def eSuc_def)

lemma infinity_ne_i0 [simp]: "(\<infinity>::enat) \<noteq> 0"
  by (simp add: zero_enat_def)

lemma i0_ne_infinity [simp]: "0 \<noteq> (\<infinity>::enat)"
  by (simp add: zero_enat_def)

lemma zero_one_enat_neq [simp]:
  "\<not> 0 = (1\<Colon>enat)"
  "\<not> 1 = (0\<Colon>enat)"
  unfolding zero_enat_def one_enat_def by simp_all

lemma infinity_ne_i1 [simp]: "(\<infinity>::enat) \<noteq> 1"
  by (simp add: one_enat_def)

lemma i1_ne_infinity [simp]: "1 \<noteq> (\<infinity>::enat)"
  by (simp add: one_enat_def)

lemma eSuc_enat: "eSuc (enat n) = enat (Suc n)"
  by (simp add: eSuc_def)

lemma eSuc_infinity [simp]: "eSuc \<infinity> = \<infinity>"
  by (simp add: eSuc_def)

lemma eSuc_ne_0 [simp]: "eSuc n \<noteq> 0"
  by (simp add: eSuc_def zero_enat_def split: enat.splits)

lemma zero_ne_eSuc [simp]: "0 \<noteq> eSuc n"
  by (rule eSuc_ne_0 [symmetric])

lemma eSuc_inject [simp]: "eSuc m = eSuc n \<longleftrightarrow> m = n"
  by (simp add: eSuc_def split: enat.splits)

lemma eSuc_enat_iff: "eSuc x = enat y \<longleftrightarrow> (\<exists>n. y = Suc n \<and> x = enat n)"
  by (cases y) (auto simp: enat_0 eSuc_enat[symmetric])

lemma enat_eSuc_iff: "enat y = eSuc x \<longleftrightarrow> (\<exists>n. y = Suc n \<and> enat n = x)"
  by (cases y) (auto simp: enat_0 eSuc_enat[symmetric])

subsection {* Addition *}

instantiation enat :: comm_monoid_add
begin

definition [nitpick_simp]:
  "m + n = (case m of \<infinity> \<Rightarrow> \<infinity> | enat m \<Rightarrow> (case n of \<infinity> \<Rightarrow> \<infinity> | enat n \<Rightarrow> enat (m + n)))"

lemma plus_enat_simps [simp, code]:
  fixes q :: enat
  shows "enat m + enat n = enat (m + n)"
    and "\<infinity> + q = \<infinity>"
    and "q + \<infinity> = \<infinity>"
  by (simp_all add: plus_enat_def split: enat.splits)

instance proof
  fix n m q :: enat
  show "n + m + q = n + (m + q)"
    by (cases n m q rule: enat3_cases) auto
  show "n + m = m + n"
    by (cases n m rule: enat2_cases) auto
  show "0 + n = n"
    by (cases n) (simp_all add: zero_enat_def)
qed

end

lemma eSuc_plus_1:
  "eSuc n = n + 1"
  by (cases n) (simp_all add: eSuc_enat one_enat_def)

lemma plus_1_eSuc:
  "1 + q = eSuc q"
  "q + 1 = eSuc q"
  by (simp_all add: eSuc_plus_1 ac_simps)

lemma iadd_Suc: "eSuc m + n = eSuc (m + n)"
  by (simp_all add: eSuc_plus_1 ac_simps)

lemma iadd_Suc_right: "m + eSuc n = eSuc (m + n)"
  by (simp only: add.commute[of m] iadd_Suc)

lemma iadd_is_0: "(m + n = (0::enat)) = (m = 0 \<and> n = 0)"
  by (cases m, cases n, simp_all add: zero_enat_def)

subsection {* Multiplication *}

instantiation enat :: comm_semiring_1
begin

definition times_enat_def [nitpick_simp]:
  "m * n = (case m of \<infinity> \<Rightarrow> if n = 0 then 0 else \<infinity> | enat m \<Rightarrow>
    (case n of \<infinity> \<Rightarrow> if m = 0 then 0 else \<infinity> | enat n \<Rightarrow> enat (m * n)))"

lemma times_enat_simps [simp, code]:
  "enat m * enat n = enat (m * n)"
  "\<infinity> * \<infinity> = (\<infinity>::enat)"
  "\<infinity> * enat n = (if n = 0 then 0 else \<infinity>)"
  "enat m * \<infinity> = (if m = 0 then 0 else \<infinity>)"
  unfolding times_enat_def zero_enat_def
  by (simp_all split: enat.split)

instance proof
  fix a b c :: enat
  show "(a * b) * c = a * (b * c)"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show "a * b = b * a"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show "1 * a = a"
    unfolding times_enat_def zero_enat_def one_enat_def
    by (simp split: enat.split)
  show "(a + b) * c = a * c + b * c"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split add: distrib_right)
  show "0 * a = 0"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show "a * 0 = 0"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show "(0::enat) \<noteq> 1"
    unfolding zero_enat_def one_enat_def
    by simp
qed

end

lemma mult_eSuc: "eSuc m * n = n + m * n"
  unfolding eSuc_plus_1 by (simp add: algebra_simps)

lemma mult_eSuc_right: "m * eSuc n = m + m * n"
  unfolding eSuc_plus_1 by (simp add: algebra_simps)

lemma of_nat_eq_enat: "of_nat n = enat n"
  apply (induct n)
  apply (simp add: enat_0)
  apply (simp add: plus_1_eSuc eSuc_enat)
  done

instance enat :: semiring_char_0 proof
  have "inj enat" by (rule injI) simp
  then show "inj (\<lambda>n. of_nat n :: enat)" by (simp add: of_nat_eq_enat)
qed

lemma imult_is_0 [simp]: "((m::enat) * n = 0) = (m = 0 \<or> n = 0)"
  by (auto simp add: times_enat_def zero_enat_def split: enat.split)

lemma imult_is_infinity: "((a::enat) * b = \<infinity>) = (a = \<infinity> \<and> b \<noteq> 0 \<or> b = \<infinity> \<and> a \<noteq> 0)"
  by (auto simp add: times_enat_def zero_enat_def split: enat.split)

subsection {* Numerals *}

lemma numeral_eq_enat:
  "numeral k = enat (numeral k)"
  using of_nat_eq_enat [of "numeral k"] by simp

lemma enat_numeral [code_abbrev]:
  "enat (numeral k) = numeral k"
  using numeral_eq_enat ..

lemma infinity_ne_numeral [simp]: "(\<infinity>::enat) \<noteq> numeral k"
  by (simp add: numeral_eq_enat)

lemma numeral_ne_infinity [simp]: "numeral k \<noteq> (\<infinity>::enat)"
  by (simp add: numeral_eq_enat)

lemma eSuc_numeral [simp]: "eSuc (numeral k) = numeral (k + Num.One)"
  by (simp only: eSuc_plus_1 numeral_plus_one)

subsection {* Subtraction *}

instantiation enat :: minus
begin

definition diff_enat_def:
"a - b = (case a of (enat x) \<Rightarrow> (case b of (enat y) \<Rightarrow> enat (x - y) | \<infinity> \<Rightarrow> 0)
          | \<infinity> \<Rightarrow> \<infinity>)"

instance ..

end

lemma idiff_enat_enat [simp, code]: "enat a - enat b = enat (a - b)"
  by (simp add: diff_enat_def)

lemma idiff_infinity [simp, code]: "\<infinity> - n = (\<infinity>::enat)"
  by (simp add: diff_enat_def)

lemma idiff_infinity_right [simp, code]: "enat a - \<infinity> = 0"
  by (simp add: diff_enat_def)

lemma idiff_0 [simp]: "(0::enat) - n = 0"
  by (cases n, simp_all add: zero_enat_def)

lemmas idiff_enat_0 [simp] = idiff_0 [unfolded zero_enat_def]

lemma idiff_0_right [simp]: "(n::enat) - 0 = n"
  by (cases n) (simp_all add: zero_enat_def)

lemmas idiff_enat_0_right [simp] = idiff_0_right [unfolded zero_enat_def]

lemma idiff_self [simp]: "n \<noteq> \<infinity> \<Longrightarrow> (n::enat) - n = 0"
  by (auto simp: zero_enat_def)

lemma eSuc_minus_eSuc [simp]: "eSuc n - eSuc m = n - m"
  by (simp add: eSuc_def split: enat.split)

lemma eSuc_minus_1 [simp]: "eSuc n - 1 = n"
  by (simp add: one_enat_def eSuc_enat[symmetric] zero_enat_def[symmetric])

(*lemmas idiff_self_eq_0_enat = idiff_self_eq_0[unfolded zero_enat_def]*)

subsection {* Ordering *}

instantiation enat :: linordered_ab_semigroup_add
begin

definition [nitpick_simp]:
  "m \<le> n = (case n of enat n1 \<Rightarrow> (case m of enat m1 \<Rightarrow> m1 \<le> n1 | \<infinity> \<Rightarrow> False)
    | \<infinity> \<Rightarrow> True)"

definition [nitpick_simp]:
  "m < n = (case m of enat m1 \<Rightarrow> (case n of enat n1 \<Rightarrow> m1 < n1 | \<infinity> \<Rightarrow> True)
    | \<infinity> \<Rightarrow> False)"

lemma enat_ord_simps [simp]:
  "enat m \<le> enat n \<longleftrightarrow> m \<le> n"
  "enat m < enat n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::enat)"
  "q < (\<infinity>::enat) \<longleftrightarrow> q \<noteq> \<infinity>"
  "(\<infinity>::enat) \<le> q \<longleftrightarrow> q = \<infinity>"
  "(\<infinity>::enat) < q \<longleftrightarrow> False"
  by (simp_all add: less_eq_enat_def less_enat_def split: enat.splits)

lemma numeral_le_enat_iff[simp]:
  shows "numeral m \<le> enat n \<longleftrightarrow> numeral m \<le> n"
by (auto simp: numeral_eq_enat)

lemma numeral_less_enat_iff[simp]:
  shows "numeral m < enat n \<longleftrightarrow> numeral m < n"
by (auto simp: numeral_eq_enat)

lemma enat_ord_code [code]:
  "enat m \<le> enat n \<longleftrightarrow> m \<le> n"
  "enat m < enat n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::enat) \<longleftrightarrow> True"
  "enat m < \<infinity> \<longleftrightarrow> True"
  "\<infinity> \<le> enat n \<longleftrightarrow> False"
  "(\<infinity>::enat) < q \<longleftrightarrow> False"
  by simp_all

instance by default
  (auto simp add: less_eq_enat_def less_enat_def plus_enat_def split: enat.splits)

end

instance enat :: ordered_comm_semiring
proof
  fix a b c :: enat
  assume "a \<le> b" and "0 \<le> c"
  thus "c * a \<le> c * b"
    unfolding times_enat_def less_eq_enat_def zero_enat_def
    by (simp split: enat.splits)
qed

(* BH: These equations are already proven generally for any type in
class linordered_semidom. However, enat is not in that class because
it does not have the cancellation property. Would it be worthwhile to
a generalize linordered_semidom to a new class that includes enat? *)

lemma enat_ord_number [simp]:
  "(numeral m \<Colon> enat) \<le> numeral n \<longleftrightarrow> (numeral m \<Colon> nat) \<le> numeral n"
  "(numeral m \<Colon> enat) < numeral n \<longleftrightarrow> (numeral m \<Colon> nat) < numeral n"
  by (simp_all add: numeral_eq_enat)

lemma i0_lb [simp]: "(0\<Colon>enat) \<le> n"
  by (simp add: zero_enat_def less_eq_enat_def split: enat.splits)

lemma ile0_eq [simp]: "n \<le> (0\<Colon>enat) \<longleftrightarrow> n = 0"
  by (simp add: zero_enat_def less_eq_enat_def split: enat.splits)

lemma infinity_ileE [elim!]: "\<infinity> \<le> enat m \<Longrightarrow> R"
  by (simp add: zero_enat_def less_eq_enat_def split: enat.splits)

lemma infinity_ilessE [elim!]: "\<infinity> < enat m \<Longrightarrow> R"
  by simp

lemma not_iless0 [simp]: "\<not> n < (0\<Colon>enat)"
  by (simp add: zero_enat_def less_enat_def split: enat.splits)

lemma i0_less [simp]: "(0\<Colon>enat) < n \<longleftrightarrow> n \<noteq> 0"
  by (simp add: zero_enat_def less_enat_def split: enat.splits)

lemma eSuc_ile_mono [simp]: "eSuc n \<le> eSuc m \<longleftrightarrow> n \<le> m"
  by (simp add: eSuc_def less_eq_enat_def split: enat.splits)

lemma eSuc_mono [simp]: "eSuc n < eSuc m \<longleftrightarrow> n < m"
  by (simp add: eSuc_def less_enat_def split: enat.splits)

lemma ile_eSuc [simp]: "n \<le> eSuc n"
  by (simp add: eSuc_def less_eq_enat_def split: enat.splits)

lemma not_eSuc_ilei0 [simp]: "\<not> eSuc n \<le> 0"
  by (simp add: zero_enat_def eSuc_def less_eq_enat_def split: enat.splits)

lemma i0_iless_eSuc [simp]: "0 < eSuc n"
  by (simp add: zero_enat_def eSuc_def less_enat_def split: enat.splits)

lemma iless_eSuc0[simp]: "(n < eSuc 0) = (n = 0)"
  by (simp add: zero_enat_def eSuc_def less_enat_def split: enat.split)

lemma ileI1: "m < n \<Longrightarrow> eSuc m \<le> n"
  by (simp add: eSuc_def less_eq_enat_def less_enat_def split: enat.splits)

lemma Suc_ile_eq: "enat (Suc m) \<le> n \<longleftrightarrow> enat m < n"
  by (cases n) auto

lemma iless_Suc_eq [simp]: "enat m < eSuc n \<longleftrightarrow> enat m \<le> n"
  by (auto simp add: eSuc_def less_enat_def split: enat.splits)

lemma imult_infinity: "(0::enat) < n \<Longrightarrow> \<infinity> * n = \<infinity>"
  by (simp add: zero_enat_def less_enat_def split: enat.splits)

lemma imult_infinity_right: "(0::enat) < n \<Longrightarrow> n * \<infinity> = \<infinity>"
  by (simp add: zero_enat_def less_enat_def split: enat.splits)

lemma enat_0_less_mult_iff: "(0 < (m::enat) * n) = (0 < m \<and> 0 < n)"
  by (simp only: i0_less imult_is_0, simp)

lemma mono_eSuc: "mono eSuc"
  by (simp add: mono_def)

lemma min_enat_simps [simp]:
  "min (enat m) (enat n) = enat (min m n)"
  "min q 0 = 0"
  "min 0 q = 0"
  "min q (\<infinity>::enat) = q"
  "min (\<infinity>::enat) q = q"
  by (auto simp add: min_def)

lemma max_enat_simps [simp]:
  "max (enat m) (enat n) = enat (max m n)"
  "max q 0 = q"
  "max 0 q = q"
  "max q \<infinity> = (\<infinity>::enat)"
  "max \<infinity> q = (\<infinity>::enat)"
  by (simp_all add: max_def)

lemma enat_ile: "n \<le> enat m \<Longrightarrow> \<exists>k. n = enat k"
  by (cases n) simp_all

lemma enat_iless: "n < enat m \<Longrightarrow> \<exists>k. n = enat k"
  by (cases n) simp_all

lemma chain_incr: "\<forall>i. \<exists>j. Y i < Y j ==> \<exists>j. enat k < Y j"
apply (induct_tac k)
 apply (simp (no_asm) only: enat_0)
 apply (fast intro: le_less_trans [OF i0_lb])
apply (erule exE)
apply (drule spec)
apply (erule exE)
apply (drule ileI1)
apply (rule eSuc_enat [THEN subst])
apply (rule exI)
apply (erule (1) le_less_trans)
done

instantiation enat :: "{order_bot, order_top}"
begin

definition bot_enat :: enat where
  "bot_enat = 0"

definition top_enat :: enat where
  "top_enat = \<infinity>"

instance proof
qed (simp_all add: bot_enat_def top_enat_def)

end

lemma finite_enat_bounded:
  assumes le_fin: "\<And>y. y \<in> A \<Longrightarrow> y \<le> enat n"
  shows "finite A"
proof (rule finite_subset)
  show "finite (enat ` {..n})" by blast

  have "A \<subseteq> {..enat n}" using le_fin by fastforce
  also have "\<dots> \<subseteq> enat ` {..n}"
    by (rule subsetI) (case_tac x, auto)
  finally show "A \<subseteq> enat ` {..n}" .
qed

subsection {* Cancellation simprocs *}

lemma enat_add_left_cancel: "a + b = a + c \<longleftrightarrow> a = (\<infinity>::enat) \<or> b = c"
  unfolding plus_enat_def by (simp split: enat.split)

lemma enat_add_left_cancel_le: "a + b \<le> a + c \<longleftrightarrow> a = (\<infinity>::enat) \<or> b \<le> c"
  unfolding plus_enat_def by (simp split: enat.split)

lemma enat_add_left_cancel_less: "a + b < a + c \<longleftrightarrow> a \<noteq> (\<infinity>::enat) \<and> b < c"
  unfolding plus_enat_def by (simp split: enat.split)

ML {*
structure Cancel_Enat_Common =
struct
  (* copied from src/HOL/Tools/nat_numeral_simprocs.ML *)
  fun find_first_t _    _ []         = raise TERM("find_first_t", [])
    | find_first_t past u (t::terms) =
          if u aconv t then (rev past @ terms)
          else find_first_t (t::past) u terms

  fun dest_summing (Const (@{const_name Groups.plus}, _) $ t $ u, ts) =
        dest_summing (t, dest_summing (u, ts))
    | dest_summing (t, ts) = t :: ts

  val mk_sum = Arith_Data.long_mk_sum
  fun dest_sum t = dest_summing (t, [])
  val find_first = find_first_t []
  val trans_tac = Numeral_Simprocs.trans_tac
  val norm_ss =
    simpset_of (put_simpset HOL_basic_ss @{context}
      addsimps @{thms ac_simps add_0_left add_0_right})
  fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset norm_ss ctxt))
  fun simplify_meta_eq ctxt cancel_th th =
    Arith_Data.simplify_meta_eq [] ctxt
      ([th, cancel_th] MRS trans)
  fun mk_eq (a, b) = HOLogic.mk_Trueprop (HOLogic.mk_eq (a, b))
end

structure Eq_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_eq
  val dest_bal = HOLogic.dest_bin @{const_name HOL.eq} @{typ enat}
  fun simp_conv _ _ = SOME @{thm enat_add_left_cancel}
)

structure Le_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
  val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} @{typ enat}
  fun simp_conv _ _ = SOME @{thm enat_add_left_cancel_le}
)

structure Less_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
  val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} @{typ enat}
  fun simp_conv _ _ = SOME @{thm enat_add_left_cancel_less}
)
*}

simproc_setup enat_eq_cancel
  ("(l::enat) + m = n" | "(l::enat) = m + n") =
  {* fn phi => fn ctxt => fn ct => Eq_Enat_Cancel.proc ctxt (term_of ct) *}

simproc_setup enat_le_cancel
  ("(l::enat) + m \<le> n" | "(l::enat) \<le> m + n") =
  {* fn phi => fn ctxt => fn ct => Le_Enat_Cancel.proc ctxt (term_of ct) *}

simproc_setup enat_less_cancel
  ("(l::enat) + m < n" | "(l::enat) < m + n") =
  {* fn phi => fn ctxt => fn ct => Less_Enat_Cancel.proc ctxt (term_of ct) *}

text {* TODO: add regression tests for these simprocs *}

text {* TODO: add simprocs for combining and cancelling numerals *}

subsection {* Well-ordering *}

lemma less_enatE:
  "[| n < enat m; !!k. n = enat k ==> k < m ==> P |] ==> P"
by (induct n) auto

lemma less_infinityE:
  "[| n < \<infinity>; !!k. n = enat k ==> P |] ==> P"
by (induct n) auto

lemma enat_less_induct:
  assumes prem: "!!n. \<forall>m::enat. m < n --> P m ==> P n" shows "P n"
proof -
  have P_enat: "!!k. P (enat k)"
    apply (rule nat_less_induct)
    apply (rule prem, clarify)
    apply (erule less_enatE, simp)
    done
  show ?thesis
  proof (induct n)
    fix nat
    show "P (enat nat)" by (rule P_enat)
  next
    show "P \<infinity>"
      apply (rule prem, clarify)
      apply (erule less_infinityE)
      apply (simp add: P_enat)
      done
  qed
qed

instance enat :: wellorder
proof
  fix P and n
  assume hyp: "(\<And>n\<Colon>enat. (\<And>m\<Colon>enat. m < n \<Longrightarrow> P m) \<Longrightarrow> P n)"
  show "P n" by (blast intro: enat_less_induct hyp)
qed

subsection {* Complete Lattice *}

instantiation enat :: complete_lattice
begin

definition inf_enat :: "enat \<Rightarrow> enat \<Rightarrow> enat" where
  "inf_enat = min"

definition sup_enat :: "enat \<Rightarrow> enat \<Rightarrow> enat" where
  "sup_enat = max"

definition Inf_enat :: "enat set \<Rightarrow> enat" where
  "Inf_enat A = (if A = {} then \<infinity> else (LEAST x. x \<in> A))"

definition Sup_enat :: "enat set \<Rightarrow> enat" where
  "Sup_enat A = (if A = {} then 0 else if finite A then Max A else \<infinity>)"
instance
proof
  fix x :: "enat" and A :: "enat set"
  { assume "x \<in> A" then show "Inf A \<le> x"
      unfolding Inf_enat_def by (auto intro: Least_le) }
  { assume "\<And>y. y \<in> A \<Longrightarrow> x \<le> y" then show "x \<le> Inf A"
      unfolding Inf_enat_def
      by (cases "A = {}") (auto intro: LeastI2_ex) }
  { assume "x \<in> A" then show "x \<le> Sup A"
      unfolding Sup_enat_def by (cases "finite A") auto }
  { assume "\<And>y. y \<in> A \<Longrightarrow> y \<le> x" then show "Sup A \<le> x"
      unfolding Sup_enat_def using finite_enat_bounded by auto }
qed (simp_all add:
 inf_enat_def sup_enat_def bot_enat_def top_enat_def Inf_enat_def Sup_enat_def)
end

instance enat :: complete_linorder ..

subsection {* Traditional theorem names *}

lemmas enat_defs = zero_enat_def one_enat_def eSuc_def
  plus_enat_def less_eq_enat_def less_enat_def

end


header {* \isachapter{Instantiating the Framework with a simple While-Language}
  \isaheader{Commands} *}

theory Com imports Main begin

section {* Variables and Values *}

type_synonym vname = string -- "names for variables"

datatype val
  = Bool bool      -- "Boolean value"
  | Intg int       -- "integer value"

abbreviation "true == Bool True"
abbreviation "false == Bool False"

section {* Expressions and Commands*}

datatype bop = Eq | And | Less | Add | Sub     -- "names of binary operations"

datatype expr
  = Val val                                          -- "value"
  | Var vname                                        -- "local variable"
  | BinOp expr bop expr    ("_ \<guillemotleft>_\<guillemotright> _" [80,0,81] 80)  -- "binary operation"

fun binop :: "bop \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val option"
where "binop Eq v\<^sub>1 v\<^sub>2               = Some(Bool(v\<^sub>1 = v\<^sub>2))"
  | "binop And (Bool b\<^sub>1) (Bool b\<^sub>2)  = Some(Bool(b\<^sub>1 \<and> b\<^sub>2))"
  | "binop Less (Intg i\<^sub>1) (Intg i\<^sub>2) = Some(Bool(i\<^sub>1 < i\<^sub>2))"
  | "binop Add (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 + i\<^sub>2))"
  | "binop Sub (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 - i\<^sub>2))"
  | "binop bop v\<^sub>1 v\<^sub>2                = None"

datatype cmd
  = Skip
  | LAss vname expr        ("_:=_" [70,70] 70)  -- "local assignment"
  | Seq cmd cmd            ("_;;/ _" [61,60] 60)
  | Cond expr cmd cmd      ("if '(_') _/ else _" [80,79,79] 70)
  | While expr cmd         ("while '(_') _" [80,79] 70)

fun num_inner_nodes :: "cmd \<Rightarrow> nat" ("#:_")
where "#:Skip              = 1"
  | "#:(V:=e)              = 2"       (* zusätzlicher Skip-Knoten *)
  | "#:(c\<^sub>1;;c\<^sub>2)            = #:c\<^sub>1 + #:c\<^sub>2"
  | "#:(if (b) c\<^sub>1 else c\<^sub>2) = #:c\<^sub>1 + #:c\<^sub>2 + 1"
  | "#:(while (b) c)       = #:c + 2" (* zusätzlicher Skip-Knoten *)

lemma num_inner_nodes_gr_0:"#:c > 0"
by(induct c) auto

lemma [dest]:"#:c = 0 \<Longrightarrow> False"
by(induct c) auto

section {* The state *}

type_synonym state = "vname \<rightharpoonup> val"

fun "interpret" :: "expr \<Rightarrow> state \<Rightarrow> val option"
where Val: "interpret (Val v) s = Some v"
  | Var: "interpret (Var V) s = s V"
  | BinOp: "interpret (e\<^sub>1\<guillemotleft>bop\<guillemotright>e\<^sub>2) s =
    (case interpret e\<^sub>1 s of None \<Rightarrow> None
                         | Some v\<^sub>1 \<Rightarrow> (case interpret e\<^sub>2 s of None \<Rightarrow> None
                                                           | Some v\<^sub>2 \<Rightarrow> (
      case binop bop v\<^sub>1 v\<^sub>2 of None \<Rightarrow> None | Some v \<Rightarrow> Some v)))"

end


theory Union_Find_Time
imports
  "Imperative_HOL_Time.SLTC_Main"
  "../../Refine_Imperative_HOL/Sepref_Additional"
  Collections.Partial_Equivalence_Relation
  "HOL-Library.Code_Target_Numeral"
  "Imperative_HOL_Time.Asymptotics_1D"
  UnionFind_Impl
begin

notation timeCredit_assn  ("$")
no_notation Ref_Time.update ("_ := _" 62) (* to disambiguate with list_update  *)

text \<open>
  We implement a simple union-find data-structure based on an array.
  It uses path compression and a size-based union heuristics.
\<close>

subsection \<open>Abstract Union-Find on Lists\<close>
text \<open>
  We first formulate union-find structures on lists, and later implement
  them using Imperative/HOL. This is a separation of proof concerns
  between proving the algorithmic idea correct and generating the verification
  conditions.
\<close>

subsubsection \<open>Representatives\<close>
text \<open>
  We define a function that searches for the representative of an element.
  This function is only partially defined, as it does not terminate on all
  lists. We use the domain of this function to characterize valid union-find
  lists.
\<close>
function (domintros) rep_of
  where "rep_of l i = (if l!i = i then i else rep_of l (l!i))"
  by pat_completeness auto

text \<open>A valid union-find structure only contains valid indexes, and
  the \<open>rep_of\<close> function terminates for all indexes.\<close>
definition
  "ufa_invar l \<equiv> \<forall>i<length l. rep_of_dom (l,i) \<and> l!i<length l"

lemma ufa_invarD:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of_dom (l,i)"
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> l!i<length l"
  unfolding ufa_invar_def by auto

text \<open>We derive the following equations for the \<open>rep-of\<close> function.\<close>
lemma rep_of_refl: "l!i=i \<Longrightarrow> rep_of l i = i"
  apply (subst rep_of.psimps)
  apply (rule rep_of.domintros)
  apply (auto)
  done

lemma rep_of_step:
  "\<lbrakk>ufa_invar l; i<length l; l!i\<noteq>i\<rbrakk> \<Longrightarrow> rep_of l i = rep_of l (l!i)"
  apply (subst rep_of.psimps)
  apply (auto dest: ufa_invarD)
  done

lemmas rep_of_simps = rep_of_refl rep_of_step

lemma rep_of_iff: "\<lbrakk>ufa_invar l; i<length l\<rbrakk>
  \<Longrightarrow> rep_of l i = (if l!i=i then i else rep_of l (l!i))"
  by (simp add: rep_of_simps)

text \<open>We derive a custom induction rule, that is more suited to
  our purposes.\<close>
lemma rep_of_induct[case_names base step, consumes 2]:
  assumes I: "ufa_invar l"
  assumes L: "i<length l"
  assumes BASE: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i=i \<rbrakk> \<Longrightarrow> P l i"
  assumes STEP: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i\<noteq>i; P l (l!i) \<rbrakk>
    \<Longrightarrow> P l i"
  shows "P l i"
proof -
  from ufa_invarD[OF I L] have "ufa_invar l \<and> i<length l \<longrightarrow> P l i"
    apply (induct l\<equiv>l i rule: rep_of.pinduct)
    apply (auto intro: STEP BASE dest: ufa_invarD)
    done
  thus ?thesis using I L by simp
qed

text \<open>In the following, we define various properties of \<open>rep_of\<close>.\<close>
lemma rep_of_min:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
proof -
  have "\<lbrakk>rep_of_dom (l,i) \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    apply (induct arbitrary:  rule: rep_of.pinduct)
    apply (subst rep_of.psimps, assumption)
    apply (subst (2) rep_of.psimps, assumption)
    apply auto
    done
  thus "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    by (metis ufa_invarD(1))
qed

lemma rep_of_bound:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l i < length l"
  apply (induct rule: rep_of_induct)
  apply (auto simp: rep_of_iff)
  done

lemma rep_of_idem:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l (rep_of l i) = rep_of l i"
  by (auto simp: rep_of_min rep_of_refl)

lemma rep_of_min_upd: "\<lbrakk> ufa_invar l; x<length l; i<length l \<rbrakk> \<Longrightarrow>
  rep_of (l[rep_of l x := rep_of l x]) i = rep_of l i"
  by (metis list_update_id rep_of_min)

lemma rep_of_idx:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of l (l!i) = rep_of l i"
  by (metis rep_of_step)

subsubsection \<open>Abstraction to Partial Equivalence Relation\<close>
definition ufa_\<alpha> :: "nat list \<Rightarrow> (nat\<times>nat) set"
  where "ufa_\<alpha> l
    \<equiv> {(x,y). x<length l \<and> y<length l \<and> rep_of l x = rep_of l y}"

lemma ufa_\<alpha>_equiv[simp, intro!]: "part_equiv (ufa_\<alpha> l)"
  apply rule
  unfolding ufa_\<alpha>_def
  apply (rule symI)
  apply auto
  apply (rule transI)
  apply auto
  done

lemma ufa_\<alpha>_lenD:
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> x<length l"
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> y<length l"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_dom[simp]: "Domain (ufa_\<alpha> l) = {0..<length l}"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_refl[simp]: "(i,i)\<in>ufa_\<alpha> l \<longleftrightarrow> i<length l"
  unfolding ufa_\<alpha>_def
  by simp

lemma ufa_\<alpha>_len_eq:
  assumes "ufa_\<alpha> l = ufa_\<alpha> l'"
  shows "length l = length l'"
  by (metis assms le_antisym less_not_refl linorder_le_less_linear ufa_\<alpha>_refl)

subsubsection \<open>Operations\<close>
lemma ufa_init_invar: "ufa_invar [0..<n]"
  unfolding ufa_invar_def
  by (auto intro: rep_of.domintros)

lemma ufa_init_correct: "ufa_\<alpha> [0..<n] = {(x,x) | x. x<n}"
  unfolding ufa_\<alpha>_def
  using ufa_init_invar[of n]
  apply (auto simp: rep_of_refl)
  done

lemma ufa_find_correct: "\<lbrakk>ufa_invar l; x<length l; y<length l\<rbrakk>
  \<Longrightarrow> rep_of l x = rep_of l y \<longleftrightarrow> (x,y)\<in>ufa_\<alpha> l"
  unfolding ufa_\<alpha>_def
  by auto

abbreviation "ufa_union l x y \<equiv> l[rep_of l x := rep_of l y]"

lemma ufa_union_invar:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  shows "ufa_invar (ufa_union l x y)"
  unfolding ufa_invar_def
proof (intro allI impI, simp only: length_list_update)
  fix i
  assume A: "i<length l"
  with I have "rep_of_dom (l,i)" by (auto dest: ufa_invarD)

  have "ufa_union l x y ! i < length l" using I L A
    apply (cases "i=rep_of l x")
    apply (auto simp: rep_of_bound dest: ufa_invarD)
    done
  moreover have "rep_of_dom (ufa_union l x y, i)" using I A L
  proof (induct rule: rep_of_induct)
    case (base i)
    thus ?case
      apply -
      apply (rule rep_of.domintros)
      apply (cases "i=rep_of l x")
      apply auto
      apply (rule rep_of.domintros)
      apply (auto simp: rep_of_min)
      done
  next
    case (step i)

    from step.prems \<open>ufa_invar l\<close> \<open>i<length l\<close> \<open>l!i\<noteq>i\<close>
    have [simp]: "ufa_union l x y ! i = l!i"
      apply (auto simp: rep_of_min rep_of_bound nth_list_update)
      done

    from step show ?case
      apply -
      apply (rule rep_of.domintros)
      apply simp
      done
  qed
  ultimately show
    "rep_of_dom (ufa_union l x y, i) \<and> ufa_union l x y ! i < length l"
    by blast

qed

lemma ufa_union_aux:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  assumes IL: "i<length l"
  shows "rep_of (ufa_union l x y) i =
    (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)"
  using I IL
proof (induct rule: rep_of_induct)
  case (base i)
  have [simp]: "rep_of l i = i" using \<open>l!i=i\<close> by (simp add: rep_of_refl)
  note [simp] = \<open>ufa_invar l\<close> \<open>i<length l\<close>
  show ?case proof (cases)
    assume A[simp]: "rep_of l x = i"
    have [simp]: "l[i := rep_of l y] ! i = rep_of l y"
      by (auto simp: rep_of_bound)

    show ?thesis proof (cases)
      assume [simp]: "rep_of l y = i"
      show ?thesis by (simp add: rep_of_refl)
    next
      assume A: "rep_of l y \<noteq> i"
      have [simp]: "rep_of (l[i := rep_of l y]) i = rep_of l y"
        apply (subst rep_of_step[OF ufa_union_invar[OF I L], simplified])
        using A apply simp_all
        apply (subst rep_of_refl[where i="rep_of l y"])
        using I L
        apply (simp_all add: rep_of_min)
        done
      show ?thesis by (simp add: rep_of_refl)
    qed
  next
    assume A: "rep_of l x \<noteq> i"
    hence "ufa_union l x y ! i = l!i" by (auto)
    also note \<open>l!i=i\<close>
    finally have "rep_of (ufa_union l x y) i = i" by (simp add: rep_of_refl)
    thus ?thesis using A by auto
  qed
next
  case (step i)

  note [simp] = I L \<open>i<length l\<close>

  have "rep_of l x \<noteq> i" by (metis I L(1) rep_of_min \<open>l!i\<noteq>i\<close>)
  hence [simp]: "ufa_union l x y ! i = l!i"
    by (auto simp add: nth_list_update rep_of_bound \<open>l!i\<noteq>i\<close>) []

  have "rep_of (ufa_union l x y) i = rep_of (ufa_union l x y) (l!i)"
    by (auto simp add: rep_of_iff[OF ufa_union_invar[OF I L]])
  also note step.hyps(4)
  finally show ?case
    by (auto simp: rep_of_idx)
qed

lemma ufa_union_correct: "\<lbrakk> ufa_invar l; x<length l; y<length l \<rbrakk>
  \<Longrightarrow> ufa_\<alpha> (ufa_union l x y) = per_union (ufa_\<alpha> l) x y"
  unfolding ufa_\<alpha>_def per_union_def
  by (auto simp: ufa_union_aux
    split: if_split_asm
  )

lemma ufa_compress_aux:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  and "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
proof -
  {
    fix i
    assume "i<length (l[x := rep_of l x])"
    hence IL: "i<length l" by simp

    have G1: "l[x := rep_of l x] ! i < length (l[x := rep_of l x])"
      using I IL
      by (auto dest: ufa_invarD[OF I] simp: nth_list_update rep_of_bound)
    from I IL have G2: "rep_of (l[x := rep_of l x]) i = rep_of l i
      \<and> rep_of_dom (l[x := rep_of l x], i)"
    proof (induct rule: rep_of_induct)
      case (base i)
      thus ?case
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_refl)
        done
    next
      case (step i)
      hence D: "rep_of_dom (l[x := rep_of l x], i)"
        apply -
        apply (rule rep_of.domintros)
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done

      thus ?case apply simp using step
        apply -
        apply (subst rep_of.psimps[OF D])
        apply (cases "x=i")
        apply (auto simp: rep_of_min rep_of_idx)
        apply (subst rep_of.psimps[where i="rep_of l i"])
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done
    qed
    note G1 G2
  } note G=this

  thus "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
    by auto

  from G show "ufa_invar (l[x := rep_of l x])"
    by (auto simp: ufa_invar_def)
qed

lemma ufa_compress_invar:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  using assms by (rule ufa_compress_aux)

lemma ufa_compress_correct:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_\<alpha> (l[x := rep_of l x]) = ufa_\<alpha> l"
  by (auto simp: ufa_\<alpha>_def ufa_compress_aux[OF I])

subsubsection \<open>stuff about the height (by Max Haslbeck)\<close>

function (domintros) height_of
  where "height_of l i = (if l!i = i then 0::nat else 1 + height_of l (l!i))"
  by pat_completeness auto
print_theorems

lemma height_of_dom_rep_of_dom[simp]: "height_of_dom (l, i) = rep_of_dom (l, i)"
  apply(rule)
  subgoal
    apply (induct arbitrary:  rule: height_of.pinduct)
    apply (rule rep_of.domintros) by simp
  subgoal
    apply (induct arbitrary:  rule: rep_of.pinduct)
    apply (rule height_of.domintros) by simp
  done

lemma height_of_step: "ufa_invar l \<Longrightarrow>
         i < length l \<Longrightarrow>
         l ! i \<noteq> i \<Longrightarrow>
          height_of l i = Suc (height_of l (l ! i))"
  by (simp add: height_of.psimps ufa_invarD(1))

definition "h_of l i = Max {height_of l j|j. j<length l \<and> rep_of l j = i}"

definition invar where
  "invar l sl = (length l = length sl
              \<and> sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l} = length l
              \<and> (\<forall>i<length l. l!i=i \<longrightarrow> (2::nat) ^ h_of l i \<le> sl ! i))"

lemma invar_sli_le_l:
  assumes "invar l sl" "ufa_invar l" "i<length l"
  shows "sl ! (rep_of l i) \<le> length l"
proof -
  from assms(1) have a: "sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l} = length l"
      and len: "length sl = length l" by(auto simp: invar_def)

  let ?r = "(rep_of l i)"
  from assms have "?r<length l" by(auto simp: rep_of_bound)
  then have f: "{0..<length l} = {?r} \<union> ({0..<length l}-{?r})" by auto
  have "sl ! (?r) \<le> sum (\<lambda>i. if l!i=i then sl !i else 0) ({0..<length l}-{?r}) + (if l!?r=?r then sl !?r else 0)"
    using assms by (auto simp: rep_of_min)
  also have "\<dots> = sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l}"
    apply(subst (2) f) apply(subst sum_Un_nat) by simp_all
  also have "\<dots> = length l" using a by simp
  finally show "sl ! (rep_of l i) \<le> length l" .
qed

lemma h_rep: "ufa_invar l \<Longrightarrow> y<length l\<Longrightarrow> height_of l (rep_of l y) = 0"
  apply (subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
  by (simp add: rep_of_min)

lemma ufa_compress_compresses:
  "\<lbrakk>ufa_invar l; i<length l; j<length l\<rbrakk> \<Longrightarrow>
      height_of (l[j:=rep_of l j]) i \<le> height_of l i"
  proof (induct rule: rep_of_induct)
    case (base i)
    then show ?case
      apply(subst height_of.psimps)  subgoal apply simp apply(rule ufa_invarD(1)) by(auto simp add: ufa_compress_invar)
      apply (auto simp add: rep_of_refl)
      by (metis nth_list_update' rep_of_iff)
  next
    case (step i)
    show ?case
      apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_compress_invar )
      apply auto
      apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_compress_invar )
      using step(1-3) apply auto
      apply(cases "i=j")
      subgoal apply simp apply(subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_compress_invar ufa_invarD(1))
      using rep_of_min by auto
    subgoal apply simp apply(rule step(4)) using step by auto
    done
  qed

lemma ufa_union_on_path_only_increases_by_one:
  "\<lbrakk>ufa_invar l; i<length l; x<length l; y<length l; rep_of l i = rep_of l x\<rbrakk> \<Longrightarrow>
      height_of (ufa_union l x y) i \<le> Suc (height_of l i)"
proof (induct rule: rep_of_induct)
  case (base i)
  then show ?case
    apply(cases "i=rep_of l x")
    subgoal
      apply(subst height_of.psimps)  subgoal by (simp add: ufa_invarD(1) ufa_union_invar )
      apply simp
      apply (auto simp add:   )[]
       apply(subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar)
      apply (auto simp: h_rep)[] by(simp add: rep_of_min)
    subgoal
      apply(subst height_of.psimps)  subgoal apply simp
        by (simp add: ufa_invarD(1) ufa_union_invar)
      by simp
    done
next
  case (step i)
  then have not: "i\<noteq>rep_of l x"
    using rep_of_min by blast

  show ?case
    apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_union_invar )
    using not apply simp
    apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
    apply simp apply safe
     apply(rule step(4)) using step
    by (auto simp add: rep_of_idx)
qed

lemma ufa_union_not_on_path_stays:
  "\<lbrakk>ufa_invar l; i<length l; x<length l; y<length l; rep_of l i \<noteq> rep_of l x\<rbrakk> \<Longrightarrow>
      height_of (ufa_union l x y) i = height_of l i"
proof (induct rule: rep_of_induct)
  case (base i)
  then show ?case
    apply(cases "i=rep_of l x")
    subgoal
      by (auto simp add:  h_rep  rep_of_iff)
    subgoal
      apply(subst height_of.psimps)  subgoal apply simp
        by (simp add: ufa_invarD(1) ufa_union_invar)
      apply auto
      apply(subst height_of.psimps)  subgoal apply simp
        by (simp add: ufa_invarD(1) ufa_union_invar)
      by simp
    done
next
  case (step i)
  then have not: "i\<noteq>rep_of l x"
    using rep_of_min by blast

  show ?case
    apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_union_invar )
    using not step(1-3) apply auto
    apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
    apply simp
     apply(rule step(4)) using step
    by (auto simp add: rep_of_idx)
qed

lemma ufa_union_on_path:
"\<lbrakk>ufa_invar l; i<length l; x<length l; y<length l\<rbrakk> \<Longrightarrow>
      height_of (ufa_union l x y) i \<le> Suc (height_of l i)"
  proof (induct rule: rep_of_induct)
    case (base i)
    then show ?case
      apply(cases "i=rep_of l x")
      subgoal
      apply(subst height_of.psimps)  subgoal by (simp add: ufa_invarD(1) ufa_union_invar )
      apply (auto simp add:   )[]
        apply(subst height_of.psimps) subgoal by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar)
        apply auto[] by(simp add: rep_of_min)
      subgoal
        apply(subst height_of.psimps)  subgoal apply simp
          by (simp add: ufa_invarD(1) ufa_union_invar)
        by simp
      done
  next
    case (step i)
    then have not: "i\<noteq>rep_of l x"
      using rep_of_min by blast

    show ?case
      apply(subst height_of.psimps)  subgoal using step by (simp add: ufa_invarD(1) ufa_union_invar )
      using not apply simp
      apply(subst (2) height_of.psimps)  subgoal using step by (simp add: rep_of_bound ufa_invarD(1) ufa_union_invar )
      apply simp apply safe
      apply(rule step(4)) using step by auto
  qed

lemma hel: "(\<And>x. x\<in>A \<Longrightarrow> f x \<le> g x) \<Longrightarrow> finite A  \<Longrightarrow> Max (f ` A) \<le> Max (g ` A)"
  by (smt Max_ge_iff Max_in finite_imageI imageE image_eqI image_is_empty order_refl)
lemma MAXIMUM_mono: "(\<And>x. x\<in>A \<Longrightarrow> f x \<le> g x) \<Longrightarrow> finite A  \<Longrightarrow> A = B \<Longrightarrow> Max (f ` A) \<le> Max (g ` B)"
  using hel by blast
lemma MAXIMUM_eq: "(\<And>x. x\<in>A \<Longrightarrow> f x = g x) \<Longrightarrow> finite A  \<Longrightarrow> A = B \<Longrightarrow> Max (f ` A) =  Max (g ` B)"
  apply(rule antisym) by  (auto intro: MAXIMUM_mono)

lemma h_of_alt: "h_of l i = Max ((height_of l) ` {j|j. j<length l \<and> rep_of l j = i})"
  unfolding h_of_def
  by (simp add: setcompr_eq_image)

lemma h_of_compress: "ufa_invar l \<Longrightarrow> j < length l \<Longrightarrow> h_of (l[j:=rep_of l j]) i \<le>  h_of l i"
  unfolding h_of_alt
  apply(rule MAXIMUM_mono)
  subgoal apply(rule ufa_compress_compresses) by auto
  by (auto simp add: ufa_compress_aux(2))

lemma h_of_uf_union_untouched:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> y < length l \<Longrightarrow> i < length l \<Longrightarrow> l!i = i
    \<Longrightarrow> i \<noteq> rep_of l x \<Longrightarrow> i \<noteq> rep_of l y   \<Longrightarrow> h_of (ufa_union l x y) i = h_of l i"
  unfolding h_of_alt
  apply(rule MAXIMUM_eq)
  subgoal apply(rule ufa_union_not_on_path_stays)
    using ufa_union_aux by auto
  using ufa_union_aux by auto

lemma Suc_h_of: assumes
  a:  "i < length l " "rep_of l i = i"
  shows
  "Suc (h_of l i) = Max ((\<lambda>j. Suc (height_of l j)) ` {j|j. j<length l \<and> rep_of l j = i})"
  unfolding h_of_alt
  apply(subst  mono_Max_commute[where f=Suc])
  subgoal by (simp add: mono_Suc)
  subgoal by simp
  subgoal using a by auto
  by (simp add: image_image)

lemma MAXIMUM_Un: "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<noteq> {} \<Longrightarrow> B \<noteq> {}
  \<Longrightarrow> Max (f ` (A \<union> B)) = max (Max (f `A)) (Max (f `B))"
  apply(simp add: image_Un)
  apply(subst Max_Un) by auto

lemma fixes A::nat
  shows "A\<le>A' \<Longrightarrow> B\<le>B' \<Longrightarrow> max A B \<le> max A' B'"
  by auto

lemma h_of_uf_union_id:
  assumes "ufa_invar l "" x < length l "" y < length l "" i < length l "
    " rep_of l i = i" "i = rep_of l y" and neq: "rep_of l y = rep_of l x"
  shows "h_of (ufa_union l x y) i = h_of l i"
  using neq apply simp using assms
  by (metis list_update_id rep_of_min)

lemma h_of_uf_union_touched:
  assumes "ufa_invar l "" x < length l "" y < length l "" i < length l "
    " rep_of l i = i" "i = rep_of l y" and neq: "rep_of l y \<noteq> rep_of l x"
  shows "h_of (ufa_union l x y) i \<le> max (h_of l (rep_of l y)) (Suc (h_of l (rep_of l x)))"
proof -
  have *: "{j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i}
      = {j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i \<and> rep_of l j = rep_of l y}
          \<union> {j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i \<and> rep_of l j = rep_of l x}" (is "_ = ?A \<union> ?B")
    apply auto using assms
    by (simp add: ufa_union_aux)

  have A: "?A = {j |j. j < length l \<and> rep_of l j = rep_of l y}"
    using ufa_union_aux assms by auto
  have B: "?B = {j |j. j < length l \<and> rep_of l j = rep_of l x}"
    using ufa_union_aux assms by auto

  have "h_of (ufa_union l x y) i = Max ((height_of (ufa_union l x y))` {j|j. j<length (ufa_union l x y) \<and> rep_of (ufa_union l x y) j = i} )"
    unfolding h_of_alt by simp
  also have "\<dots> = Max ((height_of (ufa_union l x y))`(?A \<union> ?B))"
    unfolding * by simp
  also have "\<dots> = max (Max ((height_of (ufa_union l x y))`?A)) (Max ((height_of (ufa_union l x y))`?B))"
    apply(subst MAXIMUM_Un) apply simp_all
    subgoal  apply(rule exI[where x=y]) using assms by (simp add: ufa_union_aux)
    subgoal  apply(rule exI[where x=x]) using assms by (simp add: ufa_union_aux)
    done
  also have "\<dots> \<le> max (Max ((height_of l)` ?A )) (Max ((\<lambda>j. Suc (height_of l j))` ?B))"
    apply(rule max.mono)
    subgoal apply(rule MAXIMUM_mono)
      subgoal apply(rule order_eq_refl) apply(rule ufa_union_not_on_path_stays) using assms by auto
      by simp_all
    subgoal apply(rule MAXIMUM_mono)
      subgoal apply(rule ufa_union_on_path)  using assms by auto
       apply simp by simp
    done
  also have "\<dots> \<le> max  (h_of l (rep_of l y)) (Suc (h_of l (rep_of l x)))"
    apply(rule max.mono)
    subgoal unfolding h_of_alt A by simp
    subgoal apply(subst Suc_h_of)
      subgoal using assms by (auto simp: rep_of_min rep_of_bound rep_of_refl)
      subgoal using assms by (auto simp: rep_of_min rep_of_bound rep_of_refl)
      unfolding B by simp
    done
  finally show ?thesis .
qed

lemma height_of_le_h_of: "i < length l \<Longrightarrow> height_of l i \<le> h_of l (rep_of l i)"
    unfolding h_of_def apply(rule Max.coboundedI) apply simp
    apply(subst setcompr_eq_image) apply(rule imageI)
    by auto

lemma height_of_ub: assumes "invar l sl" "ufa_invar l" "i<length l"
  shows "2 ^ (height_of l i) \<le> length l"
proof -
  from assms(1) have "length l = length sl "
            and 2:  "sum (\<lambda>i. if l!i=i then sl !i else 0) {0..<length l} = length l"
            and 3:  "\<And>i. i<length l \<Longrightarrow>  l!i=i \<Longrightarrow> (2::nat) ^ h_of l i \<le> sl ! i"
    unfolding invar_def  by auto

  have *: "height_of l i \<le> h_of l (rep_of l i)"
    using assms by (auto intro: height_of_le_h_of)

  have "(2::nat) ^ (height_of l i) \<le> 2 ^ (h_of l (rep_of l i))"
    apply(rule power_increasing) apply(rule *) by simp
  also have "\<dots> \<le> sl ! (rep_of l i)"
   using 3 assms by(auto simp add: rep_of_bound rep_of_min )
  also have "\<dots> \<le> length l" using assms
    by (auto simp: rep_of_bound intro: invar_sli_le_l)
  finally show ?thesis .
qed

subsection \<open>Implementation with Imperative/HOL\<close>
text \<open>In this section, we implement the union-find data-structure with
  two arrays, one holding the next-pointers, and another one holding the size
  information. Note that we do not prove that the array for the
  size information contains any reasonable values, as the correctness of the
  algorithm is not affected by this. We leave it future work to also estimate
  the complexity of the algorithm.
\<close>

type_synonym uf = "nat array \<times> nat array"

definition is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where
  "is_uf R u \<equiv> case u of (s,p) \<Rightarrow>
  \<exists>\<^sub>Al szl. p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>aszl
    * \<up>(ufa_invar l \<and> ufa_\<alpha> l = R \<and> length szl = length l \<and> invar l szl)"

definition uf_init :: "nat \<Rightarrow> uf Heap" where
  "uf_init n \<equiv> do {
    l \<leftarrow> Array_Time.of_list [0..<n];
    szl \<leftarrow> Array_Time.new n (1::nat);
    return (szl,l)
  }"

lemma of_list_rule':
    "<$ (1 + n)> Array_Time.of_list [0..<n] <\<lambda>r. r \<mapsto>\<^sub>a [0..<n]>"
  using of_list_rule[of "[0..<n]"] by auto

lemma height_of_init: "j<n \<Longrightarrow> height_of [0..<n] j = 0"
  by (simp add: height_of.psimps ufa_init_invar ufa_invarD(1))

lemma h_of_init: "i < n \<Longrightarrow> h_of [0..<n] i = 0"
  unfolding h_of_def apply auto
  apply(rule antisym)
  subgoal apply(rule Max.boundedI)
     apply simp
    using ufa_init_invar apply auto apply(rule exI[where x=i]) apply simp
    subgoal
      by (simp add: rep_of_refl)
    apply(rule height_of_init) by simp
  by simp

lemma ufa_init_invar': "invar [0..<n] (replicate n (Suc 0))"
  unfolding invar_def apply auto using h_of_init by auto

definition uf_init_time :: "nat \<Rightarrow> nat" where "uf_init_time n == (2*n+3)"

lemma uf_init_bound[asym_bound]: "uf_init_time \<in> \<Theta>(\<lambda>n. n)"
  unfolding uf_init_time_def by auto2

lemma uf_init_rule:
  "<$(uf_init_time n)> uf_init n <is_uf {(i,i) |i. i<n}>\<^sub>t"
  unfolding uf_init_time_def uf_init_def is_uf_def[abs_def]
  by (sep_auto simp: ufa_init_correct ufa_init_invar ufa_init_invar' zero_time heap: of_list_rule')

partial_function (heap_time) uf_rep_of :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where [code]:
  "uf_rep_of p i = do {
    n \<leftarrow> Array_Time.nth p i;
    if n=i then return i else uf_rep_of p n
  }"

lemma root_height_of_zero: "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> l ! i = i  \<Longrightarrow>  height_of l i =0"
    using h_rep rep_of_iff by fastforce

lemma uf_rep_of_rule: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al * $(height_of l i + 2)> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>\<^sub>t"
  apply (induct rule: rep_of_induct)
   apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_refl)

  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_step height_of_step)
  done

text \<open>We chose a non tail-recursive version here, as it is easier to prove.\<close>
partial_function (heap_time) uf_compress :: "nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> unit Heap"
  where [code]:
  "uf_compress i ci p = (
    if i=ci then return ()
    else do {
      ni\<leftarrow>Array_Time.nth p i;
      uf_compress ni ci p;
      Array_Time.upd i ci p;
      return ()
    })"

lemma compress_invar:
  assumes "invar l szl"
    "ufa_invar l" "i<length l"
  shows "invar (l[i := rep_of l i]) szl"
  using assms unfolding invar_def
  apply safe
  subgoal by simp
  subgoal apply simp
    by (smt nth_list_update_eq nth_list_update_neq rep_of_iff rep_of_min sum.ivl_cong)
  subgoal for i
    apply(rule order.trans)
    apply(rule power_increasing[where N="h_of l i"])
    subgoal apply(rule h_of_compress) by auto
     apply simp
    apply simp
    by (metis nth_list_update_eq nth_list_update_neq rep_of_min)
  done

lemma uf_compress_rule: "\<lbrakk> ufa_invar l; i<length l; ci=rep_of l i; invar l szl \<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al *  $(1+height_of l i*3)> uf_compress i ci p
  <\<lambda>_. (\<exists>\<^sub>Al'. p\<mapsto>\<^sub>al' * \<up>(invar l' szl \<and> ufa_invar l' \<and> length l' = length l
     \<and> (\<forall>i<length l. rep_of l' i = rep_of l i)))>\<^sub>t"
proof (induction rule: rep_of_induct)
  case (base i) thus ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: rep_of_refl)
    done
next
  case (step i)
  note SS = \<open>ufa_invar l\<close> \<open>i<length l\<close> \<open>l!i\<noteq>i\<close> \<open>ci = rep_of l i\<close> \<open>invar l szl\<close>

  have IH':
    "<p \<mapsto>\<^sub>a l * $ (1 + height_of l (l ! i) *3)>
       uf_compress (l ! i) (rep_of l i) p
     <\<lambda>_.  (\<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' *
        \<up> (invar l' szl \<and>ufa_invar l' \<and> length l' = length l
           \<and> (\<forall>i<length l'. rep_of l i = rep_of l' i)))
     >\<^sub>t"
    apply(rule pre_rule[OF _ post_rule[OF step.IH[simplified SS rep_of_idx] ]] )
    by (sep_auto simp add: rep_of_idx SS)+

  show ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: SS height_of_step heap: )
    apply(sep_auto heap: IH')

    using SS apply (sep_auto  )
    subgoal using compress_invar by simp
    subgoal using ufa_compress_invar by fastforce
    subgoal by simp
    subgoal using ufa_compress_aux(2) by fastforce
    done
qed

definition uf_rep_of_c :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where "uf_rep_of_c p i \<equiv> do {
    ci\<leftarrow>uf_rep_of p i;
    uf_compress i ci p;
    return ci
  }"

lemma uf_rep_of_c_rule: "\<lbrakk>ufa_invar l; i<length l; invar l szl\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al * $(4+height_of l i*4)> uf_rep_of_c p i <\<lambda>r.  (\<exists>\<^sub>Al'. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> ufa_invar l' \<and> invar l' szl
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i)))>\<^sub>t"
  unfolding uf_rep_of_c_def
  by (sep_auto heap: uf_compress_rule uf_rep_of_rule)

thm height_of_ub

definition height_ub :: "nat \<Rightarrow> nat" where "height_ub n = nat (ceiling (log 2 n))"

lemma height_ub_bound[asym_bound]: "height_ub \<in> \<Theta>(\<lambda>n. ln n)"
  unfolding height_ub_def using abcd_lnx[of 0 1 1 0] by auto

lemma height_ub:
  assumes "invar l sl" "ufa_invar l" "i<length l"
  shows "height_of l i \<le> height_ub (length l)"
proof -
  from height_of_ub[OF assms] have "2 ^ height_of l i \<le> length l" .
  from le_log2_of_power[OF this]
    show ?thesis unfolding height_ub_def by linarith
  qed

lemma uf_rep_of_c_rule_ub:
  assumes "ufa_invar l"  "i<length l" "invar l szl"
  shows "<p\<mapsto>\<^sub>al * $(4+ height_ub (length l)*4)> uf_rep_of_c p i <\<lambda>r. (\<exists>\<^sub>Al'. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> ufa_invar l' \<and> invar l' szl
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))) >\<^sub>t"
proof -
  from assms height_ub have "height_of l i \<le> height_ub (length l)" by auto
  then obtain x where p: "height_ub (length l) = height_of l i + x"
    using le_Suc_ex by blast
  show ?thesis unfolding p
    using assms by(sep_auto heap: uf_rep_of_c_rule)
qed

definition uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "uf_cmp u i j \<equiv> do {
    let (s,p)=u;
    n\<leftarrow>Array_Time.len p;
    if (i\<ge>n \<or> j\<ge>n) then return False
    else do {
      ci\<leftarrow>uf_rep_of_c p i;
      cj\<leftarrow>uf_rep_of_c p j;
      return (ci=cj)
    }
  }"

lemma cnv_to_ufa_\<alpha>_eq:
  "\<lbrakk>(\<forall>i<length l. rep_of l' i = rep_of l i); length l = length l'\<rbrakk>
  \<Longrightarrow> (ufa_\<alpha> l = ufa_\<alpha> l')"
  unfolding ufa_\<alpha>_def by auto

lemma "  card (Domain (ufa_\<alpha> l)) = length l"
  by simp

definition uf_cmp_time :: "nat \<Rightarrow> nat" where "uf_cmp_time n = 10+ height_ub n*8"

lemma uf_cmp_time_bound[asym_bound]:
  "uf_cmp_time \<in> \<Theta>(\<lambda>n. ln n)" unfolding uf_cmp_time_def by auto2

lemma uf_cmp_rule:
  "<is_uf R u * $(uf_cmp_time (card (Domain R)))> uf_cmp u i j <\<lambda>r. is_uf R u * \<up>(r\<longleftrightarrow>(i,j)\<in>R)>\<^sub>t"
  unfolding uf_cmp_def is_uf_def uf_cmp_time_def
  apply (sep_auto heap: uf_rep_of_c_rule_ub length_rule dest: ufa_\<alpha>_lenD simp: not_le split: prod.split)
  (* problem here is, that timeframeinference does not work under equalities.
      length l' = length l  is not used when infering the timeframe *)
   apply(rule fi_rule[OF uf_rep_of_c_rule_ub]) defer defer defer
      apply(simp only: mult.assoc)
      apply(rule match_first)
      apply simp
      apply(time_frame_inference)
     defer apply simp apply simp apply simp
  apply(sep_auto)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (subst ufa_find_correct)
  by (auto simp add: )

definition uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union u i j \<equiv> do {
    let (s,p)=u;
    ci \<leftarrow> uf_rep_of p i;
    cj \<leftarrow> uf_rep_of p j;
    if (ci=cj) then return (s,p)
    else do {
      si \<leftarrow> Array_Time.nth s ci;
      sj \<leftarrow> Array_Time.nth s cj;
      if si<sj then do {
        Array_Time.upd ci cj p;
        Array_Time.upd cj (si+sj) s;
        return (s,p)
      } else do {
        Array_Time.upd cj ci p;
        Array_Time.upd ci (si+sj) s;
        return (s,p)
      }
    }
  }"

lemma uf_rep_of_rule_ub: assumes "ufa_invar l" "i<length l"  "invar l szl"
  shows "<p\<mapsto>\<^sub>al * $(height_ub (length l) + 2)> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>\<^sub>t"
proof -
  from assms height_ub have "height_of l i \<le> height_ub (length l)" by auto
  then obtain x where p: "height_ub (length l) = height_of l i + x"
    using le_Suc_ex by blast
  show ?thesis unfolding p
    using assms by(sep_auto heap: uf_rep_of_rule)
qed

lemma 12:
  assumes "i < length l " "j < length l"
       "ufa_invar l " "(i, j) \<notin> ufa_\<alpha> l "
     and size:  "szl ! rep_of l i < szl ! rep_of l j  "
  and i:  "invar l szl "
      shows "invar (ufa_union l i j) (szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j])"
proof -
  let ?upd = "ufa_union l i j"

  from i have [simp]: "length szl = length l" unfolding invar_def by auto

  { fix a b and f :: "'a\<Rightarrow>nat" have r: "a\<noteq>b \<Longrightarrow> sum f {a,b}   = f a + f b" by simp     }
  note ff=this

  have *: "{0..<length l} = ({0..<length l}-{rep_of l j}) \<union> {rep_of l j}"
    using assms rep_of_bound by auto
  have **:"{0..<length l} = ({0..<length l}-{rep_of l i,rep_of l j}) \<union> {rep_of l i,rep_of l j}"
    using assms rep_of_bound by auto

  have ss: "(({0..<length l} - {rep_of l j}) \<inter> {ia. ?upd ! ia = ia})
        = ({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia}" using assms by (auto simp: nth_list_update')

  have "(\<Sum>ia = 0..<length l. if ?upd ! ia = ia then szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0)
     = sum (\<lambda>ia. if ?upd ! ia = ia then szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0) ({0..<length l}-{rep_of l j})
            + (szl ! rep_of l i + szl ! rep_of l j)" (is "?A = _")
    apply(subst *)  apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply safe
    subgoal using assms rep_of_bound
      using invar_def by fastforce
    subgoal using assms
      by (simp add: rep_of_min ufa_find_correct)
    subgoal using assms
      by (simp add: rep_of_min ufa_find_correct)
    done
  also have "\<dots> = sum (\<lambda>i. if l ! i = i then szl ! i else 0)
                         ({0..<length l}-{rep_of l i,rep_of l j})
               + (szl ! rep_of l i + szl ! rep_of l j)" (is "?L + _ = ?R + _")
  proof -
    have "?L = sum (\<lambda>ia. szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l j})\<inter>{ia. ?upd ! ia = ia})"
      apply(subst sum.inter_restrict) by simp_all
    also have "\<dots> = sum (\<lambda>ia. szl[rep_of l j := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia})"
      unfolding ss by simp
    also have "\<dots> = ?R"
      apply(subst sum.inter_restrict) apply simp apply auto apply(rule sum.cong) apply simp using assms by auto
    finally have "?L = ?R" .
    then show ?thesis by simp
  qed
  also have "\<dots> = (\<Sum>i = 0..<length l. if l ! i = i then szl ! i else 0)"
    apply(subst (2) **) apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply(subst ff) using assms apply (auto simp: rep_of_min)
    done
  also from i have "\<dots> = length l" unfolding invar_def by auto
  finally have A: "?A = length l" .

  have max_distrib: "\<And>a b :: nat. (2::nat) ^ max a b = max (2 ^ a) (2 ^ b)"
    by (simp add: max_def)
  {
    assume a: "rep_of l j < length szl" "?upd ! rep_of l j = rep_of l j"

    from i have g: "\<And>i. i<length l \<Longrightarrow> l ! i = i \<Longrightarrow> 2 ^ h_of l i \<le> szl ! i" unfolding invar_def by metis

    have "(2::nat) ^ (max (h_of l (rep_of l j)) (Suc (h_of l (rep_of l i))))
          \<le> max ( (szl ! (rep_of l j))) (2 * (szl ! (rep_of l i)))"
      apply(subst max_distrib)
      apply(rule max.mono)
      subgoal apply(rule g) using assms a by (auto simp: rep_of_min)
      subgoal apply(simp only: power.power_Suc) apply(rule mult_left_mono)
        apply(rule g) using assms a by (auto simp: rep_of_refl rep_of_min rep_of_bound)
      done
    also have "\<dots> \<le> szl ! rep_of l i + szl ! rep_of l j"
      using size by auto
    finally
    have "2 ^ max (h_of l (rep_of l j)) (Suc (h_of l (rep_of l i))) \<le> szl ! rep_of l i + szl ! rep_of l j"
      .
  } note absch = this

  show ?thesis unfolding invar_def
    apply safe
    subgoal using i[unfolded invar_def] by simp
    subgoal apply simp using A by simp
    subgoal for i apply(cases "i=rep_of l j")
      subgoal apply simp
        apply(rule order.trans)
         apply(rule power_increasing[OF h_of_uf_union_touched])
                prefer 9
        subgoal using absch by simp
        using assms by (auto simp: rep_of_idem)
      subgoal
        apply simp apply(subst h_of_uf_union_untouched)
               prefer 8 subgoal
          using i unfolding invar_def
          by (metis nth_list_update')
        using assms apply (auto simp: rep_of_idem )
        by (metis nth_list_update')
      done
    done
qed

lemma 21:
  assumes "i < length l "" j < length l ""
       ufa_invar l "
       "(i, j) \<notin> ufa_\<alpha> l "
   and size: "\<not> szl ! rep_of l i < szl ! rep_of l j  "
  and i: "invar l szl "
      shows "invar (ufa_union l j i) (szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j])"
proof -
  let ?upd = "ufa_union l j i"

  from i have [simp]: "length szl = length l" unfolding invar_def by auto

  { fix a b and f :: "'a\<Rightarrow>nat" have r: "a\<noteq>b \<Longrightarrow> sum f {a,b}   = f a + f b" by simp     }
  note ff=this

  have *: "{0..<length l} = ({0..<length l}-{rep_of l i}) \<union> {rep_of l i}"
    using assms rep_of_bound by auto
  have **:"{0..<length l} = ({0..<length l}-{rep_of l i,rep_of l j}) \<union> {rep_of l i,rep_of l j}"
    using assms rep_of_bound by auto

  have ss: "(({0..<length l} - {rep_of l i}) \<inter> {ia. ?upd ! ia = ia})
        = ({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia}" using assms by (auto simp: nth_list_update')

  have "(\<Sum>ia = 0..<length l. if ?upd ! ia = ia then szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0)
     = sum (\<lambda>ia. if ?upd ! ia = ia then szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia else 0) ({0..<length l}-{rep_of l i})
            + (szl ! rep_of l i + szl ! rep_of l j)" (is "?A = _")
    apply(subst *)  apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply safe
    subgoal using assms rep_of_bound
      using invar_def by fastforce
    subgoal using assms
      using rep_of_min ufa_find_correct by fastforce
    subgoal using assms
      using rep_of_min ufa_find_correct by fastforce
    done
  also have "\<dots> = sum (\<lambda>i. if l ! i = i then szl ! i else 0)
                         ({0..<length l}-{rep_of l i,rep_of l j})
               + (szl ! rep_of l i + szl ! rep_of l j)" (is "?L + _ = ?R + _")
  proof -
    have "?L = sum (\<lambda>ia. szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l i})\<inter>{ia. ?upd ! ia = ia})"
      apply(subst sum.inter_restrict) by simp_all
    also have "\<dots> = sum (\<lambda>ia. szl[rep_of l i := szl ! rep_of l i + szl ! rep_of l j] ! ia)
                 (({0..<length l}-{rep_of l i,rep_of l j}) \<inter> {ia. l ! ia = ia})"
      unfolding ss by simp
    also have "\<dots> = ?R"
      apply(subst sum.inter_restrict) apply simp apply auto apply(rule sum.cong) apply simp using assms by auto
    finally have "?L = ?R" .
    then show ?thesis by simp
  qed
  also have "\<dots> = (\<Sum>i = 0..<length l. if l ! i = i then szl ! i else 0)"
    apply(subst (2) **) apply(subst sum_Un_nat) apply simp apply simp apply simp
    apply(subst ff) using assms apply (auto simp: rep_of_min)
    using ufa_find_correct by blast
  also from i have "\<dots> = length l" unfolding invar_def by auto
  finally have A: "?A = length l" .

  have max_distrib: "\<And>a b :: nat. (2::nat) ^ max a b = max (2 ^ a) (2 ^ b)"
    by (simp add: max_def)
  {
    assume a: "rep_of l i < length szl" "?upd ! rep_of l i = rep_of l i"

    from i have g: "\<And>i. i<length l \<Longrightarrow> l ! i = i \<Longrightarrow> 2 ^ h_of l i \<le> szl ! i" unfolding invar_def by metis

    have "(2::nat) ^ (max (h_of l (rep_of l i)) (Suc (h_of l (rep_of l j))))
          \<le> max ( (szl ! (rep_of l i))) (2 * (szl ! (rep_of l j)))"
      apply(subst max_distrib)
      apply(rule max.mono)
      subgoal apply(rule g) using assms a by (auto simp: rep_of_min)
      subgoal apply(simp only: power.power_Suc) apply(rule mult_left_mono)
        apply(rule g) using assms a by (auto simp: rep_of_refl rep_of_min rep_of_bound)
      done
    also have "\<dots> \<le> szl ! rep_of l i + szl ! rep_of l j"
      using size by auto
    finally
    have "2 ^ max (h_of l (rep_of l i)) (Suc (h_of l (rep_of l j))) \<le> szl ! rep_of l i + szl ! rep_of l j"
      .
  } note absch = this

  show ?thesis unfolding invar_def
    apply safe
    subgoal using i[unfolded invar_def] by simp
    subgoal apply simp using A by simp
    subgoal for e apply(cases "e=rep_of l i")
      subgoal apply simp
        apply(rule order.trans)
         apply(rule power_increasing[OF h_of_uf_union_touched])
                prefer 9
        subgoal using absch by simp
        using assms by (auto simp: rep_of_idem ufa_find_correct)
      subgoal
        apply simp apply(subst h_of_uf_union_untouched)
               prefer 8 subgoal
          using i unfolding invar_def
          by (metis nth_list_update')
        using assms apply (auto simp: rep_of_idem )
        by (metis nth_list_update')
      done
    done
qed

lemma uf_union_rule': "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u * $(11+ height_ub (card (Domain R))*2)> uf_union u i j <is_uf (per_union R i j)>\<^sub>t"
  unfolding uf_union_def
  apply (cases u)
  apply(sep_auto heap: uf_rep_of_rule_ub simp add: is_uf_def[abs_def])
    apply(simp add: ufa_\<alpha>_lenD)
  apply simp
  apply(sep_auto heap: uf_rep_of_rule_ub)
    apply(simp add: ufa_\<alpha>_lenD)
   apply simp
  apply (sep_auto
    simp: per_union_cmp ufa_\<alpha>_lenD ufa_find_correct
    rep_of_bound
    ufa_union_invar
    ufa_union_correct
  )
  subgoal apply(drule ufa_\<alpha>_lenD) apply(drule ufa_\<alpha>_lenD) using 12 by blast
  apply (sep_auto
    simp: per_union_cmp ufa_\<alpha>_lenD ufa_find_correct
    rep_of_bound
    ufa_union_invar
    ufa_union_correct
  )
  subgoal apply(drule ufa_\<alpha>_lenD) apply(drule ufa_\<alpha>_lenD) using 21 by blast
  done

definition "uf_union_time n = 11+ height_ub n*2"

lemma uf_union_time_bound[asym_bound]: "uf_union_time \<in> \<Theta>(\<lambda>n. ln n)"
  unfolding uf_union_time_def by auto2

lemma uf_union_rule: "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u * $(uf_union_time (card (Domain R)))> uf_union u i j <is_uf (per_union R i j)>\<^sub>t"
  unfolding uf_union_time_def using uf_union_rule' by auto

interpretation UnionFind_Impl is_uf uf_init uf_init_time uf_cmp uf_cmp_time uf_union uf_union_time
proof (unfold_locales, goal_cases)
case (1 t x' x)
  show ?case
    unfolding PR_CONST_def mop_per_init_def apply simp
    apply(rule extract_cost_otherway'[OF _ uf_init_rule, where Cost_lb="uf_init_time x"])
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    using 1 by simp
next
  case (2 t R' R a' a b' b)
   show ?case
    unfolding PR_CONST_def mop_per_compare_def apply simp
    apply(rule extract_cost_otherway'[OF _ uf_cmp_rule, where Cost_lb="(uf_cmp_time (card (Domain R')))"])
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    using 2 by simp
next
  case (3  t R' R a' a b' b)
   show ?case
    unfolding PR_CONST_def mop_per_union_def apply simp
    apply(rule extract_cost_otherway'[OF _ uf_union_rule, where Cost_lb="(uf_union_time (card (Domain R')))"])
        apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    subgoal using 3 by simp
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def)+
    subgoal using 3 by simp
      apply (sep_auto simp: per_init'_def hn_ctxt_def pure_def invalid_assn_def)+
    using 3 by simp
qed

end


theory labellings
  imports base
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=2] (*default settings*)

(************** Labelling-based semantics for argumentation frameworks ******************)

(* Sources:
 [BCG 2011] Baroni, P., M. Caminada and M. Giacomin, An introduction to argumentation semantics,
  Knowledge Engineering Review (2011)
*)

(* Generalising sets as "labellings", i.e. functions into some finite codomain (of "labels") *)
datatype Label = In | Out | Undec (*introduces a 3-element set of labels*)
type_synonym 'a Labelling = \<open>'a \<Rightarrow> Label\<close> (*labellings as functions into "labels" *)

(* (cf. [BCG 2011] p. 4) *)
definition inset :: \<open>'a Labelling \<Rightarrow> 'a Set\<close> ("in") where \<open>in(Lab) \<equiv> \<lambda>x. Lab(x) = In\<close>
definition outset :: \<open>'a Labelling \<Rightarrow> 'a Set\<close> ("out") where \<open>out(Lab) \<equiv> \<lambda>x. Lab(x) = Out\<close>
definition undecset :: \<open>'a Labelling \<Rightarrow> 'a Set\<close> ("undec") where \<open>undec(Lab) \<equiv> \<lambda>x. Lab(x) = Undec\<close>

declare inset_def[Defs] outset_def[Defs] undecset_def[Defs]

(* The definitions below draw from [BCG 2011] but are stated for any arbitrarily labelled argument.*)
(* An argument is termed legally-in if all of its attackers are labelled out ([BCG 2011] Def. 9). *)
definition legallyIn :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> 'a \<Rightarrow> bool\<close>
  where \<open>legallyIn AF Lab \<equiv> \<lambda>x.  (\<forall>y. (AF y x) \<longrightarrow> out Lab y)\<close>
(* An argument is termed legally-out if it has an in-labelled attacker ([BCG 2011] Def. 9). *)
definition legallyOut :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> 'a \<Rightarrow> bool\<close>
  where \<open>legallyOut AF Lab \<equiv>  \<lambda>x.  (\<exists>y. (AF y x) \<and> in Lab y)\<close>
(* An argument is termed legally-undec if it is neither legally-in nor legally-out ([BCG2011] Def. 17). *)
definition legallyUndec :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> 'a \<Rightarrow> bool\<close>
  where \<open>legallyUndec AF Lab \<equiv> \<lambda>x. \<not>legallyIn AF Lab x \<and> \<not>legallyOut AF Lab x\<close>

declare legallyIn_def[Defs] legallyOut_def[Defs] legallyUndec_def[Defs]

(* A labelling is termed conflict-free when ([BCG2011] Def. 16)
 (i) every in-labelled argument is not legally-out (i.e. it does not have an attacked that is in-labelled);
(ii) every out-labelled argument is legally-out. *)
definition conflictfree :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>conflictfree AF Lab \<equiv> \<forall>x. (in Lab x  \<longrightarrow> \<not>legallyOut AF Lab x) \<and> (out Lab x \<longrightarrow> legallyOut AF Lab x)\<close>
declare conflictfree_def[Defs]

(* A labelling is termed conflict-free when ([BCG2011] Def. 10)
 (i) every in-labelled argument is legally-in;
(ii) every out-labelled argument is legally-out. *)
definition admissible :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>admissible AF Lab \<equiv> \<forall>x. (in Lab x \<longrightarrow> legallyIn AF Lab x) \<and> (out Lab x \<longrightarrow> legallyOut AF Lab x)\<close>
declare admissible_def[Defs]

(* A complete labelling is an admissible labelling where every undec-labelled argument is legally-undec ([BCG2011] Def. 10). *)
definition complete :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>complete AF Lab \<equiv> admissible AF Lab \<and> (\<forall>x. undec Lab x \<longrightarrow> legallyUndec AF Lab x)\<close>
declare complete_def[Defs]

(* For complete labellings, legally-in/out does indeed imply in/out-labelled. *)
lemma completeLegIn:  \<open>complete AF Lab \<and> legallyIn AF Lab x \<longrightarrow> in Lab x\<close> unfolding Defs by (metis Label.exhaust)
lemma completeLegOut: \<open>complete AF Lab \<and> legallyOut AF Lab x \<longrightarrow> out Lab x\<close> unfolding Defs by (metis Label.exhaust)

(* Complete labelling can be alternatively characterised as the labellings in which, for each argument A
 (i) A is labelled in iff all its attackers are labelled out; and
(ii) A is labelled out iff it has at least one attacker that is labelled in ([BCG2011] Prop. 2). *)
definition complete2 :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>complete2 AF Lab \<equiv> (\<forall>x. (in Lab x \<longleftrightarrow> legallyIn AF Lab x) \<and>
                                            (out Lab x \<longleftrightarrow> legallyOut AF Lab x))\<close>
declare complete2_def[Defs]

lemma complete_def2: \<open>complete AF Lab = complete2 AF Lab\<close>
 using completeLegIn completeLegOut complete2_def by (metis Label.distinct(3) Label.distinct(5) admissible_def complete_def legallyUndec_def inset_def outset_def undecset_def)

(* A grounded labelling is a (the) complete labelling whose in-set is minimal (least) wrt.
set inclusion ([BCG 2011] Def. 20). The two definitions below are shown equivalent in theory "tests". *)
definition grounded :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>grounded AF Lab \<equiv> minimal (complete AF) Lab in\<close>
definition grounded2 :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>grounded2 AF Lab \<equiv> least (complete AF) Lab in\<close>
declare grounded_def[Defs] grounded2_def[Defs]

(* Def. 22 from [BCG 2011] *)
definition preferred :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling => bool\<close>
  where \<open>preferred AF Lab \<equiv> maximal (complete AF) Lab in\<close>
declare preferred_def[Defs]

(* Def 24 from [BCG 2011] *)
definition stable :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling => bool\<close>
  where \<open>stable AF Lab \<equiv> complete AF Lab \<and> (\<forall>x. Lab(x) \<noteq> Undec)\<close>
declare stable_def[Defs]

(* Def. 26 from [BCG 2011] *)
definition semistable :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>semistable AF Lab \<equiv> minimal (complete AF) Lab undec\<close>
declare semistable_def[Defs]

(* Def. 28 from [BCG 2011] *)
definition lessOrEquallyCommitted :: \<open>'a Labelling \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close> (infix "\<sqsubseteq>" 52)
  where "L1 \<sqsubseteq> L2 \<equiv> (in(L1) \<subseteq> in(L2)) \<and> (out(L1) \<subseteq> out(L2))"
declare lessOrEquallyCommitted_def[Defs]

(* Def. 29 from [BCG 2011] *)
definition ideal :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  (* where \<open>ideal AF Lab \<equiv> admissible AF Lab \<and> (\<forall>L. ((admissible AF L) \<and> Lab \<sqsubseteq> L) \<longrightarrow> (\<forall>x. Lab(x) = L(x))) \<and> (\<forall>L. ((preferred AF L)) \<longrightarrow> (Lab \<sqsubseteq> L)) \<close>   *)
  where \<open>ideal AF Lab \<equiv> admissible AF Lab \<and> (\<forall>L. admissible AF L \<longrightarrow> L \<sqsubseteq> Lab) \<and> (\<forall>L. preferred AF L \<longrightarrow> Lab \<sqsubseteq> L)\<close>
declare ideal_def[Defs]

(* Def. 31 from [BCG2011] *)
definition stage :: \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling \<Rightarrow> bool\<close>
  where \<open>stage AF Lab \<equiv> minimal (conflictfree AF) Lab undec\<close>
declare stage_def[Defs]

(********** Argument justification (cf. [BCG 2011] \<section>4). ****************)
type_synonym 'a Semantics = \<open>'a \<A>\<F> \<Rightarrow> 'a Labelling => bool\<close>

definition skepticallyJustified :: \<open>'a Semantics \<Rightarrow> 'a \<A>\<F> \<Rightarrow> 'a \<Rightarrow> bool\<close> ("sJ")
  where \<open>sJ S AF \<equiv> \<lambda>arg. \<forall>Lab. (S AF Lab) \<longrightarrow> Lab(arg) = In\<close>
definition credulouslyJustified :: \<open>'a Semantics \<Rightarrow> 'a \<A>\<F> \<Rightarrow> 'a \<Rightarrow> bool\<close> ("cJ")
  where \<open>cJ S AF \<equiv> \<lambda>arg. \<exists>Lab. (S AF Lab) \<longrightarrow> Lab(arg) = In\<close>

lemma \<open>sJ S AF a \<Longrightarrow> cJ S AF a\<close>
  by (simp add: credulouslyJustified_def skepticallyJustified_def)
lemma \<open>cJ S AF a \<Longrightarrow> sJ S AF a\<close> nitpick oops

(****************** Utility function for Examples *********************)

(* This is adapted for label functions: *)
abbreviation "findFor AF Prop Ext \<equiv> \<forall>Lab. Ext Lab \<longleftrightarrow> (Prop(AF) Lab)"
(* when using sets instead of predicates, we get nitpick to output only those which are contained: *)
abbreviation "findFor2 AF Prop Ext \<equiv> \<forall>Lab. Lab \<in> Ext \<longleftrightarrow> (Prop(AF) Lab)"

end