(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>Par\<close>\<close>
theory CZH_ECAT_Par
  imports
    CZH_Foundations.CZH_SMC_Par
    CZH_ECAT_Rel
    CZH_ECAT_Subcategory
begin

subsection\<open>Background\<close>

text\<open>
The methodology chosen for the exposition of \<open>Par\<close> as a category is
analogous to the one used in \<^cite>\<open>"milehins_category_2021"\<close>
for the exposition of \<open>Par\<close> as a semicategory.
\<close>

named_theorems cat_Par_cs_simps
named_theorems cat_Par_cs_intros

lemmas (in arr_Par) [cat_Par_cs_simps] =
  dg_Rel_shared_cs_simps

lemmas (in arr_Par) [cat_cs_intros, cat_Par_cs_intros] =
  arr_Par_axioms'

lemmas [cat_Par_cs_simps] =
  dg_Rel_shared_cs_simps
  arr_Par.arr_Par_length
  arr_Par_comp_Par_id_Par_left
  arr_Par_comp_Par_id_Par_right

lemmas [cat_Par_cs_intros] =
  arr_Par_comp_Par

subsection\<open>\<open>Par\<close> as a category\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition cat_Par :: "V \<Rightarrow> V"
  where "cat_Par \<alpha> =
    [
      Vset \<alpha>,
      set {T. arr_Par \<alpha> T},
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>),
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>),
      (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Par \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>R\<^sub>e\<^sub>l ST\<lparr>1\<^sub>\<nat>\<rparr>),
      VLambda (Vset \<alpha>) id_Par
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma cat_Par_components:
  shows "cat_Par \<alpha>\<lparr>Obj\<rparr> = Vset \<alpha>"
    and "cat_Par \<alpha>\<lparr>Arr\<rparr> = set {T. arr_Par \<alpha> T}"
    and "cat_Par \<alpha>\<lparr>Dom\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>)"
    and "cat_Par \<alpha>\<lparr>Cod\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>)"
    and "cat_Par \<alpha>\<lparr>Comp\<rparr> = (\<lambda>ST\<in>\<^sub>\<circ>composable_arrs (dg_Par \<alpha>). ST\<lparr>0\<rparr> \<circ>\<^sub>P\<^sub>a\<^sub>r ST\<lparr>1\<^sub>\<nat>\<rparr>)"
    and "cat_Par \<alpha>\<lparr>CId\<rparr> = VLambda (Vset \<alpha>) id_Par"
  unfolding cat_Par_def dg_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma cat_smc_cat_Par: "cat_smc (cat_Par \<alpha>) = smc_Par \<alpha>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> (cat_smc (cat_Par \<alpha>)) = 5\<^sub>\<nat>"
    unfolding cat_smc_def by (simp add: nat_omega_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> (smc_Par \<alpha>) = 5\<^sub>\<nat>"
    unfolding smc_Par_def by (simp add: nat_omega_simps)
  show "\<D>\<^sub>\<circ> (cat_smc (cat_Par \<alpha>)) = \<D>\<^sub>\<circ> (smc_Par \<alpha>)"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_smc (cat_Par \<alpha>)) \<Longrightarrow> cat_smc (cat_Par \<alpha>)\<lparr>a\<rparr> = smc_Par \<alpha>\<lparr>a\<rparr>"
    for a
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold cat_smc_def dg_field_simps cat_Par_def smc_Par_def
      )
      (auto simp: nat_omega_simps)
qed (auto simp: cat_smc_def smc_Par_def)

lemmas_with [folded cat_smc_cat_Par, unfolded slicing_simps]:
  cat_Par_Obj_iff = smc_Par_Obj_iff
  and cat_Par_Arr_iff[cat_Par_cs_simps] = smc_Par_Arr_iff
  and cat_Par_Dom_vsv[cat_Par_cs_intros] = smc_Par_Dom_vsv
  and cat_Par_Dom_vdomain[cat_Par_cs_simps] = smc_Par_Dom_vdomain
  and cat_Par_Dom_vrange = smc_Par_Dom_vrange
  and cat_Par_Dom_app[cat_Par_cs_simps] = smc_Par_Dom_app
  and cat_Par_Cod_vsv[cat_Par_cs_intros] = smc_Par_Cod_vsv
  and cat_Par_Cod_vdomain[cat_Par_cs_simps] = smc_Par_Cod_vdomain
  and cat_Par_Cod_vrange = smc_Par_Cod_vrange
  and cat_Par_Cod_app[cat_Par_cs_simps] = smc_Par_Cod_app
  and cat_Par_is_arrI = smc_Par_is_arrI
  and cat_Par_is_arrD = smc_Par_is_arrD
  and cat_Par_is_arrE = smc_Par_is_arrE

lemmas_with [folded cat_smc_cat_Par, unfolded slicing_simps]:
  cat_Par_composable_arrs_dg_Par = smc_Par_composable_arrs_dg_Par
  and cat_Par_Comp = smc_Par_Comp
  and cat_Par_Comp_app[cat_Par_cs_simps] = smc_Par_Comp_app
  and cat_Par_Comp_vdomain[cat_Par_cs_simps] = smc_Par_Comp_vdomain
  and cat_Par_is_monic_arrI = smc_Par_is_monic_arrI
  and cat_Par_is_monic_arrD = smc_Par_is_monic_arrD
  and cat_Par_is_monic_arr = smc_Par_is_monic_arr
  and cat_Par_is_epic_arrI = smc_Par_is_epic_arrI
  and cat_Par_is_epic_arrD = smc_Par_is_epic_arrD
  and cat_Par_is_epic_arr = smc_Par_is_epic_arr

lemmas [cat_cs_simps] = cat_Par_is_arrD(2,3)

lemmas [cat_Par_cs_intros] = cat_Par_is_arrI

lemmas_with (in \<Z>) [folded cat_smc_cat_Par, unfolded slicing_simps]:
  cat_Par_Hom_vifunion_in_Vset = smc_Par_Hom_vifunion_in_Vset
  and cat_Par_incl_Par_is_arr = smc_Par_incl_Par_is_arr
  and cat_Par_incl_Par_is_arr'[cat_Par_cs_intros] = smc_Par_incl_Par_is_arr'
  and cat_Par_Comp_vrange = smc_Par_Comp_vrange
  and cat_Par_obj_terminal = smc_Par_obj_terminal
  and cat_Par_obj_initial = smc_Par_obj_initial
  and cat_Par_obj_terminal_obj_initial = smc_Par_obj_terminal_obj_initial
  and cat_Par_obj_null = smc_Par_obj_null
  and cat_Par_is_zero_arr = smc_Par_is_zero_arr

lemmas [cat_Par_cs_intros] = \<Z>.cat_Par_incl_Par_is_arr'

subsubsection\<open>Identity\<close>

lemma cat_Par_CId_app[cat_Par_cs_simps]:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr> = id_Par A"
  using assms unfolding cat_Par_components by simp

lemma id_Par_CId_app_app[cat_cs_simps]:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>" and "a \<in>\<^sub>\<circ> A"
  shows "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr>\<lparr>ArrVal\<rparr>\<lparr>a\<rparr> = a"
  unfolding cat_Par_CId_app[OF assms(1)] id_Rel_ArrVal_app[OF assms(2)] by simp

subsubsection\<open>\<open>Par\<close> is a category\<close>

lemma (in \<Z>) category_cat_Par: "category \<alpha> (cat_Par \<alpha>)"
proof(intro categoryI, unfold cat_smc_cat_Rel cat_smc_cat_Par cat_op_simps)

  interpret Par: semicategory \<alpha> \<open>cat_smc (cat_Par \<alpha>)\<close>
    unfolding cat_smc_cat_Par by (simp add: semicategory_smc_Par)

  show "vfsequence (cat_Par \<alpha>)" unfolding cat_Par_def by simp
  show "vcard (cat_Par \<alpha>) = 6\<^sub>\<nat>"
    unfolding cat_Par_def by (simp add: nat_omega_simps)
  show "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr> : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> A" if "A \<in>\<^sub>\<circ> cat_Par \<alpha>\<lparr>Obj\<rparr>" for A
    using that
    unfolding cat_Par_Obj_iff
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_Par_cs_simps cs_intro: cat_Par_cs_intros arr_Par_id_ParI
      )

  show "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>B\<rparr> \<circ>\<^sub>A\<^bsub>cat_Par \<alpha>\<^esub> F = F"
    if "F : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B" for F A B
  proof-
    from that have "arr_Par \<alpha> F" "B \<in>\<^sub>\<circ> Vset \<alpha>"
      by (auto elim: cat_Par_is_arrE simp: cat_Par_cs_simps)
    with that \<Z>_axioms show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_Par_cs_simps
            cs_intro: cat_Par_cs_intros arr_Par_id_ParI
        )
  qed

  show "F \<circ>\<^sub>A\<^bsub>cat_Par \<alpha>\<^esub> cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>B\<rparr> = F"
    if "F : B \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> C" for F B C
  proof-
    from that have "arr_Par \<alpha> F" "B \<in>\<^sub>\<circ> Vset \<alpha>"
      by (auto elim: cat_Par_is_arrE simp: cat_Par_cs_simps)
    with that show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_cs_simps cat_Par_cs_simps
            cs_intro: cat_Par_cs_intros arr_Par_id_ParI
        )
  qed

qed (auto simp: semicategory_smc_Par cat_Par_components)

subsubsection\<open>\<open>Par\<close> is a wide replete subcategory of \<open>Rel\<close>\<close>

lemma (in \<Z>) wide_replete_subcategory_cat_Par_cat_Rel:
  "cat_Par \<alpha> \<subseteq>\<^sub>C\<^sub>.\<^sub>w\<^sub>r\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
proof(intro wide_replete_subcategoryI)
  show wide_subcategory_cat_Par_cat_Rel: "cat_Par \<alpha> \<subseteq>\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
  proof(intro wide_subcategoryI, unfold cat_smc_cat_Rel cat_smc_cat_Par)
    interpret Rel: category \<alpha> \<open>cat_Rel \<alpha>\<close> by (rule category_cat_Rel)
    interpret Par: category \<alpha> \<open>cat_Par \<alpha>\<close> by (rule category_cat_Par)
    interpret wide_subsemicategory \<alpha> \<open>smc_Par \<alpha>\<close> \<open>smc_Rel \<alpha>\<close>
      by (simp add: wide_subsemicategory_smc_Par_smc_Rel)
    show "cat_Par \<alpha> \<subseteq>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
    proof(intro subcategoryI, unfold cat_smc_cat_Rel cat_smc_cat_Par)
      show "smc_Par \<alpha> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> smc_Rel \<alpha>" by (simp add: subsemicategory_axioms)
      fix A assume "A \<in>\<^sub>\<circ> cat_Par \<alpha>\<lparr>Obj\<rparr>"
      then show "cat_Par \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr> = cat_Rel \<alpha>\<lparr>CId\<rparr>\<lparr>A\<rparr>"
        unfolding cat_Par_components cat_Rel_components by simp
    qed
      (
        auto simp:
          subsemicategory_axioms Rel.category_axioms Par.category_axioms
      )
  qed (rule wide_subsemicategory_smc_Par_smc_Rel)
  show "cat_Par \<alpha> \<subseteq>\<^sub>C\<^sub>.\<^sub>r\<^sub>e\<^sub>p\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>"
  proof(intro replete_subcategoryI)
    interpret wide_subcategory \<alpha> \<open>cat_Par \<alpha>\<close> \<open>cat_Rel \<alpha>\<close>
      by (rule wide_subcategory_cat_Par_cat_Rel)
    show "cat_Par \<alpha> \<subseteq>\<^sub>C\<^bsub>\<alpha>\<^esub> cat_Rel \<alpha>" by (rule subcategory_axioms)
    fix A B F assume prems: "A \<in>\<^sub>\<circ> cat_Par \<alpha>\<lparr>Obj\<rparr>" "F : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    note arr_Rel = cat_Rel_is_iso_arrD[OF prems(2)]
    from arr_Rel(2) show "F : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B"
      by (intro cat_Par_is_arrI arr_Par_arr_RelI cat_Rel_is_arrD[OF arr_Rel(1)])
        auto
  qed
qed

subsection\<open>Isomorphism\<close>

lemma cat_Par_is_iso_arrI[intro]:
  assumes "T : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B"
    and "v11 (T\<lparr>ArrVal\<rparr>)"
    and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
    and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  shows "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
proof-
  interpret T: arr_Par \<alpha> T by (intro cat_Par_is_arrD(1)[OF assms(1)])
  note [cat_cs_intros] = cat_Rel_is_iso_arrI
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms have
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    by (cs_concl cs_intro: cat_cs_intros cat_sub_cs_intros cat_sub_fw_cs_intros)
  with T.wide_replete_subcategory_cat_Par_cat_Rel assms show
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
    by (cs_concl cs_shallow cs_simp: cat_sub_bw_cs_simps)
qed

lemma cat_Par_is_iso_arrD[dest]:
  assumes "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
  shows "T : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B"
    and "v11 (T\<lparr>ArrVal\<rparr>)"
    and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
    and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
proof-
  interpret T: arr_Par \<alpha> T
    by (intro cat_Par_is_arrD(1)[OF is_iso_arrD(1)[OF assms(1)]])
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms have T:
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    by (cs_concl cs_shallow cs_intro: cat_sub_cs_intros cat_sub_fw_cs_intros)
  show "v11 (T\<lparr>ArrVal\<rparr>)" "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A" "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
    by (intro cat_Rel_is_iso_arrD[OF T])+
qed (rule is_iso_arrD(1)[OF assms])

lemma cat_Par_is_iso_arr:
  "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B \<longleftrightarrow>
    T : A \<mapsto>\<^bsub>cat_Par \<alpha>\<^esub> B \<and>
    v11 (T\<lparr>ArrVal\<rparr>) \<and>
    \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A \<and>
    \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = B"
  by auto

subsection\<open>The inverse arrow\<close>

abbreviation (input) converse_Par :: "V \<Rightarrow> V" ("(_\<inverse>\<^sub>P\<^sub>a\<^sub>r)" [1000] 999)
  where "a\<inverse>\<^sub>P\<^sub>a\<^sub>r \<equiv> a\<inverse>\<^sub>R\<^sub>e\<^sub>l"

lemma cat_Par_the_inverse[cat_Par_cs_simps]:
  assumes "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Par \<alpha>\<^esub> B"
  shows "T\<inverse>\<^sub>C\<^bsub>cat_Par \<alpha>\<^esub> = T\<inverse>\<^sub>P\<^sub>a\<^sub>r"
proof-
  interpret T: arr_Par \<alpha> T
    by (intro cat_Par_is_arrD(1)[OF is_iso_arrD(1)[OF assms(1)]])
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms have T:
    "T : A \<mapsto>\<^sub>i\<^sub>s\<^sub>o\<^bsub>cat_Rel \<alpha>\<^esub> B"
    by (cs_concl cs_shallow cs_intro: cat_sub_cs_intros cat_sub_fw_cs_intros)
  from T.wide_replete_subcategory_cat_Par_cat_Rel assms
  have [symmetric, cat_cs_simps]: "T\<inverse>\<^sub>C\<^bsub>cat_Rel \<alpha>\<^esub> = T\<inverse>\<^sub>C\<^bsub>cat_Par \<alpha>\<^esub>"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_sub_bw_cs_simps cs_intro: cat_sub_cs_intros
      )
  from T show "T\<inverse>\<^sub>C\<^bsub>cat_Par \<alpha>\<^esub> = T\<inverse>\<^sub>P\<^sub>a\<^sub>r"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_Rel_cs_simps cat_cs_simps cs_intro: cat_cs_intros
      )
qed

text\<open>\newpage\<close>

end


(* Author: Simon Wimmer *)
theory Graphs
  imports
    More_List Stream_More
    "HOL-Library.Rewrite"
    Instantiate_Existentials "Eval_Base.Eval_Base"
begin

section \<open>Graphs\<close>

subsection \<open>Basic Definitions and Theorems\<close>

locale Graph_Defs =
  fixes E :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

inductive steps where
  Single: "steps [x]" |
  Cons: "steps (x # y # xs)" if "E x y" "steps (y # xs)"

lemmas [intro] = steps.intros

lemma steps_append:
  "steps (xs @ tl ys)" if "steps xs" "steps ys" "last xs = hd ys"
  using that apply2 induction by (auto 4 4 elim: steps.cases)

lemma steps_append':
  "steps xs" if "steps as" "steps bs" "last as = hd bs" "as @ tl bs = xs"
  using steps_append that by blast

coinductive run where
  "run (x ## y ## xs)" if "E x y" "run (y ## xs)"

lemmas [intro] = run.intros

lemma steps_appendD1:
  "steps xs" if "steps (xs @ ys)" "xs \<noteq> []"
  using that proof2 (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
    by - (cases xs; auto elim: steps.cases)
qed

lemma steps_appendD2:
  "steps ys" if "steps (xs @ ys)" "ys \<noteq> []"
  using that apply2 (induction xs) by(auto elim: steps.cases)

lemma steps_appendD3:
  "steps (xs @ [x]) \<and> E x y" if "steps (xs @ [x, y])"
  using that proof2 (induction xs)
  case Nil
  then show ?case by (auto elim!: steps.cases)
next
  case prems: (Cons a xs)
  then show ?case by (cases xs) (auto elim: steps.cases)
qed

lemma steps_ConsD:
  "steps xs" if "steps (x # xs)" "xs \<noteq> []"
  using that by (auto elim: steps.cases)

lemmas stepsD = steps_ConsD steps_appendD1 steps_appendD2

lemma steps_alt_induct[consumes 1, case_names Single Snoc]:
  assumes
    "steps x" "(\<And>x. P [x])"
    "\<And>y x xs. E y x \<Longrightarrow> steps (xs @ [y]) \<Longrightarrow> P (xs @ [y]) \<Longrightarrow> P (xs @ [y,x])"
  shows "P x"
  using assms(1)
proof2 (induction rule: rev_induct)
    case Nil
    then show ?case by (auto elim: steps.cases)
  next
    case prems: (snoc x xs)
    then show ?case by (cases xs rule: rev_cases) (auto intro: assms(2,3) dest!: steps_appendD3)
  qed

lemma steps_appendI:
  "steps (xs @ [x, y])" if "steps (xs @ [x])" "E x y"
  using that
proof2 (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case by (cases xs; auto elim: steps.cases)
qed

lemma steps_append_single:
  assumes
    "steps xs" "E (last xs) x" "xs \<noteq> []"
  shows "steps (xs @ [x])"
  using assms(3,1,2) apply2 (induction xs rule: list_nonempty_induct) by(auto 4 4 elim: steps.cases)

lemma extend_run:
  assumes
    "steps xs" "E (last xs) x" "run (x ## ys)" "xs \<noteq> []"
  shows "run (xs @- x ## ys)"
  using assms(4,1-3) apply2 (induction xs rule: list_nonempty_induct) by(auto 4 3 elim: steps.cases)

lemma run_cycle:
  assumes "steps xs" "E (last xs) (hd xs)" "xs \<noteq> []"
  shows "run (cycle xs)"
  using assms proof (coinduction arbitrary: xs)
  case run
  then show ?case
    apply (rewrite at \<open>cycle xs\<close> stream.collapse[symmetric])
    apply (rewrite at \<open>stl (cycle xs)\<close> stream.collapse[symmetric])
    apply clarsimp
    apply (erule steps.cases)
    subgoal for x
      apply (rule conjI)
       apply (simp; fail)
      apply (rule disjI1)
      apply (inst_existentials xs)
         apply (simp, metis cycle_Cons[of x "[]", simplified])
      by auto
    subgoal for x y xs'
      apply (rule conjI)
       apply (simp; fail)
      apply (rule disjI1)
      apply (inst_existentials "y # xs' @ [x]")
      using steps_append_single[of "y # xs'" x]
         apply (auto elim: steps.cases split: if_split_asm)
       apply (subst (2) cycle_Cons, simp) (* XXX Automate forward reasoning *)
      apply (subst cycle_Cons, simp)
      done
    done
qed

lemma run_stl:
  "run (stl xs)" if "run xs"
  using that by (auto elim: run.cases)

lemma run_sdrop:
  "run (sdrop n xs)" if "run xs"
  using that apply2 (induction n arbitrary: xs) by(auto intro: run_stl)

lemma run_reachable':
  assumes "run (x ## xs)" "E\<^sup>*\<^sup>* x\<^sub>0 x"
  shows "pred_stream (\<lambda> x. E\<^sup>*\<^sup>* x\<^sub>0 x) xs"
  using assms by (coinduction arbitrary: x xs) (auto 4 3 elim: run.cases)

lemma run_reachable:
  assumes "run (x\<^sub>0 ## xs)"
  shows "pred_stream (\<lambda> x. E\<^sup>*\<^sup>* x\<^sub>0 x) xs"
  by (rule run_reachable'[OF assms]) blast

lemma run_decomp:
  assumes "run (xs @- ys)" "xs \<noteq> []"
  shows "steps xs \<and> run ys \<and> E (last xs) (shd ys)"
using assms(2,1) proof2 (induction xs rule: list_nonempty_induct)
  case (single x)
  then show ?case by (auto elim: run.cases)
next
  case (cons x xs)
  then show ?case by (cases xs; auto 4 4 elim: run.cases)
qed

lemma steps_decomp:
  assumes "steps (xs @ ys)" "xs \<noteq> []" "ys \<noteq> []"
  shows "steps xs \<and> steps ys \<and> E (last xs) (hd ys)"
using assms(2,1,3) proof2 (induction xs rule: list_nonempty_induct)
  case (single x)
  then show ?case by (auto elim: steps.cases)
next
  case (cons x xs)
  then show ?case by (cases xs; auto 4 4 elim: steps.cases)
qed

lemma steps_rotate:
  assumes "steps (x # xs @ y # ys @ [x])"
  shows "steps (y # ys @ x # xs @ [y])"
proof -
  from steps_decomp[of "x # xs" "y # ys @ [x]"] assms have
    "steps (x # xs)" "steps (y # ys @ [x])" "E (last (x # xs)) y"
    by auto
  then have "steps ((x # xs) @ [y])" by (blast intro: steps_append_single)
  from steps_append[OF \<open>steps (y # ys @ [x])\<close> this] show ?thesis by auto
qed

lemma run_shift_coinduct[case_names run_shift, consumes 1]:
  assumes "R w"
      and "\<And> w. R w \<Longrightarrow> \<exists> u v x y. w = u @- x ## y ## v \<and> steps (u @ [x]) \<and> E x y \<and> R (y ## v)"
  shows "run w"
  using assms(2)[OF \<open>R w\<close>] proof (coinduction arbitrary: w)
  case (run w)
  then obtain u v x y where "w = u @- x ## y ## v" "steps (u @ [x])" "E x y" "R (y ## v)"
    by auto
  then show ?case
    apply -
    apply (drule assms(2))
    apply (cases u)
     apply force
    subgoal for z zs
      apply (cases zs)
      subgoal
        apply simp
        apply safe
         apply (force elim: steps.cases)
        subgoal for u' v' x' y'
          by (inst_existentials "x # u'") (cases u'; auto)
        done
      subgoal for a as
        apply simp
        apply safe
         apply (force elim: steps.cases)
        subgoal for u' v' x' y'
          apply (inst_existentials "a # as @ x # u'")
          using steps_append[of "a # as @ [x, y]" "u' @ [x']"]
          apply simp
          apply (drule steps_appendI[of "a # as" x, rotated])
          by (cases u'; force elim: steps.cases)+
        done
      done
    done
qed

lemma run_flat_coinduct[case_names run_shift, consumes 1]:
  assumes "R xss"
    and
    "\<And> xs ys xss.
    R (xs ## ys ## xss) \<Longrightarrow> xs \<noteq> [] \<and> steps xs \<and> E (last xs) (hd ys) \<and> R (ys ## xss)"
  shows "run (flat xss)"
proof -
  obtain xs ys xss' where "xss = xs ## ys ## xss'" by (metis stream.collapse)
  with assms(2)[OF assms(1)[unfolded this]] show ?thesis
  proof (coinduction arbitrary: xs ys xss' xss rule: run_shift_coinduct)
    case (run_shift xs ys xss' xss)
    from run_shift show ?case
      apply (cases xss')
      apply clarify
      apply (drule assms(2))
      apply (inst_existentials "butlast xs" "tl ys @- flat xss'" "last xs" "hd ys")
         apply (cases ys)
          apply (simp; fail)
      subgoal premises prems for x1 x2 z zs
      proof (cases "xs = []")
        case True
        with prems show ?thesis
          by auto
      next
        case False
        then have "xs = butlast xs @ [last xs]" by auto
        then have "butlast xs @- last xs ## tail = xs @- tail" for tail
          by (metis shift.simps(1,2) shift_append)
        with prems show ?thesis by simp
      qed
        apply (simp; fail)
       apply assumption
      subgoal for ws wss
        by (inst_existentials ys ws wss) (cases ys, auto)
      done
  qed
qed

lemma steps_non_empty[simp]:
  "\<not> steps []"
  by (auto elim: steps.cases)

lemma steps_non_empty'[simp]:
  "xs \<noteq> []" if "steps xs"
  using that by auto

(* XXX Generalize *)
lemma steps_replicate:
  "steps (hd xs # concat (replicate n (tl xs)))" if "last xs = hd xs" "steps xs" "n > 0"
  using that
proof2 (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  show ?case
  proof (cases n)
    case 0
    with Suc.prems show ?thesis by (cases xs; auto)
  next
    case prems: (Suc nat)
    from Suc.prems have [simp]: "hd xs # tl xs @ ys = xs @ ys" for ys
      by (cases xs; auto)
    from Suc.prems have **: "tl xs @ ys = tl (xs @ ys)" for ys
      by (cases xs; auto)
    from prems Suc show ?thesis
      by (fastforce intro: steps_append')
  qed
qed

notation E ("_ \<rightarrow> _" [100, 100] 40)

abbreviation reaches ("_ \<rightarrow>* _" [100, 100] 40) where "reaches x y \<equiv> E\<^sup>*\<^sup>* x y"

abbreviation reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40) where "reaches1 x y \<equiv> E\<^sup>+\<^sup>+ x y"

lemma steps_reaches:
  "hd xs \<rightarrow>* last xs" if "steps xs"
  using that apply2 (induction xs) by auto

lemma steps_reaches':
  "x \<rightarrow>* y" if "steps xs" "hd xs = x" "last xs = y"
  using that steps_reaches by auto

lemma reaches_steps:
  "\<exists> xs. hd xs = x \<and> last xs = y \<and> steps xs" if "x \<rightarrow>* y"
  using that
  apply2 (induction)
   apply force
  apply clarsimp
  subgoal for z xs
    by (inst_existentials "xs @ [z]", (cases xs; simp), auto intro: steps_append_single)
  done

lemma reaches_steps_iff:
  "x \<rightarrow>* y \<longleftrightarrow> (\<exists> xs. hd xs = x \<and> last xs = y \<and> steps xs)"
  using steps_reaches reaches_steps by fast

lemma steps_reaches1:
  "x \<rightarrow>\<^sup>+ y" if "steps (x # xs @ [y])"
  by (metis list.sel(1,3) rtranclp_into_tranclp2 snoc_eq_iff_butlast steps.cases steps_reaches that)

lemma stepsI:
  "steps (x # xs)" if "x \<rightarrow> hd xs" "steps xs"
  using that by (cases xs) auto

lemma reaches1_steps:
  "\<exists> xs. steps (x # xs @ [y])" if "x \<rightarrow>\<^sup>+ y"
proof -
  from that obtain z where "x \<rightarrow> z" "z \<rightarrow>* y"
    by atomize_elim (simp add: tranclpD)
  from reaches_steps[OF this(2)] obtain xs where *: "hd xs = z" "last xs = y" "steps xs"
    by auto
  then obtain xs' where [simp]: "xs = xs' @ [y]"
    by atomize_elim (auto 4 3 intro: append_butlast_last_id[symmetric])
  with \<open>x \<rightarrow> z\<close> * show ?thesis
    by (auto intro: stepsI)
qed

lemma reaches1_steps_iff:
  "x \<rightarrow>\<^sup>+ y \<longleftrightarrow> (\<exists> xs. steps (x # xs @ [y]))"
  using steps_reaches1 reaches1_steps by fast

lemma reaches1_reaches_iff1:
  "x \<rightarrow>\<^sup>+ y \<longleftrightarrow> (\<exists> z. x \<rightarrow> z \<and> z \<rightarrow>* y)"
  by (auto dest: tranclpD)

lemma
  "x \<rightarrow>\<^sup>+ z" if "x \<rightarrow>* y" "y \<rightarrow>\<^sup>+ z"
  using that by auto

lemma
  "x \<rightarrow>\<^sup>+ z" if "x \<rightarrow>\<^sup>+ y" "y \<rightarrow>* z"
  using that by auto

lemma steps_append2:
  "steps (xs @ x # ys)" if "steps (xs @ [x])" "steps (x # ys)"
  using that by (auto dest: steps_append)

lemma reaches1_steps_append:
  assumes "a \<rightarrow>\<^sup>+ b" "steps xs" "hd xs = b"
  shows "\<exists> ys. steps (a # ys @ xs)"
  using assms by (fastforce intro: steps_append' dest: reaches1_steps)

lemma steps_last_step:
  "\<exists> a. a \<rightarrow> last xs" if "steps xs" "length xs > 1"
  using that apply2 induction by auto

lemmas graphI =
  steps.intros
  steps_append_single
  steps_reaches'
  stepsI

end (* Graph Defs *)

subsection \<open>Graphs with a Start Node\<close>

locale Graph_Start_Defs = Graph_Defs +
  fixes s\<^sub>0 :: 'a
begin

definition reachable where
  "reachable = E\<^sup>*\<^sup>* s\<^sub>0"

lemma start_reachable[intro!, simp]:
  "reachable s\<^sub>0"
  unfolding reachable_def by auto

lemma reachable_step:
  "reachable b" if "reachable a" "E a b"
  using that unfolding reachable_def by auto

lemma reachable_reaches:
  "reachable b" if "reachable a" "a \<rightarrow>* b"
  using that(2,1) apply2 induction by(auto intro: reachable_step)

lemma reachable_steps_append:
  assumes "reachable a" "steps xs" "hd xs = a" "last xs = b"
  shows "reachable b"
  using assms by (auto intro: graphI reachable_reaches)

lemmas steps_reachable = reachable_steps_append[of s\<^sub>0, simplified]

lemma reachable_steps_elem:
  "reachable y" if "reachable x" "steps xs" "y \<in> set xs" "hd xs = x"
proof -
  from \<open>y \<in> set xs\<close> obtain as bs where [simp]: "xs = as @ y # bs"
    by (auto simp: in_set_conv_decomp)
  show ?thesis
  proof (cases "as = []")
    case True
    with that show ?thesis
      by simp
  next
    case False
    (* XXX *)
    from \<open>steps xs\<close> have "steps (as @ [y])"
      by (auto intro: stepsD)
    with \<open>as \<noteq> []\<close> \<open>hd xs = x\<close> \<open>reachable x\<close> show ?thesis
      by (auto 4 3 intro: reachable_reaches graphI)
  qed
qed

lemma reachable_steps:
  "\<exists> xs. steps xs \<and> hd xs = s\<^sub>0 \<and> last xs = x" if "reachable x"
  using that unfolding reachable_def
proof2 induction
  case base
  then show ?case by (inst_existentials "[s\<^sub>0]"; force)
next
  case (step y z)
  from step.IH guess xs by clarify
  with step.hyps show ?case
    apply (inst_existentials "xs @ [z]")
    apply (force intro: graphI)
    by (cases xs; auto)+
qed

lemma reachable_cycle_iff:
  "reachable x \<and> x \<rightarrow>\<^sup>+ x \<longleftrightarrow> (\<exists> ws xs. steps (s\<^sub>0 # ws @ [x] @ xs @ [x]))"
proof (safe, goal_cases)
  case (2 ws)
  then show ?case
    by (auto intro: steps_reachable stepsD)
next
  case (3 ws xs)
  then show ?case
    by (auto intro: stepsD steps_reaches1)
next
  case prems: 1
  from \<open>reachable x\<close> prems(2) have "s\<^sub>0 \<rightarrow>\<^sup>+ x"
    unfolding reachable_def by auto
  with \<open>x \<rightarrow>\<^sup>+ x\<close> show ?case
    by (fastforce intro: steps_append' dest: reaches1_steps)
qed

lemma reachable_induct[consumes 1, case_names start step, induct pred: reachable]:
  assumes "reachable x"
    and "P s\<^sub>0"
    and "\<And> a b. reachable a \<Longrightarrow> P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> P b"
  shows "P x"
  using assms(1) unfolding reachable_def
  apply2 induction by(auto intro: assms(2-)[unfolded reachable_def])

lemmas graphI_aggressive =
  tranclp_into_rtranclp
  rtranclp.rtrancl_into_rtrancl
  tranclp.trancl_into_trancl
  rtranclp_into_tranclp2

lemmas graphI_aggressive1 =
  graphI_aggressive
  steps_append'

lemmas graphI_aggressive2 =
  graphI_aggressive
  stepsD
  steps_reaches1
  steps_reachable

lemmas graphD =
  reaches1_steps

lemmas graphD_aggressive =
  tranclpD

lemmas graph_startI =
  reachable_reaches
  start_reachable

end (* Graph Start Defs *)

subsection \<open>Subgraphs\<close>

subsubsection \<open>Edge-induced Subgraphs\<close>

locale Subgraph_Defs = G: Graph_Defs +
  fixes E' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

sublocale G': Graph_Defs E' .

end (* Subgraph Defs *)

locale Subgraph_Start_Defs = G: Graph_Start_Defs +
  fixes E' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

sublocale G': Graph_Start_Defs E' s\<^sub>0 .

end (* Subgraph Start Defs *)

locale Subgraph = Subgraph_Defs +
  assumes subgraph[intro]: "E' a b \<Longrightarrow> E a b"
begin

lemma non_subgraph_cycle_decomp:
  "\<exists> c d. G.reaches a c \<and> E c d \<and> \<not> E' c d \<and> G.reaches d b" if
  "G.reaches1 a b" "\<not> G'.reaches1 a b" for a b
    using that
  proof2 induction
    case (base y)
    then show ?case
      by auto
  next
    case (step y z)
    show ?case
    proof (cases "E' y z")
      case True
      with step have "\<not> G'.reaches1 a y"
        by (auto intro: tranclp.trancl_into_trancl) (* XXX *)
      with step obtain c d where
        "G.reaches a c" "E c d" "\<not> E' c d" "G.reaches d y"
        by auto
      with \<open>E' y z\<close> show ?thesis
        by (blast intro: rtranclp.rtrancl_into_rtrancl) (* XXX *)
    next
      case False
      with step show ?thesis
        by (intro exI conjI) auto
    qed
  qed

lemma reaches:
  "G.reaches a b" if "G'.reaches a b"
  using that apply2 induction by (auto intro: rtranclp.intros(2))

lemma reaches1:
  "G.reaches1 a b" if "G'.reaches1 a b"
  using that apply2 induction  by(auto intro: tranclp.intros(2))

end (* Subgraph *)

locale Subgraph_Start = Subgraph_Start_Defs + Subgraph
begin

lemma reachable_subgraph[intro]: "G.reachable b" if \<open>G.reachable a\<close> \<open>G'.reaches a b\<close> for a b
  using that by (auto intro: G.graph_startI mono_rtranclp[rule_format, of E'])

lemma reachable:
  "G.reachable x" if "G'.reachable x"
  using that by (fastforce simp: G.reachable_def G'.reachable_def)

end (* Subgraph Start *)

subsubsection \<open>Node-induced Subgraphs\<close>

locale Subgraph_Node_Defs = Graph_Defs +
  fixes V :: "'a \<Rightarrow> bool"
begin

definition E' where "E' x y \<equiv> E x y \<and> V x \<and> V y"

sublocale Subgraph E E' by standard (auto simp: E'_def)

lemma subgraph':
  "E' x y" if "E x y" "V x" "V y"
  using that unfolding E'_def by auto

lemma E'_V1:
  "V x" if "E' x y"
  using that unfolding E'_def by auto

lemma E'_V2:
  "V y" if "E' x y"
  using that unfolding E'_def by auto

lemma G'_reaches_V:
  "V y" if "G'.reaches x y" "V x"
  using that by (cases) (auto intro: E'_V2)

lemma G'_steps_V_all:
  "list_all V xs" if "G'.steps xs" "V (hd xs)"
  using that apply2 induction by(auto intro: E'_V2)

lemma G'_steps_V_last:
  "V (last xs)" if "G'.steps xs" "V (hd xs)"
  using that apply2 induction by(auto dest: E'_V2)

lemmas subgraphI = E'_V1 E'_V2 G'_reaches_V

lemmas subgraphD = E'_V1 E'_V2 G'_reaches_V

end (* Subgraph Node *)

locale Subgraph_Node_Defs_Notation = Subgraph_Node_Defs
begin

no_notation E ("_ \<rightarrow> _" [100, 100] 40)
notation E' ("_ \<rightarrow> _" [100, 100] 40)
no_notation reaches ("_ \<rightarrow>* _" [100, 100] 40)
notation G'.reaches ("_ \<rightarrow>* _" [100, 100] 40)
no_notation reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40)
notation G'.reaches1 ("_ \<rightarrow>\<^sup>+ _" [100, 100] 40)

end (* Subgraph_Node_Defs_Notation *)

subsubsection \<open>The Reachable Subgraph\<close>

context Graph_Start_Defs
begin

interpretation Subgraph_Node_Defs_Notation E reachable .

sublocale reachable_subgraph: Subgraph_Node_Defs E reachable .

lemma reachable_supgraph:
  "x \<rightarrow> y" if "E x y" "reachable x"
  using that unfolding E'_def by (auto intro: graph_startI)

lemma reachable_reaches_equiv: "reaches x y \<longleftrightarrow> x \<rightarrow>* y" if "reachable x" for x y
  apply standard
  subgoal premises prems
    using prems \<open>reachable x\<close>
    apply2 induction by (auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
  subgoal premises prems
    using prems \<open>reachable x\<close>
    apply2 induction by(auto dest: subgraph)
  done

lemma reachable_reaches1_equiv: "reaches1 x y \<longleftrightarrow> x \<rightarrow>\<^sup>+ y" if "reachable x" for x y
  apply standard
  subgoal premises prems
    using prems \<open>reachable x\<close>
    apply2 induction by(auto dest: reachable_supgraph intro: graph_startI graphI_aggressive)
  subgoal premises prems
    using prems \<open>reachable x\<close>
    apply2 induction by(auto dest: subgraph)
  done

lemma reachable_steps_equiv:
  "steps (x # xs) \<longleftrightarrow> G'.steps (x # xs)" if "reachable x"
  apply standard
  subgoal premises prems
    using prems \<open>reachable x\<close>
    apply2 (induction "x # xs" arbitrary: x xs) by(auto dest: reachable_supgraph intro: graph_startI)
  subgoal premises prems
    using prems apply2 induction by auto
  done

end (* Graph Start Defs *)

subsection \<open>Bundles\<close>

bundle graph_automation
begin

lemmas [intro] = Graph_Defs.graphI Graph_Start_Defs.graph_startI
lemmas [dest]  = Graph_Start_Defs.graphD

end (* Bundle *)

bundle reaches_steps_iff =
  Graph_Defs.reaches1_steps_iff [iff]
  Graph_Defs.reaches_steps_iff  [iff]

bundle graph_automation_aggressive
begin

unbundle graph_automation

lemmas [intro] = Graph_Start_Defs.graphI_aggressive
lemmas [dest]  = Graph_Start_Defs.graphD_aggressive

end (* Bundle *)

bundle subgraph_automation
begin

unbundle graph_automation

lemmas [intro] = Subgraph_Node_Defs.subgraphI
lemmas [dest]  = Subgraph_Node_Defs.subgraphD

end (* Bundle *)

subsection \<open>Simulations and Bisimulations\<close>

locale Graph_Invariant = Graph_Defs +
  fixes P :: "'a \<Rightarrow> bool"
  assumes invariant: "P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> P b"
begin

lemma invariant_steps:
  "list_all P as" if "steps (a # as)" "P a"
  using that apply2 (induction "a # as" arbitrary: as a) by(auto intro: invariant)

lemma invariant_reaches:
  "P b" if "a \<rightarrow>* b" "P a"
  using that apply2 (induction) by( blast intro: invariant)+

lemma invariant_run:
  assumes run: "run (x ## xs)" and P: "P x"
  shows "pred_stream P (x ## xs)"
  using run P by (coinduction arbitrary: x xs) (auto 4 3 elim: invariant run.cases)

end (* Graph Invariant *)

locale Graph_Invariants = Graph_Defs +
  fixes P Q :: "'a \<Rightarrow> bool"
  assumes invariant: "P a \<Longrightarrow> a \<rightarrow> b \<Longrightarrow> Q b" and Q_P: "Q a \<Longrightarrow> P a"
begin

sublocale Pre: Graph_Invariant E P
  by standard (blast intro: invariant Q_P)

sublocale Post: Graph_Invariant E Q
  by standard (blast intro: invariant Q_P)

lemma invariant_steps:
  "list_all Q as" if "steps (a # as)" "P a"
  using that apply2 (induction "a # as" arbitrary: as a) by(auto intro: invariant Q_P)

lemma invariant_run:
  assumes run: "run (x ## xs)" and P: "P x"
  shows "pred_stream Q xs"
  using run P by (coinduction arbitrary: x xs) (auto 4 4 elim: invariant run.cases intro: Q_P)

lemma invariant_reaches1:
  "Q b" if "a \<rightarrow>\<^sup>+ b" "P a"
  using that apply2 (induction) by( blast intro: invariant Q_P)+

end (* Graph Invariants *)

locale Graph_Invariant_Start = Graph_Start_Defs + Graph_Invariant +
  assumes P_s\<^sub>0: "P s\<^sub>0"
begin

lemma invariant_steps:
  "list_all P as" if "steps (s\<^sub>0 # as)"
  using that P_s\<^sub>0 by (rule invariant_steps)

lemma invariant_reaches:
  "P b" if "s\<^sub>0 \<rightarrow>* b"
  using invariant_reaches[OF that P_s\<^sub>0] .

lemmas invariant_run = invariant_run[OF _ P_s\<^sub>0]

end (* Graph Invariant Start *)

locale Graph_Invariant_Strong = Graph_Defs +
  fixes P :: "'a \<Rightarrow> bool"
  assumes invariant: "a \<rightarrow> b \<Longrightarrow> P b"
begin

sublocale inv: Graph_Invariant by standard (rule invariant)

lemma P_invariant_steps:
  "list_all P as" if "steps (a # as)"
  using that apply2 (induction "a # as" arbitrary: as a) by (auto intro: invariant)

lemma steps_last_invariant:
  "P (last xs)" if "steps (x # xs)" "xs \<noteq> []"
  using steps_last_step[of "x # xs"] that by (auto intro: invariant)

lemmas invariant_reaches = inv.invariant_reaches

lemma invariant_reaches1:
  "P b" if "a \<rightarrow>\<^sup>+ b"
  using that apply2 (induction) by( blast intro: invariant)+

end (* Graph Invariant *)

locale Simulation_Defs =
  fixes A :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and B :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
    and sim :: "'a \<Rightarrow> 'b \<Rightarrow> bool" (infixr "\<sim>" 60)
begin

sublocale A: Graph_Defs A .

sublocale B: Graph_Defs B .

end (* Simulation Defs *)

locale Simulation = Simulation_Defs +
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
begin

lemma simulation_reaches:
  "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b"
  using that apply2 (induction rule: rtranclp_induct) by (auto intro: rtranclp.intros(2) dest: A_B_step)

lemma simulation_reaches1:
  "\<exists> b'. B\<^sup>+\<^sup>+ b b' \<and> a' \<sim> b'" if "A\<^sup>+\<^sup>+ a a'" "a \<sim> b"
  using that apply2 (induction rule: tranclp_induct) by(auto 4 3 intro: tranclp.intros(2) dest: A_B_step)

lemma simulation_steps:
  "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs" if "A.steps (a # as)" "a \<sim> b"
  using that
  apply2 (induction "a # as" arbitrary: a b as)
   apply force
  apply (frule A_B_step, auto)
  done

lemma simulation_run:
  "\<exists> ys. B.run (y ## ys) \<and> stream_all2 (\<sim>) xs ys" if "A.run (x ## xs)" "x \<sim> y"
proof -
  let ?ys = "sscan (\<lambda> a' b. SOME b'. B b b' \<and> a' \<sim> b') xs y"
  have "B.run (y ## ?ys)"
    using that by (coinduction arbitrary: x y xs) (force dest!: someI_ex A_B_step elim: A.run.cases)
  moreover have "stream_all2 (\<sim>) xs ?ys"
    using that by (coinduction arbitrary: x y xs) (force dest!: someI_ex A_B_step elim: A.run.cases)
  ultimately show ?thesis by blast
qed

end (* Simulation *)

lemma (in Subgraph) Subgraph_Simulation:
  "Simulation E' E (=)"
  by standard auto

locale Simulation_Invariant = Simulation_Defs +
  fixes PA :: "'a \<Rightarrow> bool" and PB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> PA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> PB b"
begin

definition "equiv' \<equiv> \<lambda> a b. a \<sim> b \<and> PA a \<and> PB b"

sublocale Simulation A B equiv' by standard (auto dest: A_B_step simp: equiv'_def)

sublocale PA_invariant: Graph_Invariant A PA by standard blast

lemma simulation_reaches:
  "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b' \<and> PA a' \<and> PB b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b" "PA a" "PB b"
  using simulation_reaches[of a a' b] that unfolding equiv'_def by simp

lemma simulation_steps:
  "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b \<and> PA a \<and> PB b) as bs"
  if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
  using simulation_steps[of a as b] that unfolding equiv'_def by simp

lemma simulation_steps':
  "\<exists> bs. B.steps (b # bs) \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs \<and> list_all PA as \<and> list_all PB bs"
  if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
  using simulation_steps[OF that]
  by (metis (mono_tags, lifting) list_all2_conv_all_nth list_all_length)

context
  fixes f
  assumes eq: "a \<sim> b \<Longrightarrow> b = f a"
begin

lemma simulation_steps'_map:
  "\<exists> bs.
    B.steps (b # bs) \<and> bs = map f as
    \<and> list_all2 (\<lambda> a b. a \<sim> b) as bs
    \<and> list_all PA as \<and> list_all PB bs"
  if "A.steps (a # as)" "a \<sim> b" "PA a" "PB b"
proof -
  from simulation_steps'[OF that] guess bs by clarify
  note guessed = this
  from this(2) have "bs = map f as"
    apply2 (induction) by( simp add: eq)+
  with guessed show ?thesis
    by auto
qed

end (* Context for Equality Relation *)

end (* Simulation Invariant *)

locale Simulation_Invariants = Simulation_Defs +
  fixes PA QA :: "'a \<Rightarrow> bool" and PB QB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> QA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> QB b"
  assumes PA_QA[intro]: "\<And> a. QA a \<Longrightarrow> PA a" and PB_QB[intro]: "\<And> a. QB a \<Longrightarrow> PB a"
begin

sublocale Pre: Simulation_Invariant A B "(\<sim>)" PA PB
  by standard (auto intro: A_B_step)

sublocale Post: Simulation_Invariant A B "(\<sim>)" QA QB
  by standard (auto intro: A_B_step)

sublocale A_invs: Graph_Invariants A PA QA
  by standard auto

sublocale B_invs: Graph_Invariants B PB QB
  by standard auto

lemma simulation_reaches1:
  "\<exists> b2. B.reaches1 b1 b2 \<and> a2 \<sim> b2 \<and> QB b2" if "A.reaches1 a1 a2" "a1 \<sim> b1" "PA a1" "PB b1"
  using that
  by - (drule Pre.simulation_reaches1, auto intro: B_invs.invariant_reaches1 simp: Pre.equiv'_def)

lemma reaches1_unique:
  assumes unique: "\<And> b2. a \<sim> b2 \<Longrightarrow> QB b2 \<Longrightarrow> b2 = b"
    and that: "A.reaches1 a a" "a \<sim> b" "PA a" "PB b"
  shows "B.reaches1 b b"
  using that by (auto dest: unique simulation_reaches1)

end (* Simualation Invariants *)

locale Bisimulation = Simulation_Defs +
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
begin

sublocale A_B: Simulation A B "(\<sim>)" by standard (rule A_B_step)

sublocale B_A: Simulation B A "\<lambda> x y. y \<sim> x" by standard (rule B_A_step)

lemma A_B_reaches:
  "\<exists> b'. B\<^sup>*\<^sup>* b b' \<and> a' \<sim> b'" if "A\<^sup>*\<^sup>* a a'" "a \<sim> b"
  using A_B.simulation_reaches[OF that] .

lemma B_A_reaches:
  "\<exists> b'. A\<^sup>*\<^sup>* b b' \<and> b' \<sim> a'" if "B\<^sup>*\<^sup>* a a'" "b \<sim> a"
  using B_A.simulation_reaches[OF that] .

end (* Bisim *)

locale Bisimulation_Invariant = Simulation_Defs +
  fixes PA :: "'a \<Rightarrow> bool" and PB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> PA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> PB b"
begin

sublocale PA_invariant: Graph_Invariant A PA by standard blast

sublocale PB_invariant: Graph_Invariant B PB by standard blast

lemmas B_steps_invariant[intro] = PB_invariant.invariant_reaches

definition "equiv' \<equiv> \<lambda> a b. a \<sim> b \<and> PA a \<and> PB b"

sublocale bisim: Bisimulation A B equiv'
  by standard (clarsimp simp add: equiv'_def, frule A_B_step B_A_step, assumption; auto)+

sublocale A_B: Simulation_Invariant A B "(\<sim>)" PA PB
  by (standard; blast intro: A_B_step B_A_step)

sublocale B_A: Simulation_Invariant B A "\<lambda> x y. y \<sim> x" PB PA
  by (standard; blast intro: A_B_step B_A_step)

context
  fixes f
  assumes eq: "a \<sim> b \<longleftrightarrow> b = f a"
    and inj: "\<forall> a b. PB (f a) \<and> PA b \<and> f a = f b \<longrightarrow> a = b"
begin

lemma list_all2_inj_map_eq:
  "as = bs" if "list_all2 (\<lambda>a b. a = f b) (map f as) bs" "list_all PB (map f as)" "list_all PA bs"
  using that inj
  apply2 (induction "map f as" bs arbitrary: as rule: list_all2_induct) by(auto simp: inj_on_def)

lemma steps_map_equiv:
  "A.steps (a # as) \<longleftrightarrow> B.steps (b # map f as)" if "a \<sim> b" "PA a" "PB b"
  using A_B.simulation_steps'_map[of f a as b] B_A.simulation_steps'[of b "map f as" a] that eq
  by (auto dest: list_all2_inj_map_eq)

lemma steps_map:
  "\<exists> as. bs = map f as" if "B.steps (f a # bs)" "PA a" "PB (f a)"
proof -
  have "a \<sim> f a" unfolding eq ..
  from B_A.simulation_steps'[OF that(1) this \<open>PB _\<close> \<open>PA _\<close>] guess as by clarify
  from this(2) show ?thesis
    unfolding eq apply (inst_existentials as) apply2( induction rule: list_all2_induct) by( auto)
qed

lemma reaches_equiv:
  "A.reaches a a' \<longleftrightarrow> B.reaches (f a) (f a')" if "PA a" "PB (f a)"
  apply safe
   apply (drule A_B.simulation_reaches[of a a' "f a"]; simp add: eq that)
  apply (drule B_A.simulation_reaches)
     defer
     apply (rule that | clarsimp simp: eq | metis inj)+
  done

end (* Context for Equality Relation *)

lemma equiv'_D:
  "a \<sim> b" if "A_B.equiv' a b"
  using that unfolding A_B.equiv'_def by auto

lemma equiv'_rotate_1:
  "B_A.equiv' b a" if "A_B.equiv' a b"
  using that by (auto simp: B_A.equiv'_def A_B.equiv'_def)

lemma equiv'_rotate_2:
  "A_B.equiv' a b" if "B_A.equiv' b a"
  using that by (auto simp: B_A.equiv'_def A_B.equiv'_def)

lemma stream_all2_equiv'_D:
  "stream_all2 (\<sim>) xs ys" if "stream_all2 A_B.equiv' xs ys"
  using stream_all2_weaken[OF that equiv'_D] by fast

lemma stream_all2_equiv'_D2:
  "stream_all2 B_A.equiv' ys xs \<Longrightarrow> stream_all2 (\<sim>)\<inverse>\<inverse> ys xs"
  by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def)

lemma stream_all2_rotate_1:
  "stream_all2 B_A.equiv' ys xs \<Longrightarrow> stream_all2 A_B.equiv' xs ys"
  by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def A_B.equiv'_def)

lemma stream_all2_rotate_2:
  "stream_all2 A_B.equiv' xs ys \<Longrightarrow> stream_all2 B_A.equiv' ys xs"
  by (coinduction arbitrary: xs ys) (auto simp: B_A.equiv'_def A_B.equiv'_def)

end (* Bisim Invariant *)

locale Bisimulation_Invariants = Simulation_Defs +
  fixes PA QA :: "'a \<Rightarrow> bool" and PB QB :: "'b \<Rightarrow> bool"
  assumes A_B_step: "\<And> a b a'. A a b \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b'. B a' b' \<and> b \<sim> b')"
  assumes B_A_step: "\<And> a a' b'. B a' b' \<Longrightarrow> a \<sim> a' \<Longrightarrow> PA a \<Longrightarrow> PB a' \<Longrightarrow> (\<exists> b. A a b \<and> b \<sim> b')"
  assumes A_invariant[intro]: "\<And> a b. PA a \<Longrightarrow> A a b \<Longrightarrow> QA b"
  assumes B_invariant[intro]: "\<And> a b. PB a \<Longrightarrow> B a b \<Longrightarrow> QB b"
  assumes PA_QA[intro]: "\<And> a. QA a \<Longrightarrow> PA a" and PB_QB[intro]: "\<And> a. QB a \<Longrightarrow> PB a"
begin

sublocale PA_invariant: Graph_Invariant A PA by standard blast

sublocale PB_invariant: Graph_Invariant B PB by standard blast

sublocale QA_invariant: Graph_Invariant A QA by standard blast

sublocale QB_invariant: Graph_Invariant B QB by standard blast

sublocale Pre_Bisim: Bisimulation_Invariant A B "(\<sim>)" PA PB
  by standard (auto intro: A_B_step B_A_step)

sublocale Post_Bisim: Bisimulation_Invariant A B "(\<sim>)" QA QB
  by standard (auto intro: A_B_step B_A_step)

sublocale A_B: Simulation_Invariants A B "(\<sim>)" PA QA PB QB
  by standard (blast intro: A_B_step)+

sublocale B_A: Simulation_Invariants B A "\<lambda> x y. y \<sim> x" PB QB PA QA
  by standard (blast intro: B_A_step)+

context
  fixes f
  assumes eq[simp]: "a \<sim> b \<longleftrightarrow> b = f a"
    and inj: "\<forall> a b. QB (f a) \<and> QA b \<and> f a = f b \<longrightarrow> a = b"
begin

lemmas list_all2_inj_map_eq = Post_Bisim.list_all2_inj_map_eq[OF eq inj]
lemmas steps_map_equiv' = Post_Bisim.steps_map_equiv[OF eq inj]

lemma steps_map_equiv:
  "A.steps (a # as) \<longleftrightarrow> B.steps (b # map f as)" if "a \<sim> b" "PA a" "PB b"
proof
  assume "A.steps (a # as)"
  then show "B.steps (b # map f as)"
  proof cases
    case Single
    then show ?thesis by auto
  next
    case prems: (Cons a' xs)
    from A_B_step[OF \<open>A a a'\<close> \<open>a \<sim> b\<close> \<open>PA a\<close> \<open>PB b\<close>] obtain b' where "B b b'" "a' \<sim> b'"
      by auto
    with steps_map_equiv'[OF \<open>a' \<sim> b'\<close>, of xs] prems that show ?thesis
      by auto
  qed
next
  assume "B.steps (b # map f as)"
  then show "A.steps (a # as)"
  proof cases
    case Single
    then show ?thesis by auto
  next
    case prems: (Cons b' xs)
    from B_A_step[OF \<open>B b b'\<close> \<open>a \<sim> b\<close> \<open>PA a\<close> \<open>PB b\<close>] obtain a' where "A a a'" "a' \<sim> b'"
      by auto
    with that prems have "QA a'" "QB b'"
      by auto
    with \<open>A a a'\<close> \<open>a' \<sim> b'\<close> steps_map_equiv'[OF \<open>a' \<sim> b'\<close>, of "tl as"] prems that show ?thesis
      apply clarsimp
      subgoal for z zs
        using inj[rule_format, of z a'] by auto
      done
  qed
qed

lemma steps_map:
  "\<exists> as. bs = map f as" if "B.steps (f a # bs)" "PA a" "PB (f a)"
  using that proof cases
  case Single
  then show ?thesis by simp
next
  case prems: (Cons b' xs)
  from B_A_step[OF \<open>B _ b'\<close> _ \<open>PA a\<close> \<open>PB (f a)\<close>] obtain a' where "A a a'" "a' \<sim> b'"
    by auto
  with that prems have "QA a'" "QB b'"
    by auto
  with Post_Bisim.steps_map[OF eq inj, of a' xs] prems \<open>a' \<sim> b'\<close> obtain ys where "xs = map f ys"
    by auto
  with \<open>bs = _\<close> \<open>a' \<sim> b'\<close> show ?thesis
    by (inst_existentials "a' # ys") auto
qed

text \<open>
  @{thm Post_Bisim.reaches_equiv} cannot be lifted directly:
  injectivity cannot be applied for the reflexive case.
\<close>
lemma reaches1_equiv:
  "A.reaches1 a a' \<longleftrightarrow> B.reaches1 (f a) (f a')" if "PA a" "PB (f a)"
proof safe
  assume "A.reaches1 a a'"
  then obtain a'' where prems: "A a a''" "A.reaches a'' a'"
    including graph_automation_aggressive by blast
  from A_B_step[OF \<open>A a _\<close> _ that] obtain b where "B (f a) b" "a'' \<sim> b"
    by auto
  with that prems have "QA a''" "QB b"
    by auto
  with Post_Bisim.reaches_equiv[OF eq inj, of a'' a'] prems \<open>B (f a) b\<close> \<open>a'' \<sim> b\<close>
  show "B.reaches1 (f a) (f a')"
    by auto
next
  assume "B.reaches1 (f a) (f a')"
  then obtain b where prems: "B (f a) b" "B.reaches b (f a')"
    including graph_automation_aggressive by blast
  from B_A_step[OF \<open>B _ b\<close> _ \<open>PA a\<close> \<open>PB (f a)\<close>] obtain a'' where "A a a''" "a'' \<sim> b"
    by auto
  with that prems have "QA a''" "QB b"
    by auto
  with Post_Bisim.reaches_equiv[OF eq inj, of a'' a'] prems \<open>A a a''\<close> \<open>a'' \<sim> b\<close>
  show "A.reaches1 a a'"
    by auto
qed

end (* Context for Equality Relation *)

end (* Bisim Invariant *)

lemma Bisimulation_Invariant_composition:
  assumes
    "Bisimulation_Invariant A B sim1 PA PB"
    "Bisimulation_Invariant B C sim2 PB PC"
  shows
    "Bisimulation_Invariant A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA PC"
proof -
  interpret A: Bisimulation_Invariant A B sim1 PA PB
    by (rule assms(1))
  interpret B: Bisimulation_Invariant B C sim2 PB PC
    by (rule assms(2))
  show ?thesis
    by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
qed

lemma Bisimulation_Invariant_filter:
  assumes
    "Bisimulation_Invariant A B sim PA PB"
    "\<And> a b. sim a b \<Longrightarrow> PA a \<Longrightarrow> PB b \<Longrightarrow> FA a \<longleftrightarrow> FB b"
    "\<And> a b. A a b \<and> FA b \<longleftrightarrow> A' a b"
    "\<And> a b. B a b \<and> FB b \<longleftrightarrow> B' a b"
  shows
    "Bisimulation_Invariant A' B' sim PA PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms(1))
  have unfold:
    "A' = (\<lambda> a b. A a b \<and> FA b)" "B' = (\<lambda> a b. B a b \<and> FB b)"
    using assms(3,4) by auto
  show ?thesis
    unfolding unfold
    apply standard
    using assms(2) apply (blast dest: A_B_step)
    using assms(2) apply (blast dest: B_A_step)
    by blast+
qed

lemma Bisimulation_Invariants_filter:
  assumes
    "Bisimulation_Invariants A B sim PA QA PB QB"
    "\<And> a b. QA a \<Longrightarrow> QB b \<Longrightarrow> FA a \<longleftrightarrow> FB b"
    "\<And> a b. A a b \<and> FA b \<longleftrightarrow> A' a b"
    "\<And> a b. B a b \<and> FB b \<longleftrightarrow> B' a b"
  shows
    "Bisimulation_Invariants A' B' sim PA QA PB QB"
proof -
  interpret Bisimulation_Invariants A B sim PA QA PB QB
    by (rule assms(1))
  have unfold:
    "A' = (\<lambda> a b. A a b \<and> FA b)" "B' = (\<lambda> a b. B a b \<and> FB b)"
    using assms(3,4) by auto
  show ?thesis
    unfolding unfold
    apply standard
    using assms(2) apply (blast dest: A_B_step)
    using assms(2) apply (blast dest: B_A_step)
    by blast+
qed

lemma Bisimulation_Invariants_composition:
  assumes
    "Bisimulation_Invariants A B sim1 PA QA PB QB"
    "Bisimulation_Invariants B C sim2 PB QB PC QC"
  shows
    "Bisimulation_Invariants A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA QA PC QC"
proof -
  interpret A: Bisimulation_Invariants A B sim1 PA QA PB QB
    by (rule assms(1))
  interpret B: Bisimulation_Invariants B C sim2 PB QB PC QC
    by (rule assms(2))
  show ?thesis
    by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
qed

lemma Bisimulation_Invariant_Invariants_composition:
  assumes
    "Bisimulation_Invariant A B sim1 PA PB"
    "Bisimulation_Invariants B C sim2 PB QB PC QC"
  shows
    "Bisimulation_Invariants A C (\<lambda> a c. \<exists> b. PB b \<and> sim1 a b \<and> sim2 b c) PA PA PC QC"
proof -
  interpret Bisimulation_Invariant A B sim1 PA PB
    by (rule assms(1))
  interpret B: Bisimulation_Invariants B C sim2 PB QB PC QC
    by (rule assms(2))
  interpret A: Bisimulation_Invariants A B sim1 PA PA PB QB
    by (standard; blast intro: A_B_step B_A_step)+
  show ?thesis
    by (standard; (blast dest: A.A_B_step B.A_B_step | blast dest: A.B_A_step B.B_A_step))
qed

lemma Bisimulation_Invariant_Bisimulation_Invariants:
  assumes "Bisimulation_Invariant A B sim PA PB"
  shows "Bisimulation_Invariants A B sim PA PA PB PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step B_A_step)
qed

lemma Bisimulation_Invariant_strengthen_post:
  assumes
    "Bisimulation_Invariant A B sim PA PB"
    "\<And> a b. PA' a \<Longrightarrow> PA b \<Longrightarrow> A a b \<Longrightarrow> PA' b"
    "\<And> a. PA' a \<Longrightarrow> PA a"
  shows "Bisimulation_Invariant A B sim PA' PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step B_A_step assms)
qed

lemma Bisimulation_Invariant_strengthen_post':
  assumes
    "Bisimulation_Invariant A B sim PA PB"
    "\<And> a b. PB' a \<Longrightarrow> PB b \<Longrightarrow> B a b \<Longrightarrow> PB' b"
    "\<And> a. PB' a \<Longrightarrow> PB a"
  shows "Bisimulation_Invariant A B sim PA PB'"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step B_A_step assms)
qed

lemma Simulation_Invariant_strengthen_post:
  assumes
    "Simulation_Invariant A B sim PA PB"
    "\<And> a b. PA a \<Longrightarrow> PA b \<Longrightarrow> A a b \<Longrightarrow> PA' b"
    "\<And> a. PA' a \<Longrightarrow> PA a"
  shows "Simulation_Invariant A B sim PA' PB"
proof -
  interpret Simulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step assms)
qed

lemma Simulation_Invariant_strengthen_post':
  assumes
    "Simulation_Invariant A B sim PA PB"
    "\<And> a b. PB a \<Longrightarrow> PB b \<Longrightarrow> B a b \<Longrightarrow> PB' b"
    "\<And> a. PB' a \<Longrightarrow> PB a"
  shows "Simulation_Invariant A B sim PA PB'"
proof -
  interpret Simulation_Invariant A B sim PA PB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step assms)
qed

lemma Simulation_Invariants_strengthen_post:
  assumes
    "Simulation_Invariants A B sim PA QA PB QB"
    "\<And> a b. PA a \<Longrightarrow> QA b \<Longrightarrow> A a b \<Longrightarrow> QA' b"
    "\<And> a. QA' a \<Longrightarrow> QA a"
  shows "Simulation_Invariants A B sim PA QA' PB QB"
proof -
  interpret Simulation_Invariants A B sim PA QA PB QB
    by (rule assms)
  show ?thesis
    by (standard; blast intro: A_B_step assms)
qed

lemma Bisimulation_Invariant_sim_replace:
  assumes "Bisimulation_Invariant A B sim PA PB"
      and "\<And> a b. PA a \<Longrightarrow> PB b \<Longrightarrow> sim a b \<longleftrightarrow> sim' a b"
    shows "Bisimulation_Invariant A B sim' PA PB"
proof -
  interpret Bisimulation_Invariant A B sim PA PB
    by (rule assms(1))
  show ?thesis
    apply standard
    using assms(2) apply (blast dest: A_B_step)
    using assms(2) apply (blast dest: B_A_step)
    by blast+
qed

end (* Theory *)


(*  Title:      Imperative_HOL_Time/SepLogicTime/SLTC.thy
    Author:     Maximilian P. L. Haslbeck & Bohua Zhan, TU Muenchen
*)

text \<open>The development here follows Separation_Logic_Imperative_HOL
   (by Lammich and Meis) in the AFP \<close>

theory SLTC
  imports Auto2_Imperative_HOL.SepLogic_Base "../Imperative_HOL_Time"
begin

section \<open>Partial Heaps\<close>

datatype pheap = pHeap (heapOf: heap) (addrOf: "addr set") (timeOf: nat)
setup \<open>add_simple_datatype "pheap"\<close>

fun in_range :: "(heap \<times> addr set) \<Rightarrow> bool" where
  "in_range (h,as) \<longleftrightarrow> (\<forall>a\<in>as. a < lim h)"
setup \<open>add_rewrite_rule @{thm in_range.simps}\<close>

(* Two heaps agree on a set of addresses. *)
definition relH :: "addr set \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> bool" where [rewrite]:
  "relH as h h' = (in_range (h, as) \<and> in_range (h', as) \<and>
     (\<forall>t. \<forall>a\<in>as. refs h t a = refs h' t a \<and> arrays h t a = arrays h' t a))"

lemma relH_D [forward]:
  "relH as h h' \<Longrightarrow> in_range (h, as) \<and> in_range (h', as)" by auto2

lemma relH_D2 [rewrite]:
  "relH as h h' \<Longrightarrow> a \<in> as \<Longrightarrow> refs h t a = refs h' t a"
  "relH as h h' \<Longrightarrow> a \<in> as \<Longrightarrow> arrays h t a = arrays h' t a" by auto2+
setup \<open>del_prfstep_thm_eqforward @{thm relH_def}\<close>

lemma relH_dist_union [forward]:
  "relH (as \<union> as') h h' \<Longrightarrow> relH as h h' \<and> relH as' h h'" by auto2

lemma relH_ref [rewrite]:
  "relH as h h' \<Longrightarrow> addr_of_ref r \<in> as \<Longrightarrow> Ref_Time.get h r = Ref_Time.get h' r"
  by (simp add: Ref_Time.get_def relH_def)

lemma relH_array [rewrite]:
  "relH as h h' \<Longrightarrow> addr_of_array r \<in> as \<Longrightarrow> Array_Time.get h r = Array_Time.get h' r"
  by (simp add: Array_Time.get_def relH_def)

lemma relH_set_ref [resolve]:
  "relH {a. a < lim h \<and> a \<notin> {addr_of_ref r}} h (Ref_Time.set r x h)"
  by (simp add: Ref_Time.set_def relH_def)

lemma relH_set_array [resolve]:
  "relH {a. a < lim h \<and> a \<notin> {addr_of_array r}} h (Array_Time.set r x h)"
  by (simp add: Array_Time.set_def relH_def)

section \<open>Assertions\<close>

datatype assn_raw = Assn (assn_fn: "pheap \<Rightarrow> bool")

fun aseval :: "assn_raw \<Rightarrow> pheap \<Rightarrow> bool" where
  "aseval (Assn f) h = f h"
setup \<open>add_rewrite_rule @{thm aseval.simps}\<close>

definition proper :: "assn_raw \<Rightarrow> bool" where [rewrite]:
  "proper P = (
    (\<forall>h as n. aseval P (pHeap h as n) \<longrightarrow> in_range (h,as)) \<and>
    (\<forall>h h' as n. aseval P (pHeap h as n) \<longrightarrow> relH as h h' \<longrightarrow> in_range (h',as) \<longrightarrow> aseval P (pHeap h' as n)))"

fun in_range_assn :: "pheap \<Rightarrow> bool" where
  "in_range_assn (pHeap h as n) \<longleftrightarrow> (\<forall>a\<in>as. a < lim h)"
setup \<open>add_rewrite_rule @{thm in_range_assn.simps}\<close>

typedef assn = "Collect proper"
@proof @have "Assn in_range_assn \<in> Collect proper" @qed

setup \<open>add_rewrite_rule @{thm Rep_assn_inject}\<close>
setup \<open>register_wellform_data ("Abs_assn P", ["proper P"])\<close>
setup \<open>add_prfstep_check_req ("Abs_assn P", "proper P")\<close>

lemma Abs_assn_inverse' [rewrite]: "proper y \<Longrightarrow> Rep_assn (Abs_assn y) = y"
  by (simp add: Abs_assn_inverse)

lemma proper_Rep_assn [forward]: "proper (Rep_assn P)" using Rep_assn by auto

definition models :: "pheap \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Turnstile>" 50) where [rewrite_bidir]:
  "h \<Turnstile> P \<longleftrightarrow> aseval (Rep_assn P) h"

lemma models_in_range [resolve]: "pHeap h as n \<Turnstile> P \<Longrightarrow> in_range (h,as)" by auto2

lemma mod_relH [forward]: "relH as h h' \<Longrightarrow> pHeap h as n \<Turnstile> P \<Longrightarrow> pHeap h' as n \<Turnstile> P" by auto2

instantiation assn :: one begin
definition one_assn :: assn where [rewrite]:
  "1 \<equiv> Abs_assn (Assn (\<lambda>h. timeOf h = 0 \<and> addrOf h = {}))"
instance .. end

abbreviation one_assn :: assn ("emp") where "one_assn \<equiv> 1"

lemma one_assn_rule [rewrite]: "h \<Turnstile> emp \<longleftrightarrow> timeOf h = 0 \<and> addrOf h = {}" by auto2
setup \<open>del_prfstep_thm @{thm one_assn_def}\<close>

section \<open>Definition of $\<close>

definition timeCredit_assn :: "nat \<Rightarrow> assn" ("$") where [rewrite]:
  "timeCredit_assn n = Abs_assn (Assn (\<lambda>h. timeOf h = n \<and> addrOf h = {}))"

lemma timeCredit_assn_rule [rewrite]: "h \<Turnstile> $n \<longleftrightarrow> timeOf h = n \<and> addrOf h = {}" by auto2
setup \<open>del_prfstep_thm @{thm timeCredit_assn_def}\<close>

instantiation assn :: times begin
definition times_assn where [rewrite]:
  "P * Q = Abs_assn (Assn (
    \<lambda>h. (\<exists>as1 as2 n1 n2. addrOf h = as1 \<union> as2 \<and> as1 \<inter> as2 = {} \<and> timeOf h = n1 + n2 \<and>
         aseval (Rep_assn P) (pHeap (heapOf h) as1 n1) \<and> aseval (Rep_assn Q) (pHeap (heapOf h) as2 n2))))"
instance .. end

lemma mod_star_convE [backward]:
  "pHeap h as n \<Turnstile> A * B \<Longrightarrow>
   \<exists>as1 as2 n1 n2. as = as1 \<union> as2 \<and> as1 \<inter> as2 = {} \<and> n = n1 + n2 \<and> pHeap h as1 n1 \<Turnstile> A \<and> pHeap h as2 n2 \<Turnstile> B" by auto2

lemma mod_star_convI [backward]:
  "as1 \<inter> as2 = {} \<Longrightarrow> pHeap h as1 n1 \<Turnstile> A \<Longrightarrow> pHeap h as2 n2 \<Turnstile> B \<Longrightarrow>
   pHeap h (as1 \<union> as2) (n1 + n2) \<Turnstile> A * B" by auto2
setup \<open>del_prfstep_thm @{thm times_assn_def}\<close>

lemma aseval_ext [backward]: "\<forall>h. aseval P h = aseval P' h \<Longrightarrow> P = P'"
  apply (cases P) apply (cases P') by auto

lemma assn_ext: "\<forall>h as n. pHeap h as n \<Turnstile> P \<longleftrightarrow> pHeap h as n \<Turnstile> Q \<Longrightarrow> P = Q"
@proof @have "Rep_assn P = Rep_assn Q" @qed
setup \<open>add_backward_prfstep_cond @{thm assn_ext} [with_filt (order_filter "P" "Q")]\<close>

setup \<open>del_prfstep_thm @{thm aseval_ext}\<close>

lemma assn_one_left: "emp * P = (P::assn)"
@proof
  @have "\<forall>h as n. pHeap h as n \<Turnstile> P \<longleftrightarrow> pHeap h as n \<Turnstile> emp * P" @with
    @case "pHeap h as n \<Turnstile> P" @with
      @have "as = {} \<union> as"
      @have "n = 0 + n"
    @end
    @case "pHeap h as n \<Turnstile> 1 * P" @with
      @obtain as1 as2 n1 n2 where
        "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> emp" "pHeap h as2 n2 \<Turnstile> P"
    @end
  @end
@qed

lemma assn_times_comm: "P * Q = Q * (P::assn)"
@proof
  @have "\<forall>h as n. pHeap h as n \<Turnstile> P * Q \<longleftrightarrow> pHeap h as n \<Turnstile> Q * P" @with
    @case "pHeap h as n \<Turnstile> P * Q" @with
      @obtain as1 as2 n1 n2 where
        "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> P" "pHeap h as2 n2 \<Turnstile> Q"
      @have "as = as2 \<union> as1" @have "n = n2 + n1"
    @end
    @case "pHeap h as n \<Turnstile> Q * P" @with
      @obtain as1 as2 n1 n2 where
        "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> Q" "pHeap h as2 n2 \<Turnstile> P"
      @have "as = as2 \<union> as1" @have "n = n2 + n1"
    @end
  @end
@qed

lemma assn_times_assoc: "(P * Q) * R = P * (Q * (R::assn))"
@proof
  @have "\<forall>h as n. pHeap h as n \<Turnstile> (P * Q) * R \<longleftrightarrow> pHeap h as n \<Turnstile> P * (Q * R)" @with
    @case "pHeap h as n \<Turnstile> (P * Q) * R" @with
      @obtain as1 as2 n1 n2 where
        "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> P * Q" "pHeap h as2 n2 \<Turnstile> R"
      @obtain as11 as12 n11 n12 where
        "as1 = as11 \<union> as12" "as11 \<inter> as12 = {}" "n1 = n11 + n12" "pHeap h as11 n11 \<Turnstile> P" "pHeap h as12 n12 \<Turnstile> Q"
      @have "pHeap h (as12 \<union> as2) (n12 + n2) \<Turnstile> Q * R"
      @have "as = as11 \<union> (as12 \<union> as2)" @have "n = n11 + (n12 + n2)"
    @end
    @case "pHeap h as n \<Turnstile> P * (Q * R)" @with
      @obtain as1 as2 n1 n2 where
        "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> P" "pHeap h as2 n2 \<Turnstile> (Q * R)"
      @obtain as21 as22 n21 n22 where
        "as2 = as21 \<union> as22" "as21 \<inter> as22 = {}" "n2 = n21 + n22" "pHeap h as21 n21 \<Turnstile> Q" "pHeap h as22 n22 \<Turnstile> R"
      @have "pHeap h (as1 \<union> as21) (n1 + n21) \<Turnstile> P * Q"
      @have "as = (as1 \<union> as21) \<union> as22" @have "n = (n1 + n21) + n22"
    @end
  @end
@qed

instantiation assn :: comm_monoid_mult begin
  instance apply standard
  apply (rule assn_times_assoc) apply (rule assn_times_comm) by (rule assn_one_left)
end

subsection \<open>Existential Quantification\<close>

definition ex_assn :: "('a \<Rightarrow> assn) \<Rightarrow> assn" (binder "\<exists>\<^sub>A" 11) where [rewrite]:
  "(\<exists>\<^sub>Ax. P x) = Abs_assn (Assn (\<lambda>h. \<exists>x. h \<Turnstile> P x))"

lemma mod_ex_dist [rewrite]: "(h \<Turnstile> (\<exists>\<^sub>Ax. P x)) \<longleftrightarrow> (\<exists>x. h \<Turnstile> P x)" by auto2
setup \<open>del_prfstep_thm @{thm ex_assn_def}\<close>

lemma ex_distrib_star: "(\<exists>\<^sub>Ax. P x * Q) = (\<exists>\<^sub>Ax. P x) * Q"
@proof
  @have "\<forall>h as n. pHeap h as n \<Turnstile> (\<exists>\<^sub>Ax. P x) * Q \<longleftrightarrow> pHeap h as n \<Turnstile> (\<exists>\<^sub>Ax. P x * Q)" @with
    @case "pHeap h as n \<Turnstile> (\<exists>\<^sub>Ax. P x) * Q" @with
      @obtain as1 as2 n1 n2 where
        "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> (\<exists>\<^sub>Ax. P x)" "pHeap h as2 n2 \<Turnstile> Q"
      @obtain x where "pHeap h as1 n1 \<Turnstile> P x"
      @have "pHeap h as n \<Turnstile> P x * Q"
    @end
    @case "pHeap h as n \<Turnstile> (\<exists>\<^sub>Ax. P x * Q)" @with
      @obtain x where "pHeap h as n \<Turnstile> P x * Q"
      @obtain as1 as2 n1 n2 where
        "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> P x" "pHeap h as2 n2 \<Turnstile> Q"
    @end
  @end
@qed

subsection \<open>Disjunction\<close>

definition or_assn :: "assn \<Rightarrow> assn \<Rightarrow> assn" (infixr "\<or>\<^sub>A" 61)  where [rewrite]:
  "A \<or>\<^sub>A B = Abs_assn (Assn (\<lambda>h. h\<Turnstile>A \<or> h\<Turnstile>B ) )"

lemma or_assn_conv: "h \<Turnstile> A \<or>\<^sub>A B \<longleftrightarrow> (h \<Turnstile> A \<or> h \<Turnstile> B)" by auto2

subsection \<open>Conjunction\<close>

definition and_assn :: "assn \<Rightarrow> assn \<Rightarrow> assn" (infixr "\<and>\<^sub>A" 61)  where [rewrite]:
  "A \<and>\<^sub>A B = Abs_assn (Assn (\<lambda>h. h\<Turnstile>A \<and> h\<Turnstile>B ) )"

lemma and_assn_conv: "h \<Turnstile> A \<and>\<^sub>A B \<longleftrightarrow> (h \<Turnstile> A \<and> h \<Turnstile> B)" by auto2

subsection \<open>Pointers\<close>

definition sngr_assn :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> assn" (infix "\<mapsto>\<^sub>r" 82) where [rewrite]:
  "r \<mapsto>\<^sub>r x = Abs_assn (Assn (
    \<lambda>h. timeOf h = 0 \<and> Ref_Time.get (heapOf h) r = x \<and> addrOf h = {addr_of_ref r} \<and> addr_of_ref r < lim (heapOf h)))"

lemma sngr_assn_rule [rewrite]:
  "pHeap h as n \<Turnstile> r \<mapsto>\<^sub>r x \<longleftrightarrow>
      n = 0 \<and> Ref_Time.get h r = x \<and> as = {addr_of_ref r} \<and> addr_of_ref r < lim h" by auto2
setup \<open>del_prfstep_thm @{thm sngr_assn_def}\<close>

definition snga_assn :: "'a::heap array \<Rightarrow> 'a list \<Rightarrow> assn" (infix "\<mapsto>\<^sub>a" 82) where [rewrite]:
  "r \<mapsto>\<^sub>a x = Abs_assn (Assn (
    \<lambda>h. timeOf h = 0 \<and> Array_Time.get (heapOf h) r = x \<and> addrOf h = {addr_of_array r} \<and> addr_of_array r < lim (heapOf h)))"

lemma snga_assn_rule [rewrite]:
  "pHeap h as n \<Turnstile> r \<mapsto>\<^sub>a x \<longleftrightarrow>
      (n = 0 \<and> Array_Time.get h r = x \<and> as = {addr_of_array r} \<and> addr_of_array r < lim h)" by auto2
setup \<open>del_prfstep_thm @{thm snga_assn_def}\<close>

subsection \<open>Pure Assertions\<close>

definition pure_assn :: "bool \<Rightarrow> assn" ("\<up>") where [rewrite]:
  "\<up>b = Abs_assn (Assn (\<lambda>h. addrOf h = {} \<and> timeOf h = 0 \<and> b))"

lemma pure_assn_rule [rewrite]: "h \<Turnstile> \<up>b \<longleftrightarrow> (addrOf h = {} \<and> timeOf h = 0 \<and> b)" by auto2
setup \<open>del_prfstep_thm @{thm pure_assn_def}\<close>

definition top_assn :: assn ("true") where [rewrite]:
  "top_assn = Abs_assn (Assn in_range_assn)"

lemma top_assn_rule [rewrite]: "pHeap h as n \<Turnstile> true \<longleftrightarrow> in_range (h, as)" by auto2
setup \<open>del_prfstep_thm @{thm top_assn_def}\<close>

setup \<open>del_prfstep_thm @{thm models_def}\<close>

subsection \<open>Properties of assertions\<close>

abbreviation bot_assn :: assn ("false") where "bot_assn \<equiv> \<up>False"

setup \<open>add_forward_prfstep @{thm mod_star_convE}\<close>

lemma mod_false' [resolve]: "\<not>(h \<Turnstile> false * R)" by auto2

lemma top_assn_reduce: "true * true = true"
@proof
  @have "\<forall>h. h \<Turnstile> true * true \<longleftrightarrow> h \<Turnstile> true" @with
    @have "addrOf h = addrOf h \<union> {}"
    @have "timeOf h = timeOf h + 0"
  @end
@qed

lemma mod_pure_star_dist [rewrite]:
  "h \<Turnstile> P * \<up>b \<longleftrightarrow> h \<Turnstile> P \<and> b"
@proof
  @case "h \<Turnstile> P \<and> b" @with
    @have "addrOf h = addrOf h \<union> {}"
    @have "timeOf h = timeOf h + 0"
  @end
@qed

lemma mod_timeCredit_dest [rewrite]:
  "pHeap h as n \<Turnstile> P * $m \<longleftrightarrow> pHeap h as (n - m) \<Turnstile> P \<and> n \<ge> m"
@proof
  @case "pHeap h as (n - m) \<Turnstile> P \<and> n \<ge> m" @with
    @have "as = as \<union> {}"
    @have "n = (n - m) + m"
  @end
@qed

lemma pure_conj:  "\<up>(P \<and> Q) = \<up>P * \<up>Q" by auto2

subsection \<open>Theorems for time credits\<close>

lemma time_credit_add [resolve]: "$(m + n) = $m * $n" by auto2

subsection \<open>Entailment and its properties\<close>

definition entails :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Longrightarrow>\<^sub>A" 10) where [rewrite]:
  "(P \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<forall>h. h \<Turnstile> P \<longrightarrow> h \<Turnstile> Q)"

lemma entails_triv: "A \<Longrightarrow>\<^sub>A A" by auto2
lemma entails_true: "A \<Longrightarrow>\<^sub>A true" by auto2
lemma entails_frame [backward]: "P \<Longrightarrow>\<^sub>A Q \<Longrightarrow> P * R \<Longrightarrow>\<^sub>A Q * R" by auto2
lemma entails_frame': "\<not> (A * F \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<not> (B * F \<Longrightarrow>\<^sub>A Q)" by auto2
lemma entails_frame'': "\<not> (P \<Longrightarrow>\<^sub>A B * F) \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<not> (P \<Longrightarrow>\<^sub>A A * F)" by auto2
lemma entails_equiv_forward: "P = Q \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q" by auto2
lemma entails_equiv_backward: "P = Q \<Longrightarrow> Q \<Longrightarrow>\<^sub>A P" by auto2
lemma entailsD [forward]: "P \<Longrightarrow>\<^sub>A Q \<Longrightarrow> h \<Turnstile> P \<Longrightarrow> h \<Turnstile> Q" by auto2
lemma entailsD': "P \<Longrightarrow>\<^sub>A Q \<Longrightarrow> h \<Turnstile> P * R \<Longrightarrow> h \<Turnstile> Q * R" by auto2
lemma entails_trans2: "A \<Longrightarrow>\<^sub>A D * B \<Longrightarrow> B \<Longrightarrow>\<^sub>A C \<Longrightarrow> A \<Longrightarrow>\<^sub>A D * C" by auto2

lemma gc_time: "a\<ge>b \<Longrightarrow> $a \<Longrightarrow>\<^sub>A $b * true"
@proof @have "$a = $b * $(a-b)" @qed

lemma entails_pure': "\<not>(\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<not>(emp \<Longrightarrow>\<^sub>A Q) \<and> b)" by auto2
lemma entails_pure: "\<not>(P * \<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<not>(P \<Longrightarrow>\<^sub>A Q) \<and> b)" by auto2
lemma entails_ex: "\<not>((\<exists>\<^sub>Ax. P x) \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<exists>x. \<not>(P x \<Longrightarrow>\<^sub>A Q))" by auto2
lemma entails_ex_post: "\<not>(P \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. Q x)) \<Longrightarrow> \<forall>x. \<not>(P \<Longrightarrow>\<^sub>A Q x)" by auto2
lemma entails_pure_post: "\<not>(P \<Longrightarrow>\<^sub>A Q * \<up>b) \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q \<Longrightarrow> \<not>b" by auto2

setup \<open>del_prfstep_thm @{thm entails_def}\<close>

definition time_credit_ge :: "nat \<Rightarrow> nat \<Rightarrow> bool" (infix "\<ge>\<^sub>t" 60) where
  "a \<ge>\<^sub>t b \<longleftrightarrow> a \<ge> b"
setup \<open>add_backward_prfstep (equiv_backward_th @{thm time_credit_ge_def})\<close>

lemma gc_time': "a \<ge>\<^sub>t b \<Longrightarrow> R * $(a + p) \<Longrightarrow>\<^sub>A R * $(b + p) * true"
  by (smt assn_times_assoc assn_times_comm entails_frame gc_time time_credit_add time_credit_ge_def)

lemma gc_time'': "a \<ge>\<^sub>t b \<Longrightarrow> $(a + p) \<Longrightarrow>\<^sub>A $(b + p) * true"
  by (smt add.commute add.right_neutral gc_time' time_credit_add)

section \<open>Setup for timeFrame\<close>

setup \<open>fold add_rewrite_rule @{thms timeFrame.simps}\<close>

lemma timeFrame_reduceNone [forward]: "timeFrame n f = None \<Longrightarrow> f = None" by auto2

lemma timeFrame_reduceSome [forward]: "timeFrame n f = (Some (r,h,t)) \<Longrightarrow> f = Some (r,h,t-n) \<and> t\<ge>n"
@proof @case "f = None" @qed

lemma zero_time: "$0 = emp" by auto2

section \<open>Definition of the run predicate\<close>

inductive run :: "'a Heap \<Rightarrow> heap option \<Rightarrow> heap option \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> bool" where
  "run c None None r n"
| "execute c h = None \<Longrightarrow> run c (Some h) None r n"
| "execute c h = Some (r, h', n) \<Longrightarrow> run c (Some h) (Some h') r n"
setup \<open>add_case_induct_rule @{thm run.cases}\<close>
setup \<open>fold add_resolve_prfstep @{thms run.intros(1,2)}\<close>
setup \<open>add_forward_prfstep @{thm run.intros(3)}\<close>

lemma run_complete [resolve]:
  "\<exists>\<sigma>' r n. run c \<sigma> \<sigma>' (r::'a) n"
@proof
  @obtain "r::'a" where "r = r"
  @case "\<sigma> = None" @with @have "run c None None r 0" @end
  @case "execute c (the \<sigma>) = None" @with @have "run c \<sigma> None r 0" @end
@qed

lemma run_to_execute [forward]:
  "run c (Some h) \<sigma>' r n \<Longrightarrow> if \<sigma>' = None then execute c h = None else execute c h = Some (r, the \<sigma>', n)"
@proof @case_induct "run c (Some h) \<sigma>' r n" @qed

setup \<open>add_rewrite_rule @{thm execute_bind(1)}\<close>
lemma runE [forward]:
  "run f (Some h) (Some h') r' t1 \<Longrightarrow> run (f \<bind> g) (Some h) \<sigma> r t \<Longrightarrow> run (g r') (Some h') \<sigma> r (t-t1)" by auto2

setup \<open>add_rewrite_rule @{thm Array_Time.get_alloc}\<close>
setup \<open>add_rewrite_rule @{thm Ref_Time.get_alloc}\<close>
setup \<open>add_rewrite_rule_bidir @{thm Array_Time.length_def}\<close>

section \<open>Definition of hoare triple, and the frame rule.\<close>

definition new_addrs :: "heap \<Rightarrow> addr set \<Rightarrow> heap \<Rightarrow> addr set" where [rewrite]:
  "new_addrs h as h' = as \<union> {a. lim h \<le> a \<and> a < lim h'}"

definition hoare_triple :: "assn \<Rightarrow> 'a Heap \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bool" ("<_>/ _/ <_>") where [rewrite]:
  "<P> c <Q> \<longleftrightarrow> (\<forall>h as \<sigma> r n t. pHeap h as n \<Turnstile> P \<longrightarrow> run c (Some h) \<sigma> r t \<longrightarrow>
    (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n-t) \<Turnstile> Q r \<and> n\<ge>t \<and> relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and>
     lim h \<le> lim (the \<sigma>)))"

lemma hoare_tripleD [forward]:
  "<P> c <Q> \<Longrightarrow> run c (Some h) \<sigma> r t \<Longrightarrow> \<forall>as n. pHeap h as n \<Turnstile> P \<longrightarrow>
    (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n-t) \<Turnstile> Q r \<and> n\<ge>t \<and> relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and>
     lim h \<le> lim (the \<sigma>))" by auto2
setup \<open>del_prfstep_thm_eqforward @{thm hoare_triple_def}\<close>

abbreviation hoare_triple' :: "assn \<Rightarrow> 'r Heap \<Rightarrow> ('r \<Rightarrow> assn) \<Rightarrow> bool" ("<_> _ <_>\<^sub>t") where
  "<P> c <Q>\<^sub>t \<equiv> <P> c <\<lambda>r. Q r * true>"

lemma frame_rule [backward]:
  "<P> c <Q> \<Longrightarrow> <P * R> c <\<lambda>x. Q x * R>"
@proof
  @have "\<forall>h as \<sigma> r n t. pHeap h as n \<Turnstile> P * R \<longrightarrow> run c (Some h) \<sigma> r t \<longrightarrow>
                    (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n-t) \<Turnstile> Q r * R \<and> n\<ge>t \<and>
                     relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and> lim h \<le> lim (the \<sigma>))" @with
    @obtain as1 as2 n1 n2 where
      "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "n = n1 + n2" "pHeap h as1 n1 \<Turnstile> P" "pHeap h as2 n2 \<Turnstile> R"
    @have "relH as2 h (the \<sigma>)"
    @have "new_addrs h as (the \<sigma>) = new_addrs h as1 (the \<sigma>) \<union> as2"
    @have "n - t = (n1 - t) + n2"
  @end
@qed

(* This is the last use of the definition of separating conjunction. *)
setup \<open>fold del_prfstep_thm [@{thm mod_star_convI}, @{thm mod_star_convE}]\<close>

lemma bind_rule:
  "<P> f <Q> \<Longrightarrow> \<forall>x. <Q x> g x <R> \<Longrightarrow> <P> f \<bind> g <R>"
@proof
  @have "\<forall>h as \<sigma> r n t. pHeap h as n \<Turnstile> P \<longrightarrow> run (f \<bind> g) (Some h) \<sigma> r t \<longrightarrow>
                    (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n-t) \<Turnstile> R r \<and> n\<ge>t \<and>
                     relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and> lim h \<le> lim (the \<sigma>))" @with
    (* First step from h to h' *)
    @obtain \<sigma>' r' t' where "run f (Some h) \<sigma>' r' t'"
    @obtain h' where "\<sigma>' = Some h'"
    @let "as' = new_addrs h as h'"
    @have "pHeap h' as' (n-t') \<Turnstile> Q r'"

    (* Second step from h' to h'' *)
    @obtain h'' where "\<sigma> = Some h''"
    @let "as'' = new_addrs h' as' h''"
    @have "pHeap h'' as'' (n-t) \<Turnstile> R r \<and> n\<ge>t"
    @have "as'' = new_addrs h as h''"
  @end
@qed

(* Actual statement used: *)
lemma bind_rule':
  "<P> f <Q> \<Longrightarrow> \<not> <P> f \<bind> g <R> \<Longrightarrow> \<exists>x. \<not> <Q x> g x <R>" using bind_rule by blast

lemma pre_rule':
  "\<not> <P * R> f <Q> \<Longrightarrow> P \<Longrightarrow>\<^sub>A P' \<Longrightarrow> \<not> <P' * R> f <Q>"
@proof @have "P * R \<Longrightarrow>\<^sub>A P' * R" @qed

lemma pre_rule:
  "P'\<Longrightarrow>\<^sub>A P \<Longrightarrow> <P> f <Q> \<Longrightarrow> <P' > f <Q>"
@proof @qed

lemma pre_rule'':
  "<P> f <Q> \<Longrightarrow> P' \<Longrightarrow>\<^sub>A P * R \<Longrightarrow> <P'> f <\<lambda>x. Q x * R>"
@proof @have "<P * R> f <\<lambda>x. Q x * R>" @qed

lemma pre_ex_rule:
  "\<not> <\<exists>\<^sub>Ax. P x> f <Q> \<longleftrightarrow> (\<exists>x. \<not> <P x> f <Q>)" by auto2

lemma pre_pure_rule:
  "\<not> <P * \<up>b> f <Q> \<longleftrightarrow> \<not> <P> f <Q> \<and> b" by auto2

lemma pre_pure_rule':
  "\<not> <\<up>b> f <Q> \<longleftrightarrow> \<not> <emp> f <Q> \<and> b" by auto2

lemma post_rule:
  "<P> f <Q> \<Longrightarrow> \<forall>x. Q x \<Longrightarrow>\<^sub>A R x \<Longrightarrow> <P> f <R>" by auto2

declare gc_time' [backward]
declare gc_time'' [backward]
lemma gc_time_hoare': "a \<ge>\<^sub>t b \<Longrightarrow> \<not><R * $(a + p)> c <Q> \<Longrightarrow> \<not><R * $(b + p) * true> c <Q>"
@proof @have "R * $(a+p) \<Longrightarrow>\<^sub>A R * $(b+p) * true" @qed

lemma gc_time_hoare'': "a \<ge>\<^sub>t b \<Longrightarrow> \<not><$(a + p)> c <Q> \<Longrightarrow> \<not><$(b + p) * true> c <Q>"
@proof @have "$(a+p) \<Longrightarrow>\<^sub>A $(b+p) * true" @qed
setup \<open>del_prfstep_thm @{thm gc_time'}\<close>
setup \<open>del_prfstep_thm @{thm gc_time''}\<close>

setup \<open>fold del_prfstep_thm [@{thm entailsD}, @{thm entails_frame}, @{thm frame_rule}]\<close>

(* Actual statement used: *)
lemma post_rule':
  "<P> f <Q> \<Longrightarrow> \<not> <P> f <R> \<Longrightarrow> \<exists>x. \<not> (Q x \<Longrightarrow>\<^sub>A R x)" using post_rule by blast

lemma norm_pre_pure_iff: "<P * \<up>b> c <Q> \<longleftrightarrow> (b \<longrightarrow> <P> c <Q>)" by auto2
lemma norm_pre_pure_iff2: "<\<up>b> c <Q> \<longleftrightarrow> (b \<longrightarrow> <emp> c <Q>)" by auto2

section \<open>Hoare triples for atomic commands\<close>

(* First, those that do not modify the heap. *)
setup \<open>add_rewrite_rule @{thm execute_assert(1)}\<close>
lemma assert_rule:
  "<\<up>(R x) * $1> assert R x <\<lambda>r. \<up>(r = x)>" by auto2

lemma execute_return' [rewrite]: "execute (return x) h = Some (x, h, 1)" by (metis comp_eq_dest_lhs execute_return)
lemma return_rule:
  "<$1> return x <\<lambda>r. \<up>(r = x)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_nth(1)}\<close>
lemma nth_rule:
  "<a \<mapsto>\<^sub>a xs * $1 * \<up>(i < length xs)> Array_Time.nth a i <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs ! i)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_len}\<close>
lemma length_rule:
  "<a \<mapsto>\<^sub>a xs * $1> Array_Time.len a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = length xs)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_lookup}\<close>
lemma lookup_rule:
  "<p \<mapsto>\<^sub>r x * $1> !p <\<lambda>r. p \<mapsto>\<^sub>r x * \<up>(r = x)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_freeze}\<close>
lemma freeze_rule:
  "<a \<mapsto>\<^sub>a xs * $(1 + length xs)> Array_Time.freeze a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs)>" by auto2

(* Next, the update rules. *)
setup \<open>add_rewrite_rule @{thm Ref_Time.lim_set}\<close>
lemma Array_lim_set [rewrite]: "lim (Array_Time.set p xs h) = lim h" by (simp add: Array_Time.set_def)

setup \<open>fold add_rewrite_rule [@{thm Ref_Time.get_set_eq}, @{thm Array_Time.get_set_eq}]\<close>
setup \<open>add_rewrite_rule @{thm Array_Time.update_def}\<close>

setup \<open>add_rewrite_rule @{thm execute_upd(1)}\<close>
lemma upd_rule:
  "<a \<mapsto>\<^sub>a xs * $1 * \<up>(i < length xs)> Array_Time.upd i x a <\<lambda>r. a \<mapsto>\<^sub>a list_update xs i x * \<up>(r = a)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_update}\<close>
lemma update_rule:
  "<p \<mapsto>\<^sub>r y * $1> p := x <\<lambda>r. p \<mapsto>\<^sub>r x>" by auto2

(* Finally, the allocation rules. *)
lemma lim_set_gen [rewrite]: "lim (h\<lparr>lim := l\<rparr>) = l" by simp

lemma Array_alloc_def' [rewrite]:
  "Array_Time.alloc xs h = (let l = lim h; r = Array l in (r, (Array_Time.set r xs (h\<lparr>lim := l + 1\<rparr>))))"
  by (simp add: Array_Time.alloc_def)

setup \<open>fold add_rewrite_rule [
  @{thm addr_of_array.simps}, @{thm addr_of_ref.simps}, @{thm Ref_Time.alloc_def}]\<close>

lemma refs_on_Array_set [rewrite]: "refs (Array_Time.set p xs h) t i = refs h t i"
  by (simp add: Array_Time.set_def)

lemma arrays_on_Ref_set [rewrite]: "arrays (Ref_Time.set p x h) t i = arrays h t i"
  by (simp add: Ref_Time.set_def)

lemma refs_on_Array_alloc [rewrite]: "refs (snd (Array_Time.alloc xs h)) t i = refs h t i"
  by (metis (no_types, lifting) Array_Time.alloc_def refs_on_Array_set select_convs(2) snd_conv surjective update_convs(3))

lemma arrays_on_Ref_alloc [rewrite]: "arrays (snd (Ref_Time.alloc x h)) t i = arrays h t i"
  by (metis (no_types, lifting) Ref_Time.alloc_def arrays_on_Ref_set select_convs(1) sndI surjective update_convs(3))

lemma arrays_on_Array_alloc [rewrite]: "i < lim h \<Longrightarrow> arrays (snd (Array_Time.alloc xs h)) t i = arrays h t i"
  by (smt Array_Time.alloc_def Array_Time.set_def addr_of_array.simps fun_upd_apply less_or_eq_imp_le
          linorder_not_less simps(1) snd_conv surjective update_convs(1) update_convs(3))

lemma refs_on_Ref_alloc [rewrite]: "i < lim h \<Longrightarrow> refs (snd (Ref_Time.alloc x h)) t i = refs h t i"
  by (smt Ref_Time.alloc_def Ref_Time.set_def addr_of_ref.simps fun_upd_apply less_or_eq_imp_le
          linorder_not_less select_convs(2) simps(6) snd_conv surjective update_convs(3))

setup \<open>add_rewrite_rule @{thm execute_new}\<close>
lemma new_rule:
  "<$(n+1)> Array_Time.new n x <\<lambda>r. r \<mapsto>\<^sub>a replicate n x>" by auto2

setup \<open>add_rewrite_rule @{thm execute_make}\<close>
lemma make_rule:
  "<$(n+1)> Array_Time.make n f <\<lambda>r. r \<mapsto>\<^sub>a map f [0 ..< n]>" by auto2

setup \<open>add_rewrite_rule @{thm execute_of_list}\<close>
lemma of_list_rule:
  "<$ (1+length xs)> Array_Time.of_list xs <\<lambda>r. r \<mapsto>\<^sub>a xs>" by auto2

setup \<open>add_rewrite_rule @{thm execute_ref}\<close>
lemma ref_rule:
  "<$1> ref x <\<lambda>r. r \<mapsto>\<^sub>r x>" by auto2

setup \<open>fold del_prfstep_thm [
  @{thm sngr_assn_rule}, @{thm snga_assn_rule}, @{thm pure_assn_rule}, @{thm top_assn_rule},
  @{thm mod_pure_star_dist}, @{thm one_assn_rule}, @{thm hoare_triple_def}, @{thm mod_ex_dist},
  @{thm mod_timeCredit_dest}, @{thm timeCredit_assn_rule}]\<close>
setup \<open>del_simple_datatype "pheap"\<close>

subsection \<open>Definition of procedures\<close>

(* ASCII abbreviations for ML files. *)
abbreviation (input) ex_assn_ascii :: "('a \<Rightarrow> assn) \<Rightarrow> assn" (binder "EXA" 11)
  where "ex_assn_ascii \<equiv> ex_assn"

abbreviation (input) models_ascii :: "pheap \<Rightarrow> assn \<Rightarrow> bool" (infix "|=" 50)
  where "h |= P \<equiv> h \<Turnstile> P"

ML_file "rings.ML"
ML_file "rings_test.ML"
ML_file "sep_time_util.ML"
ML_file "sep_util.ML"
ML_file "sep_time_steps.ML"

ML \<open>
structure AssnMatcher = AssnMatcher(SepUtil)
structure SepLogic = SepLogic(SepUtil)
structure SepTimeSteps = SepTimeSteps(SepUtil)
val add_assn_matcher = AssnMatcher.add_assn_matcher
val add_entail_matcher = AssnMatcher.add_entail_matcher
val add_forward_ent_prfstep = SepLogic.add_forward_ent_prfstep
val add_rewrite_ent_rule = SepLogic.add_rewrite_ent_rule
val add_hoare_triple_prfstep = SepLogic.add_hoare_triple_prfstep
\<close>

(* Make sure to add time proofsteps first (execute time_credit_ge first) *)
setup \<open>SepTimeSteps.add_time_proofsteps\<close>
setup \<open>AssnMatcher.add_assn_matcher_proofsteps\<close>
setup \<open>SepLogic.add_sep_logic_proofsteps\<close>

ML_file "sep_time_test.ML"

attribute_setup forward_ent = \<open>setup_attrib add_forward_ent_prfstep\<close>
attribute_setup rewrite_ent = \<open>setup_attrib add_rewrite_ent_rule\<close>
attribute_setup hoare_triple = \<open>setup_attrib add_hoare_triple_prfstep\<close>

setup \<open>fold add_hoare_triple_prfstep [
  @{thm assert_rule}, @{thm update_rule}, @{thm nth_rule}, @{thm upd_rule},
  @{thm return_rule}, @{thm ref_rule}, @{thm lookup_rule}, @{thm new_rule},
  @{thm make_rule}, @{thm of_list_rule}, @{thm length_rule}, @{thm freeze_rule}]\<close>

(* Some simple tests *)

theorem "<$1> ref x <\<lambda>r. r \<mapsto>\<^sub>r x>" by auto2
theorem "<a \<mapsto>\<^sub>r x * $1> ref x <\<lambda>r. a \<mapsto>\<^sub>r x * r \<mapsto>\<^sub>r x>" by auto2
theorem "<a \<mapsto>\<^sub>r x * $1> (!a) <\<lambda>r. a \<mapsto>\<^sub>r x * \<up>(r = x)>" by auto2
theorem "<a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y * $1> (!a) <\<lambda>r. a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y * \<up>(r = x)>" by auto2
theorem "<a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y * $1> (!b) <\<lambda>r. a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y * \<up>(r = y)>" by auto2
theorem "<a \<mapsto>\<^sub>r x * $2> do { a := y; !a } <\<lambda>r. a \<mapsto>\<^sub>r y * \<up>(r = y)>" by auto2
theorem "<a \<mapsto>\<^sub>r x * $3> do { a := y; a := z; !a } <\<lambda>r. a \<mapsto>\<^sub>r z * \<up>(r = z)>" by auto2
theorem "<a \<mapsto>\<^sub>r x * $2> do { y \<leftarrow> !a; ref y} <\<lambda>r. a \<mapsto>\<^sub>r x * r \<mapsto>\<^sub>r x>" by auto2
theorem "<$1> return x <\<lambda>r. \<up>(r = x)>" by auto2

end


theory prop_08
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  (*hipster plus minus *)
  theorem x0 :
    "(minus (plus k m) (plus k n)) = (minus m n)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end