theory CC_Explain2_Definition
  imports CC_Definition2 "HOL-Library.Multiset_Order"
begin

section \<open>Alternative definition of explain\<close>

text \<open>This version of explain is equivalent to the other one, without the optimization
of the additional proof forest. We can prove, that it also terminates, and that it outputs
the same equations as the original explain algorithm. \<close>

function (domintros) explain_along_path2 :: "congruence_closure \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
    (equation set * (nat * nat) list)"
  where
    "explain_along_path2 cc a c =
(if a = c
then
  ({}, [])
else
  (let b = (proof_forest cc) ! a in
    (
    case the ((pf_labels cc) ! a) of
        One a' \<Rightarrow>
          (let (output, pending) = explain_along_path2 cc b c
          in ({a'} \<union> output, pending))
        | Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b') \<Rightarrow>
          (let (output, pending) = explain_along_path2 cc b c
          in ({(F a\<^sub>1 a\<^sub>2 \<approx> a'), (F b\<^sub>1 b\<^sub>2 \<approx> b')} \<union> output, [(a\<^sub>1, b\<^sub>1), (a\<^sub>2, b\<^sub>2)] @ pending))
    )
  )
)"
  by pat_completeness auto

lemma explain_along_path2_simp1:
  assumes "a = c"
  shows "explain_along_path2 cc a c = ({}, [])"
proof-
  have "explain_along_path2_dom (cc, a, c)"
    using assms explain_along_path2.domintros by blast
  then show ?thesis using explain_along_path2.psimps
    by (simp add: assms)
qed

lemma explain_along_path2_simp2:
  assumes "a \<noteq> c"
    "(pf_labels cc) ! a = Some (One a')"
    "(output, pend) = explain_along_path2 cc ((proof_forest cc) ! a) c"
    "explain_along_path2_dom (cc, a, c)"
  shows "explain_along_path2 cc a c = ({a'} \<union> output, pend)"
  using explain_along_path2.psimps unfolding Let_def
  by (metis (no_types, lifting) assms case_prod_conv option.sel pending_equation.simps(5))

lemma explain_along_path2_simp3:
  assumes "a \<noteq> c"
    "(pf_labels cc) ! a = Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b'))"
    "explain_along_path2 cc ((proof_forest cc) ! a) c = (output, pend)"
    "explain_along_path2_dom (cc, a, c)"
  shows "explain_along_path2 cc a c = ({(F a\<^sub>1 a\<^sub>2 \<approx> a'), (F b\<^sub>1 b\<^sub>2 \<approx> b')} \<union> output,
     [(a\<^sub>1, b\<^sub>1), (a\<^sub>2, b\<^sub>2)] @ pend)"
  using explain_along_path2.psimps unfolding Let_def
  by (metis (no_types, lifting) assms case_prod_conv option.sel pending_equation.simps(6) equation.simps(6))

function (domintros) cc_explain_aux2 :: "congruence_closure \<Rightarrow> (nat * nat) list \<Rightarrow> equation set"
  where
    "cc_explain_aux2 cc [] = {}"
  | "cc_explain_aux2 cc ((a, b) # xs) =
(if are_congruent cc (a \<approx> b)
then
  (let c = lowest_common_ancestor (proof_forest cc) a b;
    (output1, pending1) = explain_along_path2 cc a c;
    (output2, pending2) = explain_along_path2 cc b c
  in
    output1 \<union> output2 \<union> cc_explain_aux2 cc (pending1 @ pending2 @ xs))
else cc_explain_aux2 cc xs)"
  by pat_completeness auto

lemma cc_explain_aux2_simp1:
  "cc_explain_aux2 cc [] = {}"
  using cc_explain_aux2.domintros cc_explain_aux2.psimps by blast

lemma cc_explain_aux2_simp2:
  assumes "cc_explain_aux2_dom (cc, ((a, b) # xs))"
    "c = lowest_common_ancestor (proof_forest cc) a b"
    "are_congruent cc (a \<approx> b)"
    "(output1, pending1) = explain_along_path2 cc a c"
    "(output2, pending2) = explain_along_path2 cc b c"
  shows "cc_explain_aux2 cc ((a, b) # xs) =
output1 \<union> output2 \<union> cc_explain_aux2 cc (pending1 @ pending2 @ xs)"
  using cc_explain_aux2.domintros cc_explain_aux2.psimps assms unfolding Let_def
  by auto

lemma cc_explain_aux2_simp3:
  assumes "cc_explain_aux2_dom (cc, ((a, b) # xs))"
    "\<not> are_congruent cc (a \<approx> b)"
  shows "cc_explain_aux2 cc ((a, b) # xs) = cc_explain_aux2 cc xs"
  using cc_explain_aux2.domintros cc_explain_aux2.psimps assms unfolding Let_def
  by auto

abbreviation cc_explain2 :: "congruence_closure \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> equation set"
  where
    "cc_explain2 cc a b \<equiv> cc_explain_aux2 cc [(a, b)]"

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

lemma explain_along_path2_domain:
  assumes "cc_invar cc"
    "path (proof_forest cc) c p a"
  shows "explain_along_path2_dom (cc, a, c)"
  using assms proof(induction "length p" arbitrary: p a rule: less_induct)
  case less
  then show ?case proof(cases "a = c")
    case True
    then show ?thesis using explain_along_path2.domintros by blast
  next
    case False
    then have "length p > 0" using less unfolding proof_forest_invar_def
      by (simp add: path_not_empty)
    from False have "length p \<noteq> 1" using less unfolding proof_forest_invar_def
      by (metis impossible_Cons length_greater_0_conv less_numeral_extra(3) nat_geq_1_eq_neqz path.cases path_length_1)
    then have "length p > 1"
      using \<open>0 < length p\<close> nat_neq_iff by auto
    then obtain cc_l u t pe pf pfl ip where cc: "cc =
\<lparr>cc_list = cc_l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl,
         input = ip\<rparr>" using congruence_closure.cases by blast
    have invar: "ufa_invar pf"
      using "less.prems" unfolding proof_forest_invar_def cc congruence_closure.select_convs by blast
    then have pRAC': "path pf c (butlast p) (pf ! a)"
      using "less.prems" unfolding cc congruence_closure.select_convs
      by (metis False path_butlast)
    with less(1,2)  pRAC' cc have recursive_dom:
      "explain_along_path2_dom (cc, (pf ! a), c)"
      by (metis \<open>0 < length p\<close> congruence_closure.select_convs(5) diff_less length_butlast less_numeral_extra(1))
    show ?thesis using cc recursive_dom explain_along_path2.domintros
      by (metis congruence_closure.select_convs(5))
  qed
qed

subsection \<open>Induction rule on \<open>explain_long_path2\<close>\<close>

lemma explain_along_path2_induct[consumes 3, case_names base One Two]:
  assumes "cc_invar cc"
    "path (proof_forest cc) c p a"
    "explain_along_path2 cc a c = (output, pend)"
    "(\<And>cc a c p.
    explain_along_path2_dom (cc, a, c) \<Longrightarrow>
    cc_invar cc \<Longrightarrow>
      path (proof_forest cc) c p a \<Longrightarrow>
        a = c \<Longrightarrow>
        P cc a c {} [] p)"
    "(\<And>cc a c p1 p2 x x1 x11 x12 output pend.
    explain_along_path2_dom (cc, a, c) \<Longrightarrow>
    cc_invar cc \<Longrightarrow>
      path (proof_forest cc) c p1 a \<Longrightarrow>
      path (proof_forest cc) c p2 x \<Longrightarrow>
      explain_along_path2 cc x c = (output, pend) \<Longrightarrow>
      a \<noteq> c \<Longrightarrow>
      x = proof_forest cc ! a \<Longrightarrow>
      pf_labels cc ! a = Some (One x1) \<Longrightarrow>
      x11 < nr_vars cc \<Longrightarrow> x12 < nr_vars cc \<Longrightarrow> x1 = (x11 \<approx> x12) \<Longrightarrow>
      x < nr_vars cc \<Longrightarrow>
      P cc x c output pend p2 \<Longrightarrow>
         P cc a c ({x1} \<union> output) pend p1)"
    "(\<And>cc a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y output pend.
      explain_along_path2_dom (cc, a, c) \<Longrightarrow>
      cc_invar cc \<Longrightarrow>
      path (proof_forest cc) c p1 a \<Longrightarrow>
      path (proof_forest cc) c p2 x \<Longrightarrow>
       explain_along_path2 cc x c = (output, pend) \<Longrightarrow>
       a \<noteq> c \<Longrightarrow>
        x = proof_forest cc ! a \<Longrightarrow>
        pf_labels cc ! a = Some (Two x21 x22)
      \<Longrightarrow> x21 = (F x\<^sub>1 x\<^sub>2 \<approx> x') \<Longrightarrow> x22 = (F y\<^sub>1 y\<^sub>2 \<approx> y) \<Longrightarrow>
      x < nr_vars cc \<Longrightarrow> x\<^sub>1 < nr_vars cc \<Longrightarrow> x\<^sub>2 < nr_vars cc
      \<Longrightarrow> x' < nr_vars cc \<Longrightarrow> y\<^sub>1 < nr_vars cc \<Longrightarrow> y\<^sub>2 < nr_vars cc \<Longrightarrow> y < nr_vars cc
      \<Longrightarrow> P cc x c output pend p2 \<Longrightarrow>
      P cc a c ({(F x\<^sub>1 x\<^sub>2 \<approx> x'), (F y\<^sub>1 y\<^sub>2 \<approx> y)} \<union> output) ([(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)] @ pend) p1)"
  shows "P cc a c output pend p"
proof-
  have "explain_along_path2_dom (cc, a, c)"
    using assms explain_along_path2_domain by fast
  then show ?thesis
    using assms proof(induction
      arbitrary: "output" pend p
      rule: explain_along_path2.pinduct)
    case (1 cc a c)
    then show ?case
    proof(cases "a = c")
      case True
      with 1(6) have "output = {}"  "pend = []" using explain_along_path2_simp1
        by simp+
      then show ?thesis using 1(7)
        using "1.hyps" "1.prems"(1,2) True by blast
    next
      case False
      define x where "x = (proof_forest cc) ! a"
      have path_to_rep: "path (proof_forest cc) c (butlast p) x"
        using "1.prems" x_def
        using False path_butlast by auto
      have not_none: "(pf_labels cc) ! a \<noteq> None"
        using "1.prems" False pf_labels_invar_def path_nodes_lt_length_l
        by (metis option.distinct(1) path_root)
      then obtain output_rec' pending_rec'
        where
          rec': "explain_along_path2 cc x c = (output_rec',  pending_rec')"
        using old.prod.exhaust by blast
      then have "x < nr_vars cc"
        using "1.prems"(1,2) same_length_invar_def path_nodes_lt_length_l path_to_rep
        by metis
      show ?thesis
      proof(cases "the ((pf_labels cc) ! a)")
        case (One x1)
        then have Some: "(pf_labels cc) ! a = Some (One x1)"
          using not_none by auto
        then obtain x11 x12 where "x1 = (x11 \<approx> x12)" "x11 < nr_vars cc" "x12 < nr_vars cc"
          using "1.prems" One not_none unfolding pf_labels_invar_def same_length_invar_def
          by (metis False \<open>x < nr_vars cc\<close> option.sel path_nodes_lt_length_l path_root pending_equation.distinct(1) pending_equation.inject(1) x_def)
        then have rec: "(output, pend) = ({x1} \<union> output_rec', pending_rec')"
          using "1.hyps" "1.prems" False Some x_def explain_along_path2_simp2
          by (metis rec')
        have IH: "P cc x c output_rec' pending_rec' (butlast p)" using 1(2)
          using "1.prems"(1) False One assms(4-6) rec' x_def path_to_rep by blast
        then show ?thesis using 1(8)
          using "1.hyps" "1.prems"(1,2,3) False Some \<open>x < nr_vars cc\<close> \<open>x1 = (x11 \<approx> x12)\<close> \<open>x11 < nr_vars cc\<close> \<open>x12 < nr_vars cc\<close> local.rec path_to_rep rec' x_def
          by blast
      next
        case (Two x21 x22)
        have "(proof_forest cc) ! a \<noteq> a" "a < length (proof_forest cc)"
          using "1.prems"(2) False path_no_root apply auto[1]
          using "1.prems"(2) path_nodes_lt_length_l by fastforce
        then obtain x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y where Some: "((pf_labels cc) ! a = Some (One (x' \<approx> y)) \<or>
          (pf_labels cc) ! a = Some (Two (F x\<^sub>1 x\<^sub>2 \<approx> x') (F y\<^sub>1 y\<^sub>2 \<approx> y)))
          \<and> (x' = (proof_forest cc) ! a \<and> y = a \<or> x' = a \<and> y = (proof_forest cc) ! a)
          \<and> valid_vars_pending (the ((pf_labels cc) ! a)) (cc_list cc)"
          using Two "1.prems" False not_none unfolding pf_labels_invar_def
          by blast
        then have Some: "(pf_labels cc) ! a =
Some (Two (F x\<^sub>1 x\<^sub>2 \<approx> x') (F y\<^sub>1 y\<^sub>2 \<approx> y))" "x\<^sub>1 < nr_vars cc" "x\<^sub>2 < nr_vars cc" "x' < nr_vars cc"
          "y\<^sub>1 < nr_vars cc" "y\<^sub>2 < nr_vars cc"  "y < nr_vars cc"
          using Two by fastforce+
        then have x21x22: "x21 = (F x\<^sub>1 x\<^sub>2 \<approx> x')" "x22 = (F y\<^sub>1 y\<^sub>2 \<approx> y)" using Two by auto
        have rec: "(output, pend)
= ({(F x\<^sub>1 x\<^sub>2 \<approx> x'), (F y\<^sub>1 y\<^sub>2 \<approx> y)} \<union> output_rec', [(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)] @ pending_rec')"
          using explain_along_path2_simp3 False Some(1) rec' x_def 1(1,6) by auto
        have IH: "P cc x c output_rec' pending_rec' (butlast p)"
          using 1(3) False x_def Two x21x22 "1.prems"(1) path_to_rep rec'
          using assms(4-6) by blast
        then show ?thesis
          using 1(9)[OF 1(1,4,5) path_to_rep rec' False
              x_def Some(1) _ _ \<open>x < nr_vars cc\<close> Some(2,3,4,5,6,7) IH] rec
          by blast
      qed
    qed
  qed
qed

subsection \<open>Lemmata about \<open>cc_explain_along_path\<close> and \<open>cc_explain_along_path2\<close>\<close>

fun pending_pairs :: "pending_equation option \<Rightarrow> (nat * nat) set"
  where
    "pending_pairs None = {}"
  | "pending_pairs (Some (One a)) = {}"
  | "pending_pairs (Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b'))) = {(a\<^sub>1, b\<^sub>1), (a\<^sub>2, b\<^sub>2)}"
  | "pending_pairs (Some (Two a b)) = {}"

definition additional_uf_labels_set where
 "additional_uf_labels_set l pfl \<equiv> \<Union>{pe_to_set (pfl ! a) |a. a < length l \<and> l ! a \<noteq> a}"

definition additional_uf_pairs_set where
  "additional_uf_pairs_set l pfl \<equiv> \<Union>{pending_pairs (pfl ! a) |a. a < length l \<and> l ! a \<noteq> a}"

lemma additional_uf_labels_set_fun_upd_l:
  assumes "k \<noteq> pf ! k" "k < length l"
  shows "additional_uf_labels_set (l[k := pf ! k]) pfl =
additional_uf_labels_set l pfl \<union> pe_to_set (pfl ! k)"
proof
  show "additional_uf_labels_set (l[k := pf ! k]) pfl
    \<subseteq> additional_uf_labels_set l pfl \<union> pe_to_set (pfl ! k)"
  proof
    fix x assume "x \<in> additional_uf_labels_set (l[k := pf ! k]) pfl"
    then obtain i where i: "x \<in> pe_to_set (pfl ! i)"
      "i < length (l[k := pf ! k])" "l[k := pf ! k] ! i \<noteq> i"
      unfolding additional_uf_labels_set_def by auto
    then show "x \<in> additional_uf_labels_set l pfl \<union> pe_to_set (pfl ! k)"
    proof(cases "l ! i = i")
      case True
      with i show ?thesis unfolding additional_uf_labels_set_def
        by (metis (no_types, lifting) Un_iff nth_list_update_neq)
    next
      case False
      then show ?thesis unfolding additional_uf_labels_set_def
        using i by auto
    qed
  qed
next
  show "additional_uf_labels_set l pfl \<union> pe_to_set (pfl ! k)
    \<subseteq> additional_uf_labels_set (l[k := pf ! k]) pfl"
  proof
    fix x assume "x \<in> additional_uf_labels_set l pfl \<union> pe_to_set (pfl ! k)"
    then show "x \<in> additional_uf_labels_set (l[k := pf ! k]) pfl"
    proof
      assume "x \<in> additional_uf_labels_set l pfl"
      then obtain i where i: "x \<in> pe_to_set (pfl ! i)" "i < length l \<and> l ! i \<noteq> i"
        unfolding additional_uf_labels_set_def by blast
      then have "l[k := pf ! k] ! i \<noteq> i" using assms
        by (metis nth_list_update_eq nth_list_update_neq)
      then show ?thesis unfolding additional_uf_labels_set_def
        using i(1) i(2) by auto
    next
      assume "x \<in> pe_to_set (pfl ! k)"
      have "l[k := pf ! k] ! k \<noteq> k"
        using assms by simp
      then show ?thesis unfolding additional_uf_labels_set_def
        using \<open>x \<in> pe_to_set (pfl ! k)\<close> assms(2) length_list_update mem_Collect_eq by fastforce
    qed
  qed
qed

lemma additional_uf_labels_set_explain_along_path:
  assumes "cc_invar cc"
    "explain_list_invar l (proof_forest cc)"
    "path (proof_forest cc) c p a"
    "explain_along_path cc l a c = (output, new_l, pend)"
  shows "additional_uf_labels_set new_l (pf_labels cc) =
additional_uf_labels_set l (pf_labels cc) \<union> output"
  using assms proof(induction rule: explain_along_path_induct)
  case (One cc l a c p1 p2 x x1 x11 x12 "output" new_l pend)
  have "additional_uf_labels_set (l[rep_of l a := x]) (pf_labels cc)
= additional_uf_labels_set l (pf_labels cc) \<union> pe_to_set (pf_labels cc ! rep_of l a)"
    by (metis (no_types, lifting) One.hyps(3,4,5,8,9) additional_uf_labels_set_fun_upd_l explain_list_invar_def path_nodes_lt_length_l path_root rep_of_iff rep_of_less_length_l)
  moreover have "pe_to_set (pf_labels cc ! rep_of l a) = {x1}"
    by (simp add: One.hyps(10))
  ultimately show ?case
    by (simp add: One.IH)
next
  case (Two cc l a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y "output" new_l pend)
  have "additional_uf_labels_set (l[rep_of l a := x]) (pf_labels cc)
= additional_uf_labels_set l (pf_labels cc) \<union> pe_to_set (pf_labels cc ! rep_of l a)"
    by (metis (no_types, lifting) Two.hyps(3,4,5,8,9) additional_uf_labels_set_fun_upd_l explain_list_invar_def path_nodes_lt_length_l path_root rep_of_iff rep_of_less_length_l)
  moreover have "pe_to_set (pf_labels cc ! rep_of l a) = {F x\<^sub>1 x\<^sub>2 \<approx> x', F y\<^sub>1 y\<^sub>2 \<approx> y}"
    by (simp add: Two.hyps(10-12))
  ultimately show ?case
    by (simp add: Two.IH)
qed simp

lemma additional_uf_labels_set_explain_along_path':
  assumes "cc_invar cc"
    "explain_list_invar l (proof_forest cc)"
    "c = lowest_common_ancestor (proof_forest cc) a b"
    "explain_along_path cc l a c = (output1, new_l, pend1)"
    "explain_along_path cc new_l b c = (output2, new_new_l, pend2)"
    "a < nr_vars cc" "b < nr_vars cc"
    "are_congruent cc (a \<approx> b)"
  shows "additional_uf_labels_set l (pf_labels cc) \<subseteq>
additional_uf_labels_set new_new_l (pf_labels cc)"
proof-
obtain p1 p2 where paths: "path (proof_forest cc) c p1 a" "path (proof_forest cc) c p2 b"
    using assms lowest_common_ancestor_correct unfolding proof_forest_invar_def
    by (metis assms(1) explain_along_path_lowest_common_ancestor)
  have 1: "additional_uf_labels_set l (pf_labels cc) \<subseteq> additional_uf_labels_set new_l (pf_labels cc)"
    using additional_uf_labels_set_explain_along_path assms paths
    by blast
  have eli: "explain_list_invar new_l (proof_forest cc)" using assms
    by (metis explain_along_path_domain explain_list_invar_explain_along_path' paths(1))
  then have  "additional_uf_labels_set new_l (pf_labels cc)
 \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc)"
    using additional_uf_labels_set_explain_along_path assms paths
    by blast
  then show ?thesis using 1
    by simp
qed

lemma additional_uf_pairs_set_fun_upd_l:
  assumes "k \<noteq> pf ! k" "k < length l"
  shows "additional_uf_pairs_set (l[k := pf ! k]) pfl =
additional_uf_pairs_set l pfl \<union> pending_pairs (pfl ! k)"
proof
  show "additional_uf_pairs_set (l[k := pf ! k]) pfl
    \<subseteq> additional_uf_pairs_set l pfl \<union> pending_pairs (pfl ! k)"
  proof
    fix x assume "x \<in> additional_uf_pairs_set (l[k := pf ! k]) pfl"
    then obtain i where i: "x \<in> pending_pairs (pfl ! i)"
      "i < length (l[k := pf ! k])" "l[k := pf ! k] ! i \<noteq> i"
      unfolding additional_uf_pairs_set_def by auto
    then show "x \<in> additional_uf_pairs_set l pfl \<union> pending_pairs (pfl ! k)"
    proof(cases "l ! i = i")
      case True
      with i show ?thesis
        by (metis (no_types, lifting) Un_iff nth_list_update_neq)
    next
      case False
      then show ?thesis unfolding additional_uf_pairs_set_def
        using i by auto
    qed
  qed
next
  show "additional_uf_pairs_set l pfl \<union> pending_pairs (pfl ! k)
    \<subseteq> additional_uf_pairs_set (l[k := pf ! k]) pfl"
  proof
    fix x assume "x \<in> additional_uf_pairs_set l pfl \<union> pending_pairs (pfl ! k)"
    then show "x \<in> additional_uf_pairs_set (l[k := pf ! k]) pfl"
    proof
      assume "x \<in> additional_uf_pairs_set l pfl"
      then obtain i where i: "x \<in> pending_pairs (pfl ! i)" "i < length l \<and> l ! i \<noteq> i"
        unfolding additional_uf_pairs_set_def by blast
      then have "l[k := pf ! k] ! i \<noteq> i" using assms
        by (metis nth_list_update_eq nth_list_update_neq)
      then show ?thesis unfolding additional_uf_pairs_set_def
        using i(1) i(2) by auto
    next
      assume "x \<in> pending_pairs (pfl ! k)"
      have "l[k := pf ! k] ! k \<noteq> k"
        using assms by simp
      then show ?thesis unfolding additional_uf_pairs_set_def
        using \<open>x \<in> pending_pairs (pfl ! k)\<close> assms(2) length_list_update mem_Collect_eq by fastforce
    qed
  qed
qed

lemma additional_uf_pairs_set_explain_along_path:
  assumes "cc_invar cc"
    "explain_list_invar l (proof_forest cc)"
    "path (proof_forest cc) c p a"
    "explain_along_path cc l a c = (output, new_l, pend)"
  shows "additional_uf_pairs_set new_l (pf_labels cc) =
additional_uf_pairs_set l (pf_labels cc) \<union> set pend"
  using assms proof(induction rule: explain_along_path_induct)
  case (One cc l a c p1 p2 x x1 x11 x12 "output" new_l pend)
  have "additional_uf_pairs_set (l[rep_of l a := x]) (pf_labels cc)
= additional_uf_pairs_set l (pf_labels cc) \<union> pending_pairs (pf_labels cc ! rep_of l a)"
    by (metis (no_types, lifting) One.hyps(3,4,5,8,9) additional_uf_pairs_set_fun_upd_l explain_list_invar_def path_nodes_lt_length_l path_root rep_of_iff rep_of_less_length_l)
  moreover have "pending_pairs (pf_labels cc ! rep_of l a) = {}"
    by (simp add: One.hyps(10))
  ultimately show ?case
    by (simp add: One.IH)
next
  case (Two cc l a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y "output" new_l pend)
  have "additional_uf_pairs_set (l[rep_of l a := x]) (pf_labels cc)
= additional_uf_pairs_set l (pf_labels cc) \<union> pending_pairs (pf_labels cc ! rep_of l a)"
    by (metis (no_types, lifting) Two.hyps(3,4,5,8,9) additional_uf_pairs_set_fun_upd_l explain_list_invar_def path_nodes_lt_length_l path_root rep_of_iff rep_of_less_length_l)
  moreover have "pending_pairs (pf_labels cc ! rep_of l a) = {(x\<^sub>1,y\<^sub>1), (x\<^sub>2, y\<^sub>2)}"
    by (simp add: Two.hyps(10-12))
  ultimately show ?case
    by (simp add: Two.IH)
qed simp

lemma additional_uf_pairs_set_explain_along_path'':
  assumes "cc_invar cc"
    "explain_list_invar l (proof_forest cc)"
    "c = lowest_common_ancestor (proof_forest cc) a b"
    "a < nr_vars cc" "b < nr_vars cc"
    "are_congruent cc (a \<approx> b)"
    "explain_along_path cc l a c = (output1, new_l, pend1)"
    "explain_along_path cc new_l a c = (output2, new_new_l, pend2)"
  shows "additional_uf_pairs_set new_new_l (pf_labels cc) =
additional_uf_pairs_set l (pf_labels cc) \<union> set pend1 \<union> set pend2"
proof-
  have "ufa_invar (proof_forest cc)" "nr_vars cc = length (proof_forest cc)"
    using assms unfolding proof_forest_invar_def same_length_invar_def
    by auto
  then obtain p1 p2 where "path (proof_forest cc) c p1 a" "path (proof_forest cc) c p2 b"
    using assms lowest_common_ancestor_correct
    by (metis are_congruent_implies_proof_forest_rep_of_eq length_explain_list_cc_list)
  then have 1: "additional_uf_pairs_set new_l (pf_labels cc) =
additional_uf_pairs_set l (pf_labels cc) \<union> set pend1"
    using additional_uf_pairs_set_explain_along_path by (simp add: assms(1) assms(2) assms(7))
  have "explain_list_invar new_l (proof_forest cc)" using assms
    by (metis explain_list_invar_explain_along_path'' length_explain_list_cc_list)
  then have "additional_uf_pairs_set new_new_l (pf_labels cc) =
additional_uf_pairs_set new_l (pf_labels cc) \<union> set pend2"
    using additional_uf_pairs_set_explain_along_path
    using \<open>path (proof_forest cc) c p1 a\<close> assms(1) assms(8) by auto
  then show ?thesis using 1
    by auto
qed

lemma additional_uf_pairs_set_explain_along_path':
  assumes "cc_invar cc"
    "explain_list_invar l (proof_forest cc)"
    "c = lowest_common_ancestor (proof_forest cc) a b"
    "explain_along_path cc l a c = (output1, new_l, pend1)"
    "explain_along_path cc new_l b c = (output2, new_new_l, pend2)"
    "a < nr_vars cc" "b < nr_vars cc"
    "are_congruent cc (a \<approx> b)"
  shows "additional_uf_pairs_set l (pf_labels cc) \<subseteq>
additional_uf_pairs_set new_new_l (pf_labels cc)"
proof-
obtain p1 p2 where paths: "path (proof_forest cc) c p1 a" "path (proof_forest cc) c p2 b"
    using assms lowest_common_ancestor_correct unfolding proof_forest_invar_def
    by (metis assms(1) explain_along_path_lowest_common_ancestor)
  have 1: "additional_uf_pairs_set l (pf_labels cc) \<subseteq> additional_uf_pairs_set new_l (pf_labels cc)"
    using additional_uf_pairs_set_explain_along_path assms paths
    by blast
  have eli: "explain_list_invar new_l (proof_forest cc)" using assms
    by (metis explain_along_path_domain explain_list_invar_explain_along_path' paths(1))
  then have  "additional_uf_pairs_set new_l (pf_labels cc)
 \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc)"
    using additional_uf_pairs_set_explain_along_path assms paths
    by blast
  then show ?thesis using 1
    by simp
qed

lemma explain_along_path_parent_eq:
  assumes "cc_invar cc"
    "explain_list_invar l (proof_forest cc)"
    "path (proof_forest cc) c p a"
  shows "explain_along_path cc l a c = explain_along_path cc l (l ! a) c"
proof(cases "l ! a = a")
  case False
  have *: "rep_of l a = rep_of l (l ! a)"
    using assms(2) assms(3) explain_list_invar_def path_nodes_lt_length_l rep_of_idx by fastforce
  then show ?thesis proof(cases "rep_of l a = rep_of l c")
    case True
    then show ?thesis using * explain_along_path_simp1
      by simp
  next
    case False': False
    have "l ! a = proof_forest cc ! a" using assms False unfolding explain_list_invar_def
      using path_nodes_lt_length_l by presburger
    then have p: "path (proof_forest cc) c (butlast p) (l ! a)"
      using False' assms(3) path_butlast by auto
    have not_none: "pf_labels cc! rep_of l a \<noteq> None" using pf_labels_explain_along_path_case_2
      using False' assms(1) assms(2) assms(3) explain_list_invar_def path_nodes_lt_length_l by auto
    define b where "b = proof_forest cc ! rep_of l a"
    obtain o_rec l_rec p_rec where rec: "explain_along_path cc (l[rep_of l a := b]) b c
= (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    then show ?thesis proof(cases "the ((pf_labels cc) ! rep_of l a)")
      case (One x1)
      have "explain_along_path cc l a c = ({x1} \<union> o_rec, l_rec, p_rec)"
        using explain_along_path_simp2 explain_along_path_domain b_def rec not_none explain_list_invar_def
        using False' One assms(1) assms(2) assms(3) by force
      moreover have "explain_along_path cc l (l ! a) c = ({x1} \<union> o_rec, l_rec, p_rec)"
        using * explain_along_path_simp2 explain_along_path_domain b_def rec not_none explain_list_invar_def
        using False' One assms(1) assms(2) p by force
      ultimately show ?thesis using * explain_along_path_simp2 explain_along_path_domain
        by argo
    next
      case (Two x21 x22)
      then obtain x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y where Some: "(pf_labels cc) ! rep_of l a =
Some (Two (F x\<^sub>1 x\<^sub>2 \<approx> x') (F y\<^sub>1 y\<^sub>2 \<approx> y))" "x\<^sub>1 < length l" "x\<^sub>2 < length l" "x' < length l"
        "y\<^sub>1 < length l" "y\<^sub>2 < length l"  "y < length l"
        using pf_labels_Two_valid assms False False' by blast
      have "explain_along_path cc l a c =
({(F x\<^sub>1 x\<^sub>2 \<approx> x'), (F y\<^sub>1 y\<^sub>2 \<approx> y)} \<union> o_rec, l_rec, [(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)] @ p_rec)"
        using explain_along_path_simp3 explain_along_path_domain b_def rec not_none explain_list_invar_def
        using False' Some assms(1) assms(2) assms(3) by force
      moreover have "explain_along_path cc l (l ! a) c =
({(F x\<^sub>1 x\<^sub>2 \<approx> x'), (F y\<^sub>1 y\<^sub>2 \<approx> y)} \<union> o_rec, l_rec, [(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)] @ p_rec)"
        using * explain_along_path_simp3 explain_along_path_domain b_def rec not_none explain_list_invar_def
        using False' Some assms(1) assms(2) p by force
      ultimately show ?thesis
        by argo
    qed
  qed
qed simp

lemma explain_along_path_explain_along_path2_pending_subseq:
  assumes "cc_invar cc"
    "path (proof_forest cc) c p a"
    "explain_along_path2 cc a c = (output2, pend2)"
    "explain_list_invar l (proof_forest cc)"
    "explain_along_path cc l a c = (output, new_l, pend)"
  shows "subseq pend pend2"
  using assms proof(induction arbitrary: l "output" new_l pend rule: explain_along_path2_induct)
  case (base cc a c p)
  then show ?case
    by (simp add: explain_along_path_simp1)
next
  case (One cc a c p1 p2 x x1 x11 x12 "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF One(14)] One(2,7) proof_forest_invar_def
      by (metis One.hyps(3) One.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def One True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "pend = p_rec"
      using explain_along_path_simp2[OF *] One(2,3,7,8,15) rec
        explain_along_path_domain[OF One(2,14,3)] True by auto
    then show ?thesis
      using One(13)[OF invar rec] by simp
  next
    case False
    then have "x = l ! a"
      by (metis (no_types, lifting) One.hyps(3) One.hyps(7) One.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    then show ?thesis
      using One.IH One.hyps(2,3) One.prems(1,2) explain_along_path_parent_eq by auto
  qed
next
  case (Two cc a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF Two(19)] Two(2,7) proof_forest_invar_def
      by (metis Two.hyps(3) Two.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def Two True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "pend = [(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)] @ p_rec"
      using explain_along_path_simp3[OF *] Two(7-) rec
        explain_along_path_domain[OF Two(2,19,3)] True
      by auto
    then show ?thesis
      using Two(18)[OF invar rec] by simp
  next
    case False
    then have "x = l ! a"
      by (metis (no_types, lifting) Two.hyps(3) Two.hyps(7) Two.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    then show ?thesis
      using Two.IH Two.hyps(2,3) Two.prems(1,2) explain_along_path_parent_eq
      by (metis list_emb_append2)
  qed
qed

lemma explain_along_path_new_l_unchanged:
  assumes "cc_invar cc"
    "explain_list_invar l (proof_forest cc)"
    "path (proof_forest cc) c p a"
    "explain_along_path cc l a c = (output, new_l, pend)"
    "l ! k \<noteq> k" "k < length l"
  shows "new_l ! k = l ! k"
  using assms proof(induction rule: explain_along_path_induct)
  case (One cc l a c p1 p2 x x1 x11 x12 "output" new_l pend)
  have "l[rep_of l a := x] ! k \<noteq> k"
    by (metis One.hyps(3,9) One.prems(1,2) explain_list_invar_def nth_list_update_eq nth_list_update_neq)
  then show ?case
    using One.IH One.hyps(3,6) One.prems(1,2) explain_list_invar_def by auto
next
  case (Two cc l a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y "output" new_l pend)
  have "l[rep_of l a := x] ! k \<noteq> k"
    by (metis Two.hyps(3,9) Two.prems(1,2) explain_list_invar_def nth_list_update_eq nth_list_update_neq)
  then show ?case
    using Two.IH Two.hyps(3,6) Two.prems(1,2) explain_list_invar_def by auto
qed blast

lemma explain_along_path_explain_along_path2_output_subset:
  assumes "cc_invar cc"
    "path (proof_forest cc) c p a"
    "explain_along_path2 cc a c = (output2, pend2)"
    "explain_list_invar l (proof_forest cc)"
    "explain_along_path cc l a c = (output, new_l, pend)"
  shows "output2 \<subseteq> additional_uf_labels_set new_l (pf_labels cc)"
  using assms proof(induction arbitrary: l "output" new_l pend rule: explain_along_path2_induct)
  case (base cc a c p)
  then show ?case
    by (simp add: explain_along_path_simp1)
next
  case (One cc a c p1 p2 x x1 x11 x12 "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF One(14)] One(2,7) proof_forest_invar_def
      by (metis One.hyps(3) One.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def One True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "output = {x1} \<union> o_rec" "new_l = l_rec"
      using explain_along_path_simp2[OF *] One rec
        explain_along_path_domain[OF One(2,14,3)] True by auto
    have IH: "output2 \<subseteq> additional_uf_labels_set l_rec (pf_labels cc)"
      using One(13) invar rec by blast
    have "length l_rec = length l" "l_rec ! a = x"
      using rec explain_along_path_new_l_length
       apply (metis One.hyps(2,3) One.prems(1,2) \<open>new_l = l_rec\<close>)
      using rec explain_along_path_new_l_unchanged
      by (smt (verit) One.hyps(2-7) One.prems(1) True explain_list_invar_def invar nth_list_update_eq path_nodes_lt_length_l path_root)
    then have "x1 \<in> pe_to_set (pf_labels cc ! a)" "a < length l_rec" "l_rec ! a \<noteq> a"
        apply (simp add: One.hyps(8))
      using One.hyps(3) One.prems(1) \<open>length l_rec = length l\<close> explain_list_invar_def path_nodes_lt_length_l apply fastforce
      using One.hyps(3,6,7) \<open>l_rec ! a = x\<close> path_root by auto
    then have "{x1} \<subseteq> additional_uf_labels_set l_rec (pf_labels cc)"
      unfolding additional_uf_labels_set_def by auto
    then show ?thesis
      using IH \<open>new_l = l_rec\<close> by simp
  next
    case False
    then have *: "x = l ! a"
      by (metis (no_types, lifting) One.hyps(3,7) One.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    have "length new_l = length l" "new_l ! a = x"
      using explain_along_path_new_l_length
       apply (metis One.hyps(2,3) One.prems(1,2))
      using * One
      by (smt (verit, del_insts) False explain_along_path_new_l_unchanged length_explain_list_cc_list path_nodes_lt_length_l rep_of_refl same_length_invar_def)
    then have "x1 \<in> pe_to_set (pf_labels cc ! a)" "a < length new_l" "new_l ! a \<noteq> a"
        apply (simp add: One.hyps(8))
      using One.hyps(3) One.prems(1) \<open>length new_l = length l\<close> explain_list_invar_def path_nodes_lt_length_l apply auto[1]
      using "*" False \<open>new_l ! a = x\<close> rep_of_refl by auto
    then have "x1 \<in> additional_uf_labels_set new_l (pf_labels cc)"
      unfolding additional_uf_labels_set_def by blast
    have "explain_along_path cc l x c = explain_along_path cc l a c"
      using "*" One.hyps(2) One.hyps(3) One.prems(1) explain_along_path_parent_eq by presburger
    then show ?thesis
      using One.IH One.hyps(2,3) One.prems(1,2) explain_along_path_parent_eq
      by (metis \<open>x1 \<in> additional_uf_labels_set new_l (pf_labels cc)\<close> insert_is_Un insert_subset)
  qed
next
  case (Two cc a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF Two(19)] Two(2,7) proof_forest_invar_def
      by (metis Two.hyps(3) Two.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def Two True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "output = {x21, x22} \<union> o_rec" "new_l = l_rec"
      using explain_along_path_simp3[OF *] Two rec
        explain_along_path_domain[OF Two(2,19,3)] True by auto
    have IH: "output2 \<subseteq> additional_uf_labels_set l_rec (pf_labels cc)"
      using Two(18) invar rec by blast
    have "length l_rec = length l" "l_rec ! a = x"
      using rec explain_along_path_new_l_length
       apply (metis Two.hyps(2,3) Two.prems(1,2) \<open>new_l = l_rec\<close>)
      using rec explain_along_path_new_l_unchanged
Two.hyps(2-7) Two.prems(1) True explain_list_invar_def invar nth_list_update_eq path_nodes_lt_length_l path_root
      by (smt (verit))
    then have "{x21, x22} \<subseteq> pe_to_set (pf_labels cc ! a)" "a < length l_rec" "l_rec ! a \<noteq> a"
        apply (simp add: Two.hyps(8))
      using Two.hyps(3) Two.prems(1) \<open>length l_rec = length l\<close> explain_list_invar_def path_nodes_lt_length_l apply fastforce
      using Two.hyps(3,6,7) \<open>l_rec ! a = x\<close> path_root by auto
    then have "{x21, x22} \<subseteq> additional_uf_labels_set l_rec (pf_labels cc)"
      unfolding additional_uf_labels_set_def by auto
    then show ?thesis
      using IH \<open>new_l = l_rec\<close> Two(9,10) by simp
  next
    case False
    then have *: "x = l ! a"
      by (metis (no_types, lifting) Two.hyps(3,7) Two.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    have "length new_l = length l" "new_l ! a = x"
      using explain_along_path_new_l_length
       apply (metis Two.hyps(2,3) Two.prems(1,2))
      using * Two False explain_along_path_new_l_unchanged length_explain_list_cc_list path_nodes_lt_length_l rep_of_refl same_length_invar_def
      by (smt (verit, del_insts))
    then have "{x21, x22} \<subseteq> pe_to_set (pf_labels cc ! a)" "a < length new_l" "new_l ! a \<noteq> a"
        apply (simp add: Two.hyps(8))
      using Two.hyps(3) Two.prems(1) \<open>length new_l = length l\<close> explain_list_invar_def path_nodes_lt_length_l apply auto[1]
      using "*" False \<open>new_l ! a = x\<close> rep_of_refl by auto
    then have "{x21, x22} \<subseteq> additional_uf_labels_set new_l (pf_labels cc)"
      unfolding additional_uf_labels_set_def by blast
    have "explain_along_path cc l x c = explain_along_path cc l a c"
      using "*" Two.hyps(2,3) Two.prems(1) explain_along_path_parent_eq by presburger
    then show ?thesis
      using Two.IH Two.hyps(2,3) Two.prems(1,2) explain_along_path_parent_eq Two(9,10)
      by (metis Un_least \<open>{x21, x22} \<subseteq> additional_uf_labels_set new_l (pf_labels cc)\<close>)
  qed
qed

lemma explain_along_path_explain_along_path2_output_subset':
  assumes "cc_invar cc"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . a < nr_vars cc \<and> b < nr_vars cc"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . are_congruent cc (a \<approx> b)"
    "c = lowest_common_ancestor (proof_forest cc) a b"
    "explain_along_path cc l a c = (output1, new_l, pending1)"
    "explain_along_path cc new_l b c = (output2, new_new_l, pending2)"
    "explain_list_invar l (proof_forest cc)"
    "explain_along_path2 cc a c = (output12, pending12)"
    "explain_along_path2 cc b c = (output22, pending22)"
       shows "output12 \<union> output22 \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc)"
proof-
  obtain p1 p2 where paths: "path (proof_forest cc) c p1 a" "path (proof_forest cc) c p2 b"
    using assms lowest_common_ancestor_correct unfolding proof_forest_invar_def
    by (metis assms(1) case_prod_conv explain_along_path_lowest_common_ancestor list.set_intros(1))
  have 1: "output12 \<subseteq> additional_uf_labels_set new_l (pf_labels cc)"
    using explain_along_path_explain_along_path2_output_subset assms paths
    by metis
  have eli: "explain_list_invar new_l (proof_forest cc)" using assms
    by (metis explain_along_path_domain explain_list_invar_explain_along_path' paths(1))
  then have 2: "output22 \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc)"
    using explain_along_path_explain_along_path2_output_subset assms paths
    by metis
  have 3: "additional_uf_labels_set new_l (pf_labels cc) \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc)"
    using assms additional_uf_labels_set_explain_along_path eli paths
    by (metis Un_upper1)
  then show ?thesis using 1 2 3
    by simp
qed

lemma explain_along_path_explain_along_path2_pending_subset:
  assumes "cc_invar cc"
    "path (proof_forest cc) c p a"
    "explain_along_path2 cc a c = (output2, pend2)"
    "explain_list_invar l (proof_forest cc)"
    "explain_along_path cc l a c = (output, new_l, pend)"
  shows "set pend2 \<subseteq> additional_uf_pairs_set new_l (pf_labels cc)"
  using assms proof(induction arbitrary: l "output" new_l pend rule: explain_along_path2_induct)
  case (base cc a c p)
  then show ?case
    by (simp add: explain_along_path_simp1)
next
  case (One cc a c p1 p2 x x1 x11 x12 "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF One(14)] One(2,7) proof_forest_invar_def
      by (metis One.hyps(3) One.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def One True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "new_l = l_rec"
      using explain_along_path_simp2[OF *] One rec
        explain_along_path_domain[OF One(2,14,3)] True by auto
    have IH: "set pend2 \<subseteq> additional_uf_pairs_set l_rec (pf_labels cc)"
      using One(13) invar rec by blast
    show ?thesis
      using IH \<open>new_l = l_rec\<close> by simp
  next
    case False
    then have *: "x = l ! a"
      by (metis (no_types, lifting) One.hyps(3,7) One.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    then have "explain_along_path cc l x c = explain_along_path cc l a c"
      using One.hyps(2) One.hyps(3) One.prems(1) explain_along_path_parent_eq by presburger
    then show ?thesis
      using One.IH One.hyps(2,3) One.prems(1,2) explain_along_path_parent_eq
      by metis
  qed
next
  case (Two cc a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF Two(19)] Two(2,7) proof_forest_invar_def
      by (metis Two.hyps(3) Two.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def Two True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "new_l = l_rec" "pend = [(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)] @ p_rec"
      using explain_along_path_simp3[OF *] Two rec
        explain_along_path_domain[OF Two(2,19,3)] True by auto
    have IH: "set pend2 \<subseteq> additional_uf_pairs_set l_rec (pf_labels cc)"
      using Two(18) invar rec by blast
    have "length l_rec = length l" "l_rec ! a = x" "{(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)} \<subseteq> pending_pairs (pf_labels cc ! a)"
      using rec explain_along_path_new_l_length
        apply (metis Two.hyps(2,3) Two.prems(1,2) \<open>new_l = l_rec\<close>)
      using rec explain_along_path_new_l_unchanged
       apply (smt (verit) Two.hyps(2-7) Two.prems(1) True explain_list_invar_def invar nth_list_update_eq path_nodes_lt_length_l path_root)
      by (simp add: Two.hyps(8-10))
    then have "{(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)} \<subseteq> additional_uf_pairs_set l_rec (pf_labels cc)"
      unfolding additional_uf_pairs_set_def
      by (smt (verit, del_insts) Sup_upper2 True Two.hyps(3) Two.hyps(6) Two.hyps(7) Two.hyps(8) \<open>new_l = l_rec\<close> explain_list_invar_def insert_Collect invar length_list_update mem_Collect_eq path_no_root path_nodes_lt_length_l singleton_conv)
    then show ?thesis
      using IH \<open>new_l = l_rec\<close> by simp
  next
    case False
    then have *: "x = l ! a"
      by (metis (no_types, lifting) Two.hyps(3,7) Two.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    have "length new_l = length l" "new_l ! a = x"
      using explain_along_path_new_l_length
       apply (metis Two.hyps(2,3) Two.prems(1,2))
      using * Two
      by (smt (verit, del_insts) False explain_along_path_new_l_unchanged length_explain_list_cc_list path_nodes_lt_length_l rep_of_refl same_length_invar_def)
    then have "{(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)} \<subseteq> pending_pairs (pf_labels cc ! a)" "a < length new_l" "new_l ! a \<noteq> a"
        apply (simp add: Two.hyps(8-10))
      using Two.hyps(3) Two.prems(1) \<open>length new_l = length l\<close> explain_list_invar_def path_nodes_lt_length_l apply auto[1]
      using "*" False \<open>new_l ! a = x\<close> rep_of_refl by auto
    then have "{(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)} \<subseteq> additional_uf_pairs_set new_l (pf_labels cc)"
      unfolding additional_uf_pairs_set_def by blast
    have "explain_along_path cc l x c = explain_along_path cc l a c"
      using "*" Two.hyps(2,3) Two.prems(1) explain_along_path_parent_eq by presburger
    then show ?thesis
      using Two.IH Two.hyps(2,3) Two.prems(1,2) explain_along_path_parent_eq Two(9,10)
      using \<open>{(x\<^sub>1, y\<^sub>1), (x\<^sub>2, y\<^sub>2)} \<subseteq> additional_uf_pairs_set new_l (pf_labels cc)\<close> by auto
  qed
qed

lemma explain_along_path_explain_along_path2_pending_subset':
  assumes "cc_invar cc"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . a < nr_vars cc \<and> b < nr_vars cc"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . are_congruent cc (a \<approx> b)"
    "c = lowest_common_ancestor (proof_forest cc) a b"
    "explain_along_path cc l a c = (output1, new_l, pending1)"
    "explain_along_path cc new_l b c = (output2, new_new_l, pending2)"
    "equations_of_l_in_pending_invar3 cc l ((a, b) # xs)"
    "explain_list_invar l (proof_forest cc)"
    "explain_along_path2 cc a c = (output12, pending12)"
    "explain_along_path2 cc b c = (output22, pending22)"
  shows "set pending12 \<union> set pending22 \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc)"
proof-
  obtain p1 p2 where paths: "path (proof_forest cc) c p1 a" "path (proof_forest cc) c p2 b"
    using assms lowest_common_ancestor_correct unfolding proof_forest_invar_def
    by (metis assms(1) case_prod_conv explain_along_path_lowest_common_ancestor list.set_intros(1))
  have 1: "set pending12 \<subseteq> additional_uf_pairs_set new_l (pf_labels cc)"
    using explain_along_path_explain_along_path2_pending_subset assms paths
    by metis
  have eli: "explain_list_invar new_l (proof_forest cc)" using assms
    by (metis explain_along_path_domain explain_list_invar_explain_along_path' paths(1))
  then have 2: "set pending22 \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc)"
    using explain_along_path_explain_along_path2_pending_subset assms paths
    by metis
  have 3: "additional_uf_pairs_set new_l (pf_labels cc) \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc)"
    using assms eli paths additional_uf_pairs_set_explain_along_path
    by (metis Un_upper1)
  then show ?thesis using 1 2 3
    by simp
qed

lemma explain_along_path_new_new_l_same_length:
  assumes "cc_invar cc"
    "c = lowest_common_ancestor (proof_forest cc) a b"
    "(output1, new_l, pending1) = explain_along_path cc l a c"
    "(output2, new_new_l, pending2) = explain_along_path cc new_l b c"
    "explain_list_invar l (proof_forest cc)"
    "a < nr_vars cc" "b < nr_vars cc"
    "are_congruent cc (a \<approx> b)"
  shows "length l = length new_new_l"
proof-
  obtain p1 p2 where paths: "path (proof_forest cc) c p1 a" "path (proof_forest cc) c p2 b"
    using assms lowest_common_ancestor_correct unfolding proof_forest_invar_def
    same_length_invar_def
    by (metis assms(1) explain_along_path_lowest_common_ancestor)
  with explain_along_path_new_l_length have "length l = length new_l"
    by (metis assms(1) assms(3) assms(5))
  have eli: "explain_list_invar new_l (proof_forest cc)" using assms
    by (metis explain_along_path_domain explain_list_invar_explain_along_path' paths(1))
  then show ?thesis using explain_along_path_new_l_length
    by (metis \<open>length l = length new_l\<close> assms(1) assms(4) paths(2))
qed

lemma explain_along_path_explain_along_path2_output_supset:
  assumes "cc_invar cc"
    "path (proof_forest cc) c p a"
    "explain_along_path2 cc a c = (output2, pend2)"
    "explain_list_invar l (proof_forest cc)"
    "explain_along_path cc l a c = (output, new_l, pend)"
  shows "output2 \<supseteq> output"
  using assms proof(induction arbitrary: l "output" new_l pend rule: explain_along_path2_induct)
  case (base cc a c p)
  then show ?case
    by (simp add: explain_along_path_simp1)
next
  case (One cc a c p1 p2 x x1 x11 x12 "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF One(14)] One(2,7) proof_forest_invar_def
      by (metis One.hyps(3) One.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def One True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "output = {x1} \<union> o_rec"
      using explain_along_path_simp2[OF *] One rec
        explain_along_path_domain[OF One(2,14,3)] True by simp
    have IH: "output2 \<supseteq> o_rec"
      using One(13) invar rec by blast
    show ?thesis
      using IH \<open>output = {x1} \<union> o_rec\<close> by auto
  next
    case False
    then have "x = l ! a"
      by (metis (no_types, lifting) One.hyps(3,7) One.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    then have "explain_along_path cc l x c = explain_along_path cc l a c"
      using One.hyps(2) One.hyps(3) One.prems(1) explain_along_path_parent_eq by presburger
    then show ?thesis
      using One.IH One.hyps(2,3) One.prems(1,2) explain_along_path_parent_eq
      by (metis Un_insert_left insert_iff subsetI subset_trans sup_bot_left)
  qed
next
  case (Two cc a c p1 p2 x x21 x22 x\<^sub>1 x\<^sub>2 x' y\<^sub>1 y\<^sub>2 y "output2" pend2)
  then show ?case
  proof(cases "a = rep_of l a")
    case True
    obtain o_rec l_rec p_rec where
      rec: "explain_along_path cc (l[rep_of l a := x]) x c = (o_rec, l_rec, p_rec)"
      using prod_cases3 by blast
    have invar: "explain_list_invar (l[rep_of l a := x]) (proof_forest cc)"
      using explain_list_invar_step[OF Two(19)] Two(2,7) proof_forest_invar_def
      by (metis Two.hyps(3) Two.prems(1) True explain_list_invar_def path_nodes_lt_length_l)
    have *: "rep_of l a \<noteq> rep_of l c" using explain_list_invar_def Two True
      by (metis path_nodes_lt_length_l path_pf_same_rep path_root proof_forest_invar_def rep_of_root)
    have "output = {x21, x22} \<union> o_rec"
      using explain_along_path_simp3[OF *] Two rec
        explain_along_path_domain[OF Two(2,19,3)] True by simp
    have IH: "output2 \<supseteq> o_rec"
      using Two(18) invar rec by blast
    then show ?thesis
      using IH \<open>output = {x21, x22} \<union> o_rec\<close> Two(9,10) by blast
  next
    case False
    then have "x = l ! a"
      by (metis (no_types, lifting) Two.hyps(3,7) Two.prems(1) explain_list_invar_def path_nodes_lt_length_l rep_of_refl)
    then have "explain_along_path cc l x c = explain_along_path cc l a c"
      using Two.hyps(2,3) Two.prems(1) explain_along_path_parent_eq by presburger
    then show ?thesis
      using Two.IH Two.hyps(2,3) Two.prems(1,2) explain_along_path_parent_eq Two(9,10)
      by (metis le_supI2)
  qed
qed

lemma explain_along_path2_pending:
  assumes "cc_invar cc"
    "explain_along_path2 cc a c = (output, pend)"
    "path (proof_forest cc) c pAC a"
  shows "\<forall>x \<in> pending_set_explain pend. are_congruent cc x"
proof-
  have "explain_along_path2_dom (cc, a, c)"
    using explain_along_path2_domain assms by blast
  then show ?thesis
    using assms proof(induction arbitrary: pend "output" pAC
      rule: explain_along_path2.pinduct)
    case (1 cc a c)
    then show ?case proof(cases "a = c")
      case True
      then have "pend = []"
        using "1.prems"(2) explain_along_path2_simp1 by fastforce
      then show ?thesis by simp
    next
      case False
      define b where "b = proof_forest cc ! a"
      then have p2: "path (proof_forest cc) c (butlast pAC) b"
        using "1.prems"(3) False path_butlast by blast
      obtain aa a\<^sub>1 a\<^sub>2 bb b\<^sub>1 b\<^sub>2 where valid_eq: "
          (pf_labels cc ! a = Some (One (aa \<approx> bb)) \<or>
          pf_labels cc ! a = Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> aa) (F b\<^sub>1 b\<^sub>2 \<approx> bb)))
          \<and> (aa = proof_forest cc ! a \<and> bb = a \<or> aa = a \<and> bb = proof_forest cc ! a)"
        using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
        by (metis False b_def path_nodes_lt_length_l path_root)
      have "(pf_labels cc ! a) \<noteq> None"
        by (metis "1.prems"(1) "1.prems"(3) False b_def option.discI path_nodes_lt_length_l path_root pf_labels_invar_def)
      obtain pend_rec output_rec where
        rec: "explain_along_path2 cc b c = (output_rec, pend_rec)"
        by fastforce
      then show ?thesis
      proof(cases "the (pf_labels cc ! a)")
        case (One x1)
        then have *: "\<forall>a\<in>pending_set_explain pend_rec. are_congruent cc a"
          using 1(2) False One b_def p2 1(4) rec by blast
        then have "pend = pend_rec"
          using One explain_along_path2_simp2 explain_along_path_domain
          using "1.hyps" "1.prems"(2) False rec \<open>pf_labels cc ! a \<noteq> None\<close> b_def by force
        then show ?thesis using *
          by blast
      next
        case (Two x21 x22)
        then obtain a\<^sub>1 a\<^sub>2 a' b\<^sub>1 b\<^sub>2 b' where **: "(pf_labels cc ! a)
= Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b'))"
          by (metis option.sel pending_equation.distinct(1) valid_eq)
        then have *: "\<forall>a\<in>pending_set_explain pend_rec. are_congruent cc a"
          using 1(3) False Two b_def p2 1(4) rec
          by (metis option.sel)
        then have pend: "pend = [(a\<^sub>1, b\<^sub>1), (a\<^sub>2, b\<^sub>2)] @ pend_rec"
          using Two explain_along_path2_simp3[OF False **] explain_along_path_domain
          using "1.hyps" "1.prems"(2) False rec \<open>pf_labels cc ! a \<noteq> None\<close> b_def rec by simp
        have "rep_of (cc_list cc) a\<^sub>1 = rep_of (cc_list cc) b\<^sub>1"
          "rep_of (cc_list cc) a\<^sub>2 = rep_of (cc_list cc) b\<^sub>2"
          using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
           apply (metis "**" False option.sel path_no_root path_nodes_lt_length_l valid_vars_pending.simps(2))
          using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
          by (metis "**" False option.sel path_no_root path_nodes_lt_length_l valid_vars_pending.simps(2))
        then have "are_congruent cc (a\<^sub>1 \<approx> b\<^sub>1)" "are_congruent cc (a\<^sub>2 \<approx> b\<^sub>2)"
          by (metis (full_types) are_congruent.simps(1) congruence_closure.cases congruence_closure.select_convs(1))+
        then show ?thesis
          using * pend by simp
      qed
    qed
  qed
qed

lemma pending_set_explain_set:
  "(a, b) \<in> set xs \<longleftrightarrow> (a \<approx> b) \<in> pending_set_explain xs"
proof
  show "(a, b) \<in> set xs \<Longrightarrow> (a \<approx> b) \<in> pending_set_explain xs"
  proof-
    assume "(a, b) \<in> set xs"
    then obtain i where i: "xs ! i = (a, b)" "i < length xs"
      using in_set_conv_nth by metis
    then have "(map (\<lambda>(a, b) . (a \<approx> b)) xs) ! i = (a \<approx> b)"
      by simp
    then have "(a \<approx> b) \<in> set (map (\<lambda>(a, b) . (a \<approx> b)) xs)"
      using i by (metis length_map nth_mem)
    then show ?thesis
      by force
  qed
  show "(a \<approx> b) \<in> pending_set_explain xs \<Longrightarrow> (a, b) \<in> set xs"
  proof-
    assume "(a \<approx> b) \<in> pending_set_explain xs"
    then obtain i where i: "(map (\<lambda>(a, b) . (a \<approx> b)) xs) ! i = (a \<approx> b)"
      "i < length (map (\<lambda>(a, b) . (a \<approx> b)) xs)"
      using in_set_conv_nth by (metis pending_set_explain.simps)
    then have "xs ! i = (a, b)"
      by (metis equation.inject(1) length_map nth_map prod.collapse split_beta)
    then have "(a \<approx> b) \<in> set (map (\<lambda>(a, b) . (a \<approx> b)) xs)"
      using i by (metis length_map nth_mem)
    then show ?thesis
      by force
  qed
qed

lemma explain_along_path2_pending':
  assumes "cc_invar cc"
    "explain_along_path2 cc a c = (output, pend)"
    "explain_along_path2 cc b c = (output2, pend2)"
    "path (proof_forest cc) c pAC a"
    "path (proof_forest cc) c pBC b"
  shows "\<forall>(a, b) \<in> set (pend @ pend2). are_congruent cc (a \<approx> b)"
proof
  fix x assume "x \<in> set (pend @ pend2)"
  obtain a' b' where x: "x = (a', b')"
    using prod_decode_aux.cases by blast
  then have in_pend_set: "(a' \<approx> b') \<in> pending_set_explain (pend @ pend2)"
    by (metis \<open>x \<in> set (pend @ pend2)\<close> pending_set_explain_set)
  then have "\<forall>x \<in> pending_set_explain (pend @ pend2) . are_congruent cc x"
    using assms explain_along_path2_pending
    by fastforce
  then have "are_congruent cc (a' \<approx> b')"
    using in_pend_set by blast
  then show "case x of (a, b) \<Rightarrow> are_congruent cc (a \<approx> b)"
    by (simp add: x)
qed

lemma explain_along_path2_pending_in_bounds:
  assumes "cc_invar cc"
    "explain_along_path2 cc a c = (output, pend)"
    "path (proof_forest cc) c pAC a"
  shows "\<forall>(a,b)\<in>set pend. a < nr_vars cc \<and> b < nr_vars cc"
proof-
  have "explain_along_path2_dom (cc, a, c)"
    using explain_along_path2_domain assms by blast
  then show ?thesis
    using assms proof(induction arbitrary: pend "output" pAC
      rule: explain_along_path2.pinduct)
    case (1 cc a c)
    then show ?case proof(cases "a = c")
      case True
      then have "pend = []"
        using "1.prems"(2) explain_along_path2_simp1 by fastforce
      then show ?thesis by simp
    next
      case False
      define b where "b = proof_forest cc ! a"
      then have p2: "path (proof_forest cc) c (butlast pAC) b"
        using "1.prems"(3) False path_butlast by blast
      obtain aa a\<^sub>1 a\<^sub>2 bb b\<^sub>1 b\<^sub>2 where valid_eq: "
          (pf_labels cc ! a = Some (One (aa \<approx> bb)) \<or>
          pf_labels cc ! a = Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> aa) (F b\<^sub>1 b\<^sub>2 \<approx> bb)))
          \<and> (aa = proof_forest cc ! a \<and> bb = a \<or> aa = a \<and> bb = proof_forest cc ! a)"
        using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
        by (metis False b_def path_nodes_lt_length_l path_root)
      have "(pf_labels cc ! a) \<noteq> None"
        by (metis "1.prems"(1) "1.prems"(3) False b_def option.discI path_nodes_lt_length_l path_root pf_labels_invar_def)
      obtain pend_rec output_rec where
        rec: "explain_along_path2 cc b c = (output_rec, pend_rec)"
        by fastforce
      then show ?thesis
      proof(cases "the (pf_labels cc ! a)")
        case (One x1)
        then have *: "\<forall>(a,b)\<in>set pend_rec. a < nr_vars cc \<and> b < nr_vars cc"
          using 1(2) False One b_def p2 1(4) rec by blast
        then have "pend = pend_rec"
          using One explain_along_path2_simp2 explain_along_path_domain
          using "1.hyps" "1.prems"(2) False rec \<open>pf_labels cc ! a \<noteq> None\<close> b_def by force
        then show ?thesis using *
          by blast
      next
        case (Two x21 x22)
        then obtain a\<^sub>1 a\<^sub>2 a' b\<^sub>1 b\<^sub>2 b' where **: "(pf_labels cc ! a)
= Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b'))"
          by (metis option.sel pending_equation.distinct(1) valid_eq)
        then have *: "\<forall>(a,b)\<in>set pend_rec. a < nr_vars cc \<and> b < nr_vars cc"
          using 1(3) False Two b_def p2 1(4) rec
          by (metis option.sel)
        then have pend: "pend = [(a\<^sub>1, b\<^sub>1), (a\<^sub>2, b\<^sub>2)] @ pend_rec"
          using Two explain_along_path2_simp3[OF False **] explain_along_path_domain
          using "1.hyps" "1.prems"(2) False rec \<open>pf_labels cc ! a \<noteq> None\<close> b_def rec by simp
        then have "a\<^sub>1 < nr_vars cc" "a\<^sub>2 < nr_vars cc" "b\<^sub>1 < nr_vars cc" "b\<^sub>2 < nr_vars cc"
          using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
          by (metis "**" False option.sel path_nodes_lt_length_l path_root valid_vars.simps(2) valid_vars_pending.simps(2))+
        then show ?thesis
          using * pend by simp
      qed
    qed
  qed
qed

lemma explain_along_path2_pending_are_congruent:
  assumes "cc_invar cc"
    "explain_along_path2 cc a c = (output, pend)"
    "path (proof_forest cc) c pAC a"
  shows "\<forall>(a,b)\<in>set pend. are_congruent cc (a \<approx> b)"
proof-
  have "explain_along_path2_dom (cc, a, c)"
    using explain_along_path2_domain assms by blast
  then show ?thesis
    using assms proof(induction arbitrary: pend "output" pAC
      rule: explain_along_path2.pinduct)
    case (1 cc a c)
    then show ?case proof(cases "a = c")
      case True
      then have "pend = []"
        using "1.prems"(2) explain_along_path2_simp1 by fastforce
      then show ?thesis by simp
    next
      case False
      define b where "b = proof_forest cc ! a"
      then have p2: "path (proof_forest cc) c (butlast pAC) b"
        using "1.prems"(3) False path_butlast by blast
      obtain aa a\<^sub>1 a\<^sub>2 bb b\<^sub>1 b\<^sub>2 where valid_eq: "
          (pf_labels cc ! a = Some (One (aa \<approx> bb)) \<or>
          pf_labels cc ! a = Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> aa) (F b\<^sub>1 b\<^sub>2 \<approx> bb)))
          \<and> (aa = proof_forest cc ! a \<and> bb = a \<or> aa = a \<and> bb = proof_forest cc ! a)"
        using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
        by (metis False b_def path_nodes_lt_length_l path_root)
      have "(pf_labels cc ! a) \<noteq> None"
        by (metis "1.prems"(1) "1.prems"(3) False b_def option.discI path_nodes_lt_length_l path_root pf_labels_invar_def)
      obtain pend_rec output_rec where
        rec: "explain_along_path2 cc b c = (output_rec, pend_rec)"
        by fastforce
      then show ?thesis
      proof(cases "the (pf_labels cc ! a)")
        case (One x1)
        then have *: "\<forall>(a,b)\<in>set pend_rec. are_congruent cc (a \<approx> b)"
          using 1(2) False One b_def p2 1(4) rec by blast
        then have "pend = pend_rec"
          using One explain_along_path2_simp2 explain_along_path_domain
          using "1.hyps" "1.prems"(2) False rec \<open>pf_labels cc ! a \<noteq> None\<close> b_def by force
        then show ?thesis using *
          by blast
      next
        case (Two x21 x22)
        then obtain a\<^sub>1 a\<^sub>2 a' b\<^sub>1 b\<^sub>2 b' where **: "(pf_labels cc ! a)
= Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b'))"
          by (metis option.sel pending_equation.distinct(1) valid_eq)
        then have *: "\<forall>(a,b)\<in>set pend_rec. are_congruent cc (a \<approx> b)"
          using 1(3) False Two b_def p2 1(4) rec
          by (metis option.sel)
        then have pend: "pend = [(a\<^sub>1, b\<^sub>1), (a\<^sub>2, b\<^sub>2)] @ pend_rec"
          using Two explain_along_path2_simp3[OF False **] explain_along_path_domain
          using "1.hyps" "1.prems"(2) False rec \<open>pf_labels cc ! a \<noteq> None\<close> b_def rec by simp
        then have "are_congruent cc (a\<^sub>1 \<approx> b\<^sub>1)" "are_congruent cc (a\<^sub>2 \<approx> b\<^sub>2)"
          using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
          by (metis "**" False are_congruent_simp option.sel path_no_root path_nodes_lt_length_l valid_vars_pending.simps(2))+
        then show ?thesis
          using * pend by auto
      qed
    qed
  qed
qed

end


(*File: Reachability.thy
  Author: L Beringer & M Hofmann, LMU Munich
  Date: 05/12/2008
  Purpose: Operational judgement that extends MultiStep by
           entering subframes. Necessary for the interpretation
           of invariants.
*)
(*<*)
theory Reachability imports Language begin
(*>*)

subsection{*Reachability relation*}

text{*The second auxiliary operational judgement is required for the
interpretation of invariants and method invariants. Invariants are
expected to be satisfied in all heap components of (future) states
that occur either in the same frame as the current state or a subframe
thereof. Likewise, method invariants are expected to be satisfied by
all heap components of states observed during the execution of a
method, including subframes. None of the previous three operational
judgements allows us to express these interpretations, as @{text Step}
injects the execution of an invoked method as a single step. Thus,
states occurring in subframes cannot be related to states occuring in
the parent frame using these judgements. This motivates the
introduction of predicates relating states $s$ and $t$ whenever the
latter can be reach from the former, i.e.~whenever $t$ occurs as a
successor of $s$ in the same frame as $s$ or one of its
subframes. Again, we first define a relation that includes an explicit
derivation height index.*}

inductive_set
  Reachable::"(Mbody \<times> Label \<times> State \<times> nat \<times> State) set"
where
Reachable_zero: "\<lbrakk>k=0; t=s\<rbrakk> \<Longrightarrow> (M,l,s,k,t):Reachable"
|
Reachable_step:
  "\<lbrakk> (M,l,s,n,ll,r):Step; (M,ll,r,m,t):Reachable; k=Suc m+n\<rbrakk>
  \<Longrightarrow> (M,l,s,k,t) : Reachable"
|
Reachable_invS:
  "\<lbrakk> mbody_is C m (par,code,l0); get_ins M l = Some (invokeS C m);
      s = (ops,S,h); (ops,par,R,ops1):Frame;
     ((par,code,l0), l0, ([],R,h), n, t):Reachable; k=Suc n\<rbrakk>
  \<Longrightarrow> (M,l,s,k,t) : Reachable"

text{*The following properties of are useful to notice.*}
(*<*)
lemma ZeroHeightReachableElimAux[rule_format]:
  "(M, l, s, k, r) \<in> Reachable \<Longrightarrow> 0=k \<longrightarrow> r=s"
by (erule Reachable.induct, simp_all)
(*>*)
lemma ZeroHeightReachableElim: "(M,l,s,0,r) \<in> Reachable \<Longrightarrow> r=s"
(*<*)
by (erule ZeroHeightReachableElimAux, simp)
(*>*)

lemma ReachableSplit[rule_format]:
  "(M, l,s, k, t) \<in> Reachable \<Longrightarrow>
    1 \<le> k \<longrightarrow>
   ((\<exists> n m r ll. (M,l,s,n,ll,r):Step \<and>
                 (M,ll,r,m,t):Reachable \<and> Suc m +n =k) \<or>
    (\<exists> n ops S h c m par R ops1 code l0.
          s=(ops,S,h) \<and> get_ins M l = Some (invokeS c m) \<and>
          mbody_is c m (par,code,l0) \<and> (ops,par,R,ops1):Frame \<and>
          ((par,code,l0), l0, ([],R,h), n, t):Reachable \<and> Suc n = k))"
(*<*)
apply (erule Reachable.induct, simp_all)
apply clarsimp
  apply (case_tac m, clarsimp)
    apply (drule ZeroHeightReachableElim[simplified], clarsimp)
      apply (rule, rule,rule, rule,rule, rule, rule, assumption)
      apply (rule,rule Reachable_zero) apply simp apply simp apply simp
  apply clarsimp
    apply (rule, rule,rule, rule,rule, rule,rule,assumption) apply (rule,assumption)
    apply simp
apply (rule disjI2)
apply fast
done
(*>*)

lemma Reachable_returnElim[rule_format]:
"(M,l,s,k,t) \<in> Reachable \<Longrightarrow> get_ins M l = Some vreturn \<longrightarrow> t=s"
(*<*)
apply (erule Reachable.induct)
apply clarsimp
apply clarsimp apply (drule RetElim1) apply simp apply clarsimp
apply clarsimp
done
(*>*)

text{*Similar to the operational semantics, we define a variation of
the reachability relation that hides the index.*}

definition Reach::"Mbody \<Rightarrow> Label \<Rightarrow> State \<Rightarrow> State \<Rightarrow> bool"
where "Reach M l s t = (\<exists> k . (M,l,s,k,t):Reachable)"

(*<*)
end
(*>*)


section \<open>\isaheader{Iterator by get and size }\<close>
theory Idx_Iterator
imports
  SetIterator
  "../../Automatic_Refinement/Automatic_Refinement"
begin

fun idx_iteratei_aux
  :: "('s \<Rightarrow> nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('a \<Rightarrow>'\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
where
  "idx_iteratei_aux get sz i l c f \<sigma> = (
    if i=0 \<or> \<not> c \<sigma> then \<sigma>
    else idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)
  )"

declare idx_iteratei_aux.simps[simp del]

lemma idx_iteratei_aux_simps[simp]:
  "i=0 \<Longrightarrow> idx_iteratei_aux get sz i l c f \<sigma> = \<sigma>"
  "\<not>c \<sigma> \<Longrightarrow> idx_iteratei_aux get sz i l c f \<sigma> = \<sigma>"
  "\<lbrakk>i\<noteq>0; c \<sigma>\<rbrakk> \<Longrightarrow> idx_iteratei_aux get sz i l c f \<sigma> = idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)"
  apply -
  apply (subst idx_iteratei_aux.simps, simp)+
  done

definition "idx_iteratei get sz l c f \<sigma> == idx_iteratei_aux get (sz l) (sz l) l c f \<sigma>"

lemma idx_iteratei_eq_foldli:
  assumes sz: "(sz, length) \<in> arel \<rightarrow> nat_rel"
  assumes get: "(get, (!)) \<in> arel \<rightarrow> nat_rel \<rightarrow> Id"
  assumes "(s,s') \<in> arel"
  shows "(idx_iteratei get sz s, foldli s') \<in> Id"
proof-
  have size_correct: "\<And>s s'. (s,s') \<in> arel \<Longrightarrow> sz s = length s'"
      using sz[param_fo] by simp
  have get_correct: "\<And>s s' n. (s,s') \<in> arel \<Longrightarrow> get s n = s' ! n"
      using get[param_fo] by simp
  {
    fix n l
    assume A: "Suc n \<le> length l"
    hence B: "length l - Suc n < length l" by simp
    from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
    from Cons_nth_drop_Suc[OF B, simplified] have
      "drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l"
      by simp
  } note drop_aux=this

  {
    fix s s' c f \<sigma> i
    assume "(s,s') \<in> arel" "i\<le>sz s"
    hence "idx_iteratei_aux get (sz s) i s c f \<sigma> = foldli (drop (sz s - i) s') c f \<sigma>"
    proof (induct i arbitrary: \<sigma>)
      case 0 with size_correct[of s] show ?case by simp
    next
      case (Suc n)
      note S = Suc.prems(1)
      show ?case proof (cases "c \<sigma>")
        case False thus ?thesis by simp
      next
        case [simp, intro!]: True
        show ?thesis using Suc
            by (simp add: size_correct[OF S] get_correct[OF S] drop_aux)
      qed
    qed
  } note aux=this

  show ?thesis
    unfolding idx_iteratei_def[abs_def]
    by (simp, intro ext, simp add: aux[OF \<open>(s,s') \<in> arel\<close>])
qed

text \<open>Misc.\<close>

lemma idx_iteratei_aux_nth_conv_foldli_drop:
  fixes xs :: "'b list"
  assumes "i \<le> length xs"
  shows "idx_iteratei_aux (!) (length xs) i xs c f \<sigma> = foldli (drop (length xs - i) xs) c f \<sigma>"
using assms
proof(induct get\<equiv>"(!) :: 'b list \<Rightarrow> nat \<Rightarrow> 'b" sz\<equiv>"length xs" i xs c f \<sigma> rule: idx_iteratei_aux.induct)
  case (1 i l c f \<sigma>)
  show ?case
  proof(cases "i = 0 \<or> \<not> c \<sigma>")
    case True thus ?thesis
      by(subst idx_iteratei_aux.simps)(auto)
  next
    case False
    hence i: "i > 0" and c: "c \<sigma>" by auto
    hence "idx_iteratei_aux (!) (length l) i l c f \<sigma> = idx_iteratei_aux (!) (length l) (i - 1) l c f (f (l ! (length l - i)) \<sigma>)"
      by(subst idx_iteratei_aux.simps) simp
    also have "\<dots> = foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) \<sigma>)"
      using \<open>i \<le> length l\<close> i c by -(rule 1, auto)
    also from \<open>i \<le> length l\<close> i
    have "drop (length l - i) l = (l ! (length l - i)) # drop (length l - (i - 1)) l"
      apply (subst Cons_nth_drop_Suc[symmetric])
      apply simp_all
      done
    hence "foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) \<sigma>) = foldli (drop (length l - i) l) c f \<sigma>"
      using c by simp
    finally show ?thesis .
  qed
qed

lemma idx_iteratei_nth_length_conv_foldli: "idx_iteratei nth length = foldli"
by(rule ext)+(simp add: idx_iteratei_def idx_iteratei_aux_nth_conv_foldli_drop)
end


(*  Title:      HOL/BNF_Greatest_Fixpoint.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Lorenz Panny, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Greatest fixpoint (codatatype) operation on bounded natural functors.
*)

section \<open>Greatest Fixpoint (Codatatype) Operation on Bounded Natural Functors\<close>

theory BNF_Greatest_Fixpoint
imports BNF_Fixpoint_Base String
keywords
  "codatatype" :: thy_decl and
  "primcorecursive" :: thy_goal and
  "primcorec" :: thy_decl
begin

setup \<open>Sign.const_alias @{binding proj} @{const_name Equiv_Relations.proj}\<close>

lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases s) auto

lemma not_TrueE: "\<not> True \<Longrightarrow> P"
  by (erule notE, rule TrueI)

lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
  by fast

lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
  by fast

lemma equiv_proj:
  assumes e: "equiv A R" and m: "z \<in> R"
  shows "(proj R o fst) z = (proj R o snd) z"
proof -
  from m have z: "(fst z, snd z) \<in> R" by auto
  with e have "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R"
    unfolding equiv_def sym_def trans_def by blast+
  then show ?thesis unfolding proj_def[abs_def] by auto
qed

(* Operators: *)
definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"

lemma Id_on_Gr: "Id_on A = Gr A id"
  unfolding Id_on_def Gr_def by auto

lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
  unfolding image2_def by auto

lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
  by auto

lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
  unfolding image2_def Gr_def by auto

lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
  unfolding Gr_def by simp

lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
  unfolding Gr_def by simp

lemma Gr_incl: "Gr A f \<subseteq> A \<times> B \<longleftrightarrow> f ` A \<subseteq> B"
  unfolding Gr_def by auto

lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
  by blast

lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
  by blast

lemma in_rel_Collect_case_prod_eq: "in_rel (Collect (case_prod X)) = X"
  unfolding fun_eq_iff by auto

lemma Collect_case_prod_in_rel_leI: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> Collect (case_prod (in_rel Y))"
  by auto

lemma Collect_case_prod_in_rel_leE: "X \<subseteq> Collect (case_prod (in_rel Y)) \<Longrightarrow> (X \<subseteq> Y \<Longrightarrow> R) \<Longrightarrow> R"
  by force

lemma conversep_in_rel: "(in_rel R)\<inverse>\<inverse> = in_rel (R\<inverse>)"
  unfolding fun_eq_iff by auto

lemma relcompp_in_rel: "in_rel R OO in_rel S = in_rel (R O S)"
  unfolding fun_eq_iff by auto

lemma in_rel_Gr: "in_rel (Gr A f) = Grp A f"
  unfolding Gr_def Grp_def fun_eq_iff by auto

definition relImage where
  "relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"

definition relInvImage where
  "relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"

lemma relImage_Gr:
  "\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
  unfolding relImage_def Gr_def relcomp_def by auto

lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
  unfolding Gr_def relcomp_def image_def relInvImage_def by auto

lemma relImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
  unfolding relImage_def by auto

lemma relInvImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
  unfolding relInvImage_def by auto

lemma relInvImage_Id_on:
  "(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
  unfolding relInvImage_def Id_on_def by auto

lemma relInvImage_UNIV_relImage:
  "R \<subseteq> relInvImage UNIV (relImage R f) f"
  unfolding relInvImage_def relImage_def by auto

lemma relImage_proj:
  assumes "equiv A R"
  shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
  unfolding relImage_def Id_on_def
  using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
  by (auto simp: proj_preserves)

lemma relImage_relInvImage:
  assumes "R \<subseteq> f ` A \<times> f ` A"
  shows "relImage (relInvImage A R f) f = R"
  using assms unfolding relImage_def relInvImage_def by fast

lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
  by simp

lemma fst_diag_id: "(fst \<circ> (\<lambda>x. (x, x))) z = id z" by simp
lemma snd_diag_id: "(snd \<circ> (\<lambda>x. (x, x))) z = id z" by simp

lemma fst_diag_fst: "fst o ((\<lambda>x. (x, x)) o fst) = fst" by auto
lemma snd_diag_fst: "snd o ((\<lambda>x. (x, x)) o fst) = fst" by auto
lemma fst_diag_snd: "fst o ((\<lambda>x. (x, x)) o snd) = snd" by auto
lemma snd_diag_snd: "snd o ((\<lambda>x. (x, x)) o snd) = snd" by auto

definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"

lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
  unfolding Shift_def Succ_def by simp

lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
  unfolding Succ_def by simp

lemmas SuccE = SuccD[elim_format]

lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
  unfolding Succ_def by simp

lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
  unfolding Shift_def by simp

lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
  unfolding Succ_def Shift_def by auto

lemma length_Cons: "length (x # xs) = Suc (length xs)"
  by simp

lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
  by simp

(*injection into the field of a cardinal*)
definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
definition "toCard A r \<equiv> SOME f. toCard_pred A r f"

lemma ex_toCard_pred:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
  unfolding toCard_pred_def
  using card_of_ordLeq[of A "Field r"]
    ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
  by blast

lemma toCard_pred_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
  unfolding toCard_def using someI_ex[OF ex_toCard_pred] .

lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> toCard A r x = toCard A r y \<longleftrightarrow> x = y"
  using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast

definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"

lemma fromCard_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
  unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)

lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma rec_nat_0_imp: "f = rec_nat f1 (\<lambda>n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
  by auto

lemma rec_nat_Suc_imp: "f = rec_nat f1 (\<lambda>n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
  by auto

lemma rec_list_Nil_imp: "f = rec_list f1 (\<lambda>x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
  by auto

lemma rec_list_Cons_imp: "f = rec_list f1 (\<lambda>x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
  by auto

lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
  by simp

definition image2p where
  "image2p f g R = (\<lambda>x y. \<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"

lemma image2pI: "R x y \<Longrightarrow> image2p f g R (f x) (g y)"
  unfolding image2p_def by blast

lemma image2pE: "\<lbrakk>image2p f g R fx gy; (\<And>x y. fx = f x \<Longrightarrow> gy = g y \<Longrightarrow> R x y \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
  unfolding image2p_def by blast

lemma rel_fun_iff_geq_image2p: "rel_fun R S f g = (image2p f g R \<le> S)"
  unfolding rel_fun_def image2p_def by auto

lemma rel_fun_image2p: "rel_fun R (image2p f g R) f g"
  unfolding rel_fun_def image2p_def by auto

subsection \<open>Equivalence relations, quotients, and Hilbert's choice\<close>

lemma equiv_Eps_in:
"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (\<lambda>x. x \<in> X) \<in> X"
  apply (rule someI2_ex)
  using in_quotient_imp_non_empty by blast

lemma equiv_Eps_preserves:
  assumes ECH: "equiv A r" and X: "X \<in> A//r"
  shows "Eps (\<lambda>x. x \<in> X) \<in> A"
  apply (rule in_mono[rule_format])
   using assms apply (rule in_quotient_imp_subset)
  by (rule equiv_Eps_in) (rule assms)+

lemma proj_Eps:
  assumes "equiv A r" and "X \<in> A//r"
  shows "proj r (Eps (\<lambda>x. x \<in> X)) = X"
unfolding proj_def
proof auto
  fix x assume x: "x \<in> X"
  thus "(Eps (\<lambda>x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
next
  fix x assume "(Eps (\<lambda>x. x \<in> X),x) \<in> r"
  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
qed

definition univ where "univ f X == f (Eps (\<lambda>x. x \<in> X))"

lemma univ_commute:
assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
shows "(univ f) (proj r x) = f x"
proof (unfold univ_def)
  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
  hence "Eps (\<lambda>y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
  moreover have "proj r (Eps (\<lambda>y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
  ultimately have "(x, Eps (\<lambda>y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
  thus "f (Eps (\<lambda>y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
qed

lemma univ_preserves:
  assumes ECH: "equiv A r" and RES: "f respects r" and PRES: "\<forall>x \<in> A. f x \<in> B"
  shows "\<forall>X \<in> A//r. univ f X \<in> B"
proof
  fix X assume "X \<in> A//r"
  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  hence "univ f X = f x" using ECH RES univ_commute by fastforce
  thus "univ f X \<in> B" using x PRES by simp
qed

ML_file "Tools/BNF/bnf_gfp_util.ML"
ML_file "Tools/BNF/bnf_gfp_tactics.ML"
ML_file "Tools/BNF/bnf_gfp.ML"
ML_file "Tools/BNF/bnf_gfp_rec_sugar_tactics.ML"
ML_file "Tools/BNF/bnf_gfp_rec_sugar.ML"

end


theory LaunchburyLog
imports Terms Substitution "Arity-Nominal"
begin

type_synonym CallLog = "(var \<times> Arity) list"

inductive
  reds :: "heap \<Rightarrow> exp \<Rightarrow> Arity \<Rightarrow>  var list \<Rightarrow> heap \<Rightarrow> exp \<Rightarrow> CallLog \<Rightarrow> bool"
  ("_ : _ \<Down>\<^bsub>_,_\<^esub> _ : _ (_)" [50,50,50,50,50,50] 50)
where
  Lambda:
    "\<Gamma> : (Lam [x]. e) \<Down>\<^bsub>n,L\<^esub> \<Gamma> : (Lam [x]. e) []"
 | Application: "\<lbrakk>
    atom y \<sharp> (\<Gamma>,e,x,L,\<Delta>,\<Theta>,z,c\<^sub>1,c\<^sub>2) ;
    \<Gamma> : e \<Down>\<^bsub>inc\<cdot>n,x#L\<^esub> \<Delta> : (Lam [y]. e') c\<^sub>1;
    \<Delta> : e'[y ::= x] \<Down>\<^bsub>n,L\<^esub> \<Theta> : z c\<^sub>2
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : App e x \<Down>\<^bsub>n,L\<^esub> \<Theta> : z c\<^sub>1@c\<^sub>2"
 | Variable: "\<lbrakk>
    map_of \<Gamma> x = Some e;
    delete x \<Gamma> : e \<Down>\<^bsub>n,x#L\<^esub> \<Delta> : z c
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Var x \<Down>\<^bsub>n,L\<^esub> (x, z) # \<Delta> : z (x,n)#c"
 | Let: "\<lbrakk>
    atom ` domA as \<sharp>* (\<Gamma>, L);
    as @ \<Gamma> : body \<Down>\<^bsub>n,L\<^esub> \<Delta> : z c
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Terms.Let as body \<Down>\<^bsub>n,L\<^esub> \<Delta> : z c"

equivariance reds

nominal_inductive reds
  avoids Application: "y"
  by (auto simp add: fresh_star_def fresh_append pure_fresh fresh_Pair)

subsubsection {* Example evaluations *}

lemma eval_test:
  "[] : (Terms.Let [(x, Lam [y]. Var y)] (Var x)) \<Down>\<^bsub>0,[]\<^esub> [(x, Lam [y]. Var y)] : (Lam [y]. Var y) [(x,0)]"
by(auto intro!: Lambda Application Variable Let
 simp add: fresh_Pair fresh_Cons fresh_Nil fresh_star_def pure_fresh )

lemma ApplicationI: "
  atom y \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z, c\<^sub>1, c\<^sub>2) \<Longrightarrow>
  \<Gamma> : e \<Down>\<^bsub>inc\<cdot>n,x # L\<^esub> \<Delta> : Lam [y]. e' c\<^sub>1 \<Longrightarrow>
  \<Delta> : e'[y::=x] \<Down>\<^bsub>n,L\<^esub> \<Theta> : z c\<^sub>2 \<Longrightarrow>
  c\<^sub>1@c\<^sub>2 = c \<Longrightarrow>
  \<Gamma> : App e x \<Down>\<^bsub>n,L\<^esub> \<Theta> : z c"
by (metis Application)

lemma eval_test2:
  "y \<noteq> x \<Longrightarrow> n \<noteq> y \<Longrightarrow> n \<noteq> x \<Longrightarrow>[] : (Terms.Let [(x, Lam [y]. Var y)] (App (Var x) x)) \<Down>\<^bsub>0,[]\<^esub> [(x, Lam [y]. Var y)] : (Lam [y]. Var y) [(x,inc\<cdot>0),(x,0)]"
  by (auto intro!: Lambda ApplicationI[where y = y and c\<^sub>2 = "[(x,0)]"] Variable Let simp add: fresh_Pair fresh_at_base fresh_Cons fresh_Nil fresh_star_def pure_fresh)

subsubsection {* Properties of the semantics *}

text {*
Heap entries are never removed.
*}

lemma reds_doesnt_forget:
  "\<Gamma> : e \<Down>\<^bsub>n,L\<^esub> \<Delta> : z c \<Longrightarrow> domA \<Gamma> \<subseteq> domA \<Delta>"
proof(induct rule: reds.induct)
case(Variable \<Gamma> v e n L \<Delta> z c)
  show ?case
  proof
    fix x
    assume "x \<in> domA \<Gamma>"
    show "x \<in> domA ((v, z) # \<Delta>)"
    proof(cases "x = v")
    case True
      thus ?thesis by simp
    next
    case False
      with `x \<in> domA \<Gamma>`
      have "x \<in> domA (delete v \<Gamma>)" by simp
      hence "x \<in> domA \<Delta>" using Variable.hyps(3) by auto
      thus ?thesis by simp
    qed
  qed
qed (auto)

subsubsection {* Log talks about heap *}

lemma log_heap_subset:
  assumes  "\<Gamma> : e \<Down>\<^bsub>n,L\<^esub> \<Delta> : v c"
  shows "domA c \<subseteq> domA \<Delta>"
using assms
by (induction rule: reds.induct)(auto simp add: set_mp[OF reds_doesnt_forget])

subsubsection {* Better Introduction variables *}

lemma reds_ApplicationI:
  assumes "atom y \<sharp> x" (* Less freshness required here *)
  assumes "\<Gamma> : e \<Down>\<^bsub>inc\<cdot>n, x # L\<^esub> \<Delta> : Lam [y]. e' c\<^sub>1"
  assumes "\<Delta> : e'[y::=x] \<Down>\<^bsub>n,L\<^esub> \<Theta> : z c\<^sub>2"
  shows "\<Gamma> : App e x \<Down>\<^bsub>n,L\<^esub> \<Theta> : z (c\<^sub>1@c\<^sub>2)"
proof-
  obtain y' :: var where "atom y' \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z, e',c\<^sub>1,c\<^sub>2)" by (rule obtain_fresh)

  have a: "Lam [y']. ((y' \<leftrightarrow> y) \<bullet> e') = Lam [y]. e'"
    using `atom y' \<sharp> _`
    by (auto simp add: Abs1_eq_iff fresh_Pair fresh_at_base)

  have [simp]: "(y' \<leftrightarrow> y) \<bullet> x = x" using `atom y \<sharp> _`  `atom y' \<sharp> _`
      by (simp add: flip_fresh_fresh fresh_Pair fresh_at_base)

  have "((y' \<leftrightarrow> y) \<bullet> e')[y'::=x] = (y' \<leftrightarrow> y) \<bullet> (e'[y::=x])" by simp
  also have "\<dots> = e'[y::=x]"
    using `atom y \<sharp> _`  `atom y' \<sharp> _`
    by (simp add: flip_fresh_fresh fresh_Pair fresh_at_base subst_pres_fresh)
  finally
  have b: "((y' \<leftrightarrow> y) \<bullet> e')[y'::=x] = e'[y::=x]".

  have "atom y' \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z, c\<^sub>1, c\<^sub>2)" using  `atom y' \<sharp> _` by (simp add: fresh_Pair)
  from  this assms(2,3)[folded a b]
  show ?thesis ..
qed

(*
text {*
Live variables are not added to the heap.
*}

lemma reds_avoids_live:
  "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   x \<in> set L;
   x \<notin> domA \<Gamma>
  \<rbrakk> \<Longrightarrow> x \<notin> domA \<Delta>"
proof(induct rule:reds.induct)
case (Lambda \<Gamma> x e L) thus ?case by auto
next
case (Application y \<Gamma> e x L \<Delta> \<Theta> z e') thus ?case by auto
next
case (Variable \<Gamma> x e L \<Delta> z)
   from Variable(1) have "x \<in> domA \<Gamma>" by (metis domA_from_set map_of_is_SomeD)
   with Variable
   show ?case by auto
next
case (Let as \<Gamma> L body \<Delta> z)
  have "x \<notin> domA \<Gamma>" by fact moreover
  have "set (bn as) \<sharp>* L" using `set (bn as) \<sharp>* (\<Gamma>, L)` by (simp add: fresh_star_Pair)
  hence "x \<notin> domA (asToHeap as)"
    using `x \<in> set L`
    apply -
    apply (induct as rule: asToHeap.induct)
    apply (auto simp add: exp_assn.bn_defs fresh_star_insert fresh_star_Pair)
    by (metis finite_set fresh_finite_set_at_base fresh_set)  ultimately
  have "x \<notin> domA (asToHeap as @ \<Gamma>)" by auto
  thus ?case
    by (rule Let.hyps(3)[OF `x \<in> set L`])
qed

lemma reds_avoids_live':
 assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
 shows "set L \<subseteq> - (domA \<Delta> - domA \<Gamma>)"
using reds_avoids_live[OF assms] by auto

text {*
Fresh variables either stay fresh or are added to the heap.
*}

lemma reds_fresh:" \<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   atom (x::var) \<sharp> (\<Gamma>, e)
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, z) \<or> x \<in> (domA \<Delta> - set L)"
proof(induct rule: reds.induct)
case (Lambda \<Gamma> x e) thus ?case by auto
next
case (Application y \<Gamma> e x' L \<Delta> \<Theta> z e')
  hence "atom x \<sharp> (\<Delta>, Lam [y]. e') \<or> x \<in> domA \<Delta> - set (x' # L)" by (auto simp add: fresh_Pair)

  thus ?case
  proof
    assume  "atom x \<sharp> (\<Delta>, Lam [y]. e')"
    show ?thesis
    proof(cases "x = y")
    case False
      hence "atom x \<sharp> e'" using `atom x \<sharp> (\<Delta>, Lam [y]. e')`
        by (auto simp add:fresh_Pair)
      hence "atom x \<sharp> e'[y ::= x']" using Application.prems
        by (auto intro: subst_pres_fresh[rule_format] simp add: fresh_Pair)
      thus ?thesis using Application.hyps(5) `atom x \<sharp> (\<Delta>, Lam [y]. e')` by auto
    next
    case True
      hence "atom x \<sharp> e'[y ::= x']" using `atom x \<sharp> (\<Delta>, Lam [y]. e')` Application.prems
        by (auto intro:subst_is_fresh simp add: fresh_Pair)
      thus ?thesis using Application.hyps(5) `atom x \<sharp> (\<Delta>, Lam [y]. e')` by auto
    qed
  next
    assume "x \<in> domA \<Delta>  - set (x' # L)"
    thus ?thesis using reds_doesnt_forget[OF Application.hyps(4)] by auto
  qed
next

case(Variable \<Gamma> v e L \<Delta> z)
  have "atom x \<sharp> \<Gamma>" and "atom x \<sharp> v" using Variable.prems(1) by (auto simp add: fresh_Pair)
  from fresh_delete[OF this(1)]
  have "atom x \<sharp> delete v \<Gamma>".
  moreover
  have "v \<in> domA \<Gamma>" using Variable.hyps(1) by (metis domA_from_set map_of_is_SomeD)
  from fresh_map_of[OF this  `atom x \<sharp> \<Gamma>`]
  have "atom x \<sharp> the (map_of \<Gamma> v)".
  hence "atom x \<sharp> e" using `map_of \<Gamma> v = Some e` by simp
  ultimately
  have "atom x \<sharp> (\<Delta>, z) \<or> x \<in> domA \<Delta> - set (v # L)"  using Variable.hyps(3) by (auto simp add: fresh_Pair)
  thus ?case using `atom x \<sharp> v` by (auto simp add: fresh_Pair fresh_Cons fresh_at_base)
next

case (Let as \<Gamma> L body \<Delta> z)
  show ?case
    proof (cases "atom x \<in> set(bn as)")
    case False
      hence "atom x \<sharp> as" using Let.prems by(auto simp add: fresh_Pair)
      show ?thesis
        apply(rule Let.hyps(3))
        using Let.prems `atom x \<sharp> as` False
        by (auto simp add: fresh_Pair fresh_append fresh_fun_eqvt_app[OF asToHeap_eqvt])
    next
    case True
      hence "x \<in> domA (asToHeap as)"
        by(induct as rule:asToHeap.induct)(auto simp add: exp_assn.bn_defs)
      moreover
      have "x \<notin> set L"
        using Let(1)
        by (metis True fresh_list_elem fresh_star_Pair fresh_star_def not_self_fresh)
      ultimately
      show ?thesis
      using reds_doesnt_forget[OF Let.hyps(2)] by auto
    qed
qed

lemma reds_fresh_fv: "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   x \<in> fv (\<Delta>, z) \<and> (x \<notin> domA \<Delta> \<or>  x \<in> set L)
  \<rbrakk> \<Longrightarrow> x \<in> fv (\<Gamma>, e)"
using reds_fresh
unfolding fv_def fresh_def
by blast

lemma new_vars_not_free:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  assumes "x \<in> domA \<Delta>"
  assumes "x \<in> set L"
  shows "x \<in> fv (\<Gamma>, e)"
  apply (rule reds_fresh_fv[OF assms(1)])
  using assms(2,3)
  apply (auto dest: set_mp[OF domA_fv_subset])
  done

lemma new_free_vars_on_heap:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  shows "fv (\<Delta>, z) - domA \<Delta> \<subseteq> fv (\<Gamma>, e) - domA \<Gamma>"
using reds_fresh_fv[OF assms(1)] reds_doesnt_forget[OF assms(1)] by auto

text {*
Reducing the set of variables to avoid is always possible.
*}

lemma reds_smaller_L: "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   set L' \<subseteq> set L
  \<rbrakk> \<Longrightarrow> \<Gamma> : e \<Down>\<^bsub>L'\<^esub> \<Delta> : z"
proof(nominal_induct avoiding : L' rule: reds.strong_induct)
case (Lambda \<Gamma> x e L L')
  show ?case
    by (rule reds.Lambda)
next
case (Application y \<Gamma> e xa L \<Delta> \<Theta> z e' L')
  show ?case
  proof(rule reds.Application)
    show "atom y \<sharp> (\<Gamma>, e, xa, L', \<Delta>, \<Theta>, z)"
      using Application
      by (auto simp add: fresh_Pair)

    have "set (xa # L') \<subseteq> set (xa # L)"
      using `set L' \<subseteq> set L` by auto
    thus "\<Gamma> : e \<Down>\<^bsub>xa # L'\<^esub> \<Delta> : Lam [y]. e'"
      by (rule Application.hyps(10))

    show "\<Delta> : e'[y::=xa] \<Down>\<^bsub>L'\<^esub> \<Theta> : z "
      by (rule Application.hyps(12)[OF Application.prems])
  qed
next
case (Variable \<Gamma> xa e L \<Delta> z L')
  have "set (xa # L') \<subseteq> set (xa # L)"
    using Variable.prems by auto
  thus ?case
    by (rule reds.Variable[OF Variable(1) Variable.hyps(3)])
next
case (Let as \<Gamma>  L body \<Delta> z L')
  have "set (bn as) \<sharp>* (\<Gamma>, L')"
    using Let(1-3) Let.prems
    by (auto simp add: fresh_star_Pair  fresh_star_set_subset)
  thus ?case
    by (rule reds.Let[OF _ Let.hyps(4)[OF Let.prems]])
qed

text {* Things are evaluated to a lambda expression, and the variable can be freely chose. *}

lemma result_evaluated_fresh:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  obtains y e'
  where "z = (Lam [y]. e')" and "atom y \<sharp> (c::'a::fs)"
proof-
  from assms
  have "\<exists> x e'. z = Lam [x]. e'"
    by (induct \<Gamma> e L \<Delta> z rule:reds.induct) (auto dest: reds_doesnt_forget)
  hence "\<exists> y e'. z = Lam [y]. e' \<and> atom y \<sharp> c"
    by (nominal_induct z avoiding: c rule:exp_assn.strong_induct(1)) auto
  thus thesis using that by blast
qed

*)
end