theory CC_Explain_Explain2_Equivalence
  imports CC_Explain2_Correctness
begin

subsection \<open>Lemma about \<open>cc_explain2\<close> and append and subset\<close>

theorem cc_explain_aux2_app:
  assumes "cc_invar_t cc_t"
    "\<forall> (a, b) \<in> set xs . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set xs . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    "cc = congruence_closure.truncate cc_t"
    "\<forall> (a, b) \<in> set ys . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set ys . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
  shows "cc_explain_aux2 cc (xs @ ys) = cc_explain_aux2 cc xs \<union> cc_explain_aux2 cc ys"
  using assms proof(induction rule: cc_explain_aux2_induct)
  case (base cc)
  then show ?case using cc_explain_aux2.psimps by auto
next
  case (congruent cc a b xs c output1 pending1 output2 pending2)
  then have "\<forall>a\<in>set xs. case a of (a, b) \<Rightarrow> a < nr_vars cc \<and> b < nr_vars cc"
"\<forall>a\<in>set xs. case a of (a, b) \<Rightarrow> are_congruent cc (a \<approx> b)"
    by auto
  have vars_t: "nr_vars cc = length (cc_list cc_t)"
    unfolding congruent(3) congruence_closure.truncate_def congruence_closure.select_convs
    by simp
  then have " \<forall>(a, b)\<in>set (((a,b) # xs) @ ys). a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
" \<forall>(a, b)\<in>set (((a,b) # xs) @ ys). are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    using congruent unfolding congruent(3)[symmetric] by auto
  then have dom: "cc_explain_aux2_dom (cc, (((a, b) # xs) @ ys))"
    "cc_explain_aux2_dom (cc, ((a, b) # xs))"
    using cc_explain_aux2_domain congruent vars_t congruent(3) by blast+
  have in_bounds: "a < nr_vars cc" "b < nr_vars cc"
    using congruent unfolding explain_list_invar_def same_length_invar_def by auto
  then have same_rep: "rep_of (proof_forest cc) a = rep_of (proof_forest cc) b"
    using congruent are_congruent_rep_of(2) by presburger
  then obtain p1 p2 where p: "path (proof_forest cc) c p1 a"
    "path (proof_forest cc) c p2 b"
    using congruent in_bounds explain_along_path_lowest_common_ancestor
    by metis
  then have bounds1: "\<forall>(a, b)\<in>set pending1. a < nr_vars cc \<and> b < nr_vars cc"
    using explain_along_path2_pending_in_bounds congruent
    by metis
  have "\<forall>(a, b)\<in>set pending2. a < nr_vars cc \<and> b < nr_vars cc"
    using explain_along_path2_pending_in_bounds congruent
    by (metis p(2))
  then have in_bounds2: "\<forall>a\<in>set (pending1 @ pending2 @ xs).
       case a of
       (a, b) \<Rightarrow> a < nr_vars cc \<and> b < nr_vars cc"
    "\<forall>a\<in>set ys.
       case a of
       (a, b) \<Rightarrow> a < nr_vars cc \<and> b < nr_vars cc"
    using bounds1 congruent congruent(3) vars_t by auto
  have "cc_explain_aux2 cc (((a, b) # xs) @ ys) =
output1 \<union> output2 \<union> cc_explain_aux2 cc (pending1 @ pending2 @ xs @ ys)"
    using cc_explain_aux2_simp2 dom congruent
    by auto

  also have "... = output1 \<union> output2 \<union> cc_explain_aux2 cc (pending1 @ pending2 @ xs)
\<union> cc_explain_aux2 cc ys"
    using congruent in_bounds2 by auto
  also have "... = cc_explain_aux2 cc ((a, b) # xs) \<union> cc_explain_aux2 cc ys"
    using cc_explain_aux2_simp2 dom(2) congruent
    by simp
  finally show ?case
    by simp
qed

lemma cc_explain_aux2_union:
  assumes "cc_invar_t cc_t"
    "\<forall> (a, b) \<in> set xs . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set xs . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    "cc = congruence_closure.truncate cc_t"
  shows "cc_explain_aux2 cc xs = \<Union>{cc_explain_aux2 cc [x] |x. x \<in> set xs}"
using assms proof(induction xs)
  case Nil
  then show ?case
    using cc_explain_aux2_simp1 by fastforce
next
  case (Cons a xs)
  then have "cc_explain_aux2 cc xs = \<Union> {cc_explain_aux2 cc [x] |x. x \<in> set xs}"
    by simp
  moreover have "cc_explain_aux2 cc (a # xs) = cc_explain_aux2 cc [a] \<union> cc_explain_aux2 cc xs"
"set (a # xs) = {a} \<union> set xs"
    using cc_explain_aux2_app[of cc_t "[a]" cc xs] Cons by auto
  moreover have "\<Union> {cc_explain_aux2 cc [x] |x. x \<in> set (a # xs)} =
\<Union> {cc_explain_aux2 cc [x] |x. x \<in> {a}} \<union> \<Union> {cc_explain_aux2 cc [x] |x. x \<in> set xs}"
    by fastforce
  moreover have "\<Union> {cc_explain_aux2 cc [x] |x. x \<in> {a}} = cc_explain_aux2 cc [a]"
    by blast
  ultimately show ?case using cc_explain_aux2_app
    by auto
qed

theorem cc_explain_aux2_subset:
  assumes "cc_invar_t cc_t"
    "\<forall> (a, b) \<in> set xs . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set xs . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    "cc = congruence_closure.truncate cc_t"
    "\<forall> (a, b) \<in> set ys . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set ys . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    "set xs \<subseteq> set ys"
  shows "cc_explain_aux2 cc xs \<subseteq> cc_explain_aux2 cc ys"
proof-
  have "cc_explain_aux2 cc xs = \<Union>{cc_explain_aux2 cc [x] |x. x \<in> set xs}"
    using cc_explain_aux2_union[OF assms(1-4)] by blast
  moreover have "cc_explain_aux2 cc ys = \<Union>{cc_explain_aux2 cc [y] |y. y \<in> set ys}"
    using cc_explain_aux2_union[OF assms(1,5,6,4)] assms by simp
  ultimately show ?thesis using assms(7)
    by blast
qed

subsection \<open>Invariant of elements in the additional union find and pending\<close>

text \<open>Invariant of \<open>explain_along_path\<close> that states that the recursive calls of explain are
present in the total output\<close>

fun pending_equations_list :: "pending_equation option \<Rightarrow> (nat * nat) list"
  where
    "pending_equations_list None = []"
  | "pending_equations_list (Some (One a)) = []"
  | "pending_equations_list (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_equations_list (Some (Two a b)) = []"

text \<open>Invariant to show the equivalence of \<open>cc_explain\<close> and \<open>cc_explain2\<close>.\<close>

definition was_already_in_pending where
  "was_already_in_pending cc l a b xs \<equiv>
    (((a, b) \<in> set xs) \<or>
        (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) \<subseteq> additional_uf_labels_set l (pf_labels cc)
            \<and> set pending1 \<union> set pending2 \<subseteq> additional_uf_pairs_set l (pf_labels cc))
        ))"

definition equations_of_l_in_pending_invar where
  "equations_of_l_in_pending_invar cc l xs \<equiv>
  (\<forall> (a, b) \<in> additional_uf_pairs_set l (pf_labels cc).
      was_already_in_pending cc l a b xs
  )"

lemma equations_of_l_in_pending_invar_a_b:
  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_invar cc l ((a, b) # xs)"
    "explain_list_invar l (proof_forest cc)"
  shows
    "was_already_in_pending cc new_new_l a b (pending1 @ pending2 @ xs)"
proof-
  obtain output12 pending12 output22 pending22 where
defs: "explain_along_path2 cc a c = (output12, pending12)"
         "explain_along_path2 cc b c = (output22, pending22)"
    by (metis old.prod.exhaust)
  have "output12 \<union> output22 \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc)"
    using explain_along_path_explain_along_path2_output_subset' defs assms
    by blast
  moreover have "set pending12 \<union> set pending22 \<subseteq>
additional_uf_pairs_set new_new_l (pf_labels cc)"
    using explain_along_path_explain_along_path2_pending_subset' defs assms
    by blast
  ultimately show ?thesis unfolding was_already_in_pending_def Let_def using defs
    using assms(4) by force
qed

lemma changed_edge_in_pending:
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 ! n = n" "new_l ! n \<noteq> n" "n < nr_vars cc"
    "pf_labels cc ! n = (Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b')))"
  shows  "(a\<^sub>1, b\<^sub>1) \<in> set pend \<and> (a\<^sub>2, b\<^sub>2) \<in> 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)
  then show ?case
    by (metis nth_list_update_neq option.inject pending_equation.distinct(1))
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)
  then show ?case
  proof(cases "l[rep_of l a := x] ! n = n")
    case True
    then have "(a\<^sub>1, b\<^sub>1) \<in> set pend \<and> (a\<^sub>2, b\<^sub>2) \<in> set pend"
      using Two by blast
    then show ?thesis
      by simp
  next
    case False
    then have "n = rep_of l a" using Two(21)
      by (metis nth_list_update_neq)
    then have "a\<^sub>1 = x\<^sub>1" "a\<^sub>2 = x\<^sub>2" "b\<^sub>1 = y\<^sub>1" "b\<^sub>2 = y\<^sub>2"
      using Two by auto
    then show ?thesis
      using Two by simp
  qed
qed simp

lemma changed_edge_in_pending':
  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)"
    "l ! n = n" "new_new_l ! n \<noteq> n" "n < nr_vars cc"
    "pf_labels cc ! n = (Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b')))"
  shows "(a\<^sub>1, b\<^sub>1) \<in> set (pend1 @ pend2) \<and> (a\<^sub>2, b\<^sub>2) \<in> set (pend1 @ pend2)"
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 (meson assms(1) explain_along_path_lowest_common_ancestor)
  then show ?thesis proof(cases "new_l ! n = n")
    case True
    have "explain_list_invar new_l (proof_forest cc)"
      using explain_list_invar_explain_along_path'' assms(1,2,3,4,6-8)
      by (metis length_explain_list_cc_list)
    with changed_edge_in_pending
    have "(a\<^sub>1, b\<^sub>1) \<in> set pend2 \<and> (a\<^sub>2, b\<^sub>2) \<in> set pend2"
      using paths True assms(1,10,11,12,5) by blast
    then show ?thesis by simp
  next
    case False
    with changed_edge_in_pending
    have "(a\<^sub>1, b\<^sub>1) \<in> set pend1 \<and> (a\<^sub>2, b\<^sub>2) \<in> set pend1"
      using paths assms(1,11,12,2,4,9) by blast
    then show ?thesis by auto
  qed
qed

lemma equations_of_l_in_pending_invar_invar:
  assumes "cc_invar_t cc_t"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    "cc = congruence_closure.truncate cc_t"
    "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_invar cc l ((a, b) # xs)"
    "explain_list_invar l (proof_forest cc)"
  shows
    "equations_of_l_in_pending_invar cc new_new_l (pending1 @ pending2 @ xs)"
  unfolding equations_of_l_in_pending_invar_def
proof(standard, standard)
  fix x x\<^sub>1 x\<^sub>2
  assume eq: "x \<in> additional_uf_pairs_set new_new_l (pf_labels cc)" "x = (x\<^sub>1, x\<^sub>2)"
  then obtain n where n: "n < length new_new_l \<and> new_new_l ! n \<noteq> n"
    "x \<in> pending_pairs (pf_labels cc ! n)" unfolding additional_uf_pairs_set_def
    by blast
  from n(2) obtain a\<^sub>1 a\<^sub>2  a' b\<^sub>1 b\<^sub>2 b' where
pfl: "pf_labels cc ! n = (Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b')))"
    "x = (a\<^sub>1, b\<^sub>1) \<or> x = (a\<^sub>2, b\<^sub>2)"
    using pending_pairs.cases
    by (metis insert_iff memb_imp_not_empty pending_pairs.elims)
  have same_length: "length l = length new_new_l"
    using assms explain_along_path_new_new_l_same_length
    by (metis case_prodD list.set_intros(1) equivalent_assumptions(2))
  have valid_eqs: "a < nr_vars cc \<and> b < nr_vars cc"
    "are_congruent cc (a \<approx> b)" using equivalent_assumptions(2,3)[OF assms(1-4)] by auto
  show "was_already_in_pending cc new_new_l x\<^sub>1 x\<^sub>2 (pending1 @ pending2 @ xs)"
    unfolding was_already_in_pending_def
  proof-
    define c where "c = lowest_common_ancestor (proof_forest cc) x\<^sub>1 x\<^sub>2"
    obtain output12 pending12 output22 pending22 where
      rec: "(output12, pending12) = explain_along_path2 cc x\<^sub>1 c"
      "(output22, pending22) = explain_along_path2 cc x\<^sub>2 c"
      by (metis old.prod.exhaust)
    have "was_already_in_pending cc new_new_l a b (pending1 @ pending2 @ xs)"
      using equations_of_l_in_pending_invar_a_b assms equivalent_assumptions[OF assms(1-4)] by simp
    have "(x\<^sub>1, x\<^sub>2) \<in> set (pending1 @ pending2 @ xs) \<or>
    (output12 \<union> output22 \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc) \<and>
        set pending12 \<union> set pending22 \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc))"
    proof(cases "l ! n = n")
      case True
      have "nr_vars cc = length new_new_l"
        using same_length same_length_invar_def explain_list_invar_def
        using assms(1,4,9) by presburger
      then have "(x\<^sub>1, x\<^sub>2) \<in> set (pending1 @ pending2)"
        using changed_edge_in_pending'[OF _ assms(9,5)]
        using assms(1,6,7,5) True n pfl valid_eqs unfolding assms(4)[symmetric]
        by (metis (no_types, lifting) eq(2) same_length valid_eqs(1) valid_eqs(2))
      then show ?thesis
        by auto
    next
      case False
      then have a_b: "x \<in> additional_uf_pairs_set l (pf_labels cc)" using n same_length
        unfolding additional_uf_pairs_set_def by auto
      then have 1: "was_already_in_pending cc l x\<^sub>1 x\<^sub>2 ((a, b) # xs)"
        using assms(2,3,7) n same_length eq equivalent_assumptions[OF assms(1-4)]
        unfolding equations_of_l_in_pending_invar_def
        by (metis assms(8) case_prodD equations_of_l_in_pending_invar_def)
      then have 2: "((x\<^sub>1, x\<^sub>2) \<in> set ((a, b) # xs)) \<or> (output12 \<union> output22 \<subseteq> additional_uf_labels_set l (pf_labels cc) \<and>
      set pending12 \<union> set pending22 \<subseteq> additional_uf_pairs_set l (pf_labels cc))"
        unfolding was_already_in_pending_def Let_def using rec c_def by force
      have subset: "additional_uf_labels_set l (pf_labels cc) \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc)"
        "additional_uf_pairs_set l (pf_labels cc) \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc)"
        using equivalent_assumptions[OF assms(1-4)] additional_uf_labels_set_explain_along_path'
         apply (metis assms(5) assms(6) assms(7) assms(9) valid_eqs(1) valid_eqs(2))
        using equivalent_assumptions[OF assms(1-4)] additional_uf_pairs_set_explain_along_path'
        by (metis assms(5) assms(6) assms(7) assms(9) valid_eqs(1) valid_eqs(2))

      have append: "cc_explain_aux2 cc ((a, b) # xs) = cc_explain_aux2 cc [(a, b)] \<union> cc_explain_aux2 cc xs"
        using cc_explain_aux2_app[of cc_t "[(a, b)]" cc xs] assms(1,2,3,4)
        by auto
      have 0: "was_already_in_pending cc new_new_l a b (pending1 @ pending2 @ xs)"
        using equations_of_l_in_pending_invar_a_b assms equivalent_assumptions[OF assms(1-4)] by blast
      consider "(x\<^sub>1, x\<^sub>2) = (a, b)" | "(x\<^sub>1, x\<^sub>2) \<in> set xs" | "output12 \<union> output22 \<subseteq> additional_uf_labels_set l (pf_labels cc) \<and>
      set pending12 \<union> set pending22 \<subseteq> additional_uf_pairs_set l (pf_labels cc)"
        by (meson "2" set_ConsD)
      then show ?thesis proof(cases)
        case 1
        then show ?thesis using 0 unfolding was_already_in_pending_def Let_def
          using c_def local.rec(1) local.rec(2) by force
      next
        case 2
        then show ?thesis
          by force
      next
        case 3
        then show ?thesis using subset
          by (meson subset_trans)
      qed
    qed
    then show "(x\<^sub>1, x\<^sub>2) \<in> set (pending1 @ pending2 @ xs) \<or>
    (let c = lowest_common_ancestor (proof_forest cc) x\<^sub>1 x\<^sub>2; (output1, pending1) = explain_along_path2 cc x\<^sub>1 c;
         (output2, pending2) = explain_along_path2 cc x\<^sub>2 c
     in output1 \<union> output2 \<subseteq> additional_uf_labels_set new_new_l (pf_labels cc) \<and>
        set pending1 \<union> set pending2 \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc))"
      unfolding was_already_in_pending_def Let_def
      using c_def local.rec(1) local.rec(2) by force
  qed
qed

lemma equations_of_l_in_pending_invar_initial:
"equations_of_l_in_pending_invar cc [0..<nr_vars cc] xs"
proof-
  have "additional_uf_pairs_set [0..<nr_vars cc] (pf_labels cc) = {}"
    unfolding additional_uf_pairs_set_def by auto
  then show ?thesis
    unfolding equations_of_l_in_pending_invar_def by blast
qed

subsection \<open>Equivalence proof of \<open>cc_explain2\<close> and \<open>cc_explain\<close>\<close>

lemma subseq_removeAll:
"subseq (removeAll x xs) xs"
  apply(induct xs)
  by auto

lemma subseq_notin_set:
  assumes "(a, b) \<notin> set xs"
    "subseq xs xs2"
  shows "subseq xs (removeAll (a, b) xs2)"
  using assms proof(induction xs2 arbitrary: xs)
  case Nil
  then show ?case
    by auto
next
  case (Cons a xs2)
  then show ?case proof(cases xs)
    case Nil
    then show ?thesis
      by blast
  next
    case (Cons a list)
    then show ?thesis
      by (metis Cons.prems removeAll_filter_not_eq removeAll_id subseq_filter)
  qed
qed

lemma cc_explain_aux2_removeAll:
   assumes "cc_invar_t cc_t"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set ((a, b) # xs) . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    "cc = congruence_closure.truncate cc_t"
  shows "cc_explain_aux2 cc ((a, b) # xs) = cc_explain_aux2 cc ((a, b) # removeAll (a, b) xs)"
proof-
  have same_set: "set ((a, b) # xs) = set ((a, b) # removeAll (a, b) xs)"
    by auto
  then have valid: "\<forall> (a, b) \<in> set ((a, b) # removeAll (a, b) xs) . a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "\<forall> (a, b) \<in> set ((a, b) # removeAll (a, b) xs) . are_congruent (congruence_closure.truncate cc_t) (a \<approx> b)"
    using assms by auto
  have "cc_explain_aux2 cc ((a, b) # xs) =  \<Union> {cc_explain_aux2 cc [x] |x. x \<in> set ((a, b) # xs)}"
    using cc_explain_aux2_union[OF assms] by blast
  also have "... = \<Union> {cc_explain_aux2 cc [x] |x. x \<in> set ((a, b) # removeAll (a, b) xs)}"
    using same_set by blast
  also have "... = cc_explain_aux2 cc ((a, b) # removeAll (a, b) xs)"
    using cc_explain_aux2_union[OF assms(1) valid assms(4)] by argo
  finally show ?thesis
    by blast
qed

lemma cc_explain_aux_cc_explain_aux2_equivalence:
  assumes "cc_invar_t cc_t"
    "\<forall> (a, b) \<in> set xs . a < nr_vars cc \<and> b < nr_vars cc"
    "\<forall> (a, b) \<in> set xs . are_congruent cc (a \<approx> b)"
    "cc = congruence_closure.truncate cc_t"
    "\<forall> (a, b) \<in> set xs2 . a < nr_vars cc \<and> b < nr_vars cc"
    "\<forall> (a, b) \<in> set xs2 . are_congruent cc (a \<approx> b)"
    "explain_list_invar l (proof_forest cc)"
    "equations_of_l_in_pending_invar cc l xs"
    "set xs2 \<subseteq> set xs \<union> additional_uf_pairs_set l (pf_labels cc)"
    "subseq xs xs2"
  shows "cc_explain_aux2 cc xs2 \<subseteq>
cc_explain_aux cc l xs \<union> additional_uf_labels_set l (pf_labels cc)"
  using assms proof (induction "timestamp_mset xs2 (proof_forest cc_t) (timestamps cc_t)"
    arbitrary: xs xs2 l rule: less_induct)
  case 1: less
  then show ?case proof(cases xs2)
    case Nil
    then show ?thesis
      using cc_explain_aux2_simp1 by blast
  next
    case (Cons ab xs2')
    obtain a b where ab: "ab = (a, b)"
      by force
    define c where "c = lowest_common_ancestor (proof_forest cc) a b"
    obtain output12 output22 pending12 pending22 where
      defs: "explain_along_path2 cc a c = (output12, pending12)"
      "explain_along_path2 cc b c = (output22, pending22)"
      by (metis old.prod.exhaust)
    have cc2: "\<lparr>cc_list = cc_list cc_t, use_list = use_list cc_t, lookup = lookup cc_t,
         pending = pending cc_t, proof_forest = proof_forest cc_t,
         pf_labels = pf_labels cc_t, input = input cc_t\<rparr> = cc"
      and cc3: "proof_forest cc_t = proof_forest cc"
      "cc_list cc_t = cc_list cc"
      unfolding 1(5) congruence_closure.truncate_def
        congruence_closure.select_convs by auto
    note hyps = 1[unfolded congruence_closure.truncate_def
        congruence_closure.select_convs cc2, unfolded cc3]
    have "rep_of (proof_forest cc) a = rep_of (proof_forest cc) b"
      "ufa_invar (proof_forest cc)"
      "a < length (proof_forest cc)" "b < length (proof_forest cc)"
      using  hyps(2,3,4,5,6,7) are_congruent_rep_of same_length_invar_def
        ab Cons proof_forest_invar_def by auto
    then obtain p1 p2 where path: "path (proof_forest cc) c p1 a"
      "path (proof_forest cc) c p2 b"
      using c_def lowest_common_ancestor_correct
      by presburger
    then have are_congruent:
      "\<forall>a\<in>set (pending12 @ pending12 @ xs). case a of (a, b) \<Rightarrow> are_congruent cc (a \<approx> b)"
      using explain_along_path2_pending' hyps defs
      by fastforce
    have dom: "cc_explain_aux2_dom (cc, (a, b) # xs2')" using cc_explain_aux2_domain
      using 1(2,5) hyps(6,7) Cons ab equivalent_assumptions2
      by blast
    then have rec': "cc_explain_aux2 cc ((a, b) # xs2') =
output12 \<union> output22 \<union> cc_explain_aux2 cc (pending12 @ pending22 @ xs2')"
      using hyps c_def defs cc_explain_aux2_simp2 Cons ab
      by auto
    then show ?thesis
    proof(cases "xs = (a, b) # tl xs")
      case True
        (* The current pair that we consider is both in xs and in xs2 *)
      obtain output1 new_l pending1 output2 new_new_l pending2 where rec:
        "explain_along_path cc l a c = (output1, new_l, pending1)"
        "explain_along_path cc new_l b c = (output2, new_new_l, pending2)"
        by (meson prod_cases3)
      have "cc_explain_aux_dom (cc, l, ((a, b) # tl xs))"
        using cc_explain_aux_domain hyps True by simp
      then have cc_explain_aux: "cc_explain_aux cc l ((a, b) # tl xs) = output1 \<union> output2
\<union> cc_explain_aux cc new_new_l (pending1 @ pending2 @ tl xs)"
        using cc_explain_aux_simp2 hyps rec c_def
        by (metis \<open>a < length (proof_forest cc)\<close> \<open>b < length (proof_forest cc)\<close> \<open>rep_of (proof_forest cc) a = rep_of (proof_forest cc) b\<close> are_congruent_simp same_eq_classes_invar_not_divided)
      have eli: "explain_list_invar new_l (proof_forest cc)" using explain_list_invar_explain_along_path'
        using hyps explain_along_path_domain local.rec(1) path(1)
        by fast
      then have eli': "explain_list_invar new_new_l (proof_forest cc)" using explain_list_invar_explain_along_path'
        using hyps explain_along_path_domain local.rec(2) path(2)
        by fast
      have pend_in_bounds: "\<forall> (a, b) \<in> set pending12 . a < nr_vars cc \<and> b < nr_vars cc"
        "\<forall> (a, b) \<in> set pending22 . a < nr_vars cc \<and> b < nr_vars cc"
        "\<forall> (a, b) \<in> set pending12 . are_congruent cc (a \<approx> b)"
        "\<forall> (a, b) \<in> set pending22 . are_congruent cc (a \<approx> b)"
        "\<forall> (a, b) \<in> set pending1 . a < nr_vars cc \<and> b < nr_vars cc"
        "\<forall> (a, b) \<in> set pending2 . a < nr_vars cc \<and> b < nr_vars cc"
        "\<forall> (a, b) \<in> set pending1 . are_congruent cc (a \<approx> b)"
        "\<forall> (a, b) \<in> set pending2 . are_congruent cc (a \<approx> b)"
        using explain_along_path2_pending_in_bounds defs path explain_along_path2_pending_are_congruent
          explain_along_path_pending_in_bounds hyps
               apply blast+
        using explain_along_path_pending_in_bounds path hyps
           apply (simp add: local.rec eli)
        using explain_along_path_pending_in_bounds path hyps
        using case_prodI2 eli local.rec(2) snd_conv apply simp
        using explain_along_path_pending_are_congruent  path hyps
        using local.rec(1) apply presburger
        using explain_along_path_pending_are_congruent  path hyps eli local.rec(2) by blast
      then have in_bounds: "\<forall> (a, b) \<in> set (pending12 @ pending22 @ xs2') . a < nr_vars cc \<and> b < nr_vars cc"
        "\<forall> (a, b) \<in> set (pending12 @ pending22 @ xs2') . are_congruent cc (a \<approx> b)"
        "\<forall> (a, b) \<in> set (pending1 @ pending2 @ tl xs) . a < nr_vars cc \<and> b < nr_vars cc"
        "\<forall> (a, b) \<in> set (pending1 @ pending2 @ tl xs) . are_congruent cc (a \<approx> b)"
        "explain_list_invar new_new_l (proof_forest cc)"
        using hyps Cons ab apply auto[2]
        using pend_in_bounds hyps apply (metis UnE in_set_tlD set_union_code)
        using pend_in_bounds hyps apply (metis UnE in_set_tlD set_union_code)
        using eli explain_list_invar_explain_along_path'
        using hyps(2) explain_along_path_domain local.rec(2) path(2) by blast
      from eli have supset: "output12 \<supseteq> output1" "output22 \<supseteq> output2"
        using explain_along_path_explain_along_path2_output_supset defs path hyps rec
        by metis+
      have add_uf_new_l': "additional_uf_labels_set new_l (pf_labels cc)
= additional_uf_labels_set l (pf_labels cc) \<union> output1"
        "additional_uf_labels_set new_new_l (pf_labels cc)
= additional_uf_labels_set new_l (pf_labels cc) \<union> output2"
        using additional_uf_labels_set_explain_along_path
        using hyps local.rec path eli by auto
      then have add_uf_new_l: "additional_uf_labels_set new_new_l (pf_labels cc)
= additional_uf_labels_set l (pf_labels cc) \<union> output1 \<union> output2"
        by simp
      have *: "output12 \<union> output22
    \<subseteq> cc_explain_aux cc l xs \<union> additional_uf_labels_set l (pf_labels cc)"
      proof-
        (* The output of explain2 is bigger than the output of explain, but
all the equations that are in explain2 are also present in new_new_l *)
        have "output12 \<subseteq> output1 \<union> additional_uf_labels_set l (pf_labels cc)"
          "output22 \<subseteq> output2 \<union> additional_uf_labels_set new_l (pf_labels cc)"
          "output1 \<union> additional_uf_labels_set l (pf_labels cc) =
additional_uf_labels_set new_l (pf_labels cc)"
          using add_uf_new_l' explain_along_path_explain_along_path2_output_subset hyps path(1) rec defs path
            apply blast
          using add_uf_new_l' explain_along_path_explain_along_path2_output_subset path(2) hyps eli rec defs path
           apply blast
          using add_uf_new_l' by blast
        then show ?thesis
          using cc_explain_aux supset add_uf_new_l True by auto
      qed
      have "cc_explain_aux2 cc (pending12 @ pending22 @ xs2')
\<subseteq> cc_explain_aux cc l xs \<union> additional_uf_labels_set l (pf_labels cc)"
        (* The pending list of explain2 is longer than the pending list of explain.
        We can use the induction hypothesis to show the thesis. *)
      proof-
        have invar_eofip: "equations_of_l_in_pending_invar cc new_new_l (pending1 @ pending2 @ tl xs)"
          using equations_of_l_in_pending_invar_invar[OF 1(2) _ _ 1(5) c_def rec _ 1(8), of "tl xs"] 1(9) True equivalent_assumptions2[OF 1(3,4,5)]
          by force
have pending_subset: "set pending12 \<subseteq> additional_uf_pairs_set new_l (pf_labels cc)"
            "set pending22 \<subseteq> additional_uf_pairs_set new_new_l (pf_labels cc)"
            using explain_along_path_explain_along_path2_pending_subset[OF _ path(1) defs(1)]
            using hyps(2,8) local.rec(1) apply blast
            using explain_along_path_explain_along_path2_pending_subset[OF _ path(2) defs(2)]
            using hyps(2) eli rec(2) by blast
          have pending_subseq: "subseq pending1 pending12" "subseq pending2 pending22" "subseq (tl xs) xs2'"
            using explain_along_path_explain_along_path2_pending_subseq hyps path(1) defs(1) rec(1)
              apply blast
            using explain_along_path_explain_along_path2_pending_subseq hyps path(2) defs(2) eli rec(2)
             apply blast
            by (metis True ab hyps(11) local.Cons subseq_Cons2')
have aups_n_l: "additional_uf_pairs_set new_l (pf_labels cc) =
additional_uf_pairs_set l (pf_labels cc) \<union> set pending1"
            using additional_uf_pairs_set_explain_along_path hyps local.rec(1) path(1) by blast
          then have aups_n_n_l: "additional_uf_pairs_set new_new_l (pf_labels cc) =
additional_uf_pairs_set l (pf_labels cc) \<union> set pending1 \<union> set pending2"
            using hyps additional_uf_pairs_set_explain_along_path eli rec(2) path(2) by presburger
        then show ?thesis
        proof(cases "(a, b) \<in> set (tl xs)")
          case True': True
          have "set xs = set (tl xs) \<union> {(a, b)}"
            "set ((a, b) # xs2) = set xs2 \<union> {(a, b)}" using hyps True
             apply (metis Un_insert_right list.simps(15) sup_bot_right)
            by auto
          then have "set xs2 \<subseteq> set (tl xs) \<union> additional_uf_pairs_set l (pf_labels cc)"
            using hyps(10) True True' by blast
          have "set xs2 \<subseteq> set (tl xs) \<union> additional_uf_pairs_set l (pf_labels cc)"
            using True by (simp add: \<open>set xs2 \<subseteq> set (tl xs) \<union> additional_uf_pairs_set l (pf_labels cc)\<close>)
          then have subset: "set (pending12 @ pending22 @ xs2')
    \<subseteq> set (pending1 @ pending2 @ tl xs) \<union> additional_uf_pairs_set new_new_l (pf_labels cc)"
            "subseq (pending1 @ pending2 @ tl xs) (pending12 @ pending22 @ xs2')"
            using pending_subset aups_n_l aups_n_n_l Cons ab apply auto[1]
            using pending_subseq Cons ab by (metis list_emb_append_mono)
          have mset_less: "(timestamp_mset (pending12 @ pending22 @ xs2') (proof_forest cc) (timestamps cc_t))
     < (timestamp_mset xs2 (proof_forest cc) (timestamps cc_t))"
            using recursive_calls_mset_less[OF assms(1) defs[unfolded 1(5)] c_def[unfolded cc3(1)[symmetric]] "1.prems"(4)[symmetric]]
"1.prems" Cons ab cc3
            by auto
          then have IH: "cc_explain_aux2 cc (pending12 @ pending22 @ xs2')
\<subseteq> cc_explain_aux cc new_new_l (pending1 @ pending2 @ tl xs) \<union>
additional_uf_labels_set new_new_l (pf_labels cc)"
            using hyps(1)[OF mset_less hyps(2) in_bounds(3,4) _ in_bounds(1,2) eli' invar_eofip]
              c_def subset defs in_bounds invar_eofip Cons ab mset_less by blast
          then show ?thesis
            using IH True add_uf_new_l cc_explain_aux by auto
        next
          case False
          (* in this case "xs = (a, b) # tl xs" and "(a, b) \<notin> set (tl xs)" *)
          note True False
          define xs2_no_ab where "xs2_no_ab = removeAll (a, b) xs2'"
          have cc_explain_eq: "cc_explain_aux2 cc ((a, b) # xs2_no_ab) = cc_explain_aux2 cc ((a, b) # xs2')"
            using cc_explain_aux2_removeAll equivalent_assumptions2[OF hyps(6,7) 1(5)] 1(2,5)
            unfolding Cons ab xs2_no_ab_def by blast
 have same_set: "set xs2 = set ((a, b) # xs2_no_ab)"
            unfolding xs2_no_ab_def Cons ab by auto
          then have in_bounds': "\<forall> (a, b) \<in> set ((a, b) # xs2_no_ab) . a < nr_vars cc \<and> b < nr_vars cc"
            "\<forall> (a, b) \<in> set ((a, b) # xs2_no_ab) . are_congruent cc (a \<approx> b)"
            "\<forall> (a, b) \<in> set (pending12 @ pending22 @ xs2_no_ab) . a < nr_vars cc \<and> b < nr_vars cc"
            "\<forall> (a, b) \<in> set (pending12 @ pending22 @ xs2_no_ab) . are_congruent cc (a \<approx> b)"
            using hyps(6,7) pend_in_bounds by auto
have dom2: "cc_explain_aux2_dom (cc, ((a, b) # xs2_no_ab))"
            using cc_explain_aux2_domain[OF 1(2) equivalent_assumptions2[OF in_bounds'(1,2) 1(5)]] 1(5)
            by blast
          then have cc_explain_aux_no_ab:
            "cc_explain_aux2 cc ((a, b) # xs2_no_ab) = output12 \<union> output22 \<union>
cc_explain_aux2 cc (pending12 @ pending22 @ xs2_no_ab)"
            using cc_explain_aux2_simp2[OF dom2 c_def _ defs[symmetric]] hyps rec c_def
              in_bounds'
              \<open>a < length (proof_forest cc)\<close> \<open>b < length (proof_forest cc)\<close> \<open>rep_of (proof_forest cc) a = rep_of (proof_forest cc) b\<close> are_congruent_simp same_eq_classes_invar_not_divided
            by presburger
          have cc_explain_eq2: "cc_explain_aux2 cc (pending12 @ pending22 @ xs2_no_ab)
- output12 - output22
= cc_explain_aux2 cc (pending12 @ pending22 @ xs2') - output12 - output22"
            using cc_explain_eq cc_explain_aux cc_explain_aux_no_ab rec' by auto
          have "subseq (tl xs) xs2_no_ab"
            using False hyps(10,11) xs2_no_ab_def by (metis True ab local.Cons subseq_Cons2' subseq_notin_set)
          have "set xs2_no_ab = set xs2' - {(a, b)}" unfolding xs2_no_ab_def by simp
          have "(a, b) \<notin> set xs2_no_ab" unfolding xs2_no_ab_def by simp
           then have "set xs2_no_ab \<subseteq> set (tl xs) \<union> additional_uf_pairs_set l (pf_labels cc)"
            using hyps(10) True
            by (metis (no_types, lifting) Diff_insert2 Diff_insert_absorb Diff_subset_conv list.simps(15) same_set)
          then have subset: "set (pending12 @ pending22 @ xs2_no_ab)
    \<subseteq> set (pending1 @ pending2 @ tl xs) \<union> additional_uf_pairs_set new_new_l (pf_labels cc)"
            "subseq (pending1 @ pending2 @ tl xs) (pending12 @ pending22 @ xs2')"
            using pending_subset aups_n_l aups_n_n_l Cons ab apply auto[1]
            using pending_subseq Cons ab by (metis list_emb_append_mono)
          have mset_less: "(timestamp_mset (pending12 @ pending22 @ xs2') (proof_forest cc) (timestamps cc_t))
     < (timestamp_mset xs2 (proof_forest cc) (timestamps cc_t))"
            using recursive_calls_mset_less[OF assms(1) defs[unfolded 1(5)] c_def[unfolded cc3(1)[symmetric]] "1.prems"(4)[symmetric]]
"1.prems" Cons ab cc3
            by auto
          then have "(timestamp_mset xs2_no_ab (proof_forest cc) (timestamps cc_t))
     < (timestamp_mset xs2' (proof_forest cc) (timestamps cc_t))
\<or> (timestamp_mset xs2_no_ab (proof_forest cc) (timestamps cc_t))
     = (timestamp_mset xs2' (proof_forest cc) (timestamps cc_t))"
            using removeAll_timestamp_mset_less unfolding xs2_no_ab_def by simp
            then have "(timestamp_mset (pending12 @ pending22 @ xs2_no_ab) (proof_forest cc) (timestamps cc_t))
     < (timestamp_mset (pending12 @ pending22 @ xs2') (proof_forest cc) (timestamps cc_t))
\<or> (timestamp_mset (pending12 @ pending22 @ xs2_no_ab) (proof_forest cc) (timestamps cc_t))
     = (timestamp_mset (pending12 @ pending22 @ xs2') (proof_forest cc) (timestamps cc_t))"
              using append_timestamp_mset_less timestamp_mset_app by force
            then have **: "(timestamp_mset (pending12 @ pending22 @ xs2_no_ab) (proof_forest cc) (timestamps cc_t))
    < (timestamp_mset xs2 (proof_forest cc) (timestamps cc_t))"
              using mset_less by fastforce
          have IH: "cc_explain_aux2 cc (pending12 @ pending22 @ xs2_no_ab)
\<subseteq> cc_explain_aux cc new_new_l (pending1 @ pending2 @ tl xs) \<union>
additional_uf_labels_set new_new_l (pf_labels cc)"
            using hyps(1)[OF ** hyps(2) in_bounds(3,4) _ in_bounds'(3,4) eli' invar_eofip] c_def defs in_bounds(3-) invar_eofip in_bounds'
              subset by (meson \<open>subseq (tl xs) xs2_no_ab\<close> list_emb_append_mono pending_subseq(1) pending_subseq(2))
          have "additional_uf_labels_set new_new_l (pf_labels cc) =
additional_uf_labels_set l (pf_labels cc) \<union> output1 \<union> output2"
            using hyps c_def defs additional_uf_labels_set_explain_along_path' eli rec path add_uf_new_l by force
          then show ?thesis
            using IH True add_uf_new_l cc_explain_aux cc_explain_eq cc_explain_aux_no_ab
             xs2_no_ab_def Cons ab cc_explain_eq2 *
            by auto
        qed
      qed
      then show ?thesis using defs c_def rec' "*"
        by (simp add: ab local.Cons)
    next
      case False
        (* The current pair that we consider is only in xs2, and not in xs.
We must prove that the added output and the added elements in pending
are also present in explain xs.

The invariant equations_of_l_in_pending_invar states that all the edges
that are present in explain2 and not in explain were already in the pending list
sometime before this point.
*)
      then have subset: "set xs2' \<subseteq> set xs \<union> additional_uf_pairs_set l (pf_labels cc)"
        using hyps(10) Cons ab by auto
      then have union: "cc_explain_aux2 cc ((a, b) # xs2') =
cc_explain_aux2 cc [(a, b)] \<union> cc_explain_aux2 cc xs2'"
        using cc_explain_aux2_app[of cc_t "[(a, b)]" cc xs2', OF 1(2) _ _ 1(5)]
        using 1(5) equivalent_assumptions2[OF 1(6,7,5)] unfolding ab Cons by auto
      have subseq: "subseq xs xs2'" using hyps(11) Cons ab
        by (metis False list.collapse list_emb.simps subseq_Cons2_neq)
      have *: "cc_explain_aux2 cc ((a, b) # xs2') \<subseteq>
      cc_explain_aux cc l xs \<union> additional_uf_labels_set l (pf_labels cc)"
      proof-
        show ?thesis
        proof(cases "(a, b) \<in> set xs")
          (* (a,b) is also present in the remaining list xs2 *)
          case True
          then have "(a, b) \<in> set xs2'"
            by (meson subseq subseq_order.trans subseq_singleton_left)
          then have set_eq: "set ((a, b) # xs2') = set xs2'"
            by auto
          have *: "(timestamp_mset xs2' (proof_forest cc) (timestamps cc_t))
     < (timestamp_mset xs2 (proof_forest cc) (timestamps cc_t))"
            using tl_list_mset_less[OF 1(2)] Cons ab equivalent_assumptions2[OF 1(6,7,5)]
            using True assms(4) case_prodD cc3 hyps(3) by auto
          have "cc_explain_aux2 cc ((a, b) # xs2') = \<Union> {cc_explain_aux2 cc [x] |x. x \<in> set ((a, b) # xs2')}"
            using cc_explain_aux2_union[of cc_t "((a, b) # xs2')" cc] 1(2,5)
              equivalent_assumptions2[OF 1(6,7,5)] unfolding Cons ab
            by presburger
          also have "... = \<Union> {cc_explain_aux2 cc [x] |x. x \<in> set xs2'}"
            using Cons ab False set_eq by auto
          also have "... = cc_explain_aux2 cc xs2'"
            using cc_explain_aux2_union[of cc_t "xs2'" cc] equivalent_assumptions2[OF _ _ 1(5)]
              1(6,7) assms(1) assms(4) local.Cons by auto
          finally show ?thesis
            using * hyps subseq subset unfolding Cons ab by auto
        next
          case False
            (* (a, b) is in the pairs set. We can use the invariant to prove that (a, b) \<in> explain2 xs*)
          then have "(a, b) \<in> additional_uf_pairs_set l (pf_labels cc)"
            using hyps(10) ab Cons by force
          with hyps(9) have invariant: "output12 \<union> output22 \<subseteq> additional_uf_labels_set l (pf_labels cc) \<and>
         set pending12 \<union> set pending22 \<subseteq> additional_uf_pairs_set l (pf_labels cc)"
            unfolding equations_of_l_in_pending_invar_def was_already_in_pending_def Let_def
            using False defs c_def by force
          then have subset: "set (pending12 @ pending22 @ xs2') \<subseteq> set xs \<union> additional_uf_pairs_set l (pf_labels cc)"
            using subset by auto
          have subseq_xs: "subseq xs (pending12 @ pending22 @ xs2')"
            by (simp add: subseq subseq_drop_many)
          have *: "\<forall> (a, b) \<in> set pending12 . a < nr_vars cc \<and> b < nr_vars cc"
            "\<forall> (a, b) \<in> set pending22 . a < nr_vars cc \<and> b < nr_vars cc"
            "\<forall> (a, b) \<in> set pending12 . are_congruent cc (a \<approx> b)"
            "\<forall> (a, b) \<in> set pending22 . are_congruent cc (a \<approx> b)"
            using hyps(2) explain_along_path2_pending_in_bounds defs path explain_along_path2_pending_are_congruent
              explain_along_path_pending_in_bounds
            by blast+
          then have in_bounds: "\<forall> (a, b) \<in> set (pending12 @ pending22 @ xs2') . a < nr_vars cc \<and> b < nr_vars cc"
            "\<forall> (a, b) \<in> set (pending12 @ pending22 @ xs2') . are_congruent cc (a \<approx> b)"
            using hyps(5,6,7,8) Cons by auto
          have mset_less: "(timestamp_mset (pending12 @ pending22 @ xs2') (proof_forest cc) (timestamps cc_t))
     < (timestamp_mset xs2 (proof_forest cc) (timestamps cc_t))"
            using recursive_calls_mset_less[OF assms(1) defs[unfolded 1(5)] c_def[unfolded cc3(1)[symmetric]] "1.prems"(4)[symmetric]]
"1.prems" Cons ab cc3
            by auto
          then have IH: "cc_explain_aux2 cc (pending12 @ pending22 @ xs2')
\<subseteq> cc_explain_aux cc l xs \<union> additional_uf_labels_set l (pf_labels cc)"
            using hyps(1) in_bounds defs hyps subseq_xs subset by blast
          then show ?thesis
            using invariant rec' by auto
        qed
      qed
      then show ?thesis
        using hyps Un_iff set_subset_Cons Cons ab by blast
    qed
  qed
qed

theorem cc_explain_cc_explain2_equivalence:
  assumes "are_congruent cc (a \<approx> b)" "cc_invar_t cc_t" "valid_vars (a \<approx> b) (nr_vars cc)"
"cc = congruence_closure.truncate cc_t"
shows "cc_explain cc a b \<supseteq> cc_explain2 cc a b"
proof-
 have cc: "length (cc_list cc_t) = nr_vars cc" "cc_invar cc" using assms(2)
   unfolding congruence_closure.truncate_def congruence_closure.select_convs assms(4) by auto
  then have a_b: "\<forall>(a, b)\<in>set [(a, b)]. a < nr_vars cc \<and> b < nr_vars cc"
"\<forall>(a, b)\<in>set [(a, b)]. are_congruent cc (a \<approx> b)"
    using assms valid_vars.simps by auto
  have *: "additional_uf_pairs_set [0..<nr_vars cc] (pf_labels cc) = {}"
"additional_uf_labels_set [0..<nr_vars cc] (pf_labels cc) = {}"
    unfolding additional_uf_pairs_set_def additional_uf_labels_set_def by auto
  have eli: "explain_list_invar [0..<nr_vars cc] (proof_forest cc)"
    using cc explain_list_invar_initial unfolding same_length_invar_def
    by metis
  with a_b show ?thesis
    using cc_explain_aux_cc_explain_aux2_equivalence[OF assms(2) a_b assms(4) a_b eli equations_of_l_in_pending_invar_initial]
    * by blast
qed

subsection \<open>Correctness proof of \<open>cc_explain\<close>\<close>

theorem cc_explain_correctness:
  assumes "are_congruent cc (a \<approx> b)" "cc_invar_t cc_t" "valid_vars (a \<approx> b) (nr_vars cc)"
"cc = congruence_closure.truncate cc_t"
  shows "(a \<approx> b) \<in> Congruence_Closure (cc_explain cc a b)"
proof-
  have *: "(a \<approx> b) \<in> Congruence_Closure (cc_explain2 cc a b)"
    using cc_explain2_correctness cc_explain_cc_explain2_equivalence assms
    by blast
  then have "cc_explain2 cc a b \<subseteq> cc_explain cc a b"
    using cc_explain2_correctness cc_explain_cc_explain2_equivalence assms
    by blast
  then show ?thesis using *
    by (meson Congruence_Closure_monotonic in_mono)
qed

end


theory SASP_Checker
imports SASP_Semantics
  "HOL-Library.Code_Target_Nat"
begin

section \<open>An Executable Checker for Multi-Valued Planning Problem Solutions\<close>

  subsection \<open>Auxiliary Lemmas\<close>
  lemma map_of_leI:
    assumes "distinct (map fst l)"
    assumes "\<And>k v. (k,v)\<in>set l \<Longrightarrow> m k = Some v"
    shows "map_of l \<subseteq>\<^sub>m m"
    using assms
    by (metis (no_types, opaque_lifting) domIff map_le_def map_of_SomeD not_Some_eq)

  subsection \<open>Well-formedness Check\<close>
  lemmas wf_code_thms =
      ast_problem.astDom_def ast_problem.astI_def ast_problem.astG_def ast_problem.ast\<delta>_def
      ast_problem.numVars_def ast_problem.numVals_def
      ast_problem.wf_partial_state_def ast_problem.wf_operator_def ast_problem.well_formed_def

  declare wf_code_thms[code]

  export_code ast_problem.well_formed in SML

  subsection \<open>Execution\<close>

  definition match_pre :: "ast_precond \<Rightarrow> state \<Rightarrow> bool" where
    "match_pre \<equiv> \<lambda>(x,v) s. s x = Some v"

  definition match_pres :: "ast_precond list \<Rightarrow> state \<Rightarrow> bool" where
    "match_pres pres s \<equiv> \<forall>pre\<in>set pres. match_pre pre s"

  definition match_implicit_pres :: "ast_effect list \<Rightarrow> state \<Rightarrow> bool" where
    "match_implicit_pres effs s \<equiv> \<forall>(_,x,vp,_)\<in>set effs.
      (case vp of None \<Rightarrow> True | Some v \<Rightarrow> s x = Some v)"

  definition enabled_opr' :: "ast_operator \<Rightarrow> state \<Rightarrow> bool" where
    "enabled_opr' \<equiv> \<lambda>(name,pres,effs,cost) s. match_pres pres s \<and> match_implicit_pres effs s"

  definition eff_enabled' :: "state \<Rightarrow> ast_effect \<Rightarrow> bool" where
    "eff_enabled' s \<equiv> \<lambda>(pres,_,_,_). match_pres pres s"

  definition "execute_opr' \<equiv> \<lambda>(name,_,effs,_) s.
    let effs = filter (eff_enabled' s) effs
    in fold (\<lambda>(_,x,_,v) s. s(x\<mapsto>v)) effs s
  "

  definition lookup_operator' :: "ast_problem \<Rightarrow> name \<rightharpoonup> ast_operator"
    where "lookup_operator' \<equiv> \<lambda>(D,I,G,\<delta>) name. find (\<lambda>(n,_,_,_). n=name) \<delta>"

  definition enabled' :: "ast_problem \<Rightarrow> name \<Rightarrow> state \<Rightarrow> bool" where
    "enabled' problem name s \<equiv>
      case lookup_operator' problem name of
        Some \<pi> \<Rightarrow> enabled_opr' \<pi> s
      | None \<Rightarrow> False"

  definition execute' :: "ast_problem \<Rightarrow> name \<Rightarrow> state \<Rightarrow> state" where
    "execute' problem name s \<equiv>
      case lookup_operator' problem name of
        Some \<pi> \<Rightarrow> execute_opr' \<pi> s
      | None \<Rightarrow> undefined"

  context wf_ast_problem begin

    lemma match_pres_correct:
      assumes D: "distinct (map fst pres)"
      assumes "s\<in>valid_states"
      shows "match_pres pres s \<longleftrightarrow> s\<in>subsuming_states (map_of pres)"
    proof -
      have "match_pres pres s \<longleftrightarrow> map_of pres \<subseteq>\<^sub>m s"
        unfolding match_pres_def match_pre_def
        apply (auto split: prod.splits)
        using map_le_def map_of_SomeD apply fastforce
        by (metis (full_types) D domIff map_le_def map_of_eq_Some_iff option.simps(3))

      with assms show ?thesis
        unfolding subsuming_states_def
        by auto
    qed

    lemma match_implicit_pres_correct:
      assumes D: "distinct (map (\<lambda>(_, v, _, _). v) effs)"
      assumes "s\<in>valid_states"
      shows "match_implicit_pres effs s \<longleftrightarrow> s\<in>subsuming_states (map_of (implicit_pres effs))"
    proof -
      from assms show ?thesis
        unfolding subsuming_states_def
        unfolding match_implicit_pres_def implicit_pres_def
        apply (auto
            split: prod.splits option.splits
            simp: distinct_map_filter
            intro!: map_of_leI)
        apply (force simp: distinct_map_filter split: prod.split elim: map_mp)
        done
    qed

    lemma enabled_opr'_correct:
      assumes V: "s\<in>valid_states"
      assumes "lookup_operator name = Some \<pi>"
      shows "enabled_opr' \<pi> s \<longleftrightarrow> enabled name s"
      using lookup_operator_wf[OF assms(2)] assms
      unfolding enabled_opr'_def enabled_def wf_operator_def
      by (auto
          simp: match_pres_correct[OF _ V] match_implicit_pres_correct[OF _ V]
          simp: wf_partial_state_def
          split: option.split
          )

    lemma eff_enabled'_correct:
      assumes V: "s\<in>valid_states"
      assumes "case eff of (pres,_,_,_) \<Rightarrow> wf_partial_state pres"
      shows "eff_enabled' s eff \<longleftrightarrow> eff_enabled s eff"
      using assms
      unfolding eff_enabled'_def eff_enabled_def wf_partial_state_def
      by (auto simp: match_pres_correct)

    lemma execute_opr'_correct:
      assumes V: "s\<in>valid_states"
      assumes LO: "lookup_operator name = Some \<pi>"
      shows "execute_opr' \<pi> s = execute name s"
    proof (cases \<pi>)
      case [simp]: (fields name pres effs)

      have [simp]: "filter (eff_enabled' s) effs = filter (eff_enabled s) effs"
        apply (rule filter_cong[OF refl])
        apply (rule eff_enabled'_correct[OF V])
        using lookup_operator_wf[OF LO]
        unfolding wf_operator_def by auto

      have X1: "distinct (map fst (map (\<lambda>(_, x, _, y). (x, y)) (filter (eff_enabled s) effs)))"
        using lookup_operator_wf[OF LO]
        unfolding wf_operator_def
        by (auto simp: distinct_map_filter)

      term "filter (eff_enabled s) effs"

      have [simp]:
        "fold (\<lambda>(_, x, _, v) s. s(x \<mapsto> v)) l s =
         fold (\<lambda>(k, v) m. m(k \<mapsto> v)) (map (\<lambda>(_, x, _, y). (x, y)) l) s"
        for l :: "ast_effect list"
        by (induction l arbitrary: s) auto

      show ?thesis
        unfolding execute_opr'_def execute_def using LO
        by (auto simp: map_add_map_of_fold[OF X1])
    qed

    lemma lookup_operator'_correct:
      "lookup_operator' problem name = lookup_operator name"
      unfolding lookup_operator'_def lookup_operator_def
      unfolding ast\<delta>_def
      by (auto split: prod.split)

    lemma enabled'_correct:
      assumes V: "s\<in>valid_states"
      shows "enabled' problem name s = enabled name s"
      unfolding enabled'_def
      using enabled_opr'_correct[OF V]
      by (auto split: option.splits simp: enabled_def lookup_operator'_correct)

    lemma execute'_correct:
      assumes V: "s\<in>valid_states"
      assumes "enabled name s"      (* Intentionally put this here, also we could resolve non-enabled case by reflexivity (undefined=undefined) *)
      shows "execute' problem name s = execute name s"
      unfolding execute'_def
      using execute_opr'_correct[OF V] \<open>enabled name s\<close>
      by (auto split: option.splits simp: enabled_def lookup_operator'_correct)

  end

  context ast_problem
  begin

    fun simulate_plan :: "plan \<Rightarrow> state \<rightharpoonup> state" where
      "simulate_plan [] s = Some s"
    | "simulate_plan (\<pi>#\<pi>s) s = (
        if enabled \<pi> s then
          let s' = execute \<pi> s in
          simulate_plan \<pi>s s'
        else
          None
      )"

    lemma simulate_plan_correct: "simulate_plan \<pi>s s = Some s' \<longleftrightarrow> path_to s \<pi>s s'"
      by (induction s \<pi>s s' rule: path_to.induct) auto

    definition check_plan :: "plan \<Rightarrow> bool" where
      "check_plan \<pi>s = (
        case simulate_plan \<pi>s I of
          None \<Rightarrow> False
        | Some s' \<Rightarrow> s' \<in> G)"

    lemma check_plan_correct: "check_plan \<pi>s \<longleftrightarrow> valid_plan \<pi>s"
      unfolding check_plan_def valid_plan_def
      by (auto split: option.split simp: simulate_plan_correct[symmetric])

  end

  fun simulate_plan' :: "ast_problem \<Rightarrow> plan \<Rightarrow> state \<rightharpoonup> state" where
    "simulate_plan' problem [] s = Some s"
  | "simulate_plan' problem (\<pi>#\<pi>s) s = (
      if enabled' problem \<pi> s then
        let s = execute' problem \<pi> s in
        simulate_plan' problem \<pi>s s
      else
        None
    )"

  text \<open>Avoiding duplicate lookup.\<close>
  (*[code]  *)
  lemma simulate_plan'_code[code]:
    "simulate_plan' problem [] s = Some s"
    "simulate_plan' problem (\<pi>#\<pi>s) s = (
      case lookup_operator' problem \<pi> of
        None \<Rightarrow> None
      | Some \<pi> \<Rightarrow>
          if enabled_opr' \<pi> s then
            simulate_plan' problem \<pi>s (execute_opr' \<pi> s)
          else None
    )"
    by (auto simp: enabled'_def execute'_def split: option.split)

  definition initial_state' :: "ast_problem \<Rightarrow> state" where
    "initial_state' problem \<equiv> let astI = ast_problem.astI problem in (
       \<lambda>v. if v<length astI then Some (astI!v) else None
     )"

  definition check_plan' :: "ast_problem \<Rightarrow> plan \<Rightarrow> bool" where
    "check_plan' problem \<pi>s = (
      case simulate_plan' problem \<pi>s (initial_state' problem) of
        None \<Rightarrow> False
      | Some s' \<Rightarrow> match_pres (ast_problem.astG problem) s')"

  context wf_ast_problem
  begin

    lemma simulate_plan'_correct:
      assumes "s\<in>valid_states"
      shows "simulate_plan' problem \<pi>s s = simulate_plan \<pi>s s"
      using assms
      apply (induction \<pi>s s rule: simulate_plan.induct)
      apply (auto simp: enabled'_correct execute'_correct execute_preserves_valid)
      done

    lemma simulate_plan'_correct_paper: (* For presentation in paper.
        Summarizing intermediate refinement step. *)
      assumes "s\<in>valid_states"
      shows "simulate_plan' problem \<pi>s s = Some s'
            \<longleftrightarrow> path_to s \<pi>s s'"
      using simulate_plan'_correct[OF assms] simulate_plan_correct by simp

    lemma initial_state'_correct:
      "initial_state' problem = I"
      unfolding initial_state'_def I_def by (auto simp: Let_def)

    lemma check_plan'_correct:
      "check_plan' problem \<pi>s = check_plan \<pi>s"
    proof -
      have D: "distinct (map fst astG)" using wf_goal unfolding wf_partial_state_def by auto

      have S'V: "s'\<in>valid_states" if "simulate_plan \<pi>s I = Some s'" for s'
        using that by (auto simp: simulate_plan_correct path_to_pres_valid[OF I_valid])

      show ?thesis
        unfolding check_plan'_def check_plan_def
        by (auto
            split: option.splits
            simp: initial_state'_correct simulate_plan'_correct[OF I_valid]
            simp: match_pres_correct[OF D S'V] G_def
            )
    qed

  end

  (* Overall checker *)

  definition verify_plan :: "ast_problem \<Rightarrow> plan \<Rightarrow> String.literal + unit" where
    "verify_plan problem \<pi>s = (
      if ast_problem.well_formed problem then
        if check_plan' problem \<pi>s then Inr () else Inl (STR ''Invalid plan'')
      else Inl (STR ''Problem not well formed'')
    )"

  lemma verify_plan_correct:
    "verify_plan problem \<pi>s = Inr ()
    \<longleftrightarrow> ast_problem.well_formed problem \<and> ast_problem.valid_plan problem \<pi>s"
  proof -
    {
      assume "ast_problem.well_formed problem"
      then interpret wf_ast_problem by unfold_locales

      from check_plan'_correct check_plan_correct
      have "check_plan' problem \<pi>s = valid_plan \<pi>s" by simp
    }
    then show ?thesis
      unfolding verify_plan_def
      by auto
  qed

  definition nat_opt_of_integer :: "integer \<Rightarrow> nat option" where
       "nat_opt_of_integer i = (if (i \<ge> 0) then Some (nat_of_integer i) else None)"

  (*Export functions, which includes constructors*)
  export_code verify_plan nat_of_integer integer_of_nat nat_opt_of_integer Inl Inr String.explode String.implode
    in SML
    module_name SASP_Checker_Exported

end


(*  Title:      HOL/Lifting.thy
    Author:     Brian Huffman and Ondrej Kuncar
    Author:     Cezary Kaliszyk and Christian Urban
*)

section {* Lifting package *}

theory Lifting
imports Equiv_Relations Transfer
keywords
  "parametric" and
  "print_quot_maps" "print_quotients" :: diag and
  "lift_definition" :: thy_goal and
  "setup_lifting" "lifting_forget" "lifting_update" :: thy_decl
begin

subsection {* Function map *}

context
begin
interpretation lifting_syntax .

lemma map_fun_id:
  "(id ---> id) = id"
  by (simp add: fun_eq_iff)

subsection {* Quotient Predicate *}

definition
  "Quotient R Abs Rep T \<longleftrightarrow>
     (\<forall>a. Abs (Rep a) = a) \<and>
     (\<forall>a. R (Rep a) (Rep a)) \<and>
     (\<forall>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s) \<and>
     T = (\<lambda>x y. R x x \<and> Abs x = y)"

lemma QuotientI:
  assumes "\<And>a. Abs (Rep a) = a"
    and "\<And>a. R (Rep a) (Rep a)"
    and "\<And>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s"
    and "T = (\<lambda>x y. R x x \<and> Abs x = y)"
  shows "Quotient R Abs Rep T"
  using assms unfolding Quotient_def by blast

context
  fixes R Abs Rep T
  assumes a: "Quotient R Abs Rep T"
begin

lemma Quotient_abs_rep: "Abs (Rep a) = a"
  using a unfolding Quotient_def
  by simp

lemma Quotient_rep_reflp: "R (Rep a) (Rep a)"
  using a unfolding Quotient_def
  by blast

lemma Quotient_rel:
  "R r r \<and> R s s \<and> Abs r = Abs s \<longleftrightarrow> R r s" -- {* orientation does not loop on rewriting *}
  using a unfolding Quotient_def
  by blast

lemma Quotient_cr_rel: "T = (\<lambda>x y. R x x \<and> Abs x = y)"
  using a unfolding Quotient_def
  by blast

lemma Quotient_refl1: "R r s \<Longrightarrow> R r r"
  using a unfolding Quotient_def
  by fast

lemma Quotient_refl2: "R r s \<Longrightarrow> R s s"
  using a unfolding Quotient_def
  by fast

lemma Quotient_rel_rep: "R (Rep a) (Rep b) \<longleftrightarrow> a = b"
  using a unfolding Quotient_def
  by metis

lemma Quotient_rep_abs: "R r r \<Longrightarrow> R (Rep (Abs r)) r"
  using a unfolding Quotient_def
  by blast

lemma Quotient_rep_abs_eq: "R t t \<Longrightarrow> R \<le> op= \<Longrightarrow> Rep (Abs t) = t"
  using a unfolding Quotient_def
  by blast

lemma Quotient_rep_abs_fold_unmap:
  assumes "x' \<equiv> Abs x" and "R x x" and "Rep x' \<equiv> Rep' x'"
  shows "R (Rep' x') x"
proof -
  have "R (Rep x') x" using assms(1-2) Quotient_rep_abs by auto
  then show ?thesis using assms(3) by simp
qed

lemma Quotient_Rep_eq:
  assumes "x' \<equiv> Abs x"
  shows "Rep x' \<equiv> Rep x'"
by simp

lemma Quotient_rel_abs: "R r s \<Longrightarrow> Abs r = Abs s"
  using a unfolding Quotient_def
  by blast

lemma Quotient_rel_abs2:
  assumes "R (Rep x) y"
  shows "x = Abs y"
proof -
  from assms have "Abs (Rep x) = Abs y" by (auto intro: Quotient_rel_abs)
  then show ?thesis using assms(1) by (simp add: Quotient_abs_rep)
qed

lemma Quotient_symp: "symp R"
  using a unfolding Quotient_def using sympI by (metis (full_types))

lemma Quotient_transp: "transp R"
  using a unfolding Quotient_def using transpI by (metis (full_types))

lemma Quotient_part_equivp: "part_equivp R"
by (metis Quotient_rep_reflp Quotient_symp Quotient_transp part_equivpI)

end

lemma identity_quotient: "Quotient (op =) id id (op =)"
unfolding Quotient_def by simp

text {* TODO: Use one of these alternatives as the real definition. *}

lemma Quotient_alt_def:
  "Quotient R Abs Rep T \<longleftrightarrow>
    (\<forall>a b. T a b \<longrightarrow> Abs a = b) \<and>
    (\<forall>b. T (Rep b) b) \<and>
    (\<forall>x y. R x y \<longleftrightarrow> T x (Abs x) \<and> T y (Abs y) \<and> Abs x = Abs y)"
apply safe
apply (simp (no_asm_use) only: Quotient_def, fast)
apply (simp (no_asm_use) only: Quotient_def, fast)
apply (simp (no_asm_use) only: Quotient_def, fast)
apply (simp (no_asm_use) only: Quotient_def, fast)
apply (simp (no_asm_use) only: Quotient_def, fast)
apply (simp (no_asm_use) only: Quotient_def, fast)
apply (rule QuotientI)
apply simp
apply metis
apply simp
apply (rule ext, rule ext, metis)
done

lemma Quotient_alt_def2:
  "Quotient R Abs Rep T \<longleftrightarrow>
    (\<forall>a b. T a b \<longrightarrow> Abs a = b) \<and>
    (\<forall>b. T (Rep b) b) \<and>
    (\<forall>x y. R x y \<longleftrightarrow> T x (Abs y) \<and> T y (Abs x))"
  unfolding Quotient_alt_def by (safe, metis+)

lemma Quotient_alt_def3:
  "Quotient R Abs Rep T \<longleftrightarrow>
    (\<forall>a b. T a b \<longrightarrow> Abs a = b) \<and> (\<forall>b. T (Rep b) b) \<and>
    (\<forall>x y. R x y \<longleftrightarrow> (\<exists>z. T x z \<and> T y z))"
  unfolding Quotient_alt_def2 by (safe, metis+)

lemma Quotient_alt_def4:
  "Quotient R Abs Rep T \<longleftrightarrow>
    (\<forall>a b. T a b \<longrightarrow> Abs a = b) \<and> (\<forall>b. T (Rep b) b) \<and> R = T OO conversep T"
  unfolding Quotient_alt_def3 fun_eq_iff by auto

lemma Quotient_alt_def5:
  "Quotient R Abs Rep T \<longleftrightarrow>
    T \<le> BNF_Def.Grp UNIV Abs \<and> BNF_Def.Grp UNIV Rep \<le> T\<inverse>\<inverse> \<and> R = T OO T\<inverse>\<inverse>"
  unfolding Quotient_alt_def4 Grp_def by blast

lemma fun_quotient:
  assumes 1: "Quotient R1 abs1 rep1 T1"
  assumes 2: "Quotient R2 abs2 rep2 T2"
  shows "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2) (T1 ===> T2)"
  using assms unfolding Quotient_alt_def2
  unfolding rel_fun_def fun_eq_iff map_fun_apply
  by (safe, metis+)

lemma apply_rsp:
  fixes f g::"'a \<Rightarrow> 'c"
  assumes q: "Quotient R1 Abs1 Rep1 T1"
  and     a: "(R1 ===> R2) f g" "R1 x y"
  shows "R2 (f x) (g y)"
  using a by (auto elim: rel_funE)

lemma apply_rsp':
  assumes a: "(R1 ===> R2) f g" "R1 x y"
  shows "R2 (f x) (g y)"
  using a by (auto elim: rel_funE)

lemma apply_rsp'':
  assumes "Quotient R Abs Rep T"
  and "(R ===> S) f f"
  shows "S (f (Rep x)) (f (Rep x))"
proof -
  from assms(1) have "R (Rep x) (Rep x)" by (rule Quotient_rep_reflp)
  then show ?thesis using assms(2) by (auto intro: apply_rsp')
qed

subsection {* Quotient composition *}

lemma Quotient_compose:
  assumes 1: "Quotient R1 Abs1 Rep1 T1"
  assumes 2: "Quotient R2 Abs2 Rep2 T2"
  shows "Quotient (T1 OO R2 OO conversep T1) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2) (T1 OO T2)"
  using assms unfolding Quotient_alt_def4 by fastforce

lemma equivp_reflp2:
  "equivp R \<Longrightarrow> reflp R"
  by (erule equivpE)

subsection {* Respects predicate *}

definition Respects :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set"
  where "Respects R = {x. R x x}"

lemma in_respects: "x \<in> Respects R \<longleftrightarrow> R x x"
  unfolding Respects_def by simp

lemma UNIV_typedef_to_Quotient:
  assumes "type_definition Rep Abs UNIV"
  and T_def: "T \<equiv> (\<lambda>x y. x = Rep y)"
  shows "Quotient (op =) Abs Rep T"
proof -
  interpret type_definition Rep Abs UNIV by fact
  from Abs_inject Rep_inverse Abs_inverse T_def show ?thesis
    by (fastforce intro!: QuotientI fun_eq_iff)
qed

lemma UNIV_typedef_to_equivp:
  fixes Abs :: "'a \<Rightarrow> 'b"
  and Rep :: "'b \<Rightarrow> 'a"
  assumes "type_definition Rep Abs (UNIV::'a set)"
  shows "equivp (op=::'a\<Rightarrow>'a\<Rightarrow>bool)"
by (rule identity_equivp)

lemma typedef_to_Quotient:
  assumes "type_definition Rep Abs S"
  and T_def: "T \<equiv> (\<lambda>x y. x = Rep y)"
  shows "Quotient (eq_onp (\<lambda>x. x \<in> S)) Abs Rep T"
proof -
  interpret type_definition Rep Abs S by fact
  from Rep Abs_inject Rep_inverse Abs_inverse T_def show ?thesis
    by (auto intro!: QuotientI simp: eq_onp_def fun_eq_iff)
qed

lemma typedef_to_part_equivp:
  assumes "type_definition Rep Abs S"
  shows "part_equivp (eq_onp (\<lambda>x. x \<in> S))"
proof (intro part_equivpI)
  interpret type_definition Rep Abs S by fact
  show "\<exists>x. eq_onp (\<lambda>x. x \<in> S) x x" using Rep by (auto simp: eq_onp_def)
next
  show "symp (eq_onp (\<lambda>x. x \<in> S))" by (auto intro: sympI simp: eq_onp_def)
next
  show "transp (eq_onp (\<lambda>x. x \<in> S))" by (auto intro: transpI simp: eq_onp_def)
qed

lemma open_typedef_to_Quotient:
  assumes "type_definition Rep Abs {x. P x}"
  and T_def: "T \<equiv> (\<lambda>x y. x = Rep y)"
  shows "Quotient (eq_onp P) Abs Rep T"
  using typedef_to_Quotient [OF assms] by simp

lemma open_typedef_to_part_equivp:
  assumes "type_definition Rep Abs {x. P x}"
  shows "part_equivp (eq_onp P)"
  using typedef_to_part_equivp [OF assms] by simp

text {* Generating transfer rules for quotients. *}

context
  fixes R Abs Rep T
  assumes 1: "Quotient R Abs Rep T"
begin

lemma Quotient_right_unique: "right_unique T"
  using 1 unfolding Quotient_alt_def right_unique_def by metis

lemma Quotient_right_total: "right_total T"
  using 1 unfolding Quotient_alt_def right_total_def by metis

lemma Quotient_rel_eq_transfer: "(T ===> T ===> op =) R (op =)"
  using 1 unfolding Quotient_alt_def rel_fun_def by simp

lemma Quotient_abs_induct:
  assumes "\<And>y. R y y \<Longrightarrow> P (Abs y)" shows "P x"
  using 1 assms unfolding Quotient_def by metis

end

text {* Generating transfer rules for total quotients. *}

context
  fixes R Abs Rep T
  assumes 1: "Quotient R Abs Rep T" and 2: "reflp R"
begin

lemma Quotient_left_total: "left_total T"
  using 1 2 unfolding Quotient_alt_def left_total_def reflp_def by auto

lemma Quotient_bi_total: "bi_total T"
  using 1 2 unfolding Quotient_alt_def bi_total_def reflp_def by auto

lemma Quotient_id_abs_transfer: "(op = ===> T) (\<lambda>x. x) Abs"
  using 1 2 unfolding Quotient_alt_def reflp_def rel_fun_def by simp

lemma Quotient_total_abs_induct: "(\<And>y. P (Abs y)) \<Longrightarrow> P x"
  using 1 2 assms unfolding Quotient_alt_def reflp_def by metis

lemma Quotient_total_abs_eq_iff: "Abs x = Abs y \<longleftrightarrow> R x y"
  using Quotient_rel [OF 1] 2 unfolding reflp_def by simp

end

text {* Generating transfer rules for a type defined with @{text "typedef"}. *}

context
  fixes Rep Abs A T
  assumes type: "type_definition Rep Abs A"
  assumes T_def: "T \<equiv> (\<lambda>(x::'a) (y::'b). x = Rep y)"
begin

lemma typedef_left_unique: "left_unique T"
  unfolding left_unique_def T_def
  by (simp add: type_definition.Rep_inject [OF type])

lemma typedef_bi_unique: "bi_unique T"
  unfolding bi_unique_def T_def
  by (simp add: type_definition.Rep_inject [OF type])

(* the following two theorems are here only for convinience *)

lemma typedef_right_unique: "right_unique T"
  using T_def type Quotient_right_unique typedef_to_Quotient
  by blast

lemma typedef_right_total: "right_total T"
  using T_def type Quotient_right_total typedef_to_Quotient
  by blast

lemma typedef_rep_transfer: "(T ===> op =) (\<lambda>x. x) Rep"
  unfolding rel_fun_def T_def by simp

end

text {* Generating the correspondence rule for a constant defined with
  @{text "lift_definition"}. *}

lemma Quotient_to_transfer:
  assumes "Quotient R Abs Rep T" and "R c c" and "c' \<equiv> Abs c"
  shows "T c c'"
  using assms by (auto dest: Quotient_cr_rel)

text {* Proving reflexivity *}

lemma Quotient_to_left_total:
  assumes q: "Quotient R Abs Rep T"
  and r_R: "reflp R"
  shows "left_total T"
using r_R Quotient_cr_rel[OF q] unfolding left_total_def by (auto elim: reflpE)

lemma Quotient_composition_ge_eq:
  assumes "left_total T"
  assumes "R \<ge> op="
  shows "(T OO R OO T\<inverse>\<inverse>) \<ge> op="
using assms unfolding left_total_def by fast

lemma Quotient_composition_le_eq:
  assumes "left_unique T"
  assumes "R \<le> op="
  shows "(T OO R OO T\<inverse>\<inverse>) \<le> op="
using assms unfolding left_unique_def by blast

lemma eq_onp_le_eq:
  "eq_onp P \<le> op=" unfolding eq_onp_def by blast

lemma reflp_ge_eq:
  "reflp R \<Longrightarrow> R \<ge> op=" unfolding reflp_def by blast

lemma ge_eq_refl:
  "R \<ge> op= \<Longrightarrow> R x x" by blast

text {* Proving a parametrized correspondence relation *}

definition POS :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool" where
"POS A B \<equiv> A \<le> B"

definition  NEG :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool" where
"NEG A B \<equiv> B \<le> A"

lemma pos_OO_eq:
  shows "POS (A OO op=) A"
unfolding POS_def OO_def by blast

lemma pos_eq_OO:
  shows "POS (op= OO A) A"
unfolding POS_def OO_def by blast

lemma neg_OO_eq:
  shows "NEG (A OO op=) A"
unfolding NEG_def OO_def by auto

lemma neg_eq_OO:
  shows "NEG (op= OO A) A"
unfolding NEG_def OO_def by blast

lemma POS_trans:
  assumes "POS A B"
  assumes "POS B C"
  shows "POS A C"
using assms unfolding POS_def by auto

lemma NEG_trans:
  assumes "NEG A B"
  assumes "NEG B C"
  shows "NEG A C"
using assms unfolding NEG_def by auto

lemma POS_NEG:
  "POS A B \<equiv> NEG B A"
  unfolding POS_def NEG_def by auto

lemma NEG_POS:
  "NEG A B \<equiv> POS B A"
  unfolding POS_def NEG_def by auto

lemma POS_pcr_rule:
  assumes "POS (A OO B) C"
  shows "POS (A OO B OO X) (C OO X)"
using assms unfolding POS_def OO_def by blast

lemma NEG_pcr_rule:
  assumes "NEG (A OO B) C"
  shows "NEG (A OO B OO X) (C OO X)"
using assms unfolding NEG_def OO_def by blast

lemma POS_apply:
  assumes "POS R R'"
  assumes "R f g"
  shows "R' f g"
using assms unfolding POS_def by auto

text {* Proving a parametrized correspondence relation *}

lemma fun_mono:
  assumes "A \<ge> C"
  assumes "B \<le> D"
  shows   "(A ===> B) \<le> (C ===> D)"
using assms unfolding rel_fun_def by blast

lemma pos_fun_distr: "((R ===> S) OO (R' ===> S')) \<le> ((R OO R') ===> (S OO S'))"
unfolding OO_def rel_fun_def by blast

lemma functional_relation: "right_unique R \<Longrightarrow> left_total R \<Longrightarrow> \<forall>x. \<exists>!y. R x y"
unfolding right_unique_def left_total_def by blast

lemma functional_converse_relation: "left_unique R \<Longrightarrow> right_total R \<Longrightarrow> \<forall>y. \<exists>!x. R x y"
unfolding left_unique_def right_total_def by blast

lemma neg_fun_distr1:
assumes 1: "left_unique R" "right_total R"
assumes 2: "right_unique R'" "left_total R'"
shows "(R OO R' ===> S OO S') \<le> ((R ===> S) OO (R' ===> S')) "
  using functional_relation[OF 2] functional_converse_relation[OF 1]
  unfolding rel_fun_def OO_def
  apply clarify
  apply (subst all_comm)
  apply (subst all_conj_distrib[symmetric])
  apply (intro choice)
  by metis

lemma neg_fun_distr2:
assumes 1: "right_unique R'" "left_total R'"
assumes 2: "left_unique S'" "right_total S'"
shows "(R OO R' ===> S OO S') \<le> ((R ===> S) OO (R' ===> S'))"
  using functional_converse_relation[OF 2] functional_relation[OF 1]
  unfolding rel_fun_def OO_def
  apply clarify
  apply (subst all_comm)
  apply (subst all_conj_distrib[symmetric])
  apply (intro choice)
  by metis

subsection {* Domains *}

lemma composed_equiv_rel_eq_onp:
  assumes "left_unique R"
  assumes "(R ===> op=) P P'"
  assumes "Domainp R = P''"
  shows "(R OO eq_onp P' OO R\<inverse>\<inverse>) = eq_onp (inf P'' P)"
using assms unfolding OO_def conversep_iff Domainp_iff[abs_def] left_unique_def rel_fun_def eq_onp_def
fun_eq_iff by blast

lemma composed_equiv_rel_eq_eq_onp:
  assumes "left_unique R"
  assumes "Domainp R = P"
  shows "(R OO op= OO R\<inverse>\<inverse>) = eq_onp P"
using assms unfolding OO_def conversep_iff Domainp_iff[abs_def] left_unique_def eq_onp_def
fun_eq_iff is_equality_def by metis

lemma pcr_Domainp_par_left_total:
  assumes "Domainp B = P"
  assumes "left_total A"
  assumes "(A ===> op=) P' P"
  shows "Domainp (A OO B) = P'"
using assms
unfolding Domainp_iff[abs_def] OO_def bi_unique_def left_total_def rel_fun_def
by (fast intro: fun_eq_iff)

lemma pcr_Domainp_par:
assumes "Domainp B = P2"
assumes "Domainp A = P1"
assumes "(A ===> op=) P2' P2"
shows "Domainp (A OO B) = (inf P1 P2')"
using assms unfolding rel_fun_def Domainp_iff[abs_def] OO_def
by (fast intro: fun_eq_iff)

definition rel_pred_comp :: "('a => 'b => bool) => ('b => bool) => 'a => bool"
where "rel_pred_comp R P \<equiv> \<lambda>x. \<exists>y. R x y \<and> P y"

lemma pcr_Domainp:
assumes "Domainp B = P"
shows "Domainp (A OO B) = (\<lambda>x. \<exists>y. A x y \<and> P y)"
using assms by blast

lemma pcr_Domainp_total:
  assumes "left_total B"
  assumes "Domainp A = P"
  shows "Domainp (A OO B) = P"
using assms unfolding left_total_def
by fast

lemma Quotient_to_Domainp:
  assumes "Quotient R Abs Rep T"
  shows "Domainp T = (\<lambda>x. R x x)"
by (simp add: Domainp_iff[abs_def] Quotient_cr_rel[OF assms])

lemma eq_onp_to_Domainp:
  assumes "Quotient (eq_onp P) Abs Rep T"
  shows "Domainp T = P"
by (simp add: eq_onp_def Domainp_iff[abs_def] Quotient_cr_rel[OF assms])

end

subsection {* ML setup *}

ML_file "Tools/Lifting/lifting_util.ML"

named_theorems relator_eq_onp
  "theorems that a relator of an eq_onp is an eq_onp of the corresponding predicate"
ML_file "Tools/Lifting/lifting_info.ML"

(* setup for the function type *)
declare fun_quotient[quot_map]
declare fun_mono[relator_mono]
lemmas [relator_distr] = pos_fun_distr neg_fun_distr1 neg_fun_distr2

ML_file "Tools/Lifting/lifting_bnf.ML"
ML_file "Tools/Lifting/lifting_term.ML"
ML_file "Tools/Lifting/lifting_def.ML"
ML_file "Tools/Lifting/lifting_setup.ML"

hide_const (open) POS NEG

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Early_Tau_Chain
  imports Early_Semantics
begin

abbreviation tauChain :: "pi \<Rightarrow> pi \<Rightarrow> bool" ("_ \<Longrightarrow>\<^sub>\<tau> _" [80, 80] 80)
  where "P \<Longrightarrow>\<^sub>\<tau> P' \<equiv> (P, P') \<in> {(P, P') | P P'. P \<longmapsto>\<tau> \<prec> P'}^*"

lemma tauActTauChain:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<longmapsto>\<tau> \<prec> P'"

  shows "P \<Longrightarrow>\<^sub>\<tau> P'"
using assms
by auto

lemma tauChainAddTau[intro]:
  fixes P   :: pi
  and   P'  :: pi
  and   P'' :: pi

  shows "P \<Longrightarrow>\<^sub>\<tau> P' \<Longrightarrow> P' \<longmapsto>\<tau> \<prec> P'' \<Longrightarrow> P \<Longrightarrow>\<^sub>\<tau> P''"
  and "P \<longmapsto>\<tau> \<prec> P' \<Longrightarrow> P' \<Longrightarrow>\<^sub>\<tau> P'' \<Longrightarrow> P \<Longrightarrow>\<^sub>\<tau> P''"
by(auto dest: tauActTauChain)

lemma tauChainInduct[consumes 1, case_names id ih]:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "F P"
  and     "\<And>P'' P'''. \<lbrakk>P \<Longrightarrow>\<^sub>\<tau> P''; P'' \<longmapsto>\<tau> \<prec> P'''; F P''\<rbrakk> \<Longrightarrow> F P'''"

  shows "F P'"
using assms
by(drule_tac rtrancl_induct) auto

lemma eqvtChainI:
  fixes P    :: pi
  and   P'   :: pi
  and   perm :: "name prm"

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "(perm \<bullet> P) \<Longrightarrow>\<^sub>\<tau> (perm \<bullet> P')"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih P'' P''')
  have "P \<Longrightarrow>\<^sub>\<tau> P''" and "P'' \<longmapsto> \<tau> \<prec> P'''" by fact+
  hence "(perm \<bullet> P'') \<longmapsto>\<tau> \<prec> (perm \<bullet> P''')" by(drule_tac TransitionsEarly.eqvt) auto
  moreover have "(perm \<bullet> P) \<Longrightarrow>\<^sub>\<tau> (perm \<bullet> P'')" by fact
  ultimately show ?case by(force dest: tauActTauChain)
qed

lemma eqvtChainE:
  fixes perm :: "name prm"
  and   P    :: pi
  and   P'   :: pi

  assumes Trans: "(perm \<bullet> P) \<Longrightarrow>\<^sub>\<tau> (perm \<bullet> P')"

  shows   "P \<Longrightarrow>\<^sub>\<tau> P'"
proof -
  have "rev perm \<bullet> (perm \<bullet> P) = P" by(simp add: pt_rev_pi[OF pt_name_inst, OF at_name_inst])
  moreover have "rev perm \<bullet> (perm \<bullet> P') = P'" by(simp add: pt_rev_pi[OF pt_name_inst, OF at_name_inst])
  ultimately show ?thesis using assms
    by(drule_tac perm="rev perm" in eqvtChainI, simp)
qed

lemma eqvtChainEq:
  fixes P    :: pi
  and   P'   :: pi
  and   perm :: "name prm"

  shows   "P \<Longrightarrow>\<^sub>\<tau> P' = (perm \<bullet> P) \<Longrightarrow>\<^sub>\<tau> (perm \<bullet> P')"
by(blast intro: eqvtChainE eqvtChainI)

lemma freshChain:
  fixes P  :: pi
  and   P' :: pi
  and   x  :: name

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "x \<sharp> P"

  shows   "x \<sharp> P'"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih P' P'')
  have "x \<sharp> P" and "x \<sharp> P \<Longrightarrow> x \<sharp> P'" by fact+
  hence "x \<sharp> P'" by simp
  moreover have "P' \<longmapsto> \<tau> \<prec> P''" by fact
  ultimately show ?case by(force intro: freshTransition)
qed

lemma matchChain:
  fixes b :: name
  and   P :: pi
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P \<noteq> P'"

  shows "[b\<frown>b]P \<Longrightarrow>\<^sub>\<tau> P'"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih P'' P''')
  have P''TransP''':  "P'' \<longmapsto>\<tau> \<prec> P'''"  by fact
  show "[b\<frown>b]P \<Longrightarrow>\<^sub>\<tau> P'''"
  proof(cases "P = P''")
    assume "P=P''"
    moreover with P''TransP''' have "[b\<frown>b]P \<longmapsto>\<tau> \<prec> P'''" by(force intro: Match)
    thus "[b\<frown>b]P \<Longrightarrow>\<^sub>\<tau> P'''" by(rule tauActTauChain)
  next
    assume "P \<noteq> P''"
    moreover have "P \<noteq> P'' \<Longrightarrow> [b\<frown>b]P \<Longrightarrow>\<^sub>\<tau> P''" by fact
    ultimately show "[b\<frown>b]P \<Longrightarrow>\<^sub>\<tau> P'''" using P''TransP''' by(blast)
  qed
qed

lemma mismatchChain:
  fixes a :: name
  and   b :: name
  and   P :: pi
  and   P' :: pi

  assumes PChain: "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     aineqb: "a \<noteq> b"
  and     PineqP': "P \<noteq> P'"

  shows "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> P'"
proof -
  from PChain PineqP' show ?thesis
  proof(induct rule: tauChainInduct)
    case id
    thus ?case by simp
  next
    case(ih P'' P''')
    have P''TransP''':  "P'' \<longmapsto>\<tau> \<prec> P'''"  by fact
    show "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> P'''"
    proof(cases "P = P''")
      assume "P=P''"
      moreover with aineqb P''TransP''' have "[a\<noteq>b]P \<longmapsto>\<tau> \<prec> P'''" by(force intro: Mismatch)
      thus "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> P'''" by(rule tauActTauChain)
    next
      assume "P \<noteq> P''"
      moreover have "P \<noteq> P'' \<Longrightarrow> [a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> P''" by fact
      ultimately show "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> P'''" using P''TransP''' by(blast)
    qed
  qed
qed

lemma sum1Chain:
  fixes P  :: pi
  and   P' :: pi
  and   Q  :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P \<noteq> P'"

  shows "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih P'' P''')
  have P''TransP''':  "P'' \<longmapsto>\<tau> \<prec> P'''" by fact
  show "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'''"
  proof(cases "P = P''")
    assume "P=P''"
    moreover with P''TransP''' have "P \<oplus> Q \<longmapsto>\<tau> \<prec> P'''" by(force intro: Sum1)
    thus "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'''" by(force intro: tauActTauChain)
  next
    assume "P \<noteq> P''"
    moreover have "P \<noteq> P'' \<Longrightarrow> P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P''" by fact
    ultimately show "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'''" using P''TransP''' by(force dest: tauActTauChain)
  qed
qed

lemma sum2Chain:
  fixes P  :: pi
  and   Q :: pi
  and   Q'  :: pi

  assumes "Q \<Longrightarrow>\<^sub>\<tau> Q'"
  and     "Q \<noteq> Q'"

  shows "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih Q'' Q''')
  have Q''TransQ''':  "Q'' \<longmapsto>\<tau> \<prec> Q'''" by fact
  show "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'''"
  proof(cases "Q = Q''")
    assume "Q=Q''"
    moreover with Q''TransQ''' have "P \<oplus> Q \<longmapsto>\<tau> \<prec> Q'''" by(force intro: Sum2)
    thus "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'''" by(force intro: tauActTauChain)
  next
    assume "Q \<noteq> Q''"
    moreover have "Q \<noteq> Q'' \<Longrightarrow> P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q''" by fact
    ultimately show "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'''" using Q''TransQ''' by blast
  qed
qed

lemma Par1Chain:
  fixes P  :: pi
  and   P' :: pi
  and   Q  :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih P'' P')
  have P''TransP':  "P'' \<longmapsto>\<tau> \<prec> P'" by fact
  have IH: "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P'' \<parallel> Q" by fact

  have "P'' \<parallel> Q \<longmapsto>\<tau> \<prec> P' \<parallel> Q" using P''TransP' by(force intro: Par1F)
  thus "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q" using IH by(force dest: tauActTauChain)
qed

lemma Par2Chain:
  fixes P  :: pi
  and   Q  :: pi
  and   Q' :: pi

  assumes "Q \<Longrightarrow>\<^sub>\<tau> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih Q'' Q')
  have Q''TransQ':  "Q'' \<longmapsto>\<tau> \<prec> Q'" by fact
  have IH: "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q''" by fact

  have "P \<parallel> Q'' \<longmapsto>\<tau> \<prec> P \<parallel> Q'" using Q''TransQ' by(force intro: Par2F)
  thus "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'" using IH by(force dest: tauActTauChain)
qed

lemma chainPar:
  fixes P  :: pi
  and   P' :: pi
  and   Q  :: pi
  and   Q' :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "Q \<Longrightarrow>\<^sub>\<tau> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q'"
proof -
  from \<open>P \<Longrightarrow>\<^sub>\<tau> P'\<close> have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q" by(rule Par1Chain)
  moreover from \<open>Q \<Longrightarrow>\<^sub>\<tau> Q'\<close> have "P' \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q'" by(rule Par2Chain)
  ultimately show ?thesis by auto
qed

lemma ResChain:
  fixes P  :: pi
  and   P' :: pi
  and   a  :: name

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "<\<nu>a>P \<Longrightarrow>\<^sub>\<tau> <\<nu>a>P'"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih P'' P''')
  have "P'' \<longmapsto>\<tau> \<prec> P'''" by fact
  hence "<\<nu>a>P'' \<longmapsto>\<tau> \<prec> <\<nu>a>P'''" by(force intro: ResF)
  moreover have "<\<nu>a>P \<Longrightarrow>\<^sub>\<tau> <\<nu>a>P''" by fact
  ultimately show ?case by(force dest: tauActTauChain)
qed

lemma substChain:
  fixes P  :: pi
  and   x  :: name
  and   b  :: name
  and   P' :: pi

  assumes PTrans: "P[x::=b] \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P[x::=b] \<Longrightarrow>\<^sub>\<tau> P'[x::=b]"
proof(cases "x=b")
  assume "x = b"
  with PTrans show ?thesis by simp
next
  assume "x \<noteq> b"
  hence "x \<sharp> P[x::=b]" by(simp add: fresh_fact2)
  with PTrans have "x \<sharp> P'" by(force intro: freshChain)
  hence "P' = P'[x::=b]" by(simp add: forget)
  with PTrans show ?thesis by simp
qed

lemma bangChain:
  fixes P  :: pi
  and   P' :: pi

  assumes PTrans: "P \<parallel> !P \<Longrightarrow>\<^sub>\<tau> P'"
  and     P'ineq: "P' \<noteq> P \<parallel> !P"

  shows "!P \<Longrightarrow>\<^sub>\<tau> P'"
using assms
proof(induct rule: tauChainInduct)
  case id
  thus ?case by simp
next
  case(ih P' P'')
  show ?case
  proof(cases "P' = P \<parallel> !P")
    case True
    from \<open>P' \<longmapsto>\<tau> \<prec> P''\<close> \<open>P' = P \<parallel> !P\<close> have "!P \<longmapsto>\<tau> \<prec> P''" by(blast intro: Bang)
    thus ?thesis by auto
  next
    case False
    from \<open>P' \<noteq> P \<parallel> !P\<close> have "!P \<Longrightarrow>\<^sub>\<tau> P'" by(rule ih)
    with \<open>P' \<longmapsto>\<tau> \<prec> P''\<close> show ?thesis by(auto dest: tauActTauChain)
  qed
qed

end