section \<open>(Multihole)Context closure of recognized tree languages\<close>

theory TA_Clousure_Const
  imports Tree_Automata_Derivation_Split
begin

subsection \<open>Tree Automata closure constructions\<close>
declare ta_union_def [simp]
subsubsection \<open>Reflexive closure over a given signature\<close>

definition "reflcl_rules \<F> q \<equiv> (\<lambda> (f, n). TA_rule f (replicate n q) q) |`| \<F>"
definition "refl_ta \<F> q = TA (reflcl_rules \<F> q) {||}"

definition gen_reflcl_automaton :: "('f \<times> nat) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q \<Rightarrow> ('q, 'f) ta" where
  "gen_reflcl_automaton \<F> \<A> q = ta_union \<A> (refl_ta \<F> q)"

definition "reflcl_automaton \<F> \<A> = (let \<B> = fmap_states_ta Some \<A> in
   gen_reflcl_automaton \<F> \<B> None)"

definition "reflcl_reg \<F> \<A> = Reg (finsert None (Some |`| fin \<A>)) (reflcl_automaton \<F> (ta \<A>))"

subsubsection \<open>Multihole context closure over a given signature\<close>

definition "refl_over_states_ta Q \<F> \<A> q = TA (reflcl_rules \<F> q) ((\<lambda> p. (p, q)) |`| (Q |\<inter>| \<Q> \<A>))"

definition gen_parallel_closure_automaton :: "'q fset \<Rightarrow> ('f \<times> nat) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q \<Rightarrow> ('q, 'f) ta" where
  "gen_parallel_closure_automaton Q \<F> \<A> q = ta_union \<A> (refl_over_states_ta Q \<F> \<A> q)"

definition parallel_closure_reg where
  "parallel_closure_reg \<F> \<A> = (let \<B> = fmap_states_reg Some \<A> in
   Reg {|None|} (gen_parallel_closure_automaton (fin \<B>) \<F> (ta \<B>) None))"

subsubsection \<open>Context closure of regular tree language\<close>

definition "semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
  |\<Union>| ((\<lambda> (f, n). fset_of_list (map (\<lambda> i. TA_rule f ((replicate n q\<^sub>c)[i := q\<^sub>i]) q\<^sub>f) [0..< n])) |`| \<F>)"

definition "reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f \<equiv>
  TA (reflcl_rules \<F> q\<^sub>c |\<union>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f) ((\<lambda> p. (p, q\<^sub>f)) |`| Q)"

definition "gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f = ta_union \<A> (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"

definition "gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f =
   Reg {|q\<^sub>f|} (gen_ctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>f)"

definition "ctxt_closure_reg \<F> \<A> =
  (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
  gen_ctxt_closure_reg \<F> \<B> (Inr False) (Inr True))"

subsubsection \<open>Not empty context closure of regular tree language\<close>

datatype cl_states = cl_state | tr_state | fin_state | fin_clstate

definition "reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
  TA (reflcl_rules \<F> q\<^sub>c |\<union>| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f |\<union>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f) ((\<lambda> p. (p, q\<^sub>i)) |`| Q)"

definition "gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
   ta_union \<A> (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"

definition "gen_nhole_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
    Reg {|q\<^sub>f|} (gen_nhole_ctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"

definition "nhole_ctxt_closure_reg \<F> \<A> =
  (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
  (gen_nhole_ctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"

subsubsection \<open>Non empty multihole context closure of regular tree language\<close>

abbreviation "add_eps \<A> e \<equiv> TA (rules \<A>) (eps \<A> |\<union>| e)"
definition "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
  add_eps (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) {|(q\<^sub>i, q\<^sub>c)|}"

definition "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
   ta_union \<A> (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"

definition "gen_nhole_mctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
   Reg {|q\<^sub>f|} (gen_nhole_mctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"

definition "nhole_mctxt_closure_reg \<F> \<A> =
  (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
  (gen_nhole_mctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"

subsubsection \<open>Not empty multihole context closure of regular tree language\<close>

definition "gen_mctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
   Reg {|q\<^sub>f, q\<^sub>i|} (gen_nhole_mctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"

definition "mctxt_closure_reg \<F> \<A> =
  (let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
  (gen_mctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"

subsubsection \<open>Multihole context closure of regular tree language\<close>

definition "nhole_mctxt_reflcl_reg \<F> \<A> =
  reg_union (nhole_mctxt_closure_reg \<F> \<A>) (Reg {|fin_clstate|} (refl_ta \<F> (fin_clstate)))"

subsubsection \<open>Lemmas about @{const ta_der'}\<close>

lemma ta_det'_ground_id:
  "t |\<in>| ta_der' \<A> s \<Longrightarrow> ground t \<Longrightarrow> t = s"
  by (induct s arbitrary: t) (auto simp add: ta_der'.simps nth_equalityI)

lemma ta_det'_vars_term_id:
  "t |\<in>| ta_der' \<A> s \<Longrightarrow> vars_term t \<inter> fset (\<Q> \<A>) = {} \<Longrightarrow> t = s"
proof (induct s arbitrary: t)
  case (Fun f ss)
  from Fun(2-) obtain ts where [simp]: "t = Fun f ts" and len: "length ts = length ss"
    by (cases t) (auto simp flip: fmember_iff_member_fset dest: rule_statesD eps_dest_all)
  from Fun(1)[OF nth_mem, of i "ts ! i" for i] show ?case using Fun(2-) len
    by (auto simp add: ta_der'.simps Union_disjoint simp flip: fmember_iff_member_fset
        dest: rule_statesD eps_dest_all intro!: nth_equalityI)
qed (auto simp add: ta_der'.simps simp flip: fmember_iff_member_fset dest: rule_statesD eps_dest_all)

lemma fresh_states_ta_der'_pres:
  assumes st: "q \<in> vars_term s" "q |\<notin>| \<Q> \<A>"
    and reach: "t |\<in>| ta_der' \<A> s"
  shows "q \<in> vars_term t" using reach st(1)
proof (induct s arbitrary: t)
  case (Var x)
  then show ?case using assms(2)
    by (cases t) (auto simp: ta_der'.simps dest: eps_trancl_statesD)
next
  case (Fun f ss)
  from Fun(3) obtain i where w: "i < length ss" "q \<in> vars_term (ss ! i)" by (auto simp: in_set_conv_nth)
  have "i < length (args t) \<and> q \<in> vars_term (args t ! i)" using Fun(2) w assms(2) Fun(1)[OF nth_mem[OF w(1)] _ w(2)]
    using rule_statesD(3) ta_der_to_ta_der'
    by (auto simp: ta_der'.simps dest: rule_statesD(3)) fastforce+
  then show ?case by (cases t) auto
qed

lemma ta_der'_states:
  "t |\<in>| ta_der' \<A> s \<Longrightarrow> vars_term t \<subseteq> vars_term s \<union> fset (\<Q> \<A>)"
proof (induct s arbitrary: t)
  case (Var x) then show ?case
    by (auto simp: ta_der'.simps simp flip: fmember_iff_member_fset dest: eps_dest_all)
next
  case (Fun f ts) then show ?case
    by (auto simp: ta_der'.simps rule_statesD simp flip: fmember_iff_member_fset dest: eps_dest_all)
       (metis (no_types, opaque_lifting) Un_iff in_set_conv_nth notin_fset subsetD)
qed

lemma ta_der'_gterm_states:
  "t |\<in>| ta_der' \<A> (term_of_gterm s) \<Longrightarrow> vars_term t \<subseteq> fset (\<Q> \<A>)"
  using ta_der'_states[of t \<A> "term_of_gterm s"]
  by auto

lemma ta_der'_Var_funas:
  "Var q |\<in>| ta_der' \<A> s \<Longrightarrow> funas_term s \<subseteq> fset (ta_sig \<A>)"
  by (auto simp: less_eq_fset.rep_eq ffunas_term.rep_eq dest!: ta_der_term_sig ta_der'_to_ta_der)

lemma ta_sig_fsubsetI:
  assumes "\<And> r. r |\<in>| rules \<A> \<Longrightarrow> (r_root r, length (r_lhs_states r)) |\<in>| \<F>"
  shows "ta_sig \<A> |\<subseteq>| \<F>" using assms
  by (auto simp: ta_sig_def)

subsubsection \<open>Signature induced by @{const refl_ta} and @{const refl_over_states_ta}\<close>

lemma refl_ta_sig [simp]:
  "ta_sig (refl_ta \<F> q) = \<F>"
  "ta_sig (refl_over_states_ta  Q \<F> \<A> q ) = \<F>"
  by (auto simp: ta_sig_def refl_ta_def reflcl_rules_def refl_over_states_ta_def fimage_iff fBex_def)

subsubsection \<open>Correctness of @{const refl_ta}, @{const gen_reflcl_automaton}, and @{const reflcl_automaton}\<close>

lemma refl_ta_eps [simp]: "eps (refl_ta \<F> q) = {||}"
  by (auto simp: refl_ta_def)

lemma refl_ta_sound:
  "s \<in> \<T>\<^sub>G (fset \<F>) \<Longrightarrow> q |\<in>| ta_der (refl_ta \<F> q) (term_of_gterm s)"
  by (induct rule: \<T>\<^sub>G.induct) (auto simp: refl_ta_def reflcl_rules_def
      fimage_iff fBex_def simp flip: fmember_iff_member_fset)

lemma reflcl_rules_args:
  "length ps = n \<Longrightarrow> f ps \<rightarrow> p |\<in>| reflcl_rules \<F> q \<Longrightarrow> ps = replicate n q"
  by (auto simp: reflcl_rules_def)

lemma \<Q>_refl_ta:
  "\<Q> (refl_ta \<F> q) |\<subseteq>| {|q|}"
  by (auto simp: \<Q>_def refl_ta_def rule_states_def reflcl_rules_def fset_of_list_elem)

lemma refl_ta_complete1:
  "Var p |\<in>| ta_der' (refl_ta \<F> q) s \<Longrightarrow> p \<noteq> q \<Longrightarrow> s = Var p"
  by (cases s) (auto simp: ta_der'.simps refl_ta_def reflcl_rules_def)

lemma refl_ta_complete2:
  "Var q |\<in>| ta_der' (refl_ta \<F> q) s \<Longrightarrow> funas_term s \<subseteq> fset \<F> \<and> vars_term s \<subseteq> {q}"
  unfolding ta_der_to_ta_der'[symmetric]
  using ta_der_term_sig[of q "refl_ta \<F> q" s] ta_der_states'[of q "refl_ta \<F> q" s]
  using fsubsetD[OF \<Q>_refl_ta[of \<F> q]]
  by (auto simp: fmember_iff_member_fset ffunas_term.rep_eq)
     (metis Term.term.simps(17) fresh_states_ta_der'_pres notin_fset singletonD ta_der_to_ta_der')

lemma gen_reflcl_lang:
  assumes "q |\<notin>| \<Q> \<A>"
  shows "gta_lang (finsert q Q) (gen_reflcl_automaton \<F> \<A> q) = gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_reflcl_automaton \<F> \<A> q"
  interpret sq: derivation_split ?A "\<A>" "refl_ta \<F> q"
    using assms unfolding derivation_split_def
    by (auto simp: gen_reflcl_automaton_def refl_ta_def reflcl_rules_def \<Q>_def)
  show ?thesis
  proof
    {fix s assume "s \<in> ?Ls" then obtain p u where
        seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var p |\<in>| ta_der' (refl_ta \<F> q) u" and
        fin: "p |\<in>| finsert q Q"
        by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
      have "vars_term u \<subseteq> {q} \<Longrightarrow> u = term_of_gterm s" using assms
        by (intro ta_det'_vars_term_id[OF seq(1)]) (auto simp flip: fmember_iff_member_fset)
      then have "s \<in> ?Rs" using assms fin seq funas_term_of_gterm_conv
        using refl_ta_complete1[OF seq(2)]
        by (cases "p = q") (auto simp: ta_der_to_ta_der' \<T>\<^sub>G_funas_gterm_conv dest!: refl_ta_complete2)}
    then show "?Ls \<subseteq> gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)" by blast
  next
    show "gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>) \<subseteq> ?Ls"
      using sq.ta_der_monos unfolding gta_lang_def gta_der_def
      by (auto dest: refl_ta_sound)
  qed
qed

lemma reflcl_lang:
  "gta_lang (finsert None (Some |`| Q)) (reflcl_automaton \<F> \<A>) = gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)"
proof -
  have st: "None |\<notin>| \<Q> (fmap_states_ta Some \<A>)" by auto
  have "gta_lang Q \<A> = gta_lang (Some |`| Q) (fmap_states_ta Some \<A>)"
    by (simp add: finj_Some fmap_states_ta_lang2)
  then show ?thesis
    unfolding reflcl_automaton_def Let_def gen_reflcl_lang[OF st, of "Some |`| Q" \<F>]
    by simp
qed

lemma \<L>_reflcl_reg:
  "\<L> (reflcl_reg \<F> \<A>) = \<L> \<A> \<union>  \<T>\<^sub>G (fset \<F>)"
  by (simp add: \<L>_def reflcl_lang reflcl_reg_def )

subsubsection \<open>Correctness of @{const gen_parallel_closure_automaton} and @{const parallel_closure_reg}\<close>

lemma set_list_subset_nth_conv:
  "set xs \<subseteq> A \<Longrightarrow> i < length xs \<Longrightarrow> xs ! i \<in> A"
  by (metis in_set_conv_nth subset_code(1))

lemma ground_gmctxt_of_mctxt_fill_holes':
  "num_holes C = length ss \<Longrightarrow> ground_mctxt C \<Longrightarrow> \<forall>s\<in>set ss. ground s \<Longrightarrow>
   fill_gholes (gmctxt_of_mctxt C) (map gterm_of_term ss) = gterm_of_term (fill_holes C ss)"
  using ground_gmctxt_of_mctxt_fill_holes
  by (metis term_of_gterm_inv)

lemma refl_over_states_ta_eps_trancl [simp]:
  "(eps (refl_over_states_ta Q \<F> \<A> q))|\<^sup>+| = eps (refl_over_states_ta Q \<F> \<A> q)"
  using ftranclD ftranclE unfolding refl_over_states_ta_def
  by fastforce

lemma refl_over_states_ta_epsD:
  "(p, q) |\<in>| (eps (refl_over_states_ta Q \<F> \<A> q)) \<Longrightarrow> p |\<in>| Q"
  by (auto simp: refl_over_states_ta_def)

lemma refl_over_states_ta_vars_term:
  "q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) u \<Longrightarrow> vars_term u \<subseteq> insert q (fset Q)"
proof (induct u)
  case (Fun f ts)
  from Fun(2) reflcl_rules_args[of _ "length ts" f _ \<F> q]
  have "i < length ts \<Longrightarrow> q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) (ts ! i)" for i
    by (fastforce simp: refl_over_states_ta_def)
  then have "i < length ts \<Longrightarrow> x \<in> vars_term (ts ! i) \<Longrightarrow> x = q \<or> x |\<in>| Q" for i x
    using Fun(1)[OF nth_mem, of i]
    by (meson insert_iff notin_fset subsetD)
  then show ?case by (fastforce simp: in_set_conv_nth fmember_iff_member_fset)
qed (auto simp flip: fmember_iff_member_fset dest: refl_over_states_ta_epsD)

lemmas refl_over_states_ta_vars_term' =
  refl_over_states_ta_vars_term[unfolded ta_der_to_ta_der' ta_der'_target_args_vars_term_conv,
    THEN set_list_subset_nth_conv, unfolded fmember_iff_member_fset[symmetric] finsert.rep_eq[symmetric]]

lemma refl_over_states_ta_sound:
  "funas_term u \<subseteq> fset \<F> \<Longrightarrow> vars_term u \<subseteq> insert q (fset (Q |\<inter>| \<Q> \<A>)) \<Longrightarrow> q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) u"
proof (induct u)
  case (Fun f ts)
  have reach: "i < length ts \<Longrightarrow> q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) (ts ! i)" for i
    using Fun(2-) by (intro Fun(1)[OF nth_mem]) (auto simp: SUP_le_iff)
  from Fun(2) have "TA_rule f (replicate (length ts) q) q |\<in>| rules (refl_over_states_ta Q \<F> \<A> q)"
    by (auto simp: refl_over_states_ta_def reflcl_rules_def fimage_iff fBex_def simp flip: fmember_iff_member_fset)
  then show ?case using reach
    by force
qed (auto simp: refl_over_states_ta_def simp flip: fmember_iff_member_fset)

lemma gen_parallelcl_lang:
  fixes \<A> :: "('q, 'f) ta"
  assumes "q |\<notin>| \<Q> \<A>"
  shows "gta_lang {|q|} (gen_parallel_closure_automaton Q \<F> \<A> q) =
    {fill_gholes C ss | C ss. num_gholes C = length ss \<and> funas_gmctxt C \<subseteq> (fset \<F>) \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_parallel_closure_automaton Q \<F> \<A> q" let ?B = "refl_over_states_ta Q \<F> \<A> q"
  interpret sq: derivation_split "?A" "\<A>" "?B"
    using assms unfolding derivation_split_def
    by (auto simp: gen_parallel_closure_automaton_def refl_over_states_ta_def \<Q>_def reflcl_rules_def)
  {fix s assume "s \<in> ?Ls" then obtain u where
      seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q |\<in>| ta_der'?B u" and
      fin: "q |\<in>| finsert q Q"
      by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
    let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
    have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)] fin
      using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms
      using refl_over_states_ta_vars_term'[OF seq(2)]
      using ta_der'_ground_mctxt_structure[OF seq(1)]
      by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
          intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
          exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
          gta_langI[of "ta_der'_target_args u ! i" Q \<A>
            "gterm_of_term (?w i)" for i])}
  then have ls: "?Ls \<subseteq> ?Rs" by blast
  {fix t assume "t \<in> ?Rs"
    then obtain C ss where len: "num_gholes C = length ss" and
      gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
      reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
      const: "t = fill_gholes C ss" by auto
    from reachA obtain qs where "length ss = length qs" "\<forall> i < length qs. qs ! i |\<in>| Q |\<inter>| \<Q> \<A>"
      "\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> ((map term_of_gterm ss) ! i)"
      using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q |\<in>| Q"]
      by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
    then have "q |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q])
        (auto simp: funas_mctxt_of_gmctxt_conv simp flip: fmember_iff_member_fset
          dest!: in_set_idx intro!: refl_over_states_ta_sound)
    then have "t \<in> ?Ls" unfolding const
      by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
  then show ?thesis using ls by blast
qed

lemma parallelcl_gmctxt_lang:
  fixes \<A> :: "('q, 'f) reg"
  shows "\<L> (parallel_closure_reg \<F> \<A>) =
    {fill_gholes C ss |
      C ss. num_gholes C = length ss \<and> funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
proof -
  have *: "gta_lang (fin (fmap_states_reg Some \<A>)) (fmap_states_ta Some (ta \<A>)) = gta_lang (fin \<A>) (ta \<A>)"
    by (simp add: finj_Some fmap_states_reg_def fmap_states_ta_lang2)
  have " None |\<notin>| \<Q> (fmap_states_ta Some (ta \<A>))" by auto
  from gen_parallelcl_lang[OF this, of "fin (fmap_states_reg Some \<A>)" \<F>] show ?thesis
    unfolding \<L>_def parallel_closure_reg_def Let_def * fmap_states_reg_def
    by (simp add: finj_Some fmap_states_ta_lang2)
qed

lemma parallelcl_mctxt_lang:
  shows "\<L> (parallel_closure_reg \<F> \<A>) =
    {(gterm_of_term :: ('f, 'q option) term \<Rightarrow> 'f gterm) (fill_holes C (map term_of_gterm ss)) |
      C ss. num_holes C = length ss \<and> ground_mctxt C \<and> funas_mctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
  by (auto simp: parallelcl_gmctxt_lang) (metis funas_gmctxt_of_mctxt num_gholes_gmctxt_of_mctxt
      ground_gmctxt_of_gterm_of_term funas_mctxt_of_gmctxt_conv
      ground_mctxt_of_gmctxt mctxt_of_gmctxt_fill_holes num_holes_mctxt_of_gmctxt)+

subsubsection \<open>Correctness of @{const gen_ctxt_closure_reg} and @{const ctxt_closure_reg}\<close>

lemma semantic_path_rules_rhs:
  "r |\<in>| semantic_path_rules Q q\<^sub>c q\<^sub>i q\<^sub>f \<Longrightarrow> r_rhs r = q\<^sub>f"
  by (auto simp: semantic_path_rules_def)

lemma reflcl_over_single_ta_transl [simp]:
  "(eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f))|\<^sup>+| = eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
  using ftranclD ftranclE unfolding reflcl_over_single_ta_def
  by fastforce

lemma reflcl_over_single_ta_epsD:
  "(p, q\<^sub>f) |\<in>| eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow> p |\<in>| Q"
  "(p, q) |\<in>| eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow> q = q\<^sub>f"
  by (auto simp: reflcl_over_single_ta_def)

lemma reflcl_over_single_ta_rules_split:
  "r |\<in>| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow>
     r |\<in>| reflcl_rules \<F> q\<^sub>c \<or> r |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f"
  by (auto simp: reflcl_over_single_ta_def)

lemma reflcl_over_single_ta_rules_semantic_path_rulesI:
  "r |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f \<Longrightarrow> r |\<in>| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
  by (auto simp: reflcl_over_single_ta_def)

lemma semantic_path_rules_fmember [intro]:
  "TA_rule f qs q |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<longleftrightarrow> (\<exists> n i. (f, n) |\<in>| \<F> \<and> i < n \<and> q = q\<^sub>f \<and>
    (qs = (replicate n q\<^sub>c)[i := q\<^sub>i]))" (is "?Ls \<longleftrightarrow> ?Rs")
  by (force simp: semantic_path_rules_def fBex_def fimage_iff fset_of_list_elem)

lemma semantic_path_rules_fmemberD:
  "r |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<Longrightarrow> (\<exists> n i. (r_root r, n) |\<in>| \<F> \<and> i < n \<and> r_rhs r = q\<^sub>f \<and>
    (r_lhs_states r = (replicate n q\<^sub>c)[i := q\<^sub>i]))"
  by (cases r) (simp add: semantic_path_rules_fmember)

lemma reflcl_over_single_ta_vars_term_q\<^sub>c:
  "q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) u \<Longrightarrow>
    vars_term_list u = replicate (length (vars_term_list u)) q\<^sub>c"
proof (induct u)
  case (Fun f ts)
  have "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ts ! i)" for i using Fun(2, 3)
    by (auto dest!: reflcl_over_single_ta_rules_split reflcl_over_single_ta_epsD
        reflcl_rules_args semantic_path_rules_rhs)
  then have "i < length (concat (map vars_term_list ts)) \<Longrightarrow> concat (map vars_term_list ts) ! i = q\<^sub>c" for i
    using Fun(1)[OF nth_mem Fun(2)]
    by (metis (no_types, lifting) length_map nth_concat_split nth_map nth_replicate)
  then show ?case using Fun(1)[OF nth_mem Fun(2)]
    by (auto intro: nth_equalityI)
qed (auto simp flip: fmember_iff_member_fset dest: reflcl_over_single_ta_epsD)

lemma reflcl_over_single_ta_vars_term:
  "q\<^sub>c |\<notin>| Q \<Longrightarrow> q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>f |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) u \<Longrightarrow>
   length (vars_term_list u) = n \<Longrightarrow> (\<exists> i q. i < n \<and> q |\<in>| finsert q\<^sub>f Q \<and> vars_term_list u = (replicate n q\<^sub>c)[i := q])"
proof (induct u arbitrary: n)
  case (Var x) then show ?case
    by (intro exI[of _ 0] exI[of _ x]) (auto dest: reflcl_over_single_ta_epsD(1))
next
  case (Fun f ts)
  from Fun(2, 3, 4) obtain qs where rule: "TA_rule f qs q\<^sub>f |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f"
    "length qs = length ts" "\<forall> i < length ts. qs ! i |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ts ! i)"
    using semantic_path_rules_rhs reflcl_over_single_ta_epsD
    by (fastforce simp: reflcl_rules_def dest!: reflcl_over_single_ta_rules_split)
  from rule(1, 2) obtain i where states: "i < length ts" "qs = (replicate (length ts) q\<^sub>c)[i := q\<^sub>f]"
    by (auto simp: semantic_path_rules_fmember)
  then have qc: "j < length ts \<Longrightarrow> j \<noteq> i \<Longrightarrow> vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) q\<^sub>c" for j
    using reflcl_over_single_ta_vars_term_q\<^sub>c[OF Fun(3)] rule
    by force
  from Fun(1)[OF nth_mem, of i] Fun(2, 3) rule states obtain k q where
    qf: "k <  length (vars_term_list (ts ! i))" "q |\<in>| finsert q\<^sub>f Q"
    "vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) q\<^sub>c)[k := q]"
    by (auto simp: nth_list_update split: if_splits)
  let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
  show ?case using qc qf rule(2) Fun(5) states(1)
    apply (intro exI[of _ ?l] exI[of _ q])
    apply (auto simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
       apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
    done
qed

lemma refl_ta_reflcl_over_single_ta_mono:
  "q |\<in>| ta_der (refl_ta \<F> q) t \<Longrightarrow> q |\<in>| ta_der (reflcl_over_single_ta Q \<F> q q\<^sub>f) t"
  by (intro ta_der_el_mono[where ?\<B> = "reflcl_over_single_ta Q \<F> q q\<^sub>f"])
    (auto simp: refl_ta_def reflcl_over_single_ta_def)

lemma reflcl_over_single_ta_sound:
  assumes "funas_gctxt C \<subseteq> fset \<F>" "q |\<in>| Q"
  shows "q\<^sub>f |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using assms(1)
proof (induct C)
  case GHole then show ?case using assms(2)
    by (auto simp add: reflcl_over_single_ta_def)
next
  case (GMore f ss C ts)
  let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
  from GMore have "(f, ?n) |\<in>| \<F>" by (auto simp flip: fmember_iff_member_fset)
  then have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>f]) \<rightarrow> q\<^sub>f |\<in>| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
    using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]" q\<^sub>f \<F> q\<^sub>c q\<^sub>f q\<^sub>f]
    using less_add_Suc1
    by (intro reflcl_over_single_ta_rules_semantic_path_rulesI) blast
  moreover from GMore(2) have "i < length ss \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (term_of_gterm (ss ! i))" for i
    by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
  moreover from GMore(2) have "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (term_of_gterm (ts ! i))" for i
    by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
  moreover from GMore have "q\<^sub>f |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" by auto
  ultimately show ?case
    by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]"] exI[of _ q\<^sub>f])
qed

lemma reflcl_over_single_ta_sig: "ta_sig (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) |\<subseteq>| \<F>"
  by (intro ta_sig_fsubsetI)
    (auto simp: reflcl_rules_def dest!: semantic_path_rules_fmemberD reflcl_over_single_ta_rules_split)

lemma gen_gctxtcl_lang:
  assumes "q\<^sub>c |\<notin>| \<Q> \<A>" and "q\<^sub>f |\<notin>| \<Q> \<A>" and "q\<^sub>c |\<notin>| Q" and "q\<^sub>c \<noteq> q\<^sub>f"
  shows "gta_lang {|q\<^sub>f|} (gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f) =
    {C\<langle>s\<rangle>\<^sub>G | C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> gta_lang Q \<A>}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f" let ?B = "reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f"
  interpret sq: derivation_split ?A \<A> ?B
    using assms unfolding derivation_split_def
    by (auto simp: gen_ctxt_closure_automaton_def reflcl_over_single_ta_def \<Q>_def reflcl_rules_def
        dest!: semantic_path_rules_rhs)
  {fix s assume "s \<in> ?Ls" then obtain u where
      seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f |\<in>| ta_der'?B u" using sq.ta_der'_split
      by (force simp: ta_der_to_ta_der' elim!: gta_langE)
    have "q\<^sub>c \<notin> vars_term u" "q\<^sub>f \<notin> vars_term u"
      using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1, 2)
      by (auto simp flip: set_vars_term_list fmember_iff_member_fset)
    then obtain q where vars: "vars_term_list u = [q]" and fin: "q |\<in>| Q" unfolding set_vars_term_list[symmetric]
      using reflcl_over_single_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(3, 4) seq(2), of "length (vars_term_list u)"]
      by (metis (no_types, lifting) finsertE in_set_conv_nth length_0_conv length_Suc_conv
          length_replicate lessI less_Suc_eq_0_disj nth_Cons_0 nth_list_update nth_replicate zero_less_Suc)
    have "s \<in> ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars]
      using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_single_ta_sig[unfolded less_eq_fset.rep_eq]]
      by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
        (metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv subset_eq)
  }
  then have ls: "?Ls \<subseteq> ?Rs" by blast
  {fix t assume "t \<in> ?Rs"
    then obtain C s where gr_fun: "funas_gctxt C \<subseteq> fset \<F>" and reachA: "s \<in> gta_lang Q \<A>" and
      const: "t = C\<langle>s\<rangle>\<^sub>G" by auto
    from reachA obtain q where der_A: "q |\<in>| Q |\<inter>| \<Q> \<A>" "q |\<in>| ta_der \<A> (term_of_gterm s)"
      by auto
    have "q\<^sub>f |\<in>| ta_der ?B (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using gr_fun der_A(1)
      using reflcl_over_single_ta_sound[OF gr_fun]
      by force
    then have "t \<in> ?Ls" unfolding const
      by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
  then show ?thesis using ls by blast
qed

lemma gen_gctxt_closure_sound:
  fixes \<A> :: "('q, 'f) reg"
  assumes "q\<^sub>c |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>f |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>c |\<notin>| fin \<A>" and "q\<^sub>c \<noteq> q\<^sub>f"
  shows "\<L> (gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f) = {C\<langle>s\<rangle>\<^sub>G | C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
  using gen_gctxtcl_lang[OF assms] unfolding \<L>_def
  by (simp add: gen_ctxt_closure_reg_def)

lemma gen_ctxt_closure_sound:
  fixes \<A> :: "('q, 'f) reg"
  assumes "q\<^sub>c |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>f |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>c |\<notin>| fin \<A>" and "q\<^sub>c \<noteq> q\<^sub>f"
  shows "\<L> (gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f) =
    {(gterm_of_term :: ('f, 'q) term \<Rightarrow> 'f gterm) C\<langle>term_of_gterm s\<rangle> | C s. ground_ctxt C \<and> funas_ctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
  unfolding gen_gctxt_closure_sound[OF assms]
  by (metis (no_types, opaque_lifting) ctxt_of_gctxt_apply funas_ctxt_of_gctxt_conv gctxt_of_ctxt_inv ground_ctxt_of_gctxt)

lemma gctxt_closure_lang:
  shows "\<L> (ctxt_closure_reg \<F> \<A>) =
    { C\<langle>s\<rangle>\<^sub>G | C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
proof -
  let ?B = "fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)"
  have ts: "Inr False |\<notin>| \<Q>\<^sub>r ?B" "Inr True |\<notin>| \<Q>\<^sub>r ?B" "Inr False |\<notin>| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
    by (auto simp: fmap_states_reg_def fmap_states_ta_def' \<Q>_def rule_states_def)
  from gen_gctxt_closure_sound[OF ts] show ?thesis
    by (simp add: ctxt_closure_reg_def)
qed

lemma ctxt_closure_lang:
  shows "\<L> (ctxt_closure_reg \<F> \<A>) =
    {(gterm_of_term :: ('f, 'q + bool) term \<Rightarrow> 'f gterm) C\<langle>term_of_gterm s\<rangle> |
      C s. ground_ctxt C \<and> funas_ctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
  unfolding gctxt_closure_lang
  by (metis (mono_tags, opaque_lifting) ctxt_of_gctxt_inv funas_gctxt_of_ctxt
      ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply_gterm term_of_gterm_inv)

subsubsection \<open>Correctness of @{const gen_nhole_ctxt_closure_automaton} and @{const nhole_ctxt_closure_reg}\<close>

lemma reflcl_over_nhole_ctxt_ta_vars_term_q\<^sub>c:
  "q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>c \<noteq> q\<^sub>i \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u \<Longrightarrow>
    vars_term_list u = replicate (length (vars_term_list u)) q\<^sub>c"
proof (induct u)
  case (Fun f ts)
  have "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)" for i using Fun(2, 3, 4)
    by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2 reflcl_rules_args semantic_path_rules_rhs)
  then have "i < length (concat (map vars_term_list ts)) \<Longrightarrow> concat (map vars_term_list ts) ! i = q\<^sub>c" for i
    using Fun(1)[OF nth_mem Fun(2, 3)]
    by (metis (no_types, lifting) length_map map_nth_eq_conv nth_concat_split' nth_replicate)
  then show ?case using Fun(1)[OF nth_mem Fun(2)]
    by (auto intro: nth_equalityI)
qed (auto simp flip: fmember_iff_member_fset simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)

lemma reflcl_over_nhole_ctxt_ta_vars_term_Var:
  assumes disj: "q\<^sub>c |\<notin>| Q" "q\<^sub>f |\<notin>| Q" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f" "q\<^sub>c \<noteq> q\<^sub>i"
    and reach: "q\<^sub>i |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u"
  shows "(\<exists> q. q |\<in>| finsert q\<^sub>i Q \<and>  u = Var q)" using assms
  by (cases u) (fastforce simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD semantic_path_rules_rhs)+

lemma reflcl_over_nhole_ctxt_ta_vars_term:
  assumes disj: "q\<^sub>c |\<notin>| Q" "q\<^sub>f |\<notin>| Q" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f" "q\<^sub>c \<noteq> q\<^sub>i"
    and reach: "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u"
  shows "(\<exists> i q. i < length (vars_term_list u) \<and> q |\<in>| {|q\<^sub>i, q\<^sub>f|} |\<union>| Q \<and> vars_term_list u = (replicate (length (vars_term_list u)) q\<^sub>c)[i := q])"
  using assms
proof (induct u)
  case (Var q) then show ?case
    by (intro exI[of _ 0] exI[of _ q]) (auto simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)
next
  case (Fun f ts)
  from Fun(2 - 7) obtain q qs where rule: "TA_rule f qs q\<^sub>f |\<in>| semantic_path_rules \<F> q\<^sub>c q q\<^sub>f" "q = q\<^sub>i \<or> q = q\<^sub>f"
    "length qs = length ts" "\<forall> i < length ts. qs ! i |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)"
    by (auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD2)
  from rule(1- 3) obtain i where states: "i < length ts" "qs = (replicate (length ts) q\<^sub>c)[i := q]"
    by (auto simp: semantic_path_rules_fmember)
  then have qc: "j < length ts \<Longrightarrow> j \<noteq> i \<Longrightarrow> vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) q\<^sub>c" for j
    using reflcl_over_nhole_ctxt_ta_vars_term_q\<^sub>c[OF Fun(4, 6)] rule
    by force
  from rule states have "q |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)"
    by auto
  from this Fun(1)[OF nth_mem, of i, OF _ Fun(2 - 6)] rule(2) states(1) obtain k q' where
    qf: "k < length (vars_term_list (ts ! i))" "q' |\<in>| {|q\<^sub>i, q\<^sub>f|} |\<union>| Q "
    "vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) q\<^sub>c)[k :=  q']"
    using reflcl_over_nhole_ctxt_ta_vars_term_Var[OF Fun(2 - 6), of \<F> "ts ! i"]
    by (auto simp: nth_list_update split: if_splits) blast
  let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
  show ?case using qc qf rule(3) states(1)
    apply (intro exI[of _ ?l] exI[of _  q'])
    apply (auto 0 0 simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
         apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
    done
qed

lemma reflcl_over_nhole_ctxt_ta_mono:
  "q |\<in>| ta_der (refl_ta \<F> q) t \<Longrightarrow> q |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q q\<^sub>i q\<^sub>f) t"
  by (intro ta_der_el_mono[where ?\<B> = "reflcl_over_nhole_ctxt_ta Q \<F> q q\<^sub>i q\<^sub>f"])
    (auto simp: refl_ta_def reflcl_over_nhole_ctxt_ta_def)

lemma reflcl_over_nhole_ctxt_ta_sound:
  assumes "funas_gctxt C \<subseteq> fset \<F>" "C \<noteq> GHole" "q |\<in>| Q"
  shows "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using assms(1, 2)
proof (induct C)
  case GHole then show ?case using assms(2)
    by (auto simp add: reflcl_over_single_ta_def)
next
  case (GMore f ss C ts) note IH = this
  let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
  from GMore have funas: "(f, ?n) |\<in>| \<F>" by (auto simp flip: fmember_iff_member_fset)
  from GMore(2) have args_ss: "i < length ss \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (term_of_gterm (ss ! i))" for i
    by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
  from GMore(2) have args_ts: "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (term_of_gterm (ts ! i))" for i
    by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
  note args = this
  show ?case
  proof (cases C)
    case [simp]: GHole
    from funas have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>i]) \<rightarrow> q\<^sub>f |\<in>| rules (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
      using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>i]" q\<^sub>f \<F> q\<^sub>c q\<^sub>i q\<^sub>f]
      unfolding reflcl_over_nhole_ctxt_ta_def
      by (metis funionCI less_add_Suc1 ta.sel(1))
    moreover have "q\<^sub>i |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
      using assms(3) by (auto simp: reflcl_over_nhole_ctxt_ta_def)
    ultimately show ?thesis using args_ss args_ts
      by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>i]"] exI[of _ q\<^sub>f])
  next
    case (GMore x21 x22 x23 x24)
    then have "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
      using IH(1, 2) by auto
    moreover from funas have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>f]) \<rightarrow> q\<^sub>f |\<in>| rules (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
      using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]" q\<^sub>f \<F> q\<^sub>c q\<^sub>f q\<^sub>f]
      unfolding reflcl_over_nhole_ctxt_ta_def
      by (metis funionI2 less_add_Suc1 ta.sel(1))
    ultimately show ?thesis using args_ss args_ts
      by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]"] exI[of _ q\<^sub>f])
  qed
qed

lemma reflcl_over_nhole_ctxt_ta_sig: "ta_sig (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) |\<subseteq>| \<F>"
  by (intro ta_sig_fsubsetI)
    (auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest!: semantic_path_rules_fmemberD)

lemma gen_nhole_gctxt_closure_lang:
  assumes "q\<^sub>c |\<notin>| \<Q> \<A>" "q\<^sub>i |\<notin>| \<Q> \<A>" "q\<^sub>f |\<notin>| \<Q> \<A>"
    and "q\<^sub>c |\<notin>| Q" "q\<^sub>f |\<notin>| Q"
    and "q\<^sub>c \<noteq> q\<^sub>i" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f"
  shows "gta_lang {|q\<^sub>f|} (gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
    {C\<langle>s\<rangle>\<^sub>G | C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> gta_lang Q \<A>}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
  interpret sq: derivation_split ?A \<A> ?B
    using assms unfolding derivation_split_def
    by (auto simp: gen_nhole_ctxt_closure_automaton_def reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def
        dest!: semantic_path_rules_rhs)
  {fix s assume "s \<in> ?Ls" then obtain u where
      seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f |\<in>| ta_der'?B u" using sq.ta_der'_split
      by (force simp: ta_der_to_ta_der' elim!: gta_langE)
    have "q\<^sub>c \<notin> vars_term u" "q\<^sub>i \<notin> vars_term u" "q\<^sub>f \<notin> vars_term u"
      using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1 - 3)
      by (auto simp flip: set_vars_term_list fmember_iff_member_fset)
    then obtain q where vars: "vars_term_list u = [q]" and fin: "q |\<in>| Q"
      unfolding set_vars_term_list[symmetric]
      using reflcl_over_nhole_ctxt_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(4, 5, 7 - 8, 6) seq(2)]
      by (metis (no_types, opaque_lifting) finsert_iff funion_commute funion_finsert_right
          length_greater_0_conv lessI list.size(3) list_update_code(2) not0_implies_Suc
          nth_list_update_neq nth_mem nth_replicate replicate_Suc replicate_empty sup_bot.right_neutral)
    from seq(2) have "ta_der'_gctxt u \<noteq> GHole" using ta_der'_ground_ctxt_structure(1)[OF seq(1) vars]
      using fin assms(4, 5, 8) by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2)
    then have "s \<in> ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars] seq(2)
      using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_nhole_ctxt_ta_sig[unfolded less_eq_fset.rep_eq]]
      by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
        (metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv in_mono)}
  then have ls: "?Ls \<subseteq> ?Rs" by blast
  {fix t assume "t \<in> ?Rs"
    then obtain C s where gr_fun: "funas_gctxt C \<subseteq> fset \<F>" "C \<noteq> GHole" and reachA: "s \<in> gta_lang Q \<A>" and
      const: "t = C\<langle>s\<rangle>\<^sub>G" by auto
    from reachA obtain q where der_A: "q |\<in>| Q |\<inter>| \<Q> \<A>" "q |\<in>| ta_der \<A> (term_of_gterm s)"
      by auto
    have "q\<^sub>f |\<in>| ta_der ?B (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using gr_fun der_A(1)
      using reflcl_over_nhole_ctxt_ta_sound[OF gr_fun]
      by force
    then have "t \<in> ?Ls" unfolding const
      by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
  then show ?thesis using ls by blast
qed

lemma gen_nhole_gctxt_closure_sound:
  assumes "q\<^sub>c |\<notin>| \<Q>\<^sub>r \<A>" "q\<^sub>i |\<notin>| \<Q>\<^sub>r \<A>" "q\<^sub>f |\<notin>| \<Q>\<^sub>r \<A>"
    and "q\<^sub>c |\<notin>| (fin \<A>)" "q\<^sub>f |\<notin>| (fin \<A>)"
    and "q\<^sub>c \<noteq> q\<^sub>i" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f"
  shows "\<L> (gen_nhole_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
    { C\<langle>s\<rangle>\<^sub>G | C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
  using gen_nhole_gctxt_closure_lang[OF assms] unfolding \<L>_def
  by (auto simp: gen_nhole_ctxt_closure_reg_def)

lemma nhole_ctxtcl_lang:
  "\<L> (nhole_ctxt_closure_reg \<F> \<A>) =
    { C\<langle>s\<rangle>\<^sub>G | C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
proof -
  let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
  have ts: "Inr cl_state |\<notin>| \<Q>\<^sub>r ?B" "Inr tr_state |\<notin>| \<Q>\<^sub>r ?B" "Inr fin_state |\<notin>| \<Q>\<^sub>r ?B"
    by (auto simp: fmap_states_reg_def)
  then have "Inr cl_state |\<notin>| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
    "Inr fin_state |\<notin>| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
    using finj_Inl_Inr(1) fmap_states_reg_Restr_Q\<^sub>f_fin by blast+
  from gen_nhole_gctxt_closure_sound[OF ts this] show ?thesis
    by (simp add: nhole_ctxt_closure_reg_def Let_def)
qed

subsubsection \<open>Correctness of @{const gen_nhole_mctxt_closure_automaton}\<close>

lemmas reflcl_over_nhole_mctxt_ta_simp = reflcl_over_nhole_mctxt_ta_def reflcl_over_nhole_ctxt_ta_def

lemma reflcl_rules_rhsD:
  "f ps \<rightarrow> q |\<in>| reflcl_rules \<F> q\<^sub>c \<Longrightarrow> q = q\<^sub>c"
  by (auto simp: reflcl_rules_def)

lemma reflcl_over_nhole_mctxt_ta_vars_term:
  assumes "q |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t"
   and "q\<^sub>c |\<notin>| Q" "q \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>i \<noteq> q\<^sub>c"
  shows "vars_term t \<noteq> {}" using assms
proof (induction t arbitrary: q)
  case (Fun f ts)
  let ?A = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
  from Fun(2) obtain p ps where rule: "TA_rule f ps p |\<in>| rules ?A"
    "length ps = length ts" "\<forall> i < length ts. ps ! i |\<in>| ta_der ?A (ts ! i)"
    "p = q \<or> (p, q) |\<in>| (eps ?A)|\<^sup>+|"
    by force
  from rule(1, 4) Fun(3-) have "p \<noteq> q\<^sub>c"
    by (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD)
  then have "\<exists> i < length ts. ps ! i \<noteq> q\<^sub>c" using rule(1, 2) Fun(4-)
    using semantic_path_rules_fmemberD
    by (force simp: reflcl_over_nhole_mctxt_ta_simp dest: reflcl_rules_rhsD)
  then show ?case using Fun(1)[OF nth_mem _ Fun(3) _ Fun(5, 6)] rule(2, 3)
    by fastforce
qed auto

lemma reflcl_over_nhole_mctxt_ta_Fun:
  assumes "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" "t \<noteq> Var q\<^sub>f"
    and  "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i"
  shows "is_Fun t" using assms
  by (cases t) (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD2)

lemma rule_states_reflcl_rulesD:
  "p |\<in>| rule_states (reflcl_rules \<F> q) \<Longrightarrow> p = q"
  by (auto simp: reflcl_rules_def rule_states_def fset_of_list_elem)

lemma rule_states_semantic_path_rulesD:
  "p |\<in>| rule_states (semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f) \<Longrightarrow> p = q\<^sub>c \<or> p = q\<^sub>i \<or> p = q\<^sub>f"
  by (auto simp: rule_states_def dest!: semantic_path_rules_fmemberD)
    (metis in_fset_conv_nth length_list_update length_replicate nth_list_update nth_replicate)

lemma \<Q>_reflcl_over_nhole_mctxt_ta:
  "\<Q> (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) |\<subseteq>| Q |\<union>| {|q\<^sub>c, q\<^sub>i, q\<^sub>f|}"
  by (auto 0 0 simp: eps_states_def reflcl_over_nhole_mctxt_ta_simp \<Q>_def
      dest!: rule_states_reflcl_rulesD rule_states_semantic_path_rulesD)

lemma reflcl_over_nhole_mctxt_ta_vars_term_subset_eq:
  assumes "q |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" "q = q\<^sub>f \<or> q = q\<^sub>i"
  shows "vars_term t \<subseteq> {q\<^sub>c, q\<^sub>i, q\<^sub>f} \<union> fset Q"
  using fresh_states_ta_der'_pres[OF _ _ assms(1)[unfolded ta_der_to_ta_der']] assms(2)
  using fsubsetD[OF \<Q>_reflcl_over_nhole_mctxt_ta[of Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f]]
  by auto (meson notin_fset)+

lemma sig_reflcl_over_nhole_mctxt_ta [simp]:
  "ta_sig (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) = \<F>"
  by (force simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def
      dest!: semantic_path_rules_fmemberD intro!: ta_sig_fsubsetI)

lemma reflcl_over_nhole_mctxt_ta_aux_sound:
  assumes "funas_term t \<subseteq> fset \<F>" "vars_term t \<subseteq> fset Q"
  shows "q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" using assms
proof (induct t)
  case (Var x)
  then show ?case
    by (auto simp: reflcl_over_nhole_mctxt_ta_simp fimage_iff simp flip: fmember_iff_member_fset)
     (meson finsertI1 finsertI2 fr_into_trancl ftrancl_into_trancl rev_fimage_eqI)
next
  case (Fun f ts)
  from Fun(2) have "TA_rule f (replicate (length ts) q\<^sub>c) q\<^sub>c |\<in>| rules (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
    by (auto simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def fimage_iff fBall_def
             simp flip: fmember_iff_member_fset split: prod.splits)
  then show ?case using Fun(1)[OF nth_mem] Fun(2-)
    by (auto simp: SUP_le_iff) (metis length_replicate nth_replicate)
qed

lemma reflcl_over_nhole_mctxt_ta_sound:
  assumes "funas_term t \<subseteq> fset \<F>" "vars_term t \<subseteq> fset Q" "vars_term t \<noteq> {}"
  shows "(is_Var t \<longrightarrow> q\<^sub>i |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t) \<and>
    (is_Fun t \<longrightarrow> q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t)" using assms
proof (induct t)
  case (Fun f ts)
  let ?A = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
  from Fun(4) obtain i where vars: "i < length ts" "vars_term (ts ! i) \<noteq> {}"
    by (metis SUP_le_iff in_set_conv_nth subset_empty term.set(4))
  consider (v) "is_Var (ts ! i)" | (f) "is_Fun (ts ! i)" by blast
  then show ?case
  proof cases
    case v
    from v Fun(1)[OF nth_mem[OF vars(1)]] have "q\<^sub>i |\<in>| ta_der ?A (ts ! i)"
      using vars Fun(2-) by (auto simp: SUP_le_iff)
    moreover have "f (replicate (length ts) q\<^sub>c)[i := q\<^sub>i] \<rightarrow> q\<^sub>f |\<in>| rules ?A"
      using Fun(2) vars(1)
      by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember_iff_member_fset)
    moreover have "j < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der ?A (ts ! j)" for j using Fun(2-)
      by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
    ultimately show ?thesis using vars
      by auto (metis length_list_update length_replicate nth_list_update nth_replicate)
  next
    case f
    from f Fun(1)[OF nth_mem[OF vars(1)]] have "q\<^sub>f |\<in>| ta_der ?A (ts ! i)"
      using vars Fun(2-) by (auto simp: SUP_le_iff)
    moreover have "f (replicate (length ts) q\<^sub>c)[i := q\<^sub>f] \<rightarrow> q\<^sub>f |\<in>| rules ?A"
      using Fun(2) vars(1)
      by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember_iff_member_fset)
    moreover have "j < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der ?A (ts ! j)" for j using Fun(2-)
      by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
    ultimately show ?thesis using vars
      by auto (metis length_list_update length_replicate nth_list_update nth_replicate)
  qed
qed (auto simp: reflcl_over_nhole_mctxt_ta_simp simp flip: fmember_iff_member_fset dest!: ftranclD2)

lemma gen_nhole_gmctxt_closure_lang:
  assumes "q\<^sub>c |\<notin>| \<Q> \<A>" and "q\<^sub>i |\<notin>| \<Q> \<A>" "q\<^sub>f |\<notin>| \<Q> \<A>"
    and "q\<^sub>c |\<notin>| Q" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i" "q\<^sub>i \<noteq> q\<^sub>c"
  shows "gta_lang {|q\<^sub>f|} (gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
    { fill_gholes C ss |
      C ss. 0 < num_gholes C \<and> num_gholes C = length ss \<and> C \<noteq> GMHole \<and>
      funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
  interpret sq: derivation_split "?A" "\<A>" "?B"
    using assms unfolding derivation_split_def
    by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
        reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def dest!: semantic_path_rules_rhs)
  {fix s assume "s \<in> ?Ls" then obtain u where
      seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f |\<in>| ta_der'?B u"
      by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
    note der = seq(2)[unfolded ta_der_to_ta_der'[symmetric]]
    have "vars_term u \<subseteq> fset Q" "vars_term u \<noteq> {}"
      using ta_der'_gterm_states[OF seq(1)] assms(1 - 3)
      using reflcl_over_nhole_mctxt_ta_vars_term[OF der assms(4) assms(5) assms(5) assms(7)]
      using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF der]
      by (metis Un_insert_left insert_is_Un notin_fset subset_iff subset_insert)+
    then have vars: "\<not> ground u" "i < length (ta_der'_target_args u) \<Longrightarrow> ta_der'_target_args u ! i |\<in>| Q" for i
      by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
          fmember_iff_member_fset set_list_subset_nth_conv simp flip: set_vars_term_list)
    have hole: "ta_der'_target_mctxt u \<noteq> MHole" using vars assms(3-)
      using reflcl_over_nhole_mctxt_ta_Fun[OF der]
      using ta_der'_mctxt_structure(1, 3)[OF seq(1)]
      by auto (metis fill_holes_MHole gterm_ta_der_states length_map lessI map_nth_eq_conv seq(1) ta_der_to_ta_der' term.disc(1))
    let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
    have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
      using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms vars
      using ta_der'_ground_mctxt_structure[OF seq(1)] hole
      by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
          intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
          exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
          gta_langI[of "ta_der'_target_args u ! i" Q \<A>
            "gterm_of_term (?w i)" for i])}
  then have ls: "?Ls \<subseteq> ?Rs" by blast
  {fix t assume "t \<in> ?Rs"
    then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" "C \<noteq> GMHole" and
      gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
      reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
      const: "t = fill_gholes C ss" by auto
    from reachA obtain qs where states: "length ss = length qs" "\<forall> i < length qs. qs ! i |\<in>| Q |\<inter>| \<Q> \<A>"
      "\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> ((map term_of_gterm ss) ! i)"
      using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q |\<in>| Q"]
      by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
    have [simp]: "is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) \<longleftrightarrow> True"
      "is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) \<longleftrightarrow> False"
      using len(3) by (cases C, auto)+
    have "q\<^sub>f |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun states
      using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>f])
        (auto simp: funas_mctxt_of_gmctxt_conv  fmember_iff_member_fset set_list_subset_eq_nth_conv
          simp flip: fmember_iff_member_fset dest!: in_set_idx)
    then have "t \<in> ?Ls" unfolding const
      by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
  then show ?thesis using ls by blast
qed

lemma nhole_gmctxt_closure_lang:
  "\<L> (nhole_mctxt_closure_reg \<F> \<A>) =
    { fill_gholes C ss | C ss. num_gholes C = length ss \<and> 0 < num_gholes C \<and> C \<noteq> GMHole \<and>
      funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
  (is "?Ls = ?Rs")
proof -
  let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
  have ts: "Inr cl_state |\<notin>| \<Q>\<^sub>r ?B" "Inr tr_state |\<notin>| \<Q>\<^sub>r ?B" "Inr fin_state |\<notin>| \<Q>\<^sub>r ?B"
    "Inr cl_state |\<notin>| fin ?B"
    by (auto simp: fmap_states_reg_def)
  have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))) (ta (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)))
    = gta_lang (fin \<A>) (ta \<A>)"
    by (metis \<L>_def \<L>_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states)
  from gen_nhole_gmctxt_closure_lang[OF ts] show ?thesis
    by (auto simp add: nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def Let_def \<L>_def)
qed

subsubsection \<open>Correctness of @{const gen_mctxt_closure_reg} and @{const mctxt_closure_reg}\<close>

lemma gen_gmctxt_closure_lang:
  assumes "q\<^sub>c |\<notin>| \<Q> \<A>" and "q\<^sub>i |\<notin>| \<Q> \<A>" "q\<^sub>f |\<notin>| \<Q> \<A>"
    and disj: "q\<^sub>c |\<notin>| Q" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i" "q\<^sub>i \<noteq> q\<^sub>c"
  shows "gta_lang {|q\<^sub>f, q\<^sub>i|} (gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
    { fill_gholes C ss |
      C ss. 0 < num_gholes C \<and> num_gholes C = length ss \<and>
      funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
    (is "?Ls = ?Rs")
proof -
  let ?A = "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
  interpret sq: derivation_split "?A" "\<A>" "?B"
    using assms unfolding derivation_split_def
    by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
        reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def dest!: semantic_path_rules_rhs)
  {fix s assume "s \<in> ?Ls" then obtain u q where
      seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q |\<in>| ta_der'?B u" "q = q\<^sub>f \<or> q = q\<^sub>i"
      by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
    have "vars_term u \<subseteq> fset Q" "vars_term u \<noteq> {}"
      using ta_der'_gterm_states[OF seq(1)] assms seq(3)
      using reflcl_over_nhole_mctxt_ta_vars_term[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] disj(1) _ disj(2, 4)]
      using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] seq(3)]
      by (metis Un_insert_left notin_fset subsetD subset_insert sup_bot_left)+
    then have vars: "\<not> ground u" "i < length (ta_der'_target_args u) \<Longrightarrow> ta_der'_target_args u ! i |\<in>| Q" for i
      by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
          fmember_iff_member_fset set_list_subset_nth_conv simp flip: set_vars_term_list)
    let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
    have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
      using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms vars
      using ta_der'_ground_mctxt_structure[OF seq(1)]
      by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
          intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
          exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
          gta_langI[of "ta_der'_target_args u ! i" Q \<A>
            "gterm_of_term (?w i)" for i])}
  then have "?Ls \<subseteq> ?Rs" by blast
  moreover
  {fix t assume "t \<in> ?Rs"
    then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" and
      gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
      reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
      const: "t = fill_gholes C ss" by auto
    from const have const': "term_of_gterm t = fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss)"
      by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes len(2))
    from reachA obtain qs where states: "length ss = length qs" "\<forall> i < length qs. qs ! i |\<in>| Q |\<inter>| \<Q> \<A>"
      "\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> ((map term_of_gterm ss) ! i)"
      using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q |\<in>| Q"]
      by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
    have "C = GMHole \<Longrightarrow> is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True" using len states(1)
      by (metis fill_holes_MHole length_map mctxt_of_gmctxt.simps(1) nth_map num_gholes.simps(1) term.disc(1))
    then have hole: "C = GMHole \<Longrightarrow> q\<^sub>i |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun states len
      using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>i])
         (auto simp: funas_mctxt_of_gmctxt_conv  fmember_iff_member_fset set_list_subset_eq_nth_conv
          simp flip: fmember_iff_member_fset dest!: in_set_idx)
    have "C \<noteq> GMHole \<Longrightarrow> is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True"
      by (cases C) auto
    then have "C \<noteq> GMHole \<Longrightarrow> q\<^sub>f |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
      using reachA len gr_fun states
      using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
      by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>f])
         (auto simp: funas_mctxt_of_gmctxt_conv  fmember_iff_member_fset set_list_subset_eq_nth_conv
          simp flip: fmember_iff_member_fset dest!: in_set_idx)
    then have "t \<in> ?Ls" using hole const' unfolding gta_lang_def gta_der_def
      by (metis (mono_tags, lifting) fempty_iff finsert_iff finterI mem_Collect_eq)}
  ultimately show ?thesis
    by (meson subsetI subset_antisym)
qed

lemma gmctxt_closure_lang:
  "\<L> (mctxt_closure_reg \<F> \<A>) =
    { fill_gholes C ss | C ss. num_gholes C = length ss \<and> 0 < num_gholes C \<and>
      funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
  (is "?Ls = ?Rs")
proof -
  let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
  have ts: "Inr cl_state |\<notin>| \<Q>\<^sub>r ?B" "Inr tr_state |\<notin>| \<Q>\<^sub>r ?B" "Inr fin_state |\<notin>| \<Q>\<^sub>r ?B"
    "Inr cl_state |\<notin>| fin ?B"
    by (auto simp: fmap_states_reg_def)
  have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))) (ta (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)))
    = gta_lang (fin \<A>) (ta \<A>)"
    by (metis \<L>_def \<L>_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states)
  from gen_gmctxt_closure_lang[OF ts] show ?thesis
    by (auto simp add: mctxt_closure_reg_def gen_mctxt_closure_reg_def Let_def \<L>_def)
qed

subsubsection \<open>Correctness of @{const nhole_mctxt_reflcl_reg}\<close>

lemma nhole_mctxt_reflcl_lang:
  "\<L> (nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<F> \<A>) \<union> \<T>\<^sub>G (fset \<F>)"
proof -
  let ?refl = "Reg {|fin_clstate|} (refl_ta \<F> (fin_clstate))"
  {fix t assume "t \<in> \<L> ?refl" then have "t \<in> \<T>\<^sub>G (fset \<F>)"
      using reg_funas by fastforce}
  moreover
  {fix t assume "t \<in> \<T>\<^sub>G (fset \<F>)" then have "t \<in> \<L> ?refl"
      by (simp add: \<L>_def gta_langI refl_ta_sound)}
  ultimately have *: "\<L> ?refl = \<T>\<^sub>G (fset \<F>)"
    by blast
  show ?thesis unfolding nhole_mctxt_reflcl_reg_def \<L>_union * by simp
qed
declare ta_union_def [simp del]
end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Hash maps implementation} *}
theory HashMap_Impl
imports
  RBTMapImpl
  ListMapImpl
  "../../Lib/HashCode"
begin

text {*
  We use a red-black tree instead of an indexed array. This
  has the disadvantage of being more complex, however we need not bother
  about a fixed-size array and rehashing if the array becomes too full.

  The entries of the red-black tree are lists of (key,value) pairs.
*}

subsection {* Abstract Hashmap *}
text {*
  We first specify the behavior of our hashmap on the level of maps.
  We will then show that our implementation based on hashcode-map and bucket-map
  is a correct implementation of this specification.
*}
type_synonym
  ('k,'v) abs_hashmap = "hashcode \<rightharpoonup> ('k \<rightharpoonup> 'v)"

  -- "Map entry of map by function"
abbreviation map_entry where "map_entry k f m == m(k := f (m k))"

  -- "Invariant: Buckets only contain entries with the right hashcode and there are no empty buckets"
definition ahm_invar:: "('k::hashable,'v) abs_hashmap \<Rightarrow> bool"
  where "ahm_invar m ==
    (\<forall>hc cm k. m hc = Some cm \<and> k\<in>dom cm \<longrightarrow> hashcode k = hc) \<and>
    (\<forall>hc cm. m hc = Some cm \<longrightarrow> cm \<noteq> Map.empty)"

  -- "Abstract a hashmap to the corresponding map"
definition ahm_\<alpha> where
  "ahm_\<alpha> m k == case m (hashcode k) of
    None \<Rightarrow> None |
    Some cm \<Rightarrow> cm k"

  -- "Lookup an entry"
definition ahm_lookup :: "'k::hashable \<Rightarrow> ('k,'v) abs_hashmap \<Rightarrow> 'v option"
  where "ahm_lookup k m == (ahm_\<alpha> m) k"

  -- "The empty hashmap"
definition ahm_empty :: "('k::hashable,'v) abs_hashmap"
  where "ahm_empty = Map.empty"

  -- "Update/insert an entry"
definition ahm_update where
  "ahm_update k v m ==
    case m (hashcode k) of
      None \<Rightarrow> m (hashcode k \<mapsto> [k \<mapsto> v]) |
      Some cm \<Rightarrow> m (hashcode k \<mapsto> cm (k \<mapsto> v))
  "

  -- "Delete an entry"
definition ahm_delete where
  "ahm_delete k m == map_entry (hashcode k)
    (\<lambda>v. case v of
      None \<Rightarrow> None |
      Some bm \<Rightarrow> (
        if bm |` (- {k}) = Map.empty then
          None
        else
          Some ( bm |` (- {k}))
      )
    ) m
  "

definition ahm_isEmpty where
  "ahm_isEmpty m == m=Map.empty"

text {*
  Now follow correctness lemmas, that relate the hashmap operations to
  operations on the corresponding map. Those lemmas are named op\_correct, where
  op is the operation.
*}

lemma ahm_invarI: "\<lbrakk>
  !!hc cm k. \<lbrakk>m hc = Some cm; k\<in>dom cm\<rbrakk> \<Longrightarrow> hashcode k = hc;
  !!hc cm. \<lbrakk> m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty
  \<rbrakk> \<Longrightarrow> ahm_invar m"
  by (unfold ahm_invar_def) blast

lemma ahm_invarD: "\<lbrakk> ahm_invar m; m hc = Some cm; k\<in>dom cm \<rbrakk> \<Longrightarrow> hashcode k = hc"
  by (unfold ahm_invar_def) blast

lemma ahm_invarDne: "\<lbrakk> ahm_invar m; m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty"
  by (unfold ahm_invar_def) blast

lemma ahm_invar_bucket_not_empty[simp]:
  "ahm_invar m \<Longrightarrow> m hc \<noteq> Some Map.empty"
  by (auto dest: ahm_invarDne)

lemmas ahm_lookup_correct = ahm_lookup_def

lemma ahm_empty_correct:
  "ahm_\<alpha> ahm_empty = Map.empty"
  "ahm_invar ahm_empty"
  apply (rule ext)
  apply (unfold ahm_empty_def)
  apply (auto simp add: ahm_\<alpha>_def intro: ahm_invarI split: option.split)
  done

lemma ahm_update_correct:
  "ahm_\<alpha> (ahm_update k v m) = ahm_\<alpha> m (k \<mapsto> v)"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_update k v m)"
  apply (rule ext)
  apply (unfold ahm_update_def)
  apply (auto simp add: ahm_\<alpha>_def split: option.split)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD ahm_invarDne split: split_if_asm)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD split: split_if_asm)
  apply (drule (1) ahm_invarD)
  apply auto
  done

lemma fun_upd_apply_ne: "x\<noteq>y \<Longrightarrow> (f(x:=v)) y = f y"
  by simp

lemma cancel_one_empty_simp: "m |` (-{k}) = Map.empty \<longleftrightarrow> dom m \<subseteq> {k}"
proof
  assume "m |` (- {k}) = Map.empty"
  hence "{} = dom (m |` (-{k}))" by auto
  also have "\<dots> = dom m - {k}" by auto
  finally show "dom m \<subseteq> {k}" by blast
next
  assume "dom m \<subseteq> {k}"
  hence "dom m - {k} = {}" by auto
  hence "dom (m |` (-{k})) = {}" by auto
  thus "m |` (-{k}) = Map.empty" by (simp only: dom_empty_simp)
qed

lemma ahm_delete_correct:
  "ahm_\<alpha> (ahm_delete k m) = (ahm_\<alpha> m) |` (-{k})"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_delete k m)"
  apply (rule ext)
  apply (unfold ahm_delete_def)
  apply (auto simp add: ahm_\<alpha>_def Let_def Map.restrict_map_def
              split: option.split)[1]
  apply (drule_tac x=x in fun_cong)
  apply (auto)[1]
  apply (rule ahm_invarI)
  apply (auto split: split_if_asm option.split_asm dest: ahm_invarD)
  apply (drule (1) ahm_invarD)
  apply (auto simp add: restrict_map_def split: split_if_asm option.split_asm)
  done

lemma ahm_isEmpty_correct: "ahm_invar m \<Longrightarrow> ahm_isEmpty m \<longleftrightarrow> ahm_\<alpha> m = Map.empty"
proof
  assume "ahm_invar m" "ahm_isEmpty m"
  thus "ahm_\<alpha> m = Map.empty"
    by (auto simp add: ahm_isEmpty_def ahm_\<alpha>_def intro: ext)
next
  assume I: "ahm_invar m"
    and E: "ahm_\<alpha> m = Map.empty"

  show "ahm_isEmpty m"
  proof (rule ccontr)
    assume "\<not>ahm_isEmpty m"
    then obtain hc bm where MHC: "m hc = Some bm"
      by (unfold ahm_isEmpty_def)
         (blast elim: nempty_dom dest: domD)
    from ahm_invarDne[OF I, OF MHC] obtain k v where
      BMK: "bm k = Some v"
      by (blast elim: nempty_dom dest: domD)
    from ahm_invarD[OF I, OF MHC] BMK have [simp]: "hashcode k = hc"
      by auto
    hence "ahm_\<alpha> m k = Some v"
      by (simp add: ahm_\<alpha>_def MHC BMK)
    with E show False by simp
  qed
qed

lemmas ahm_correct = ahm_empty_correct ahm_lookup_correct ahm_update_correct
                     ahm_delete_correct ahm_isEmpty_correct

  -- "Bucket entries correspond to map entries"

  -- "Map entries correspond to bucket entries"
lemma ahm_e_is_be: "\<lbrakk>
  ahm_\<alpha> m k = Some v;
  !!bm. \<lbrakk>m (hashcode k) = Some bm; bm k = Some v \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (unfold ahm_\<alpha>_def)
     (auto split: option.split_asm)

subsection {* Concrete Hashmap *}
text {*
  In this section, we define the concrete hashmap that is made from the
  hashcode map and the bucket map.

  We then show the correctness of the operations w.r.t. the abstract hashmap, and
  thus, indirectly, w.r.t. the corresponding map.
*}

type_synonym
  ('k,'v) hm_impl = "(hashcode, ('k,'v) lm) rm"

subsubsection "Operations"

  -- "Auxiliary function: Apply function to value of an entry"
definition rm_map_entry
  :: "hashcode \<Rightarrow> ('v option \<Rightarrow> 'v option) \<Rightarrow> (hashcode, 'v) rm \<Rightarrow> (hashcode,'v) rm"
  where
  "rm_map_entry k f m ==
      case rm.lookup k m of
        None \<Rightarrow> (
          case f None of
            None \<Rightarrow> m |
            Some v \<Rightarrow> rm.update k v m
        ) |
        Some v \<Rightarrow> (
          case f (Some v) of
            None \<Rightarrow> rm.delete k m |
            Some v' \<Rightarrow> rm.update k v' m
        )
    "

  -- "Empty hashmap"
definition empty :: "unit \<Rightarrow> ('k :: hashable, 'v) hm_impl" where "empty == rm.empty"

  -- "Update/insert entry"
definition update :: "'k::hashable \<Rightarrow> 'v \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl"
  where
  "update k v m ==
   let hc = hashcode k in
     case rm.lookup hc m of
       None \<Rightarrow> rm.update hc (lm.update k v (lm.empty ())) m |
       Some bm \<Rightarrow> rm.update hc (lm.update k v bm) m"

  -- "Lookup value by key"
definition lookup :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> 'v option" where
  "lookup k m ==
   case rm.lookup (hashcode k) m of
     None \<Rightarrow> None |
     Some lm \<Rightarrow> lm.lookup k lm"

  -- "Delete entry by key"
definition delete :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl" where
  "delete k m ==
   rm_map_entry (hashcode k)
     (\<lambda>v. case v of
       None \<Rightarrow> None |
       Some lm \<Rightarrow> (
         let lm' = lm.delete k lm
         in  if lm.isEmpty lm' then None else Some lm'
       )
     ) m"

  -- "Emptiness check"
definition "isEmpty == rm.isEmpty"

  -- "Interruptible iterator"
definition "iteratei m c f \<sigma>0 ==
  rm.iteratei m c (\<lambda>(hc, lm) \<sigma>.
    lm.iteratei lm c f \<sigma>
  ) \<sigma>0"

lemma iteratei_alt_def :
  "iteratei m = set_iterator_image snd (
     set_iterator_product (rm.iteratei m) (\<lambda>hclm. lm.iteratei (snd hclm)))"
proof -
  have aux: "\<And>c f. (\<lambda>(hc, lm). lm.iteratei lm c f) = (\<lambda>m. lm.iteratei (snd m) c f)"
    by auto
  show ?thesis
    unfolding set_iterator_product_def set_iterator_image_alt_def
      iteratei_def[abs_def] aux
    by (simp add: split_beta)
qed

subsubsection "Correctness w.r.t. Abstract HashMap"
text {*
  The following lemmas establish the correctness of the operations w.r.t. the
  abstract hashmap.

  They have the naming scheme op\_correct', where op is the name of the
  operation.
*}

  -- "Abstract concrete hashmap to abstract hashmap"
definition hm_\<alpha>' where "hm_\<alpha>' m == \<lambda>hc. case rm.\<alpha> m hc of
  None \<Rightarrow> None |
  Some lm \<Rightarrow> Some (lm.\<alpha> lm)"

  -- "Invariant for concrete hashmap:
    The hashcode-map and bucket-maps satisfy their invariants and
    the invariant of the corresponding abstract hashmap is satisfied.
  "

definition "invar m == ahm_invar (hm_\<alpha>' m)"

lemma rm_map_entry_correct:
  "rm.\<alpha> (rm_map_entry k f m) = (rm.\<alpha> m)(k := f (rm.\<alpha> m k))"
  apply (auto
    simp add: rm_map_entry_def rm.delete_correct rm.lookup_correct rm.update_correct
    split: option.split)
  apply (auto simp add: Map.restrict_map_def fun_upd_def intro: ext)
  done

lemma empty_correct':
  "hm_\<alpha>' (empty ()) = ahm_empty"
  "invar (empty ())"
  by (simp_all add: hm_\<alpha>'_def empty_def ahm_empty_def rm.correct invar_def ahm_invar_def)

lemma lookup_correct':
  "invar m \<Longrightarrow> lookup k m = ahm_lookup k (hm_\<alpha>' m)"
  apply (unfold lookup_def invar_def)
  apply (auto split: option.split
              simp add: ahm_lookup_def ahm_\<alpha>_def hm_\<alpha>'_def
                        rm.correct lm.correct)
  done

lemma update_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (update k v m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: update_def ahm_update_def hm_\<alpha>'_def Let_def
                          rm.correct lm.correct
                split: option.split)
    done
  thus "invar m \<Longrightarrow> invar (update k v m)"
    by (simp add: invar_def ahm_update_correct)
qed

lemma delete_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (delete k m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: delete_def ahm_delete_def hm_\<alpha>'_def
                          rm_map_entry_correct
                          rm.correct lm.correct Let_def
                split: option.split option.split_asm)
    done
  thus "invar (delete k m)" using `invar m`
    by (simp add: ahm_delete_correct invar_def)
qed

lemma isEmpty_correct':
  "invar hm \<Longrightarrow> isEmpty hm \<longleftrightarrow> ahm_\<alpha> (hm_\<alpha>' hm) = Map.empty"
apply (simp add: isEmpty_def rm.isEmpty_correct invar_def
                 ahm_isEmpty_correct[unfolded ahm_isEmpty_def, symmetric])
by (auto simp add: hm_\<alpha>'_def ahm_\<alpha>_def fun_eq_iff split: option.split_asm)

(*
lemma sel_correct':
  assumes "invar hm"
  shows "\<lbrakk> sel hm f = Some r; \<And>u v. \<lbrakk> ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  and "\<lbrakk> sel hm f = None; ahm_\<alpha> (hm_\<alpha>' hm) u = Some v \<rbrakk> \<Longrightarrow> f (u, v) = None"
proof -
  assume sel: "sel hm f = Some r"
    and P: "\<And>u v. \<lbrakk>ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r\<rbrakk> \<Longrightarrow> P"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from TrueI sel obtain hc lm where "rm_\<alpha> hm hc = Some lm"
    and "lm_sel lm f = Some r"
    unfolding sel_def by (rule rm.sel_someE) simp
  from TrueI `lm_sel lm f = Some r`
  obtain k v where "lm_\<alpha> lm k = Some v" "f (k, v) = Some r"
    by(rule lm.sel_someE)
  from `rm_\<alpha> hm hc = Some lm` have "hm_\<alpha>' hm hc = Some (lm_\<alpha> lm)"
    by(simp add: hm_\<alpha>'_def)
  with IA have "ahm_\<alpha> (hm_\<alpha>' hm) k = Some v" using `lm_\<alpha> lm k = Some v`
    by(rule ahm_be_is_e)
  thus P using `f (k, v) = Some r` by(rule P)
next
  assume sel: "sel hm f = None"
    and \<alpha>: "ahm_\<alpha> (hm_\<alpha>' hm) u = Some v"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from \<alpha> obtain lm where \<alpha>_u: "hm_\<alpha>' hm (hashcode u) = Some lm"
    and "lm u = Some v" by (rule ahm_e_is_be)
  from \<alpha>_u obtain lmc where "rm_\<alpha> hm (hashcode u) = Some lmc" "lm = lm_\<alpha> lmc"
    by(auto simp add: hm_\<alpha>'_def split: option.split_asm)
  with `lm u = Some v` have "lm_\<alpha> lmc u = Some v" by simp
  from sel rm.sel_noneD [OF TrueI _ `rm_\<alpha> hm (hashcode u) = Some lmc`,
         of "(\<lambda>(hc, lm). lm_sel lm f)"]
  have "lm_sel lmc f = None" unfolding sel_def by simp
  with TrueI show "f (u, v) = None" using `lm_\<alpha> lmc u = Some v` by(rule lm.sel_noneD)
qed
*)

lemma iteratei_correct':
  assumes invar: "invar hm"
  shows "map_iterator (iteratei hm) (ahm_\<alpha> (hm_\<alpha>' hm))"
proof -
  from rm.iteratei_correct
  have it_rm: "map_iterator (rm.iteratei hm) (rm.\<alpha> hm)" by simp

  from lm.iteratei_correct
  have it_lm: "\<And>lm. map_iterator (lm.iteratei lm) (lm.\<alpha> lm)" by simp

  from set_iterator_product_correct
    [OF it_rm, of "\<lambda>hclm. lm.iteratei (snd hclm)"
     "\<lambda>hclm. map_to_set (lm.\<alpha> (snd hclm))", OF it_lm]
  have it_prod: "set_iterator
         (set_iterator_product (rm.iteratei hm) (\<lambda>hclm. lm.iteratei (snd hclm)))
         (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
    by simp

  show ?thesis unfolding iteratei_alt_def
  proof (rule set_iterator_image_correct[OF it_prod])
    from invar
    show "inj_on snd
       (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def split: option.splits)
      apply (metis domI option.inject)
    done
  next
    from invar
    show "map_to_set (ahm_\<alpha> (hm_\<alpha>' hm)) =
          snd ` (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def set_eq_iff image_iff split: option.splits)
      apply (auto simp add: dom_def ahm_\<alpha>_def split: option.splits)
    done
  qed
qed

lemmas hm_correct' = empty_correct' lookup_correct' update_correct'
                     delete_correct' isEmpty_correct'
                     iteratei_correct'
lemmas hm_invars = empty_correct'(2) update_correct'(2)
                   delete_correct'(2)

hide_const (open) empty invar lookup update delete isEmpty iteratei

end


header {* Monad-Zero Class *}

theory Monad_Zero
imports Monad
begin

class zeroU = tycon +
  fixes zeroU :: "udom\<cdot>'a::tycon"

class functor_zero = zeroU + "functor" +
  assumes fmapU_zeroU [coerce_simp]:
    "fmapU\<cdot>f\<cdot>zeroU = zeroU"

class monad_zero = zeroU + monad +
  assumes bindU_zeroU:
    "bindU\<cdot>zeroU\<cdot>f = zeroU"

instance monad_zero \<subseteq> functor_zero
proof
  fix f show "fmapU\<cdot>f\<cdot>zeroU = (zeroU :: udom\<cdot>'a)"
    unfolding fmapU_eq_bindU
    by (rule bindU_zeroU)
qed

definition fzero :: "'a\<cdot>'f::functor_zero"
  where "fzero = coerce\<cdot>(zeroU :: udom\<cdot>'f)"

lemma fmap_fzero:
  "fmap\<cdot>f\<cdot>(fzero :: 'a\<cdot>'f::functor_zero) = (fzero :: 'b\<cdot>'f)"
unfolding fmap_def fzero_def
by (simp add: coerce_simp)

abbreviation mzero :: "'a\<cdot>'m::monad_zero"
  where "mzero \<equiv> fzero"

lemmas mzero_def = fzero_def [where 'f="'m::monad_zero"] for f
lemmas fmap_mzero = fmap_fzero [where 'f="'m::monad_zero"] for f

lemma bindU_eq_bind: "bindU = bind"
unfolding bind_def by simp

lemma bind_mzero:
  "bind\<cdot>(fzero :: 'a\<cdot>'m::monad_zero)\<cdot>k = (mzero :: 'b\<cdot>'m)"
unfolding bind_def mzero_def
by (simp add: coerce_simp bindU_zeroU)

end


(* Author: Dmitriy Traytel *)

section \<open>Derivatives of $\Pi$-Extended Regular Expressions\<close>
(*<*)
theory Pi_Derivatives
imports Pi_Regular_Exp
begin
(*>*)

locale embed = project \<Sigma> wf_atom project lookup
  for \<Sigma> :: "nat \<Rightarrow> 'a set"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool" +
fixes embed :: "'a \<Rightarrow> 'a list"
assumes embed: "\<And>a. a \<in> \<Sigma> n \<Longrightarrow> b \<in> set (embed a) = (b \<in> \<Sigma> (Suc n) \<and> project b = a)"
begin

subsection \<open>Syntactic Derivatives\<close>

primrec lderiv :: "'a \<Rightarrow> 'b rexp \<Rightarrow> 'b rexp" where
  "lderiv _ Zero = Zero"
| "lderiv _ Full = Full"
| "lderiv _ One = Zero"
| "lderiv a (Atom b) = (if lookup b a then One else Zero)"
| "lderiv a (Plus r s) = Plus (lderiv a r) (lderiv a s)"
| "lderiv a (Times r s) =
    (let r's = Times (lderiv a r) s
     in if final r then Plus r's (lderiv a s) else r's)"
| "lderiv a (Star r) = Times (lderiv a r) (Star r)"
| "lderiv a (Not r) = Not (lderiv a r)"
| "lderiv a (Inter r s) = Inter (lderiv a r) (lderiv a s)"
| "lderiv a (Pr r) = Pr (PLUS (map (\<lambda>a'. lderiv a' r) (embed a)))"

primrec lderivs where
  "lderivs [] r = r"
| "lderivs (w#ws) r = lderivs ws (lderiv w r)"

subsection \<open>Finiteness of ACI-Equivalent Derivatives\<close>

lemma toplevel_summands_lderiv:
  "toplevel_summands (lderiv as r) = (\<Union>s\<in>toplevel_summands r. toplevel_summands (lderiv as s))"
  by (induct r) (auto simp: Let_def)

lemma lderivs_Zero[simp]: "lderivs xs Zero = Zero"
  by (induct xs) auto

lemma lderivs_Full[simp]: "lderivs xs Full = Full"
  by (induct xs) auto

lemma lderivs_One: "lderivs xs One \<in> {Zero, One}"
  by (induct xs) auto

lemma lderivs_Atom: "lderivs xs (Atom as) \<in> {Zero, One, Atom as}"
proof (induct xs)
  case (Cons x xs) thus ?case by (auto intro: insertE[OF lderivs_One])
qed simp

lemma lderivs_Plus: "lderivs xs (Plus r s) = Plus (lderivs xs r) (lderivs xs s)"
  by (induct xs arbitrary: r s) auto

lemma lderivs_PLUS: "lderivs xs (PLUS ys) = PLUS (map (lderivs xs) ys)"
  by (induct ys rule: list_singleton_induct) (auto simp: lderivs_Plus)

lemma toplevel_summands_lderivs_Times: "toplevel_summands (lderivs xs (Times r s)) \<subseteq>
  {Times (lderivs xs r) s} \<union>
  {r'. \<exists>ys zs. r' \<in> toplevel_summands (lderivs ys s) \<and> ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induct xs arbitrary: r s)
  case (Cons x xs)
  thus ?case by (auto simp: Let_def lderivs_Plus) (fastforce intro: exI[of _ "x#xs"])+
qed simp

lemma toplevel_summands_lderivs_Star_nonempty:
  "xs \<noteq> [] \<Longrightarrow> toplevel_summands (lderivs xs (Star r)) \<subseteq>
    {Times (lderivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induct xs rule: length_induct)
  case (1 xs)
  then obtain y ys where "xs = y # ys" by (cases xs) auto
  thus ?case using spec[OF 1(1)]
    by (auto dest!: subsetD[OF toplevel_summands_lderivs_Times] intro: exI[of _ "y#ys"])
       (auto elim!: impE dest!: meta_spec subsetD)
qed

lemma toplevel_summands_lderivs_Star:
  "toplevel_summands (lderivs xs (Star r)) \<subseteq>
    {Star r} \<union> {Times (lderivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
  by (cases "xs = []") (auto dest!: toplevel_summands_lderivs_Star_nonempty)

lemma ex_lderivs_Pr: "\<exists>s. lderivs ass (Pr r) = Pr s"
  by (induct ass arbitrary: r) auto

lemma toplevel_summands_PLUS:
 "xs \<noteq> [] \<Longrightarrow> toplevel_summands (PLUS (map f xs)) = (\<Union>r \<in> set xs. toplevel_summands (f r))"
  by (induct xs rule: list_singleton_induct) simp_all

lemma lderiv_toplevel_summands_Zero:
  "\<lbrakk>lderivs xs (Pr r) = Pr s; toplevel_summands r = {Zero}\<rbrakk> \<Longrightarrow> toplevel_summands s = {Zero}"
proof (induct xs arbitrary: r s)
  case (Cons y ys)
  from Cons.prems(1) have "toplevel_summands (PLUS (map (\<lambda>a. lderiv a r) (embed y))) = {Zero}"
  proof (cases "embed y = []")
    case False
    show ?thesis using Cons.prems(2) unfolding toplevel_summands_PLUS[OF False]
      by (subst toplevel_summands_lderiv) (simp add: False)
  qed simp
  with Cons show ?case by simp
qed simp

lemma toplevel_summands_lderivs_Pr:
  "\<lbrakk>xs \<noteq> []; lderivs xs (Pr r) = Pr s\<rbrakk> \<Longrightarrow>
    toplevel_summands s \<subseteq> {Zero} \<or> toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
proof (induct xs arbitrary: r s)
  case (Cons y ys) note * = this
  show ?case
  proof (cases "embed y = []")
    case True with Cons show ?thesis by (cases "ys = []") (auto dest: lderiv_toplevel_summands_Zero)
  next
    case False
    show ?thesis
    proof (cases ys)
      case Nil with * show ?thesis
        by (auto simp: toplevel_summands_PLUS[OF False]) (metis lderivs.simps)
    next
      case (Cons z zs)
      have "toplevel_summands s \<subseteq> {Zero} \<or> toplevel_summands s \<subseteq>
       (\<Union>xs. toplevel_summands (lderivs xs (PLUS (map (\<lambda>a. lderiv a r) (embed y)))))" (is "_ \<or> ?B")
        by (rule *(1)) (auto simp: Cons *(3)[symmetric])
      thus ?thesis
      proof
        assume ?B
        also have "\<dots> \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
          by (auto simp: lderivs_PLUS toplevel_summands_PLUS[OF False]) (metis lderivs.simps(2))
        finally show ?thesis ..
      qed blast
    qed
  qed
qed simp

lemma lderivs_Pr:
  "{lderivs xs (Pr r) | xs. True} \<subseteq>
    {Pr s | s. toplevel_summands s \<subseteq> {Zero} \<or>
               toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))}"
  (is "?L \<subseteq>?R")
proof (rule subsetI)
  fix s assume "s \<in> ?L"
  then obtain xs where "s = lderivs xs (Pr r)" by blast
  moreover obtain t where "lderivs xs (Pr r) = Pr t" using ex_lderivs_Pr by blast
  ultimately show "s \<in> ?R"
    by (cases "xs = []") (auto dest!: toplevel_summands_lderivs_Pr elim!: allE[of _ "[]"])
qed

lemma ACI_norm_toplevel_summands_Zero: "toplevel_summands r \<subseteq> {Zero} \<Longrightarrow> \<guillemotleft>r\<guillemotright> = Zero"
  by (subst ACI_norm_flatten) (auto dest: subset_singletonD)

lemma ACI_norm_lderivs_Pr:
  "ACI_norm ` {lderivs xs (Pr r) | xs. True} \<subseteq>
    {Pr Zero} \<union> {Pr \<guillemotleft>s\<guillemotright> | s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
proof (intro subset_trans[OF image_mono[OF lderivs_Pr]] subsetI,
       elim imageE CollectE exE conjE disjE)
  fix x x' s :: "'b rexp"
  assume *: "x = \<guillemotleft>x'\<guillemotright>" "x' = Pr s" and "toplevel_summands s \<subseteq> {Zero}"
  hence "\<guillemotleft>Pr s\<guillemotright> = Pr Zero" using ACI_norm_toplevel_summands_Zero by simp
  thus "x \<in> {Pr Zero} \<union>
    {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    unfolding * by blast
next
  fix x x' s :: "'b rexp"
  assume *: "x = \<guillemotleft>x'\<guillemotright>" "x' = Pr s" and "toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
  hence "toplevel_summands \<guillemotleft>s\<guillemotright> \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)"
    by (fastforce simp: toplevel_summands_ACI_norm)
  moreover have "x = Pr \<guillemotleft>\<guillemotleft>s\<guillemotright>\<guillemotright>" unfolding * ACI_norm_idem ACI_norm.simps(10) ..
  ultimately show "x \<in> {Pr Zero} \<union>
    {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    by blast
qed

lemma finite_ACI_norm_toplevel_summands: "finite B \<Longrightarrow> finite {f \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> B}"
  apply (elim finite_surj [OF iffD2 [OF finite_Pow_iff], of _ _ "f o flatten PLUS o image ACI_norm"])
  apply (subst ACI_norm_flatten)
  apply auto
  done

lemma lderivs_Not: "lderivs xs (Not r) = Not (lderivs xs r)"
  by (induct xs arbitrary: r) auto

lemma lderivs_Inter: "lderivs xs (Inter r s) = Inter (lderivs xs r) (lderivs xs s)"
  by (induct xs arbitrary: r s) auto

theorem finite_lderivs: "finite {\<guillemotleft>lderivs xs r\<guillemotright> | xs . True}"
proof (induct r)
  case Zero show ?case by simp
next
  case Full show ?case by simp
next
  case One show ?case
   by (rule finite_surj[of "{Zero, One}"]) (blast intro: insertE[OF lderivs_One])+
next
  case (Atom as) show ?case
    by (rule finite_surj[of "{Zero, One, Atom as}"]) (blast intro: insertE[OF lderivs_Atom])+
next
  case (Plus r s)
  show ?case by (auto simp: lderivs_Plus intro!: finite_surj[OF finite_cartesian_product[OF Plus]])
next
  case (Times r s)
  hence "finite (\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs s\<guillemotright> | xs . True}))" by auto
  moreover have "{\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (lderivs ys s)} =
    {r'. \<exists>ys. r' \<in> toplevel_summands \<guillemotleft>lderivs ys s\<guillemotright>}"
    unfolding toplevel_summands_ACI_norm by auto
  ultimately have fin: "finite {\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (lderivs ys s)}"
    by (fastforce intro: finite_subset[of _ "\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs s\<guillemotright> | xs . True})"])
  let ?X = "\<lambda>xs. {Times (lderivs ys r) s | ys. True} \<union> {r'. r' \<in> (\<Union>ys. toplevel_summands (lderivs ys s))}"
  show ?case
  proof (simp only: ACI_norm_flatten,
      rule finite_surj[of "{X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}" _ "flatten PLUS"])
    show "finite {X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}"
      using fin by (fastforce simp: image_Un elim: finite_subset[rotated] intro: finite_surj[OF Times(1), of _ "\<lambda>r. Times r \<guillemotleft>s\<guillemotright>"])
  qed (fastforce dest!: subsetD[OF toplevel_summands_lderivs_Times] intro!: imageI)
next
  case (Star r)
  let ?f = "\<lambda>f r'. Times r' (Star (f r))"
  let ?X = "{Star r} \<union> ?f id ` {r'. r' \<in> {lderivs ys r|ys. True}}"
  show ?case
  proof (simp only: ACI_norm_flatten,
      rule finite_surj[of "{X. X \<subseteq> ACI_norm ` ?X}" _ "flatten PLUS"])
    have *: "\<And>X. ACI_norm ` ?f (\<lambda>x. x) ` X = ?f ACI_norm ` ACI_norm ` X" by (auto simp: image_def)
    show "finite {X. X \<subseteq> ACI_norm ` ?X}"
      by (rule finite_Collect_subsets)
         (auto simp: * intro!: finite_imageI[of _ "?f ACI_norm"] intro: finite_subset[OF _ Star])
  qed (fastforce dest!: subsetD[OF toplevel_summands_lderivs_Star] intro!: imageI)
next
  case (Not r) thus ?case by (auto simp: lderivs_Not) (blast intro: finite_surj)
next
  case (Inter r s)
  show ?case by (auto simp: lderivs_Inter intro!: finite_surj[OF finite_cartesian_product[OF Inter]])
next
  case (Pr r)
  hence *: "finite (\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs r\<guillemotright> | xs . True}))" by auto
  have "finite (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)" by (rule finite_subset[OF _ *]) auto
  hence fin: "finite {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    by (intro finite_ACI_norm_toplevel_summands)
  have "{s. \<exists>xs. s = \<guillemotleft>lderivs xs (Pr r)\<guillemotright>} = {\<guillemotleft>s\<guillemotright>| s. \<exists>xs. s = lderivs xs (Pr r)}" by auto
  thus ?case using finite_subset[OF ACI_norm_lderivs_Pr, of r] fin unfolding image_Collect by auto
qed

subsection \<open>Wellformedness and language of derivatives\<close>

lemma wf_lderiv[simp]: "wf n r \<Longrightarrow> wf n (lderiv w r)"
  by (induct r arbitrary: n w) (auto simp add: Let_def)

lemma wf_lderivs[simp]: "wf n r \<Longrightarrow> wf n (lderivs ws r)"
  by (induct ws arbitrary: r) (auto intro: wf_lderiv)

lemma lQuot_map_project:
assumes "as \<in> \<Sigma> n" "A \<subseteq> lists (\<Sigma> (Suc n))"
shows "lQuot as (map project ` A) = map project ` (\<Union>a \<in> set (embed as). lQuot a A)" (is "?L = ?R")
proof (intro equalityI image_subsetI subsetI)
  fix xss assume "xss \<in> ?L"
  with assms obtain zss
    where zss: "zss \<in> A" "as # xss = map project zss"
    unfolding lQuot_def by fastforce
  hence "xss = map project (tl zss)" by auto
  with zss assms(2) show "xss \<in> ?R" using embed[OF project, of _ n] unfolding lQuot_def by fastforce
next
  fix xss assume "xss \<in> (\<Union>a \<in> set (embed as). lQuot a A)"
  with assms(1) show "map project xss \<in> lQuot as (map project ` A)" unfolding lQuot_def
    by (fastforce intro!: rev_image_eqI simp: embed)
qed

lemma lang_lderiv: "\<lbrakk>wf n r; w \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> lang n (lderiv w r) = lQuot w (lang n r)"
proof (induct r arbitrary: n w)
  case (Pr r)
  hence *: "wf (Suc n) r" "\<And>w'. w' \<in> set (embed w) \<Longrightarrow>  w' \<in> \<Sigma> (Suc n)" by (auto simp: embed)
  from Pr(1)[OF *] lQuot_map_project[OF Pr(3) lang_subset_lists[OF *(1)]] show ?case
    by (auto simp: wf_lderiv[OF *(1)])
qed (auto simp: Let_def lang_final[symmetric])

lemma lang_lderivs: "\<lbrakk>wf n r; wf_word n ws\<rbrakk> \<Longrightarrow> lang n (lderivs ws r) = lQuots ws (lang n r)"
  by (induct ws arbitrary: r) (auto simp: lang_lderiv)

corollary lderivs_final:
assumes "wf n r" "wf_word n ws"
shows "final (lderivs ws r) \<longleftrightarrow> ws \<in> lang n r"
  using lang_lderivs[OF assms] lang_final[of "lderivs ws r" n] by auto

abbreviation "lderivs_set n r s \<equiv> {(\<guillemotleft>lderivs w r\<guillemotright>, \<guillemotleft>lderivs w s\<guillemotright>) | w. wf_word n w}"

subsection \<open>Deriving preserves ACI-equivalence\<close>

lemma ACI_norm_PLUS:
  "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>) xs ys \<Longrightarrow> \<guillemotleft>PLUS xs\<guillemotright> = \<guillemotleft>PLUS ys\<guillemotright>"
proof (induct rule: list_all2_induct)
  case (Cons x xs y ys)
  hence "length xs = length ys" by (elim list_all2_lengthD)
  thus ?case using Cons by (induct xs ys rule: list_induct2) auto
qed simp

lemma toplevel_summands_ACI_norm_lderiv:
  "(\<Union>a\<in>toplevel_summands r. toplevel_summands \<guillemotleft>lderiv as \<guillemotleft>a\<guillemotright>\<guillemotright>) = toplevel_summands \<guillemotleft>lderiv as \<guillemotleft>r\<guillemotright>\<guillemotright>"
proof (induct r)
  case (Plus r1 r2) thus ?case
   unfolding toplevel_summands.simps toplevel_summands_ACI_norm
     toplevel_summands_lderiv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un Union_Un_distrib
   by (simp add: image_UN)
qed (auto simp: Let_def)

theorem ACI_norm_lderiv:
  "\<guillemotleft>lderiv as \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>lderiv as r\<guillemotright>"
proof (induct r arbitrary: as)
  case (Plus r1 r2) thus ?case
   unfolding lderiv.simps ACI_norm_flatten[of "lderiv as \<guillemotleft>Plus r1 r2\<guillemotright>"]
     toplevel_summands_lderiv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un image_UN
   by (auto simp: toplevel_summands_ACI_norm toplevel_summands_flatten_ACI_norm_image_Union)
     (auto simp: toplevel_summands_ACI_norm[symmetric] toplevel_summands_ACI_norm_lderiv)
next
  case (Pr r)
  hence "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>)
    (map (\<lambda>a. lderiv a \<guillemotleft>r\<guillemotright>) (embed as)) (map (\<lambda>a. lderiv a r) (embed as))"
    unfolding list_all2_map1 list_all2_map2 by (intro list_all2_refl)
  thus ?case unfolding lderiv.simps ACI_norm.simps by (blast intro: ACI_norm_PLUS)
qed (simp_all add: Let_def)

corollary lderiv_preserves: "\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright> \<Longrightarrow> \<guillemotleft>lderiv as r\<guillemotright> = \<guillemotleft>lderiv as s\<guillemotright>"
  by (rule box_equals[OF _ ACI_norm_lderiv ACI_norm_lderiv]) (erule arg_cong)

lemma lderivs_snoc[simp]: "lderivs (ws @ [w]) r = (lderiv w (lderivs ws r))"
  by (induct ws arbitrary: r) auto

theorem ACI_norm_lderivs:
  "\<guillemotleft>lderivs ws \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>lderivs ws r\<guillemotright>"
proof (induct ws arbitrary: r rule: rev_induct)
  case (snoc w ws) thus ?case
    using ACI_norm_lderiv[of w "lderivs ws r"] ACI_norm_lderiv[of w "lderivs ws \<guillemotleft>r\<guillemotright>"] by auto
qed simp

lemma lderivs_alt: "\<guillemotleft>lderivs w r\<guillemotright> = fold (\<lambda>a r. \<guillemotleft>lderiv a r\<guillemotright>) w \<guillemotleft>r\<guillemotright>"
  by (induct w arbitrary: r) (auto simp: ACI_norm_lderiv)

lemma finite_fold_lderiv: "finite {fold (\<lambda>a r. \<guillemotleft>lderiv a r\<guillemotright>) w \<guillemotleft>s\<guillemotright> |w. True}"
  using finite_lderivs unfolding lderivs_alt .

end

(*<*)
end
(*>*)