(*
  File:         PAC_Map_Rel.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory PAC_Map_Rel
  imports
    Refine_Imperative_HOL.IICF Finite_Map_Multiset
begin

section \<open>Hash-Map for finite mappings\<close>

text \<open>

This function declares hash-maps for \<^typ>\<open>('a, 'b)fmap\<close>, that are nicer
to use especially here where everything is finite.

\<close>
definition fmap_rel where
  [to_relAPP]:
  "fmap_rel K V \<equiv> {(m1, m2).
     (\<forall>i j. i |\<in>| fmdom m2 \<longrightarrow> (j, i) \<in> K \<longrightarrow> (the (fmlookup m1 j), the (fmlookup m2 i)) \<in> V) \<and>
     fset (fmdom m1) \<subseteq> Domain K \<and> fset (fmdom m2) \<subseteq> Range K \<and>
     (\<forall>i j. (i, j) \<in> K \<longrightarrow> j |\<in>| fmdom m2 \<longleftrightarrow> i |\<in>| fmdom m1)}"

lemma fmap_rel_alt_def:
  \<open>\<langle>K, V\<rangle>fmap_rel \<equiv>
     {(m1, m2).
      (\<forall>i j. i \<in># dom_m m2 \<longrightarrow>
             (j, i) \<in> K \<longrightarrow> (the (fmlookup m1 j), the (fmlookup m2 i)) \<in> V) \<and>
      fset (fmdom m1) \<subseteq> Domain K \<and>
      fset (fmdom m2) \<subseteq> Range K \<and>
      (\<forall>i j. (i, j) \<in> K \<longrightarrow> (j \<in># dom_m m2) = (i \<in># dom_m m1))}
\<close>
  unfolding fmap_rel_def dom_m_def fmember_iff_member_fset
  by auto

lemma fmdom_empty_fmempty_iff[simp]: \<open>fmdom m = {||} \<longleftrightarrow> m = fmempty\<close>
  by (metis fmdom_empty fmdrop_fset_fmdom fmdrop_fset_null)

lemma fmap_rel_empty1_simp[simp]:
  "(fmempty,m)\<in>\<langle>K,V\<rangle>fmap_rel \<longleftrightarrow> m=fmempty"
  apply (cases \<open>fmdom m = {||}\<close>)
   apply (auto simp: fmap_rel_def)[]
  by (auto simp add: fmember_iff_member_fset fmap_rel_def simp del: fmdom_empty_fmempty_iff)

lemma fmap_rel_empty2_simp[simp]:
  "(m,fmempty)\<in>\<langle>K,V\<rangle>fmap_rel \<longleftrightarrow> m=fmempty"
  apply (cases \<open>fmdom m = {||}\<close>)
   apply (auto simp: fmap_rel_def)[]
  by (fastforce simp add: fmember_iff_member_fset fmap_rel_def simp del: fmdom_empty_fmempty_iff)

sepref_decl_intf ('k,'v) f_map is "('k, 'v) fmap"

subsection \<open>Operations\<close>
sepref_decl_op fmap_empty: "fmempty" :: "\<langle>K,V\<rangle>fmap_rel" .

sepref_decl_op fmap_is_empty: "(=) fmempty" :: "\<langle>K,V\<rangle>fmap_rel \<rightarrow> bool_rel"
  apply (rule fref_ncI)
  apply parametricity
  apply (rule fun_relI; auto)
  done

lemma fmap_rel_fmupd_fmap_rel:
  \<open>(A, B) \<in> \<langle>K, R\<rangle>fmap_rel \<Longrightarrow> (p, p') \<in> K \<Longrightarrow> (q, q') \<in> R \<Longrightarrow>
   (fmupd p q A, fmupd p' q' B) \<in> \<langle>K, R\<rangle>fmap_rel\<close>
  if "single_valued K" "single_valued (K\<inverse>)"
  using that
  unfolding fmap_rel_alt_def
  apply (case_tac \<open>p' \<in># dom_m B\<close>)
  apply (auto simp add: all_conj_distrib IS_RIGHT_UNIQUED dest!: multi_member_split)
  done

sepref_decl_op fmap_update: "fmupd" :: "K \<rightarrow> V \<rightarrow> \<langle>K,V\<rangle>fmap_rel \<rightarrow> \<langle>K,V\<rangle>fmap_rel"
  where "single_valued K" "single_valued (K\<inverse>)"
  apply (rule fref_ncI)
  apply parametricity
  apply (intro fun_relI)
  by (rule fmap_rel_fmupd_fmap_rel)

lemma remove1_mset_eq_add_mset_iff:
   \<open>remove1_mset a A = add_mset a A' \<longleftrightarrow> A = add_mset a (add_mset a A')\<close>
  by (metis add_mset_add_single add_mset_diff_bothsides diff_zero remove1_mset_eqE)

lemma fmap_rel_fmdrop_fmap_rel:
  \<open>(fmdrop p A, fmdrop p' B) \<in> \<langle>K, R\<rangle>fmap_rel\<close>
  if single: "single_valued K" "single_valued (K\<inverse>)" and
    H0: \<open>(A, B) \<in> \<langle>K, R\<rangle>fmap_rel\<close> \<open>(p, p') \<in> K\<close>
proof -
  have H: \<open>\<And>Aa j.
       \<forall>i. i \<in># dom_m B \<longrightarrow> (\<forall>j. (j, i) \<in> K \<longrightarrow> (the (fmlookup A j), the (fmlookup B i)) \<in> R) \<Longrightarrow>
       remove1_mset p' (dom_m B) = add_mset p' Aa \<Longrightarrow> (j, p') \<in> K \<Longrightarrow> False\<close>
    by (metis dom_m_fmdrop fmlookup_drop in_dom_m_lookup_iff union_single_eq_member)
  have H2: \<open>\<And>i Aa j.
       (p, p') \<in> K \<Longrightarrow>
       \<forall>i. i \<in># dom_m B \<longrightarrow> (\<forall>j. (j, i) \<in> K \<longrightarrow> (the (fmlookup A j), the (fmlookup B i)) \<in> R) \<Longrightarrow>
       \<forall>i j. (i, j) \<in> K \<longrightarrow> (j \<in># dom_m B) = (i \<in># dom_m A) \<Longrightarrow>
       remove1_mset p' (dom_m B) = add_mset i Aa \<Longrightarrow>
       (j, i) \<in> K \<Longrightarrow>
            (the (fmlookup A j), the (fmlookup B i)) \<in> R \<and> j \<in># remove1_mset p (dom_m A) \<and>
        i \<in># remove1_mset p' (dom_m B)\<close>
    \<open>\<And>i j Aa.
       (p, p') \<in> K \<Longrightarrow>
       single_valued K \<Longrightarrow>
       single_valued (K\<inverse>) \<Longrightarrow>
       \<forall>i. i \<in># dom_m B \<longrightarrow> (\<forall>j. (j, i) \<in> K \<longrightarrow> (the (fmlookup A j), the (fmlookup B i)) \<in> R) \<Longrightarrow>
       fset (fmdom A) \<subseteq> Domain K \<Longrightarrow>
       fset (fmdom B) \<subseteq> Range K \<Longrightarrow>
       \<forall>i j. (i, j) \<in> K \<longrightarrow> (j \<in># dom_m B) = (i \<in># dom_m A) \<Longrightarrow>
       (i, j) \<in> K \<Longrightarrow> remove1_mset p (dom_m A) = add_mset i Aa \<Longrightarrow> j \<in># remove1_mset p' (dom_m B)\<close>
    using single
    by (metis IS_RIGHT_UNIQUED converse.intros dom_m_fmdrop fmlookup_drop in_dom_m_lookup_iff
        union_single_eq_member)+
  show \<open>(fmdrop p A, fmdrop p' B) \<in> \<langle>K, R\<rangle>fmap_rel\<close>
    using that
    unfolding fmap_rel_alt_def
    by (auto simp add: all_conj_distrib IS_RIGHT_UNIQUED
        dest!: multi_member_split dest: H H2)
qed

sepref_decl_op fmap_delete: "fmdrop" :: "K \<rightarrow> \<langle>K,V\<rangle>fmap_rel \<rightarrow> \<langle>K,V\<rangle>fmap_rel"
  where "single_valued K" "single_valued (K\<inverse>)"
  apply (rule fref_ncI)
  apply parametricity
  by (auto simp add: fmap_rel_fmdrop_fmap_rel)

lemma fmap_rel_nat_the_fmlookup[intro]:
  \<open>(A, B) \<in> \<langle>S, R\<rangle>fmap_rel \<Longrightarrow> (p, p') \<in> S \<Longrightarrow> p' \<in># dom_m B \<Longrightarrow>
     (the (fmlookup A p), the (fmlookup B p')) \<in> R\<close>
  by (auto simp: fmap_rel_alt_def distinct_mset_dom)

lemma fmap_rel_in_dom_iff:
  \<open>(aa, a'a) \<in> \<langle>K, V\<rangle>fmap_rel \<Longrightarrow>
    (a, a') \<in> K \<Longrightarrow>
    a' \<in># dom_m a'a \<longleftrightarrow>
    a \<in># dom_m aa\<close>
  unfolding fmap_rel_alt_def
  by auto

lemma fmap_rel_fmlookup_rel:
  \<open>(a, a') \<in> K \<Longrightarrow> (aa, a'a) \<in> \<langle>K, V\<rangle>fmap_rel \<Longrightarrow>
         (fmlookup aa a, fmlookup a'a a') \<in> \<langle>V\<rangle>option_rel\<close>
  using fmap_rel_nat_the_fmlookup[of aa a'a K V a a']
    fmap_rel_in_dom_iff[of aa a'a K V a a']
    in_dom_m_lookup_iff[of a' a'a]
    in_dom_m_lookup_iff[of a aa]
  by (cases \<open>a' \<in># dom_m a'a\<close>)
    (auto simp del: fmap_rel_nat_the_fmlookup)

sepref_decl_op fmap_lookup: "fmlookup" :: "\<langle>K,V\<rangle>fmap_rel \<rightarrow> K \<rightarrow>  \<langle>V\<rangle>option_rel"
  apply (rule fref_ncI)
  apply parametricity
  apply (intro fun_relI)
  apply (rule fmap_rel_fmlookup_rel; assumption)
  done

lemma in_fdom_alt: "k\<in>#dom_m m \<longleftrightarrow> \<not>is_None (fmlookup m k)"
  apply (auto split: option.split intro: fmdom_notI simp: dom_m_def fmember_iff_member_fset)
   apply (meson fmdom_notI notin_fset)
  using notin_fset by fastforce

sepref_decl_op fmap_contains_key: "\<lambda>k m. k\<in>#dom_m m" :: "K \<rightarrow> \<langle>K,V\<rangle>fmap_rel \<rightarrow> bool_rel"
  unfolding in_fdom_alt
  apply (rule fref_ncI)
  apply parametricity
  apply (rule fmap_rel_fmlookup_rel; assumption)
  done

subsection \<open>Patterns\<close>

lemma pat_fmap_empty[pat_rules]: "fmempty \<equiv> op_fmap_empty" by simp

lemma pat_map_is_empty[pat_rules]:
  "(=) $m$fmempty \<equiv> op_fmap_is_empty$m"
  "(=) $fmempty$m \<equiv> op_fmap_is_empty$m"
  "(=) $(dom_m$m)${#} \<equiv> op_fmap_is_empty$m"
  "(=) ${#}$(dom_m$m) \<equiv> op_fmap_is_empty$m"
  unfolding atomize_eq
  by (auto dest: sym)

lemma op_map_contains_key[pat_rules]:
  "(\<in>#) $ k $ (dom_m$m) \<equiv> op_fmap_contains_key$'k$'m"
  by (auto intro!: eq_reflection)

subsection \<open>Mapping to Normal Hashmaps\<close>

abbreviation map_of_fmap :: \<open>('k \<Rightarrow> 'v option) \<Rightarrow> ('k, 'v) fmap\<close> where
  \<open>map_of_fmap h \<equiv> Abs_fmap h\<close>

definition map_fmap_rel where
  \<open>map_fmap_rel = br map_of_fmap (\<lambda>a. finite (dom a))\<close>

lemma fmdrop_set_None:
  \<open>(op_map_delete, fmdrop) \<in> Id \<rightarrow> map_fmap_rel \<rightarrow> map_fmap_rel\<close>
  apply (auto simp: map_fmap_rel_def br_def)
  apply (subst fmdrop.abs_eq)
   apply (auto simp: eq_onp_def fmap.Abs_fmap_inject
      map_drop_def map_filter_finite
      intro!: ext)
   apply (auto simp: map_filter_def)
  done

lemma map_upd_fmupd:
  \<open>(op_map_update, fmupd) \<in> Id \<rightarrow> Id \<rightarrow> map_fmap_rel \<rightarrow> map_fmap_rel\<close>
  apply (auto simp: map_fmap_rel_def br_def)
  apply (subst fmupd.abs_eq)
   apply (auto simp: eq_onp_def fmap.Abs_fmap_inject
      map_drop_def map_filter_finite map_upd_def
      intro!: ext)
  done

text \<open>Technically @{term op_map_lookup} has the arguments in the wrong direction.\<close>
definition fmlookup' where
  [simp]: \<open>fmlookup' A k = fmlookup k A\<close>

lemma op_map_lookup_fmlookup:
  \<open>(op_map_lookup, fmlookup') \<in> Id \<rightarrow> map_fmap_rel \<rightarrow> \<langle>Id\<rangle>option_rel\<close>
  by (auto simp: map_fmap_rel_def br_def fmap.Abs_fmap_inverse)

abbreviation hm_fmap_assn where
  \<open>hm_fmap_assn K V \<equiv> hr_comp (hm.assn K V) map_fmap_rel\<close>

lemmas fmap_delete_hnr [sepref_fr_rules] =
  hm.delete_hnr[FCOMP fmdrop_set_None]

lemmas fmap_update_hnr [sepref_fr_rules] =
  hm.update_hnr[FCOMP map_upd_fmupd]

lemmas fmap_lookup_hnr [sepref_fr_rules] =
  hm.lookup_hnr[FCOMP op_map_lookup_fmlookup]

lemma fmempty_empty:
  \<open>(uncurry0 (RETURN op_map_empty), uncurry0 (RETURN fmempty)) \<in> unit_rel \<rightarrow>\<^sub>f \<langle>map_fmap_rel\<rangle>nres_rel\<close>
  by (auto simp: map_fmap_rel_def br_def fmempty_def frefI nres_relI)

lemmas [sepref_fr_rules] =
  hm.empty_hnr[FCOMP fmempty_empty, unfolded op_fmap_empty_def[symmetric]]

abbreviation iam_fmap_assn where
  \<open>iam_fmap_assn K V \<equiv> hr_comp (iam.assn K V) map_fmap_rel\<close>

lemmas iam_fmap_delete_hnr [sepref_fr_rules] =
  iam.delete_hnr[FCOMP fmdrop_set_None]

lemmas iam_ffmap_update_hnr [sepref_fr_rules] =
  iam.update_hnr[FCOMP map_upd_fmupd]

lemmas iam_ffmap_lookup_hnr [sepref_fr_rules] =
  iam.lookup_hnr[FCOMP op_map_lookup_fmlookup]

definition op_iam_fmap_empty where
  \<open>op_iam_fmap_empty = fmempty\<close>

lemma iam_fmempty_empty:
  \<open>(uncurry0 (RETURN op_map_empty), uncurry0 (RETURN op_iam_fmap_empty)) \<in> unit_rel \<rightarrow>\<^sub>f \<langle>map_fmap_rel\<rangle>nres_rel\<close>
  by (auto simp: map_fmap_rel_def br_def fmempty_def frefI nres_relI op_iam_fmap_empty_def)

lemmas [sepref_fr_rules] =
  iam.empty_hnr[FCOMP fmempty_empty, unfolded op_iam_fmap_empty_def[symmetric]]

definition upper_bound_on_dom where
  \<open>upper_bound_on_dom A = SPEC(\<lambda>n. \<forall>i \<in>#(dom_m A). i < n)\<close>

lemma [sepref_fr_rules]:
  \<open>((Array.len), upper_bound_on_dom) \<in> (iam_fmap_assn nat_assn V)\<^sup>k \<rightarrow>\<^sub>a nat_assn\<close>
proof -
  have [simp]: \<open>finite (dom b) \<Longrightarrow> i \<in> fset (fmdom (map_of_fmap b)) \<longleftrightarrow> i \<in> dom b\<close> for i b
    by (subst fmdom.abs_eq)
      (auto simp: eq_onp_def fset.Abs_fset_inverse)
  have 2: \<open>nat_rel = the_pure (nat_assn)\<close> and
    3: \<open>nat_assn = pure nat_rel\<close>
    by auto
  have [simp]: \<open>the_pure (\<lambda>a c :: nat. \<up> (c = a)) = nat_rel\<close>
    apply (subst 2)
    apply (subst 3)
    apply (subst pure_def)
    apply auto
    done

  have [simp]: \<open>(iam_of_list l, b) \<in> the_pure (\<lambda>a c :: nat. \<up> (c = a)) \<rightarrow> \<langle>the_pure V\<rangle>option_rel \<Longrightarrow>
       b i = Some y \<Longrightarrow> i < length l\<close>  for i b l y
    by (auto dest!: fun_relD[of _ _ _ _ i i] simp: option_rel_def
        iam_of_list_def split: if_splits)
  show ?thesis
    by sepref_to_hoare
      (sep_auto simp: upper_bound_on_dom_def hr_comp_def iam.assn_def map_rel_def
        map_fmap_rel_def is_iam_def br_def dom_m_def)
qed

lemma fmap_rel_nat_rel_dom_m[simp]:
  \<open>(A, B) \<in> \<langle>nat_rel, R\<rangle>fmap_rel \<Longrightarrow> dom_m A = dom_m B\<close>
  by (subst distinct_set_mset_eq_iff[symmetric])
    (auto simp: fmap_rel_alt_def distinct_mset_dom
      simp del: fmap_rel_nat_the_fmlookup)

lemma ref_two_step':
  \<open>A \<le> B \<Longrightarrow>  \<Down> R A \<le> \<Down> R B\<close>
  using ref_two_step by auto

end


(* Author: Dmitriy Traytel *)

section \<open>Deciding Equivalence of $\Pi$-Extended Regular Expressions\<close>

(*<*)
theory Pi_Equivalence_Checking
imports Pi_Regular_Exp "HOL-Library.While_Combinator" List_More
begin
(*>*)

lemma image2p_in_rel: "BNF_Greatest_Fixpoint.image2p f g (in_rel R) =  in_rel (map_prod f g ` R)"
  unfolding image2p_def fun_eq_iff by auto

lemma image2p_apply: "BNF_Greatest_Fixpoint.image2p f g R x y = (\<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"
  unfolding image2p_def fun_eq_iff by auto

lemma rtrancl_fold_product:
shows "{((r, s), (f a r, f a s))| r s a. a \<in> A}^* =
       {((r, s), (fold f w r, fold f w s))| r s w. w \<in> lists A}" (is "?L = ?R")
proof-
  { fix x :: "('a \<times> 'a) \<times> 'a \<times> 'a"
    obtain r s r' s' where x: "x = ((r, s), (r', s'))" by (cases x) auto
    have "((r, s), (r', s')) \<in> ?L \<Longrightarrow> ((r, s), (r', s')) \<in> ?R"
    proof(induction rule: converse_rtrancl_induct2)
      case refl show ?case by(force intro!: fold_simps(1)[symmetric])
    next
      case step thus ?case by(force intro!: fold_simps(2)[symmetric])
    qed
    with x have "x \<in> ?L \<Longrightarrow> x \<in> ?R" by simp
  } moreover
  { fix x :: "('a \<times> 'a) \<times> 'a \<times> 'a"
    obtain r s r' s' where x: "x = ((r, s), (r', s'))" by (cases x) auto
    { fix w have "\<forall>x\<in>set w. x \<in> A \<Longrightarrow> ((r, s), fold f w r, fold f w s) \<in> ?L"
      proof(induction w rule: rev_induct)
        case Nil show ?case by simp
      next
        case snoc thus ?case by (auto elim!: rtrancl_into_rtrancl)
      qed
    }
    hence "((r, s), (r', s')) \<in> ?R \<Longrightarrow> ((r, s), (r', s')) \<in> ?L" by auto
    with x have "x \<in> ?R \<Longrightarrow> x \<in> ?L" by simp
  } ultimately show ?thesis by blast
qed

lemma in_fold_lQuot: "v \<in> fold lQuot w L \<longleftrightarrow> w @ v \<in> L"
  by (induct w arbitrary: L) (simp_all add: lQuot_def)

lemma (in project) lang_eq_ext: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> (lang n r = lang n s) =
  (\<forall>w \<in> lists(\<Sigma> n). w \<in> lang n r \<longleftrightarrow> w \<in> lang n s)"
  by (auto dest!: lang_subset_lists)

lemma (in project) lang_eq_ext_Nil_fold_Deriv:
  fixes r s n
  assumes WF: "wf n r" "wf n s"
  defines "\<BB> \<equiv> {(fold lQuot w (lang n r), fold lQuot w (lang n s))| w. w\<in>lists (\<Sigma> n)}"
  shows "lang n r = lang n s \<longleftrightarrow> (\<forall>(K, L) \<in> \<BB>. [] \<in> K \<longleftrightarrow> [] \<in> L)"
  unfolding lang_eq_ext[OF WF] \<BB>_def
  by (subst (1 2) in_fold_lQuot[of "[]", simplified, symmetric]) auto

locale rexp_DA = project "set o \<sigma>" wf_atom project lookup
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes init :: "'b rexp \<Rightarrow> 's"
  fixes delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  fixes final :: "'s \<Rightarrow> bool"
  fixes wf_state :: "'s \<Rightarrow> bool"
  fixes post :: "'s \<Rightarrow> 's"
  fixes L :: "'s \<Rightarrow> 'a lang"
  fixes n :: "nat"
  assumes L_init[simp]: "wf n r \<Longrightarrow> L (init r) = lang n r"
  assumes L_delta[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> L (delta a s) = lQuot a (L s)"
  assumes final_iff_Nil[simp]: "final s \<longleftrightarrow> [] \<in> L s"
  assumes L_wf_state[dest]: "wf_state s \<Longrightarrow> L s \<subseteq> lists (set (\<sigma> n))"
  assumes init_wf_state[simp]: "wf n r \<Longrightarrow> wf_state (init r)"
  assumes delta_wf_state[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> wf_state (delta a s)"
  assumes L_post[simp]: "wf_state s \<Longrightarrow> L (post s) = L s"
  assumes wf_state_post[simp]: "wf_state s \<Longrightarrow> wf_state (post s)"
begin

lemma L_deltas[simp]: "\<lbrakk>wf_word n w; wf_state s\<rbrakk> \<Longrightarrow> L (fold delta w s) = fold lQuot w (L s)"
  by (induction w arbitrary: s) auto

definition progression (infix "\<rightarrow>" 60) where
  "R \<rightarrow> S = (\<forall>s1 s2. R s1 s2 \<longrightarrow> wf_state s1 \<and> wf_state s2 \<and> final s1 = final s2 \<and>
     (\<forall>x \<in> set (\<sigma> n). BNF_Greatest_Fixpoint.image2p post post S (post (delta x s1)) (post (delta x s2))))"

lemma SUPR_progression[intro!]: "\<forall>n. \<exists>m. X n \<rightarrow> Y m \<Longrightarrow> (SUP n. X n) \<rightarrow> (SUP n. Y n)"
  unfolding progression_def image2p_def by fastforce

definition bisimulation where
  "bisimulation R = R \<rightarrow> R"

definition bisimulation_upto where
  "bisimulation_upto R f = R \<rightarrow> f R"

declare image2pI[intro!] image2pE[elim!]
lemmas bisim_def = bisimulation_def progression_def
lemmas bisim_upto_def = bisimulation_upto_def progression_def

definition compatible where
  "compatible f = (mono f \<and> (\<forall>R S. R \<rightarrow> S \<longrightarrow> f R \<rightarrow> f S))"

lemmas compat_def = compatible_def progression_def

lemma bisimulation_upto_bisimulation:
  assumes "compatible f" "bisimulation_upto R f"
  obtains S where "bisimulation S" "R \<le> S"
proof
  { fix n from assms have "(f^^n) R \<rightarrow> (f^^Suc n) R"
     by (induct n) (auto simp: bisimulation_upto_def compatible_def) }
  then show "bisimulation (SUP n. (f^^n) R)"
    unfolding bisimulation_def by (auto simp del: funpow.simps)
  show "R \<le> (SUP n. (f^^n) R)" by (auto intro!: exI[of _ 0])
qed

lemma bisimulation_eqL: "bisimulation (\<lambda>s1 s2. wf_state s1 \<and> wf_state s2 \<and> L s1 = L s2)"
  unfolding bisim_def by (auto simp: lQuot_def)

lemma coinduction:
  assumes bisim[unfolded bisim_def]: "bisimulation R" and
    WF: "wf_state s1" "wf_state s2" and R: "R s1 s2"
  shows "L s1 = L s2"
proof (rule set_eqI)
  fix w
  from R WF show "w \<in> L s1 \<longleftrightarrow> w \<in> L s2"
  proof (induction w arbitrary: s1 s2)
    case Nil then show ?case using bisim by simp
  next
    case (Cons a w s1 s2)
    show ?case
    proof cases
      assume a: "a \<in> set (\<sigma> n)"
      with \<open>R s1 s2\<close> obtain s1' s2' where "R s1' s2'" "wf_state s1'" "wf_state s2'" and
        *[symmetric]: "post s1' = post (delta a s1)"  "post s2' = post (delta a s2)"
        using bisim unfolding image2p_apply by blast
      then have "w \<in> L (post (delta a s1)) \<longleftrightarrow> w \<in> L (post (delta a s2))"
        unfolding * using Cons.IH[of s1' s2'] by simp
      with a Cons.prems(2,3) show ?case by (simp add: lQuot_def)
    next
      assume "a \<notin> set (\<sigma> n)"
      thus ?case using Cons.prems bisim by force
    qed
  qed
qed

lemma coinduction_upto:
  assumes "bisimulation_upto R f" and WF: "wf_state s1" "wf_state s2" and "R s1 s2" "compatible f"
  shows "L s1 = L s2"
proof (rule bisimulation_upto_bisimulation[OF assms(5,1)])
  fix S assume "R \<le> S"
  assume "bisimulation S"
  then show "L s1 = L s2"
  proof (rule coinduction[OF _ WF])
    from \<open>R \<le> S\<close> \<open>R s1 s2\<close> show "S s1 s2" by blast
  qed
qed

fun test_invariant where
  "test_invariant (ws, _ :: ('s \<times> 's) list , _ :: 's rel) = (case ws of [] \<Rightarrow>  False | (w::'a list,p,q)#_ \<Rightarrow> final p = final q)"
fun test where "test (ws, _ :: 's rel) = (case ws of [] \<Rightarrow>  False | (p,q)#_ \<Rightarrow> final p = final q)"

fun step_invariant where "step_invariant (ws, ps, N) =
    (let
      (w, r, s) = hd ws;
      ps' = (r, s) # ps;
      succs = map (\<lambda>a.
        let r' = delta a r; s' = delta a s
        in ((a # w, r', s'), (post r', post s'))) (\<sigma> n);
      new = remdups' snd (filter (\<lambda>(_, rs). rs \<notin> N) succs);
      ws' = tl ws @ map fst new;
      N' = set (map snd new) \<union> N
    in (ws', ps', N'))"

fun step where "step (ws, N) =
    (let
      (r, s) = hd ws;
      succs = map (\<lambda>a.
        let r' = delta a r; s' = delta a s
        in ((r', s'), (post r', post s'))) (\<sigma> n);
      new = remdups' snd (filter (\<lambda>(_, rs). rs \<notin> N) succs)
    in (tl ws @ map fst new, set (map snd new) \<union> N))"

definition closure_invariant where "closure_invariant = while_option test_invariant step_invariant"
definition closure where "closure = while_option test step"

definition invariant where
  "invariant r s = (\<lambda>(ws, ps, N).
     (r, s) \<in> snd ` set ws \<union> set ps \<and>
     distinct (map snd ws @ ps) \<and>
     bij_betw (map_prod post post) (set (map snd ws @ ps)) N \<and>
     (\<forall>(w, r', s') \<in> set ws. fold delta (rev w) r = r' \<and> fold delta (rev w) s = s' \<and>
        wf_word n (rev w) \<and> wf_state r' \<and> wf_state s') \<and>
     (\<forall>(r', s') \<in> set ps. (\<exists>w. fold delta w r = r' \<and> fold delta w s = s') \<and>
       wf_state r' \<and> wf_state s' \<and> (final r' \<longleftrightarrow> final s') \<and>
       (\<forall>a\<in>set (\<sigma> n). (post (delta a r'), post (delta a s')) \<in> N)))"

lemma invariant_start:
  "\<lbrakk>wf_state r; wf_state s\<rbrakk> \<Longrightarrow> invariant r s ([([], r, s)], [], {(post r, post s)})"
  by (auto simp add: invariant_def bij_betw_def)

lemma step_invatiant_unfold: "step_invariant (w # ws, ps, N) = (ws', ps', N') \<Longrightarrow> (\<exists>xs r s.
  w = (xs, r, s) \<and> ps' = (r, s) # ps \<and>
  ws' = ws @ remdups' (map_prod post post o snd) (filter (\<lambda>(_, p). map_prod post post p \<notin> N)
   (map (\<lambda>a. (a#xs, delta a r, delta a s)) (\<sigma> n))) \<and>
  N' = set (map (\<lambda>a. (post (delta a r), post (delta a s))) (\<sigma> n)) \<union> N)"
  by (auto split: prod.splits dest!: mp_remdups'
  simp: Let_def filter_map set_n_lists image_Collect image_image comp_def)

lemma invariant: "invariant r s st \<Longrightarrow> test_invariant st \<Longrightarrow> invariant r s (step_invariant st)"
proof (unfold invariant_def, (split prod.splits)+, elim case_prodE conjE, clarify, intro allI impI conjI)
  fix ws ps N ws' ps' N'
  assume test_invariant: "test_invariant (ws, ps, N)"
  and step_invariant: "step_invariant (ws, ps, N) = (ws', ps', N')"
  and rs: "(r, s) \<in> snd ` set ws \<union> set ps"
  and distinct: "distinct (map snd ws @ ps)"
  and bij: "bij_betw (map_prod post post) (set (map snd ws @ ps)) N"
  and ws: "\<forall>(w, r', s') \<in> set ws. fold delta (rev w) r = r' \<and> fold delta (rev w) s = s' \<and>
    wf_word n (rev w) \<and> wf_state r' \<and> wf_state s'"
      (is "\<forall>(w, r', s') \<in> set ws. ?ws w r' s'")
  and ps: "\<forall>(r', s') \<in> set ps. (\<exists>w. fold delta w r = r' \<and> fold delta w s = s') \<and>
    wf_state r' \<and> wf_state s' \<and> (final r' \<longleftrightarrow> final s') \<and>
    (\<forall>a\<in>set (\<sigma> n). (post (delta a r'), post (delta a s')) \<in> N)"
      (is "\<forall>(r, s) \<in> set ps. ?ps r s N")
  from test_invariant obtain x xs where ws_Cons: "ws = x # xs" by (cases ws) auto
  obtain w r' s' where x: "x = (w, r', s')" and ps': "ps' = (r', s') # ps"
    and ws': "ws' = xs @ remdups' (map_prod post post o snd)
      (filter (\<lambda>(_, p). map_prod post post p \<notin> N)
        (map (\<lambda>a. (a # w, delta a r',  delta a s')) (\<sigma> n)))"
    and N': "N' = (set (map (\<lambda>a. (post (delta a r'), post (delta a s'))) (\<sigma> n)) - N) \<union> N"
    using step_invatiant_unfold[OF step_invariant[unfolded ws_Cons]] by blast
  hence ws'ps': "set (map snd ws' @ ps') =
     set (remdups' (map_prod post post) (filter (\<lambda>p. map_prod post post p \<notin> N)
    (map (\<lambda>a. (delta a r',  delta a s')) (\<sigma> n)))) \<union> (set (map snd ws @ ps))"
    unfolding ws' ps' ws_Cons x by (auto dest!: mp_remdups' simp: filter_map image_image image_Un o_def)
  from rs step_invariant show "(r, s) \<in> snd ` set ws' \<union> set ps'" by (blast dest: step_invariant_mono)
(*next*)
  from distinct ps' ws' ws_Cons x bij show "distinct (map snd ws' @ ps')"
    by (auto simp: bij_betw_def
      intro!: imageI[of _ _ "map_prod post post"] distinct_remdups'_strong
        map_prod_imageI[of _ _ _ post post]
      dest!: mp_remdups'
      elim: image_eqI[of _ snd, OF sym[OF snd_conv]])
(*next*)
  from ps' ws' N' ws x bij show "bij_betw (map_prod post post) (set (map snd ws' @ ps')) N'"
  unfolding ws'ps' N' by (intro bij_betw_combine[OF _ bij]) (auto simp: bij_betw_def map_prod_def)
(*next*)
  from ws x ws_Cons have wr's': "?ws w r' s'" by auto
  with ws ws_Cons show "\<forall>(w, r', s') \<in> set ws'. ?ws w r' s'" unfolding ws'
    by (auto dest!: mp_remdups' elim!: subsetD)
(*next*)
  from ps wr's' test_invariant[unfolded ws_Cons x] show "\<forall>(r', s') \<in> set ps'. ?ps r' s' N'" unfolding ps' N'
    by (fastforce simp: image_Collect)
qed

lemma step_commute: "ws \<noteq> [] \<Longrightarrow>
  (case step_invariant (ws, ps, N) of (ws', ps', N') \<Rightarrow> (map snd ws', N')) = step (map snd ws, N)"
apply (auto split: prod.splits)
   apply (auto simp only: step_invariant.simps step.simps Let_def map_apfst_remdups' filter_map list.map_comp apfst_def map_prod_def snd_conv id_def)
   apply (auto simp: filter_map comp_def map_tl hd_map)
 apply (intro image_eqI, auto)+
done

lemma closure_invariant_closure:
  "map_option (\<lambda>(ws, ps, N). (map snd ws, N)) (closure_invariant (ws, ps, N)) = closure (map snd ws, N)"
  unfolding closure_invariant_def closure_def
  by (rule trans[OF while_option_commute[of _ test _ _ "step"]])
   (auto split: list.splits simp del: step_invariant.simps step.simps list.map simp: step_commute)

lemma
  assumes result: "closure_invariant ([([], init r, init s)], [], {(post (init r), post (init s))}) =
    Some(ws, ps, N)" (is "closure_invariant ([([], ?r, ?s)], _) = _")
  and WF: "wf n r" "wf n s"
  shows closure_invariant_sound: "ws = [] \<Longrightarrow> lang n r = lang n s" and
    counterexample: "ws \<noteq> [] \<Longrightarrow> rev (fst (hd ws)) \<in> lang n r \<longleftrightarrow> rev (fst (hd ws)) \<notin> lang n s"
proof -
  from WF have wf_state: "wf_state ?r" "wf_state ?s" by simp_all
  from invariant invariant_start[OF wf_state] have invariant_ps: "invariant ?r ?s (ws, ps, N)"
    by (rule while_option_rule[OF _ result[unfolded closure_invariant_def]])
  { assume "ws = []"
    with invariant_ps have "bisimulation (in_rel (set ps))" "(?r, ?s) \<in> set ps"
      by (auto simp: bij_betw_def invariant_def bisimulation_def progression_def image2p_in_rel)
    with wf_state have "L ?r = L ?s" by (auto dest: coinduction)
    with WF show "lang n r = lang n s" by simp
  }
  { assume "ws \<noteq> []"
    then obtain w r' s' ws' where ws: "ws = (w, r', s') # ws'" by (cases ws) auto
    with invariant_ps have "r' = fold delta (rev w) (init r)" "s' = fold delta (rev w) (init s)"
      "wf_word n (rev w)" unfolding invariant_def by auto
    moreover have "\<not> test_invariant ((w, r', s') # ws', ps, N)"
      by (rule while_option_stop[OF result[unfolded ws closure_invariant_def]])
    ultimately have "rev (fst (hd ws)) \<in> L ?r \<longleftrightarrow> rev (fst (hd ws)) \<notin> L ?s"
      unfolding ws using wf_state by (simp add: in_fold_lQuot)
    with WF show "rev (fst (hd ws)) \<in> lang n r \<longleftrightarrow> rev (fst (hd ws)) \<notin> lang n s" by simp
  }
qed

lemma closure_sound:
  assumes result: "closure ([(init r, init s)], {(post (init r), post (init s))}) = Some ([], N)"
  and WF: "wf n r" "wf n s"
  shows "lang n r = lang n s"
  using trans[OF closure_invariant_closure[of "[([], init r, init s)]", simplified] result]
  by (auto dest: closure_invariant_sound[OF _ WF])

definition check_eqv where
  "check_eqv r s =
    (let r' = init r; s' = init s in (case closure ([(r', s')], {(post r', post s')}) of
       Some ([], _) \<Rightarrow> True | _ \<Rightarrow> False))"

lemma check_eqv_sound:
  assumes "check_eqv r s" and WF: "wf n r" "wf n s"
  shows "lang n r = lang n s"
  using closure_sound assms
  by (auto simp: check_eqv_def Let_def split: option.splits list.splits)

definition counterexample where
  "counterexample r s =
    (let r' = init r; s' = init s in (case closure_invariant ([([], r', s')], [], {(post r', post s')}) of
       Some((w,_,_) # _, _) \<Rightarrow> Some (rev w) | _ => None))"

lemma counterexample_sound:
  assumes result: "counterexample r s = Some w"  and WF: "wf n r" "wf n s"
  shows "w \<in> lang n r \<longleftrightarrow> w \<notin> lang n s"
  using assms unfolding counterexample_def Let_def
  by (auto dest!: counterexample[of r s] split: option.splits list.splits)

text\<open>Auxiliary exacutable functions:\<close>

definition reachable :: "'b rexp \<Rightarrow> 's set" where
  "reachable s = snd (the (rtrancl_while (\<lambda>_. True) (\<lambda>s. map (\<lambda>a. post (delta a s)) (\<sigma> n)) (init s)))"

definition automaton :: "'b rexp \<Rightarrow> (('s * 'a) * 's) set" where
  "automaton s =
    snd (the
    (let i = init s;
         start = (([i], {post i}), {});
         test_invariant = \<lambda>((ws, Z), A). ws \<noteq> [];
         step_invariant = \<lambda>((ws, Z), A).
           (let s = hd ws;
                new_edges = map (\<lambda>a. ((s, a), delta a s)) (\<sigma> n);
                new = remdups (filter (\<lambda>ss. post ss \<notin> Z) (map snd new_edges))
           in ((new @ tl ws, post ` set new \<union> Z), set new_edges \<union> A))
    in while_option test_invariant step_invariant start))"

definition match :: "'b rexp \<Rightarrow> 'a list \<Rightarrow> bool" where
  "match s w = final (fold delta w (init s))"

lemma match_correct: "\<lbrakk>wf_word n w; wf n s\<rbrakk> \<Longrightarrow> match s w \<longleftrightarrow> w \<in> lang n s"
  unfolding match_def
  by (induct w arbitrary: s) (auto simp: in_fold_lQuot lQuot_def)

end

locale rexp_DFA = rexp_DA \<sigma> wf_atom project lookup init delta final wf_state post L n
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and init :: "'b rexp \<Rightarrow> 's"
  and delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  and final :: "'s \<Rightarrow> bool"
  and wf_state :: "'s \<Rightarrow> bool"
  and post :: "'s \<Rightarrow> 's"
  and L :: "'s \<Rightarrow> 'a lang"
  and n :: nat +
assumes fin: "finite {fold delta w (init s) | w. True}"
begin

abbreviation "Reachable s \<equiv> {fold delta w (init s) | w. True}"

lemma closure_invariant_termination:
  assumes WF: "wf n r" "wf n s"
  and result: "closure_invariant ([([], init r, init s)], [], {(post (init r), post (init s))}) = None"
    (is "closure_invariant ([([], ?r, ?s)], _) = None" is "?cl = None")
  shows "False"
proof -
  let ?D =  "post ` Reachable r \<times> post ` Reachable s"
  let ?X = "\<lambda>ps. ?D - map_prod post post ` set ps"
  let ?f = "\<lambda>(ws, ps, N). card (?X ps)"
  have "\<exists>st. ?cl = Some st" unfolding closure_invariant_def
  proof (rule measure_while_option_Some[of "invariant ?r ?s" _ _ ?f], intro conjI)
    fix st assume base: "invariant ?r ?s st" and "test_invariant st"
    hence step: "invariant ?r ?s (step_invariant st)" by (rule invariant)
    obtain ws ps N where st: "st = (ws, ps, N)" by (cases st) blast
    hence "finite (?X ps)" by (blast intro: finite_cartesian_product fin)
    moreover obtain ws' ps' N' where step_invariant: "step_invariant (ws, ps, N) = (ws', ps', N')"
      by (cases "step_invariant (ws, ps, N)") blast
    moreover
    { have "map_prod post post ` set ps \<subseteq> ?D" using base[unfolded st invariant_def] by fast
      moreover
      have "map_prod post post ` set ps' \<subseteq> ?D" using step[unfolded st step_invariant invariant_def]
        by fast
      moreover
      { have "distinct (map snd ws @ ps)" "inj_on (map_prod post post) (set (map snd ws @ ps))"
          using base[unfolded st invariant_def] by (auto simp: bij_betw_def)
        hence "distinct (map (map_prod post post) (map snd ws @ ps))" unfolding distinct_map ..
        hence "map_prod post post ` set ps \<subset> map_prod post post ` set (snd (hd ws) # ps)"
          using \<open>test_invariant st\<close> st by (cases ws) (simp_all, blast)
        moreover have "map_prod post post ` set ps' = map_prod post post ` set (snd (hd ws) # ps)"
          using step_invariant by (auto split: prod.splits)
        ultimately have "map_prod post post ` set ps \<subset> map_prod post post ` set ps'" by simp
      }
      ultimately have "?X ps' \<subset> ?X ps" by (auto simp add: image_set simp del: set_map)
    }
    ultimately show "?f (step_invariant st) < ?f st" unfolding st step_invariant
      using psubset_card_mono[of "?X ps" "?X ps'"] by simp
  qed (auto simp add: invariant_start WF invariant)
  then show False using result by auto
qed

lemma closure_termination:
  assumes WF: "wf n r" "wf n s"
  and result: "closure ([(init r, init s)], {(post (init r), post (init s))}) = None"
  shows "False"
  using trans[OF closure_invariant_closure[of "[([], init r, init s)]", simplified] result]
  by (auto intro: closure_invariant_termination[OF WF])

lemma closure_invariant_complete:
  assumes eq: "lang n r = lang n s"
  and WF:  "wf n r" "wf n s"
  shows "\<exists>ps N. closure_invariant ([([], init r, init s)], [], {(post (init r), post (init s))}) =
    Some([], ps, N)" (is "\<exists>_ _. closure_invariant ([([], ?r, ?s)], _) = _" is "\<exists>_ _. ?cl = _")
proof (cases ?cl)
  case (Some st)
  moreover obtain ws ps N where ws_ps_N: "st = (ws, ps, N)" by (cases st) blast
  ultimately show ?thesis
  proof (cases ws)
    case (Cons wrs ws)
    with Some obtain w where "counterexample r s = Some w" unfolding counterexample_def
      by (cases wrs) (auto simp: ws_ps_N)
    with eq counterexample_sound[OF _ WF] show ?thesis by blast
  qed blast
qed (auto intro: closure_invariant_termination[OF WF])

lemma closure_complete:
  assumes "lang n r = lang n s" "wf n r" "wf n s"
  shows "\<exists>N. closure ([(init r, init s)], {(post (init r), post (init s))}) = Some ([], N)"
  using closure_invariant_complete[OF assms]
  by (subst closure_invariant_closure[of "[([], init r, init s)]", simplified, symmetric]) auto

lemma check_eqv_complete:
  assumes "lang n r = lang n s" "wf n r" "wf n s"
  shows "check_eqv r s"
  using closure_complete[OF assms] by (auto simp: check_eqv_def)

lemma counterexample_complete:
  assumes "lang n r \<noteq> lang n s" and WF: "wf n r" "wf n s"
  shows "\<exists>w. counterexample r s = Some w"
  using closure_invariant_sound[OF _ WF] closure_invariant_termination[OF WF] assms
  by (fastforce simp: counterexample_def Let_def split: option.splits list.splits)

end

locale rexp_DA_no_post = rexp_DA \<sigma> wf_atom project lookup init delta final wf_state id L n
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and init :: "'b rexp \<Rightarrow> 's"
  and delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  and final :: "'s \<Rightarrow> bool"
  and wf_state :: "'s \<Rightarrow> bool"
  and L :: "'s \<Rightarrow> 'a lang"
  and n :: nat
begin

lemma step_efficient[code]: "step (ws, N) =
  (let
    (r, s) = hd ws;
    new = remdups (filter (\<lambda>(r,s). (r,s) \<notin> N) (map (\<lambda>a. (delta a r, delta a s)) (\<sigma> n)))
  in (tl ws @ new, set new \<union> N))"
  by (force simp: Let_def map_apfst_remdups' filter_map o_def split: prod.splits)

end

locale rexp_DFA_no_post = rexp_DFA \<sigma> wf_atom project lookup init delta final wf_state id L
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and init :: "'b rexp \<Rightarrow> 's"
  and delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  and final :: "'s \<Rightarrow> bool"
  and wf_state :: "'s \<Rightarrow> bool"
  and L :: "'s \<Rightarrow> 'a lang"
begin

sublocale rexp_DA_no_post by unfold_locales

end

locale rexp_DA_sim = project "set o \<sigma>" wf_atom project lookup
  for \<sigma> :: "nat \<Rightarrow> 'a list"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes init :: "'b rexp \<Rightarrow> 's"
  fixes sim_delta :: "'s \<Rightarrow> 's list"
  fixes final :: "'s \<Rightarrow> bool"
  fixes wf_state :: "'s \<Rightarrow> bool"
  fixes L :: "'s \<Rightarrow> 'a lang"
  fixes post :: "'s \<Rightarrow> 's"
  fixes n :: nat
  assumes L_init[simp]: "wf n r \<Longrightarrow> L (init r) = lang n r"
  assumes final_iff_Nil[simp]: "final s \<longleftrightarrow> [] \<in> L s"
  assumes L_wf_state[dest]: "wf_state s \<Longrightarrow> L s \<subseteq> lists (set (\<sigma> n))"
  assumes init_wf_state[simp]: "wf n r \<Longrightarrow> wf_state (init r)"
  assumes L_post[simp]: "wf_state s \<Longrightarrow> L (post s) = L s"
  assumes wf_state_post[simp]: "wf_state s \<Longrightarrow> wf_state (post s)"
  assumes L_sim_delta[simp]: "wf_state s \<Longrightarrow> map L (sim_delta s) = map (\<lambda>a. lQuot a (L s)) (\<sigma> n)"
  assumes sim_delta_wf_state[simp]: "wf_state s \<Longrightarrow> \<forall>s' \<in> set (sim_delta s). wf_state s'"
begin

definition "delta a s = sim_delta s ! index (\<sigma> n) a"

lemma length_sim_delta[simp]: "wf_state s \<Longrightarrow> length (sim_delta s) = length (\<sigma> n)"
  by (metis L_sim_delta length_map)

lemma L_delta[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> L (delta a s) = lQuot a (L s)"
  using L_sim_delta[of s] unfolding delta_def in_set_conv_nth
  by (subst (asm) list_eq_iff_nth_eq) auto

lemma delta_wf_state[simp]: "\<lbrakk>a \<in> set (\<sigma> n); wf_state s\<rbrakk> \<Longrightarrow> wf_state (delta a s)"
  unfolding delta_def by (auto intro: bspec[OF sim_delta_wf_state nth_mem])

sublocale rexp_DA \<sigma> wf_atom project lookup init delta final wf_state post L
  by unfold_locales auto

sublocale rexp_DA_sim_no_post: rexp_DA_no_post \<sigma> wf_atom project lookup init delta final wf_state L
  by unfold_locales auto

end

(*<*)
end
(*>*)