(*  Title:       An adaptation of the work on Presburger automata to the automata
                 defined here
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

section \<open> Presburger Adaptation \<close>

theory Presburger_Adapt
imports Main NFA DFA
  "implementation/NFASpec"
  "../Presburger-Automata/DFS"
  "../Presburger-Automata/Presburger_Automata"
begin

text \<open> The translation of Presburger arithmetic to finite automata
defined in the AFP Library \emph{Presburger-Automata} consists of
building finite automata for Diophantine equations and inequations as well as
standard automata constructions. These automata constructions are
however defined on a datastructure which is well suited for the
specific automata used. Here, let's try to replace these specialised
finite automata with general ones. \<close>

subsection \<open> DFAs for Diophantine Equations and Inequations \<close>

subsubsection \<open> Definition \<close>

datatype pres_NFA_state =
   pres_NFA_state_error
 | pres_NFA_state_int int

fun pres_DFA_eq_ineq_trans_fun where
   "pres_DFA_eq_ineq_trans_fun ineq ks pres_NFA_state_error _ = pres_NFA_state_error"
 | "pres_DFA_eq_ineq_trans_fun ineq ks (pres_NFA_state_int j) bs =
      (if (ineq \<or> (eval_dioph ks (map nat_of_bool bs)) mod 2 = j mod 2)
           then pres_NFA_state_int ((j - (eval_dioph ks (map nat_of_bool bs))) div 2)
           else pres_NFA_state_error)"

fun pres_DFA_is_node where
  "pres_DFA_is_node ks l (pres_NFA_state_error) = True"
| "pres_DFA_is_node ks l (pres_NFA_state_int m) =
   dioph_is_node ks l m"

lemma finite_pres_DFA_is_node_set [simp] :
  "finite {q. pres_DFA_is_node ks l q}"
proof -
  have set_eq: "{q. pres_DFA_is_node ks l q} =
   insert pres_NFA_state_error
     (pres_NFA_state_int ` {m. dioph_is_node ks l m})"
   (is "?s1 = ?s2")
  proof (intro set_eqI)
    fix q
    show "(q \<in> ?s1) = (q \<in> ?s2)"
    proof (cases q)
      case pres_NFA_state_error thus ?thesis by simp
    next
      case (pres_NFA_state_int m)
      thus ?thesis by auto
    qed
  qed

  show ?thesis
  apply (simp add: set_eq)
  apply (rule finite_imageI)
  apply (insert Presburger_Automata.dioph_dfs.graph_finite)
  apply simp
  done
qed

definition pres_DFA_eq_ineq ::
  "bool \<Rightarrow> nat \<Rightarrow> int list \<Rightarrow> int \<Rightarrow> (pres_NFA_state, bool list) NFA_rec" where
  "pres_DFA_eq_ineq ineq n ks l =
     \<lparr> \<Q> = {q. pres_DFA_is_node ks l q},
       \<Sigma> = {bs . length bs = n},
       \<Delta> = {(q, bs, pres_DFA_eq_ineq_trans_fun ineq ks q bs) | q bs.
             pres_DFA_is_node ks l q \<and> length bs = n},
       \<I> = {pres_NFA_state_int l},
       \<F> = {pres_NFA_state_int m |m.
             dioph_is_node ks l m \<and> 0 \<le> m \<and> (ineq \<or> m = 0)} \<rparr>"

subsubsection \<open> Properties \<close>
lemma pres_DFA_is_node___pres_DFA_eq_ineq_trans_fun :
assumes q_OK: "pres_DFA_is_node ks l q"
    and bs_OK: "length bs = n"
shows "pres_DFA_is_node ks l (pres_DFA_eq_ineq_trans_fun i ks q bs)"
proof (cases "pres_DFA_eq_ineq_trans_fun i ks q bs")
    case pres_NFA_state_error
    thus ?thesis
       unfolding pres_DFA_eq_ineq_def by simp
next
    case (pres_NFA_state_int m')
    note q'_eq = this

    then obtain m where
          q_eq : "q = pres_NFA_state_int m"
      and m'_eq : "m' = (m - eval_dioph ks (map nat_of_bool bs)) div 2"
      and cond: "i \<or> eval_dioph ks (map nat_of_bool bs) mod 2 = m mod 2"
      apply (cases q, simp_all)
      by (metis pres_NFA_state.inject pres_NFA_state.simps(3))

    from q_OK q_eq have is_node_m: "dioph_is_node ks l m"
      unfolding pres_DFA_eq_ineq_def
      by simp

    have "m' \<in> set (dioph_ineq_succs n ks m)"
      using bs_OK
      unfolding dioph_ineq_succs_def List.map_filter_def pres_DFA_eq_ineq_def
      apply (simp add: o_def image_iff m'_eq Bex_def)
      apply (rule_tac exI [where x = "map nat_of_bool bs"])
      apply (simp add: nat_of_bool_mk_nat_vecs)
    done
    with dioph_ineq_dfs.succs_is_node [OF is_node_m]
    show ?thesis
      unfolding pres_DFA_eq_ineq_def q'_eq
      by (simp add: list_all_iff)
qed

lemma pres_DFA_eq_ineq___is_well_formed :
  "DFA (pres_DFA_eq_ineq i n ks l)"
unfolding DFA_alt_def NFA_full_def SemiAutomaton_is_complete_deterministic_def
proof (intro conjI allI impI)
  show "\<I> (pres_DFA_eq_ineq i n ks l) \<subseteq> \<Q> (pres_DFA_eq_ineq i n ks l)"
    unfolding pres_DFA_eq_ineq_def
    by (simp add: dioph_is_node_def)
next
  show "\<F> (pres_DFA_eq_ineq i n ks l) \<subseteq> \<Q> (pres_DFA_eq_ineq i n ks l)"
    unfolding pres_DFA_eq_ineq_def
    by (auto simp add: subset_iff)
next
  let ?p = "pres_DFA_eq_ineq i n ks l"
  show "finite (\<Sigma> ?p)"
    unfolding pres_DFA_eq_ineq_def
    by (simp, rule Presburger_Automata.finite_list)

  moreover
  show fin\<Q>: "finite (\<Q> ?p)"
    unfolding pres_DFA_eq_ineq_def
    by simp

  moreover
  {
    fix q bs q'
    assume in_D: "(q, bs, q') \<in> \<Delta> ?p"
    then show "q \<in> \<Q> ?p"
      and  "bs \<in> \<Sigma> ?p"
      and  "q' \<in> \<Q> ?p"
      using pres_DFA_is_node___pres_DFA_eq_ineq_trans_fun
      unfolding pres_DFA_eq_ineq_def
      by simp_all
  }
  hence "\<Delta> ?p \<subseteq> \<Q> ?p \<times> \<Sigma> ?p \<times> \<Q> ?p" by auto
  ultimately show "finite (\<Delta> ?p)" using finite_subset by blast
next
  show "\<exists>q0. \<I> (pres_DFA_eq_ineq i n ks l) = {q0}"
    unfolding pres_DFA_eq_ineq_def
    by simp
next
  show "LTS_is_complete_deterministic (\<Q> (pres_DFA_eq_ineq i n ks l)) (\<Sigma> (pres_DFA_eq_ineq i n ks l))
     (\<Delta> (pres_DFA_eq_ineq i n ks l))"
  unfolding pres_DFA_eq_ineq_def LTS_is_complete_deterministic_def
    LTS_is_deterministic_def LTS_is_complete_def
  by (simp add: pres_DFA_is_node___pres_DFA_eq_ineq_trans_fun)
qed

interpretation pres_DFA_eq_ineq :
  DFA "pres_DFA_eq_ineq i n ks l"
using  pres_DFA_eq_ineq___is_well_formed[of i n ks l] .

lemma \<delta>_pres_DFA_eq_ineq :
 "\<delta> (pres_DFA_eq_ineq i n ks l) (q, bs) =
  (if (pres_DFA_is_node ks l q \<and> length bs = n) then
      Some (pres_DFA_eq_ineq_trans_fun i ks q bs)
   else None)"
using pres_DFA_eq_ineq.\<delta>_in_\<Delta>_iff [symmetric]
      pres_DFA_eq_ineq.DetSemiAutomaton_\<delta>_is_none_iff
  by (simp add: pres_DFA_eq_ineq_def)

lemma pres_DFA_eq_ineq_reach_error :
"list_all (is_alph n) bss \<Longrightarrow>
 DLTS_reach (\<delta> (pres_DFA_eq_ineq i n ks l)) pres_NFA_state_error bss = Some (pres_NFA_state_error)"
proof (induct bss)
  case Nil thus ?case by simp
next
  case (Cons bs bss)
  from Cons(2) have len_bs: "length bs = n" by (simp add: is_alph_def)
  from Cons(2) have bss_OK: "list_all (is_alph n) bss" by simp
  note ind_hyp = Cons(1) [OF bss_OK]

  from len_bs
  have step: "\<delta> (pres_DFA_eq_ineq i n ks l) (pres_NFA_state_error, bs) =
    Some pres_NFA_state_error"
    unfolding \<delta>_pres_DFA_eq_ineq
    by simp

  from step ind_hyp
  show ?case by simp
qed

lemma eval_dioph_nats_of_boolss_eq:
"\<lbrakk>length bs = n; list_all (is_alph n) bss\<rbrakk> \<Longrightarrow>
eval_dioph ks (nats_of_boolss n (bs # bss)) = j \<longleftrightarrow>
eval_dioph ks (map nat_of_bool bs) mod 2 = j mod 2 \<and>
eval_dioph ks (nats_of_boolss n bss) = (j - eval_dioph ks (map nat_of_bool bs)) div 2"
apply (subst eval_dioph_div_mod)
apply (simp add: nats_of_boolss_mod2 nats_of_boolss_div2)
done

lemma pres_DFA_eq_ineq_reach_eq :
assumes "pres_NFA_state_int j \<in> \<Q> (pres_DFA_eq_ineq False n ks l)"
    and "list_all (is_alph n) bss"
shows "DLTS_reach (\<delta> (pres_DFA_eq_ineq False n ks l)) (pres_NFA_state_int j) bss = Some (pres_NFA_state_int 0) \<longleftrightarrow>
       eval_dioph ks (nats_of_boolss n bss) = j"
using assms
proof (induct bss arbitrary: j)
  case Nil
  thus ?case
  by (simp add: eval_dioph_replicate_0)
next
  case (Cons bs bss' j)
  from Cons(3) have
    bs_in: "length bs = n" and
    bss'_in : "list_all (is_alph n) bss'"
    by (simp_all add: is_alph_def)
  note ind_hyp = Cons(1) [OF _ bss'_in]
  note j_in_Q = Cons(2)

  have \<delta>_j_bs_eq:
   "\<delta> (pres_DFA_eq_ineq False n ks l) (pres_NFA_state_int j, bs) = Some (pres_DFA_eq_ineq_trans_fun False ks (pres_NFA_state_int j) bs)"
    using j_in_Q bs_in
    unfolding \<delta>_pres_DFA_eq_ineq
    unfolding pres_DFA_eq_ineq_def
    by simp

  show ?case
  proof (cases "eval_dioph ks (map nat_of_bool bs) mod 2 = j mod 2")
    case False
    thus ?thesis
      by (simp add: pres_DFA_eq_ineq_reach_error
        \<delta>_j_bs_eq eval_dioph_nats_of_boolss_eq bs_in bss'_in)
  next
    case True note cond_true = True

    have j'_in_Q: "pres_DFA_eq_ineq_trans_fun False ks (pres_NFA_state_int j) bs \<in> \<Q> (pres_DFA_eq_ineq False n ks l)"
    using bs_in j_in_Q pres_DFA_is_node___pres_DFA_eq_ineq_trans_fun [where i = False]
    unfolding pres_DFA_eq_ineq_def
    by (simp add: cond_true del: pres_DFA_eq_ineq_trans_fun.simps)

    have j'_eq: "pres_DFA_eq_ineq_trans_fun False ks (pres_NFA_state_int j) bs =
      pres_NFA_state_int ((j - eval_dioph ks (map nat_of_bool bs)) div 2)"
      by (simp add: cond_true)

    from ind_hyp [OF j'_in_Q [unfolded j'_eq]]
    show ?thesis
      by (simp add: pres_DFA_eq_ineq_reach_error
        \<delta>_j_bs_eq eval_dioph_nats_of_boolss_eq bs_in bss'_in)
  qed
qed

lemma pres_DFA_eq_correct :
assumes bss_OK: "list_all (is_alph n) bss"
shows "NFA_accept (pres_DFA_eq_ineq False n ks l) bss =
       (eval_dioph ks (nats_of_boolss n bss) = l)"
proof -
  have \<i>_eval: "\<i> (pres_DFA_eq_ineq False n ks l) = pres_NFA_state_int l"
    unfolding pres_DFA_eq_ineq_def
    by (simp add: \<i>_def)

  have \<F>_eval: "\<F> (pres_DFA_eq_ineq False n ks l) = {pres_NFA_state_int 0}"
    unfolding pres_DFA_eq_ineq_def
    by (auto simp add: dioph_is_node_def)

  from pres_DFA_eq_ineq.\<i>_is_state [of False n ks l]
  have l_in_Q: "pres_NFA_state_int l \<in> \<Q> (pres_DFA_eq_ineq False n ks l)"
    by (simp add: \<i>_eval)
  note dioph_OK = pres_DFA_eq_ineq_reach_eq [OF l_in_Q bss_OK, symmetric]

  have "DLTS_reach (\<delta> (pres_DFA_eq_ineq False n ks l)) (pres_NFA_state_int l) bss \<noteq> None"
    using bss_OK
    apply (simp add: pres_DFA_eq_ineq.DetSemiAutomaton_reach_is_none_iff)
    apply (simp add: pres_DFA_eq_ineq_def is_alph_def in_lists_conv_set
      dioph_is_node_def Ball_set_list_all)
  done
  thus ?thesis
    by (auto simp add: pres_DFA_eq_ineq.DFA_accept_alt_def dioph_OK \<F>_eval \<i>_eval)
qed

lemma pres_DFA_eq_ineq_reach_ineq :
assumes "pres_NFA_state_int j \<in> \<Q> (pres_DFA_eq_ineq True n ks l)"
    and "list_all (is_alph n) bss"
    and "DLTS_reach (\<delta> (pres_DFA_eq_ineq True n ks l)) (pres_NFA_state_int j) bss = Some (pres_NFA_state_int j')"
shows "0 \<le> j' \<longleftrightarrow> eval_dioph ks (nats_of_boolss n bss) \<le> j"
using assms
proof (induct bss arbitrary: j j')
  case Nil
  thus ?case
  by (simp add: eval_dioph_replicate_0)
next
  case (Cons bs bss' j)
  from Cons(3) have
    bs_in: "length bs = n" and
    bss'_in : "list_all (is_alph n) bss'"
    by (simp_all add: is_alph_def)
  note ind_hyp = Cons(1) [OF _ bss'_in]
  note j_in_Q = Cons(2)
  note reach_j_j' = Cons(4)

  let ?j' = "(j - eval_dioph ks (map nat_of_bool bs)) div 2"
  have \<delta>_j_bs_eq:
   "\<delta> (pres_DFA_eq_ineq True n ks l) (pres_NFA_state_int j, bs) =
    Some (pres_NFA_state_int ?j')"
    using j_in_Q bs_in
    unfolding \<delta>_pres_DFA_eq_ineq
    unfolding pres_DFA_eq_ineq_def
    by simp

  have j'_in_Q: "pres_DFA_eq_ineq_trans_fun True ks (pres_NFA_state_int j) bs \<in> \<Q> (pres_DFA_eq_ineq True n ks l)"
    using bs_in j_in_Q pres_DFA_is_node___pres_DFA_eq_ineq_trans_fun [where i = True]
    unfolding pres_DFA_eq_ineq_def
    by (simp del: pres_DFA_eq_ineq_trans_fun.simps)

  have j'_eq: "pres_DFA_eq_ineq_trans_fun True ks (pres_NFA_state_int j) bs =
    pres_NFA_state_int ?j'"
      by simp

  with ind_hyp [OF j'_in_Q [unfolded j'_eq]] reach_j_j'
  show ?case
    by (simp add: \<delta>_j_bs_eq
        eval_dioph_ineq_div_mod [where xs = "nats_of_boolss n (bs#bss')"]
        nats_of_boolss_div2 bs_in bss'_in nats_of_boolss_mod2)
qed

lemma pres_DFA_ineq_reach_exists :
"\<lbrakk>list_all (is_alph n) bss; dioph_is_node ks l j\<rbrakk> \<Longrightarrow>
 \<exists>j'. DLTS_reach (\<delta> (pres_DFA_eq_ineq True n ks l)) (pres_NFA_state_int j) bss =
 Some (pres_NFA_state_int j') \<and> dioph_is_node ks l j'"
proof (induct bss arbitrary: j)
  case Nil thus ?case by simp
next
  case (Cons bs bss')

  let ?j' = "(j - eval_dioph ks (map nat_of_bool bs)) div 2"
  have "pres_DFA_eq_ineq_trans_fun True ks (pres_NFA_state_int j) bs \<in> \<Q> (pres_DFA_eq_ineq False n ks l)"
    using Cons pres_DFA_is_node___pres_DFA_eq_ineq_trans_fun [where i = True]
    unfolding pres_DFA_eq_ineq_def
    by (simp del: pres_DFA_eq_ineq_trans_fun.simps)
  hence j'_is_node: "dioph_is_node ks l ?j'"
    unfolding pres_DFA_eq_ineq_def
    by simp

  from Cons j'_is_node
  show ?case
    by (simp add: is_alph_def \<delta>_pres_DFA_eq_ineq)
qed

lemma pres_DFA_ineq_correct :
assumes bss_OK: "list_all (is_alph n) bss"
shows "NFA_accept (pres_DFA_eq_ineq True n ks l) bss =
       (eval_dioph ks (nats_of_boolss n bss) \<le> l)"
proof -
  have \<i>_eval: "\<i> (pres_DFA_eq_ineq True n ks l) = pres_NFA_state_int l"
    unfolding pres_DFA_eq_ineq_def
    by (simp add: \<i>_def)

  have \<F>_eval: "\<F> (pres_DFA_eq_ineq True n ks l) = {pres_NFA_state_int m |m. dioph_is_node ks l m \<and> 0 \<le> m}"
    unfolding pres_DFA_eq_ineq_def
    by simp

  obtain j' where reach_eq:
    "DLTS_reach (\<delta> (pres_DFA_eq_ineq True n ks l)) (pres_NFA_state_int l) bss =
     Some (pres_NFA_state_int j')"
    and is_node_j': "dioph_is_node ks l j'"
     using pres_DFA_ineq_reach_exists [OF bss_OK, of ks l l]
     by (simp add: dioph_is_node_def, blast)

  have l_in_Q: "pres_NFA_state_int l \<in> \<Q> (pres_DFA_eq_ineq True n ks l)"
    unfolding pres_DFA_eq_ineq_def
    by (simp add: dioph_is_node_def)

  from pres_DFA_eq_ineq_reach_ineq [OF l_in_Q bss_OK reach_eq, symmetric]
  show ?thesis
    by (simp add: pres_DFA_eq_ineq.DFA_accept_alt_def \<i>_eval \<F>_eval
                  reach_eq is_node_j')
qed

subsubsection \<open> Efficiency \<close>

subsubsection \<open> Implementation \<close>
text \<open> For using these automata constructions let's replace
the new datatype for states with natural numbers and consider only
reachable states. \<close>

fun pres_NFA_state_to_nat where
  "pres_NFA_state_to_nat pres_NFA_state_error = 0"
| "pres_NFA_state_to_nat (pres_NFA_state_int m) =
   int_encode m + 1"

lemma pres_NFA_state_nat_eq_0 [simp] :
  "(pres_NFA_state_to_nat q = 0) \<longleftrightarrow> q = pres_NFA_state_error"
by (cases q, auto)

lemma pres_NFA_state_nat_neq_0 [simp] :
  "(pres_NFA_state_to_nat q = Suc m) \<longleftrightarrow> q = pres_NFA_state_int (int_decode m)"
by (cases q, auto)

lemma inj_pres_NFA_state_to_nat:
  "inj_on pres_NFA_state_to_nat S"
unfolding inj_on_def Ball_def
proof (intro allI impI)
  fix q1 q2
  assume f_q1: "pres_NFA_state_to_nat q1 = pres_NFA_state_to_nat q2"
  thus "q1 = q2"
    by (cases "pres_NFA_state_to_nat q2", simp_all)
qed

definition efficient_pres_DFA_eq_ineq where
  "efficient_pres_DFA_eq_ineq i n ks l =
   NFA_rename_states (NFA_remove_unreachable_states (pres_DFA_eq_ineq i n ks l)) pres_NFA_state_to_nat"

lemma efficient_pres_DFA_eq_ineq___is_well_formed :
  "DFA (efficient_pres_DFA_eq_ineq i n ks l)"
unfolding efficient_pres_DFA_eq_ineq_def
apply (intro DFA___inj_rename DFA___NFA_remove_unreachable_states)
apply (simp_all add: pres_DFA_eq_ineq___is_well_formed inj_pres_NFA_state_to_nat)
done

lemma pres_DFA_eq_ineq___isomorphic_wf :
  "NFA_isomorphic_wf (NFA_remove_unreachable_states (pres_DFA_eq_ineq i n ks l))
                     (efficient_pres_DFA_eq_ineq i n ks l)"
unfolding efficient_pres_DFA_eq_ineq_def
by (intro NFA_isomorphic_wf___NFA_rename_states inj_pres_NFA_state_to_nat
          NFA_remove_unreachable_states___is_well_formed pres_DFA_eq_ineq.NFA_axioms)

lemma efficient_pres_DFA_eq_ineq___NFA_accept [simp] :
  "NFA_accept (efficient_pres_DFA_eq_ineq i n ks l) bss =
   NFA_accept (pres_DFA_eq_ineq i n ks l) bss"
proof -
  have equiv_f: "\<And>\<A>. NFA_is_equivalence_rename_fun \<A> pres_NFA_state_to_nat"
    by (rule NFA_is_equivalence_rename_funI___inj_used, fact inj_pres_NFA_state_to_nat)

  have wf_1 : "DFA (NFA_remove_unreachable_states (pres_DFA_eq_ineq i n ks l))"
    by (intro DFA___NFA_remove_unreachable_states, fact pres_DFA_eq_ineq___is_well_formed)
  hence wf_2: "NFA (NFA_remove_unreachable_states (pres_DFA_eq_ineq i n ks l))"
    by (simp add: DFA_alt_def)

  note NFA.NFA_rename_states___accept [OF wf_2 equiv_f]
  thus ?thesis
    unfolding efficient_pres_DFA_eq_ineq_def
    by simp
qed

subsection \<open> Existential Quantification \<close>

type_synonym pres_NFA = "(nat, bool list) NFA_rec"

definition pres_DFA_labels_tl ::
  "pres_NFA \<Rightarrow> pres_NFA" where
  "pres_DFA_labels_tl \<A> = SemiAutomaton_rename_labels \<A> tl"

lemma pres_DFA_labels_tl___well_formed:
"NFA \<A> \<Longrightarrow> NFA (pres_DFA_labels_tl \<A>)"
  by (simp add: pres_DFA_labels_tl_def
                NFA.NFA_rename_labels___is_well_formed)

lemma pres_DFA_labels_tl___NFA_accept :
assumes wf_A: "NFA \<A>"
    and \<Sigma>_A: "\<And>bs. bs \<in> \<Sigma> \<A> \<Longrightarrow> bs \<noteq> []"
shows "NFA_accept (pres_DFA_labels_tl \<A>) bss \<longleftrightarrow>
       (\<exists>bs. length bs = length bss \<and> NFA_accept \<A> (insertll 0 bs bss))"
apply (simp add: pres_DFA_labels_tl_def NFA_accept___NFA_rename_labels_iff)
proof
  assume "\<exists>bss'. bss = map tl bss' \<and> NFA_accept \<A> bss'"
  then obtain bss' where
       bss_eq: "bss = map tl bss'"
   and bss'_acc: "NFA_accept \<A> bss'" by blast

  have len_bs : "length (map hd bss') = length bss"
    unfolding bss_eq by simp

  from bss'_acc have "bss' \<in> lists (\<Sigma> \<A>)"
    by (simp add: NFA.NFA_accept_wf_def[OF wf_A])
  hence "insertll 0 (map hd bss') (map tl bss') = bss'"
  proof (induct bss')
    case Nil thus ?case by simp
  next
    case (Cons bs bss)
    from Cons(1) have "bs \<noteq> []" using \<Sigma>_A by simp
    then obtain bs_hd bs_tl where bs_eq: "bs = bs_hd # bs_tl"
      by (cases bs, simp)

    with Cons(3) show ?case
      by (simp add: insertl_0_eq)
  qed
  hence "NFA_accept \<A> (insertll 0 (map hd bss') bss)"
    unfolding bss_eq
    using bss'_acc
    by simp
  with len_bs show "\<exists>bs. length bs = length bss \<and> NFA_accept \<A> (insertll 0 bs bss)" by blast
next
  assume "\<exists>bs. length bs = length bss \<and> NFA_accept \<A> (insertll 0 bs bss)"
  then obtain bs where
       bss_acc: "NFA_accept \<A> (insertll 0 bs bss)"
   and len_bs: "length bs = length bss" by blast

  from len_bs
  have "map tl (insertll 0 bs bss) = bss"
  proof (induct bss arbitrary: bs)
    case Nil thus ?case by simp
  next
    case (Cons bss_hd bss_tl bs)
    thus ?case
      by (cases bs, simp_all add: insertl_0_eq)
  qed
  with bss_acc show "\<exists>bss'. bss = map tl bss' \<and> NFA_accept \<A> bss'"
    apply (rule_tac exI [where x = "insertll 0 bs bss"])
    apply simp
  done
qed

definition pres_DFA_exists ::
  "nat \<Rightarrow> pres_NFA \<Rightarrow> pres_NFA" where
  "pres_DFA_exists n \<A> = NFA_right_quotient_lists (pres_DFA_labels_tl \<A>)
    {replicate n False}"

lemma pres_DFA_exists___well_formed:
"NFA \<A> \<Longrightarrow> NFA (pres_DFA_exists n \<A>)"
 unfolding pres_DFA_exists_def
 by (intro NFA_right_quotient___is_well_formed pres_DFA_labels_tl___well_formed, assumption)

lemma pres_DFA_exists___NFA_accept :
assumes wf_A: "NFA \<A>"
    and \<Sigma>_A: "\<And>bs. bs \<in> \<Sigma> \<A> \<Longrightarrow> bs \<noteq> []"
shows "NFA_accept (pres_DFA_exists n \<A>) bss \<longleftrightarrow>
       (\<exists>bs m. length bs = length bss + m \<and> NFA_accept \<A> (insertll 0 bs (bss @ zeros m n)))"
proof -
  have lists_repl: "lists {replicate n False} = {zeros m n | m. True}" (is "?s1 = ?s2")
  proof (intro set_eqI iffI)
    fix bss
    assume "bss \<in> ?s2"
    thus "bss \<in> ?s1" by (auto simp add: zeros_def list_all_iff)
  next
    fix bss
    assume "bss \<in> ?s1"
    hence "\<And>bs. bs \<in> set bss \<Longrightarrow> bs = replicate n False" by (auto simp add: list_all_iff)
    hence "bss = replicate (length bss) (replicate n False)"
      by (induct bss, auto)
    thus "bss \<in> ?s2" by (simp add: zeros_def, blast)
  qed

  note wf_ex = pres_DFA_labels_tl___well_formed [OF wf_A]
  note NFA_accept = NFA.NFA_right_quotient___accepts [OF wf_ex, where L = "lists {replicate n False}"]
  with lists_repl show ?thesis
    by (simp del: ex_simps
             add: pres_DFA_exists_def pres_DFA_labels_tl___NFA_accept [OF wf_A \<Sigma>_A]
                  ex_simps[symmetric] zeros_len)
qed

lemma nats_of_boolss_append_zeros :
assumes bss_in: "list_all (is_alph n) bss"
shows "nats_of_boolss n (bss @ zeros m n) = nats_of_boolss n bss"
proof -
  have map_eq: "\<And>nl::nat list. map (\<lambda>(x, y). x + (2::nat) ^ length bss * y) (zip nl (replicate (length nl) 0)) = nl"
  proof -
    fix nl
    show "map (\<lambda>(x::nat, y). x + 2 ^ length bss * y) (zip nl (replicate (length nl) 0)) = nl"
    proof (induct nl)
      case Nil thus ?case by simp
    next
      case (Cons x nl)
      thus ?case by (simp)
    qed
  qed

  from map_eq [of "nats_of_boolss n bss"]
       nats_of_boolss_append [of n bss "zeros m n"]
  show "nats_of_boolss n (bss @ zeros m n) = nats_of_boolss n bss"
    by (simp add: bss_in zeros_is_alpha nats_of_boolss_zeros nats_of_boolss_length)
qed

lemma pres_DFA_exists___NFA_accept___nats :
assumes wf_A: "NFA \<A>"
    and \<Sigma>_A: "\<Sigma> \<A> = {bs. length bs = Suc n}"
    and acc_A: "\<And>bss. list_all (is_alph (Suc n)) bss \<Longrightarrow> NFA_accept \<A> bss \<longleftrightarrow> P (nats_of_boolss (Suc n) bss)"
    and bss_in: "list_all (is_alph n) bss"
shows "NFA_accept (pres_DFA_exists n \<A>) bss =
       (\<exists>x. P (x # nats_of_boolss n bss))"
proof -
  have \<Sigma>_A': "\<And>bs. bs \<in> \<Sigma> \<A> \<Longrightarrow> bs \<noteq> []"
  proof -
    fix bs
    assume "bs \<in> \<Sigma> \<A>"
    with \<Sigma>_A have "length bs = Suc n" by simp
    thus "bs \<noteq> []" by auto
  qed

  have "\<And>bs m. length bs = length bss + m \<Longrightarrow>
                NFA_accept \<A> (insertll 0 bs (bss @ zeros m n)) =
                P (nats_of_boolss (Suc n) (insertll 0 bs (bss @ zeros m n)))"
  proof -
    fix bs :: "bool list"
    fix m
    assume len_bs: "length bs = length bss + m"
    with insertll_len2 [of n "bss @ (zeros m n)" bs 0]
         acc_A
    show "NFA_accept \<A> (insertll 0 bs (bss @ zeros m n)) =
          P (nats_of_boolss (Suc n) (insertll 0 bs (bss @ zeros m n)))"
      by (simp add: bss_in zeros_is_alpha zeros_len)
  qed
  hence step0:
     "(\<exists>bs m. length bs = length bss + m \<and> NFA_accept \<A> (insertll 0 bs (bss @ zeros m n))) =
      (\<exists>bs m. length bs = length bss + m \<and> P (nats_of_boolss (Suc n) (insertll 0 bs (bss @ zeros m n))))"
    by auto

  have "\<And>bs m. length bs = length bss + m \<Longrightarrow>
        nats_of_boolss (Suc n) (insertll 0 bs (bss @ zeros m n)) =
        nat_of_bools bs # nats_of_boolss n bss"
  proof -
   fix bs :: "bool list"
   fix m
   assume "length bs = length bss + m"
   hence len_bs: "length bs = length (bss @ zeros m n)"
     by (simp add: zeros_len)

   have bss'_in: "list_all (is_alph n) (bss @ zeros m n)"
     by (simp add: bss_in zeros_is_alpha)

   from nats_of_boolss_insertll [of n "bss @ (zeros m n)" bs 0, OF bss'_in len_bs]
        nats_of_boolss_append_zeros [of n bss m, OF bss_in]
   show "nats_of_boolss (Suc n) (insertll 0 bs (bss @ zeros m n)) =
         nat_of_bools bs # nats_of_boolss n bss"
     by (simp add: insertl_0_eq)
  qed
  hence step1:
     "(\<exists>bs m. length bs = length bss + m \<and> P (nats_of_boolss (Suc n) (insertll 0 bs (bss @ zeros m n)))) =
      (\<exists>bs m. length bs = length bss + m \<and> P (nat_of_bools bs # nats_of_boolss n bss))"
    by (metis (no_types))

  have step2: "(\<exists>bs m. length bs = length bss + m \<and> P (nat_of_bools bs # nats_of_boolss n bss)) =
               (\<exists>x. P (x # nats_of_boolss n bss))"
    apply (rule iffI)
    apply (erule exE conjE)+
    apply (erule exI)
    apply (erule exE)
    apply (rule_tac x="bools_of_nat (length bss) x" in exI)
    apply (rule_tac x="length (bools_of_nat (length bss) x) - length bss" in exI)
    apply (simp add: bools_of_nat_inverse bools_of_nat_length)
  done

  from step0 step1 step2 show ?thesis
    by (simp add: pres_DFA_exists___NFA_accept [OF wf_A \<Sigma>_A']
                  nats_of_boolss_insertll)
qed

definition pres_DFA_exists_min where
  "pres_DFA_exists_min n \<A> = NFA_right_quotient_lists (
     NFA_minimise (pres_DFA_labels_tl \<A>)) {replicate n False}"

find_theorems name: "NFA_right_quotient" name: "well_formed"
lemma pres_DFA_exists_min___well_formed :
assumes wf_A: "NFA \<A>"
shows "DFA (pres_DFA_exists_min n \<A>)"
unfolding pres_DFA_exists_min_def pres_DFA_labels_tl_def
by (metis NFA_right_quotient___is_well_formed_DFA NFA.NFA_rename_labels___is_well_formed
          NFA_minimise_spec(3) assms DFA_is_minimal_gen_def)

lemma pres_DFA_exists_min___well_formed_DFA :
"DFA \<A> \<Longrightarrow> DFA (pres_DFA_exists_min n \<A>)"
using pres_DFA_exists_min___well_formed
by (metis DFA_alt_def)

lemma pres_DFA_exists_min___NFA_accept :
assumes wf_A: "DFA \<A>"
shows "NFA_accept (pres_DFA_exists_min n \<A>) bss \<longleftrightarrow>
       NFA_accept (pres_DFA_exists n \<A>) bss"
proof -
  let ?A1 = "pres_DFA_labels_tl \<A>"
  let ?A2 = "NFA_minimise ?A1"

  from wf_A have NFA_A: "NFA \<A>" by (simp add: DFA_alt_def)
  have NFA_A1: "NFA ?A1"
    unfolding pres_DFA_labels_tl_def
    by (simp add: NFA.NFA_rename_labels___is_well_formed [OF NFA_A])

  from NFA_minimise_spec(3)[OF NFA_A1]
  have NFA_A2: "NFA ?A2" unfolding DFA_is_minimal_def DFA_alt_def by simp

  from NFA_minimise_spec(1)[OF NFA_A1]
  have NFA_accept_A2: "\<And>bss. NFA_accept ?A2 bss = NFA_accept ?A1 bss"
    by (auto simp add: \<L>_def)

  show ?thesis
    unfolding pres_DFA_exists_min_def pres_DFA_exists_def
    by (simp add: NFA.NFA_right_quotient___accepts NFA_A1 NFA_A2 NFA_accept_A2)
qed

lemma pres_DFA_exists_min___NFA_accept___nats :
assumes wf_A: "DFA \<A>"
    and \<Sigma>_A: "\<Sigma> \<A> = {bs. length bs = Suc n}"
    and acc_A: "\<And>bss. list_all (is_alph (Suc n)) bss \<Longrightarrow> NFA_accept \<A> bss \<longleftrightarrow> P (nats_of_boolss (Suc n) bss)"
    and bss_in: "list_all (is_alph n) bss"
shows "NFA_accept (pres_DFA_exists_min n \<A>) bss =
       (\<exists>x. P (x # nats_of_boolss n bss))"
proof -
  have wf_A' : "NFA \<A>"
    using wf_A unfolding DFA_alt_def by simp
  show ?thesis by (metis pres_DFA_exists___NFA_accept___nats [OF wf_A' \<Sigma>_A acc_A bss_in]
       pres_DFA_exists_min___NFA_accept [OF wf_A])
qed

lemma \<Sigma>_pres_DFA_exists_min :
  "NFA \<A> \<Longrightarrow> \<Sigma> (pres_DFA_exists_min n \<A>) = tl ` \<Sigma> \<A>"
by (simp add: pres_DFA_exists_min_def pres_DFA_labels_tl_def NFA_minimise_spec(2)
              NFA.NFA_rename_labels___is_well_formed)

subsection \<open> Universal Quantification \<close>

definition pres_DFA_forall_min where
  "pres_DFA_forall_min n \<A> = DFA_complement (pres_DFA_exists_min n (DFA_complement \<A>))"

lemma pres_DFA_forall_min___well_formed_DFA :
"DFA \<A> \<Longrightarrow> DFA (pres_DFA_forall_min n \<A>)"
unfolding pres_DFA_forall_min_def
by (intro DFA_complement_of_DFA_is_DFA pres_DFA_exists_min___well_formed_DFA,
    assumption)

lemma \<Sigma>_image_tl : "tl ` {bs::'a list. length bs = Suc n} = {bs. length bs = n}"
proof (intro set_eqI iffI)
   fix bs :: "'a list"
   assume "bs \<in> tl ` {bs. length bs = Suc n}"
   thus "bs \<in> {bs. length bs = n}" by auto
next
   fix bs :: "'a list"
   assume "bs \<in> {bs. length bs = n}"
   thus "bs \<in> tl ` {bs. length bs = Suc n}"
     apply (simp add: image_iff)
     apply (rule exI [where x = "e # bs"])
     apply simp
   done
qed

lemma pres_DFA_forall_min___NFA_accept___nats :
fixes \<A> :: pres_NFA
assumes wf_A: "DFA \<A>"
    and \<Sigma>_A: "\<Sigma> \<A> = {bs. length bs = Suc n}"
    and acc_A: "\<And>bss. list_all (is_alph (Suc n)) bss \<Longrightarrow> NFA_accept \<A> bss \<longleftrightarrow> P (nats_of_boolss (Suc n) bss)"
    and bss_in: "list_all (is_alph n) bss"
shows "NFA_accept (pres_DFA_forall_min n \<A>) bss =
       (\<forall>x. P (x # nats_of_boolss n bss))"
proof -
  let ?cA = "DFA_complement \<A>"
  note wf_ca = DFA_complement_of_DFA_is_DFA [OF wf_A]
  hence wf'_ca: "NFA ?cA" unfolding DFA_alt_def by simp

  have acc_cA: "\<And>bss. list_all (is_alph (Suc n)) bss \<Longrightarrow> NFA_accept ?cA bss \<longleftrightarrow> \<not>(P (nats_of_boolss (Suc n) bss))"
    using DFA_complement_word [OF wf_A] \<Sigma>_A
    by (simp add: list_all_iff in_lists_conv_set acc_A is_alph_def)

  have acc : "NFA_accept (pres_DFA_forall_min n \<A>) bss \<longleftrightarrow>
              \<not> (NFA_accept (pres_DFA_exists_min n ?cA) bss)"
    unfolding pres_DFA_forall_min_def
    apply (rule DFA_complement_word [OF pres_DFA_exists_min___well_formed_DFA [OF wf_ca]])
    apply (insert bss_in)
    apply (simp add: \<Sigma>_pres_DFA_exists_min[OF wf'_ca] \<Sigma>_A \<Sigma>_image_tl)
    apply (simp add: list_all_iff is_alph_def in_lists_conv_set)
  done

  with pres_DFA_exists_min___NFA_accept___nats [OF wf_ca _ acc_cA bss_in] \<Sigma>_A
  show ?thesis by simp
qed

lemma \<Sigma>_pres_DFA_forall_min :
  "NFA \<A> \<Longrightarrow> \<Sigma> (pres_DFA_forall_min n \<A>) = tl ` \<Sigma> \<A>"
by (simp add: pres_DFA_forall_min_def \<Sigma>_pres_DFA_exists_min DFA_complement___is_well_formed)

subsection \<open> Translation \<close>

fun DFA_of_pf :: "nat \<Rightarrow> pf \<Rightarrow> pres_NFA" where
  Eq:     "DFA_of_pf n (Eq ks l) = efficient_pres_DFA_eq_ineq False n ks l"
| Le:     "DFA_of_pf n (Le ks l) = efficient_pres_DFA_eq_ineq True n ks l"
| And:    "DFA_of_pf n (And p q) = NFA_bool_comb (\<and>) (DFA_of_pf n p) (DFA_of_pf n q)"
| Or:     "DFA_of_pf n (Or p q) = NFA_bool_comb (\<or>) (DFA_of_pf n p) (DFA_of_pf n q)"
| Imp:    "DFA_of_pf n (Imp p q) = NFA_bool_comb (\<longrightarrow>) (DFA_of_pf n p) (DFA_of_pf n q)"
| Exists: "DFA_of_pf n (Exist p) = pres_DFA_exists_min n (DFA_of_pf (Suc n) p)"
| Forall: "DFA_of_pf n (Forall p) = pres_DFA_forall_min n (DFA_of_pf (Suc n) p)"
| Neg:    "DFA_of_pf n (Neg p) = DFA_complement (DFA_of_pf n p)"

lemmas DFA_of_pf_induct =
  DFA_of_pf.induct [case_names Eq Le And Or Imp Exist Forall Neg]

lemma DFA_of_pf___correct:
  "DFA (DFA_of_pf n p) \<and>
   \<Sigma> (DFA_of_pf n p) = {bs. length bs = n} \<and>
   (\<forall>bss. list_all (is_alph n) bss \<longrightarrow>
     NFA.NFA_accept (DFA_of_pf n p) bss = eval_pf p (nats_of_boolss n bss))"
   (is "?P1 n p \<and> ?P2 n p \<and> ?P3 n p")
proof (induct n p rule: DFA_of_pf_induct)
  case (Eq n ks l)
  show ?case
    apply (simp add: efficient_pres_DFA_eq_ineq___is_well_formed pres_DFA_eq_correct)
    apply (simp add: efficient_pres_DFA_eq_ineq_def pres_DFA_eq_ineq_def)
  done
next
  case (Le n ks l)
  show ?case
    apply (simp add: efficient_pres_DFA_eq_ineq___is_well_formed pres_DFA_ineq_correct)
    apply (simp add: efficient_pres_DFA_eq_ineq_def pres_DFA_eq_ineq_def)
  done
next
  case (And n p q)
  thus ?case
    by (simp add: NFA_bool_comb_DFA___NFA_accept NFA_bool_comb_DFA___is_well_formed
                  in_lists_conv_set list_all_iff is_alph_def)
next
  case (Or n p q)
  thus ?case
    by (simp add: NFA_bool_comb_DFA___NFA_accept NFA_bool_comb_DFA___is_well_formed
                  in_lists_conv_set list_all_iff is_alph_def)
next
  case (Imp n p q)
  thus ?case
    by (simp add: NFA_bool_comb_DFA___NFA_accept NFA_bool_comb_DFA___is_well_formed
                  in_lists_conv_set list_all_iff is_alph_def)
next
  case (Neg n p)
  thus ?case
    by (simp add: DFA_complement_of_DFA_is_DFA DFA_complement_word
                  in_lists_conv_set list_all_iff is_alph_def)
next
  case (Exist n p)
  with pres_DFA_exists_min___NFA_accept___nats [where \<A> = "DFA_of_pf (Suc n) p" and n = n and P = "eval_pf p"]
  show ?case
    by (simp add: \<Sigma>_pres_DFA_exists_min \<Sigma>_image_tl pres_DFA_exists_min___well_formed_DFA)
next
  case (Forall n p)
  with pres_DFA_forall_min___NFA_accept___nats [where \<A> = "DFA_of_pf (Suc n) p" and n = n and P = "eval_pf p"]
  show ?case
    by (simp add: \<Sigma>_pres_DFA_forall_min \<Sigma>_image_tl pres_DFA_forall_min___well_formed_DFA)
qed

subsection \<open> Code Generation \<close>

text \<open> The automata used for presburger arithmetic have label sets that consist of all
bitvectors of a certain length. The following locale is used to cache these sets. \<close>

locale presburger_label_set_cache = set a_\<alpha> a_invar
    for a_\<alpha> :: "'al_set \<Rightarrow> ('a list) set" and a_invar +
    fixes c_\<alpha> :: "'cache \<Rightarrow> nat \<Rightarrow> 'cache \<times> 'al_set"
    fixes c_invar :: "'cache \<Rightarrow> bool"
    fixes init_cache :: "unit \<Rightarrow> 'cache"
    assumes init_cache_OK :
      "c_invar (init_cache ())"
    assumes cache_correct :
      "c_invar c \<Longrightarrow> c_invar (fst (c_\<alpha> c n))"
      "c_invar c \<Longrightarrow> a_invar (snd (c_\<alpha> c n))"
      "c_invar c \<Longrightarrow> a_\<alpha> (snd (c_\<alpha> c n)) = {bs. length bs = n}"

locale presburger_locale =
   nfa: StdNFA nfa_ops +
   presburger_label_set_cache a_\<alpha> a_invar c_\<alpha> c_invar c_init +
   dfa_construct_no_enc_fun "nfa_op_\<alpha> nfa_ops" "nfa_op_invar nfa_ops" a_\<alpha> a_invar dfa_construct +
   labels_gen: nfa_rename_labels_gen "nfa_op_\<alpha> nfa_ops" "nfa_op_invar nfa_ops"
                         "nfa_op_\<alpha> nfa_ops" "nfa_op_invar nfa_ops" a_\<alpha> a_invar rename_labels_gen
   for a_\<alpha> :: "'bl_set \<Rightarrow> (bool list) set" and a_invar c_init and
       c_\<alpha> :: "'cache \<Rightarrow> nat \<Rightarrow> ('cache \<times> 'bl_set)" and c_invar and
       nfa_ops :: "('q::{automaton_states}, bool list, 'nfa) nfa_ops" and
       dfa_construct :: "(pres_NFA_state,nat,bool list,'bl_set,'nfa) nfa_construct_fun" and
       rename_labels_gen
begin
  definition pres_DFA_eq_ineq_impl where
    "pres_DFA_eq_ineq_impl A ineq n ks l =
     dfa_construct pres_NFA_state_to_nat (pres_NFA_state_int l) A
           (if ineq then
             (\<lambda>q. case q of pres_NFA_state_error \<Rightarrow> False
                          | pres_NFA_state_int m \<Rightarrow> (0 \<le> m))
           else
             (\<lambda>q. case q of pres_NFA_state_error \<Rightarrow> False
                          | pres_NFA_state_int m \<Rightarrow> (m = 0)))
           (pres_DFA_eq_ineq_trans_fun ineq ks)"

  lemma pres_DFA_eq_ineq_impl_correct :
  assumes A_OK: "a_invar A" "a_\<alpha> A = {bs. length bs = n}"
  shows "nfa.invar (pres_DFA_eq_ineq_impl A ineq n ks l)"
        "NFA_isomorphic_wf (nfa.\<alpha> (pres_DFA_eq_ineq_impl A ineq n ks l))
                           (efficient_pres_DFA_eq_ineq ineq n ks l)"
  proof -
    have "nfa.invar (pres_DFA_eq_ineq_impl A ineq n ks l) \<and>
           NFA_isomorphic_wf (nfa.\<alpha> (pres_DFA_eq_ineq_impl A ineq n ks l))
                           (NFA_remove_unreachable_states (pres_DFA_eq_ineq ineq n ks l))"
      unfolding pres_DFA_eq_ineq_impl_def
      apply (rule dfa_construct_no_enc_fun_correct)
      apply (rule pres_DFA_eq_ineq___is_well_formed)
      apply (auto simp add: pres_DFA_eq_ineq_def A_OK inj_pres_NFA_state_to_nat
                       split: pres_NFA_state.split)
    done
    thus "nfa.invar (pres_DFA_eq_ineq_impl A ineq n ks l)"
         "NFA_isomorphic_wf (nfa.\<alpha> (pres_DFA_eq_ineq_impl A ineq n ks l))
                           (efficient_pres_DFA_eq_ineq ineq n ks l)"
    by (simp_all add: NFA_isomorphic_wf_trans[OF _ pres_DFA_eq_ineq___isomorphic_wf])
  qed

  definition pres_DFA_exists_min_impl where
    "pres_DFA_exists_min_impl A AA =
      nfa.right_quotient_lists (list_all (\<lambda>b. \<not> b)) (nfa.minimise_Hopcroft_NFA (rename_labels_gen AA A tl))"

  lemma im_tl_eq: "tl ` {bl. length bl = Suc n} = {bl. length bl = n}"
     apply (auto simp add: image_iff length_Suc_conv)[]
     apply (simp add: ex_simps[symmetric] del: ex_simps)
  done

  lemma pres_DFA_exists_min_impl_correct_invar :
    assumes "nfa.invar AA"
          "a_invar A" "\<Sigma> (nfa.\<alpha> AA) = {bl. length bl = Suc n}"
          "a_\<alpha> A = {bl. length bl = n}"
    shows "nfa.invar (pres_DFA_exists_min_impl A AA)"
    unfolding pres_DFA_exists_min_impl_def pres_DFA_exists_min_def pres_DFA_labels_tl_def
    apply (insert assms)
    apply (intro nfa.correct_isomorphic conjI labels_gen.rename_labels_gen_correct___isomorphic)+
    apply (simp_all add: im_tl_eq)
  done

  lemma pres_DFA_exists_min_impl_correct_\<alpha> :
    assumes "nfa.invar AA"
          "NFA_isomorphic_wf (nfa.\<alpha> AA) \<A>"
          "a_invar A" "\<Sigma> (nfa.\<alpha> AA) = {bl. length bl = Suc n}"
          "a_\<alpha> A = {bl. length bl = n}"
    shows "NFA_isomorphic_wf (nfa.\<alpha> (pres_DFA_exists_min_impl A AA)) (pres_DFA_exists_min n \<A>)"
    unfolding pres_DFA_exists_min_impl_def pres_DFA_exists_min_def pres_DFA_labels_tl_def
    apply (insert assms)
    apply (intro nfa.correct_isomorphic conjI labels_gen.rename_labels_gen_correct___isomorphic)+
    apply (simp_all add: im_tl_eq)
  proof -
     assume iso: "NFA_isomorphic_wf (nfa_op_\<alpha> nfa_ops AA) \<A>"
        and \<Sigma>_eq: "\<Sigma> (nfa_op_\<alpha> nfa_ops AA) = {bl. length bl = Suc n}"
     hence \<Sigma>_eq': "\<Sigma> \<A> = {bl. length bl = Suc n}"
       by (simp add: NFA_isomorphic_wf_\<Sigma>)

     from iso have "NFA \<A>" unfolding NFA_isomorphic_wf_alt_def by simp
     hence \<Sigma>_min: "\<Sigma> (NFA_minimise (SemiAutomaton_rename_labels \<A> tl)) = {bl. length bl = n}"
       by (simp add: NFA_minimise_spec(2) NFA.NFA_rename_labels___is_well_formed \<Sigma>_eq' im_tl_eq)

     have "{replicate n False} \<inter> {bl. length bl = n} =
           {a. list_all Not a} \<inter> {bl. length bl = n}"
       apply (intro set_eqI iffI)
       apply (induct n, simp_all)
       apply (induct n, auto simp add: length_Suc_conv)
     done
     with \<Sigma>_min
     show "{replicate n False} \<inter> \<Sigma> (NFA_minimise (SemiAutomaton_rename_labels \<A> tl)) =
           {a. list_all Not a} \<inter> \<Sigma> (NFA_minimise (SemiAutomaton_rename_labels \<A> tl))"
       by metis
  qed

  lemmas pres_DFA_exists_min_impl_correct =
    pres_DFA_exists_min_impl_correct_invar pres_DFA_exists_min_impl_correct_\<alpha>

  definition pres_DFA_forall_min_impl where
    "pres_DFA_forall_min_impl A AA =
     nfa.complement (pres_DFA_exists_min_impl A (nfa.complement AA))"

  lemma pres_DFA_forall_min_impl_correct_invar :
    assumes "nfa.invar AA"
          "a_invar A" "\<Sigma> (nfa.\<alpha> AA) = {bl. length bl = Suc n}"
          "a_\<alpha> A = {bl. length bl = n}"
    shows "nfa.invar (pres_DFA_forall_min_impl A AA)"
  unfolding pres_DFA_forall_min_impl_def pres_DFA_forall_min_def pres_DFA_labels_tl_def
    apply (insert assms)
    apply (intro nfa.correct_isomorphic conjI
                 pres_DFA_exists_min_impl_correct | assumption)+
    apply (simp_all add: nfa.correct)
  done

  lemma pres_DFA_forall_min_impl_correct_\<alpha> :
    assumes "nfa.invar AA"
          "NFA_isomorphic_wf (nfa.\<alpha> AA) \<A>"
          "a_invar A" "\<Sigma> (nfa.\<alpha> AA) = {bl. length bl = Suc n}"
          "a_\<alpha> A = {bl. length bl = n}"
    shows "NFA_isomorphic_wf (nfa.\<alpha> (pres_DFA_forall_min_impl A AA)) (pres_DFA_forall_min n \<A>)"
    unfolding pres_DFA_forall_min_impl_def pres_DFA_forall_min_def pres_DFA_labels_tl_def
    apply (insert assms)
    apply (intro nfa.correct_isomorphic conjI
                pres_DFA_exists_min_impl_correct | assumption)+
    apply (simp_all add: nfa.correct)
  done

  lemmas pres_DFA_forall_min_impl_correct =
    pres_DFA_forall_min_impl_correct_invar pres_DFA_forall_min_impl_correct_\<alpha>

  fun nfa_of_pf :: "nat \<Rightarrow> pf \<Rightarrow> 'cache \<Rightarrow> 'nfa \<times> 'cache" where
      Eq:     "nfa_of_pf n (Eq ks l) c =
                 (let (c', A) = c_\<alpha> c n in
                  (pres_DFA_eq_ineq_impl A False n ks l, c'))"
    | Le:     "nfa_of_pf n (Le ks l) c =
                 (let (c', A) = c_\<alpha> c n in
                  (pres_DFA_eq_ineq_impl A True n ks l, c'))"
    | And:    "nfa_of_pf n (And p q) c =
                 (let (P, c') = nfa_of_pf n p c in
                  let (Q, c'') = nfa_of_pf n q c' in
                  (nfa.bool_comb (\<and>) P Q, c''))"
    | Or:     "nfa_of_pf n (Or p q) c =
                 (let (P, c') = nfa_of_pf n p c in
                  let (Q, c'') = nfa_of_pf n q c' in
                  (nfa.bool_comb (\<or>) P Q, c''))"
    | Imp:    "nfa_of_pf n (Imp p q) c =
                 (let (P, c') = nfa_of_pf n p c in
                  let (Q, c'') = nfa_of_pf n q c' in
                  (nfa.bool_comb (\<longrightarrow>) P Q, c''))"
    | Exists: "nfa_of_pf n (Exist p) c =
                 (let (c', A) = c_\<alpha> c n in
                  let (P, c'') = nfa_of_pf (Suc n) p c' in
                  (pres_DFA_exists_min_impl A P, c''))"
    | Forall: "nfa_of_pf n (Forall p) c =
                 (let (c', A) = c_\<alpha> c n in
                  let (P, c'') = nfa_of_pf (Suc n) p c' in
                  (pres_DFA_forall_min_impl A P, c''))"
    | Neg:    "nfa_of_pf n (Neg p) c =
                 (let (P, c') = nfa_of_pf n p c in
                  (nfa.complement P, c'))"

lemmas nfa_of_pf_induct =
  nfa_of_pf.induct [case_names Eq Le And Or Imp Exist Forall Neg]

lemma nfa_of_pf___correct:
assumes "c_invar c"
shows "c_invar (snd (nfa_of_pf n p c)) \<and>
       nfa.invar (fst (nfa_of_pf n p c)) \<and>
       NFA_isomorphic_wf (nfa.\<alpha> (fst (nfa_of_pf n p c)))
                         (DFA_of_pf n p)"
using assms
proof (induct n p arbitrary: c rule: DFA_of_pf_induct )
  case (Eq n ks l c) note invar_c = this
  from cache_correct [OF invar_c, of n]
  show ?case
    by (auto simp add: pres_DFA_eq_ineq_impl_correct split: prod.split)
next
  case (Le n ks l c) note invar_c = this
  from cache_correct [OF invar_c, of n]
  show ?case
    by (auto simp add: pres_DFA_eq_ineq_impl_correct split: prod.split)
next
  case (And n p q c)
  obtain P c' where [simp]: "nfa_of_pf n p c = (P, c')" by (rule prod.exhaust)
  obtain Q c'' where [simp]: "nfa_of_pf n q c' = (Q, c'')" by (rule prod.exhaust)

  from And(1)[of c] And(2)[of c'] And(3)
  show ?case
    apply simp
    apply (intro conjI nfa.correct_isomorphic)
    apply simp_all
    apply (metis NFA_isomorphic_wf_\<Sigma> DFA_of_pf___correct)+
  done
next
  case (Or n p q c)
  obtain P c' where [simp]: "nfa_of_pf n p c = (P, c')" by (rule prod.exhaust)
  obtain Q c'' where [simp]: "nfa_of_pf n q c' = (Q, c'')" by (rule prod.exhaust)

  from Or(1)[of c] Or(2)[of c'] Or(3)
  show ?case
    apply simp
    apply (intro conjI nfa.correct_isomorphic)
    apply simp_all
    apply (metis NFA_isomorphic_wf_\<Sigma> DFA_of_pf___correct)+
  done
next
  case (Imp n p q c)
  obtain P c' where [simp]: "nfa_of_pf n p c = (P, c')" by (rule prod.exhaust)
  obtain Q c'' where [simp]: "nfa_of_pf n q c' = (Q, c'')" by (rule prod.exhaust)

  from Imp(1)[of c] Imp(2)[of c'] Imp(3)
  show ?case
    apply simp
    apply (intro conjI nfa.correct_isomorphic)
    apply simp_all
    apply (metis NFA_isomorphic_wf_\<Sigma> DFA_of_pf___correct)+
  done
next
  case (Exist n p c)
  obtain c' A where [simp]: "c_\<alpha> c n = (c', A)" by (rule prod.exhaust)
  obtain P c'' where [simp]: "nfa_of_pf (Suc n) p c' = (P, c'')" by (rule prod.exhaust)

  from Exist(1)[of c'] Exist(2) cache_correct [of c n]
  show ?case
    apply simp
    apply (intro conjI pres_DFA_exists_min_impl_correct)
    apply simp_all
    apply (metis NFA_isomorphic_wf_\<Sigma> DFA_of_pf___correct)+
  done
next
  case (Forall n p c)
  obtain c' A where [simp]: "c_\<alpha> c n = (c', A)" by (rule prod.exhaust)
  obtain P c'' where [simp]: "nfa_of_pf (Suc n) p c' = (P, c'')" by (rule prod.exhaust)

  from Forall(1)[of c'] Forall(2) cache_correct [of c n]
  show ?case
    apply simp
    apply (intro conjI pres_DFA_forall_min_impl_correct)
    apply simp_all
    apply (metis NFA_isomorphic_wf_\<Sigma> DFA_of_pf___correct)+
  done
next
  case (Neg n p c)
  obtain P c' where [simp]: "nfa_of_pf n p c = (P, c')" by (rule prod.exhaust)

  from Neg(1)[of c] Neg(2)
  show ?case
    apply simp
    apply (intro conjI nfa.correct_isomorphic)
    apply simp_all
  done
qed

definition pf_to_nfa where
  "pf_to_nfa n pf = fst (nfa_of_pf n pf (c_init ()))"

lemma pf_to_nfa___correct:
shows "nfa.invar (pf_to_nfa n p)"
      "NFA_isomorphic_wf (nfa.\<alpha> (pf_to_nfa n p)) (DFA_of_pf n p)"
using nfa_of_pf___correct [of "c_init ()" n p]
unfolding pf_to_nfa_def
by (simp_all add: init_cache_OK)

lemma eval_pf_impl :
  "eval_pf pf [] = nfa.accept (pf_to_nfa 0 pf) []"
proof -
  note equiv_wf = pf_to_nfa___correct [of 0 pf]
  note NFA_accept_OK = nfa.accept_correct___isomorphic [OF equiv_wf, of "[]"]
  with DFA_of_pf___correct [of 0 pf] NFA_accept_OK
  show ?thesis by simp
qed

end

locale presburger_label_set_cache_by_map_set =
    s: StdSet s_ops + m: StdMap m_ops +
    set_image "set_op_\<alpha> s_ops" "set_op_invar s_ops" "set_op_\<alpha> s_ops" "set_op_invar s_ops" s_image
    for s_ops :: "(bool list, 'bl, _) set_ops_scheme"
    and m_ops :: "(nat, 'bl, 'm, _) map_ops_scheme"
    and s_image
begin
  definition c_invar where
    "c_invar m \<equiv> m.invar m \<and>
      (\<forall>n bl. m.\<alpha> m n = Some bl \<longrightarrow> s.invar bl \<and> s.\<alpha> bl = {bv . length bv = n})"

  primrec c_\<alpha> where
     "c_\<alpha> m 0 = (m, s.sng [])"
   | "c_\<alpha> m (Suc n) =
      (case (m.lookup (Suc n) m) of Some bl \<Rightarrow> (m, bl) | None =>
       (let (m', bl) = c_\<alpha> m n in
        let bl' = s.union (s_image (\<lambda>l. True # l) bl) (s_image (\<lambda>l. False # l) bl) in
        let m'' = m.update (Suc n) bl' m' in
        (m'', bl')))"

  lemma c_\<alpha>_correct :
    assumes "c_invar m"
    shows "c_invar (fst (c_\<alpha> m n)) \<and>
           s.invar (snd (c_\<alpha> m n)) \<and>
           s.\<alpha> (snd (c_\<alpha> m n)) = {bs. length bs = n}"
  using assms
  proof (induct n arbitrary: m)
    case 0 thus ?case by (simp add: s.correct)
  next
    case (Suc n m)
    note ind_hyp = Suc(1)
    note invar_m = Suc(2)

    show ?case
    proof (cases "m.lookup (Suc n) m")
      case (Some bl)
      thus ?thesis
        apply (simp add: invar_m)
        apply (insert invar_m)
        apply (simp add: c_invar_def m.correct)
      done
    next
      case None note lookup_eq_none[simp] = this
      obtain m' bl where [simp]: "c_\<alpha> m n = (m', bl)" by (rule prod.exhaust)

      define bl' where "bl' \<equiv> set_op_union s_ops (s_image ((#) True) bl) (s_image ((#) False) bl)"

      from ind_hyp [OF invar_m]
      have bl'_props: "s.invar bl'" "s.\<alpha> bl' = {bs. length bs = Suc n}" and invar_m': "c_invar m'"
          apply (simp_all add: s.correct bl'_def image_correct)
          apply (auto simp add: image_iff length_Suc_conv)
      done

      from invar_m'
      show ?thesis
        by (simp add: bl'_def[symmetric] bl'_props c_invar_def m.correct)
    qed
  qed

  lemma  presburger_label_set_cache_OK :
    "presburger_label_set_cache s.\<alpha> s.invar c_\<alpha> c_invar m.empty"
    unfolding presburger_label_set_cache_def
    apply (simp add: c_\<alpha>_correct)
    apply (simp add: c_invar_def m.correct)
  done
end

end


subsection \<open>Weak Simulation\<close>

theory Weak_Relations_modified
imports
  Weak_Transition_Systems
  Strong_Relations
begin

context lts_tau
begin

definition weak_simulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>weak_simulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow> (\<exists> q'. R p' q'
      \<and> (q \<Rightarrow>^a q')))\<close>

text \<open>Note: Isabelle won't finish the proofs needed for the introduction of the following
  coinductive predicate if it unfolds the abbreviation of @{text \<open>\<Rightarrow>^\<close>}. Therefore we use
  @{text \<open>\<Rightarrow>^^\<close>} as a barrier. There is no mathematical purpose in this.\<close>

definition weak_step_tau2 :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close>
    ("_ \<Rightarrow>^^ _  _" [70, 70, 70] 80)
where [simp]:
  \<open>(p \<Rightarrow>^^ a q) \<equiv> p \<Rightarrow>^a q\<close>

coinductive greatest_weak_simulation ::
  \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close>
where
  \<open>(\<forall> p' a. p \<longmapsto>a p' \<longrightarrow> (\<exists> q'. greatest_weak_simulation p' q' \<and> (q \<Rightarrow>^^ a q')))
  \<Longrightarrow> greatest_weak_simulation p q\<close>

lemma weak_sim_ruleformat:
assumes \<open>weak_simulation R\<close>
  and \<open>R p q\<close>
shows
  \<open>p \<longmapsto>a p' \<Longrightarrow> \<not>tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<Rightarrow>a q'))\<close>
  \<open>p \<longmapsto>a p' \<Longrightarrow>  tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<longmapsto>* tau q'))\<close>
  using assms unfolding weak_simulation_def by (blast+)

abbreviation weakly_simulated_by :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<sqsubseteq>ws  _" [60, 60] 65)
  where \<open>weakly_simulated_by p q \<equiv> \<exists> R . weak_simulation R \<and> R p q\<close>

lemma weaksim_greatest:
  shows \<open>weak_simulation (\<lambda> p q . p \<sqsubseteq>ws q)\<close>
  unfolding weak_simulation_def
  by (metis (no_types, lifting))

lemma gws_is_weak_simulation:
  shows \<open>weak_simulation greatest_weak_simulation\<close>
  unfolding weak_simulation_def
proof safe
  fix p q p' a
  assume ih:
    \<open>greatest_weak_simulation p q\<close>
    \<open>p \<longmapsto>a  p'\<close>
  hence \<open>(\<forall>x xa. p \<longmapsto>x xa \<longrightarrow> (\<exists>q'. q \<Rightarrow>^^ x  q' \<and> greatest_weak_simulation xa q'))\<close>
    by (meson greatest_weak_simulation.simps)
  then obtain q' where \<open>q \<Rightarrow>^^ a  q' \<and> greatest_weak_simulation p' q'\<close> using ih by blast
  thus \<open>\<exists>q'. greatest_weak_simulation p' q' \<and> q \<Rightarrow>^a  q'\<close>
    unfolding weak_step_tau2_def by blast
qed

lemma weakly_sim_by_implies_gws:
  assumes \<open>p \<sqsubseteq>ws q\<close>
  shows \<open>greatest_weak_simulation p q\<close>
  using assms
proof (coinduct, simp del: weak_step_tau2_def, safe)
  fix x1 x2 R a xa
  assume ih: \<open>weak_simulation R\<close> \<open>R x1 x2\<close> \<open>x1 \<longmapsto>a  xa\<close>
  then obtain q' where \<open>x2 \<Rightarrow>^^ a  q'\<close> \<open>R xa q'\<close>
    unfolding weak_simulation_def weak_step_tau2_def by blast
  thus \<open>\<exists>q'. (xa \<sqsubseteq>ws  q' \<or> greatest_weak_simulation xa q') \<and> x2 \<Rightarrow>^^ a  q'\<close>
    using ih by blast
qed

lemma gws_eq_weakly_sim_by:
  shows \<open>p \<sqsubseteq>ws q = greatest_weak_simulation p q\<close>
  using weakly_sim_by_implies_gws gws_is_weak_simulation by blast

lemma steps_retain_weak_sim:
assumes
  \<open>weak_simulation R\<close>
  \<open>R p q\<close>
  \<open>p \<longmapsto>*A  p'\<close>
  \<open>\<And> a . tau a \<Longrightarrow> A a\<close>
shows \<open>\<exists>q'. R p' q' \<and> q \<longmapsto>*A  q'\<close>
  using assms(3,2,4) proof (induct)
  case (refl p' A)
  hence \<open>R p' q  \<and> q \<longmapsto>* A  q\<close> using assms(2) steps.refl by simp
  then show ?case by blast
next
  case (step p A p' a p'')
  then obtain q' where q': \<open>R p' q'\<close> \<open>q \<longmapsto>* A  q'\<close> by blast
  obtain q'' where q'':
    \<open>R p'' q''\<close> \<open>(\<not> tau a \<longrightarrow> q' \<Rightarrow>a  q'') \<and> (tau a \<longrightarrow> q' \<longmapsto>* tau  q'')\<close>
    using `weak_simulation R` q'(1) step(3) unfolding weak_simulation_def by blast
  have \<open>q' \<longmapsto>* A  q''\<close>
    using q''(2) steps_spec[of q'] step(4) step(6) weak_steps[of q' a q''] by blast
  hence \<open>q \<longmapsto>* A  q''\<close> using steps_concat[OF _ q'(2)] by blast
  thus ?case using q''(1) by blast
qed

lemma weak_sim_weak_premise:
  \<open>weak_simulation R =
    (\<forall> p q . R p q \<longrightarrow>
      (\<forall> p' a. p \<Rightarrow>^a p' \<longrightarrow> (\<exists> q'. R p' q' \<and> q \<Rightarrow>^a q')))\<close>
proof
  assume \<open>\<forall> p q . R p q \<longrightarrow> (\<forall>p' a. p \<Rightarrow>^a  p' \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<Rightarrow>^a  q'))\<close>
  thus \<open>weak_simulation R\<close>
    unfolding weak_simulation_def using step_weak_step_tau by simp
next
  assume ws: \<open>weak_simulation R\<close>
  show \<open>\<forall>p q. R p q \<longrightarrow> (\<forall>p' a. p \<Rightarrow>^a  p' \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<Rightarrow>^a  q'))\<close>
  proof safe
    fix p q p' a pq1 pq2
    assume case_assms:
      \<open>R p q\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain q' where q'_def: \<open>q \<longmapsto>* tau  q'\<close> \<open>R pq1 q'\<close>
      using steps_retain_weak_sim[OF ws] by blast
    then moreover obtain q'' where q''_def: \<open>R pq2 q''\<close> \<open>q' \<Rightarrow>^a  q''\<close>
      using ws case_assms(3) unfolding weak_simulation_def by blast
    then moreover obtain q''' where q''_def: \<open>R p' q'''\<close> \<open>q'' \<longmapsto>* tau  q'''\<close>
      using case_assms(4) steps_retain_weak_sim[OF ws] by blast
    ultimately show \<open>\<exists> q'''. R p' q''' \<and> q \<Rightarrow>^a  q'''\<close> using weak_step_extend by blast
  next
    fix p q p' a
    assume
      \<open>R p q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>\<nexists>q'. R p' q' \<and> q \<Rightarrow>^a  q'\<close>
      \<open>tau a\<close>
    thus \<open>False\<close>
      using steps_retain_weak_sim[OF ws] by blast
  next
    \<comment>\<open>case identical to first case\<close>
    fix p q p' a pq1 pq2
    assume case_assms:
      \<open>R p q\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain q' where q'_def: \<open>q \<longmapsto>* tau  q'\<close> \<open>R pq1 q'\<close>
      using steps_retain_weak_sim[OF ws] by blast
    then moreover obtain q'' where q''_def: \<open>R pq2 q''\<close> \<open>q' \<Rightarrow>^a  q''\<close>
      using ws case_assms(3) unfolding weak_simulation_def by blast
    then moreover obtain q''' where q''_def: \<open>R p' q'''\<close> \<open>q'' \<longmapsto>* tau  q'''\<close>
      using case_assms(4) steps_retain_weak_sim[OF ws] by blast
    ultimately show \<open>\<exists> q'''. R p' q''' \<and> q \<Rightarrow>^a  q'''\<close> using weak_step_extend by blast
  qed
qed

lemma weak_sim_enabled_subs:
  assumes
    \<open>p \<sqsubseteq>ws q\<close>
    \<open>weak_enabled p a\<close>
    \<open>\<not> tau a\<close>
  shows \<open>weak_enabled q a\<close>
proof-
  obtain p' where p'_spec: \<open>p \<Rightarrow>a p'\<close>
    using \<open>weak_enabled p a\<close> weak_enabled_step by blast
  obtain R where \<open>R p q\<close> \<open>weak_simulation R\<close> using assms(1) by blast
  then obtain q' where \<open>q \<Rightarrow>^a q'\<close>
    unfolding weak_sim_weak_premise using weak_step_impl_weak_tau[OF p'_spec] by blast
  thus ?thesis using weak_enabled_step assms(3) by blast
qed

lemma weak_sim_union_cl:
  assumes
    \<open>weak_simulation RA\<close>
    \<open>weak_simulation RB\<close>
  shows
    \<open>weak_simulation (\<lambda> p q. RA p q \<or> RB p q)\<close>
  using assms unfolding weak_simulation_def by blast

lemma weak_sim_remove_dead_state:
  assumes
    \<open>weak_simulation R\<close>
    \<open>\<And> a p . \<not> step d a p \<and> \<not> step p a d\<close>
  shows
    \<open>weak_simulation (\<lambda> p q . R p q \<and> q \<noteq> d)\<close>
  unfolding weak_simulation_def
proof safe
  fix p q p' a
  assume
    \<open>R p q\<close>
    \<open>q \<noteq> d\<close>
    \<open>p \<longmapsto>a  p'\<close>
  then obtain q' where \<open>R p' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
    using assms(1) unfolding weak_simulation_def by blast
  moreover hence \<open>q' \<noteq> d\<close>
    using assms(2) `q \<noteq> d` by (metis steps.cases)
  ultimately show \<open>\<exists>q'. (R p' q' \<and> q' \<noteq> d) \<and> q \<Rightarrow>^a  q'\<close> by blast
qed

lemma weak_sim_tau_step:
  \<open>weak_simulation (\<lambda> p1 q1 . q1 \<longmapsto>* tau p1)\<close>
  unfolding weak_simulation_def
  using lts.steps.simps by metis

lemma weak_sim_trans_constructive:
  fixes R1 R2
  defines
    \<open>R \<equiv> \<lambda> p q . \<exists> pq . (R1 p pq \<and> R2 pq q) \<or> (R2 p pq \<and> R1 pq q)\<close>
  assumes
    R1_def: \<open>weak_simulation R1\<close> \<open>R1 p pq\<close> and
    R2_def: \<open>weak_simulation R2\<close> \<open>R2 pq q\<close>
  shows
    \<open>R p q\<close> \<open>weak_simulation R\<close>
proof-
  show \<open>R p q\<close> unfolding R_def using R1_def(2) R2_def(2) by blast
next
  show \<open>weak_simulation R\<close>
    unfolding weak_sim_weak_premise R_def
  proof (safe)
    fix p q pq p' a pq1 pq2
    assume
      \<open>R1 p pq\<close>
      \<open>R2 pq q\<close>
      \<open>\<not> tau a\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    thus \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      using R1_def(1) R2_def(1) unfolding weak_sim_weak_premise by blast
  next
    fix p q pq p' a
    assume
      \<open>R1 p pq\<close>
      \<open>R2 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>\<nexists>q'.(\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q')\<and> q \<Rightarrow>^a  q'\<close>
      \<open>tau a\<close>
    thus \<open>False\<close>
      using R1_def(1) R2_def(1) unfolding weak_sim_weak_premise by blast
  next
    fix p q pq p' a pq1 pq2
    assume
      \<open>R1 p pq\<close>
      \<open>R2 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain pq' q' where \<open>R1 p' pq'\<close> \<open>pq \<Rightarrow>^a  pq'\<close> \<open>R2 pq' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
      using R1_def(1) R2_def(1) assms(3) unfolding weak_sim_weak_premise by blast
    thus \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      by blast
  next
    fix p q pq p' a pq1 pq2
    assume sa:
      \<open>R2 p pq\<close>
      \<open>R1 pq q\<close>
      \<open>\<not> tau a\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain pq' q'  where \<open>R2 p' pq'\<close> \<open>pq \<Rightarrow>^a  pq'\<close> \<open>R1 pq' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
      using R2_def(1) R1_def(1) unfolding weak_sim_weak_premise by blast
    thus \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      by blast
  next
    fix p q pq p' a
    assume
      \<open>R2 p pq\<close>
      \<open>R1 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>\<nexists>q'.(\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q')\<and> q \<Rightarrow>^a  q'\<close>
      \<open>tau a\<close>
    thus \<open>False\<close>
      using R1_def(1) R2_def(1) weak_step_tau_tau[OF `p \<longmapsto>* tau  p'` tau_tau]
      unfolding weak_sim_weak_premise by (metis (no_types, lifting))
  next
    fix p q pq p' a pq1 pq2
    assume sa:
      \<open>R2 p pq\<close>
      \<open>R1 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain pq'  where \<open>R2 p' pq'\<close> \<open>pq \<Rightarrow>^a  pq'\<close>
      using R1_def(1) R2_def(1) weak_step_impl_weak_tau[of p a p']
      unfolding weak_sim_weak_premise by blast
    moreover then obtain q' where \<open>R1 pq' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
      using R1_def(1) sa(2) unfolding weak_sim_weak_premise by blast
    ultimately show \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      by blast
  qed
qed

lemma weak_sim_trans:
  assumes
    \<open>p \<sqsubseteq>ws pq\<close>
    \<open>pq \<sqsubseteq>ws q\<close>
  shows
    \<open>p \<sqsubseteq>ws q\<close>
  using assms(1,2)
proof -
  obtain R1 R2  where  \<open>weak_simulation R1\<close> \<open>R1 p pq\<close> \<open>weak_simulation R2\<close> \<open>R2 pq q\<close>
    using assms(1,2) by blast
  thus ?thesis
    using weak_sim_trans_constructive tau_tau
    by blast
qed

subsection \<open>Weak Bisimulation\<close>

definition weak_bisimulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>weak_bisimulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow> (\<exists> q'. R p' q'
      \<and> (q \<Rightarrow>^a q'))) \<and>
    (\<forall> q' a. q \<longmapsto>a q' \<longrightarrow> (\<exists> p'. R p' q'
      \<and> ( p \<Rightarrow>^a p')))\<close>

lemma weak_bisim_ruleformat:
assumes \<open>weak_bisimulation R\<close>
  and \<open>R p q\<close>
shows
  \<open>p \<longmapsto>a p' \<Longrightarrow> \<not>tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<Rightarrow>a q'))\<close>
  \<open>p \<longmapsto>a p' \<Longrightarrow>  tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<longmapsto>* tau q'))\<close>
  \<open>q \<longmapsto>a q' \<Longrightarrow> \<not>tau a \<Longrightarrow> (\<exists> p'. R p' q' \<and> (p \<Rightarrow>a p'))\<close>
  \<open>q \<longmapsto>a q' \<Longrightarrow>  tau a \<Longrightarrow> (\<exists> p'. R p' q' \<and> (p \<longmapsto>* tau p'))\<close>
  using assms unfolding weak_bisimulation_def by (blast+)

definition tau_weak_bisimulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow>  bool) \<Rightarrow>  bool\<close>
where
  \<open>tau_weak_bisimulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow>
      (\<exists> q'. R p' q' \<and> (q \<Rightarrow>a q'))) \<and>
    (\<forall> q' a. q \<longmapsto>a q' \<longrightarrow>
      (\<exists> p'. R p' q' \<and> (p \<Rightarrow>a p')))\<close>

lemma weak_bisim_implies_tau_weak_bisim:
  assumes
    \<open>tau_weak_bisimulation R\<close>
  shows
    \<open>weak_bisimulation R\<close>
unfolding weak_bisimulation_def proof (safe)
  fix p q p' a
  assume \<open>R p q\<close> \<open>p \<longmapsto>a  p'\<close>
  thus \<open>\<exists>q'. R p' q' \<and> (q \<Rightarrow>^a  q')\<close>
    using assms weak_steps[of q a _ tau] unfolding tau_weak_bisimulation_def by blast
next
  fix p q q' a
  assume \<open>R p q\<close> \<open>q \<longmapsto>a  q'\<close>
  thus \<open>\<exists>p'. R p' q' \<and> (p \<Rightarrow>^a  p')\<close>
    using assms weak_steps[of p a _ tau] unfolding tau_weak_bisimulation_def by blast
qed

lemma weak_bisim_invert:
  assumes
    \<open>weak_bisimulation R\<close>
  shows
    \<open>weak_bisimulation (\<lambda> p q. R q p)\<close>
using assms unfolding weak_bisimulation_def by auto

lemma bisim_weak_bisim:
  assumes \<open>bisimulation R\<close>
  shows \<open>weak_bisimulation R\<close>
  unfolding weak_bisimulation_def
proof (clarify, rule)
  fix p q
  assume R: \<open>R p q\<close>
  show \<open>\<forall>p' a. p \<longmapsto>a  p' \<longrightarrow> (\<exists>q'. R p' q' \<and> (q \<Rightarrow>^a  q'))\<close>
  proof (clarify)
    fix p' a
    assume p'a: \<open>p \<longmapsto>a  p'\<close>
    have
      \<open>\<not> tau a \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<Rightarrow>a  q')\<close>
      \<open>(tau a \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<longmapsto>* tau  q'))\<close>
      using bisim_ruleformat(1)[OF assms R p'a] step_weak_step step_weak_step_tau by auto
    thus \<open>\<exists>q'. R p' q' \<and> (q \<Rightarrow>^a  q')\<close> by blast
  qed
next
  fix p q
  assume R: \<open>R p q\<close>
  have \<open>\<forall>q' a. q \<longmapsto>a  q' \<longrightarrow> (\<not> tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<Rightarrow>a  p'))
     \<and> (tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<longmapsto>* tau  p'))\<close>
  proof (clarify)
    fix q' a
    assume q'a: \<open>q \<longmapsto>a  q'\<close>
    show
      \<open>(\<not> tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<Rightarrow>a  p')) \<and>
      (tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<longmapsto>* tau  p'))\<close>
      using bisim_ruleformat(2)[OF assms R q'a] step_weak_step
        step_weak_step_tau steps_one_step by auto
  qed
  thus \<open>\<forall>q' a. q \<longmapsto>a  q' \<longrightarrow> (\<exists>p'. R p' q' \<and> (p \<Rightarrow>^a  p'))\<close> by blast
qed

lemma weak_bisim_weak_sim:
shows
  \<open>weak_bisimulation R = (weak_simulation R \<and> weak_simulation (\<lambda> p q . R q p))\<close>
unfolding weak_bisimulation_def weak_simulation_def by auto

lemma steps_retain_weak_bisim:
  assumes
    \<open>weak_bisimulation R\<close>
    \<open>R p q\<close>
    \<open>p \<longmapsto>*A  p'\<close>
    \<open>\<And> a . tau a \<Longrightarrow> A a\<close>
  shows \<open>\<exists>q'. R p' q' \<and> q \<longmapsto>*A  q'\<close>
    using assms weak_bisim_weak_sim steps_retain_weak_sim
    by auto

lemma weak_bisim_union:
  assumes
    \<open>weak_bisimulation R1\<close>
    \<open>weak_bisimulation R2\<close>
  shows
    \<open>weak_bisimulation (\<lambda> p q . R1 p q \<or> R2 p q)\<close>
  using assms unfolding weak_bisimulation_def by blast

subsection \<open>Delay Simulation\<close>

definition delay_simulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>delay_simulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow>
      (tau a \<longrightarrow> R p' q) \<and>
      (\<not>tau a \<longrightarrow> (\<exists> q'. R p' q'\<and> (q =\<rhd>a q'))))\<close>

lemma delay_simulation_implies_weak_simulation:
  assumes
    \<open>delay_simulation R\<close>
  shows
    \<open>weak_simulation R\<close>
  using assms weak_step_delay_implies_weak_tau steps.refl
  unfolding delay_simulation_def weak_simulation_def by blast

end \<comment>\<open>context @{locale lts_tau}\<close>

subsection \<open>Similarity ignores \<open>\<tau>\<close>-sinks\<close>

lemma simulation_tau_sink_1:
  fixes
    step sink \<tau> R
  defines
    \<open>step2 \<equiv> \<lambda> p1 a p2 . (p1 \<noteq> sink \<and> a = \<tau> \<and> p2 = sink) \<or> step p1 a p2\<close>
  assumes
    \<open>\<And> a p . \<not> step sink a p\<close>
    \<open>lts_tau.weak_simulation step \<tau> R\<close>
  shows
    \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda> p q. p = sink \<or> R p q)\<close>
proof -
  let ?tau = \<open>(lts_tau.tau \<tau>)\<close>
  let ?tauEx = \<open>\<tau>\<close>
  show ?thesis unfolding lts_tau.weak_simulation_def
  proof safe
    fix p q p' a
    assume \<open>step2 sink a p'\<close>
    hence \<open>p' = sink\<close> \<open>a = \<tau>\<close>
      using assms(2) unfolding step2_def by auto
    thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
        \<and> lts.steps step2 pq2 ?tau q'))\<close>
      using lts_tau.step_tau_refl[of \<tau> step2 q] lts.steps.refl[of step2 q ?tau]  by auto
  next
    fix p q p' a
    assume \<open>step2 p a p'\<close> \<open>R p q\<close>
    have step_impl_step2: \<open>\<And> p1 a p2 . step p1 a p2 \<Longrightarrow> step2 p1 a p2\<close>
      unfolding step2_def by blast
    have \<open>(p \<noteq> sink \<and> a = ?tauEx \<and> p' = sink) \<or> step p a p'\<close>
      using `step2 p a p'` unfolding step2_def .
    thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
        \<and> lts.steps step2 pq2 ?tau q'))\<close>
    proof safe
      show \<open>\<exists>q'. (sink = sink \<or> R sink q') \<and>
           (?tau ?tauEx \<longrightarrow> lts.steps step2 q ?tau q') \<and>
           (\<not> ?tau ?tauEx \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1
            \<and> step2 pq1 ?tauEx pq2 \<and> lts.steps step2 pq2 ?tau q'))\<close>
        using lts.steps.refl[of step2 q ?tau] assms(1) by (meson lts_tau.tau_tau)
    next
      assume \<open>step p a p'\<close>
      then obtain q' where q'_def:
        \<open>R p' q' \<and>
        (?tau a \<longrightarrow> lts.steps step q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step q ?tau pq1 \<and> step pq1 a pq2
          \<and> lts.steps step pq2 ?tau q'))\<close>
        using assms(3) `R p q` unfolding lts_tau.weak_simulation_def by blast
      hence \<open>(p' = sink \<or> R p' q') \<and>
        (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
          \<and> lts.steps step2 pq2 ?tau q'))\<close>
        using lts_impl_steps[of step _ _ _ step2] step_impl_step2 by blast
      thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
        (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
          \<and> lts.steps step2 pq2 ?tau q'))\<close>
        by blast
    qed
  qed
qed

lemma simulation_tau_sink_2:
  fixes
    step sink R \<tau>
  defines
    \<open>step2 \<equiv> \<lambda> p1 a p2 . (p1 \<noteq> sink \<and> a = \<tau> \<and> p2 = sink) \<or> step p1 a p2\<close>
  assumes
    \<open>\<And> a p . \<not> step sink a p \<and> \<not> step p a sink\<close>
    \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda> p q. p = sink \<or> R p q)\<close>
    \<open>\<And> p' q' q . (p' = sink \<or> R p' q')
      \<and> lts.steps step2 q (lts_tau.tau \<tau>) q'  \<longrightarrow> (p' = sink \<or> R p' q)\<close>
  shows
    \<open>lts_tau.weak_simulation step \<tau> (\<lambda> p q. p = sink \<or> R p q)\<close>
proof -
  let ?tau = \<open>(lts_tau.tau \<tau>)\<close>
  let ?tauEx = \<open>\<tau>\<close>
  let ?steps = \<open>lts.steps\<close>
  show ?thesis
    unfolding lts_tau.weak_simulation_def
  proof safe
    fix p q p' a
    assume
      \<open>step sink a p'\<close>
    hence False using assms(2) by blast
    thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> ?steps step q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
        \<and> ?steps step pq2 ?tau q'))\<close> ..
  next
    fix p q p' a
    assume \<open>R p q\<close> \<open>step p a p'\<close>
    hence not_sink: \<open>p \<noteq> sink\<close> \<open>p' \<noteq> sink\<close>
      using assms(2)[of a p] assms(2)[of a p'] by auto
    have \<open>step2 p a p'\<close> using `step p a p'` unfolding step2_def by blast
    then obtain q' where q'_def:
      \<open>p' = sink \<or> R p' q'\<close>
      \<open>?tau a \<longrightarrow> ?steps step2 q ?tau q'\<close>
      \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
        \<and> ?steps step2 pq2 ?tau q')\<close>
      using assms(3) `R p q` unfolding lts_tau.weak_simulation_def by blast
    hence outer_goal_a: \<open>R p' q'\<close> using not_sink by blast
    show \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> ?steps step q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
        \<and> ?steps step pq2 ?tau q'))\<close>
    proof (cases \<open>q' = sink\<close>)
      assume \<open>q' = sink\<close>
      then obtain q'' where q''_def:
        \<open>?tau a \<longrightarrow> (?steps step q ?tau q'' \<and> ?steps step2 q'' ?tau q')\<close>
        \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1. ?steps step2 q ?tau pq1 \<and> step pq1 a q''
          \<and> ?steps step2 q'' ?tau q')\<close>
        using q'_def(2,3) assms(1) step2_def lts_tau.step_tau_refl[of \<tau>]
          lts_tau.tau_tau[of \<tau>] by metis
      hence \<open>q'' = sink \<longrightarrow> q = sink\<close>
        using assms(2) unfolding step2_def by (metis lts.steps.cases)
      have \<open>?steps step2 q'' ?tau q'\<close> using q''_def by auto
      hence \<open>p' = sink \<or> R p' q''\<close> using  q'_def(1) assms(4)[of p' q' q''] by blast
      moreover have \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
        \<and> ?steps step pq2 ?tau q'')\<close>
      proof
        assume \<open>\<not> ?tau a\<close>
        hence \<open>q \<noteq> sink\<close> using q'_def by (metis assms(2) lts.steps_left step2_def)
        hence \<open>q'' \<noteq> sink\<close> using `q'' = sink \<longrightarrow> q = sink` by simp
        obtain pq1 where pq1_def:
            \<open>?steps step2 q ?tau pq1\<close> \<open>step pq1 a q''\<close> \<open>?steps step2 q'' ?tau q'\<close>
          using q''_def(2) `\<not> ?tau a` by blast
        hence \<open>pq1 \<noteq> sink\<close> using `q'' \<noteq> sink` assms(2) by blast
        hence \<open>?steps step q ?tau pq1\<close> using `q \<noteq> sink` `?steps step2 q ?tau pq1`
        proof (induct rule: lts.steps.induct[OF `?steps step2 q ?tau pq1`])
          case (1 p af)
          then show ?case using lts.steps.refl[of step p af] by blast
        next
          case (2 p af q1 a q)
          hence \<open>q1 \<noteq> sink\<close> \<open>step q1 a q\<close> using assms(2) unfolding step2_def by auto
          moreover hence \<open>?steps step p af q1\<close> using 2 by blast
          ultimately show ?case using 2(4) by (meson lts.step)
        qed
        thus
          \<open>\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2 \<and> ?steps step pq2 ?tau q''\<close>
          using pq1_def(2) lts.steps.refl[of step q'' ?tau] by blast
      qed
      ultimately show \<open>\<exists>q''. (p' = sink \<or> R p' q'') \<and>
           (?tau a \<longrightarrow> ?steps step q ?tau q'') \<and>
           (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
            \<and> ?steps step pq2 ?tau q''))\<close>
        using q''_def(1) q'_def(1) by auto
    next
      assume not_sink_q': \<open>q' \<noteq> sink\<close>
      have outer_goal_b: \<open>?tau a \<longrightarrow> ?steps step q ?tau q'\<close>
        using q'_def(2) not_sink_q' unfolding step2_def
      proof (safe)
        assume i:
          \<open>q' \<noteq> sink\<close> \<open>?tau a\<close>
          \<open>?steps (\<lambda>p1 a p2.  p1 \<noteq> sink \<and> a = ?tauEx \<and> p2 = sink \<or> step p1 a p2) q ?tau q'\<close>
        thus \<open>?steps step q ?tau q'\<close>
        proof (induct rule: lts.steps.induct[OF i(3)])
          case (1 p af)
          then show ?case using lts.steps.refl[of _ p af] by auto
        next
          case (2 p af q1 a q)
          hence \<open>step q1 a q\<close> by blast
          moreover have \<open>?steps step p af q1\<close> using 2 assms(2) by blast
          ultimately show ?case using `af a` lts.step[of step p af q1 a q] by blast
        qed
      qed
      have outer_goal_c:
          \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
          \<and> ?steps step pq2 ?tau q')\<close>
        using q'_def(3)
      proof safe
        fix pq1 pq2
        assume subassms:
          \<open>\<not> ?tau a\<close>
          \<open>?steps step2 q ?tau pq1\<close>
          \<open>step2 pq1 a pq2\<close>
          \<open>?steps step2 pq2 ?tau q'\<close>
        have \<open>pq2 \<noteq> sink\<close>
          using subassms(4) assms(2) not_sink_q' lts.steps_loop
          unfolding step2_def by (metis (mono_tags, lifting))
        have  goal_c: \<open>?steps step pq2 ?tau q'\<close>
          using subassms(4) not_sink_q' unfolding step2_def
        proof (induct rule:lts.steps.induct[OF subassms(4)])
          case (1 p af) show ?case using lts.steps.refl by assumption
        next
          case (2 p af q1 a q)
          hence \<open>step q1 a q\<close> unfolding step2_def by simp
          moreover hence \<open>q1 \<noteq> sink\<close> using assms(2) by blast
          ultimately have \<open>?steps step p af q1\<close> using 2 unfolding step2_def by auto
          thus ?case using `step q1 a q` 2(4) lts.step[of step p af q1 a q] by blast
        qed
        have goal_b: \<open>step pq1 a pq2\<close>
          using `pq2 \<noteq> sink` subassms(3) unfolding step2_def by blast
        hence \<open>pq1 \<noteq> sink\<close> using assms(2) by blast
        hence goal_a: \<open>?steps step q ?tau pq1\<close>
          using subassms(4) unfolding step2_def
        proof (induct rule:lts.steps.induct[OF subassms(2)])
          case (1 p af) show ?case using lts.steps.refl by assumption
        next
          case (2 p af q1 a q)
          hence \<open>step q1 a q\<close> unfolding step2_def by simp
          moreover hence \<open>q1 \<noteq> sink\<close> using assms(2) by blast
          ultimately have \<open>?steps step p af q1\<close> using 2 unfolding step2_def by auto
          thus ?case using `step q1 a q` 2(4) lts.step[of step p af q1 a q] by blast
        qed
        thus
          \<open>\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2 \<and> ?steps step pq2 ?tau q'\<close>
          using goal_b goal_c by auto
      qed
      thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and> (?tau a \<longrightarrow> ?steps step q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
          \<and> ?steps step pq2 ?tau q'))\<close>
        using outer_goal_a outer_goal_b by auto
    qed
  qed
qed

lemma simulation_sink_invariant:
  fixes
    step sink \<tau> R
  defines
    \<open>step2 \<equiv> \<lambda> p1 a p2 . (p1 \<noteq> sink \<and> a =  \<tau> \<and> p2 = sink) \<or> step p1 a p2\<close>
  assumes
    \<open>\<And> a p . \<not> step sink a p \<and> \<not> step p a sink\<close>
  shows \<open>lts_tau.weakly_simulated_by step2 \<tau> p q = lts_tau.weakly_simulated_by step \<tau> p q\<close>
proof (rule)
  have sink_sim_min: \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda> p q. p = sink)\<close>
    unfolding lts_tau.weak_simulation_def step2_def using assms(2)
    by (meson lts.steps.simps)
  define R where \<open>R \<equiv> lts_tau.weakly_simulated_by step2 \<tau>\<close>
  have weak_sim_R: \<open>lts_tau.weak_simulation step2 \<tau> R\<close>
    using lts_tau.weaksim_greatest[of step2 \<tau>] unfolding R_def by blast
  have R_contains_inv_tau_closure:
    \<open>R = (\<lambda>p1 q1. R p1 q1 \<or> lts.steps step2 q1 (lts_tau.tau \<tau>) p1)\<close> unfolding R_def
  proof (rule, rule, rule, simp)
    fix p q
    assume
      \<open>(\<exists>R. lts_tau.weak_simulation step2 \<tau>  R \<and> R p q) \<or>
       (lts.steps step2 q (lts_tau.tau \<tau>) p)\<close>
    thus \<open>\<exists>R. lts_tau.weak_simulation step2 \<tau> R \<and> R p q\<close>
      using weak_sim_R
            lts_tau.weak_sim_tau_step[of step2 \<open>\<tau>\<close>]
            lts_tau.weak_sim_union_cl[of step2 \<open>\<tau>\<close>] by blast
  qed
  assume Rpq: \<open>R p q\<close>
  have \<open>\<And> p' q' q . R p' q' \<and> lts.steps step2 q (lts_tau.tau \<tau>) q'  \<longrightarrow> R p' q\<close>
    using R_contains_inv_tau_closure lts_tau.weak_sim_trans[of step2 \<open>\<tau>\<close> _ _ _] R_def assms(2)
    by meson
  hence closed_R:
      \<open>\<And> p' q' q . (p' = sink \<or> R p' q') \<and> lts.steps step2 q (lts_tau.tau \<tau>) q'
         \<longrightarrow> (p' = sink \<or> R p' q)\<close>
    using weak_sim_R sink_sim_min lts_tau.weak_sim_union_cl by blast
  have \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda>p q. p = sink \<or> R p q)\<close>
    using weak_sim_R sink_sim_min lts_tau.weak_sim_union_cl[of step2 \<tau>] by blast
  hence \<open>lts_tau.weak_simulation step \<tau> (\<lambda>p q. p = sink \<or> R p q)\<close>
    using  simulation_tau_sink_2[of step sink \<tau> R] assms(2) closed_R
    unfolding step2_def by blast
  thus \<open>\<exists>R. lts_tau.weak_simulation step \<tau> R \<and> R p q\<close>
    using Rpq weak_sim_R by blast
next
  show \<open>\<exists>R. lts_tau.weak_simulation step \<tau> R \<and> R p q \<Longrightarrow>
        \<exists>R. lts_tau.weak_simulation step2 \<tau> R \<and> R p q\<close>
  proof clarify
    fix R
    assume
      \<open>lts_tau.weak_simulation step \<tau> R\<close>
      \<open>R p q\<close>
    hence \<open>lts_tau.weak_simulation
      (\<lambda>p1 a p2. p1 \<noteq> sink \<and> a = \<tau> \<and> p2 = sink \<or> step p1 a p2) \<tau> (\<lambda>p q. p = sink \<or> R p q)\<close>
      using simulation_tau_sink_1[of step sink \<tau> R] assms(2) unfolding step2_def by auto
    thus \<open>\<exists>R. lts_tau.weak_simulation step2 \<tau> R \<and> R p q\<close>
      using `R p q` unfolding step2_def by blast
  qed
qed

end