theory FOR_Check_Impl
  imports FOR_Check
   Regular_Tree_Relations.Regular_Relation_Impl
   NF_Impl
begin

section \<open>Inference checking implementation\<close>

(* we define epsilon free agtt/gtt constructions *)
definition "ftrancl_eps_free_closures \<A> = eps_free_automata (eps \<A>) \<A>"
abbreviation "ftrancl_eps_free_reg \<A> \<equiv> Reg (fin \<A>) (ftrancl_eps_free_closures (ta \<A>))"

lemma ftrancl_eps_free_ta_derI:
  "(eps \<A>)|\<^sup>+| = eps \<A> \<Longrightarrow> ta_der (ftrancl_eps_free_closures \<A>) (term_of_gterm t) = ta_der \<A> (term_of_gterm t)"
  using eps_free[of \<A>] ta_res_eps_free[of \<A>]
  by (auto simp add: ftrancl_eps_free_closures_def)

lemma \<L>_ftrancl_eps_free_closuresI:
  "(eps (ta \<A>))|\<^sup>+| = eps (ta \<A>) \<Longrightarrow> \<L> (ftrancl_eps_free_reg \<A>) = \<L> \<A>"
  using ftrancl_eps_free_ta_derI[of "ta \<A>"]
  unfolding \<L>_def by (auto simp: gta_lang_def gta_der_def)

definition "root_step R \<F> \<equiv> (let (TA1, TA2) = agtt_grrstep R \<F> in
  (ftrancl_eps_free_closures TA1, TA2))"

definition AGTT_trancl_eps_free :: "('q, 'f) gtt \<Rightarrow> ('q + 'q, 'f) gtt" where
  "AGTT_trancl_eps_free \<G> = (let (\<A>, \<B>) = AGTT_trancl \<G> in
    (ftrancl_eps_free_closures \<A>, \<B>))"

definition GTT_trancl_eps_free where
  "GTT_trancl_eps_free \<G> = (let (\<A>, \<B>) = GTT_trancl \<G> in
   (ftrancl_eps_free_closures \<A>,
    ftrancl_eps_free_closures \<B>))"

definition AGTT_comp_eps_free where
  "AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2 = (let (\<A>, \<B>) = AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 in
    (ftrancl_eps_free_closures \<A>, \<B>))"

definition GTT_comp_eps_free where
  "GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2 =(let (\<A>, \<B>) = GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 in
    (ftrancl_eps_free_closures \<A>, ftrancl_eps_free_closures \<B>))"

(* epsilon free proves *)
lemma eps_free_relable [simp]:
  "is_gtt_eps_free (relabel_gtt \<G>) = is_gtt_eps_free \<G>"
  by (auto simp: is_gtt_eps_free_def relabel_gtt_def fmap_states_gtt_def fmap_states_ta_def)

lemma eps_free_prod_swap:
  "is_gtt_eps_free (\<A>, \<B>) \<Longrightarrow> is_gtt_eps_free (\<B>, \<A>)"
  by (auto simp: is_gtt_eps_free_def)

lemma eps_free_root_step:
  "is_gtt_eps_free (root_step R \<F>)"
  by (auto simp add: case_prod_beta is_gtt_eps_free_def root_step_def pair_at_to_agtt'_def ftrancl_eps_free_closures_def)

lemma eps_free_AGTT_trancl_eps_free:
  "is_gtt_eps_free \<G> \<Longrightarrow> is_gtt_eps_free (AGTT_trancl_eps_free \<G>)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_trancl_def Let_def
      AGTT_trancl_eps_free_def ftrancl_eps_free_closures_def)

lemma eps_free_GTT_trancl_eps_free:
  "is_gtt_eps_free \<G> \<Longrightarrow> is_gtt_eps_free (GTT_trancl_eps_free \<G>)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_trancl_eps_free_def ftrancl_eps_free_closures_def)

lemma eps_free_AGTT_comp_eps_free:
  "is_gtt_eps_free \<G>\<^sub>2 \<Longrightarrow> is_gtt_eps_free (AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_comp_eps_free_def
    ftrancl_eps_free_closures_def AGTT_comp_def fmap_states_gtt_def fmap_states_ta_def)

lemma eps_free_GTT_comp_eps_free:
  "is_gtt_eps_free (GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2)"
  by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_comp_eps_free_def ftrancl_eps_free_closures_def)

lemmas eps_free_const =
  eps_free_prod_swap
  eps_free_root_step
  eps_free_AGTT_trancl_eps_free
  eps_free_GTT_trancl_eps_free
  eps_free_AGTT_comp_eps_free
  eps_free_GTT_comp_eps_free

(* lang preserve proofs *)
lemma agtt_lang_derI:
  assumes "\<And> t. ta_der (fst \<A>) (term_of_gterm t) = ta_der (fst \<B>) (term_of_gterm t)"
    and "\<And> t. ta_der (snd \<A>) (term_of_gterm t) = ta_der (snd \<B>) (term_of_gterm t)"
  shows "agtt_lang \<A> = agtt_lang \<B>" using assms
  by (auto simp: agtt_lang_def gta_der_def)

lemma agtt_lang_root_step_conv:
  "agtt_lang (root_step R \<F>) = agtt_lang (agtt_grrstep R \<F>)"
  using ftrancl_eps_free_ta_derI[OF agtt_grrstep_eps_trancl(1), of R \<F>]
  by (auto simp: case_prod_beta root_step_def intro!: agtt_lang_derI)

lemma agtt_lang_AGTT_trancl_eps_free_conv:
  assumes "is_gtt_eps_free \<G>"
  shows "agtt_lang (AGTT_trancl_eps_free \<G>) = agtt_lang (AGTT_trancl \<G>)"
proof -
  let ?eps = "eps (fst (AGTT_trancl \<G>))"
  have "?eps |O| ?eps = {||}" using assms
    by (auto simp: AGTT_trancl_def is_gtt_eps_free_def Let_def fmap_states_ta_def)
  from ftrancl_eps_free_ta_derI[OF frelcomp_empty_ftrancl_simp[OF this]]
  show ?thesis
    by (auto simp: case_prod_beta AGTT_trancl_eps_free_def intro!: agtt_lang_derI)
qed

lemma agtt_lang_GTT_trancl_eps_free_conv:
  assumes "is_gtt_eps_free \<G>"
  shows "agtt_lang (GTT_trancl_eps_free \<G>) = agtt_lang (GTT_trancl \<G>)"
proof -
  have "(eps (fst (GTT_trancl \<G>)))|\<^sup>+| = eps (fst (GTT_trancl \<G>))"
    "(eps (snd (GTT_trancl \<G>)))|\<^sup>+| = eps (snd (GTT_trancl \<G>))" using assms
    by (auto simp: GTT_trancl_def Let_def is_gtt_eps_free_def \<Delta>_trancl_inv)
  from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
  show ?thesis
    by (auto simp: case_prod_beta GTT_trancl_eps_free_def intro!: agtt_lang_derI)
qed

lemma agtt_lang_AGTT_comp_eps_free_conv:
  assumes "is_gtt_eps_free \<G>\<^sub>1" "is_gtt_eps_free \<G>\<^sub>2"
  shows "agtt_lang (AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)"
proof -
  have "(eps (fst (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| = eps (fst (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))" using assms
    by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def
      case_prod_beta AGTT_comp_def gtt_interface_def \<Q>_def intro!: frelcomp_empty_ftrancl_simp)
  from ftrancl_eps_free_ta_derI[OF this] show ?thesis
    by (auto simp: case_prod_beta AGTT_comp_eps_free_def intro!: agtt_lang_derI)
qed

lemma agtt_lang_GTT_comp_eps_free_conv:
  assumes "is_gtt_eps_free \<G>\<^sub>1" "is_gtt_eps_free \<G>\<^sub>2"
  shows "agtt_lang (GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)"
proof -
  have "(eps (fst (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| = eps (fst (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))"
    "(eps (snd (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| = eps (snd (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))" using assms
    by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def \<Delta>\<^sub>\<epsilon>_fmember
      case_prod_beta GTT_comp_def gtt_interface_def \<Q>_def dest!: ground_ta_der_statesD
      intro!: frelcomp_empty_ftrancl_simp)
  from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
  show ?thesis
    by (auto simp: case_prod_beta GTT_comp_eps_free_def intro!: agtt_lang_derI)
qed

fun gtt_of_gtt_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs gtt_rel \<Rightarrow> (nat, 'f) gtt option" where
  "gtt_of_gtt_rel_impl \<F> Rs (ARoot is) = liftO1 (\<lambda>R. relabel_gtt (root_step R \<F>)) (is_to_trs' Rs is)"
| "gtt_of_gtt_rel_impl \<F> Rs (GInv g) = liftO1 prod.swap (gtt_of_gtt_rel_impl \<F> Rs g)"
| "gtt_of_gtt_rel_impl \<F> Rs (AUnion g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_union' g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
| "gtt_of_gtt_rel_impl \<F> Rs (ATrancl g) = liftO1 (relabel_gtt \<circ> AGTT_trancl_eps_free) (gtt_of_gtt_rel_impl \<F> Rs g)"
| "gtt_of_gtt_rel_impl \<F> Rs (GTrancl g) = liftO1 GTT_trancl_eps_free (gtt_of_gtt_rel_impl \<F> Rs g)"
| "gtt_of_gtt_rel_impl \<F> Rs (AComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
| "gtt_of_gtt_rel_impl \<F> Rs (GComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (GTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"

lemma gtt_of_gtt_rel_impl_is_gtt_eps_free:
  "gtt_of_gtt_rel_impl \<F> Rs g = Some g' \<Longrightarrow> is_gtt_eps_free g'"
proof (induct g arbitrary: g')
  case (AUnion g1 g2)
  then show ?case
    by (auto simp: is_gtt_eps_free_def AGTT_union_def fmap_states_gtt_def fmap_states_ta_def ta_union_def relabel_gtt_def)
qed (auto simp: eps_free_const)

lemma gtt_of_gtt_rel_impl_gtt_of_gtt_rel:
  "gtt_of_gtt_rel_impl \<F> Rs g \<noteq> None \<longleftrightarrow> gtt_of_gtt_rel \<F> Rs g \<noteq> None" (is "?Ls \<longleftrightarrow> ?Rs")
proof -
  have "?Ls \<Longrightarrow> ?Rs" by (induct g) auto
  moreover have "?Rs \<Longrightarrow> ?Ls" by (induct g) auto
  ultimately show ?thesis by blast
qed

lemma gtt_of_gtt_rel_impl_sound:
  "gtt_of_gtt_rel_impl \<F> Rs g = Some g' \<Longrightarrow> gtt_of_gtt_rel \<F> Rs g = Some g'' \<Longrightarrow> agtt_lang g' = agtt_lang g''"
proof (induct g arbitrary: g' g'')
  case (ARoot x)
  then show ?case by (simp add: agtt_lang_root_step_conv)
next
  case (GInv g)
  then have "agtt_lang (prod.swap g') = agtt_lang (prod.swap g'')" by auto
  then show ?case
    by (metis converse_agtt_lang converse_converse)
next
  case (AUnion g1 g2)
  then show ?case
    by simp (metis AGTT_union'_sound option.sel)
next
  case (ATrancl g)
  then show ?case
    using agtt_lang_AGTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g]
    by simp (metis AGTT_trancl_sound option.sel)
next
  case (GTrancl g)
  then show ?case
    using agtt_lang_GTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g]
    by simp (metis GTT_trancl_alang option.sel)
next
  case (AComp g1 g2)
  then show ?case
    using agtt_lang_AGTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g
      "the (gtt_of_gtt_rel_impl \<F> Rs g1)" "the (gtt_of_gtt_rel_impl \<F> Rs g2)"]
    by simp (metis AGTT_comp'_sound agtt_lang_AGTT_comp_eps_free_conv gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel)
next
  case (GComp g1 g2)
  then show ?case
    using agtt_lang_GTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g
      "the (gtt_of_gtt_rel_impl \<F> Rs g1)" "the (gtt_of_gtt_rel_impl \<F> Rs g2)"]
    by simp (metis agtt_lang_GTT_comp_eps_free_conv gtt_comp'_alang gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel)
qed

(* eps free closure constructions *)
lemma \<L>_eps_free_nhole_ctxt_closure_reg:
  assumes "is_ta_eps_free (ta \<A>)"
  shows "\<L> (ftrancl_eps_free_reg (nhole_ctxt_closure_reg \<F> \<A>)) = \<L> (nhole_ctxt_closure_reg \<F> \<A>)"
proof -
  have "eps (ta (nhole_ctxt_closure_reg \<F> \<A>)) |O| eps (ta (nhole_ctxt_closure_reg \<F> \<A>)) = {||}" using assms
    by (auto simp: nhole_ctxt_closure_reg_def gen_nhole_ctxt_closure_reg_def
      gen_nhole_ctxt_closure_automaton_def ta_union_def reflcl_over_nhole_ctxt_ta_def
      fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
  from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
    by (intro \<L>_ftrancl_eps_free_closuresI) simp
qed

lemma \<L>_eps_free_ctxt_closure_reg:
  assumes "is_ta_eps_free (ta \<A>)"
  shows "\<L> (ftrancl_eps_free_reg (ctxt_closure_reg \<F> \<A>)) = \<L> (ctxt_closure_reg \<F> \<A>)"
proof -
  have "eps (ta (ctxt_closure_reg \<F> \<A>)) |O| eps (ta (ctxt_closure_reg \<F> \<A>)) = {||}" using assms
    by (auto simp: ctxt_closure_reg_def gen_ctxt_closure_reg_def Let_def
      gen_ctxt_closure_automaton_def ta_union_def reflcl_over_single_ta_def
      fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
  from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
    by (intro \<L>_ftrancl_eps_free_closuresI) simp
qed

lemma \<L>_eps_free_parallel_closure_reg:
  assumes "is_ta_eps_free (ta \<A>)"
  shows "\<L> (ftrancl_eps_free_reg (parallel_closure_reg \<F> \<A>)) = \<L> (parallel_closure_reg \<F> \<A>)"
proof -
  have "eps (ta (parallel_closure_reg \<F> \<A>)) |O| eps (ta (parallel_closure_reg \<F> \<A>)) = {||}" using assms
    by (auto simp: parallel_closure_reg_def gen_parallel_closure_automaton_def Let_def ta_union_def
      refl_over_states_ta_def fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
  from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
    by (intro \<L>_ftrancl_eps_free_closuresI) simp
qed

abbreviation "eps_free_reg' S R \<equiv> Reg (fin R) (eps_free_automata S (ta R))"

definition "eps_free_mctxt_closure_reg \<F> \<A> =
  (let \<B> = mctxt_closure_reg \<F> \<A> in
  eps_free_reg' ((\<lambda> p. (fst p, Inr cl_state)) |`| (eps (ta \<B>)) |\<union>| eps (ta \<B>)) \<B>)"

definition "eps_free_nhole_mctxt_reflcl_reg \<F> \<A> =
  (let \<B> = nhole_mctxt_reflcl_reg \<F> \<A> in
  eps_free_reg' ((\<lambda> p. (fst p, Inl (Inr cl_state))) |`| (eps (ta \<B>)) |\<union>| eps (ta \<B>)) \<B>)"

definition "eps_free_nhole_mctxt_closure_reg \<F> \<A> =
  (let \<B> = nhole_mctxt_closure_reg \<F> \<A> in
  eps_free_reg' ((\<lambda> p. (fst p, (Inr cl_state))) |`| (eps (ta \<B>)) |\<union>| eps (ta \<B>)) \<B>)"

lemma \<L>_eps_free_reg'I:
  "(eps (ta \<A>))|\<^sup>+| = S \<Longrightarrow> \<L> (eps_free_reg' S \<A>) = \<L> \<A>"
  by (auto simp:  \<L>_def gta_lang_def gta_der_def ta_res_eps_free simp flip: eps_free)

lemma \<L>_eps_free_mctxt_closure_reg:
  assumes "is_ta_eps_free (ta \<A>)"
  shows "\<L> (eps_free_mctxt_closure_reg \<F> \<A>) = \<L> (mctxt_closure_reg \<F> \<A>)" using assms
  unfolding eps_free_mctxt_closure_reg_def Let_def
  apply (intro \<L>_eps_free_reg'I)
  apply (auto simp: comp_def mctxt_closure_reg_def is_ta_eps_free_def Let_def
    gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
    reflcl_over_nhole_ctxt_ta_def  gen_mctxt_closure_reg_def reg_Restr_Q\<^sub>f_def
    fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
  by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)

lemma \<L>_eps_free_nhole_mctxt_reflcl_reg:
  assumes "is_ta_eps_free (ta \<A>)"
  shows "\<L> (eps_free_nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_reflcl_reg \<F> \<A>)" using assms
  unfolding eps_free_nhole_mctxt_reflcl_reg_def Let_def
  apply (intro \<L>_eps_free_reg'I)
  apply (auto simp: comp_def nhole_mctxt_reflcl_reg_def is_ta_eps_free_def Let_def
    nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def reg_union_def ta_union_def
    gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
    reflcl_over_nhole_ctxt_ta_def reg_Restr_Q\<^sub>f_def fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
  by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)

lemma \<L>_eps_free_nhole_mctxt_closure_reg:
  assumes "is_ta_eps_free (ta \<A>)"
  shows "\<L> (eps_free_nhole_mctxt_closure_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<F> \<A>)" using assms
  unfolding eps_free_nhole_mctxt_closure_reg_def Let_def
  apply (intro \<L>_eps_free_reg'I)
  apply (auto simp: comp_def nhole_mctxt_closure_reg_def is_ta_eps_free_def Let_def
    gen_nhole_mctxt_closure_reg_def reg_Restr_Q\<^sub>f_def fmap_states_reg_def fmap_states_ta_def
    gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
    reflcl_over_nhole_ctxt_ta_def dest: ftranclD ftranclD2)
  by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)

fun rr1_of_rr1_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> (nat, 'f) reg option"
and rr2_of_rr2_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> (nat, 'f option \<times> 'f option) reg option" where
  "rr1_of_rr1_rel_impl \<F> Rs R1Terms = Some (relabel_reg (term_reg \<F>))"
| "rr1_of_rr1_rel_impl \<F> Rs (R1NF is) = liftO1 (\<lambda>R. (simplify_reg (nf_reg (fst |`| R) \<F>))) (is_to_trs' Rs is)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Inf r) = liftO1 (\<lambda>R.
    let \<A> = trim_reg R in
    simplify_reg (proj_1_reg (Inf_reg_impl \<A>))
  ) (rr2_of_rr2_rel_impl \<F> Rs r)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Proj i r) = (case i of 0 \<Rightarrow>
      liftO1 (trim_reg \<circ> proj_1_reg) (rr2_of_rr2_rel_impl \<F> Rs r)
    | _ \<Rightarrow> liftO1 (trim_reg \<circ> proj_2_reg) (rr2_of_rr2_rel_impl \<F> Rs r))"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Union s1 s2) =
    liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Inter s1 s2) =
    liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Diff s1 s2) = liftO2 (\<lambda> x y. relabel_reg (trim_reg (difference_reg x y))) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"

| "rr2_of_rr2_rel_impl \<F> Rs (R2GTT_Rel g w x) =
    (case w of PRoot \<Rightarrow>
      (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
        | EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> reflcl_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
        | EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g))
      | PNonRoot \<Rightarrow>
      (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> nhole_ctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
        | EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_nhole_mctxt_reflcl_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
        | EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_nhole_mctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g))
      | PAny \<Rightarrow>
      (case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> ctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
        | EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> parallel_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
        | EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_mctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)))"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Diag s) =
    liftO1 (\<lambda> x. fmap_funs_reg (\<lambda>f. (Some f, Some f)) x) (rr1_of_rr1_rel_impl \<F> Rs s)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Prod s1 s2) =
    liftO2 (\<lambda> x y. simplify_reg (pair_automaton_reg x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Inv r) = liftO1 (fmap_funs_reg prod.swap) (rr2_of_rr2_rel_impl \<F> Rs r)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Union r1 r2) =
    liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Inter r1 r2) =
    liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Diff r1 r2) = liftO2 (\<lambda> x y. simplify_reg (difference_reg x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Comp r1 r2) = liftO2 (\<lambda> x y. simplify_reg (rr2_compositon \<F> x y))
     (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"

lemmas ta_simp_unfold = simplify_reg_def relabel_reg_def trim_reg_def relabel_ta_def term_reg_def
lemma is_ta_eps_free_trim_reg [intro!]:
  "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (trim_reg R))"
  by (simp add: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)

lemma is_ta_eps_free_relabel_reg [intro!]:
  "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (relabel_reg R))"
  by (simp add: is_ta_eps_free_def relabel_reg_def relabel_ta_def fmap_states_ta_def)

lemma is_ta_eps_free_simplify_reg [intro!]:
  "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (simplify_reg R))"
  by (simp add: is_ta_eps_free_def ta_simp_unfold fmap_states_ta_def trim_ta_def ta_restrict_def)

lemma is_ta_emptyI [simp]:
 "is_ta_eps_free (TA R {||}) \<longleftrightarrow> True"
  by (simp add: is_ta_eps_free_def)

lemma is_ta_empty_trim_reg:
  "is_ta_eps_free (ta A) \<Longrightarrow> eps (ta (trim_reg A)) = {||}"
  by (auto simp: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)

lemma is_proj_ta_eps_empty:
  "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (proj_1_reg R))"
  "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (proj_2_reg R))"
  by (auto simp: is_ta_eps_free_def proj_1_reg_def proj_2_reg_def collapse_automaton_reg_def collapse_automaton_def
    fmap_funs_reg_def fmap_funs_ta_def trim_reg_def trim_ta_def ta_restrict_def)

lemma is_pod_ta_eps_empty:
  "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta L) \<Longrightarrow> is_ta_eps_free (ta (reg_intersect R L))"
  by (auto simp: reg_intersect_def prod_ta_def prod_epsRp_def prod_epsLp_def is_ta_eps_free_def)

lemma is_fmap_funs_reg_eps_empty:
  "is_ta_eps_free (ta R) \<Longrightarrow>  is_ta_eps_free (ta (fmap_funs_reg f R))"
  by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)

lemma is_collapse_automaton_reg_eps_empty:
  "is_ta_eps_free (ta R) \<Longrightarrow>  is_ta_eps_free (ta (collapse_automaton_reg R))"
  by (auto simp: collapse_automaton_reg_def collapse_automaton_def is_ta_eps_free_def)

lemma is_pair_automaton_reg_eps_empty:
  "is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta L) \<Longrightarrow> is_ta_eps_free (ta (pair_automaton_reg R L))"
  by (auto simp: pair_automaton_reg_def pair_automaton_def is_ta_eps_free_def)

lemma is_reflcl_automaton_eps_free:
  "is_ta_eps_free A \<Longrightarrow> is_ta_eps_free (reflcl_automaton (lift_sig_RR2 |`| \<F>) A)"
  by (auto simp: is_ta_eps_free_def reflcl_automaton_def ta_union_def gen_reflcl_automaton_def Let_def fmap_states_ta_def)

lemma is_GTT_to_RR2_root_eps_empty:
  "is_gtt_eps_free \<G> \<Longrightarrow> is_ta_eps_free (GTT_to_RR2_root \<G>)"
  by (auto simp: is_gtt_eps_free_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def)

lemma is_term_automata_eps_empty:
  "is_ta_eps_free (ta (term_reg \<F>)) \<longleftrightarrow> True"
  by (auto simp: is_ta_eps_free_def term_reg_def term_automaton_def)

lemma is_ta_eps_free_eps_free_automata [simp]:
  " is_ta_eps_free (eps_free_automata S R) \<longleftrightarrow> True"
  by (auto simp: eps_free_automata_def is_ta_eps_free_def)

lemma rr2_of_rr2_rel_impl_eps_free:
  shows "\<forall> A. rr1_of_rr1_rel_impl \<F> Rs r1 = Some A \<longrightarrow> is_ta_eps_free (ta A)"
   "\<forall> A. rr2_of_rr2_rel_impl \<F> Rs r2 = Some A \<longrightarrow> is_ta_eps_free (ta A)"
proof (induct r1 and r2)
case R1Terms
  then show ?case
    by (auto simp: is_ta_eps_free_def term_automaton_def fmap_states_ta_def ta_simp_unfold)
next
  case (R1NF x)
  then show ?case
    by (auto simp: nf_reg_def nf_ta_def)
next
  case (R1Inf x)
  then show ?case
    by (auto simp: Inf_reg_impl_def Let_def Inf_reg_def Inf_automata_def is_ta_empty_trim_reg intro!: is_proj_ta_eps_empty)
next
  case (R1Proj n x2)
  then show ?case
    by (cases n) (auto  intro!: is_proj_ta_eps_empty)
next
  case (R1Union x1 x2)
  then show ?case
    by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
next
  case (R1Inter x1 x2)
  then show ?case
    by (auto intro: is_pod_ta_eps_empty)
next
  case (R1Diff x1 x2)
  then show ?case
    by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
next
  case (R2GTT_Rel x1 x2 x3)
  then show ?case
    by (cases x2; cases x3) (auto simp: GTT_to_RR2_root_reg_def ftrancl_eps_free_closures_def
      eps_free_nhole_mctxt_closure_reg_def eps_free_nhole_mctxt_reflcl_reg_def Let_def
      eps_free_mctxt_closure_reg_def reflcl_reg_def
      dest: gtt_of_gtt_rel_impl_is_gtt_eps_free
      intro!: is_GTT_to_RR2_root_eps_empty is_reflcl_automaton_eps_free)
next
  case (R2Diag x)
  then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
next
  case (R2Prod x1 x2)
  then show ?case by (auto intro: is_pair_automaton_reg_eps_empty)
next
  case (R2Inv x)
  then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
next
  case (R2Union x1 x2)
  then show ?case by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
next
  case (R2Inter x1 x2)
  then show ?case by (auto intro: is_pod_ta_eps_empty)
next
  case (R2Diff x1 x2)
  then show ?case by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
next
  case (R2Comp x1 x2)
  then show ?case by (auto simp: is_term_automata_eps_empty rr2_compositon_def Let_def
     intro!: is_pod_ta_eps_empty is_fmap_funs_reg_eps_empty is_collapse_automaton_reg_eps_empty is_pair_automaton_reg_eps_empty)
qed

lemma rr_of_rr_rel_impl_complete:
  "rr1_of_rr1_rel_impl \<F> Rs r1 \<noteq> None \<longleftrightarrow> rr1_of_rr1_rel \<F> Rs r1 \<noteq> None"
  "rr2_of_rr2_rel_impl \<F> Rs r2 \<noteq> None \<longleftrightarrow> rr2_of_rr2_rel \<F> Rs r2 \<noteq> None"
proof (induct r1 and r2)
  case (R1Proj n x2)
  then show ?case by (cases n) auto
next
  case (R2GTT_Rel x1 n p)
  then show ?case using gtt_of_gtt_rel_impl_gtt_of_gtt_rel[of \<F> Rs]
    by (cases p; cases n) auto
qed auto

lemma \<Q>_fmap_funs_reg [simp]:
  "\<Q>\<^sub>r (fmap_funs_reg f \<A>) = \<Q>\<^sub>r \<A>"
  by (auto simp: fmap_funs_reg_def)

lemma ta_reachable_fmap_funs_reg [simp]:
  "ta_reachable (ta (fmap_funs_reg f \<A>)) = ta_reachable (ta \<A>)"
  by (auto simp: fmap_funs_reg_def)

lemma collapse_reg_cong:
  "\<Q>\<^sub>r \<A> |\<subseteq>| ta_reachable (ta \<A>) \<Longrightarrow> \<Q>\<^sub>r \<B> |\<subseteq>| ta_reachable (ta \<B>) \<Longrightarrow> \<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (collapse_automaton_reg \<A>) = \<L> (collapse_automaton_reg \<B>)"
  by (auto simp: collapse_automaton_reg_def \<L>_def collapse_automaton')

lemma \<L>_fmap_funs_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (fmap_funs_reg h \<A>) = \<L> (fmap_funs_reg h \<B>)"
  by (auto simp: fmap_funs_\<L>)

lemma \<L>_pair_automaton_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> \<C> = \<L> \<D> \<Longrightarrow> \<L> (pair_automaton_reg \<A> \<C>) = \<L> (pair_automaton_reg \<B> \<D>)"
  by (auto simp: pair_automaton')

lemma \<L>_nhole_ctxt_closure_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_ctxt_closure_reg \<F> \<A>) = \<L> (nhole_ctxt_closure_reg \<G> \<B>)"
  by (auto simp: nhole_ctxtcl_lang)

lemma \<L>_nhole_mctxt_closure_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_mctxt_closure_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<G> \<B>)"
  by (auto simp: nhole_gmctxt_closure_lang)

lemma \<L>_ctxt_closure_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (ctxt_closure_reg \<F> \<A>) = \<L> (ctxt_closure_reg \<G> \<B>)"
  by (auto simp: gctxt_closure_lang)

lemma \<L>_parallel_closure_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (parallel_closure_reg \<F> \<A>) = \<L> (parallel_closure_reg \<G> \<B>)"
  by (auto simp: parallelcl_gmctxt_lang)

lemma \<L>_mctxt_closure_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (mctxt_closure_reg \<F> \<A>) = \<L> (mctxt_closure_reg \<G> \<B>)"
  by (auto simp: gmctxt_closure_lang)

lemma \<L>_nhole_mctxt_reflcl_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_reflcl_reg \<G> \<B>)"
  unfolding nhole_mctxt_reflcl_lang
  by (intro arg_cong2[where ?f = "(\<union>)"] \<L>_nhole_mctxt_closure_reg_cong) auto

declare equalityI[rule del]
declare fsubsetI[rule del]
lemma \<L>_proj_1_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (proj_1_reg \<A>) = \<L> (proj_1_reg \<B>)"
  by (auto simp: proj_1_reg_def \<L>_trim intro!: collapse_reg_cong \<L>_fmap_funs_reg_cong)

lemma \<L>_proj_2_reg_cong:
  "\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (proj_2_reg \<A>) = \<L> (proj_2_reg \<B>)"
  by (auto simp: proj_2_reg_def \<L>_trim intro!: collapse_reg_cong \<L>_fmap_funs_reg_cong)

lemma rr2_of_rr2_rel_impl_sound:
  assumes  "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
  shows "\<And> A B. rr1_of_rr1_rel_impl \<F> Rs r1 = Some A \<Longrightarrow> rr1_of_rr1_rel \<F> Rs r1 = Some B \<Longrightarrow> \<L> A = \<L> B"
  "\<And> A B. rr2_of_rr2_rel_impl \<F> Rs r2 = Some A \<Longrightarrow> rr2_of_rr2_rel \<F> Rs r2 = Some B \<Longrightarrow> \<L> A = \<L> B"
proof (induct r1 and r2)
  case (R1Inf r)
  then obtain C D where inf: "rr2_of_rr2_rel_impl \<F> Rs r = Some C" "rr2_of_rr2_rel \<F> Rs r = Some D"
     "\<L> C = \<L> D" by auto
  have spec: "RR2_spec C (eval_rr2_rel (fset \<F>) (map fset Rs) r)" "RR2_spec D (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
    using rr12_of_rr12_rel_correct(2)[OF assms, rule_format, OF inf(2)] inf(3)
    by (auto simp: RR2_spec_def)
  then have trim_spec: "RR2_spec (trim_reg C) (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
    "RR2_spec (trim_reg D) (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
    by (auto simp: RR2_spec_def \<L>_trim)
  let ?C = "Inf_reg (trim_reg C) (Q_infty (ta (trim_reg C)) \<F>)" let ?D = "Inf_reg (trim_reg D) (Q_infty (ta (trim_reg D)) \<F>)"
  from spec have *: "\<L> (Inf_reg_impl (trim_reg C)) = \<L> ?C"
    using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
    by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def)
  from spec have **: "\<L> (Inf_reg_impl (trim_reg D)) = \<L> ?D"
    using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
    by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def)
  then have C: "RR2_spec ?C {(s, t) | s t. gpair s t \<in> \<L> ?C}" and
    D: "RR2_spec ?D {(s, t) | s t. gpair s t \<in> \<L> ?D}"
    using subset_trans[OF Inf_automata_subseteq[of "trim_reg C" \<F>], of "\<L> C"] spec
    using subset_trans[OF Inf_automata_subseteq[of "trim_reg D" \<F>], of "\<L> D"]
    using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
    by (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def intro!: equalityI fsubsetI)
  from * ** have r: "\<L> (proj_1_reg (Inf_reg_impl (trim_reg C))) = \<L> (proj_1_reg ?C)"
    "\<L> (proj_1_reg (Inf_reg_impl (trim_reg D))) = \<L> (proj_1_reg ?D)"
    by (auto intro: \<L>_proj_1_reg_cong)
  from \<L>_Inf_reg[OF trim_spec(1), of \<F>] \<L>_Inf_reg[OF trim_spec(2), of \<F>]
  show ?case using R1Inf eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
    by (auto simp: liftO1_def r inf \<T>\<^sub>G_equivalent_def \<L>_proj(1)[OF C] \<L>_proj(1)[OF D])
next
  case (R1Proj n x2)
  then show ?case by (cases n)
    (auto simp: liftO1_def \<L>_trim proj_1_reg_def proj_2_reg_def intro!: fsubsetI \<L>_fmap_funs_reg_cong collapse_reg_cong, (meson fin_mono trim_reg_reach)+)
next
  case (R2GTT_Rel g p n) note IH = this
  note ass = R2GTT_Rel
  consider (a) "\<exists> A. gtt_of_gtt_rel_impl \<F> Rs g = Some A" | (b) "gtt_of_gtt_rel_impl \<F> Rs g = None" by blast
  then show ?case
  proof cases
    case a then obtain C D where gtt [simp]: "gtt_of_gtt_rel_impl \<F> Rs g = Some C"
      "gtt_of_gtt_rel \<F> Rs g = Some D" using gtt_of_gtt_rel_impl_gtt_of_gtt_rel by blast
    from gtt_of_gtt_rel_impl_sound[OF this]
    have spec [simp]: "agtt_lang C = agtt_lang D" by auto
    have eps [simp]: "is_ta_eps_free (ta (GTT_to_RR2_root_reg C))"
      using gtt_of_gtt_rel_impl_is_gtt_eps_free[OF gtt(1)]
      by (auto simp: GTT_to_RR2_root_reg_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def is_gtt_eps_free_def)
    have lang: "\<L> (GTT_to_RR2_root_reg C) = \<L> (GTT_to_RR2_root_reg D)"
      by (metis (no_types, lifting) GTT_to_RR2_root RR2_spec_def spec)
    show ?thesis
    proof (cases p)
      case PRoot
      then show ?thesis using IH spec lang
        by (cases n) (auto simp: \<L>_eps_free \<L>_reflcl_reg)
    next
      case PNonRoot
      then show ?thesis using IH
        by (cases n) (auto simp: \<L>_eps_free \<L>_eps_free_nhole_ctxt_closure_reg[OF eps]
        \<L>_eps_free_nhole_mctxt_reflcl_reg[OF eps] \<L>_eps_free_nhole_mctxt_closure_reg[OF eps]
        lang intro: \<L>_nhole_ctxt_closure_reg_cong \<L>_nhole_mctxt_reflcl_reg_cong \<L>_nhole_mctxt_closure_reg_cong)
    next
      case PAny
      then show ?thesis using IH
        by (cases n) (auto simp: \<L>_eps_free \<L>_eps_free_ctxt_closure_reg[OF eps]
          \<L>_eps_free_parallel_closure_reg[OF eps] \<L>_eps_free_mctxt_closure_reg[OF eps] lang
          intro!: \<L>_ctxt_closure_reg_cong \<L>_parallel_closure_reg_cong \<L>_mctxt_closure_reg_cong)
    qed
  next
    case b then show ?thesis using IH
      by (cases p; cases n) auto
  qed
next
  case (R2Comp x1 x2)
  then show ?case
    by (auto simp: liftO1_def rr2_compositon_def \<L>_trim \<L>_intersect Let_def
        intro!: \<L>_pair_automaton_reg_cong \<L>_fmap_funs_reg_cong collapse_reg_cong arg_cong2[where ?f = "(\<inter>)"])
qed (auto simp: liftO1_def \<L>_intersect \<L>_union \<L>_trim \<L>_difference_reg intro!: \<L>_fmap_funs_reg_cong \<L>_pair_automaton_reg_cong)
declare equalityI[intro!]
declare fsubsetI[intro!]

lemma rr12_of_rr12_rel_impl_correct:
  assumes  "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
  shows "\<forall>ta1. rr1_of_rr1_rel_impl \<F> Rs r1 = Some ta1 \<longrightarrow> RR1_spec ta1 (eval_rr1_rel (fset \<F>) (map fset Rs) r1)"
    "\<forall>ta2. rr2_of_rr2_rel_impl \<F> Rs r2 = Some ta2 \<longrightarrow> RR2_spec ta2 (eval_rr2_rel (fset \<F>) (map fset Rs) r2)"
  using rr12_of_rr12_rel_correct(1)[OF assms, of r1]
  using rr12_of_rr12_rel_correct(2)[OF assms, of r2]
  using rr2_of_rr2_rel_impl_sound(1)[OF assms, of r1]
  using rr2_of_rr2_rel_impl_sound(2)[OF assms, of r2]
  using rr_of_rr_rel_impl_complete(1)[of \<F> Rs r1]
  using rr_of_rr_rel_impl_complete(2)[of \<F> Rs r2]
  by (force simp: RR1_spec_def RR2_spec_def)+

lemma check_inference_rrn_impl_correct:
  assumes sig: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" and Rs: "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
  assumes infs: "\<And>fvA. fvA \<in> set infs \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
  assumes inf: "check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs infs (l, step, fm, is) = Some (fm', vs, A')"
  shows "l = length infs \<and> fm = fm' \<and> formula_spec (fset \<F>) (map fset Rs) vs A' fm'"
  using check_inference_correct[where ?rr1c = rr1_of_rr1_rel_impl and ?rr2c = rr2_of_rr2_rel_impl, OF assms]
  using rr12_of_rr12_rel_impl_correct[OF Rs]
  by auto

definition check_sig_nempty where
  "check_sig_nempty \<F> = (0 |\<in>| snd |`| \<F>)"

definition check_trss where
  "check_trss \<R> \<F> = list_all (\<lambda> R. lv_trs (fset R) \<and> funas_trs (fset R) \<subseteq> fset \<F>) \<R>"

lemma check_sig_nempty:
  "check_sig_nempty \<F> \<longleftrightarrow> \<T>\<^sub>G (fset \<F>) \<noteq> {}" (is "?Ls \<longleftrightarrow> ?Rs")
proof -
  {assume ?Ls then obtain a where "(a, 0) |\<in>| \<F>" by (auto simp: check_sig_nempty_def)
    then have "GFun a [] \<in> \<T>\<^sub>G (fset \<F>)"
      by (intro const) (simp add: fmember_iff_member_fset)
    then have ?Rs by blast}
  moreover
  {assume ?Rs then obtain s where "s \<in> \<T>\<^sub>G (fset \<F>)" by blast
    then obtain a where "(a, 0) |\<in>| \<F>" unfolding fmember_iff_member_fset
      by (induct s) (auto, force)
    then have ?Ls unfolding check_sig_nempty_def
      by (auto simp: fimage_iff fBex_def)}
  ultimately show ?thesis by blast
qed

lemma check_trss:
  "check_trss \<R> \<F> \<longleftrightarrow> (\<forall> R \<in> set \<R>. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>)"
  unfolding check_trss_def list_all_iff
  by (auto simp: fmember_iff_member_fset ffunas_trs.rep_eq less_eq_fset.rep_eq)

fun check_inference_list :: "('f \<times> nat) fset \<Rightarrow> ('f ::  {compare,linorder}, 'v) fin_trs list
  \<Rightarrow> (nat \<times> ftrs inference \<times> ftrs formula \<times> info list) list
  \<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) list option" where
  "check_inference_list \<F> Rs infs = do {
     guard (check_sig_nempty \<F>);
     guard (check_trss Rs \<F>);
     foldl (\<lambda> tas inf. do {
        tas' \<leftarrow> tas;
        r \<leftarrow> check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs tas' inf;
        Some (tas' @ [r])
      })
      (Some []) infs
  }"

lemma check_inference_list_correct:
  assumes "check_inference_list \<F> Rs infs = Some fvAs"
  shows "length infs = length fvAs \<and> (\<forall> i < length fvAs. fst (snd (snd (infs ! i))) = fst (fvAs ! i)) \<and>
   (\<forall> i < length fvAs. formula_spec (fset \<F>) (map fset Rs) (fst (snd (fvAs ! i))) (snd (snd (fvAs ! i))) (fst (fvAs ! i)))"
  using assms
proof (induct infs arbitrary: fvAs rule: rev_induct)
  note [simp] = bind_eq_Some_conv guard_simps
  {case Nil
    then show ?case by auto
  next
    case (snoc a infs)
    have inv: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" "\<forall>R\<in>set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
      using snoc(2) by (auto simp: check_sig_nempty check_trss)
    from snoc(2) obtain fvAs' l steps fm fm' is' vs A' where
      ch: "check_inference_list \<F> Rs infs = Some fvAs'" "a = (l, steps, fm, is')"
      "check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs fvAs' (l, steps, fm, is') = Some (fm', vs, A')" "fvAs = fvAs' @ [(fm', vs, A')]"
      by (auto simp del: check_inference.simps) (metis prod_cases4)
    from snoc(1)[OF ch(1)] have "fvA \<in> set fvAs' \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)" for fvA
      by (auto dest: in_set_idx)
    from check_inference_rrn_impl_correct[OF inv this, of fvAs'] this
    show ?case using snoc(1)[OF ch(1)] ch
      by (auto simp del: check_inference.simps simp: nth_append)
  }
qed

fun check_certificate where
  "check_certificate \<F> Rs A fm (Certificate infs claim n) = do {
    guard (n < length infs);
    guard (A \<longleftrightarrow> claim = Nonempty);
    guard (fm = fst (snd (snd (infs ! n))));
    fvA \<leftarrow> check_inference_list \<F> Rs (take (Suc n) infs);
    (let E = reg_empty (snd (snd (last fvA))) in
     case claim of Empty \<Rightarrow> Some E
       | _ \<Rightarrow> Some (\<not> E))
  }"

definition formula_unsatisfiable where
  "formula_unsatisfiable \<F> Rs fm \<longleftrightarrow> (formula_satisfiable \<F> Rs fm = False)"

definition correct_certificate where
  "correct_certificate \<F> Rs claim infs n \<equiv>
    (claim = Empty \<longleftrightarrow> (formula_unsatisfiable (fset \<F>) (map fset Rs) (fst (snd (snd (infs ! n))))) \<and>
     claim = Nonempty \<longleftrightarrow> formula_satisfiable (fset \<F>) (map fset Rs) (fst (snd (snd (infs ! n)))))"

lemma check_certificate_sound:
  assumes "check_certificate \<F> Rs A fm (Certificate infs claim n) = Some B"
  shows "fm = fst (snd (snd (infs ! n)))" "A \<longleftrightarrow> claim = Nonempty"
  using assms by (auto simp: bind_eq_Some_conv guard_simps)

lemma check_certificate_correct:
  assumes "check_certificate \<F> Rs A fm (Certificate infs claim n) = Some B"
  shows "(B = True \<longrightarrow> correct_certificate \<F> Rs claim infs n) \<and>
    (B = False \<longrightarrow> correct_certificate \<F> Rs (case_claim Nonempty Empty claim) infs n)"
proof -
  note [simp] = bind_eq_Some_conv guard_simps
  from assms obtain fvAs where inf: "check_inference_list \<F> Rs (take (Suc n) infs) = Some fvAs"
    by auto
  from assms have len: "n < length infs" by auto
  from check_inference_list_correct[OF inf] have
    inv: "length fvAs = n + 1"
    "fst (snd (snd (infs ! n))) = fst (fvAs ! n)"
    "formula_spec (fset \<F>) (map fset Rs) (fst (snd (last fvAs))) (snd (snd (last fvAs))) (fst (last fvAs))"
    using len last_conv_nth[of fvAs] by force+
  have nth: "fst (last fvAs) = fst (fvAs ! n)" using inv(1)
    using len last_conv_nth[of fvAs] by force
  note spec = formula_spec_empty[OF _ inv(3)] formula_spec_nt_empty_form_sat[OF _ inv(3)]
  consider (a) "claim = Empty" | (b) "claim = Nonempty" using claim.exhaust by blast
  then show ?thesis
  proof cases
    case a
    then have *: "B = reg_empty (snd (snd (last fvAs)))" using inv
      using assms len last_conv_nth[of fvAs]
      by (auto simp: inf simp del: check_inference_list.simps)
    show ?thesis using a inv spec unfolding *
      by (auto simp: formula_satisfiable_def nth correct_certificate_def formula_unsatisfiable_def simp del: reg_empty)
  next
    case b
    then have *: "B \<longleftrightarrow> \<not> (reg_empty (snd (snd (last fvAs))))" using inv
      using assms len last_conv_nth[of fvAs]
      by (auto simp: inf simp del: check_inference_list.simps)
    show ?thesis using b inv spec unfolding *
      by (auto simp: formula_satisfiable_def nth formula_unsatisfiable_def correct_certificate_def simp del: reg_empty)
  qed
qed

definition check_certificate_string ::
  "(integer list \<times> fvar) fset \<Rightarrow>
   ((integer list, integer list) Term.term \<times> (integer list, integer list) Term.term) fset list \<Rightarrow>
   bool \<Rightarrow> ftrs formula \<Rightarrow> ftrs certificate \<Rightarrow> bool option"
  where "check_certificate_string = check_certificate"

(***********************************)
export_code check_certificate_string Var Fun fset_of_list nat_of_integer Certificate
  R2GTT_Rel R2Eq R2Reflc R2Step R2StepEq R2Steps R2StepsEq R2StepsNF R2ParStep R2RootStep
  R2RootStepEq R2RootSteps R2RootStepsEq R2NonRootStep R2NonRootStepEq R2NonRootSteps
  R2NonRootStepsEq R2Meet R2Join
  ARoot GSteps PRoot ESingle Empty Size EDistribAndOr
  R1Terms R1Fin
  FRR1 FRestrict FTrue FFalse
  IRR1 Fwd in Haskell module_name FOR

end


theory Sep_Generic_Wp
imports
  "../lib/Sep_Algebra_Add"
  "../lib/Frame_Infer"
  "../lib/Monad"
  "HOL-Library.Extended_Nat" (* TODO: This gives us Complex_Main. Too much for this theory! *)
  "../basic/kernel/LLVM_Shallow" (* TODO: Just used for acostC datatype. Move this datatype! *)
  "../cost/Enat_Cost"
begin

  (* TODO: Move, to Sep_Lift *)
  text \<open>Lifting Assertions over Product\<close>
  definition FST :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b::zero \<Rightarrow> bool"
    where "FST P \<equiv> \<lambda>(a,b). P a \<and> b=0"

  definition SND :: "('b \<Rightarrow> bool) \<Rightarrow> 'a::zero \<times> 'b \<Rightarrow> bool"
    where "SND P \<equiv> \<lambda>(a,b). a=0 \<and> P b"

  lemma FST_project_frame: "(FST P \<and>* F) (a, b) \<longleftrightarrow> (P ** (\<lambda>a. F (a,b))) a"
    unfolding sep_conj_def
    by (force simp add: sep_algebra_simps FST_def)

  lemma SND_project_frame: "(SND P \<and>* F) (a, b) \<longleftrightarrow> (P ** (\<lambda>b. F (a,b))) b"
    unfolding sep_conj_def
    by (force simp add: sep_algebra_simps SND_def)

  lemma FST_conj_conv: "(FST P ** FST Q) = FST (P**Q)"
    unfolding sep_conj_def
    by (force simp add: sep_algebra_simps FST_def)

  lemma SND_conj_conv: "(SND P ** SND Q) = SND (P**Q)"
    unfolding sep_conj_def
    by (force simp add: sep_algebra_simps SND_def)

  lemma FST_apply[sep_algebra_simps]: "FST P (a,b) \<longleftrightarrow> P a \<and> b=0"
    unfolding FST_def by auto

  lemma SND_apply[sep_algebra_simps]: "SND P (a,b) \<longleftrightarrow> P b \<and> a=0"
    unfolding SND_def by auto

declare [[coercion_enabled = false]]
hide_const (open) Transcendental.pi

section \<open>General VCG Setup for Separation Logic\<close>

(* TODO: Move to Library *)

locale generic_wp_defs =
  fixes wp :: "'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
begin
  definition "htripleF \<alpha> F P c Q \<equiv> (\<forall>s. (P**F) (\<alpha> s) \<longrightarrow>
      wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s)"

  definition "htriple \<alpha> P c Q \<equiv> (\<forall>F s. (P**F) (\<alpha> s) \<longrightarrow>
      wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s)"

  lemma htriple_as_F_eq: "htriple \<alpha> P c Q = (\<forall>F. htripleF \<alpha> F P c Q)"
    unfolding htriple_def htripleF_def by blast

end

locale generic_wp = generic_wp_defs wp
  for wp :: "'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" +
  assumes wp_comm_inf: "inf (wp c Q) (wp c Q') = wp c (inf Q Q')"
begin

  lemma wp_comm_conj: "wp c (\<lambda>r. Q r and Q' r) s \<longleftrightarrow> wp c Q s \<and> wp c Q' s"
    using wp_comm_inf[of c Q Q']
    unfolding inf_fun_def inf_bool_def by metis

  lemma wp_comm_conjI: "\<lbrakk> wp c Q s; wp c Q' s \<rbrakk> \<Longrightarrow> wp c (\<lambda>r s. Q r s \<and> Q' r s) s"
    using wp_comm_inf[of c Q Q']
    unfolding inf_fun_def inf_bool_def by metis

  lemma wp_mono: "Q\<le>Q' \<Longrightarrow> wp c Q \<le> wp c Q'"
    by (metis (mono_tags) antisym_conv le_inf_iff order_refl wp_comm_inf)

  lemma wp_monoI:
    assumes "wp c Q s"
    assumes "\<And>r x. Q r x \<Longrightarrow> Q' r x"
    shows "wp c Q' s"
    using assms wp_mono[of Q Q' c] by auto

  lemma htripleI:
    assumes "\<And>F s. (P**F) (\<alpha> s) \<Longrightarrow> wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    shows "htriple \<alpha> P c Q"
    using assms by (auto simp: htriple_def)

  lemma htripleFI:
    assumes "\<And>s. (P**F) (\<alpha> s) \<Longrightarrow> wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    shows "htripleF \<alpha> F P c Q"
    using assms by (auto simp: htripleF_def)

  lemma htripleD:
    assumes "htriple \<alpha> P c Q"
    assumes "(P**F) (\<alpha> s)"
    shows "wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    using assms by (auto simp: htriple_def)

  lemma htriple_triv[simp, intro!]: "htriple \<alpha> sep_false c Q"
    by (auto simp: htriple_def)

  lemma frame_rule: "htriple \<alpha> P c Q \<Longrightarrow> htriple \<alpha> (P ** F) c (\<lambda>r. Q r ** F)"
    unfolding htriple_def
    by (fastforce)

  lemma cons_rule:
    assumes "htriple \<alpha> P c Q"
    assumes "\<And>s. P' s \<Longrightarrow> P s"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple \<alpha> P' c Q'"
    unfolding htriple_def
  proof clarsimp
    fix F s
    assume "(P' \<and>* F) (\<alpha> s)"
    with assms(2) have "(P \<and>* F) (\<alpha> s)"
      using sep_conj_impl1 by blast
    with assms(1) have "wp c (\<lambda>r s'. (Q r \<and>* F) (\<alpha> s')) s"
      unfolding htriple_def by auto
    thus "wp c (\<lambda>r s'. (Q' r \<and>* F) (\<alpha> s')) s"
      apply (rule wp_monoI)
      using assms(3)
      using sep_conj_impl1 by blast
  qed

  lemma cons_post_rule:
    assumes "htriple \<alpha> P c Q"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple \<alpha> P c Q'"
    using cons_rule assms by blast

  lemma htriple_alt:
    "htriple \<alpha> P c Q
      = (\<forall>p s f. p##f \<and> \<alpha> s = p + f \<and> P p \<longrightarrow> wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s)"
  proof (rule iffI, goal_cases)
    case 1
    show ?case
      using htripleD[OF 1, where F="EXACT x" for x]
        by (auto simp: sep_conj_def)

  next
    case 2
    show ?case proof (rule htripleI)
      fix F s
      assume "(P \<and>* F) (\<alpha> s)"
      then obtain p f where "p##f" "P p" "F f" "\<alpha> s = p+f"
        by (blast elim: sep_conjE)
      with 2 have "wp c (\<lambda>r s'. \<exists>p'. p' ## f \<and> \<alpha> s' = p' + f \<and> Q r p') s" by blast
      then show "wp c (\<lambda>r s'. (Q r \<and>* F) (\<alpha> s')) s"
        apply (rule wp_monoI)
        using \<open>F f\<close> by (auto intro: sep_conjI)
    qed
  qed

  lemma htripleI':
    assumes "\<And>p s f. \<lbrakk> p##f; \<alpha> s = p + f; P p\<rbrakk> \<Longrightarrow> wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s"
    shows "htriple \<alpha> P c Q"
    using assms by (auto simp: htriple_alt)

  lemma htripleD':
    assumes "htriple \<alpha> P c Q"
    assumes "p##f" "\<alpha> s = p + f" "P p"
    shows "wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s"
    using assms by (auto simp: htriple_alt)

  lemma htriple_extract_pre_pure:
    "htriple \<alpha> (\<up>\<Phi>**P) c Q \<longleftrightarrow> \<Phi> \<longrightarrow> htriple \<alpha> P c Q"
    by (cases \<Phi>) (auto simp: sep_algebra_simps)

  (*
  lemma htriple_extract_pre_EXS:
    assumes "\<And>x s. \<Phi> x \<Longrightarrow> P s \<Longrightarrow> f x ## s"
    shows "htriple \<alpha> (EXS x. \<up>\<Phi> x ** EXACT (f x) ** P) c Q \<longleftrightarrow> (\<exists>x. \<Phi> x \<and> htriple \<alpha> (EXACT (f x) ** P) c Q)"
    apply rule
  *)

  thm htripleD

  thm option.simps

  lemma sv_htripleD:
    assumes "htriple \<alpha> P c Q"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp c Q' s"
    using assms
    by (force simp: htriple_def intro: wp_monoI)

  lemma sv_htripleFD:
    assumes "htripleF \<alpha> F P c Q"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp c Q' s"
    using assms
    by (force simp: htripleF_def intro: wp_monoI)

  lemma htriple_conj_pure:
    fixes \<alpha>
    assumes "htriple \<alpha> P c Q"
    assumes "htriple \<alpha> P c (\<lambda>r. \<up>\<Phi> r ** sep_true)"
    shows "htriple \<alpha> P c (\<lambda>r. \<up>\<Phi> r ** Q r)"
  proof (rule htripleI)
    fix F s
    assume "(P**F) (\<alpha> s)"
    from wp_comm_conjI[OF assms[THEN htripleD,OF this]]
    show "wp c (\<lambda>r s'. ((\<up>\<Phi> r \<and>* Q r) \<and>* F) (\<alpha> s')) s"
      apply (rule wp_monoI)
      using and_pure_true unfolding entails_def by blast

  qed

  text \<open>With garbage collection\<close>
  abbreviation "htriple_gc GC \<alpha> P c Q \<equiv> htriple \<alpha> P c (\<lambda>r. Q r ** GC)"

  lemma htriple_to_gc: "\<lbrakk> \<box>\<turnstile>GC; htriple \<alpha> P c Q \<rbrakk> \<Longrightarrow> htriple_gc GC \<alpha> P c Q"
    apply (erule cons_rule)
    apply simp
    by (metis abel_semigroup.commute entails_def sep.mult.abel_semigroup_axioms sep_conj_empty sep_globalise)

end

experiment begin
  text \<open>Precondition defined by semantics relation:
    \<^item> \<open>T c s\<close> command terminates in state \<open>s\<close>
    \<^item> \<open>R c s r s'\<close> command yields result \<open>r\<close> and new state \<open>s'\<close>
  \<close>

  definition "my_wp T (R::_ \<Rightarrow> 's\<Rightarrow>_\<Rightarrow>'s\<Rightarrow>bool) c Q s \<equiv> T c s \<and> (\<forall>r s'. R c s r s' \<longrightarrow> Q r s')"

  interpretation generic_wp "my_wp T R"
    apply unfold_locales
    unfolding my_wp_def
    by auto

end

definition STATE :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where "STATE \<alpha> P s \<equiv> P (\<alpha> s)"

lemma STATE_assn_cong[fri_extract_congs]: "P\<equiv>P' \<Longrightarrow> STATE \<alpha> P s \<equiv> STATE \<alpha> P' s" by simp

lemma STATE_extract[vcg_normalize_simps]:
  "STATE \<alpha> (\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> \<box> h"
  "STATE \<alpha> (\<up>\<Phi> ** P) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> P h"
  "STATE \<alpha> (EXS x. Q x) h \<longleftrightarrow> (\<exists>x. STATE \<alpha> (Q x) h)"
  "STATE \<alpha> (\<lambda>_. False) h \<longleftrightarrow> False"
  "STATE \<alpha> ((\<lambda>_. False) ** P) h \<longleftrightarrow> False"
  by (auto simp: STATE_def sep_algebra_simps pred_lift_extract_simps)

definition POSTCOND :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where [vcg_tag_defs]: "POSTCOND \<alpha> \<equiv> STATE \<alpha>"

lemma POSTCONDI:
  "STATE \<alpha> A h \<Longrightarrow> POSTCOND \<alpha> A h"
  by (auto simp add: POSTCOND_def)
lemma POSTCOND_cong[vcg_normalize_congs]: "POSTCOND \<alpha> A = POSTCOND \<alpha> A" ..

lemma POSTCOND_triv_simps[vcg_normalize_simps]:
  "POSTCOND \<alpha> sep_true h"
  "\<not>POSTCOND \<alpha> sep_false h"
  unfolding POSTCOND_def STATE_def by auto

lemma start_entailsE:
  assumes "STATE \<alpha> P h"
  assumes "ENTAILS P P'"
  shows "STATE \<alpha> P' h"
  using assms unfolding STATE_def ENTAILS_def entails_def
  by auto

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms POSTCONDI},@{binding postcond_xformer},
    fn ctxt => eresolve_tac ctxt @{thms start_entailsE}
  ))
\<close>

named_theorems htriple_vcg_intros
named_theorems htriple_vcg_intro_congs
definition [vcg_tag_defs]: "DECOMP_HTRIPLE \<phi> \<equiv> \<phi>"
lemma DECOMP_HTRIPLEI: "\<phi> \<Longrightarrow> DECOMP_HTRIPLE \<phi>" unfolding vcg_tag_defs by simp

context generic_wp begin
  thm frame_rule
  thm cons_rule

  lemma htriple_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htriple \<alpha> P c Q"
    assumes P: "\<And>r s. STATE \<alpha> (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp c Q' s"
  proof -
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleD[OF HT])

  qed

  lemma htripleF_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htripleF \<alpha> F P c Q"
    assumes P: "\<And>r s. STATE \<alpha> (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp c Q' s"
  proof -
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleFD[OF HT])

  qed

  lemma htriple_vcgI':
    assumes "\<And>F s. STATE \<alpha> (P**F) s \<Longrightarrow> wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s"
    shows "htriple \<alpha> P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htriple_vcgI[htriple_vcg_intros]:
    assumes "\<And>F s. STATE \<alpha> (P**F) s \<Longrightarrow> EXTRACT (wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s)"
    shows "htriple \<alpha> P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htripleF_vcgI[htriple_vcg_intros]:
    assumes "\<And>s. STATE \<alpha> (P**F) s \<Longrightarrow> EXTRACT (wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s)"
    shows "htripleF \<alpha> F P c Q"
    apply (rule htripleFI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htriple_decompI[vcg_decomp_rules]:
    "DECOMP_HTRIPLE (htriple \<alpha> P c Q) \<Longrightarrow> htriple \<alpha> P c Q"
    "DECOMP_HTRIPLE (htripleF \<alpha> F P c Q) \<Longrightarrow> htripleF \<alpha> F P c Q"
    unfolding vcg_tag_defs by auto

  lemma htriple_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htriple \<alpha> P c Q \<equiv> htriple \<alpha> P' c Q'" by simp

  lemma htripleF_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htripleF \<alpha> F P c Q \<equiv> htripleF \<alpha> F P' c Q'" by simp

  lemma htriple_ent_pre:
    "P\<turnstile>P' \<Longrightarrow> htriple \<alpha> P' c Q \<Longrightarrow> htriple \<alpha> P c Q"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_ent_post:
    "\<lbrakk>\<And>r. Q r \<turnstile> Q' r\<rbrakk> \<Longrightarrow> htriple \<alpha> P c Q \<Longrightarrow> htriple \<alpha> P c Q'"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_pure_preI: "\<lbrakk>pure_part P \<Longrightarrow> htriple \<alpha> P c Q\<rbrakk> \<Longrightarrow> htriple \<alpha> P c Q"
    by (meson htriple_def pure_partI sep_conjE)

end

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms DECOMP_HTRIPLEI},@{binding decomp_htriple_xformer},
    fn ctxt =>
      (full_simp_tac (put_simpset HOL_basic_ss ctxt
        addsimps (Named_Theorems.get ctxt @{named_theorems vcg_tag_defs})
        |> fold Simplifier.add_cong (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intro_congs})
      ))
      THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intros})
  ))
\<close>

section \<open>a General framework for abstract and concrete costs\<close>

text \<open>This locale fixes a type of concrete costs \<open>'cc\<close> which is used in \<open>mres\<close> and a type for
      abstract costs \<open>'ca\<close> which should be used in the separation logic with (resource) credits.
      There is some invariant that has to hold between the credits currently available "on the heap"
      and the resources spent in the computation, \<open>I\<close> captures that.
      Also it needs to be possible to deduct the resources used by the computation from the credits,
      this is captured by \<open>minus\<close>.
      \<close>

locale cost_framework =
  fixes
    I :: "'cc::{monoid_add} \<Rightarrow> 'ca \<Rightarrow> bool"
  and minus :: "'ca \<Rightarrow> 'cc \<Rightarrow> 'ca" \<comment> \<open>takes abstract credits, and returns the effect of consuming
                                        the concrete resources\<close>
assumes minus_0[simp]: "\<And>y. minus y 0 = y"
  and I_0[simp,intro!]: "I 0 cr"
  and minus_minus_add: "\<And>a b c. minus (minus a b) c = minus a (b + c)"
  \<comment> \<open>TODO: maybe some of these are redundant\<close>
  and I1: "\<And>a b c. I (a + b) c \<Longrightarrow> I b (minus c a)"
  and I2: "\<And>a b c. I (a + b) c \<Longrightarrow> I a c"
  and I3:  "\<And>a b c. I a (minus c b) \<Longrightarrow> I b c \<Longrightarrow> I (b + a) c"
begin

  definition  wp :: "('d, 'e, _, 'a, 'f) M \<Rightarrow> _ \<Rightarrow> _" where
    "wp m Q \<equiv> \<lambda>(s,cr). mwp (run m s) bot bot bot (\<lambda>r c s. Q r (s,minus cr c) \<and> I c cr)"

(*
  term "\<alpha> x \<le> y \<longleftrightarrow> x \<le> \<gamma> y"
*)

  interpretation generic_wp wp
    apply unfold_locales
    unfolding wp_def fun_eq_iff inf_fun_def inf_bool_def mwp_def
    by (auto split: mres.split)

  lemma wp_return: "wp (return x) Q s \<longleftrightarrow> Q x s"
    by (auto simp: wp_def run_simps minus_0 I_0)

  lemma wp_fail: "\<not> wp (fail x) Q s"
    by (auto simp: wp_def run_simps)

  lemma wp_fcheck: "wp (fcheck e \<Phi>) Q s \<longleftrightarrow> \<Phi> \<and> Q () s"
    by (auto simp: wp_def run_simps minus_0 I_0 split: if_splits)

  (* TODO: refactor that proof, should not need to unfold mwp_def at that stage *)
  lemma wp_bind: "wp (m\<bind>f) Q s = wp m (\<lambda>x. wp (f x) Q) s"
    apply (auto simp: wp_def run_simps split: prod.splits)
    unfolding mwp_def apply (auto split: mres.splits simp add: minus_minus_add)
    subgoal
      by (metis I1)
    subgoal
      by (metis I2)
    subgoal
      by (metis I3)
    done

  lemma wp_consume: "wp (consume c) Q (s,cr) \<longleftrightarrow> I c cr \<and> Q () (s,minus cr c)"
    unfolding wp_def mwp_def consume_def by (auto split: mres.split)

end

interpretation nat: cost_framework "\<lambda>(c::nat) (cr::nat). cr-c+c=cr" "(-)"
  apply standard
  by auto

interpretation int: cost_framework "\<lambda>(c::int) (cr::int). True" "(-)"
  apply standard
  by auto

locale cost_framework2 = cost_framework I minus for I :: "'cc::{monoid_add} \<Rightarrow> 'ca::{plus} \<Rightarrow> bool" and minus +
  assumes I_left_mono: "\<And>x c d. I x c \<Longrightarrow> I x (c+d)" \<comment> \<open>@{thm ordered_comm_monoid_add_class.add_increasing2}\<close>
  assumes minus_add_assoc2: "\<And>x c d. I x c \<Longrightarrow> minus (c + d) x = minus c x + d" \<comment> \<open>@{thm ordered_cancel_comm_monoid_diff_class.diff_add_assoc2}\<close>
begin

end

locale cost_framework3 = cost_framework2 I minus for I :: "'cc::{monoid_add} \<Rightarrow> 'ca::{plus} \<Rightarrow> bool" and minus +
  fixes lift :: "'cc \<Rightarrow> 'ca"
  assumes I_add1: "\<And>c cr. I c (lift c + cr)" \<comment> \<open>@{thm le_add1}\<close>
  assumes add_minus_cancel: "\<And>c cr. minus (lift c + cr) c = cr" \<comment> \<open>@{thm Extended_Nat.add_diff_cancel_enat}\<close>
begin

end

term acostC

context cost_framework begin

abbreviation "I_fun \<equiv> (\<lambda>cc ca. \<forall>x. I (the_acost cc x) (the_acost ca x))"
abbreviation "minus_fun \<equiv> (\<lambda>ca cc. acostC (\<lambda>x. minus (the_acost ca x) (the_acost cc x)))"

  lemma fun_cost_framework: "cost_framework I_fun minus_fun"
    apply unfold_locales
    apply (simp_all add: zero_acost_def I_0 minus_0 minus_minus_add fun_eq_iff)
    subgoal for a b c by (cases a;cases b;cases c; auto)
    subgoal for a b c by (cases a;cases b;cases c; auto simp: I1)
    subgoal for a b c by (cases a;cases b;cases c; auto intro: I2)
    subgoal for a b c by (cases a;cases b;cases c; auto simp: I3)
    done
end

context cost_framework3
begin

lemma fun_cost_framework2: "cost_framework2 I_fun minus_fun"
  unfolding cost_framework2_def
  apply safe apply (fact fun_cost_framework)
  apply unfold_locales
  subgoal for x c d by(cases x; cases c; cases d) (auto intro: I_left_mono)
  subgoal for x c d by(cases x; cases c; cases d) (auto intro: minus_add_assoc2)
  done

abbreviation "lift_fun \<equiv> (\<lambda>cc. acostC (\<lambda>x. lift (the_acost cc x)))"

lemma fun_cost_framework3: "cost_framework3 I_fun minus_fun lift_fun"
  unfolding cost_framework3_def
  apply safe apply (fact fun_cost_framework2)
  apply unfold_locales
  subgoal for c cr by(cases c; cases cr) (auto intro: I_add1)
  subgoal for c cr by(cases c; cases cr) (auto intro: add_minus_cancel)
  done

end

section \<open>Setup for mres-Monad\<close>

  lemma "cr-c+c=(cr::nat) \<longleftrightarrow> cr\<ge>c" by auto
  lemma "cr-c+c=(cr::int) \<longleftrightarrow> True" by auto

  lemma enat_diff_diff: "a - enat b - enat c = a - enat (b + c)"
    apply(cases a) by auto
  lemma enat_aux1: "c - enat (a + b) + enat (a + b) = c \<Longrightarrow> c - enat a + enat a = c"
    apply(cases c) by auto

  definition le_cost_ecost :: "cost \<Rightarrow> ecost \<Rightarrow> bool"
    where "le_cost_ecost cc ca \<equiv> \<forall>x. enat (the_acost cc x) \<le> (the_acost ca x)"

  definition minus_ecost_cost :: "ecost \<Rightarrow> cost \<Rightarrow> ecost"
    where "minus_ecost_cost ca cc \<equiv> acostC (\<lambda>x. (the_acost ca x) - enat (the_acost cc x))"

  interpretation cost_framework le_cost_ecost minus_ecost_cost
    unfolding le_cost_ecost_def minus_ecost_cost_def
    apply (rule cost_framework.fun_cost_framework)
    apply standard
    apply (auto simp flip: zero_enat_def)
    subgoal by (metis enat_diff_diff)
    subgoal
      by (smt add.commute add_diff_cancel_enat add_right_mono enat.distinct(1) enat_aux1 eq_iff le_iff_add linear of_nat_add of_nat_eq_enat)
    subgoal
      by (meson enat_ord_simps(1) le_add1 order_subst2)
    subgoal
      by (metis add_diff_cancel_enat add_left_mono enat.simps(3) le_iff_add plus_enat_simps(1))
    done

  (*
  term pi
  interpretation cost_framework "\<lambda>(c::nat) (cr::enat). cr-c+c=cr" "(-)"
    apply standard
         apply (auto simp: zero_enat_def)
    subgoal
      by (metis enat_diff_diff)
    subgoal
      by (metis enat_diff_diff add_diff_assoc_enat add_diff_cancel_left' enat_ord_simps(1)
                idiff_enat_enat le_add_same_cancel1 zero_le)
    subgoal
      by (metis enat_aux1)
    subgoal
      by (metis enat_diff_diff add.assoc add.commute plus_enat_simps(1))
    done
  *)

  (*
  lemma enat_nat_I_conv: "cr - enat c + enat c = cr \<longleftrightarrow> cr \<ge> c"
    by (cases cr; cases c; auto)
  *)

  (* Definition for presentation *)
  lemma natenat_alt: "wp m Q = (\<lambda>(s, cr). mwp (run m s) bot bot bot (\<lambda>r c s. Q r (s, minus_ecost_cost cr c) \<and> le_cost_ecost c cr))" unfolding wp_def ..

  (* Definition for presentation in paper *)
  lemma wp_alt: "wp m Q (s,cr::ecost) = (\<exists>r (c::cost) s'. run m s = SUCC r c s' \<and> Q r (s', minus_ecost_cost cr c) \<and> le_cost_ecost c cr )"
    unfolding wp_def mwp_def by (fastforce split: mres.splits)

  interpretation generic_wp wp
    apply unfold_locales
    unfolding wp_def fun_eq_iff inf_fun_def inf_bool_def mwp_def
    by (auto split: mres.split)

  declare wp_return[vcg_normalize_simps]

  declare wp_fail[vcg_normalize_simps]

  declare wp_fcheck[vcg_normalize_simps]

  declare wp_bind[vcg_normalize_simps]

  thm vcg_normalize_simps

  (* TODO: Move *)
  instantiation enat :: stronger_sep_algebra begin
    definition "(_::enat) ## _ \<equiv> True"

    instance
      apply standard
      apply (simp_all add: sep_disj_enat_def)
      done

  end

  instantiation acost :: (type,stronger_sep_algebra) stronger_sep_algebra begin
    definition "f1 ## f2 \<longleftrightarrow> (\<forall>x. the_acost f1 x ## the_acost f2 x)"
    (*definition [simp]: "(f1 + f2) = acostC (\<lambda>x. the_acost f1 x + the_acost f2 x)"
    definition [simp]: "0 x \<equiv> 0"
    *)

    instance
      apply standard
      unfolding sep_disj_acost_def plus_acost_alt zero_acost_def
      apply (auto simp: sep_algebra_simps split: acost.splits)
      done

  end

definition time_credits_assn :: "ecost \<Rightarrow> (_ \<times> ecost \<Rightarrow> bool)" ("$_" [900] 900) where "($c) \<equiv> SND (EXACT c)"

term "a ** $c"
term "c ** $a"

definition "GC \<equiv> SND sep_true"

lemma GC_absorb[simp]: "(GC ** GC) = GC" by (auto simp: GC_def sep_algebra_simps SND_conj_conv)

lemma entails_GC: "$c \<turnstile> GC" unfolding GC_def time_credits_assn_def
  by (auto simp: entails_def SND_def) (* TODO: Monotonicity of FST,SND as lemmas? *)

lemma "$0 = \<box>" oops

lemma empty_ent_GC: "\<box>\<turnstile>GC" unfolding GC_def time_credits_assn_def
  by (auto simp: entails_def SND_def sep_algebra_simps)

lemma dollar_aux_conv: "($c) (aa, ba) = (aa=0 \<and> ba=c)"
  unfolding time_credits_assn_def EXACT_def SND_def
  by auto

lemma "F \<turnstile> GC ** G \<Longrightarrow> $c ** F \<turnstile> GC ** G"
  by (metis (no_types, lifting) GC_absorb conj_entails_mono entails_GC sep_conj_assoc)

lemma htriple_to_GC: "\<lbrakk> htriple \<alpha> P c Q \<rbrakk> \<Longrightarrow> htriple_gc GC \<alpha> P c Q"
  using htriple_to_gc[OF empty_ent_GC] .

lemma time_credits_add: "($A ** $B) = $(A+B)"
  by (simp add: EXACT_split SND_conj_conv sep_disj_acost_def sep_disj_enat_def time_credits_assn_def)

(* For presentation *)
lemma "($c) (s,c') \<longleftrightarrow> s=0 \<and> c'=c"
  unfolding time_credits_assn_def by (simp add: sep_algebra_simps SND_def) (* TODO: Lemmas for SND! *)

lemma "($c) a \<longleftrightarrow> a=(0,c)"
  unfolding time_credits_assn_def by (cases a) (simp add: sep_algebra_simps SND_def)

definition "lift_\<alpha>_cost \<alpha> \<equiv> \<lambda>(s,c). (\<alpha> s,c)"

lemma cost_ecost_minus_add_assoc2: "le_cost_ecost x c \<Longrightarrow> minus_ecost_cost (c + d) x = minus_ecost_cost c x + d"
  apply(cases x; cases c; cases d) apply(auto simp: minus_ecost_cost_def le_cost_ecost_def)
  by (simp add: add.commute add_diff_assoc_enat)

lemma cost_ecost_add_increasing2: "le_cost_ecost x c \<Longrightarrow> le_cost_ecost x (c + d)"
  apply(cases x; cases c; cases d) apply (auto simp:   le_cost_ecost_def)
  by (simp add:  add_increasing2)

lemma cost_ecost_add1: "le_cost_ecost c (lift_acost c + cr')"
  apply(cases cr') by (auto simp: le_cost_ecost_def lift_acost_def )

lemma cost_ecost_add_minus_cancel: "minus_ecost_cost (lift_acost c + cr') c = cr'"
  apply(cases cr') by (auto simp: minus_ecost_cost_def lift_acost_def )

lemma consume_rule_aux: "htriple (lift_\<alpha>_cost \<alpha>) ($(lift_acost c)) (consume c) (\<lambda>_. \<box>)"
  apply (rule htripleI)
  apply clarify
  apply (simp add: wp_consume time_credits_assn_def lift_\<alpha>_cost_def)
proof (rule conjI)
  fix F s cr
  assume "(SND (EXACT (lift_acost c)) \<and>* F) ((\<alpha> s, cr))"
  from this have "(EXACT (lift_acost c) \<and>* (\<lambda>b. F (\<alpha> s, b))) cr" by (simp add: SND_project_frame)
  then obtain cr' where [simp]: "lift_acost c ## cr'" "cr = lift_acost c + cr'" and F: "F (\<alpha> s, cr')"
    by (rule sep_conjE) (simp add: sep_algebra_simps)
  have "0 \<preceq> cr'"
    by (simp add: sep_substate_def)
  show "le_cost_ecost c cr" by (simp add: cost_ecost_add1)

  show "F (\<alpha> s, minus_ecost_cost cr c)" using F by (simp add: cost_ecost_add_minus_cancel)
qed

lemmas consume_rule = htriple_to_GC[OF consume_rule_aux]

section \<open>experiment: Hoare-triple without Time\<close>

  text \<open>Weakest precondition without time\<close>
  definition "wpn m Q s \<equiv> mwp (run m s) bot bot bot (\<lambda>r c s'. c=0 \<and> Q r s')"

  lemma wpn_def': "wpn m Q s = (\<exists>r s'. run m s = SUCC r 0 s' \<and> Q r s')"
    unfolding wpn_def mwp_def
    by (auto split: mres.split)

  (* TODO: Move *)
  lemma le_cost_zero_conv[simp]: "le_cost_ecost c 0 \<longleftrightarrow> c=0"
    unfolding le_cost_ecost_def by (cases c; auto simp: zero_acost_def zero_enat_def)

  lemma wpn_alt: "wpn m Q s = wp m (FST o Q) (s,0)"
    unfolding wp_def wpn_def mwp_def
    by (auto split: mres.split simp: zero_enat_def FST_def)

  lemma wpn_alt': "wpn m Q s = wp m (\<lambda>r (s,c). Q r s \<and> c=0) (s,0)"
    unfolding wp_def wpn_def mwp_def
    by (auto split: mres.split simp: zero_enat_def FST_def)

  interpretation notime: generic_wp wpn
    apply unfold_locales
    unfolding wpn_def fun_eq_iff inf_fun_def inf_bool_def mwp_def
    by (auto split: mres.split)

  lemma wpn_return[vcg_normalize_simps]: "wpn (return x) Q s \<longleftrightarrow> Q x s"
    by (auto simp: wpn_def run_simps)

  lemma wpn_fail[vcg_normalize_simps]: "\<not> wpn (fail x) Q s"
    by (auto simp: wpn_def run_simps)

  lemma wpn_fcheck[vcg_normalize_simps]: "wpn (fcheck e \<Phi>) Q s \<longleftrightarrow> \<Phi> \<and> Q () s"
    by (auto simp: wpn_def run_simps split: if_splits)

  (* TODO: refactor that proof, should not need to unfold mwp_def at that stage *)
  (* TODO: Intuitively, want equality here: BUT, equality only holds if costs cannot be negative! *)
  lemma wpn_bind[vcg_decomp_rules]: "wpn m (\<lambda>x. wpn (f x) Q) s \<Longrightarrow> wpn (m\<bind>f) Q s"
    apply (auto simp: wpn_def[abs_def] run_simps split: prod.splits)
    unfolding mwp_def
    by (auto
      split: mres.splits
      simp add: minus_minus_add dest!: addcost_SUCC_D)

  (*
  lemma wpn_bind: "wpn (m\<bind>f) Q s = wpn m (\<lambda>x. wpn (f x) Q) s"
    apply (auto simp: wpn_def run_simps split: prod.splits)
    unfolding mwp_def
    apply (auto
      split: mres.splits
      simp add: minus_minus_add dest!: addcost_SUCC_D)
    xxx. ctd here: need positive costs,
      otherwise negatove+positive can cancel out.

  *)

  lemma notime_return_rule: "notime.htriple \<alpha> P (return x) (\<lambda>r. \<up>(r=x)**P)" for \<alpha>
    by vcg

  text \<open>Transfer of Hoare-Triples\<close>

  (* TODO: Move *)
  lemma wp_time_mono: "wp m Q (s,c) \<Longrightarrow> wp m (\<lambda>r (s',c'). \<exists>cc'. c'=cc'+d \<and> Q r (s',cc')) (s,c+d)"
    unfolding wp_def mwp_def
    apply (auto simp add: algebra_simps sep_algebra_simps SND_def sep_conj_def split: mres.split)
    subgoal by (intro exI conjI; assumption?) (rule cost_ecost_minus_add_assoc2)
    subgoal by (rule cost_ecost_add_increasing2)
    done

  lemma notime_to_htriple:
    fixes c :: "('a, 'b, cost, 'd, 'e) M"
    assumes H: "notime.htriple \<alpha> P c Q"
    shows "htriple (lift_\<alpha>_cost \<alpha>) (FST P) c (FST o Q)"
    unfolding lift_\<alpha>_cost_def
    apply (rule htripleI)
    apply clarify
  proof -
    fix F a and b :: ecost
    assume "(FST P \<and>* F) (\<alpha> a, b)"
    hence "(P ** (\<lambda>a. F (a,b))) (\<alpha> a)"
      by (simp add: sep_algebra_simps FST_project_frame)
    from notime.htripleD[OF H this] have "wpn c (\<lambda>r s'. (Q r \<and>* (\<lambda>a. F (a, b))) (\<alpha> s')) a" .
    then have "wp c (\<lambda>x (a, ba). (Q x \<and>* (\<lambda>a. F (a, b))) (\<alpha> a) \<and> ba = 0) (a, 0)"
      unfolding wpn_alt FST_def comp_def by simp
    from wp_time_mono[OF this, of b] have "wp c (\<lambda>r (s', c'). c' = b \<and> (Q r \<and>* (\<lambda>a. F (a, b))) (\<alpha> s')) (a, b)"
      by simp
    then show "wp c (\<lambda>r s'. ((FST \<circ> Q) r \<and>* F) (case s' of (s, x) \<Rightarrow> (\<alpha> s, x))) (a, b)"
      apply (rule wp_monoI)
      apply (auto simp: FST_project_frame)
      done
  qed

  lemma htriple_to_notime:
    assumes H: "htriple (lift_\<alpha>_cost \<alpha>) (FST P) c (FST o Q)"
    shows "notime.htriple \<alpha> P c Q"
    apply (rule notime.htripleI)
    unfolding wpn_alt
  proof -
    fix F s
    assume A: "(P \<and>* F) (\<alpha> s)"

    show "wp c (FST \<circ> (\<lambda>r s'. (Q r \<and>* F) (\<alpha> s'))) (s, 0)"
      apply (rule wp_monoI)
      apply (rule htripleD[OF H, where F="FST F"])
      unfolding lift_\<alpha>_cost_def
      apply (auto simp: FST_conj_conv sep_algebra_simps A)
      done
  qed

  lemma notime_htriple_eq: "notime.htriple \<alpha> P c Q = htriple (lift_\<alpha>_cost \<alpha>) (FST P) c (FST o Q)"
    by (blast intro: notime_to_htriple htriple_to_notime)

  definition "wlp c Q s \<equiv> mwp (run c s) top top top (\<lambda>r c s. Q r s)"
  lemma wlp_true[simp, intro!]:
    "wlp c (\<lambda>_ _. True) s"
    "wlp c top s"
    by (auto simp: wlp_def mwp_def split: mres.splits)

  lemma wlp_return[simp]: "wlp (return x) Q s = Q x s"
    by (auto simp: wlp_def run_simps)

section \<open>experiment: cost type for Space\<close>

datatype space_cost = Space_Cost (sca: nat) (scb: nat) (* highest point,  how far below that mark at the moment *)

(*

  mm_alloc n \<Longrightarrow> \<lambda>(m,c). (max m (c+n),c+n)
  mm_free n \<Longrightarrow> \<lambda>(m,c). assert(n\<le>c), (m,c-n)

*)

fun max_cost where "max_cost (Space_Cost h _) = h"
fun curr_cost where "curr_cost (Space_Cost h c) = int h - int c"

definition "new_h m1 c1 m2 c2 \<equiv> (max (int m1) (((int m1 - int c1)+int m2)))"
definition "new_c m1 c1 m2 c2 \<equiv> (new_h m1 c1 m2 c2 - ((int m1 - int c1)+(int m2 - int c2)))"

lemma new_h_nonneg: "new_h m1 c1 m2 c2 \<ge> 0"
  by (auto simp: new_h_def)

lemma new_c_nonneg: "new_c m1 c1 m2 c2 \<ge> 0"
  by (auto simp: new_c_def new_h_def)

instantiation space_cost :: plus
begin
  lemma fixes m1 c1 m2 c2 :: nat
    shows "(max (int m1) (((int m1 - int c1)+int m2))) - ((int m1 - int c1)+(int m2 - int c2)) \<ge> 0"
    by auto

lemma "new_h m1 c1 m2 c2 - ((int m1 - int c1)+(int m2 - int c2)) \<ge> 0"
  by (auto simp: new_h_def)

  fun plus_space_cost :: "space_cost \<Rightarrow> space_cost \<Rightarrow> space_cost" where
    "plus_space_cost (Space_Cost m1 c1) (Space_Cost m2 c2) =
             Space_Cost (nat (new_h m1 c1 m2 c2)) (nat (new_c m1 c1 m2 c2))"

  instance ..
end

instantiation space_cost :: monoid_add
begin
  definition zero_space_cost :: space_cost where "zero_space_cost = Space_Cost 0 0"

  instance
    apply standard
    subgoal for a b c
      apply(cases a; cases b; cases c)
      apply (simp add: new_h_nonneg new_c_nonneg) apply safe
      subgoal for m1 c1 m2 c2 m3 c3
        apply(subst (2) new_h_def)
        apply(simp add: new_c_nonneg  new_h_nonneg)
        apply(subst (4) new_h_def)
        apply(simp add: new_c_nonneg  new_h_nonneg)
        by (auto simp: new_h_def new_c_def max.assoc)
      subgoal for m1 c1 m2 c2 m3 c3
        apply(subst (3) new_c_def)
        apply(simp add: new_c_nonneg  new_h_nonneg)
        apply(subst (3) new_c_def)
        apply(subst (3) new_h_def)
        apply(simp add: new_c_nonneg  new_h_nonneg)
        apply(subst (2) new_c_def)
        apply(simp add: new_c_nonneg  new_h_nonneg)
        by (auto simp: new_h_def new_c_def max.assoc)
      done
    subgoal for a apply(cases a)
      subgoal for m c
        by (auto simp: new_h_def new_c_def zero_space_cost_def)
      done
    subgoal for a apply(cases a)
      subgoal for m c
        by (auto simp: new_h_def new_c_def zero_space_cost_def)
      done
    done
end

text \<open>the Invariant denotes, that maximum space \<open>m\<close> is at most the number of space_credits \<open>n\<close>\<close>

fun space_I :: "space_cost \<Rightarrow> nat \<Rightarrow> bool"  where
  "space_I (Space_Cost m c) n \<longleftrightarrow> m\<le>n"

fun space_minus :: "nat \<Rightarrow> space_cost \<Rightarrow> nat"  where
  "space_minus  n (Space_Cost m c) = n - m + c"
\<comment> \<open>if space_I holds, this is n - (m-c), i.e. credits minus newly occupied space\<close>

interpretation space: cost_framework "space_I" "space_minus"
  apply standard
  subgoal for a by(simp add: zero_space_cost_def)
  subgoal for cr apply (simp add: zero_space_cost_def) done
  subgoal for a b c apply(cases b; cases c) by (simp add: new_c_def new_h_def)
  subgoal for a b c apply(cases a; cases b) by (simp add: new_c_def new_h_def)
  subgoal for a b c apply(cases a; cases b) by (simp add: new_c_def new_h_def)
  subgoal for a b c apply(cases a; cases b) by (simp add: new_c_def new_h_def)
  done

lemma space_minus_aux: "space_I b 0 \<Longrightarrow> Space_Cost 0 (space_minus 0 b) = b"
  apply(cases b) by simp

text \<open>The test \<open>sm\<le>cr\<close> makes sure that the maximum of space \<open>sm\<close> used does not exceed
      the allowed space by the "space-credits" cr.
      When before executing \<open>m\<close> there are \<open>cr\<close> credits, after the execution there will be
      \<open>cr - (sm-c)\<close>, i.e. the credits before minus the number of consumed space,
      see @{const curr_cost}.\<close>

lemma "space.wp m Q (s,cr) = (\<exists>r sm c s'. run m s = SUCC r (Space_Cost sm c) s'
                                   \<and> Q r (s', cr - sm + c) \<and> sm\<le>cr )"
    unfolding space.wp_def  mwp_def
    apply (auto split: mres.splits)
    subgoal for a b c apply(cases b)
      by simp
    done

(* TODO: again clash with type class lifting with prod for sep_algebra!
instantiation prod :: (monoid_add,monoid_add) monoid_add
begin

end

lemma
  assumes "cost_framework I1 minus1"
    and "cost_framework I2 minus2"
  shows "cost_framework (\<lambda>(a,b) (c,d). I1 a c \<and> I2 b d) (\<lambda>(a,b) (c,d). (minus1 a c, minus2 b d))"
*)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory SimpStrategy
imports Main
begin

text \<open>
Support for defining alternative simplifier strategies for some parts of terms
or some premises of rewrite rules. The "name" parameter to the simp_strategy
constant is used to identify which simplification strategy should be used on
this term. Note that, although names have type nat, it is safe for them to all
be defined as 0. The important thing is that the simplifier doesn't know they're
equal.
\<close>

definition
  simp_strategy :: "nat \<Rightarrow> ('a :: {}) \<Rightarrow> 'a"
where
  "simp_strategy name x \<equiv> x"

text \<open>
This congruence rule forbids the simplifier from simplifying the arguments of
simp_strategy normally.
\<close>

lemma simp_strategy_cong[cong]:
  "simp_strategy name x = simp_strategy name x"
  by simp

text \<open>
This strategy, or rather lack thereof, can be used to forbid simplification.
\<close>

definition
  NoSimp :: nat
where "NoSimp = 0"

text \<open>
This strategy indicates that a boolean subterm should be simplified only by
using explicit assumptions of the simpset.
\<close>

definition
  ByAssum :: nat
where "ByAssum = 0"

lemma Eq_TrueI_ByAssum:
  "P \<Longrightarrow> simp_strategy ByAssum P \<equiv> True"
  by (simp add: simp_strategy_def)

simproc_setup simp_strategy_ByAssum ("simp_strategy ByAssum b") =
  \<open>K (fn ss => fn ct => let
      val b = Thm.dest_arg ct
      val t = Thm.instantiate ([],[((("P",0),@{typ bool}), b)])
        @{thm Eq_TrueI_ByAssum}
      val prems = Raw_Simplifier.prems_of ss
    in get_first (try (fn p => p RS t)) prems end)\<close>

lemma ByAssum:
  "simp_strategy ByAssum P \<Longrightarrow> P"
  by (simp add: simp_strategy_def)

lemma simp_ByAssum_test:
  "P \<Longrightarrow> simp_strategy ByAssum P"
  by simp

text \<open>
Generic framework for instantiating a simproc which simplifies within a
simp_strategy with a given simpset.

The boolean determines whether simp_strategy Name True should be rewritten
to True.
\<close>

lemma simp_strategy_Eq_True:
  "simp_strategy name True \<equiv> True"
  by (simp add: simp_strategy_def)

ML \<open>
fun simp_strategy_True_conv ct = case Thm.term_of ct of
    (Const (@{const_name simp_strategy}, _) $ _ $ @{term True})
      => Thm.instantiate ([], [((("name",0), @{typ nat}), Thm.dest_arg1 ct)])
          @{thm simp_strategy_Eq_True}
  | _ => Conv.all_conv ct

fun new_simp_strategy thy (name : term) ss rewr_True =
let
  val ctxt = Proof_Context.init_global thy;
  val ss = Simplifier.make_simproc ctxt ("simp_strategy_" ^ fst (dest_Const name))
    {lhss = [@{term simp_strategy} $ name $ @{term x}],
     proc = (fn _ => fn ctxt' => fn ct =>
        ct
        |> (Conv.arg_conv (Simplifier.rewrite (put_simpset ss ctxt'))
          then_conv (if rewr_True then simp_strategy_True_conv
                      else Conv.all_conv))
        |> (fn c => if Thm.is_reflexive c then NONE else SOME c))
     }
in
  ss
end
\<close>

end