theory NielsenSchreier
imports N_Properties Minimal Main Freegroup_with_Basis
begin
section \<open>Proof of Nielsen-Schreier.\<close>

text \<open>This file contains the formalisation of Nielsen Schreier\<close>

text \<open>We define N reduced set as follows\<close>

definition N_reduced ("N")
  where
"N_reduced A S = ((\<forall>xs \<in> (red_rep S) ` (union_inv A S). N0 xs) \<and>
                  (\<forall>xs \<in> (red_rep S) ` (union_inv A S).
                      \<forall>ys \<in> (red_rep S) ` (union_inv A S). N1 xs ys) \<and>
                  (\<forall>xs \<in> (red_rep S) ` (union_inv A S).
                      \<forall>ys \<in> (red_rep S) ` (union_inv A S).
                         \<forall> zs \<in> (red_rep S) ` (union_inv A S).
                             N2 xs ys zs))"

lemma N_reduced_X: assumes "G \<le> freegroup S"
  shows "N_reduced (X' (SG (freegroup S) G) S) S"
proof-
  have N0: "((\<forall>x \<in> (red_rep S) ` (union_inv  (X' (SG (freegroup S) G) S) S). N0 x))"
    using assms N0 by blast
  moreover have N1: "\<forall>x \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
                      \<forall>y \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
                               N1 x y"
    using assms N1 by blast
  moreover have "\<forall>x \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
                    \<forall>y \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
                      \<forall>z \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
                        N2 x y z"
    using N0 N1 N2 assms by blast
  ultimately show ?thesis unfolding N_reduced_def by blast
qed

lemma id_notin_union_inv_X:
  assumes "G \<le> (freegroup S)"
  shows "\<forall>x \<in>  (union_inv  (X' (SG (freegroup S) G) S) S). x \<noteq> \<one>\<^bsub>freegroup S\<^esub>"
proof(rule ccontr)
  assume "\<not> (\<forall>x\<in>union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S. x \<noteq> \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>)"
  then obtain x where x:"x \<in> union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S" "x = \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>" by simp
  hence "x = reln_tuple \<langle>S\<rangle> `` {[]}" using freegroup_def[of S] by simp
  moreover have "reduced []" by auto
  ultimately have "red_rep S x = []"
    unfolding red_rep_def using red_repI[of x S "[]"]
    x unfolding freegroup_def[of "S"] union_inv_def X'_def SG_def
    by (simp add: freewords_on_def quotientI red_rep_def words_on.intros(1))
  thus False using x N_reduced_X[OF assms] unfolding N_reduced_def
    using N0_def by blast
qed

lemma min_set_exists:
  assumes "G \<le> (freegroup S)"
  shows "\<exists>A. A = minimal_set (X' (SG (freegroup S) G) S) S"
  by simp

lemma union_inv_eq_minimal:
  assumes "G \<le> (freegroup S)"
  shows "union_inv (X' (SG (freegroup S) G) S) S
                  = union_inv (minimal_set (X' (SG (freegroup S) G) S) S) S"
proof-
  let ?Q =  "\<lambda> Y . (Y \<subseteq>   (X' (SG (freegroup S) G) S)
        \<and>  Y \<inter> (m_inv (freegroup S) ` Y) = {}
        \<and> union_inv Y S = union_inv (X' (SG (freegroup S) G) S) S)"
  obtain A where S:"A \<subseteq>  (X' (SG (freegroup S) G) S) "
                   "A \<inter> (m_inv (freegroup S) ` A) = {}"
          "union_inv (X' (SG (freegroup S) G) S) S  = union_inv A S"
    using group.existence_of_minimal[OF freegroup_is_group]
    by (smt (verit, del_insts) G'_def UnCI X'_def assms dual_order.trans gen_span.intros(1) mem_Collect_eq one_SG subgroup.mem_carrier subset_eq union_inv_def union_inv_sub_H)
  hence Q_S:"?Q A" by argo
  hence "?Q (minimal_set (X' (SG (freegroup S) G) S) S)" unfolding minimal_set_def using someI
    by (smt (verit))
  then show ?thesis by argo
qed

lemma minimal_set_empty_intersection:
  assumes "G \<le> (freegroup S)"
  shows "(minimal_set (X' (SG (freegroup S) G) S) S)
      \<inter>(m_inv (freegroup S) ` (minimal_set (X' (SG (freegroup S) G) S) S)) = {}"
proof-
  let ?Q =  "\<lambda> Y . (Y \<subseteq>   (X' (SG (freegroup S) G) S)
        \<and>  Y \<inter> (m_inv (freegroup S) ` Y) = {}
        \<and> union_inv Y S = union_inv (X' (SG (freegroup S) G) S)  S)"
  obtain A where S:" A \<subseteq>  (X' (SG (freegroup S) G) S) " "A \<inter> (m_inv (freegroup S) ` A) = {}"
          "union_inv (X' (SG (freegroup S) G) S) S  = union_inv A S"
    using group.existence_of_minimal[OF freegroup_is_group]
    by (smt (verit, del_insts) G'_def UnCI X'_def assms dual_order.trans gen_span.intros(1)
          mem_Collect_eq one_SG subgroup.mem_carrier subset_eq union_inv_def union_inv_sub_H)
  hence Q_S:"?Q A" by argo
  hence "?Q (minimal_set (X' (SG (freegroup S) G) S) S)" unfolding minimal_set_def using someI
    by (smt (verit, del_insts))
  then show ?thesis by argo
qed

lemma minimal_set_in_carrier:
  assumes "G \<le> (freegroup S)"
  shows "(minimal_set (X' (SG (freegroup S) G) S) S) \<subseteq> carrier (freegroup S)"
proof-
  let ?Q =  "\<lambda> Y . (Y \<subseteq>   (X' (SG (freegroup S) G) S)
        \<and>  Y \<inter> (m_inv (freegroup S) ` Y) = {}
        \<and> union_inv Y S = union_inv (X' (SG (freegroup S) G) S)  S)"
  obtain A where S:" A \<subseteq>  (X' (SG (freegroup S) G) S)" "A \<inter> (m_inv (freegroup S) ` A) = {}"
          "union_inv (X' (SG (freegroup S) G) S) S  = union_inv A S"
    using group.existence_of_minimal[OF freegroup_is_group]
    by (smt (verit, del_insts) G'_def UnCI X'_def assms dual_order.trans gen_span.intros(1)
          mem_Collect_eq one_SG subgroup.mem_carrier subset_eq union_inv_def union_inv_sub_H)
  hence Q_S:"?Q A" by argo
  hence "?Q (minimal_set (X' (SG (freegroup S) G) S) S)" unfolding minimal_set_def using someI
   by (smt (verit, ccfv_SIG))
  hence "(minimal_set (X' (SG (freegroup S) G) S) S) \<subseteq>  (X' (SG (freegroup S) G) S)" by argo
  thus ?thesis using assms unfolding X'_def SG_def
    using subgroup.subset by fastforce
qed

lemma N_reduced_minimal:
  assumes "G \<le> (freegroup S)"
  shows "N_reduced (minimal_set (X' (SG (freegroup S) G) S) S) S"
  using union_inv_eq_minimal  unfolding N_reduced_def
    using N_reduced_X N_reduced_def assms by blast

lemma union_inv_eq_span:
  assumes "union_inv A S = union_inv B S"
  shows "\<langle>A\<rangle>\<^bsub>freegroup S\<^esub> = \<langle>B\<rangle>\<^bsub>freegroup S\<^esub>"
proof(rule equalityI)
  show " \<langle>A\<rangle>\<^bsub>freegroup S\<^esub> \<subseteq> \<langle>B\<rangle>\<^bsub>freegroup S\<^esub>" unfolding union_inv_def
  proof
    fix x
    assume x:"x \<in> \<langle>A\<rangle>\<^bsub>freegroup S\<^esub>"
    show "x \<in>  \<langle>B\<rangle>\<^bsub>freegroup S\<^esub>" using x
    proof(induction rule:gen_span.induct)
      case gen_one
      then show ?case by auto
    next
      case (gen_gens x)
      then show ?case using assms unfolding union_inv_def
        by (metis (mono_tags, opaque_lifting) Un_iff gen_span.gen_gens gen_span.gen_inv imageE)
    next
      case (gen_inv x)
      then show ?case
        by (simp add: gen_span.gen_inv)
    next
      case (gen_mult x y)
      then show ?case
        by (simp add: gen_span.gen_mult)
    qed
  qed
next
 show " \<langle>B\<rangle>\<^bsub>freegroup S\<^esub> \<subseteq> \<langle>A\<rangle>\<^bsub>freegroup S\<^esub>" unfolding union_inv_def
  proof
    fix x
    assume x:"x \<in> \<langle>B\<rangle>\<^bsub>freegroup S\<^esub>"
    show "x \<in>  \<langle>A\<rangle>\<^bsub>freegroup S\<^esub>" using x
    proof(induction rule:gen_span.induct)
      case gen_one
      then show ?case by auto
    next
      case (gen_gens x)
      then show ?case using assms unfolding union_inv_def
        by (metis (mono_tags, opaque_lifting) Un_iff gen_span.gen_gens gen_span.gen_inv imageE)
    next
      case (gen_inv x)
      then show ?case
        by (simp add: gen_span.gen_inv)
    next
      case (gen_mult x y)
      then show ?case
        by (simp add: gen_span.gen_mult)
    qed
  qed
qed

lemma min_set_eq_span:
  assumes "G \<le> (freegroup S)"
  shows "\<langle>(minimal_set (X' (SG (freegroup S) G) S) S)\<rangle>\<^bsub>(freegroup S)\<^esub>
    =  \<langle>(X' (SG (freegroup S) G) S)\<rangle>\<^bsub>(freegroup S)\<^esub>"
  using N_reduced_minimal union_inv_eq_span union_inv_eq_minimal
  using assms by blast

lemma (in group) carrier_eq_minimal:
  assumes "H \<le> freegroup S"
  shows "\<langle>(minimal_set (X' (SG (freegroup S) H) S) S)\<rangle>\<^bsub>freegroup S\<^esub> = H"
proof-
  let ?Y = "(X' (SG (freegroup S) H) S)"
  have 1:"\<langle>?Y\<rangle>\<^bsub>(SG (freegroup S) H)\<^esub> = carrier (SG (freegroup S) H)"
    using span_X_SG_eq_SG assms
    by (simp add: span_X_SG_eq_SG assms)
   have carr:"carrier (SG (freegroup S) H) = H" unfolding SG_def
      by simp
   have 2:"\<langle>?Y\<rangle>\<^bsub>(SG (freegroup S) H)\<^esub> = \<langle>?Y\<rangle>\<^bsub>(freegroup S)\<^esub>"
  proof
      show  "\<langle>?Y\<rangle>\<^bsub>(SG (freegroup S) H)\<^esub> \<subseteq> \<langle>?Y\<rangle> \<^bsub>(freegroup S)\<^esub>"
      proof(rule subsetI)
        fix x
        assume x:"x \<in> \<langle>X' (SG F\<^bsub>S\<^esub> H) S\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> H\<^esub>"
        show "x \<in> \<langle>X' (SG F\<^bsub>S\<^esub> H) S\<rangle>\<^bsub>F\<^bsub>S\<^esub>\<^esub>" using x
        proof(induction x rule:gen_span.induct)
          case gen_one
          then show ?case
            by (metis gen_span.gen_one one_SG)
        next
          case (gen_gens x)
          then show ?case
            by (simp add: gen_span.gen_gens)
        next
          case (gen_inv x)
          then show ?case
            by (metis "1" assms carr freegroup_is_group gen_span.gen_inv inv_SG)
        next
          case (gen_mult x y)
          then show ?case
            by (metis gen_span.gen_mult mult_SG)
        qed
      qed
    next
      show  "\<langle>?Y\<rangle>\<^bsub>(freegroup S)\<^esub> \<subseteq> \<langle>?Y\<rangle>\<^bsub>(SG (freegroup S) H)\<^esub>"
      proof
        fix x
        assume "x \<in> \<langle>?Y\<rangle>\<^bsub>(freegroup S)\<^esub>"
        thus "x \<in> \<langle>?Y\<rangle>\<^bsub>(SG (freegroup S) H)\<^esub>"
        proof(induction x rule:gen_span.induct)
          case gen_one
          then show ?case using assms
            unfolding SG_def X'_def
            by (metis (mono_tags, lifting) SG_def gen_span.gen_one one_SG)
        next
          case (gen_gens x)
          then show ?case
            by (simp add: gen_span.gen_gens)
        next
          case (gen_inv x)
          then show ?case using  gen_span.gen_inv[OF gen_inv(2)]
                group.m_inv_consistent[OF "freegroup_is_group" assms] carr unfolding X'_def
            by (metis (mono_tags, lifting) SG_def 1 gen_inv.IH)
        next
          case (gen_mult x y)
          then show ?case using gen_span.gen_mult[OF gen_mult(3,4)]
             group.subgroup_mult_equality[OF "freegroup_is_group" assms] carr unfolding X'_def SG_def
            by simp
        qed
      qed
    qed
  show ?thesis using 1  HOL.sym[OF 2] min_set_eq_span[OF assms] carr by argo
qed

lemma(in group) minimal_implies_non_id:
  assumes "H \<le> freegroup S"
  shows "\<forall>ws \<in> \<langle>(minimal_set (X' (SG (freegroup S) H) S) S)\<rangle>\<^bsub>freegroup S\<^esub>.
       non_reducible (freegroup S) (minimal_set (X' (SG (freegroup S) H) S) S) ws
                  \<longrightarrow> ws \<noteq> \<one>\<^bsub>freegroup S\<^esub>"
proof
  fix w
  assume w_in:"w \<in> \<langle>minimal_set (X' (SG F\<^bsub>S\<^esub> H) S) S\<rangle>\<^bsub>freegroup S\<^esub>"
  show "non_reducible (freegroup S) (minimal_set (X' (SG (freegroup S) H) S) S) w
                  \<longrightarrow> w \<noteq> \<one>\<^bsub>freegroup S\<^esub>"
  proof
    assume asm:"non_reducible F\<^bsub>S\<^esub> (minimal_set (X' (SG (freegroup S) H) S) S) w"
    define Y where "Y = (minimal_set (X' (SG (freegroup S) H) S) S)"
    hence "non_reducible (freegroup S) Y w" using asm by auto
    then obtain ls where ls:"w = monoid.m_concat (freegroup S) ls" "(ls \<noteq> [])"
                          "\<forall>x \<in> set ls. x \<in> Y \<union> m_inv (freegroup S) ` Y"
                 "(length ls = 1) \<or>(\<forall>i \<le> (length ls)-2 . ls!i \<noteq> inv\<^bsub>freegroup S\<^esub> (ls!(i+1)))"
      unfolding non_reducible_def by auto
    from ls have ls_in:"set ls \<subseteq> carrier (freegroup S)" unfolding Y_def
      using minimal_set_in_carrier[OF assms]
      by (metis (no_types, lifting) assms subgroup.subset subset_eq union_inv_def union_inv_eq_minimal union_inv_sub_H)
    define ls0 where "ls0 =  (map (red_rep S) ls)"
    hence w_eq:"w = reln_tuple \<langle>S\<rangle> `` {l_concat ls0}"
      using ls(1) ls_in
      by (simp add: m_concat_to_l_concat)
    then show "w \<noteq> \<one>\<^bsub>freegroup S\<^esub>"
    proof(cases "length ls = 1")
      case True
      then obtain s where s:"ls = [s]" "s \<in> union_inv Y S"  unfolding ls0_def
        using one_list unfolding union_inv_def
        by (metis list.set_intros(1) ls(3))
      hence "s \<noteq> \<one> \<^bsub>freegroup S\<^esub>"  using id_notin_union_inv_X[OF assms]
        unfolding Y_def
        by (simp add: assms union_inv_eq_minimal)
      thus ?thesis using ls(1) s(1)
        using ls_in m_concat_singleton by force
    next
      case False
      define B where "B = (red_rep S) ` union_inv Y S"
      have subs_B:"B \<subseteq> (red_rep S) ` (carrier (freegroup S))" unfolding B_def
        Y_def using  minimal_set_in_carrier[OF assms]
        by (metis assms image_mono union_inv_clos union_inv_eq_minimal)
      moreover have "\<forall>x \<in> B. N0 x" unfolding B_def Y_def using N_reduced_minimal[OF assms]
        unfolding N_reduced_def by argo
      moreover have "\<forall>x \<in> B. \<forall>y \<in> B. N1 x y"
        unfolding B_def Y_def using N_reduced_minimal[OF assms]
        unfolding N_reduced_def by argo
      moreover have "\<forall>x \<in> B. \<forall>y \<in> B. \<forall>z \<in> B. N2 x y z"
        unfolding B_def Y_def using N_reduced_minimal[OF assms]
        unfolding N_reduced_def by argo
      moreover have "ls0 \<noteq> []" unfolding ls0_def using ls(2) by simp
      moreover have set_ls0:"set ls0 \<subseteq> B" unfolding B_def ls0_def using ls(3) unfolding union_inv_def
        by force
      moreover have "\<forall>i < (length ls0 - 1). (ls0!i) \<noteq> (wordinverse (ls0!(i+1)))"
      proof(rule ccontr)
        assume "\<not> (\<forall>i < (length ls0 - 1). (ls0!i) \<noteq> (wordinverse (ls0!(i+1))))"
        then obtain i where i:"i < length ls0 -1" "ls0!i = (wordinverse (ls0!(i+1)))"
          by fastforce
        moreover have len:"length ls0 \<ge> 2" using False ls(2) unfolding ls0_def
          by (metis One_nat_def le_less_linear length_greater_0_conv length_map less_2_cases_iff neq0_conv)
        ultimately have i_leq:"i \<le> length ls0 - 2" by auto
        from i(2) have rel:"((ls0!i)@(ls0!(i+1))) ~ []" using i(2)
          using FreeGroupMain.inverse_wordinverse by auto
        have in_carri:"ls!i \<in> carrier (freegroup S)" using i_leq len ls0_def len False ls_in
          by (metis add_lessD1 i(1) length_map less_diff_conv nth_mem subset_iff)
        have red_rep_i:"ls0!i = red_rep S (ls!i)" using ls0_def i_leq len False ls_in
          by auto
        hence ls_i_ls0_i:"ls!i = reln_tuple \<langle>S\<rangle> `` {ls0!i}" using red_rep_the
          in_carri unfolding freegroup_def apply simp
          by blast
        have 1:"ls0!i \<in> \<langle>S\<rangle>" using  redrep_in[OF in_carri] red_rep_i by auto
        have in_carrSi:"ls!(i+1) \<in> carrier (freegroup S)"
          using i_leq len ls0_def len False ls_in
          by (metis add_lessD1 i(1) length_map less_diff_conv nth_mem subset_iff)
        have red_rep_Si:"ls0!(i+1) = red_rep S (ls!(i+1))"
          using ls0_def i_leq len False ls_in
          by auto
        hence ls_Si_ls0_Si:"ls!(i+1) = reln_tuple \<langle>S\<rangle> `` {ls0!(i+1)}"
          using red_rep_the in_carrSi unfolding freegroup_def by (simp, blast)
        have 2:"ls0!(i+1) \<in> \<langle>S\<rangle>" using  redrep_in[OF in_carri] red_rep_i
          using in_carrSi red_rep_Si redrep_in by auto
        have "(ls!i)\<otimes>\<^bsub>freegroup S\<^esub>(ls!(i+1)) = reln_tuple \<langle>S\<rangle> `` ({((ls0!i)@(ls0!(i+1)))})"
          unfolding ls0_def unfolding red_rep_def using ls_i_ls0_i ls_Si_ls0_Si freegroup_def[of A] proj_append_wd[OF 1 2]
          by (metis (no_types, lifting) False i(2) i_leq in_carrSi length_map ls(4) ls0_def wordinverse_inv)
        hence id_eq:"(ls!i)\<otimes>\<^bsub>freegroup S\<^esub>(ls!(i+1)) = \<one>\<^bsub>freegroup S\<^esub>" using rel freegroup_def
          by (metis False i(2) i_leq in_carrSi length_map ls(4) ls0_def ls_Si_ls0_Si ls_i_ls0_i wordinverse_inv)
        hence "(ls!i) = inv\<^bsub>freegroup S\<^esub>(ls!(i+1))"
          using group.inv_equality[OF "freegroup_is_group" id_eq in_carrSi in_carri]
          by simp
        then show False using False ls(4) i_leq
          using ls0_def by force
      qed
      ultimately have "\<not> (l_concat ls0 ~ [])" using n_reduced_cancel by blast
      thus ?thesis unfolding w_eq
      by (simp add: append_equivred_span ls0_def ls_in word_problem_not_eq_id)
    qed
    qed
qed

lemma(in group) subgp_of_freegroup_is_fg_with_basis:
  assumes "H \<le> (freegroup S)"
  shows "fg_with_basis (SG (freegroup S) H) (minimal_set (X' (SG (freegroup S) H) S) S)"
proof-
  define Y where  "Y = (minimal_set (X' (SG (freegroup S) H) S) S)"
  hence 1:"Y \<inter> (m_inv (freegroup S) ` Y) = {}" using minimal_set_empty_intersection[OF assms] by auto
  have 2:"Y \<subseteq> carrier (freegroup S)" using minimal_set_in_carrier[OF assms] unfolding Y_def
    by auto
  have 3:"\<forall>w \<in> \<langle>Y\<rangle>\<^bsub>freegroup S\<^esub>. non_reducible (freegroup S) Y w \<longrightarrow> w \<noteq> \<one>\<^bsub>freegroup S\<^esub>"
    using minimal_implies_non_id[OF assms] unfolding Y_def .
  thus "fg_with_basis (SG (freegroup S) H) (minimal_set (X' (SG (freegroup S) H) S) S)"
   using group.fg_with_basis_eq_cond 1 2  freegroup_is_group[of "S"]
   unfolding Y_def using carrier_eq_minimal[OF assms] unfolding SG_def
   by metis
qed

lemma(in group) assumes "x \<in> carrier G" "y \<in> carrier G"
  "x \<otimes>\<^bsub>G\<^esub> y= \<one>"
shows "x = inv\<^bsub>G\<^esub> y"
  using assms
  using inv_equality by blast

text\<open>The Nielsen Schreier Theorem is formalised as follows. The notation
for a subgroup, is on the lines of formalisation of group theory in HOL-Algebra
library.\<close>

theorem(in group) Nielsen_Schreier:
  assumes "H \<le> (freegroup S)"
  shows "is_freegroup ((freegroup S)\<lparr>carrier := H\<rparr>)"
  using subgp_of_freegroup_is_fg_with_basis[OF assms] fg_with_basis_is_free
  unfolding SG_def
  by blast

end


theory UvProof
imports UvDefs "../Reduction"
begin

subsection \<open>Preliminary Lemmas\<close>

text \<open>
  At any round, given two processes \<open>p\<close> and \<open>q\<close>, there is always
  some process which is heard by both of them, and from which \<open>p\<close> and
  \<open>q\<close> have received the same message.
\<close>
lemma some_common_msg:
  assumes "HOcommPerRd UV_M (HOs r)"
  shows "\<exists>pq. pq \<in> msgRcvd (HOrcvdMsgs UV_M r p (HOs r p) (rho r))
            \<and> pq \<in> msgRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r))
            \<and> (HOrcvdMsgs UV_M r p (HOs r p) (rho r)) pq
              = (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) pq"
  using assms
  by (auto simp: UV_HOMachine_def UV_commPerRd_def HOrcvdMsgs_def
                 UV_sendMsg_def send0_def send1_def msgRcvd_def)

text \<open>
  When executing step 0, the minimum received value is always well defined.
\<close>

lemma minval_step0:
  assumes com: "HOcommPerRd UV_M (HOs r)" and s0: "step r = 0"
  shows "smallestValRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r))
         \<in> {v. \<exists>p. (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) p = Some (Val v)}"
         (is "smallestValRcvd ?msgs \<in> ?vals")
unfolding smallestValRcvd_def proof (rule Min_in)
  have "?vals \<subseteq> getval ` ((the \<circ> ?msgs) ` (HOs r q))"
    by (auto simp: HOrcvdMsgs_def image_def)
  thus "finite ?vals" by (auto simp: finite_subset)
next
  from some_common_msg[of HOs, OF com]
  obtain p where "p \<in> msgRcvd ?msgs" by blast
  with s0 show "?vals \<noteq> {}"
    by (auto simp: msgRcvd_def HOrcvdMsgs_def UV_HOMachine_def
                   UV_sendMsg_def send0_def)
qed

text \<open>
  When executing step 1 and no vote has been received, the minimum among values received
  in messages carrying no vote is well defined.
\<close>

lemma minval_step1:
  assumes  com: "HOcommPerRd UV_M (HOs r)" and s1: "step r \<noteq> 0"
  and nov: "someVoteRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) = {}"
  shows "smallestValNoVoteRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r))
          \<in> {v . \<exists>p. (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) p
                     = Some (ValVote v None)}"
        (is "smallestValNoVoteRcvd ?msgs \<in> ?vals")
unfolding smallestValNoVoteRcvd_def proof (rule Min_in)
  have "?vals \<subseteq> getval ` ((the \<circ> ?msgs) ` (HOs r q))"
    by (auto simp: HOrcvdMsgs_def image_def)
  thus "finite ?vals" by (auto simp: finite_subset)
next
  from some_common_msg[of HOs, OF com]
  obtain p where "p \<in> msgRcvd ?msgs" by blast
  with s1 nov show "?vals \<noteq> {}"
    by (auto simp: msgRcvd_def HOrcvdMsgs_def someVoteRcvd_def isValVote_def
                   UV_HOMachine_def UV_sendMsg_def send1_def)
qed

text \<open>
  The \<open>vote\<close> field is reset every time a new phase begins.
\<close>

lemma reset_vote:
  assumes run: "HORun UV_M rho HOs" and s0: "step r' = 0"
  shows "vote (rho r' p) = None"
proof (cases r')
  assume "r' = 0"
  with run show ?thesis
    by (auto simp: UV_HOMachine_def HORun_eq HOinitConfig_eq
                   initState_def UV_initState_def)
next
  fix r
  assume sucr: "r' = Suc r"
  from run
  have nxt: "nextState UV_M r p (rho r p)
                                (HOrcvdMsgs UV_M r p (HOs r p) (rho r))
                                (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def HORun_eq HOnextConfig_eq nextState_def)
  from s0 sucr have "step r = 1" by (auto simp: step_def mod_Suc)
  with nxt sucr show ?thesis
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def next1_def)
qed

text \<open>
  Processes only vote for the value they hold in their \<open>x\<close> field.
\<close>
(* The proof relies on previous lemmas @{text reset_vote} and @{text some_common_msg}. *)

lemma x_vote_eq:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and vote: "vote (rho r p) = Some v"
  shows "v = x (rho r p)"
proof (cases r)
  case 0
  with run vote show ?thesis  \<comment> \<open>no vote in initial state\<close>
    by (auto simp: UV_HOMachine_def HORun_eq HOinitConfig_eq
                   initState_def UV_initState_def)
next
  fix r'
  assume r: "r = Suc r'"
  let ?msgs = "HOrcvdMsgs UV_M r' p (HOs r' p) (rho r')"
  from run have "nextState UV_M r' p (rho r' p) ?msgs (rho (Suc r') p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with vote r
  have nxt0: "next0 r' p (rho r' p) ?msgs (rho r p)" and s0: "step r' = 0"
    by (auto simp:  nextState_def UV_HOMachine_def UV_nextState_def next1_def)
  from run s0 have "vote (rho r' p) = None" by (rule reset_vote)
  with vote nxt0
  have idv: "\<forall>q \<in> msgRcvd ?msgs. ?msgs q = Some (Val v)"
    and x: "x (rho r p) = smallestValRcvd ?msgs"
    by (auto simp: next0_def)
  moreover
  from com obtain q where "q \<in> msgRcvd ?msgs"
    by (force dest: some_common_msg)
  with idv have "{x . \<exists>qq. ?msgs qq = Some (Val x)} = {v}"
    by (auto simp: msgRcvd_def)
  hence "smallestValRcvd ?msgs = v"
    by (auto simp: smallestValRcvd_def)
  ultimately
  show ?thesis by simp
qed

subsection \<open>Proof of Irrevocability, Agreement and Integrity\<close>

text \<open>A decision can only be taken in the second round of a phase.\<close>

lemma decide_step:
  assumes run: "HORun UV_M rho HOs"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
  shows "step r = 1"
proof -
  let ?msgs = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from run have "nextState UV_M r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with decide show ?thesis
    by (auto simp: nextState_def UV_HOMachine_def UV_nextState_def
                   next0_def step_def)
qed

text \<open>No process ever decides \<open>None\<close>.\<close>
lemma decide_nonnull:
  assumes run: "HORun UV_M rho HOs"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
  shows "decide (rho (Suc r) p) \<noteq> None"
proof -
  let ?msgs = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from assms have s1: "step r = 1" by (rule decide_step)
  with run have "next1 r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                   nextState_def UV_nextState_def)
  with decide show ?thesis
    by (auto simp: next1_def dec_update_def)
qed

text \<open>
  If some process \<open>p\<close> votes for \<open>v\<close> at some round \<open>r\<close>, then any message
  that \<open>p\<close> received in \<open>r\<close> was holding \<open>v\<close> as a value.
\<close>

lemma msgs_unanimity:
  assumes run: "HORun UV_M rho HOs"
      and vote: "vote (rho (Suc r) p) = Some v"
      and q: "q \<in> msgRcvd (HOrcvdMsgs UV_M r p (HOs r p) (rho r))"
             (is "_ \<in> msgRcvd ?msgs")
  shows "getval (the (?msgs q)) = v"
proof -
  have s0: "step r = 0"
  proof (rule ccontr)
    assume "step r \<noteq> 0"
    hence "step (Suc r) = 0" by (simp add: step_def mod_Suc)
    with run vote show False by (auto simp: reset_vote)
  qed
  with run have novote: "vote (rho r p) = None" by (auto simp: reset_vote)
  from run have "nextState UV_M r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with s0 have nxt: "next0 r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  with novote vote q show ?thesis by (auto simp: next0_def)
qed

text \<open>
  Any two processes can only vote for the same value.
\<close>
(* The proof relies on previous lemmas @{text some_common_msg} and @{text msgs_unanimity}. *)

lemma vote_agreement:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and p: "vote (rho r p) = Some v"
      and q: "vote (rho r q) = Some w"
  shows "v = w"
proof (cases r)
  case 0
  with run p show ?thesis  \<comment> \<open>no votes in initial state\<close>
    by (auto simp: UV_HOMachine_def HORun_eq HOinitConfig_eq
                   initState_def UV_initState_def)
next
  fix r'
  assume r: "r = Suc r'"
  let "?msgs p" = "HOrcvdMsgs UV_M r' p (HOs r' p) (rho r')"
  from com obtain pq
    where "?msgs p pq = ?msgs q pq"
      and smp: "pq \<in> msgRcvd (?msgs p)" and smq: "pq \<in> msgRcvd (?msgs q)"
    by (force dest: some_common_msg)
  moreover
  from run p smp r have "getval (the (?msgs p pq)) = v"
    by (simp add: msgs_unanimity)
  moreover
  from run q smq r have "getval (the (?msgs q pq)) = w"
    by (simp add: msgs_unanimity)
  ultimately
  show ?thesis by simp
qed

text \<open>
  If a process decides value \<open>v\<close> then all processes must have \<open>v\<close>
  in their \<open>x\<close> fields.
\<close>
(* The proof relies on previous lemmas @{text decide_step}, @{text some_common_msg},
   @{text vote_agreement}. *)

lemma decide_equals_x:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
      and decval: "decide (rho (Suc r) p) = Some v"
  shows "x (rho (Suc r) q) = v"
proof -
  let "?msgs p'" = "HOrcvdMsgs UV_M r p' (HOs r p') (rho r)"
  from run decide have s1: "step r = 1" by (rule decide_step)
  from run have "nextState UV_M r p (rho r p) (?msgs p) (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with s1 have nxtp: "next1 r p (rho r p) (?msgs p) (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  from run have "nextState UV_M r q (rho r q) (?msgs q) (rho (Suc r) q)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with s1 have nxtq: "next1 r q (rho r q) (?msgs q) (rho (Suc r) q)"
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)

  from com obtain pq where
    pq: "pq \<in> msgRcvd (?msgs p)" "pq \<in> msgRcvd (?msgs q)"
        "(?msgs p) pq = (?msgs q) pq"
    by (force dest: some_common_msg)
  with decide decval nxtp
  have vote: "isValVote (the (?msgs p pq))"
             "getvote (the (?msgs p pq)) = Some v"
    by (auto simp: next1_def dec_update_def identicalVoteRcvd_def)
  with nxtq pq obtain q' where
    q': "q' \<in> someVoteRcvd (?msgs q)"
        "x (rho (Suc r) q) = the (getvote (the (?msgs q q')))"
    by (auto simp: next1_def x_update_def someVoteRcvd_def)
  with s1 pq vote show ?thesis
    by (auto simp: HOrcvdMsgs_def UV_HOMachine_def UV_sendMsg_def send1_def
                   someVoteRcvd_def msgRcvd_def vote_agreement[OF run com])
qed

text \<open>
  If at some point all processes hold value \<open>v\<close> in their \<open>x\<close>
  fields, then this will still be the case at the next step.
\<close>
(* The proof relies on the previous lemma @{text x_vote_eq}. *)

lemma same_x_stable:
  assumes run: "HORun UV_M rho HOs"
      and comm: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and x: "\<forall>p. x (rho r p) = v"
  shows "x (rho (Suc r) q) = v"
proof -
  let ?msgs = "HOrcvdMsgs UV_M r q (HOs r q) (rho r)"
  from comm obtain p where p: "p \<in> msgRcvd ?msgs"
    by (force dest: some_common_msg)
  from run have "nextState UV_M r q (rho r q) ?msgs (rho (Suc r) q)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  hence "next0 r q (rho r q) ?msgs (rho (Suc r) q) \<and> step r = 0
         \<or> next1 r q (rho r q) ?msgs (rho (Suc r) q) \<and> step r \<noteq> 0"
    (is "?nxt0 \<or> ?nxt1")
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  thus ?thesis
  proof
    assume nxt0: "?nxt0"
    hence "x (rho (Suc r) q) = smallestValRcvd ?msgs"
      by (auto simp: next0_def)
    moreover
    from nxt0 x have "\<forall>p \<in> msgRcvd ?msgs. ?msgs p = Some (Val v)"
      by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                     msgRcvd_def send0_def)
    from this p have "{x . \<exists>p. ?msgs p = Some (Val x)} = {v}"
      by (auto simp: msgRcvd_def)
    hence "smallestValRcvd ?msgs = v"
      by (auto simp: smallestValRcvd_def)
    ultimately
    show ?thesis by simp
  next
    assume nxt1: "?nxt1"
    show ?thesis
    proof (cases "someVoteRcvd ?msgs = {}")
      case True
      with nxt1 have "x (rho (Suc r) q) = smallestValNoVoteRcvd ?msgs"
        by (auto simp: next1_def x_update_def)
      moreover
      from nxt1 x True
      have "\<forall>p \<in> msgRcvd ?msgs. ?msgs p = Some (ValVote v None)"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       msgRcvd_def send1_def someVoteRcvd_def isValVote_def)
      from this p have "{x . \<exists>p. ?msgs p = Some (ValVote x None)} = {v}"
        by (auto simp: msgRcvd_def)
      hence "smallestValNoVoteRcvd ?msgs = v"
        by (auto simp: smallestValNoVoteRcvd_def)
      ultimately show ?thesis by simp
    next
      case False
      with nxt1 obtain p' v' where
        p': "p' \<in> msgRcvd ?msgs" "isValVote (the (?msgs p'))"
            "getvote (the (?msgs p')) = Some v'""x (rho (Suc r) q) = v'"
        by (auto simp: someVoteRcvd_def next1_def x_update_def)
      with nxt1 have "x (rho (Suc r) q) = x (rho r p')"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       msgRcvd_def send1_def isValVote_def
                       x_vote_eq[OF run comm])
      with x show ?thesis by auto
    qed
  qed
qed

text \<open>
  Combining the last two lemmas, it follows that as soon as some process
  decides value \<open>v\<close>, all processes hold \<open>v\<close> in their \<open>x\<close> fields.
\<close>

lemma safety_argument:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
      and decval: "decide (rho (Suc r) p) = Some v"
  shows "x (rho (Suc r+k) q) = v"
proof (induct k arbitrary: q)
  fix q
  from decide_equals_x[OF assms] show "x (rho (Suc r + 0) q) = v" by simp
next
  fix k q
  assume "\<And>q. x (rho (Suc r+k) q) = v"
  with run com show "x (rho (Suc r + Suc k) q) = v"
    by (auto dest: same_x_stable)
qed

text \<open>
  Any process that holds a non-null decision value has made a decision
  sometime in the past.
\<close>

lemma decided_then_past_decision:
  assumes run: "HORun UV_M rho HOs"
      and dec: "decide (rho n p) = Some v"
  shows "\<exists>m<n. decide (rho (Suc m) p) \<noteq> decide (rho m p)
             \<and> decide (rho (Suc m) p) = Some v"
proof -
  let "?dec k" = "decide (rho k p)"
  have "(\<forall>m<n. ?dec (Suc m) \<noteq> ?dec m \<longrightarrow> ?dec (Suc m) \<noteq> Some v)
        \<longrightarrow> ?dec n \<noteq> Some v"
    (is "?P n" is "?A n \<longrightarrow> _")
  proof (induct n)
    from run show "?P 0"
      by (auto simp: HORun_eq UV_HOMachine_def HOinitConfig_eq
                     initState_def UV_initState_def)
  next
    fix n
    assume ih: "?P n" thus "?P (Suc n)" by force
  qed
  with dec show ?thesis by auto
qed

text \<open>
  We can now prove the safety properties of the algorithm, and start with
  proving Integrity.
\<close>

lemma x_values_initial:
  assumes run:"HORun UV_M rho HOs"
      and com:"\<forall>r. HOcommPerRd UV_M (HOs r)"
  shows "\<exists>q. x (rho r p) = x (rho 0 q)"
proof (induct r arbitrary: p)
  fix p
  show "\<exists>q. x (rho 0 p) = x (rho 0 q)" by auto
next
  fix r p
  assume ih: "\<And>p'. \<exists>q. x (rho r p') = x (rho 0 q)"
  let ?msgs = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from run have "nextState UV_M r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  hence "next0 r p (rho r p) ?msgs (rho (Suc r) p) \<and> step r = 0
         \<or> next1 r p (rho r p) ?msgs (rho (Suc r) p) \<and> step r \<noteq> 0"
    (is "?nxt0 \<or> ?nxt1")
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  thus "\<exists>q. x (rho (Suc r) p) = x (rho 0 q)"
  proof
    assume nxt0: "?nxt0"
    hence "x (rho (Suc r) p) = smallestValRcvd ?msgs"
      by (auto simp: next0_def)
    also with com nxt0 have "\<dots> \<in> {v . \<exists>q. ?msgs q = Some (Val v)}"
      by (intro minval_step0) auto
    also with nxt0 have "\<dots> = { x (rho r q) | q . q \<in> msgRcvd ?msgs }"
      by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                     msgRcvd_def send0_def)
    finally obtain q where "x (rho (Suc r) p) = x (rho r q)" by auto
    with ih show ?thesis by auto
  next
    assume nxt1: "?nxt1"
    show ?thesis
    proof (cases "someVoteRcvd ?msgs = {}")
      case True
      with nxt1 have "x (rho (Suc r) p) = smallestValNoVoteRcvd ?msgs"
        by (auto simp: next1_def x_update_def)
      also with com nxt1 True
      have "\<dots> \<in> {v . \<exists>q. ?msgs q = Some (ValVote v None)}"
        by (intro minval_step1) auto
      also with nxt1 True
      have "\<dots> = { x (rho r q) | q . q \<in> msgRcvd ?msgs }"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       someVoteRcvd_def isValVote_def msgRcvd_def send1_def)
      finally obtain q where "x (rho (Suc r) p) = x (rho r q)" by auto
      with ih show ?thesis by auto
    next
      case False
      with nxt1 obtain q where
        "q \<in> someVoteRcvd ?msgs"
        "x (rho (Suc r) p) = the (getvote (the (?msgs q)))"
        by (auto simp: next1_def x_update_def)
      with nxt1 have "vote (rho r q) = Some (x (rho (Suc r) p))"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       someVoteRcvd_def isValVote_def msgRcvd_def send1_def)
      with run com have "x (rho (Suc r) p) = x (rho r q)"
        by (rule x_vote_eq)
      with ih show ?thesis by auto
    qed
  qed
qed

theorem uv_integrity:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and dec: "decide (rho r p) = Some v"
  shows "\<exists>q. v = x (rho 0 q)"
proof -
  from run dec obtain k where
    "decide (rho (Suc k) p) \<noteq> decide (rho k p)"
    "decide (rho (Suc k) p) = Some v"
    by (auto dest: decided_then_past_decision)
  with run com have "x (rho (Suc k) p) = v"
    by (rule decide_equals_x)
  with run com show ?thesis
    by (auto dest: x_values_initial)
qed

text \<open>
  We now turn to Agreement.
\<close>

lemma two_decisions_agree:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and decidep: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
      and decvalp: "decide (rho (Suc r) p) = Some v"
      and decideq: "decide (rho (Suc (r+k)) q) \<noteq> decide (rho (r+k) q)"
      and decvalq: "decide (rho (Suc (r+k)) q) = Some w"
  shows "v = w"
proof -
  from run com decidep decvalp have "x (rho (Suc r+k) q) = v"
    by (rule safety_argument)
  moreover
  from run com decideq decvalq have "x (rho (Suc (r+k)) q) = w"
    by (rule decide_equals_x)
  ultimately
  show ?thesis by simp
qed

theorem uv_agreement:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and p: "decide (rho m p) = Some v"
      and q: "decide (rho n q) = Some w"
  shows "v = w"
proof -
  from run p obtain k where
    k: "decide (rho (Suc k) p) \<noteq> decide (rho k p)"
       "decide (rho (Suc k) p) = Some v"
    by (auto dest: decided_then_past_decision)
  from run q obtain l where
    l: "decide (rho (Suc l) q) \<noteq> decide (rho l q)"
       "decide (rho (Suc l) q) = Some w"
    by (auto dest: decided_then_past_decision)
  show ?thesis
  proof (cases "k \<le> l")
    case True
    then obtain m where m: "l = k+m" by (auto simp: le_iff_add)
    from run com k l m show ?thesis by (blast dest: two_decisions_agree)
  next
    case False
    hence "l \<le> k" by simp
    then obtain m where m: "k = l+m" by (auto simp: le_iff_add)
    from run com k l m show ?thesis by (blast dest: two_decisions_agree)
  qed
qed

text \<open>
  Irrevocability is a consequence of Agreement and the fact that no process
  can decide \<open>None\<close>.
\<close>

theorem uv_irrevocability:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and p: "decide (rho m p) = Some v"
  shows "decide (rho (m+n) p) = Some v"
proof (induct n)
  from p show "decide (rho (m+0) p) = Some v" by simp
next
  fix n
  assume ih: "decide (rho (m+n) p) = Some v"
  show "decide (rho (m + Suc n) p) = Some v"
  proof (rule classical)
    assume "\<not> ?thesis"
    with run ih obtain w where w: "decide (rho (m + Suc n) p) = Some w"
      by (auto dest!: decide_nonnull)
    with p have "w = v" by (auto simp: uv_agreement[OF run com])
    with w show ?thesis by simp
  qed
qed

subsection \<open>Proof of Termination\<close>

text \<open>
  Two processes having the same \emph{Heard-Of} set at some round will
  hold the same value in their \<open>x\<close> variable at the next round.
\<close>
(* The proof relies on the previous lemma @{text vote_agreement}. *)

lemma hoeq_xeq:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and hoeq: "HOs r p = HOs r q"
  shows "x (rho (Suc r) p) = x (rho (Suc r) q)"
proof -
  let "?msgs p" = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from hoeq have msgeq: "?msgs p = ?msgs q"
    by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                   send0_def send1_def)

  show ?thesis
  proof (cases "step r = 0")
    case True
    with run
    have "\<forall>p. next0 r p (rho r p) (?msgs p) (rho (Suc r) p)" (is "\<forall>p. ?nxt0 p")
      by (force simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                      nextState_def UV_nextState_def)
    hence "?nxt0 p" "?nxt0 q" by auto
    with msgeq show ?thesis by (auto simp: next0_def)
  next
    assume stp: "step r \<noteq> 0"
    with run
    have "\<forall>p. next1 r p (rho r p) (?msgs p) (rho (Suc r) p)" (is "\<forall>p. ?nxt1 p")
      by (force simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                      nextState_def UV_nextState_def)
    hence "x_update (rho r p) (?msgs p) (rho (Suc r) p)"
          "x_update (rho r q) (?msgs q) (rho (Suc r) q)"
      by (auto simp: next1_def)
    with msgeq have
      x': "x_update (rho r p) (?msgs p) (rho (Suc r) p)"
          "x_update (rho r q) (?msgs p) (rho (Suc r) q)"
      by auto
    show ?thesis
    proof (cases "someVoteRcvd (?msgs p) = {}")
      case True
      with x' show ?thesis
        by (auto simp: x_update_def)
    next
      case False
      with x' stp obtain qp qq where
        "vote (rho r qp) = Some (x (rho (Suc r) p))" and
        "vote (rho r qq) = Some (x (rho (Suc r) q))"
        by (force simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                        x_update_def someVoteRcvd_def isValVote_def
                        msgRcvd_def send1_def)
      with run com show ?thesis by (rule vote_agreement)
    qed
  qed
qed

text \<open>
  We now prove that \emph{UniformVoting} terminates.
\<close>

  txt \<open>Now obtain a round where all votes agree.\<close>
  define r' where "r' = (if step (Suc r0) = 0 then Suc r0 else Suc (Suc r0))"
  have stp': "step r' = 0"
    by (simp add: r'_def step_def mod_Suc)
  have x': "\<forall>q. x (rho r' q) = ?v"
  proof (auto simp: r'_def)
    fix q
    from xs show "x (rho (Suc r0) q) = ?v" ..
  next
    fix q
    from run commR xs show "x (rho (Suc (Suc r0)) q) = ?v"
      by (rule same_x_stable)
  qed
  have vote': "\<forall>q. vote (rho (Suc r') q) = Some ?v"
  proof
    fix q
    let ?msgs = "HOrcvdMsgs UV_M r' q (HOs r' q) (rho r')"
    from run stp' have "next0 r' q (rho r' q) ?msgs (rho (Suc r') q)"
      by (force simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                      nextState_def UV_nextState_def)
    moreover
    from stp' x' have "\<forall>q' \<in> msgRcvd ?msgs. ?msgs q' = Some (Val ?v)"
      by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                     send0_def msgRcvd_def)
    moreover
    from commR have "msgRcvd ?msgs \<noteq> {}"
      by (force dest: some_common_msg)
    ultimately
    show "vote (rho (Suc r') q) = Some ?v"
      by (auto simp: next0_def)
  qed

  txt \<open>At the subsequent round, process \<open>p\<close> will decide.\<close>
  let ?r'' = "Suc r'"
  let ?msgs' = "HOrcvdMsgs UV_M ?r'' p (HOs ?r'' p) (rho ?r'')"
  from stp' have stp'': "step ?r'' = 1"
    by (simp add: step_def mod_Suc)
  with run have "next1 ?r'' p (rho ?r'' p) ?msgs' (rho (Suc ?r'') p)"
    by (auto simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                   nextState_def UV_nextState_def)
  moreover
  from stp'' vote' have "identicalVoteRcvd ?msgs' ?v"
    by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                   send1_def identicalVoteRcvd_def isValVote_def msgRcvd_def)
  moreover
  from commR have "msgRcvd ?msgs' \<noteq> {}"
    by (force dest: some_common_msg)
  ultimately
  have "decide (rho (Suc ?r'') p) = Some ?v"
    by (force simp: next1_def dec_update_def identicalVoteRcvd_def
                    msgRcvd_def isValVote_def)
  (* subtle point: there can't be two different identical votes received,
     proving this requires "force" and takes a while *)

  thus ?thesis by blast
qed

subsection \<open>\emph{UniformVoting} Solves Consensus\<close>

text \<open>
  Summing up, all (coarse-grained) runs of \emph{UniformVoting} for
  HO collections that satisfy the communication predicate satisfy
  the Consensus property.
\<close>

theorem uv_consensus:
  assumes run: "HORun UV_M rho HOs"
      and commR: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and commG: "HOcommGlobal UV_M HOs"
  shows "consensus (x \<circ> (rho 0)) decide rho"
  using assms unfolding consensus_def image_def
  by (auto elim: uv_integrity uv_agreement uv_termination)

text \<open>
  By the reduction theorem, the correctness of the algorithm carries over
  to the fine-grained model of runs.
\<close>

theorem uv_consensus_fg:
  assumes run: "fg_run UV_M rho HOs HOs (\<lambda>r q. undefined)"
      and commR: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and commG: "HOcommGlobal UV_M HOs"
  shows "consensus (\<lambda>p. x (state (rho 0) p)) decide (state \<circ> rho)"
    (is "consensus ?inits _ _")
proof (rule local_property_reduction[OF run consensus_is_local])
  fix crun
  assume crun: "CSHORun UV_M crun HOs HOs (\<lambda>r q. undefined)"
     and init: "crun 0 = state (rho 0)"
  from crun have "HORun UV_M crun HOs"
    by (unfold HORun_def SHORun_def)
  from this commR commG have "consensus (x \<circ> (crun 0)) decide crun"
    by (rule uv_consensus)
  with init show "consensus ?inits decide crun"
    by (simp add: o_def)
qed

end


section \<open>Invariance\<close>
theory Invariance
  imports ODE_Misc
begin

context auto_ll_on_open begin

definition "invariant M \<longleftrightarrow> (\<forall>x\<in>M. trapped x M)"

definition "positively_invariant M \<longleftrightarrow> (\<forall>x\<in>M. trapped_forward x M)"

definition "negatively_invariant M \<longleftrightarrow> (\<forall>x\<in>M. trapped_backward x M)"

lemma positively_invariant_iff:
  "positively_invariant M \<longleftrightarrow>
  (\<Union>x\<in>M. flow0 x ` (existence_ivl0 x \<inter> {0..})) \<subseteq> M"
  unfolding positively_invariant_def trapped_forward_def
  by auto

lemma negatively_invariant_iff:
  "negatively_invariant M \<longleftrightarrow>
  (\<Union>x\<in>M. flow0 x ` (existence_ivl0 x \<inter> {..0})) \<subseteq> M"
  unfolding negatively_invariant_def trapped_backward_def
  by auto

lemma invariant_iff_pos_and_neg_invariant:
  "invariant M \<longleftrightarrow> positively_invariant M \<and> negatively_invariant M"
  unfolding invariant_def trapped_def positively_invariant_def negatively_invariant_def
  by blast

lemma invariant_iff:
  "invariant M \<longleftrightarrow> (\<Union>x\<in>M. flow0 x ` (existence_ivl0 x)) \<subseteq>  M"
  unfolding invariant_iff_pos_and_neg_invariant positively_invariant_iff negatively_invariant_iff
  by (metis (mono_tags) SUP_le_iff invariant_def invariant_iff_pos_and_neg_invariant negatively_invariant_iff positively_invariant_iff trapped_iff_on_existence_ivl0)

lemma positively_invariant_restrict_dom: "positively_invariant M = positively_invariant (M \<inter> X)"
  unfolding positively_invariant_def trapped_forward_def
  by (auto intro!: flow_in_domain dest: mem_existence_ivl_iv_defined)

lemma negatively_invariant_restrict_dom: "negatively_invariant M = negatively_invariant (M \<inter> X)"
  unfolding negatively_invariant_def trapped_backward_def
  by (auto intro!: flow_in_domain dest: mem_existence_ivl_iv_defined)

lemma invariant_restrict_dom: "invariant M = invariant (M \<inter> X)"
  using invariant_iff_pos_and_neg_invariant
    negatively_invariant_restrict_dom
    positively_invariant_restrict_dom by auto
    (*
lemma positively_invariant_imp_subset:
  "M \<subseteq> X" if "positively_invariant M"
  using positively_invariant_iff that by blast

lemma negatively_invariant_imp_subset:
  "M \<subseteq> X" if "negatively_invariant M"
  using negatively_invariant_iff that by blast

lemma invariant_imp_subset:
  "M \<subseteq> X" if "invariant M"
  using invariant_iff that by blast
*)

end context auto_ll_on_open begin

lemma positively_invariant_eq_rev: "positively_invariant M = rev.negatively_invariant M"
  unfolding positively_invariant_def rev.negatively_invariant_def
  by (simp add: rev.trapped_backward_iff_rev_trapped_forward)

lemma negatively_invariant_eq_rev: "negatively_invariant M = rev.positively_invariant M"
  unfolding negatively_invariant_def rev.positively_invariant_def
  by (simp add: trapped_backward_iff_rev_trapped_forward)

lemma invariant_eq_rev: "invariant M = rev.invariant M"
  unfolding invariant_iff_pos_and_neg_invariant rev.invariant_iff_pos_and_neg_invariant
    positively_invariant_eq_rev negatively_invariant_eq_rev by auto

lemma negatively_invariant_complI: "negatively_invariant (X-M)" if "positively_invariant M"
  unfolding negatively_invariant_def trapped_backward_def
proof clarsimp
  fix x t
  assume x: "x \<in> X" "x \<notin> M" "t \<in> existence_ivl0 x" "t \<le> 0"
  have a1:"flow0 x t \<in> X" using x
    using flow_in_domain by blast
  have a2:"flow0 x t \<notin> M"
  proof (rule ccontr)
    assume "\<not> flow0 x t \<notin> M"
    then have "trapped_forward (flow0 x t) M"
      using positively_invariant_def that by auto
    moreover have "flow0 (flow0 x t) (-t) = x"
      using \<open>t \<in> existence_ivl0 x\<close> flows_reverse by auto
    moreover have "-t \<in> existence_ivl0 (flow0 x t) \<inter> {0..}"
      using existence_ivl_reverse x(3) x(4) by auto
    ultimately have "x \<in> M" unfolding trapped_forward_def
      by (metis image_subset_iff)
    thus False using x(2) by auto
  qed
  show "flow0 x t \<in> X \<and> flow0 x t \<notin> M" using a1 a2 by auto
qed

end context auto_ll_on_open begin

lemma negatively_invariant_complD: "positively_invariant M" if "negatively_invariant (X-M)"
proof -
  have "rev.positively_invariant (X-M)" using that
    by (simp add: negatively_invariant_eq_rev)
  then have "rev.negatively_invariant (X-(X-M))"
    by (simp add: rev.negatively_invariant_complI)
  then have "positively_invariant (X-(X-M))"
    using rev.negatively_invariant_eq_rev by auto
  thus ?thesis using Diff_Diff_Int
    by (metis inf_commute positively_invariant_restrict_dom)
qed

lemma neg_invariant_iff_compl_pos_invariant:
  shows "negatively_invariant M \<longleftrightarrow> positively_invariant (X - M)"
  by (simp add: auto_ll_on_open.pos_invariant_iff_compl_neg_invariant negatively_invariant_eq_rev positively_invariant_eq_rev rev.auto_ll_on_open_axioms)

lemma invariant_iff_compl_invariant:
  shows "invariant M \<longleftrightarrow> invariant (X - M)"
  using invariant_iff_pos_and_neg_invariant neg_invariant_iff_compl_pos_invariant pos_invariant_iff_compl_neg_invariant by blast

lemma invariant_iff_pos_invariant_and_compl_pos_invariant:
  shows "invariant M \<longleftrightarrow> positively_invariant M \<and> positively_invariant (X-M)"
  by (simp add: invariant_iff_pos_and_neg_invariant neg_invariant_iff_compl_pos_invariant)

end

subsection \<open>Tools for proving invariance\<close>

context auto_ll_on_open begin

lemma positively_invariant_left_inter:
  assumes "positively_invariant C"
  assumes "\<forall>x \<in> C \<inter> D. trapped_forward x D"
  shows "positively_invariant (C \<inter> D)"
  using assms positively_invariant_def trapped_forward_def by auto

lemma trapped_forward_le:
  fixes V :: "'a \<Rightarrow> real"
  assumes "V x \<le> 0"
  assumes contg: "continuous_on (flow0 x ` (existence_ivl0 x \<inter> {0..})) g"
  assumes "\<And>x. (V has_derivative V' x) (at x)"
  assumes "\<And>s. s \<in> existence_ivl0 x \<inter> {0..} \<Longrightarrow> V' (flow0 x s) (f (flow0 x s)) \<le> g (flow0 x s) * V (flow0 x s)"
  shows "trapped_forward x {x. V x \<le> 0}"
  unfolding trapped_forward_def
proof clarsimp
  fix t
  assume t: "t \<in> existence_ivl0 x" "0 \<le> t"
  then have ex:"{0..t} \<subseteq> existence_ivl0 x"
    by (simp add: local.ivl_subset_existence_ivl)
  have contV: "continuous_on UNIV V"
    using assms(3) has_derivative_continuous_on by blast
  have 1: "continuous_on {0..t} (g \<circ> flow0 x)"
    apply (rule continuous_on_compose)
    using continuous_on_subset ex local.flow_continuous_on apply blast
    by (meson Int_subset_iff atLeastAtMost_iff atLeast_iff contg continuous_on_subset ex image_mono subsetI)
  have 2: "(\<And>s. s \<in> {0..t} \<Longrightarrow>
         (V \<circ> flow0 x has_real_derivative (V' (flow0 x s) \<circ> f \<circ> flow0 x) s) (at s))"
    apply (auto simp add:o_def has_field_derivative_def)
  proof -
    fix s
    assume "0 \<le> s" "s \<le> t"
    then have "s \<in> existence_ivl0 x" using ex by auto
    from flow_has_derivative[OF this] have
      "(flow0 x has_derivative (\<lambda>i. i *\<^sub>R f (flow0 x s))) (at s)" .
    from has_derivative_compose[OF this assms(3)]
    have "((\<lambda>t. V (flow0 x t)) has_derivative (\<lambda>t. V' (flow0 x s)  (t *\<^sub>R f (flow0 x s)))) (at s)" .
    moreover have "linear (V' (flow0 x s))"  using assms(3) has_derivative_linear by blast
    ultimately
    have "((\<lambda>t. V (flow0 x t)) has_derivative (\<lambda>t. t *\<^sub>R V' (flow0 x s) (f (flow0 x s)))) (at s)"
      unfolding linear_cmul[OF \<open>linear (V' (flow0 x s))\<close>] by blast
    thus "((\<lambda>t. V (flow0 x t)) has_derivative (*) (V' (flow0 x s) (f (flow0 x s)))) (at s)"
      by (auto intro!: derivative_eq_intros simp add: mult_commute_abs)
  qed
  have 3: "(\<And>s. s \<in> {0..t} \<Longrightarrow>
         (V' (flow0 x s)  \<circ> f \<circ> flow0 x) s \<le> (g \<circ> flow0 x) s *\<^sub>R (V \<circ> flow0 x) s)"
    using ex by (auto intro!:assms(4))
  from comparison_principle_le_linear[OF 1 2 _ 3] assms(1)
  have "\<forall>s \<in> {0..t}. (V \<circ> flow0 x) s \<le> 0"
    using local.mem_existence_ivl_iv_defined(2) t(1) by auto
  thus " V (flow0 x t) \<le> 0"
    by (simp add: t(2))
qed

lemma positively_invariant_le_domain:
  fixes V :: "'a \<Rightarrow> real"
  assumes "positively_invariant D"
  assumes contg: "continuous_on D g"
  assumes "\<And>x. (V has_derivative V' x) (at x)" (* TODO: domain can be added here too ? *)
  assumes "\<And>s. s \<in> D \<Longrightarrow> V' s (f s) \<le> g s * V s"
  shows "positively_invariant (D \<inter> {x. V x \<le> 0})"
  apply (auto intro!:positively_invariant_left_inter[OF assms(1)])
proof -
  fix x
  assume "x \<in> D" "V x \<le> 0"
  have "continuous_on (flow0 x ` (existence_ivl0 x \<inter> {0..})) g"
    by (meson \<open>x \<in> D\<close> assms(1) contg continuous_on_subset positively_invariant_def trapped_forward_def)
  from trapped_forward_le[OF \<open>V x \<le> 0\<close> this assms(3)]
  show "trapped_forward x {x. V x \<le> 0}" using assms(4)
    using \<open>x \<in> D\<close> assms(1) positively_invariant_def trapped_forward_def by auto
qed

lemma positively_invariant_barrier_domain:
  fixes V :: "'a \<Rightarrow> real"
  assumes "positively_invariant D"
  assumes "\<And>x. (V has_derivative V' x) (at x)"
  assumes "continuous_on D (\<lambda>x. V' x (f x))"
  assumes "\<And>s. s \<in> D \<Longrightarrow> V s = 0 \<Longrightarrow> V' s (f s) < 0"
  shows "positively_invariant (D \<inter> {x. V x \<le> 0})"
  apply (auto intro!:positively_invariant_left_inter[OF assms(1)])
proof -
  fix x
  assume "x \<in> D" "V x \<le> 0"
  have contV: "continuous_on UNIV V" using assms(2) has_derivative_continuous_on by blast
  then have *: "continuous_on (flow0 x ` (existence_ivl0 x \<inter> {0..})) V"
    using continuous_on_subset by blast
  have sub: "flow0 x ` (existence_ivl0 x \<inter> {0..}) \<subseteq> D"
    using \<open>x \<in> D\<close> assms(1) positively_invariant_def trapped_forward_def by auto
  then have contV': "continuous_on (flow0 x ` (existence_ivl0 x \<inter> {0..})) (\<lambda>x. V' x (f x))"
    by (metis assms(3) continuous_on_subset)
  have nz: "\<And>i t. t \<in> existence_ivl0 x \<Longrightarrow>
       0 \<le> t \<Longrightarrow>  max (-V' (flow0 x t) (f (flow0 x t))) ((V (flow0 x t))\<^sup>2) > 0"
  proof -
    fix i t
    assume "t \<in> existence_ivl0 x" "0 \<le> t"
    then have "flow0 x t \<in> D"
      using \<open>x \<in> D\<close> assms(1) positively_invariant_def trapped_forward_def by auto
    then have "V (flow0 x t) = 0 \<Longrightarrow> - V' (flow0 x t) (f (flow0 x t)) > 0" using assms(4) by simp
    then have "(V (flow0 x t))^2 > 0 \<or> - V' (flow0 x t) (f (flow0 x t)) > 0" by simp
    thus "max (-V' (flow0 x t) (f (flow0 x t))) ((V (flow0 x t))\<^sup>2) > 0" unfolding less_max_iff_disj
      by auto
  qed
  have *: "continuous_on (flow0 x ` (existence_ivl0 x \<inter> {0..})) (\<lambda>x. V' x (f x) * V x / max (- V' x (f x)) ((V x)^2))"
    apply (auto intro!:continuous_intros continuous_on_max simp add: * contV')
    using nz by fastforce
  have "(\<And>t. t \<in> existence_ivl0 x \<inter> {0..} \<Longrightarrow>
        V' (flow0 x t) (f (flow0 x t)) \<le>
        (V' (flow0 x t) (f (flow0 x t)) * V (flow0 x t)
        / max (- V' (flow0 x t) (f (flow0 x t))) ((V (flow0 x t))\<^sup>2)) * V (flow0 x t))"
  proof clarsimp
    fix t
    assume "t \<in> existence_ivl0 x" "0 \<le> t"
    then have p: "max (-V' (flow0 x t) (f (flow0 x t))) ((V (flow0 x t))\<^sup>2) > 0" using nz by auto
    have " V' (flow0 x t) (f (flow0 x t)) * max (- V' (flow0 x t) (f (flow0 x t))) ((V (flow0 x t))\<^sup>2)
      \<le>  V' (flow0 x t) (f (flow0 x t)) * (V (flow0 x t))\<^sup>2"
      by (smt mult_minus_left mult_minus_right power2_eq_square real_mult_le_cancel_iff2)
    then have "V' (flow0 x t) (f (flow0 x t))
      \<le>  V' (flow0 x t) (f (flow0 x t)) * (V (flow0 x t))\<^sup>2
      / max (- V' (flow0 x t) (f (flow0 x t))) ((V (flow0 x t))\<^sup>2)"
      using p pos_le_divide_eq by blast
    thus " V' (flow0 x t) (f (flow0 x t))
         \<le> V' (flow0 x t) (f (flow0 x t)) * (V (flow0 x t)) * V (flow0 x t) /
           max (- V' (flow0 x t) (f (flow0 x t))) ((V (flow0 x t))\<^sup>2)"
      by (simp add: power2_eq_square)
  qed
  from trapped_forward_le[OF \<open>V x \<le> 0\<close> * assms(2) this]
  show "trapped_forward x {x. V x \<le> 0}" by auto
qed

lemma positively_invariant_UNIV:
  shows "positively_invariant UNIV"
  using positively_invariant_iff by blast

lemma positively_invariant_conj:
  assumes "positively_invariant C"
  assumes "positively_invariant D"
  shows "positively_invariant (C \<inter> D)"
  using assms positively_invariant_def
  using positively_invariant_left_inter by auto

lemma positively_invariant_le:
  fixes V :: "'a \<Rightarrow> real"
  assumes contg: "continuous_on UNIV g"
  assumes "\<And>x. (V has_derivative V' x) (at x)"
  assumes "\<And>s. V' s (f s) \<le> g s * V s"
  shows "positively_invariant {x. V x \<le> 0}"
proof -
  from positively_invariant_le_domain[OF positively_invariant_UNIV assms]
  have "positively_invariant (UNIV \<inter> {x. V x \<le> 0})" .
  thus ?thesis by auto
qed

lemma positively_invariant_barrier:
  fixes V :: "'a \<Rightarrow> real"
  assumes "\<And>x. (V has_derivative V' x) (at x)"
  assumes "continuous_on UNIV (\<lambda>x. V' x (f x))"
  assumes "\<And>s. V s = 0 \<Longrightarrow> V' s (f s) < 0"
  shows "positively_invariant {x. V x \<le> 0}"
proof -
  from positively_invariant_barrier_domain[OF positively_invariant_UNIV assms]
  have "positively_invariant (UNIV \<inter> {x. V x \<le> 0})" .
  thus ?thesis by auto
qed

end

end


theory CC_Helper_Functions
  imports CC_Definition
begin

subsection \<open>Lemmas about the behaviour of \<open>rep_of\<close> and \<open>path_to_root\<close> after a function update\<close>

text \<open>In order to show that the termination invariant holds after adding an edge or a label to the proof forest,
we need to show a few invariants after function update\<close>

lemma rep_of_fun_upd:
  assumes "ufa_invar l" "path l (rep_of l li) p\<^sub>1 li" "i \<notin> set p\<^sub>1"
  shows "rep_of l li = rep_of (l[i := y]) li"
proof-
  have li: "li < length l"
    using assms(2) path_nodes_lt_length_l by auto
  show ?thesis
    using assms(1) li assms(2-) proof(induction arbitrary: p\<^sub>1 rule: rep_of_induct)
    case (base li)
    then show ?case
      by (metis list.set_intros(1) nth_list_update_neq path_no_cycle rep_of_refl)
  next
    case (step li)
    then have path_to_parent: "path l (rep_of l (l ! li)) (butlast p\<^sub>1) (l ! li)"
      by (metis path_butlast rep_of_idx rep_of_root)
    then have rep_of_parent: "rep_of l (l ! li) = rep_of (l[i := y]) (l ! li)"
      by (metis in_set_butlastD step.IH step.prems(2))
    from step have "li \<noteq> i"
      by (metis path_to_parent in_set_conv_decomp path_snoc path_unique rep_of_step ufa_invarD(2))
    with step(1,2) path_to_root_correct have "path l (rep_of l li) (path_to_root l li) li"
      by simp
    then have "path (l[i := y]) (rep_of l li) (path_to_root l li) li"
      using path_fun_upd path_unique step by (metis in_set_tlD)
    with step have "path (l[i := y]) (rep_of l li) (butlast (path_to_root l li)) (l ! li)"
      by (metis \<open>li \<noteq> i\<close> nth_list_update_neq path_butlast rep_of_root)
    have "l[i := y] ! (rep_of l li) = (rep_of l li)"
      by (metis list.set_intros(1) nth_list_update_neq path.simps rep_of_root step.hyps(1) step.hyps(2) step.prems(1) step.prems(2))
    with path_root_rep_of_dom have "rep_of_dom (l[i := y],l ! li)"
      using \<open>path (l[i := y]) (rep_of l li) (butlast (path_to_root l li)) (l ! li)\<close> by blast
    then have "rep_of_dom (l[i := y], li)"
      by (metis \<open>li \<noteq> i\<close> nth_list_update_neq rep_of.domintros)
    then have "rep_of l li = rep_of l (l ! li)" "rep_of (l[i := y]) li = rep_of (l[i := y]) (l ! li)"
       apply (simp add: rep_of_idx step.hyps(1) step.hyps(2))
      by (metis \<open>li \<noteq> i\<close> \<open>rep_of_dom (l[i := y], li)\<close> nth_list_update_neq rep_of_idx2)
    with rep_of_parent show ?case
      by presburger
  qed
qed

lemma rep_of_fun_upd':
  assumes "ufa_invar l" "rep_of l li \<noteq> rep_of l i" "li < length l"
  shows "rep_of l li = rep_of (l[i := y]) li"
proof-
  from path_to_root_correct assms
  have "path l (rep_of l li) (path_to_root l li) li"
    "i \<notin> set (path_to_root l li)" apply simp
    by (metis assms in_set_conv_nth nodes_path_rep_of(2) path_to_root_correct)
  with rep_of_fun_upd assms(1) show ?thesis
    by blast
qed

lemma rep_of_fun_upd_aux1:
  assumes "ufa_invar l" "path l x p a" "x \<noteq> a"
  shows "rep_of (l[a := b]) x = rep_of l x"
proof-
  obtain pR where pR: "path l (rep_of l x) pR x"
    using assms(1) assms(2) path_nodes_lt_length_l path_to_root_correct by blast
  then have "path l (rep_of l x) (pR @ tl p) a"
    using assms(2) paths_iff by blast
  then have "a \<notin> set pR"
    by (metis pR assms(1,3) hd_rev in_set_butlast_appendI not_hd_in_tl path_last path_remove_right rev_butlast_is_tl_rev set_rev)
  then show ?thesis
    using assms(1) pR rep_of_fun_upd by auto
qed

lemma ufa_invar_fun_upd:
  assumes "ufa_invar l" "path l (rep_of l y) py y" "i \<notin> set py"
  shows "ufa_invar (l[i := y])"
  unfolding ufa_invar_def
proof(standard, standard, standard)
  fix ia
  assume ia_valid: "ia < length (l[i := y])"
  have y: "y < length l"
    using assms(2) path_nodes_lt_length_l by auto
  with assms ia_valid show "l[i := y] ! ia < length (l[i := y])"
    by (metis length_list_update nth_list_update' ufa_invarD(2))
  have path_root: "path l (rep_of l ia) (path_to_root l ia) ia"
    using ia_valid assms(1) path_to_root_correct by auto
  show "rep_of_dom (l[i := y], ia)"
  proof(cases "i \<in> set (path_to_root l ia)")
    case False
      \<comment> \<open>The path to the root of \<open>ia\<close> still exists after the function update.\<close>
    with path_fun_upd path_root have "path (l[i := y]) (rep_of l ia) (path_to_root l ia) ia"
      by (metis in_set_tlD)
    with path_root have "path (l[i := y]) (rep_of (l[i := y]) ia) (path_to_root l ia) ia"
      using False assms(1) rep_of_fun_upd by auto
    from rep_of_root have "(l[i := y]) ! (rep_of (l[i := y]) ia) = (rep_of (l[i := y]) ia)"
      by (metis False \<open>path (l[i := y]) (rep_of (l[i := y]) ia) (path_to_root l ia) ia\<close> assms(1) ia_valid length_list_update list.inject list.set_intros(1) local.path_root nth_list_update_neq path.simps)
    with path_root_rep_of_dom show ?thesis
      using \<open>path (l[i := y]) (rep_of (l[i := y]) ia) (path_to_root l ia) ia\<close> by blast
  next
    case True
      \<comment> \<open>After the function update, there is a path from \<open>ia\<close> to \<open>i\<close>, and an edge from \<open>i\<close> to \<open>y\<close>.
           The assumption that there is a path from \<open>y\<close> to \<open>rep_of y\<close> is important in order to avoid
           cycles in the tree structure. Those three paths can be merged together,
           and then the lemma \<open>path_root_rep_of_dom\<close> applies.\<close>
    then obtain root_i i_ia where root_i: "path_to_root l ia = root_i @ [i] @ i_ia"
      by (metis Cons_eq_append_conv append_Nil in_set_conv_decomp_first)
    with path_root path_divide2 have paths: "path l i (i # i_ia) ia" "path l (rep_of l ia) (root_i @ [i]) i"
       apply (metis Cons_eq_appendI append_self_conv2 list.distinct(1) list.sel(1))
      by (metis Nil_is_append_conv hd_append list.distinct(1) list.sel(1) local.path_root path_divide2 root_i)
    with paths path_divide2[of l i "[i]" i_ia ia] have "i_ia \<noteq> [] \<Longrightarrow> path l (hd i_ia) i_ia ia"
      by fastforce
    with path_remove_left have "i \<notin> set i_ia"
      using assms(1) paths(1) by blast
    with path_fun_upd have path_i_ia: "i_ia \<noteq> [] \<Longrightarrow> path (l[i := y]) (hd i_ia) i_ia ia"
      by (metis \<open>i_ia \<noteq> [] \<Longrightarrow> path l (hd i_ia) i_ia ia\<close> in_set_tlD)
    have "i_ia \<noteq> [] \<Longrightarrow> l ! ((i # i_ia) ! 1) = ((i # i_ia) ! 0)"
      using paths(1) path_parent by fastforce
    then have "i_ia \<noteq> [] \<Longrightarrow> l ! hd i_ia = i"
      by (simp add: hd_conv_nth)
    then have "i_ia \<noteq> [] \<Longrightarrow> path (l[i := y]) i [i, hd i_ia] (hd i_ia)"
      using path_nodes_lt_length_l paths(1) single
      by (metis \<open>i \<notin> set i_ia\<close> path_i_ia length_list_update list.set_sel(1) nth_list_update_neq path.simps)
    with path_concat1 have p_l_upd_i_ia: "i_ia \<noteq> [] \<Longrightarrow> path (l[i := y]) i (i # i_ia) ia"
      by (metis \<open>i \<notin> set i_ia\<close> list.sel(3) path_fun_upd paths(1))
    from assms path_fun_upd in_set_tlD have path_rep_y: "path (l[i := y]) (rep_of l y) py y"
      by metis
    from assms y have "path (l[i := y]) y [y, i] i"
      by (metis \<open>path (l[i := y]) (rep_of l y) py y\<close> hd_in_set length_list_update nth_list_update_eq path.simps path_hd path_no_root paths(1))
    with p_l_upd_i_ia path_concat1 have "i_ia \<noteq> [] \<Longrightarrow> path (l[i := y]) y ([y, i] @ i_ia) ia"
      by fastforce
    with path_concat1 path_rep_y have "i_ia \<noteq> [] \<Longrightarrow> path (l[i := y]) (rep_of l y) (py @ [i] @ i_ia) ia"
      by fastforce
    with y assms path_root_rep_of_dom have "i_ia \<noteq> [] \<Longrightarrow> rep_of_dom (l[i := y], ia)"
      by (metis hd_in_set list.distinct(1) nth_list_update_neq path.simps path_hd rep_of_root)
    with path_concat1 path_rep_y have "i_ia = [] \<Longrightarrow> path (l[i := y]) (rep_of l y) (py @ [i]) i"
      using \<open>path (l[i := y]) y [y, i] i\<close>
      by fastforce
    with y assms show ?thesis
      by (metis \<open>i_ia \<noteq> [] \<Longrightarrow> rep_of_dom (l[i := y], ia)\<close>  list.set_intros(1) nth_list_update_neq path.simps path_length_1 path_root_rep_of_dom paths(1) rep_of_min)
  qed
qed

lemma ufa_invar_fun_upd':
  assumes "ufa_invar l" "y < length l" "rep_of l i \<noteq> rep_of l y"
  shows "ufa_invar (l[i := y])"
proof(rule ufa_invar_fun_upd)
  show "path l (rep_of l y) (path_to_root l y) y"
    by (simp add: assms(1) assms(2) path_to_root_correct)
  with assms show "i \<notin> set (path_to_root l y)"
    by (metis in_set_conv_nth path_rep_of_neq_not_in_path)
qed (auto simp add: assms)

lemma rep_of_fun_upd_rep_of:
  assumes "ufa_invar l"
    and "x < length l"
    and "y < length l"
    and "i < length l"
    and "rep_of l x \<noteq> rep_of l y"
  shows "rep_of (l[rep_of l x := y]) x = rep_of l y"
proof-
  have path_to_rep_x: "path l (rep_of l x) (path_to_root l x) x"
    by (simp add: assms(1) assms(2) path_to_root_correct)
  with path_fun_upd have path1: "path (l[rep_of l x := y]) (rep_of l x) (path_to_root l x) x"
    by (metis assms(1) list.sel(3) path.simps path_remove_left)
  from assms have path2: "path (l[rep_of l x := y]) y [y, rep_of l x] (rep_of l x)"
    by (metis path_to_rep_x length_list_update nth_list_update_eq path.step path_rep_eq rep_of_less_length_l single)
  have path_to_rep_y: "path l (rep_of l y) (path_to_root l y) y"
    by (simp add: assms(1) assms(3) path_to_root_correct)
  have "rep_of l (rep_of l x) = rep_of l x"
    using assms(1) path_rep_eq path_to_rep_x by blast
  with assms have "rep_of l x \<notin> set (path_to_root l y)"
    by (metis path_to_rep_y in_set_conv_nth path_rep_of_neq_not_in_path)
  then have path3: "path (l[rep_of l x := y]) (rep_of l y) (path_to_root l y) y"
    by (metis in_set_tlD path_fun_upd path_to_rep_y)
  from path1 path2 path3 assms path_rep_eq show ?thesis
    by (metis \<open>rep_of l (rep_of l x) = rep_of l x\<close> rep_of_fun_upd' ufa_invar_fun_upd')
qed

lemma rep_of_fun_upd_aux2:
  assumes "ufa_invar l" "path l a p x"
    "b < length l" "rep_of l a \<noteq> rep_of l b"
  shows "rep_of (l[a := b]) x = rep_of l b"
proof-
  obtain pR where "path l (rep_of l b) pR b"
    using assms(1,3) path_to_root_correct by blast
  then have pR: "path (l[a := b]) (rep_of l b) pR b"
    by (metis (no_types, lifting) assms(1,4) in_set_conv_nth length_list_update list.sel(3) nodes_path_rep_of(2) path.simps path_fun_upd)
  have "a \<notin> set (tl p)"
    by (metis assms(1,2) distinct.simps(1) distinct_hd_tl hd_path list.collapse path_remove_left)
  then have p: "path (l[a := b]) a p x"
    using assms(2) path_fun_upd by blast
  have "rep_of l b = rep_of (l[a := b]) b"
    using assms rep_of_fun_upd' by auto
  have "ufa_invar (l[a := b])"using ufa_invar_fun_upd
    by (simp add: assms(1) assms(3) assms(4) ufa_invar_fun_upd')
  then show ?thesis  using p pR path_rep_eq
    by (metis \<open>rep_of l b = rep_of (l[a := b]) b\<close> assms(2) assms(4) nth_list_update_eq path.step path_nodes_lt_length_l)
qed

lemma path_to_root_fun_upd:
  assumes "ufa_invar l" "path l (rep_of l li) p\<^sub>1 li" "i \<notin> set p\<^sub>1" "li < length l"
    and invar: "ufa_invar (l[i := y'])"
  shows "path_to_root (l[i := y']) li = path_to_root l li"
proof-
  have "path l (rep_of l li) (path_to_root l li) li"
    using assms(1) assms(2) path_nodes_lt_length_l path_to_root_correct by auto
  with assms have p1: "path (l[i := y']) (rep_of (l[i := y']) li) (path_to_root l li) li"
    by (metis path_fun_upd path_unique rep_of_fun_upd in_set_tlD)
  have "path (l[i := y']) (rep_of (l[i := y']) li) (path_to_root (l[i := y']) li) li"
    by (simp add: invar assms(4) path_to_root_correct)
  with p1 path_unique show ?thesis
    using invar by blast
qed

lemma path_to_root_fun_upd':
  assumes "ufa_invar l" "rep_of l li \<noteq> rep_of l i" "li < length l"
    and "ufa_invar (l[i := y'])"
  shows "path_to_root (l[i := y']) li = path_to_root l li"
proof(rule path_to_root_fun_upd)
  show "path l (rep_of l li) (path_to_root l li) li"
    by (simp add: assms(1) assms(3) path_to_root_correct)
  with assms show "i \<notin> set (path_to_root l li)"
    by (metis in_set_conv_nth nodes_path_rep_of(2))
qed(simp_all add: assms)

lemma path_to_root_fun_upd_root:
  assumes "ufa_invar l" "li < length l"
    "rep_of l li \<noteq> rep_of l y'" "y' < length l"
  shows "path_to_root (l[(rep_of l li) := y']) li = path_to_root l y' @ path_to_root l li"
proof-
  have p1: "path l (rep_of l li) (path_to_root l li) li"
    "path l (rep_of l y') (path_to_root l y') y'"
    using assms path_nodes_lt_length_l path_to_root_correct
    by auto
  with assms have p2: "path (l[(rep_of l li) := y']) (rep_of l y') (path_to_root l y') y'"
    "path (l[(rep_of l li) := y']) (rep_of l li) (path_to_root l li) li"
     apply (metis length_list_update path_to_root_correct path_to_root_fun_upd' rep_of_fun_upd' rep_of_idem ufa_invar_fun_upd')
    using assms p1 path_fun_upd path_contains_no_root rep_of_root by blast
  from assms p1 have "path (l[(rep_of l li) := y']) y' [y', rep_of l li] (rep_of l li)"
    by (metis length_list_update nth_list_update_eq path.step path_rep_eq rep_of_less_length_l single)
  with p2 p1 assms have
    "path (l[(rep_of l li) := y']) (rep_of l y') ((path_to_root l y') @ [rep_of l li]) (rep_of l li)"
    by (metis nth_list_update_eq path_nodes_lt_length_l path_rep_eq path_snoc)
  with p2 have
    "path (l[(rep_of l li) := y']) (rep_of l y') (path_to_root l y' @ path_to_root l li) li"
    using path_concat2 by fastforce
  with p1 path_unique assms show ?thesis
    by (metis path_nodes_lt_length_l path_rep_eq path_to_root_correct rep_of_fun_upd_rep_of ufa_invar_fun_upd')
qed

text \<open>If the representative changes after a list update, then it must be equal to
      the representative of the updated element.\<close>
lemma rep_of_fun_upd3:
  assumes "ufa_invar l" "x < length l" "y < length l" "x' < length l" "y' < length l"
    "rep_of l x = rep_of l y" "rep_of (l[x' := y']) x \<noteq> rep_of (l[x' := y']) y"
    "rep_of l y = rep_of (l[x':= y']) y"  "rep_of l x' \<noteq> rep_of l y'"
  shows "rep_of (l[x':= y']) x = rep_of (l[x':= y']) y'"
  using assms proof(induction rule: rep_of_induct)
  case (base i)
  then have "i = x'"
    by (metis nth_list_update' rep_of_refl)
  from base have "ufa_invar (l[x' := y'])"
    by (simp add: ufa_invar_fun_upd')
  with base show ?case
    by (metis \<open>i = x'\<close> rep_of_fun_upd_rep_of rep_of_refl)
next
  case (step i)
  then show ?case proof(cases "rep_of (l[x' := y']) (l ! i) = rep_of (l[x' := y']) y")
    case True
    with step have "i = x'"
      by (metis length_list_update nth_list_update_neq rep_of_idx ufa_invar_fun_upd')
    from step have "ufa_invar (l[x' := y'])"
      using ufa_invar_fun_upd' by presburger
    then show ?thesis
      by (metis \<open>i = x'\<close> length_list_update nth_list_update_eq rep_of_idx step.prems(2))
  next
    case False
    with step have "rep_of (l[x' := y']) (l ! i) = rep_of (l[x' := y']) y'"
      using rep_of_idx by presburger
    with step show ?thesis
      by (metis length_list_update nth_list_update_eq nth_list_update_neq rep_of_idx ufa_invar_fun_upd')
  qed
qed

subsection \<open>Termination and correctness of \<open>add_edge\<close>\<close>

lemma add_edge_domain:
  assumes "ufa_invar l" "y < length l" "y' < length l" "rep_of l y \<noteq> rep_of l y'"
  shows "add_edge_dom (l, y, y')"
proof-
  have path: "path l (rep_of l y) (path_to_root l y) y"
    by (simp add: assms(1) assms(2) path_to_root_correct)
  show ?thesis
    using path assms proof(induction "length (path_to_root l y)" arbitrary: l y' y)
    case 0
    with path_not_empty show ?case by auto
  next
    case IH: (Suc a)
    then show ?case
    proof(cases a)
      case 0
      then have "path_to_root l y = [y]"
        using IH path_unique_if_length_eq single by fastforce
      with IH have "l ! y = y"
        by (metis path_length_1 rep_of_root)
      then show ?thesis
        using add_edge.domintros by blast
    next
      case (Suc n)
      then have "length (path_to_root l y) > 1"
        using IH.hyps(2) by linarith
      then have path_root_divided:
        "path_to_root l y = rep_of l y # (tl (butlast (path_to_root l y))) @ [y]"
        using IH.prems(1) path_hd_and_last by blast
      with IH have "l ! y \<noteq> y"
        by (metis append_is_Nil_conv list_tail_coinc not_Cons_self2 path_no_cycle path_root)

      with IH have path_to_parent:
        "path l (rep_of l y) (rep_of l y # (tl (butlast (path_to_root l y)))) (l ! y)"
        by (metis butlast_eq_cons_conv path_butlast path_root_divided rep_of_min)
      have y_notin_path: "y \<notin> set (rep_of l y # (tl(butlast(path_to_root l y))))"
        by (metis IH.prems(1) IH.prems(2) butlast_eq_cons_conv path_remove_right path_root_divided)
      then have path_to_parent_update:
        "path (l[y := y']) (rep_of l y) (rep_of l y # (tl (butlast (path_to_root l y)))) (l ! y)"
        by (simp add: path_to_parent path_fun_upd)
      have rep_of_update: "rep_of l y = rep_of (l[y := y']) (l ! y)"
        by (metis IH.prems(2) IH.prems(3) path_to_parent y_notin_path rep_of_fun_upd rep_of_step)

      have path_y': "path l (rep_of l y') (path_to_root l y') y'"
        by (simp add: IH.prems(2) IH.prems(4) path_to_root_correct)
      have "y \<notin> set (path_to_root l y')"
        by (metis IH.prems(2) IH.prems(5) path_y' in_set_conv_nth nodes_path_rep_of(2))
      with ufa_invar_fun_upd have "ufa_invar (l[y := y'])"
        using IH.prems(2) IH.prems(4) path_y' by blast
      then have path_to_parent2:
        "path (l[y := y']) (rep_of (l[y := y']) (l ! y)) (path_to_root (l[y := y']) (l ! y)) (l ! y)"
        using path_to_parent_update path_nodes_lt_length_l path_to_root_correct by blast
      then have "l ! y < length (l[y := y'])"
        using path_nodes_lt_length_l by blast

      have "a = length (path_to_root (l[y := y']) (l ! y)) "
        by (metis IH.hyps(2) path_to_parent2 path_to_parent_update rep_of_update \<open>ufa_invar (l[y := y'])\<close> length_Cons length_append_singleton old.nat.inject path_root_divided path_unique)

      with IH(1) have "add_edge_dom (l[y := y'], l ! y, y)"
        by (metis IH.prems(2) IH.prems(3) IH.prems(5) \<open>l ! y < length (l[y := y'])\<close> path_to_parent2 path_y' rep_of_update \<open>ufa_invar (l[y := y'])\<close> \<open>y \<notin> set (path_to_root l y')\<close> length_list_update nth_list_update_eq rep_of_fun_upd rep_of_idx)
      then show ?thesis
        using add_edge.domintros by blast
    qed
  qed
qed

lemma add_edge_ufa_invar_invar:
  assumes "ufa_invar l"
    "e' < length l" "e < length l"
    "rep_of l e \<noteq> rep_of l e'"
  shows "ufa_invar (add_edge l e e')"
proof-
  have dom: "add_edge_dom (l, e, e')"
    by (simp add: add_edge_domain assms)
  from dom assms show ?thesis
    using assms proof(induction l e e' rule: add_edge.pinduct)
    case (1 pf e e')
 \<comment> \<open>The function update of \<open>add_edge\<close> does not form a cycle, therefore we can use
     the lemma \<open>ufa_invar_fun_upd\<close>.\<close>
    from 1 have path_root: "path pf (rep_of pf e') (path_to_root pf e') e'"
      by (simp add: path_to_root_correct)
    with path_rep_of_neq_disjoint 1 have e_notin_path_root: "e \<notin> set (path_to_root pf e')"
      by (metis in_set_conv_nth nodes_path_rep_of(2))
    with ufa_invar_fun_upd have ufa_invar_upd: "ufa_invar (pf[e := e'])"
      using 1 path_root by blast
    then show ?case
    proof(cases "pf ! e = e")
      case True
      from ufa_invar_upd show ?thesis
        by (simp add: "1.hyps" True add_edge.psimps)
    next
      case False
      from "1.prems" have lengths: "e < length (pf[e := e'])" "pf ! e < length (pf[e := e'])"
        by (auto simp add: ufa_invarD(2))
      have "rep_of (pf[e := e']) e = rep_of (pf[e := e']) e'"
        by (metis "1.prems"(3) lengths(1) nth_list_update_eq rep_of_idx ufa_invar_upd)
      also have "... = rep_of pf e'"
        using "1.prems"(1) e_notin_path_root path_root rep_of_fun_upd by auto
      from "1.prems" have path_e_root: "path pf (rep_of pf e) (path_to_root pf e) e"
        by (simp add: path_to_root_correct)
      with "1.prems" have path_pf_e: "path pf (rep_of pf e) (butlast (path_to_root pf e)) (pf ! e)"
        by (metis False path_butlast rep_of_root)
      then have "last (path_to_root pf e) = e"
        using path_e_root path_last by auto
      with path_remove_right have "e \<notin> set (butlast (path_to_root pf e))"
        using "1.prems"(1) path_e_root by auto
      with rep_of_fun_upd 1 have "rep_of (pf[e := e']) (pf ! e) = rep_of pf e"
        by (metis path_pf_e rep_of_step)
      then have "rep_of (pf[e := e']) (pf ! e) \<noteq> rep_of (pf[e := e']) e"
        by (simp add: "1.prems"(4) \<open>rep_of (pf[e := e']) e' = rep_of pf e'\<close> calculation)
      then have "ufa_invar (add_edge (pf[e := e']) (pf ! e) e)"
        by (metis "1.IH" lengths ufa_invar_upd)
      then show ?thesis
        by (simp add: "1.hyps" False add_edge.psimps)
    qed
  qed
qed

lemma add_edge_list_unchanged:
  assumes "ufa_invar l"
    "path l (rep_of l li) p\<^sub>1 li" "x < length l"
    "i \<notin> set p\<^sub>1" "rep_of l li \<noteq> rep_of l x"
  shows "l ! i = add_edge l li x ! i"
proof-
  from assms have dom: "add_edge_dom (l, li, x)"
    by (simp add: add_edge_domain path_nodes_lt_length_l)
  from dom assms show ?thesis
  proof(induction arbitrary: p\<^sub>1 rule: add_edge.pinduct)
    case (1 pf e e')
    then have invar: "ufa_invar (add_edge pf e e')"
      using add_edge_ufa_invar_invar path_nodes_lt_length_l by blast
    then show ?case
    proof(cases "pf ! e = e")
      case True
      then have add_edge: "add_edge pf e e' = pf[e := e']"
        by (simp add: "1.hyps" add_edge.psimps)
      from 1 have "i \<noteq> e"
        by (metis True list.set_intros(1) path_no_cycle path_nodes_lt_length_l rep_of_refl)
      then show ?thesis
        by (simp add: add_edge)
    next
      case False
      then have add_edge: "add_edge pf e e' = add_edge (pf[e := e']) (pf ! e) e"
        by (simp add: "1.hyps" add_edge.psimps)
      from ufa_invar_fun_upd' 1 have invar: "ufa_invar (pf[e := e'])"
        by blast
      from 1 have "last p\<^sub>1 = e"
        using path_last by blast
      with 1 have "i \<noteq> e"
        by (metis Misc.last_in_set path_not_empty)
      from 1 have path_to_parent: "path pf (rep_of pf (pf ! e)) (butlast p\<^sub>1) (pf ! e)"
        by (metis False path_butlast path_nodes_lt_length_l rep_of_min rep_of_step)
      with 1 have "path (pf[e := e']) (rep_of (pf[e := e']) (pf ! e)) (butlast p\<^sub>1) (pf ! e)"
        using path_fun_upd path_remove_right rep_of_fun_upd in_set_tlD by metis
      have "rep_of (pf[e := e']) (pf ! e) = rep_of pf (pf ! e)"
        using "1.prems" path_to_parent path_remove_right rep_of_fun_upd by auto
      from invar path_to_root_correct
      have "path (pf[e := e']) (rep_of (pf[e := e']) e) (path_to_root (pf[e := e']) e) e"
        using "1.prems" path_nodes_lt_length_l by auto
      then have "path (pf[e := e']) (rep_of (pf[e := e']) e') (butlast (path_to_root (pf[e := e']) e)) e'"
        using "1.prems" path_nodes_lt_length_l
        by (metis invar nth_list_update_eq path_butlast rep_of_idx rep_of_root)
      then have "e \<notin> set (butlast (path_to_root (pf[e := e']) e))"
        using \<open>path (pf[e := e']) (rep_of (pf[e := e']) e) (path_to_root (pf[e := e']) e) e\<close> invar path_remove_right by presburger
      have "rep_of (pf[e := e']) e' = rep_of pf e'"
        by (metis \<open>e \<notin> set (butlast (path_to_root (pf[e := e']) e))\<close> \<open>path (pf[e := e']) (rep_of (pf[e := e']) e') (butlast (path_to_root (pf[e := e']) e)) e'\<close> invar list_update_id list_update_overwrite rep_of_fun_upd)
      have "rep_of (pf[e := e']) (pf ! e) \<noteq> rep_of (pf[e := e']) e"
        by (metis "1.prems"(1) "1.prems"(2) "1.prems"(5) \<open>rep_of (pf[e := e']) (pf ! e) = rep_of pf (pf ! e)\<close> \<open>rep_of (pf[e := e']) e' = rep_of pf e'\<close> invar length_list_update nth_list_update_eq path_nodes_lt_length_l rep_of_idx)
      with 1 invar have "pf[e := e'] ! i = add_edge (pf[e := e']) (pf ! e) e ! i"
        by (metis \<open>path (pf[e := e']) (rep_of (pf[e := e']) (pf ! e)) (butlast p\<^sub>1) (pf ! e)\<close> \<open>path (pf[e := e']) (rep_of (pf[e := e']) e) (path_to_root (pf[e := e']) e) e\<close> in_set_butlastD path_nodes_lt_length_l)
      then show ?thesis
        using \<open>i \<noteq> e\<close> add_edge by force
    qed
  qed
qed

lemma nth_add_edge_e_eq_e':
  assumes "ufa_invar pf" "e < length pf" "e' < length pf"
    "rep_of pf e \<noteq> rep_of pf e'"
  shows "(add_edge pf e e') ! e = e'"
proof-
  from assms have dom: "add_edge_dom (pf, e, e')"
    by (simp add: add_edge_domain)
  from dom assms show ?thesis
  proof(induction rule: add_edge.pinduct)
    case (1 pf e e')
    then have invar: "ufa_invar (add_edge pf e e')"
      using add_edge_ufa_invar_invar by blast
    then show ?case
    proof(cases "pf ! e = e")
      case True
      then show ?thesis
        by (simp add: "1.hyps" "1.prems"(2) add_edge.psimps)
    next
      case False
      have invar: "ufa_invar (pf[e := e'])"
        using "1.prems" ufa_invar_fun_upd' by auto
      have "path pf (rep_of pf (pf ! e)) (path_to_root pf (pf ! e)) (pf ! e)"
        by (simp add: "1.prems"(1) "1.prems"(2) \<open>ufa_invar (pf[e := e'])\<close> path_to_root_correct ufa_invarD(2))
      with 1(3,4) invar path_remove_child[of "pf" "rep_of (pf[e := e']) (pf ! e)" "path_to_root (pf[e := e']) (pf ! e)" e]
      have "e \<notin> set (path_to_root pf (pf ! e))"
        using False path_remove_child by blast
      have "path (pf[e := e']) (rep_of pf (pf ! e)) (path_to_root pf (pf ! e)) (pf ! e)"
        by (metis in_set_tlD \<open>e \<notin> set (path_to_root pf (pf ! e))\<close> \<open>path pf (rep_of pf (pf ! e)) (path_to_root pf (pf ! e)) (pf ! e)\<close> path_fun_upd)
      with "1.prems" add_edge_list_unchanged[of "pf[e := e']" "pf ! e" _ e e] have "add_edge (pf[e := e']) (pf ! e) e ! e = (pf[e := e']) ! e"
        by (metis \<open>e \<notin> set (path_to_root pf (pf ! e))\<close> \<open>path pf (rep_of pf (pf ! e)) (path_to_root pf (pf ! e)) (pf ! e)\<close> invar length_list_update list_update_overwrite nth_list_update_eq rep_of_fun_upd rep_of_idx ufa_compress_aux(2))
      with 1 show ?thesis
        by (metis add_edge.psimps nth_list_update_eq)
    qed
  qed
qed

text \<open>\<open>add_edge\<close> reverses all the edges for e to its root, and then adds an edge from e to e'. \<close>
lemma add_edge_correctness:
  assumes "ufa_invar pf" "e < length pf" "e' < length pf"
    "rep_of pf e \<noteq> rep_of pf e'"
  shows "path (add_edge pf e e') e' ([e'] @ rev (path_to_root pf e)) (rep_of pf e)"
proof-
  from assms have dom: "add_edge_dom (pf, e, e')"
    by (simp add: add_edge_domain)
  from dom assms show ?thesis
  proof(induction rule: add_edge.pinduct)
    case (1 pf e e')
    then have invar: "ufa_invar (add_edge pf e e')"
      using add_edge_ufa_invar_invar by blast
    then show ?case
    proof(cases "pf ! e = e")
      case True
      then have add_edge: "add_edge pf e e' = pf[e := e']"
        by (simp add: "1.hyps" add_edge.psimps)
      have "rep_of pf e = e"
        by (simp add: True rep_of_refl)
      with True 1 have "path_to_root pf e = [e]"
        by (metis \<open>rep_of pf e = e\<close> path_to_root_correct path_unique single)
      then have "rev (path_to_root pf e) = [e]" by simp
      then have "path (add_edge pf e e') (rep_of pf e) (rev (path_to_root pf e)) e"
        by (simp add: "1.prems"(2) \<open>rep_of pf e = e\<close> add_edge single)
      then have "path (add_edge pf e e') e' [e', e] e"
        using add_edge invar 1
        by (metis \<open>rep_of pf e = e\<close> \<open>rev (path_to_root pf e) = [e]\<close> nth_list_update_eq path.step path_nodes_lt_length_l ufa_invarD(2))
      then show ?thesis
        by (simp add: \<open>rep_of pf e = e\<close> \<open>rev (path_to_root pf e) = [e]\<close>)
    next
      case False
      then have add_edge: "add_edge pf e e' = add_edge (pf[e := e']) (pf ! e) e"
        by (simp add: "1.hyps" add_edge.psimps)
      from 1 have reps: "rep_of (pf[e := e']) e = rep_of (pf[e := e']) e'"
        by (metis length_list_update nth_list_update_eq rep_of_idx ufa_invar_fun_upd')
      have path_e': "path pf (rep_of pf e') (path_to_root pf e') e'" "e \<notin> set (path_to_root pf e')"
         apply (simp add: "1.prems" path_to_root_correct)
        by (metis "1.prems"(1,3,4) in_set_conv_nth path_rep_of_neq_not_in_path path_to_root_correct)
      have path_pf_e: "path pf (rep_of pf (pf ! e)) (butlast (path_to_root pf e)) (pf ! e)"
        "e \<notin> set (butlast (path_to_root pf e))"
         apply (metis "1.prems"(1,2) False path_butlast path_to_root_correct rep_of_min rep_of_step)
        by (metis "1.prems"(1,2) path_remove_right path_to_root_correct)
      with rep_of_fun_upd path_e' 1 have reps2: "rep_of (pf[e := e']) e' = rep_of pf e'"
        "rep_of (pf[e := e']) (pf ! e) = rep_of pf (pf ! e)"
        by auto
      then have "rep_of (pf[e := e']) (pf ! e) \<noteq> rep_of (pf[e := e']) e"
        by (simp add: 1 reps rep_of_idx)
      with 1 have path_add_edge: "path (add_edge (pf[e := e']) (pf ! e) e) e
      ([e] @ rev (path_to_root (pf[e := e']) (pf ! e))) (rep_of (pf[e := e']) (pf ! e))"
        by (metis length_list_update ufa_invarD(2) ufa_invar_fun_upd')
      have "path pf (rep_of pf e) (path_to_root pf e) e"
        by (simp add: "1.prems" path_to_root_correct)
      then have last_path_to_root: "last (path_to_root pf e) = e"
        using path_last by auto
      have add_edge_e: "(add_edge pf e e') ! e = e'"
        by (simp add: "1.prems" nth_add_edge_e_eq_e')
      from "1.prems" have *: "path_to_root pf (pf ! e) @ [e] = path_to_root pf e"
        by (metis False append_butlast_last_id butlast.simps(1) last_path path_pf_e(1) path_to_root_correct path_unique ufa_invarD(2))
      with path_pf_e "1.prems"(1) path_to_root_fun_upd have path_root_parent:
        "path_to_root (pf[e := e']) (pf ! e) = path_to_root pf (pf ! e)"
        by (metis path_e' path_nodes_lt_length_l ufa_invar_fun_upd)
      with * have **: "tl (rev (path_to_root pf e)) = rev (path_to_root (pf[e := e']) (pf ! e))"
        by (metis butlast_snoc rev_butlast_is_tl_rev)
      have "hd (rev (path_to_root pf e)) = e"
        by (simp add: last_path_to_root hd_rev)
      with "1.prems" path_add_edge add_edge  ** show ?thesis
        by (metis "*" Cons_eq_appendI add_edge_e empty_append_eq_id invar path.step path_nodes_lt_length_l path_root_parent rep_of_idx reps2(2) rev_append rev_singleton_conv ufa_invarD(2))
    qed
  qed
qed

text \<open>The \<open>rep_of (add_edge l x y)\<close> behaves exactly the same as \<open>rep_of (ufa_union l x y)\<close>.\<close>
lemma rep_of_add_edge_aux:
  assumes "ufa_invar l"
    and "x < length l"
    and "y < length l"
    and "i < length l"
    and "rep_of l x \<noteq> rep_of l y"
  shows "rep_of (add_edge l x y) i = (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)"
proof-
  from assms have dom: "add_edge_dom (l, x, y)"
    by (simp add: add_edge_domain)
  from dom assms show ?thesis
  proof(induction rule: add_edge.pinduct)
    case (1 pf e e')
    then show ?case
    proof(cases "pf ! e = e")
      case True
        \<comment>\<open>e is a root, only one edge to e' is added\<close>
      then have add_edge: "add_edge pf e e' = pf[e := e']"
        by (simp add: "1.hyps" add_edge.psimps)
      have rep_e: "rep_of pf e = e"
        by (simp add: True rep_of_refl)
          \<comment>\<open>the new rep of i is either e', if it was e, or it doesn't change.\<close>
      then show ?thesis proof(cases "rep_of pf i = e")
        case True
        then show ?thesis
          using "1.prems" add_edge rep_e rep_of_fun_upd_rep_of by auto
      next
        case False
        with rep_of_fun_upd' show ?thesis
          using "1.prems" rep_e add_edge by force
      qed
    next
      case False
        \<comment>\<open>Inductive step: first we need to prove the assumptions of the inductive hypothesis.\<close>
      then have add_edge: "add_edge pf e e' = add_edge (pf[e := e']) (pf ! e) e"
        by (simp add: "1.hyps" add_edge.psimps)
      from False add_edge_correctness "1.prems"
      have invar: "ufa_invar (pf[e := e'])"
        by (simp add: "1.prems" ufa_invar_fun_upd')
      from rep_of_fun_upd "1.prems" have rep_of_parent:
        "rep_of (pf[e := e']) (pf ! e) = rep_of pf (pf ! e)"
        by (metis False path_remove_child path_to_root_correct ufa_invarD(2))
      with "1.prems" have rep_of_parent': "rep_of (pf[e := e']) (pf ! e) \<noteq> rep_of (pf[e := e']) e"
        by (metis invar length_list_update nth_list_update_eq rep_of_fun_upd' rep_of_idx)
          \<comment>\<open>The induction hypothesis tells us that the claim holds for the parent of e\<close>
      with 1(2)[OF False invar] 1 have IH: "rep_of (add_edge (pf[e := e']) (pf ! e) e) i =
      (if rep_of (pf[e := e']) i = rep_of (pf[e := e']) (pf ! e) then rep_of (pf[e := e']) e
       else rep_of (pf[e := e']) i)"
        by (metis length_list_update ufa_invarD(2))
      then show ?thesis
      proof(cases "rep_of pf i = rep_of pf e")
        case True
        then show ?thesis proof(cases "rep_of (pf[e := e']) i = rep_of (pf[e := e']) (pf ! e)")
          case True
            \<comment>\<open>i was in the same connected component as e, and after adding the edge (e, e'),
          i is in the same connected component as the parent of e,
          therefore i is nearer to the root than e.\<close>
          with "1.prems" show ?thesis
            by (metis IH add_edge invar length_list_update nth_list_update_eq rep_of_fun_upd' rep_of_idx rep_of_parent)
        next
          case False
            \<comment>\<open>i was in the same connected component as e, and after adding the edge (e, e'),
          i is not in the same connected component as the parent of e.
          Therefore e is nearer to the root than i, and the new representative of i
          is rep_of e', which is also the new representative of e.\<close>
          with True rep_of_fun_upd3 "1.prems" have *:
            "rep_of (pf[e := e']) i = rep_of (pf[e := e']) e"
            by (metis rep_of_parent' rep_of_parent rep_of_step ufa_invarD(2))
          with "1.prems" have "rep_of (pf[e := e']) e = rep_of (pf[e := e']) e'"
            by (metis False rep_of_fun_upd3 rep_of_idx rep_of_parent ufa_invarD(2))
          then show ?thesis
            using "1.prems" IH True * add_edge rep_of_fun_upd' by presburger
        qed
      next
        case False
        then show ?thesis
          using "1.prems" add_edge IH rep_of_parent rep_of_fun_upd' rep_of_idx by presburger
      qed
    qed
  qed
qed

lemma rep_of_add_edge_invar:
  assumes "rep_of l a = rep_of l b" "rep_of l x1 \<noteq> rep_of l x2"
    "ufa_invar l" "a < length l" "b < length l " "x1 < length l " "x2 < length l"
  shows "rep_of (add_edge l x1 x2) a = rep_of (add_edge l x1 x2) b"
  by (simp add: assms rep_of_add_edge_aux)

subsection \<open>Termination of \<open>add_label\<close>\<close>

text \<open>The termination of \<open>add_label\<close> only depends on pf and y.\<close>
lemma add_label_dom_pf_y: "add_label_dom (pfl, pf, y, x) \<Longrightarrow> add_label_dom (pfl', pf, y, x')"
proof(induction arbitrary: pfl' x' rule: add_label.pinduct)
  case (1 pfl pf e lbl)
  then show ?case proof(cases "pf ! e = e")
    case True
    with add_label.domintros show ?thesis by blast
  next
    case False
    have "add_label_dom (pfl'[e := Some x'], pf, pf ! e, the (pfl' ! e))"
      by (simp add: "1.IH" False)
    with add_label.domintros show ?thesis by blast
  qed
qed

lemma rep_of_dom_iff_add_label_dom: "rep_of_dom (pf, y) \<longleftrightarrow> add_label_dom (pfl, pf, y, y')"
proof
  show "rep_of_dom (pf, y) \<Longrightarrow> add_label_dom (pfl, pf, y, y')"
  proof(induction rule: rep_of.pinduct)
    case (1 l i)
    then show ?case proof(cases "l ! i = i")
      case True
      then show ?thesis
        using add_label.domintros by blast
    next
      case False
      then have "add_label_dom (pfl, l, l ! i, y')"
        by (simp add: "1.IH")
      then have "add_label_dom (pfl[i := Some y'], l, l ! i, the (pfl ! i))"
        using add_label_dom_pf_y by blast
      then show ?thesis using add_label.domintros by blast
    qed
  qed
next
  show "add_label_dom (pfl, pf, y, y') \<Longrightarrow> rep_of_dom (pf, y)"
  proof(induction rule: add_label.pinduct)
    case (1 pfl pf e lbl)
    then show ?case apply(cases "pf ! e = e")
      using rep_of.domintros by blast+
  qed
qed

lemma add_label_domain:
  assumes "ufa_invar pf" "y < length pf"
  shows "add_label_dom (pfl, pf, y, y')"
  using assms rep_of_dom_iff_add_label_dom
  by (simp add: ufa_invar_def)

subsection \<open>Invariants for lookup\<close>

abbreviation lookup_valid_element :: "equation option list list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where
    "lookup_valid_element t l i j \<equiv> t ! i ! j = None \<or>
(\<exists>a\<^sub>1 a\<^sub>2 aa. t ! i ! j = Some (F a\<^sub>1 a\<^sub>2 \<approx> aa) \<and>
  rep_of l a\<^sub>1 = i \<and> rep_of l a\<^sub>2 = j \<and>
  a\<^sub>1 < length l \<and> a\<^sub>2 < length l \<and> aa < length l)"

abbreviation quadratic_table :: "'a list list \<Rightarrow> bool"
  where
    "quadratic_table xs \<equiv> \<forall> i < length xs . length (xs ! i) = length xs"

lemma ufa_union_lookup_valid:
  assumes "lookup_valid_element t l i j" "(ufa_union l a b) ! i = i" "(ufa_union l a b) ! j = j"
    "a < length l" "b < length l" "ufa_invar l"
  shows "lookup_valid_element t (ufa_union l a b) i j"
proof(cases "t ! i ! j = None")
  case True
  then show ?thesis
    by blast
next
  case False
  from assms have "l ! i = i" "l ! j = j"
    using False rep_of_min by blast+
  then show ?thesis
    by (metis (no_types, lifting) assms length_list_update nth_list_update_eq rep_of_less_length_l ufa_union_aux)
qed

end