(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Smallness for digraph homomorphisms\<close>
theory CZH_DG_Small_DGHM
  imports
    CZH_DG_Small_Digraph
    CZH_DG_DGHM
begin

subsection\<open>Digraph homomorphism with tiny maps\<close>

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

text\<open>
The following construction is based on the concept
of a \<open>small functor\<close> used in \<^cite>\<open>"shulman_set_2008"\<close>
in the context of the presentation of the set theory \<open>ZFC/S\<close>.
\<close>

locale is_tm_dghm =
  is_dghm \<alpha> \<AA> \<BB> \<FF> +
  HomDom: digraph \<alpha> \<AA> +
  HomCod: digraph \<alpha> \<BB>
  for \<alpha> \<AA> \<BB> \<FF> +
  assumes tm_dghm_ObjMap_in_Vset[dg_small_cs_intros]: "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and tm_dghm_ArrMap_in_Vset[dg_small_cs_intros]: "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"

syntax "_is_tm_dghm" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>" \<rightleftharpoons> "CONST is_tm_dghm \<alpha> \<AA> \<BB> \<FF>"

abbreviation (input) is_cn_tm_dghm :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "is_cn_tm_dghm \<alpha> \<AA> \<BB> \<FF> \<equiv> \<FF> : op_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"

syntax "_is_cn_tm_dghm" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<mapsto>\<mapsto>\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<mapsto>\<mapsto>\<^bsub>\<alpha>\<^esub> \<BB>" \<rightharpoonup> "CONST is_cn_tm_dghm \<alpha> \<AA> \<BB> \<FF>"

abbreviation all_tm_dghms :: "V \<Rightarrow> V"
  where "all_tm_dghms \<alpha> \<equiv> set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>}"

abbreviation small_tm_dghms :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "small_tm_dghms \<alpha> \<AA> \<BB> \<equiv> set {\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>}"

lemmas [dg_small_cs_intros] =
  is_tm_dghm.tm_dghm_ObjMap_in_Vset
  is_tm_dghm.tm_dghm_ArrMap_in_Vset

text\<open>Rules.\<close>

lemma (in is_tm_dghm) is_tm_dghm_axioms'[dg_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<AA>' = \<AA>" and "\<BB>' = \<BB>"
  shows "\<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tm_dghm_axioms)

mk_ide rf is_tm_dghm_def[unfolded is_tm_dghm_axioms_def]
  |intro is_tm_dghmI|
  |dest is_tm_dghmD[dest]|
  |elim is_tm_dghmE[elim]|

lemmas [dg_small_cs_intros] = is_tm_dghmD(1)

text\<open>Elementary properties.\<close>

sublocale is_tm_dghm \<subseteq> HomDom: tiny_digraph \<alpha> \<AA>
proof(rule tiny_digraphI')
  show "\<AA>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule vdomain_in_VsetI[OF tm_dghm_ObjMap_in_Vset, simplified dg_cs_simps])
  show "\<AA>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule vdomain_in_VsetI[OF tm_dghm_ArrMap_in_Vset, simplified dg_cs_simps])
qed (cs_concl cs_shallow cs_intro: dg_cs_intros)

lemmas (in is_tm_dghm)
  tm_dghm_HomDom_is_tiny_digraph = HomDom.tiny_digraph_axioms

lemmas [dg_small_cs_intros] = is_tm_dghm.tm_dghm_HomDom_is_tiny_digraph

text\<open>Further rules.\<close>

lemma is_tm_dghmI':
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    and [simp]: "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and [simp]: "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
proof-
  interpret is_dghm \<alpha> \<AA> \<BB> \<FF> by (rule assms(1))
  from assms show ?thesis
    by (intro is_tm_dghmI) (auto simp: vfsequence_axioms dghm_ObjMap_vrange)
qed

text\<open>Size.\<close>

lemma small_all_tm_dghms[simp]: "small {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>}"
proof(rule down)
  show
    "{\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>} \<subseteq>
      elts (set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>})"
  proof
    (
      simp only: elts_of_set small_all_dghms if_True,
      rule subsetI,
      unfold mem_Collect_eq
    )
    fix \<FF> assume "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
    then obtain \<AA> \<BB> where \<FF>: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>" by clarsimp
    interpret is_tm_dghm \<alpha> \<AA> \<BB> \<FF> by (rule \<FF>)
    from is_dghm_axioms' show "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>" by blast
  qed
qed

subsubsection\<open>Opposite digraph homomorphism with tiny maps\<close>

lemma (in is_tm_dghm) is_tm_dghm_op: "op_dghm \<FF> : op_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> op_dg \<BB>"
  by (intro is_tm_dghmI', unfold dg_op_simps)
    (cs_concl cs_intro: dg_cs_intros dg_small_cs_intros dg_op_intros)

lemma (in is_tm_dghm) is_tm_dghm_op'[dg_op_intros]:
  assumes "\<AA>' = op_dg \<AA>" and "\<BB>' = op_dg \<BB>" and "\<alpha>' = \<alpha>"
  shows "op_dghm \<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tm_dghm_op)

lemmas is_tm_dghm_op[dg_op_intros] = is_tm_dghm.is_tm_dghm_op'

subsubsection\<open>Composition of a digraph homomorphism with tiny maps\<close>

lemma dghm_comp_is_tm_dghm[dg_small_cs_intros]:
  assumes "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<FF>: is_tm_dghm \<alpha> \<AA> \<BB> \<FF> by (rule assms(2))
  interpret \<GG>: is_tm_dghm \<alpha> \<BB> \<CC> \<GG> by (rule assms(1))
  show ?thesis
  proof(intro is_tm_dghmI')
    from assms show "(\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>)\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
      by
        (
          cs_concl cs_shallow
            cs_simp: dghm_comp_components
            cs_intro: dg_small_cs_intros Limit_vcomp_in_VsetI \<FF>.Limit_\<alpha>
        )+
    from assms show "(\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>)\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
      by
        (
          cs_concl cs_shallow
            cs_simp: dghm_comp_components
            cs_intro: dg_small_cs_intros Limit_vcomp_in_VsetI \<FF>.Limit_\<alpha>
        )+
  qed (auto intro: dg_cs_intros)
qed

subsubsection\<open>Finite digraphs and digraph homomorphisms with tiny maps\<close>

lemma (in is_dghm) dghm_is_tm_dghm_if_HomDom_finite_digraph:
  assumes "finite_digraph \<alpha> \<AA>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<BB>"
proof(intro is_tm_dghmI')
  interpret \<AA>: finite_digraph \<alpha> \<AA> by (rule assms(1))
  show "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  proof(rule ObjMap.vsv_Limit_vsv_in_VsetI)
    show "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    proof-
      have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by (simp add: dghm_ObjMap_vrange)
      moreover have "\<BB>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
        by (simp add: HomCod.dg_Obj_vsubset_Vset)
      ultimately show ?thesis by auto
    qed
  qed (auto simp: dg_cs_simps dg_small_cs_intros)
  show "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  proof(rule ArrMap.vsv_Limit_vsv_in_VsetI)
    show "\<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    proof-
      have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>" by (simp add: dghm_ArrMap_vrange)
      moreover have "\<BB>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
        by (simp add: HomCod.dg_Arr_vsubset_Vset)
      ultimately show ?thesis by auto
    qed
  qed (auto simp: dg_cs_simps dg_small_cs_intros)
qed (simp add: dg_cs_intros)

subsubsection\<open>Constant digraph homomorphism\<close>

lemma dghm_const_is_tm_dghm:
  assumes "tiny_digraph \<alpha> \<CC>" and "digraph \<alpha> \<DD>" and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
  shows "dghm_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<DD>"
proof(intro is_tm_dghmI')
  interpret \<CC>: tiny_digraph \<alpha> \<CC> by (rule assms(1))
  interpret \<DD>: digraph \<alpha> \<DD> by (rule assms(2))
  from assms show "dghm_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "dghm_const \<CC> \<DD> a f\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    unfolding dghm_const_components
  proof(rule vbrelation.vbrelation_Limit_in_VsetI)
    from assms(3) have "a \<in>\<^sub>\<circ> set {a}"
      by (cs_concl cs_shallow cs_intro: V_cs_intros)
    with assms(3) show "\<R>\<^sub>\<circ> (vconst_on (\<CC>\<lparr>Obj\<rparr>) a) \<in>\<^sub>\<circ> Vset \<alpha>"
      by
        (
          cs_concl cs_intro:
            dg_cs_intros
            V_cs_intros
            \<DD>.dg_in_Obj_in_Vset
            vsubset_in_VsetI
            Limit_vsingleton_in_VsetI
        )
    show "\<D>\<^sub>\<circ> (vconst_on (\<CC>\<lparr>Obj\<rparr>) a) \<in>\<^sub>\<circ> Vset \<alpha>"
      by (cs_concl cs_simp: V_cs_simps cs_intro: V_cs_intros dg_small_cs_intros)
  qed simp_all
  show "dghm_const \<CC> \<DD> a f\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    unfolding dghm_const_components
  proof(rule vbrelation.vbrelation_Limit_in_VsetI)
    from assms(3) \<DD>.dg_Arr_vsubset_Vset show
      "\<R>\<^sub>\<circ> (vconst_on (\<CC>\<lparr>Arr\<rparr>) f) \<in>\<^sub>\<circ> Vset \<alpha>"
      by (cases \<open>\<CC>\<lparr>Arr\<rparr>=0\<close>)
        (
          auto
            simp: dg_cs_simps \<DD>.dg_is_arrD(1)
            intro!: Limit_vsingleton_in_VsetI
        )
  qed (auto simp: \<CC>.tiny_dg_Arr_in_Vset)
qed

lemma dghm_const_is_tm_dghm'[dg_small_cs_intros]:
  assumes "tiny_digraph \<alpha> \<CC>"
    and "digraph \<alpha> \<DD>"
    and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
    and "\<CC>' = \<CC>"
    and "\<DD>' = \<DD>"
  shows "dghm_const \<CC> \<DD> a f : \<CC>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>m\<^bsub>\<alpha>\<^esub> \<DD>'"
  using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_tm_dghm)

subsection\<open>Tiny digraph homomorphism\<close>

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

locale is_tiny_dghm =
  is_dghm \<alpha> \<AA> \<BB> \<FF> +
  HomDom: tiny_digraph \<alpha> \<AA> +
  HomCod: tiny_digraph \<alpha> \<BB>
  for \<alpha> \<AA> \<BB> \<FF>

syntax "_is_tiny_dghm" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>" \<rightleftharpoons> "CONST is_tiny_dghm \<alpha> \<AA> \<BB> \<FF>"

abbreviation (input) is_cn_tiny_dghm :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "is_cn_tiny_dghm \<alpha> \<AA> \<BB> \<FF> \<equiv> \<FF> : op_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"

syntax "_is_cn_tiny_dghm" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<mapsto>\<mapsto>\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<mapsto>\<mapsto>\<^bsub>\<alpha>\<^esub> \<BB>" \<rightharpoonup> "CONST is_cn_tiny_dghm \<alpha> \<AA> \<BB> \<FF>"

abbreviation all_tiny_dghms :: "V \<Rightarrow> V"
  where "all_tiny_dghms \<alpha> \<equiv> set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>}"

abbreviation small_dghms :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "small_dghms \<alpha> \<AA> \<BB> \<equiv> set {\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>}"

text\<open>Rules.\<close>

lemma (in is_tiny_dghm) is_tiny_dghm_axioms'[dg_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<AA>' = \<AA>" and "\<BB>' = \<BB>"
  shows "\<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tiny_dghm_axioms)

mk_ide rf is_tiny_dghm_def
  |intro is_tiny_dghmI|
  |dest is_tiny_dghmD[dest]|
  |elim is_tiny_dghmE[elim]|

lemmas [dg_small_cs_intros] = is_tiny_dghmD(2,3)

text\<open>Size.\<close>

lemma (in is_tiny_dghm) tiny_dghm_ObjMap_in_Vset[dg_small_cs_intros]:
  "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by (simp add: dghm_ObjMap_vdomain HomDom.tiny_dg_Obj_in_Vset)
  moreover from dghm_ObjMap_vrange have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by (simp add: vsubset_in_VsetI HomCod.tiny_dg_Obj_in_Vset)
  ultimately show "\<FF>\<lparr>ObjMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by
      (
        cs_concl cs_shallow cs_intro:
          V_cs_intros dg_small_cs_intros ObjMap.vbrelation_Limit_in_VsetI
      )
qed

lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_ObjMap_in_Vset

lemma (in is_tiny_dghm) tiny_dghm_ArrMap_in_Vset[dg_small_cs_intros]:
  "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by (simp add: dghm_ArrMap_vdomain HomDom.tiny_dg_Arr_in_Vset)
  moreover from HomCod.tiny_dg_Arr_in_Vset dghm_ArrMap_vrange have
    "\<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by auto
  ultimately show "\<FF>\<lparr>ArrMap\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by
      (
        cs_concl cs_shallow cs_intro:
          V_cs_intros dg_small_cs_intros ArrMap.vbrelation_Limit_in_VsetI
      )
qed

lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_ArrMap_in_Vset

lemma (in is_tiny_dghm) tiny_dghm_in_Vset: "\<FF> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  note [dg_cs_intros] =
    tiny_dghm_ObjMap_in_Vset
    tiny_dghm_ArrMap_in_Vset
    HomDom.tiny_dg_in_Vset
    HomCod.tiny_dg_in_Vset
  show ?thesis
    by (subst dghm_def)
      (
        cs_concl cs_shallow
          cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros
      )
qed

sublocale is_tiny_dghm \<subseteq> is_tm_dghm
  by (intro is_tm_dghmI') (auto simp: dg_cs_intros dg_small_cs_intros)

lemmas (in is_tiny_dghm) tiny_dghm_is_tm_dghm = is_tm_dghm_axioms

lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_is_tm_dghm

lemma small_all_tiny_dghms[simp]: "small {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>}"
proof(rule down)
  show
    "{\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>} \<subseteq>
      elts (set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>})"
  proof
    (
      simp only: elts_of_set small_all_dghms if_True,
      rule subsetI,
      unfold mem_Collect_eq
    )
    fix \<FF> assume "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"
    then obtain \<AA> \<BB> where \<FF>: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>" by clarsimp
    interpret is_tiny_dghm \<alpha> \<AA> \<BB> \<FF> by (rule \<FF>)
    from is_dghm_axioms show "\<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>" by auto
  qed
qed

lemma tiny_dghms_vsubset_Vset[simp]:
  "set {\<FF>. \<exists>\<AA> \<BB>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>} \<subseteq>\<^sub>\<circ> Vset \<alpha>"
proof(rule vsubsetI)
  fix \<FF> assume "\<FF> \<in>\<^sub>\<circ> all_tiny_dghms \<alpha>"
  then obtain \<AA> \<BB> where \<FF>: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>" by clarsimp
  then show "\<FF> \<in>\<^sub>\<circ> Vset \<alpha>" by (auto simp: is_tiny_dghm.tiny_dghm_in_Vset)
qed

lemma (in is_dghm) dghm_is_tiny_dghm_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<beta>\<^esub> \<BB>"
proof(intro is_tiny_dghmI)
  interpret \<beta>: \<Z> \<beta> by (rule assms(1))
  show "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<beta>\<^esub> \<BB>"
    by (intro dghm_is_dghm_if_ge_Limit)
      (use assms(2) in \<open>cs_concl cs_shallow cs_intro: dg_cs_intros\<close>)+
  show "tiny_digraph \<beta> \<AA>" "tiny_digraph \<beta> \<BB>"
    by
      (
        simp_all add:
          assms
          HomDom.dg_tiny_digraph_if_ge_Limit
          HomCod.dg_tiny_digraph_if_ge_Limit
      )
qed

subsubsection\<open>Opposite tiny digraph homomorphism\<close>

lemma (in is_tiny_dghm) is_tiny_dghm_op:
  "op_dghm \<FF> : op_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> op_dg \<BB>"
  by (intro is_tiny_dghmI)
    (cs_concl cs_shallow cs_intro: dg_small_cs_intros dg_cs_intros dg_op_intros)+

lemma (in is_tiny_dghm) is_tiny_dghm_op'[dg_op_intros]:
  assumes "\<AA>' = op_dg \<AA>" and "\<BB>' = op_dg \<BB>" and "\<alpha>' = \<alpha>"
  shows "op_dghm \<FF> : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tiny_dghm_op)

lemmas is_tiny_dghm_op[dg_op_intros] = is_tiny_dghm.is_tiny_dghm_op'

subsubsection\<open>Composition of tiny digraph homomorphisms\<close>

lemma dghm_comp_is_tiny_dghm[dg_small_cs_intros]:
  assumes "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<CC>" and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<FF>: is_tiny_dghm \<alpha> \<AA> \<BB> \<FF> by (rule assms(2))
  interpret \<GG>: is_tiny_dghm \<alpha> \<BB> \<CC> \<GG> by (rule assms(1))
  show ?thesis
    by (intro is_tiny_dghmI)
      (auto simp: dg_small_cs_intros dg_cs_simps intro: dg_cs_intros)
qed

subsubsection\<open>Tiny constant digraph homomorphism\<close>

lemma dghm_const_is_tiny_dghm:
  assumes "tiny_digraph \<alpha> \<CC>" and "tiny_digraph \<alpha> \<DD>" and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
  shows "dghm_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<DD>"
proof(intro is_tiny_dghmI)
  from assms show "dghm_const \<CC> \<DD> a f : \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_small_cs_intros)
qed (auto simp: assms(1,2))

lemma dghm_const_is_tiny_dghm'[dg_small_cs_intros]:
  assumes "tiny_digraph \<alpha> \<CC>"
    and "tiny_digraph \<alpha> \<DD>"
    and "f : a \<mapsto>\<^bsub>\<DD>\<^esub> a"
    and "\<CC>' = \<CC>"
    and "\<DD>' = \<DD>"
  shows "dghm_const \<CC> \<DD> a f : \<CC>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<DD>'"
  using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_tiny_dghm)

text\<open>\newpage\<close>

end


theory prop_37
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster equal2 elem append *)

  theorem x0 :
    "(elem x z) ==> (elem x (append y z))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory L4_Protocol_Flags
imports "../../Simple_Firewall/Primitives/L4_Protocol"
begin

section\<open>Matching TCP Flags\<close>
  (*man iptables-extensions, [!] --tcp-flags mask comp*)
  datatype ipt_tcp_flags = TCP_Flags "tcp_flag set" --"mask"
                                     "tcp_flag set" --"comp"

  (*--syn: Only match TCP packets with the SYN bit set and the ACK,RST and FIN bits cleared. [...] It is equivalent to --tcp-flags SYN,RST,ACK,FIN SYN.*)
  definition ipt_tcp_syn :: "ipt_tcp_flags" where
    "ipt_tcp_syn \<equiv> TCP_Flags {TCP_SYN,TCP_RST,TCP_ACK,TCP_FIN} {TCP_SYN}"

  fun match_tcp_flags :: "ipt_tcp_flags \<Rightarrow> tcp_flag set \<Rightarrow> bool" where
     "match_tcp_flags (TCP_Flags fmask c) flags \<longleftrightarrow> (flags \<inter> fmask) = c"

  lemma "match_tcp_flags ipt_tcp_syn {TCP_SYN, TCP_URG, TCP_PSH}" by eval

  lemma match_tcp_flags_nomatch: "\<not> c \<subseteq> fmask \<Longrightarrow> \<not> match_tcp_flags (TCP_Flags fmask c) pkt" by auto

  definition ipt_tcp_flags_NoMatch :: "ipt_tcp_flags" where
    "ipt_tcp_flags_NoMatch \<equiv> TCP_Flags {} {TCP_SYN}"
  lemma ipt_tcp_flags_NoMatch: "\<not> match_tcp_flags ipt_tcp_flags_NoMatch pkt" by(simp add: ipt_tcp_flags_NoMatch_def)

  definition ipt_tcp_flags_Any :: ipt_tcp_flags where
    "ipt_tcp_flags_Any \<equiv> TCP_Flags {} {}"

  lemma ipt_tcp_flags_Any_isUNIV: "fmask = {} \<and> c = {} \<longleftrightarrow> (\<forall>pkt. match_tcp_flags (TCP_Flags fmask c) pkt)" by auto

  fun match_tcp_flags_conjunct :: "ipt_tcp_flags \<Rightarrow> ipt_tcp_flags \<Rightarrow> ipt_tcp_flags" where
    "match_tcp_flags_conjunct (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
          if c1 \<subseteq> fmask1 \<and> c2 \<subseteq> fmask2 \<and> fmask1 \<inter> fmask2 \<inter> c1 = fmask1 \<inter> fmask2 \<inter> c2
          then (TCP_Flags (fmask1 \<union> fmask2) (c1 \<union> c2))
          else ipt_tcp_flags_NoMatch)"

  lemma match_tcp_flags_conjunct: "match_tcp_flags (match_tcp_flags_conjunct f1 f2) pkt \<longleftrightarrow> match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt"
    apply(cases f1, cases f2, simp)
    apply(rename_tac fmask1 c1 fmask2 c2)
    apply(intro conjI impI)
     apply(elim conjE)
     apply blast
    apply(simp add: ipt_tcp_flags_NoMatch)
    apply fast
    done
  declare match_tcp_flags_conjunct.simps[simp del]

  text\<open>Same as @{const match_tcp_flags_conjunct}, but returns @{const None} if result cannot match anyway\<close>
  definition match_tcp_flags_conjunct_option :: "ipt_tcp_flags \<Rightarrow> ipt_tcp_flags \<Rightarrow> ipt_tcp_flags option" where
    "match_tcp_flags_conjunct_option f1 f2 = (case match_tcp_flags_conjunct f1 f2 of (TCP_Flags fmask c) \<Rightarrow> if c \<subseteq> fmask then Some (TCP_Flags fmask c) else None)"

  lemma "match_tcp_flags_conjunct_option ipt_tcp_syn (TCP_Flags {TCP_RST,TCP_ACK} {TCP_RST}) = None" by eval

  lemma match_tcp_flags_conjunct_option_Some: "match_tcp_flags_conjunct_option f1 f2 = Some f3 \<Longrightarrow>
      match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt \<longleftrightarrow> match_tcp_flags f3 pkt"
    apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
    using match_tcp_flags_conjunct by blast
  lemma match_tcp_flags_conjunct_option_None: "match_tcp_flags_conjunct_option f1 f2 = None \<Longrightarrow>
      \<not>(match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt)"
    apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
    using match_tcp_flags_conjunct match_tcp_flags_nomatch by metis

  lemma match_tcp_flags_conjunct_option: "(case match_tcp_flags_conjunct_option f1 f2 of None \<Rightarrow> False | Some f3 \<Rightarrow> match_tcp_flags f3 pkt) \<longleftrightarrow> match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt"
    apply(simp split: option.split)
    using match_tcp_flags_conjunct_option_Some match_tcp_flags_conjunct_option_None by blast

  fun ipt_tcp_flags_equal :: "ipt_tcp_flags \<Rightarrow> ipt_tcp_flags \<Rightarrow> bool" where
    "ipt_tcp_flags_equal (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
          if c1 \<subseteq> fmask1 \<and> c2 \<subseteq> fmask2
          then c1 = c2 \<and> fmask1 = fmask2
          else  (\<not> c1 \<subseteq> fmask1) \<and> (\<not> c2 \<subseteq> fmask2))"
  context
  begin
    private lemma funny_set_falg_fmask_helper: "c2 \<subseteq> fmask2 \<Longrightarrow> (c1 = c2 \<and> fmask1 = fmask2) = (\<forall>pkt. (pkt \<inter> fmask1 = c1) = (pkt \<inter> fmask2 = c2))"
    apply rule
     apply presburger
    apply(subgoal_tac "fmask1 = fmask2")
     apply blast
    (*"e": Try this: by (metis Diff_Compl Diff_eq Int_lower2 Un_Diff_Int compl_sup disjoint_eq_subset_Compl inf_assoc inf_commute inf_sup_absorb) (> 1.0 s, timed out).
      Isar proof (300 ms):*)
    proof -
      assume a1: "c2 \<subseteq> fmask2"
      assume a2: "\<forall>pkt. (pkt \<inter> fmask1 = c1) = (pkt \<inter> fmask2 = c2)"
      have f3: "\<And>A Aa. (A::'a set) - - Aa = Aa - - A"
        by (simp add: inf_commute)
      have f4: "\<And>A Aa. (A::'a set) - - (- Aa) = A - Aa"
        by simp
      have f5: "\<And>A Aa Ab. (A::'a set) - - Aa - - Ab = A - - (Aa - - Ab)"
        by blast
      have f6: "\<And>A Aa. (A::'a set) - (- A - Aa) = A"
        by fastforce
      have f7: "\<And>A Aa. - (A::'a set) - - Aa = Aa - A"
        using f4 f3 by presburger
      have f8: "\<And>A Aa. - (A::'a set) = - (A - Aa) - (A - - Aa)"
        by blast
      have f9: "c1 = - (- c1)"
        by blast
      have f10: "\<And>A. A - c1 - c1 = A - c1"
        by blast
      have "\<And>A. A - - (fmask1 - - fmask2) = c2 \<or> A - - fmask1 \<noteq> c1"
        using f6 f5 a2 by (metis (no_types) Diff_Compl)
      hence f11: "\<And>A. - A - - (fmask1 - - fmask2) = c2 \<or> fmask1 - A \<noteq> c1"
        using f7 by meson
      have "c2 - fmask2 = {}"
        using a1 by force
      hence f12: "- c2 - (fmask2 - c2) = - fmask2"
        by blast
      hence "fmask2 - - c2 = c2"
        by blast
      hence f13: "fmask1 - - c2 = c1"
        using f3 a2 by simp
      hence f14: "c1 = c2"
        using f11 by blast
      hence f15: "fmask2 - (fmask1 - c1) = c1"
        using f13 f10 f9 f8 f7 f3 a2 by (metis Diff_Compl)
      have "fmask1 - (fmask2 - c1) = c1"
        using f14 f12 f10 f9 f8 f4 f3 a2 by (metis Diff_Compl)
      thus "fmask1 = fmask2"
        using f15 by blast
    qed

    lemma ipt_tcp_flags_equal: "ipt_tcp_flags_equal f1 f2 \<longleftrightarrow> (\<forall>pkt. match_tcp_flags f1 pkt = match_tcp_flags f2 pkt)"
      apply(cases f1, cases f2, simp)
      apply(rename_tac fmask1 c1 fmask2 c2)
      apply(intro conjI impI)
       using funny_set_falg_fmask_helper apply metis
      apply blast
     done
  end
  declare ipt_tcp_flags_equal.simps[simp del]
end


theory Analysis_Tainting
imports SINVAR_Tainting SINVAR_BLPbasic
        SINVAR_TaintingTrusted SINVAR_BLPtrusted
begin

term SINVAR_Tainting.sinvar
term SINVAR_BLPbasic.sinvar

lemma tainting_imp_blp_cutcard: "\<forall>ts v. nP v = ts \<longrightarrow> finite ts \<Longrightarrow>
  SINVAR_Tainting.sinvar G nP \<Longrightarrow> SINVAR_BLPbasic.sinvar G ((\<lambda>ts. card (ts \<inter> X)) \<circ> nP)"
apply(simp add: SINVAR_Tainting.sinvar_def)
apply(clarify, rename_tac a b)
apply(erule_tac x="(a,b)" in ballE)
 apply(simp_all)
apply(subgoal_tac "finite (nP a \<inter> X)")
 prefer 2 subgoal using finite_Int by blast
apply(subgoal_tac "finite (nP b \<inter> X)")
 prefer 2 subgoal using finite_Int by blast
using card_mono by (metis Int_subset_iff order_refl subset_antisym)

lemma tainting_imp_blp_cutcard2: "finite X \<Longrightarrow>
  SINVAR_Tainting.sinvar G nP \<Longrightarrow> SINVAR_BLPbasic.sinvar G ((\<lambda>ts. card (ts \<inter> X)) \<circ> nP)"
apply(simp add: SINVAR_Tainting.sinvar_def)
apply(clarify, rename_tac a b)
apply(erule_tac x="(a,b)" in ballE)
 apply(simp_all)
apply(subgoal_tac "finite (nP a \<inter> X)")
 prefer 2 subgoal using finite_Int by blast
apply(subgoal_tac "finite (nP b \<inter> X)")
 prefer 2 subgoal using finite_Int by blast
using card_mono by (metis Int_subset_iff order_refl subset_antisym)

lemma "\<forall>ts v. nP v = ts \<longrightarrow> finite ts \<Longrightarrow>
  SINVAR_Tainting.sinvar G nP \<Longrightarrow> SINVAR_BLPbasic.sinvar G (card \<circ> nP)"
apply(drule(1) tainting_imp_blp_cutcard[where X=UNIV])
by(simp)

(*Stronger version*)
lemma "\<forall>b \<in> snd ` edges G. finite (nP b) \<Longrightarrow>
  SINVAR_Tainting.sinvar G nP \<Longrightarrow> SINVAR_BLPbasic.sinvar G (card \<circ> nP)"
apply(simp add: SINVAR_Tainting.sinvar_def)
apply(clarify, rename_tac a b)
apply(erule_tac x="(a,b)" in ballE)
 apply(simp_all)
apply(case_tac "finite (nP a)")
 apply(case_tac [!] "finite (nP b)")
   using card_mono apply blast
  apply(simp_all)
done

text\<open>One tainting invariant is equal to many BLP invariants.
     The BLP invariants are the projection of the tainting mapping for exactly one label\<close>
lemma tainting_iff_blp:
  defines "extract \<equiv> \<lambda>a ts. if a \<in> ts then 1::security_level else 0::security_level"
  shows "SINVAR_Tainting.sinvar G nP \<longleftrightarrow> (\<forall>a. SINVAR_BLPbasic.sinvar G (extract a \<circ> nP))"
proof
  show"SINVAR_Tainting.sinvar G nP \<Longrightarrow> \<forall>a. SINVAR_BLPbasic.sinvar G (extract a \<circ> nP)"
    apply(simp add: extract_def)
    apply(safe)
     apply simp
    apply(simp add: SINVAR_Tainting.sinvar_def)
    by fast
  next
    assume blp: "\<forall>a. SINVAR_BLPbasic.sinvar G (extract a \<circ> nP)"
    { fix v1 v2
      assume *: "(v1,v2)\<in>edges G"
      { fix a
        from blp * have "(if a \<in> nP v1 then 1::security_level else 0) \<le> (if a \<in> nP v2 then 1 else 0)"
          unfolding extract_def
          apply(simp)
          apply(erule_tac x=a in allE)
          apply(erule_tac x="(v1, v2)" in ballE)
           apply(simp_all)
          apply(simp split: if_split_asm)
          done
        hence "a \<in> nP v1 \<Longrightarrow> a \<in> nP v2" by(simp split: if_split_asm)
      }
      from this have "nP v1 \<subseteq> nP v2" by auto
    }
    thus "SINVAR_Tainting.sinvar G nP" unfolding SINVAR_Tainting.sinvar_def by blast
qed

text\<open>If the labels are finite, the above can be generalized to arbitrary subsets of tainting labels.\<close>
lemma tainting_iff_blp_extended:
  defines "extract \<equiv> \<lambda>A ts. card (A \<inter> ts)"
  assumes finite: "\<forall>ts v. nP v = ts \<longrightarrow> finite ts"
  shows "SINVAR_Tainting.sinvar G nP \<longleftrightarrow> (\<forall>A. SINVAR_BLPbasic.sinvar G (extract A \<circ> nP))"
proof
  show "SINVAR_Tainting.sinvar G nP \<Longrightarrow> \<forall>A. SINVAR_BLPbasic.sinvar G (extract A \<circ> nP)"
    apply(simp add: extract_def)
    apply(safe)
    apply(simp add: SINVAR_Tainting.sinvar_def)
    apply(rename_tac A a b)
    apply(subgoal_tac "finite (A \<inter> nP a)")
     prefer 2 subgoal using finite by blast
    apply(rule card_mono)
     apply(simp add: finite; fail)
    by blast
  next
    assume blp: "\<forall>A. SINVAR_BLPbasic.sinvar G (extract A \<circ> nP)"
    { fix v1 v2
      assume *: "(v1,v2)\<in>edges G"
      { fix A
        from blp * have "card (A \<inter> nP v1) \<le> card (A \<inter> nP v2)"
          unfolding extract_def
          apply(clarsimp)
          apply(erule_tac x=A in allE)
          apply(erule_tac x="(v1, v2)" in ballE)
           by(simp_all)
      }
      from this finite card_seteq have "nP v1 \<subseteq> nP v2" by (metis Int_absorb Int_lower1 inf.orderI)
    }
    thus "SINVAR_Tainting.sinvar G nP" unfolding SINVAR_Tainting.sinvar_def by blast
qed

text\<open>
  Translated to the Bell LaPadula model with trust:
  security level is the number of tainted minus the untainted things
  We set the Trusted flag if a machine untaints things.
\<close>
lemma "\<forall>ts v. nP v = ts \<longrightarrow> finite (taints ts) \<Longrightarrow>
  SINVAR_TaintingTrusted.sinvar G nP \<Longrightarrow>
    SINVAR_BLPtrusted.sinvar G ((\<lambda> ts. \<lparr>security_level = card (taints ts - untaints ts), trusted = (untaints ts \<noteq> {})\<rparr> ) \<circ> nP)"
apply(simp add: SINVAR_TaintingTrusted.sinvar_def)
apply(clarify, rename_tac a b)
apply(erule_tac x="(a,b)" in ballE)
 apply(simp_all)
apply(subgoal_tac "finite (taints (nP a) - untaints (nP a))")
 prefer 2 subgoal by blast
apply(rule card_mono)
 by blast+

lemma tainting_iff_blp_trusted:
  defines "project \<equiv> \<lambda>a ts. \<lparr>
      security_level =
        if
          a \<in> (taints ts - untaints ts)
        then
          1::security_level
        else
          0::security_level
      , trusted = a \<in> untaints ts\<rparr>"
  shows "SINVAR_TaintingTrusted.sinvar G nP \<longleftrightarrow> (\<forall>a. SINVAR_BLPtrusted.sinvar G (project a \<circ> nP))"
unfolding project_def
apply(rule iffI)
 subgoal
 apply(simp add: SINVAR_TaintingTrusted.sinvar_def)
 apply(clarify, rename_tac a b)
 apply(erule_tac x="(a,b)" in ballE)
  apply(simp_all)
 by blast
apply(simp)
apply(simp add: SINVAR_TaintingTrusted.sinvar_def)
apply(clarify, rename_tac a b taintlabel)
apply(erule_tac x=taintlabel in allE)
apply(erule_tac x="(a,b)" in ballE)
 apply(simp_all)
apply(simp split: if_split_asm)
using taints_wellformedness by blast

text\<open>If the labels are finite, the above can be generalized to arbitrary subsets of tainting labels.\<close>
lemma tainting_iff_blp_trusted_extended:
  defines "project \<equiv> \<lambda>A ts.
      \<lparr>
          security_level = card (A \<inter> (taints ts - untaints ts))
        , trusted = (A \<inter> untaints ts) \<noteq> {}
      \<rparr>"
  assumes finite: "\<forall>ts v. nP v = ts \<longrightarrow> finite (taints ts)"
  shows "SINVAR_TaintingTrusted.sinvar G nP \<longleftrightarrow> (\<forall>A. SINVAR_BLPtrusted.sinvar G (project A \<circ> nP))"
unfolding project_def
apply(rule iffI)
 subgoal
 apply(simp add: SINVAR_TaintingTrusted.sinvar_def)
 apply(clarify, rename_tac a b)
 apply(erule_tac x="(a,b)" in ballE)
  apply(simp_all)
 apply(rule card_mono)
  using finite apply blast
 by blast
apply(simp)
apply(simp add: SINVAR_TaintingTrusted.sinvar_def)
apply(clarify, rename_tac a b taintlabel)
apply(erule_tac x="{taintlabel}" in allE)
apply(erule_tac x="(a,b)" in ballE)
 apply(simp_all)
apply(simp split: if_split_asm)
 using taints_wellformedness apply blast
using Diff_insert_absorb by fastforce

end


(*  Title:      ZF/ex/CoUnit.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Trivial codatatype definitions, one of which goes wrong!\<close>

theory CoUnit imports ZF begin

text \<open>
  See discussion in: L C Paulson.  A Concrete Final Coalgebra Theorem
  for ZF Set Theory.  Report 334, Cambridge University Computer
  Laboratory.  1994.

  \bigskip

  This degenerate definition does not work well because the one
  constructor's definition is trivial!  The same thing occurs with
  Aczel's Special Final Coalgebra Theorem.
\<close>

consts
  counit :: i
codatatype
  "counit" = Con ("x \<in> counit")

inductive_cases ConE: "Con(x) \<in> counit"
  \<comment> \<open>USELESS because folding on @{term "Con(xa) == xa"} fails.\<close>

lemma Con_iff: "Con(x) = Con(y) \<longleftrightarrow> x = y"
  \<comment> \<open>Proving freeness results.\<close>
  by (auto elim!: counit.free_elims)

lemma counit_eq_univ: "counit = quniv(0)"
  \<comment> \<open>Should be a singleton, not everything!\<close>
  apply (rule counit.dom_subset [THEN equalityI])
  apply (rule subsetI)
  apply (erule counit.coinduct)
   apply (rule subset_refl)
  apply (unfold counit.con_defs)
  apply fast
  done

text \<open>
  \medskip A similar example, but the constructor is non-degenerate
  and it works!  The resulting set is a singleton.
\<close>

consts
  counit2 :: i
codatatype
  "counit2" = Con2 ("x \<in> counit2", "y \<in> counit2")

inductive_cases Con2E: "Con2(x, y) \<in> counit2"

lemma Con2_iff: "Con2(x, y) = Con2(x', y') \<longleftrightarrow> x = x' & y = y'"
  \<comment> \<open>Proving freeness results.\<close>
  by (fast elim!: counit2.free_elims)

lemma Con2_bnd_mono: "bnd_mono(univ(0), %x. Con2(x, x))"
  apply (unfold counit2.con_defs)
  apply (rule bnd_monoI)
   apply (assumption | rule subset_refl QPair_subset_univ QPair_mono)+
  done

lemma lfp_Con2_in_counit2: "lfp(univ(0), %x. Con2(x,x)) \<in> counit2"
  apply (rule singletonI [THEN counit2.coinduct])
  apply (rule qunivI [THEN singleton_subsetI])
  apply (rule subset_trans [OF lfp_subset empty_subsetI [THEN univ_mono]])
  apply (fast intro!: Con2_bnd_mono [THEN lfp_unfold])
  done

lemma counit2_Int_Vset_subset [rule_format]:
  "Ord(i) ==> \<forall>x y. x \<in> counit2 \<longrightarrow> y \<in> counit2 \<longrightarrow> x \<inter> Vset(i) \<subseteq> y"
  \<comment> \<open>Lemma for proving finality.\<close>
  apply (erule trans_induct)
  apply (tactic "safe_tac (put_claset subset_cs @{context})")
  apply (erule counit2.cases)
  apply (erule counit2.cases)
  apply (unfold counit2.con_defs)
  apply (tactic \<open>fast_tac (put_claset subset_cs @{context}
    addSIs [@{thm QPair_Int_Vset_subset_UN} RS @{thm subset_trans}, @{thm QPair_mono}]
    addSEs [@{thm Ord_in_Ord}, @{thm Pair_inject}]) 1\<close>)
  done

lemma counit2_implies_equal: "[| x \<in> counit2;  y \<in> counit2 |] ==> x = y"
  apply (rule equalityI)
  apply (assumption | rule conjI counit2_Int_Vset_subset [THEN Int_Vset_subset])+
  done

lemma counit2_eq_univ: "counit2 = {lfp(univ(0), %x. Con2(x,x))}"
  apply (rule equalityI)
   apply (rule_tac [2] lfp_Con2_in_counit2 [THEN singleton_subsetI])
  apply (rule subsetI)
  apply (drule lfp_Con2_in_counit2 [THEN counit2_implies_equal])
  apply (erule subst)
  apply (rule singletonI)
  done

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |               December 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009         |
            |                   June 2009  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_decompo
imports CSP_T_traces
begin

(*------------------------------------------------*
 |                                                |
 |      laws for monotonicity and congruence      |
 |                                                |
 *------------------------------------------------*)

(*********************************************************
                        Act_prefix mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Act_prefix_mono:
  "[| a = b ; P <=T[M1,M2] Q |] ==> a -> P <=T[M1,M2] b -> Q"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Act_prefix_cong:
  "[| a = b ; P =T[M1,M2] Q |] ==> a -> P =T[M1,M2] b -> Q"
apply (simp add: cspT_eq_ref_iff)
apply (simp add: cspT_Act_prefix_mono)
done

(*********************************************************
                   Ext_pre_choice mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Ext_pre_choice_mono:
  "[| X = Y ; !! a. a:Y ==> Pf a <=T[M1,M2] Qf a |] ==> ? :X -> Pf <=T[M1,M2] ? :Y -> Qf"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Ext_pre_choice_cong:
  "[| X = Y ; !! a. a:Y ==> Pf a =T[M1,M2] Qf a |] ==> ? :X -> Pf =T[M1,M2] ? :Y -> Qf"
by (simp add: cspT_eq_ref_iff cspT_Ext_pre_choice_mono)

(*********************************************************
                      Ext choice mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Ext_choice_mono:
  "[| P1 <=T[M1,M2] Q1 ; P2 <=T[M1,M2] Q2 |] ==> P1 [+] P2 <=T[M1,M2] Q1 [+] Q2"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Ext_choice_cong:
  "[| P1 =T[M1,M2] Q1 ; P2 =T[M1,M2] Q2 |] ==> P1 [+] P2 =T[M1,M2] Q1 [+] Q2"
by (simp add: cspT_eq_ref_iff cspT_Ext_choice_mono)

(*********************************************************
                      Int choice mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Int_choice_mono:
  "[| P1 <=T[M1,M2] Q1 ; P2 <=T[M1,M2] Q2 |] ==> P1 |~| P2 <=T[M1,M2] Q1 |~| Q2"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Int_choice_cong:
  "[| P1 =T[M1,M2] Q1 ; P2 =T[M1,M2] Q2 |] ==> P1 |~| P2 =T[M1,M2] Q1 |~| Q2"
by (simp add: cspT_eq_ref_iff cspT_Int_choice_mono)

(*********************************************************
               replicated internal choice
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

(****** mono ******)

lemma cspT_Rep_int_choice_mono_sum:
  "[| C1 = C2 ; !! c. c: sumset C1 ==> Pf c <=T[M1,M2] Qf c |]
      ==> !! :C1 .. Pf <=T[M1,M2] !! :C2 .. Qf"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

(* nat *)

lemma cspT_Rep_int_choice_mono_nat:
  "[| N1 = N2 ; !! n. n:N1 ==> Pf n <=T[M1,M2] Qf n |]
      ==> !nat :N1 .. Pf <=T[M1,M2] !nat :N2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspT_Rep_int_choice_mono_sum)
apply (auto)
done

(* set *)

lemma cspT_Rep_int_choice_mono_set:
  "[| Xs1 = Xs2 ; !! X. X:Xs1 ==> Pf X <=T[M1,M2] Qf X |]
      ==> !set :Xs1 .. Pf <=T[M1,M2] !set :Xs2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspT_Rep_int_choice_mono_sum)
apply (auto)
done

lemma cspT_Rep_int_choice_mono_com:
  "[| X1 = X2 ; !! x. x:X1 ==> Pf x <=T[M1,M2] Qf x |]
      ==> ! :X1 .. Pf <=T[M1,M2] ! :X2 .. Qf"
apply (simp add: Rep_int_choice_com_def)
apply (rule cspT_Rep_int_choice_mono_set)
apply (auto)
done

lemma cspT_Rep_int_choice_mono_f:
  "[| inj f ; X1 = X2 ; !! x. x:X1 ==> Pf x <=T[M1,M2] Qf x |]
      ==> !<f> :X1 .. Pf <=T[M1,M2] !<f> :X2 .. Qf"
apply (simp add: Rep_int_choice_f_def)
apply (rule cspT_Rep_int_choice_mono_com)
apply (auto)
done

lemmas cspT_Rep_int_choice_mono = cspT_Rep_int_choice_mono_sum
                                  cspT_Rep_int_choice_mono_set
                                  cspT_Rep_int_choice_mono_nat
                                  cspT_Rep_int_choice_mono_com
                                  cspT_Rep_int_choice_mono_f

(****** cong ******)

lemma cspT_Rep_int_choice_cong_sum:
  "[| C1 = C2 ; !! c. c: sumset C1 ==> Pf c =T[M1,M2] Qf c |]
      ==> !! :C1 .. Pf =T[M1,M2] !! :C2 .. Qf"
by (simp add: cspT_eq_ref_iff cspT_Rep_int_choice_mono)

lemma cspT_Rep_int_choice_cong_nat:
  "[| N1 = N2 ; !! n. n:N1 ==> Pf n =T[M1,M2] Qf n |]
      ==> !nat :N1 .. Pf =T[M1,M2] !nat :N2 .. Qf"
by (simp add: cspT_eq_ref_iff cspT_Rep_int_choice_mono)

lemma cspT_Rep_int_choice_cong_set:
  "[| Xs1 = Xs2 ; !! X. X:Xs1 ==> Pf X =T[M1,M2] Qf X |]
      ==> !set :Xs1 .. Pf =T[M1,M2] !set :Xs2 .. Qf"
by (simp add: cspT_eq_ref_iff cspT_Rep_int_choice_mono)

lemma cspT_Rep_int_choice_cong_com:
  "[| X1 = X2 ; !! x. x:X1 ==> Pf x =T[M1,M2] Qf x |]
      ==> ! :X1 .. Pf =T[M1,M2] ! :X2 .. Qf"
by (simp add: cspT_eq_ref_iff cspT_Rep_int_choice_mono)

lemma cspT_Rep_int_choice_cong_f:
  "[| inj f ; X1 = X2 ; !! x. x:X1 ==> Pf x =T[M1,M2] Qf x |]
      ==> !<f> :X1 .. Pf =T[M1,M2] !<f> :X2 .. Qf"
by (simp add: cspT_eq_ref_iff cspT_Rep_int_choice_mono)

lemmas cspT_Rep_int_choice_cong = cspT_Rep_int_choice_cong_sum
                                  cspT_Rep_int_choice_cong_set
                                  cspT_Rep_int_choice_cong_nat
                                  cspT_Rep_int_choice_cong_com
                                  cspT_Rep_int_choice_cong_f

(*********************************************************
                   IF mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_IF_mono:
  "[| b1 = b2 ; P1 <=T[M1,M2] Q1 ; P2 <=T[M1,M2] Q2 |]
           ==> IF b1 THEN P1 ELSE P2 <=T[M1,M2]
               IF b2 THEN Q1 ELSE Q2"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
done

lemma cspT_IF_cong:
  "[| b1 = b2 ; P1 =T[M1,M2] Q1 ;  P2 =T[M1,M2] Q2 |]
           ==> IF b1 THEN P1 ELSE P2 =T[M1,M2]
               IF b2 THEN Q1 ELSE Q2"
by (simp add: cspT_eq_ref_iff cspT_IF_mono)

(*********************************************************
                     Parallel mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Parallel_mono:
  "[| X = Y ; P1 <=T[M1,M2] Q1 ; P2 <=T[M1,M2] Q2 |]
           ==> P1 |[X]| P2 <=T[M1,M2] Q1 |[Y]| Q2"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Parallel_cong:
  "[| X = Y ; P1 =T[M1,M2] Q1 ; P2 =T[M1,M2] Q2 |]
           ==> P1 |[X]| P2 =T[M1,M2] Q1 |[Y]| Q2"
by (simp add: cspT_eq_ref_iff cspT_Parallel_mono)

(*********************************************************
                        Hiding mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Hiding_mono:
  "[| X = Y ; P <=T[M1,M2] Q |] ==> P -- X <=T[M1,M2] Q -- Y"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Hiding_cong:
  "[| X = Y ; P =T[M1,M2] Q |] ==> P -- X =T[M1,M2] Q -- Y"
by (simp add: cspT_eq_ref_iff cspT_Hiding_mono)

(*********************************************************
                        Renaming mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Renaming_mono:
  "[| r1 = r2 ; P <=T[M1,M2] Q |] ==> P [[r1]] <=T[M1,M2] Q [[r2]]"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Renaming_cong:
  "[| r1 = r2 ; P =T[M1,M2] Q |] ==> P [[r1]] =T[M1,M2] Q [[r2]]"
by (simp add: cspT_eq_ref_iff cspT_Renaming_mono)

(*********************************************************
               Sequential composition mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Seq_compo_mono:
  "[| P1 <=T[M1,M2] Q1 ; P2 <=T[M1,M2] Q2 |]
           ==> P1 ;; P2 <=T[M1,M2] Q1 ;; Q2"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
apply (fast)
done

lemma cspT_Seq_compo_cong:
  "[| P1 =T[M1,M2] Q1 ; P2 =T[M1,M2] Q2 |] ==> P1 ;; P2 =T[M1,M2] Q1 ;; Q2"
by (simp add: cspT_eq_ref_iff cspT_Seq_compo_mono)

(*********************************************************
                        Depth_rest mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Depth_rest_mono:
  "[| n1 = n2 ; P <=T[M1,M2] Q |] ==> P |. n1 <=T[M1,M2] Q |. n2"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_traces)
done

lemma cspT_Depth_rest_cong:
  "[| n1 = n2 ; P =T[M1,M2] Q |] ==> P |. n1 =T[M1,M2] Q |. n2"
by (simp add: cspT_eq_ref_iff cspT_Depth_rest_mono)

(*********************************************************
                        Timeout mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Timeout_mono:
  "[| P1 <=T[M1,M2] Q1 ; P2 <=T[M1,M2] Q2 |]
      ==> P1 [> P2 <=T[M1,M2] Q1 [> Q2"
apply (rule cspT_Ext_choice_mono)
apply (rule cspT_Int_choice_mono)
apply (simp_all)
done

lemma cspT_Timeout_cong:
  "[| P1 =T[M1,M2] Q1 ; P2 =T[M1,M2] Q2 |]
      ==> P1 [> P2 =T[M1,M2] Q1 [> Q2"
by (simp add: cspT_eq_ref_iff cspT_Timeout_mono)

(*------------------------------------------------------*
 |                       alias                          |
 *------------------------------------------------------*)

lemmas cspT_free_mono =
   cspT_Ext_choice_mono cspT_Int_choice_mono cspT_Parallel_mono
   cspT_Hiding_mono cspT_Renaming_mono cspT_Seq_compo_mono
   cspT_Depth_rest_mono

lemmas cspT_mono = cspT_free_mono
   cspT_Act_prefix_mono cspT_Ext_pre_choice_mono
   cspT_Rep_int_choice_mono cspT_IF_mono

lemmas cspT_free_cong =
   cspT_Ext_choice_cong cspT_Int_choice_cong cspT_Parallel_cong
   cspT_Hiding_cong cspT_Renaming_cong cspT_Seq_compo_cong
   cspT_Depth_rest_cong

lemmas cspT_cong = cspT_free_cong
   cspT_Act_prefix_cong cspT_Ext_pre_choice_cong
   cspT_Rep_int_choice_cong cspT_IF_cong

lemmas cspT_free_decompo = cspT_free_mono cspT_free_cong
lemmas cspT_decompo = cspT_mono cspT_cong

lemmas cspT_rm_head_mono = cspT_Act_prefix_mono cspT_Ext_pre_choice_mono
lemmas cspT_rm_head_cong = cspT_Act_prefix_cong cspT_Ext_pre_choice_cong
lemmas cspT_rm_head      = cspT_rm_head_mono cspT_rm_head_cong

(*-------------------------------------------------------*
 |            decomposition with ALL and EX              |
 *-------------------------------------------------------*)

(*** Rep_int_choice ***)

lemma cspT_Rep_int_choice_sum_decompo_ALL_EX_ref:
  "ALL c2: sumset C2. EX c1: sumset C1. (Pf c1) <=T[M1,M2] (Qf c2)
   ==> !! :C1 .. Pf <=T[M1,M2] !! :C2 .. Qf"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (erule disjE)
apply (simp)
apply (elim bexE)
apply (drule_tac x="c" in bspec, simp)
apply (erule bexE)
apply (rule disjI2)
apply (rule_tac x="c1" in bexI)
apply (erule subdomTE)
apply (simp_all)
done

lemma cspT_Rep_int_choice_nat_decompo_ALL_EX_ref:
  "ALL n2:N2. EX n1:N1. (Pf n1) <=T[M1,M2] (Qf n2)
   ==> !nat :N1 .. Pf <=T[M1,M2] !nat :N2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspT_Rep_int_choice_sum_decompo_ALL_EX_ref)
apply (auto)
apply (drule_tac x="a" in bspec, simp)
apply (auto)
done

lemma cspT_Rep_int_choice_set_decompo_ALL_EX_ref:
  "ALL X2:Xs2. EX X1:Xs1. (Pf X1) <=T[M1,M2] (Qf X2)
   ==> !set :Xs1 .. Pf <=T[M1,M2] !set :Xs2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspT_Rep_int_choice_sum_decompo_ALL_EX_ref)
apply (auto)
apply (drule_tac x="a" in bspec, simp)
apply (auto)
done

lemmas cspT_Rep_int_choice_decompo_ALL_EX_ref =
       cspT_Rep_int_choice_sum_decompo_ALL_EX_ref
       cspT_Rep_int_choice_nat_decompo_ALL_EX_ref
       cspT_Rep_int_choice_set_decompo_ALL_EX_ref

lemma cspT_Rep_int_choice_sum_decompo_ALL_EX_eq:
  "[| ALL c1: sumset C1. EX c2: sumset C2. (Pf c1) =T[M1,M2] (Qf c2) ;
      ALL c2: sumset C2. EX c1: sumset C1. (Pf c1) =T[M1,M2] (Qf c2) |]
   ==> !! :C1 .. Pf =T[M1,M2] !! :C2 .. Qf"
apply (simp add: cspT_eq_ref_iff)
apply (rule conjI)
apply (rule cspT_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
apply (rule cspT_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
done

lemma cspT_Rep_int_choice_nat_decompo_ALL_EX_eq:
  "[| ALL n1:N1. EX n2:N2. (Pf n1) =T[M1,M2] (Qf n2) ;
      ALL n2:N2. EX n1:N1. (Pf n1) =T[M1,M2] (Qf n2) |]
   ==> !nat :N1 .. Pf =T[M1,M2] !nat :N2 .. Qf"
apply (simp add: cspT_eq_ref_iff)
apply (rule conjI)
apply (rule cspT_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
apply (rule cspT_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
done

lemma cspT_Rep_int_choice_set_decompo_ALL_EX_eq:
  "[| ALL X1:Xs1. EX X2:Xs2. (Pf X1) =T[M1,M2] (Qf X2) ;
      ALL X2:Xs2. EX X1:Xs1. (Pf X1) =T[M1,M2] (Qf X2) |]
   ==> !set :Xs1 .. Pf =T[M1,M2] !set :Xs2 .. Qf"
apply (simp add: cspT_eq_ref_iff)
apply (rule conjI)
apply (rule cspT_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
apply (rule cspT_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
done

lemmas cspT_Rep_int_choice_decompo_ALL_EX_eq =
       cspT_Rep_int_choice_sum_decompo_ALL_EX_eq
       cspT_Rep_int_choice_nat_decompo_ALL_EX_eq
       cspT_Rep_int_choice_set_decompo_ALL_EX_eq

lemmas cspT_Rep_int_choice_decompo_ALL_EX
     = cspT_Rep_int_choice_decompo_ALL_EX_ref
       cspT_Rep_int_choice_decompo_ALL_EX_eq

(* =================================================== *
 |             addition for CSP-Prover 5               |
 * =================================================== *)

(*********************************************************
                        Act_prefix mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

(** mono **)

lemma cspT_Send_prefix_mono:
  "[| a = b ; P <=T[M1,M2] Q |] ==> a ! v -> P <=T[M1,M2] b ! v -> Q"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspT_decompo)
done

lemma cspT_Rec_prefix_mono:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x <=T[M1,M2] Qf x |]
    ==> a ? x:X -> Pf x <=T[M1,M2] b ? x:Y -> Qf x"
apply (simp add: csp_prefix_ss_def)
apply (rule cspT_Ext_pre_choice_mono)
apply (simp)
apply (simp add: image_iff)
apply (erule bexE)
apply (simp)
done

lemma cspT_Int_pre_choice_mono:
  "[| X = Y ;
      !! x. x:Y ==> Pf x <=T[M1,M2] Qf x |]
    ==> ! :X -> Pf <=T[M1,M2] ! :Y -> Qf"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspT_decompo)
done

lemma cspT_Nondet_send_prefix_mono:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x <=T[M1,M2] Qf x |]
    ==> a !? x:X -> Pf x <=T[M1,M2] b !? x:Y -> Qf x"
apply (simp add: csp_prefix_ss_def)
apply (rule cspT_mono)
apply (simp)
apply (rule cspT_mono)
apply (simp)
apply (simp add: image_iff)
apply (erule bexE)
apply (simp)
done

(** cong **)

lemma cspT_Send_prefix_cong:
  "[| a = b ; P =T[M1,M2] Q |] ==> a ! v -> P =T[M1,M2] b ! v -> Q"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspT_decompo)
done

lemma cspT_Rec_prefix_cong:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x =T[M1,M2] Qf x |]
    ==> a ? x:X -> Pf x =T[M1,M2] b ? x:Y -> Qf x"
by (simp add: cspT_eq_ref_iff cspT_Rec_prefix_mono)

lemma cspT_Int_pre_choice_cong:
  "[| X = Y ;
      !! x. x:Y ==> Pf x =T[M1,M2] Qf x |]
    ==> ! :X -> Pf =T[M1,M2] ! :Y -> Qf"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspT_decompo)
done

lemma cspT_Nondet_send_prefix_cong:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x =T[M1,M2] Qf x |]
    ==> a !? x:X -> Pf x =T[M1,M2] b !? x:Y -> Qf x"
by (simp add: cspT_eq_ref_iff cspT_Nondet_send_prefix_mono)

lemmas cspT_prefix_ss_mono = cspT_Send_prefix_mono
                             cspT_Rec_prefix_mono
                             cspT_Int_pre_choice_mono
                             cspT_Nondet_send_prefix_mono

lemmas cspT_prefx_ss_cong = cspT_Send_prefix_cong
                            cspT_Rec_prefix_cong
                            cspT_Int_pre_choice_cong
                            cspT_Nondet_send_prefix_cong

(* ------------------------------------------------------ *
                 decomposition with ss
 * ------------------------------------------------------ *)

lemmas cspT_mono_ss = cspT_mono  cspT_prefix_ss_mono
lemmas cspT_cong_ss = cspT_cong  cspT_prefx_ss_cong
lemmas cspT_decompo_ss = cspT_mono_ss cspT_cong_ss

(*********************************************************
             Rep_internal_choice for UNIV
              this is useful for tactic
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

(* mono_UNIV *)

lemma cspT_Rep_int_choice_mono_UNIV_nat:
  "[| !! n. Pf n <=T[M1,M2] Qf n |]
      ==> !nat n .. Pf n <=T[M1,M2] !nat n .. Qf n"
by (simp add: cspT_Rep_int_choice_mono)

lemma cspT_Rep_int_choice_mono_UNIV_set:
  "[| !! X. Pf X <=T[M1,M2] Qf X |]
      ==> !set X .. Pf X <=T[M1,M2] !set X .. Qf X"
by (simp add: cspT_Rep_int_choice_mono)

lemma cspT_Rep_int_choice_mono_UNIV_com:
  "[| !! x. Pf x <=T[M1,M2] Qf x |]
      ==> ! x .. Pf x <=T[M1,M2] ! x .. Qf x"
by (simp add: cspT_Rep_int_choice_mono)

lemma cspT_Rep_int_choice_mono_UNIV_f:
  "[| inj f ; !! x. Pf x <=T[M1,M2] Qf x |]
      ==> !<f> x .. Pf x <=T[M1,M2] !<f> x .. Qf x"
by (simp add: cspT_Rep_int_choice_mono)

lemmas cspT_Rep_int_choice_mono_UNIV =
      cspT_Rep_int_choice_mono_UNIV_nat
      cspT_Rep_int_choice_mono_UNIV_set
      cspT_Rep_int_choice_mono_UNIV_com
      cspT_Rep_int_choice_mono_UNIV_f

(* cong *)

lemma cspT_Rep_int_choice_cong_UNIV_nat:
  "[| !! n. Pf n =T[M1,M2] Qf n |]
      ==> !nat n .. Pf n =T[M1,M2] !nat n .. Qf n"
by (simp add: cspT_Rep_int_choice_cong)

lemma cspT_Rep_int_choice_cong_UNIV_set:
  "[| !! X. Pf X =T[M1,M2] Qf X |]
      ==> !set X .. Pf X =T[M1,M2] !set X .. Qf X"
by (simp add: cspT_Rep_int_choice_cong)

lemma cspT_Rep_int_choice_cong_UNIV_com:
  "[| !! x. Pf x =T[M1,M2] Qf x |]
      ==> ! x .. Pf x =T[M1,M2] ! x .. Qf x"
by (simp add: cspT_Rep_int_choice_cong)

lemma cspT_Rep_int_choice_cong_UNIV_f:
  "[| inj f ; !! x. Pf x =T[M1,M2] Qf x |]
      ==> !<f> x .. Pf x =T[M1,M2] !<f> x .. Qf x"
by (simp add: cspT_Rep_int_choice_cong)

lemmas cspT_Rep_int_choice_cong_UNIV =
      cspT_Rep_int_choice_cong_UNIV_nat
      cspT_Rep_int_choice_cong_UNIV_set
      cspT_Rep_int_choice_cong_UNIV_com
      cspT_Rep_int_choice_cong_UNIV_f

end


(*  Title:      Containers/AssocList.thy
    Author:     Andreas Lochbihler, KIT *)

theory AssocList imports
  "HOL-Library.DAList"
begin

section \<open>Additional operations for associative lists\<close>

subsection \<open>Operations on the raw type\<close>

primrec update_with_aux :: "'val \<Rightarrow> 'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "update_with_aux v k f [] = [(k, f v)]"
| "update_with_aux v k f (p # ps) = (if (fst p = k) then (k, f (snd p)) # ps else p # update_with_aux v k f ps)"

text \<open>
  Do not use @{term "AList.delete"} because this traverses all the list even if it has found the key.
  We do not have to keep going because we use the invariant that keys are distinct.
\<close>
fun delete_aux :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "delete_aux k [] = []"
| "delete_aux k ((k', v) # xs) = (if k = k' then xs else (k', v) # delete_aux k xs)"

lemma update_conv_update_with_aux:
  "AList.update k v xs = update_with_aux v k (\<lambda>_. v) xs"
by(induct xs) simp_all

lemma map_of_update_with_aux':
  "map_of (update_with_aux v k f ps) k' = ((map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))) k'"
by(induct ps) auto

lemma map_of_update_with_aux:
  "map_of (update_with_aux v k f ps) = (map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))"
by(simp add: fun_eq_iff map_of_update_with_aux')

lemma dom_update_with_aux: "fst ` set (update_with_aux v k f ps) = {k} \<union> fst ` set ps"
  by (induct ps) auto

lemma distinct_update_with_aux [simp]:
  "distinct (map fst (update_with_aux v k f ps)) = distinct (map fst ps)"
by(induct ps)(auto simp add: dom_update_with_aux)

lemma set_update_with_aux:
  "distinct (map fst xs)
  \<Longrightarrow> set (update_with_aux v k f xs) = (set xs - {k} \<times> UNIV \<union> {(k, f (case map_of xs k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by(induct xs)(auto intro: rev_image_eqI)

lemma set_delete_aux: "distinct (map fst xs) \<Longrightarrow> set (delete_aux k xs) = set xs - {k} \<times> UNIV"
apply(induct xs)
apply simp_all
apply clarsimp
apply(fastforce intro: rev_image_eqI)
done

lemma dom_delete_aux: "distinct (map fst ps) \<Longrightarrow> fst ` set (delete_aux k ps) = fst ` set ps - {k}"
by(auto simp add: set_delete_aux)

lemma distinct_delete_aux [simp]:
  "distinct (map fst ps) \<Longrightarrow> distinct (map fst (delete_aux k ps))"
proof(induct ps)
  case Nil thus ?case by simp
next
  case (Cons a ps)
  obtain k' v where a: "a = (k', v)" by(cases a)
  show ?case
  proof(cases "k' = k")
    case True with Cons a show ?thesis by simp
  next
    case False
    with Cons a have "k' \<notin> fst ` set ps" "distinct (map fst ps)" by simp_all
    with False a have "k' \<notin> fst ` set (delete_aux k ps)"
      by(auto dest!: dom_delete_aux[where k=k])
    with Cons a show ?thesis by simp
  qed
qed

lemma map_of_delete_aux':
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) = (map_of xs)(k := None)"
by(induct xs)(fastforce simp add: map_of_eq_None_iff fun_upd_twist)+

lemma map_of_delete_aux:
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) k' = ((map_of xs)(k := None)) k'"
by(simp add: map_of_delete_aux')

lemma delete_aux_eq_Nil_conv: "delete_aux k ts = [] \<longleftrightarrow> ts = [] \<or> (\<exists>v. ts = [(k, v)])"
by(cases ts)(auto split: if_split_asm)

subsection \<open>Operations on the abstract type @{typ "('a, 'b) alist"}\<close>

lift_definition update_with :: "'v \<Rightarrow> 'k \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) alist \<Rightarrow> ('k, 'v) alist"
  is "update_with_aux" by simp

lift_definition delete :: "'k \<Rightarrow> ('k, 'v) alist \<Rightarrow> ('k, 'v) alist" is "delete_aux"
by simp

lift_definition keys :: "('k, 'v) alist \<Rightarrow> 'k set" is "set \<circ> map fst" .

lift_definition set :: "('key, 'val) alist \<Rightarrow> ('key \<times> 'val) set"
is "List.set" .

lemma lookup_update_with [simp]:
  "DAList.lookup (update_with v k f al) = (DAList.lookup al)(k \<mapsto> case DAList.lookup al k of None \<Rightarrow> f v | Some v \<Rightarrow> f v)"
by transfer(simp add: map_of_update_with_aux)

lemma lookup_delete [simp]: "DAList.lookup (delete k al) = (DAList.lookup al)(k := None)"
by transfer(simp add: map_of_delete_aux')

lemma finite_dom_lookup [simp, intro!]: "finite (dom (DAList.lookup m))"
by transfer(simp add: finite_dom_map_of)

lemma update_conv_update_with: "DAList.update k v = update_with v k (\<lambda>_. v)"
by(rule ext)(transfer, simp add: update_conv_update_with_aux)

lemma lookup_update [simp]: "DAList.lookup (DAList.update k v al) = (DAList.lookup al)(k \<mapsto> v)"
by(simp add: update_conv_update_with split: option.split)

lemma dom_lookup_keys: "dom (DAList.lookup al) = keys al"
by transfer(simp add: dom_map_of_conv_image_fst)

lemma keys_empty [simp]: "keys DAList.empty = {}"
by transfer simp

lemma keys_update_with [simp]: "keys (update_with v k f al) = insert k (keys al)"
by(simp add: dom_lookup_keys[symmetric])

lemma keys_update [simp]: "keys (DAList.update k v al) = insert k (keys al)"
by(simp add: update_conv_update_with)

lemma keys_delete [simp]: "keys (delete k al) = keys al - {k}"
by(simp add: dom_lookup_keys[symmetric])

lemma set_empty [simp]: "set DAList.empty = {}"
by transfer simp

lemma set_update_with:
  "set (update_with v k f al) =
  (set al - {k} \<times> UNIV \<union> {(k, f (case DAList.lookup al k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by transfer(simp add: set_update_with_aux)

lemma set_update: "set (DAList.update k v al) = (set al - {k} \<times> UNIV \<union> {(k, v)})"
by(simp add: update_conv_update_with set_update_with)

lemma set_delete: "set (delete k al) = set al - {k} \<times> UNIV"
by transfer(simp add: set_delete_aux)

lemma size_dalist_transfer [transfer_rule]:
  includes lifting_syntax
  shows "(pcr_alist (=) (=) ===> (=)) length size"
unfolding size_alist_def[abs_def]
by transfer_prover

lemma size_eq_card_dom_lookup: "size al = card (dom (DAList.lookup al))"
by transfer (metis comp_apply distinct_card dom_map_of_conv_image_fst image_set length_map)

hide_const (open) update_with keys set delete

end


(*  Title:      ZF/InfDatatype.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Infinite-Branching Datatype Definitions\<close>

theory InfDatatype imports Datatype Univ Finite Cardinal_AC begin

lemmas fun_Limit_VfromE =
    Limit_VfromE [OF apply_funtype InfCard_csucc [THEN InfCard_is_Limit]]

lemma fun_Vcsucc_lemma:
  assumes f: "f \<in> D -> Vfrom(A,csucc(K))" and DK: "|D| \<le> K" and ICK: "InfCard(K)"
  shows "\<exists>j. f \<in> D -> Vfrom(A,j) & j < csucc(K)"
proof (rule exI, rule conjI)
  show "f \<in> D \<rightarrow> Vfrom(A, \<Union>z\<in>D. \<mu> i. f`z \<in> Vfrom (A,i))"
    proof (rule Pi_type [OF f])
      fix d
      assume d: "d \<in> D"
      show "f ` d \<in> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))"
        proof (rule fun_Limit_VfromE [OF f d ICK])
          fix x
          assume "x < csucc(K)"  "f ` d \<in> Vfrom(A, x)"
          hence "f`d \<in> Vfrom(A, \<mu> i. f`d \<in> Vfrom (A,i))" using d
            by (fast elim: LeastI ltE)
          also have "... \<subseteq> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))"
            by (rule Vfrom_mono) (auto intro: d)
          finally show "f`d \<in> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))" .
        qed
    qed
next
  show "(\<Union>d\<in>D. \<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
    proof (rule le_UN_Ord_lt_csucc [OF ICK DK])
      fix d
      assume d: "d \<in> D"
      show "(\<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
        proof (rule fun_Limit_VfromE [OF f d ICK])
          fix x
          assume "x < csucc(K)"  "f ` d \<in> Vfrom(A, x)"
          thus "(\<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
            by (blast intro: Least_le lt_trans1 lt_Ord)
        qed
    qed
qed

lemma subset_Vcsucc:
     "[| D \<subseteq> Vfrom(A,csucc(K));  |D| \<le> K;  InfCard(K) |]
      ==> \<exists>j. D \<subseteq> Vfrom(A,j) & j < csucc(K)"
by (simp add: subset_iff_id fun_Vcsucc_lemma)

(*Version for arbitrary index sets*)
lemma fun_Vcsucc:
     "[| |D| \<le> K;  InfCard(K);  D \<subseteq> Vfrom(A,csucc(K)) |] ==>
          D -> Vfrom(A,csucc(K)) \<subseteq> Vfrom(A,csucc(K))"
apply (safe dest!: fun_Vcsucc_lemma subset_Vcsucc)
apply (rule Vfrom [THEN ssubst])
apply (drule fun_is_rel)
(*This level includes the function, and is below csucc(K)*)
apply (rule_tac a1 = "succ (succ (j \<union> ja))" in UN_I [THEN UnI2])
apply (blast intro: ltD InfCard_csucc InfCard_is_Limit Limit_has_succ
                    Un_least_lt)
apply (erule subset_trans [THEN PowI])
apply (fast intro: Pair_in_Vfrom Vfrom_UnI1 Vfrom_UnI2)
done

lemma fun_in_Vcsucc:
     "[| f: D -> Vfrom(A, csucc(K));  |D| \<le> K;  InfCard(K);
         D \<subseteq> Vfrom(A,csucc(K)) |]
       ==> f: Vfrom(A,csucc(K))"
by (blast intro: fun_Vcsucc [THEN subsetD])

text\<open>Remove \<open>\<subseteq>\<close> from the rule above\<close>
lemmas fun_in_Vcsucc' = fun_in_Vcsucc [OF _ _ _ subsetI]

(** Version where K itself is the index set **)

lemma Card_fun_Vcsucc:
     "InfCard(K) ==> K -> Vfrom(A,csucc(K)) \<subseteq> Vfrom(A,csucc(K))"
apply (frule InfCard_is_Card [THEN Card_is_Ord])
apply (blast del: subsetI
             intro: fun_Vcsucc Ord_cardinal_le i_subset_Vfrom
                   lt_csucc [THEN leI, THEN le_imp_subset, THEN subset_trans])
done

lemma Card_fun_in_Vcsucc:
     "[| f: K -> Vfrom(A, csucc(K));  InfCard(K) |] ==> f: Vfrom(A,csucc(K))"
by (blast intro: Card_fun_Vcsucc [THEN subsetD])

lemma Limit_csucc: "InfCard(K) ==> Limit(csucc(K))"
by (erule InfCard_csucc [THEN InfCard_is_Limit])

lemmas Pair_in_Vcsucc = Pair_in_VLimit [OF _ _ Limit_csucc]
lemmas Inl_in_Vcsucc = Inl_in_VLimit [OF _ Limit_csucc]
lemmas Inr_in_Vcsucc = Inr_in_VLimit [OF _ Limit_csucc]
lemmas zero_in_Vcsucc = Limit_csucc [THEN zero_in_VLimit]
lemmas nat_into_Vcsucc = nat_into_VLimit [OF _ Limit_csucc]

(*For handling Cardinals of the form  @{term"nat \<union> |X|"} *)

lemmas InfCard_nat_Un_cardinal = InfCard_Un [OF InfCard_nat Card_cardinal]

lemmas le_nat_Un_cardinal =
     Un_upper2_le [OF Ord_nat Card_cardinal [THEN Card_is_Ord]]

lemmas UN_upper_cardinal = UN_upper [THEN subset_imp_lepoll, THEN lepoll_imp_Card_le]

(*The new version of Data_Arg.intrs, declared in Datatype.ML*)
lemmas Data_Arg_intros =
       SigmaI InlI InrI
       Pair_in_univ Inl_in_univ Inr_in_univ
       zero_in_univ A_into_univ nat_into_univ UnCI

(*For most K-branching datatypes with domain Vfrom(A, csucc(K)) *)
lemmas inf_datatype_intros =
     InfCard_nat InfCard_nat_Un_cardinal
     Pair_in_Vcsucc Inl_in_Vcsucc Inr_in_Vcsucc
     zero_in_Vcsucc A_into_Vfrom nat_into_Vcsucc
     Card_fun_in_Vcsucc fun_in_Vcsucc' UN_I

end


section \<open>Breadth First Search\<close>
theory Augmenting_Path_BFS
imports
  Flow_Networks.Refine_Add_Fofu
  Flow_Networks.Graph_Impl
begin
  text \<open>
    In this theory, we present a verified breadth-first search
    with an efficient imperative implementation.
    It is parametric in the successor function.
    \<close>

  subsection \<open>Algorithm\<close>
  locale pre_bfs_invar = Graph +
    fixes src dst :: node
  begin

    abbreviation "ndist v \<equiv> min_dist src v"

    definition Vd :: "nat \<Rightarrow> node set"
    where
      "\<And>d. Vd d \<equiv> {v. connected src v \<and> ndist v = d}"

    lemma Vd_disj: "\<And>d d'. d\<noteq>d' \<Longrightarrow> Vd d \<inter> Vd d' = {}"
      by (auto simp: Vd_def)

    lemma src_Vd0[simp]: "Vd 0 = {src}"
      by (auto simp: Vd_def)

    lemma in_Vd_conv: "v\<in>Vd d \<longleftrightarrow> connected src v \<and> ndist v = d"
      by (auto simp: Vd_def)

    lemma Vd_succ:
      assumes "u\<in>Vd d"
      assumes "(u,v)\<in>E"
      assumes "\<forall>i\<le>d. v\<notin>Vd i"
      shows "v\<in>Vd (Suc d)"
      using assms
      by (metis connected_append_edge in_Vd_conv le_SucE min_dist_succ)

  end

  locale valid_PRED = pre_bfs_invar +
    fixes PRED :: "node \<rightharpoonup> node"
    assumes SRC_IN_V[simp]: "src\<in>V"
    assumes FIN_V[simp, intro!]: "finite V"
    assumes PRED_src[simp]: "PRED src = Some src"
    assumes PRED_dist: "\<lbrakk>v\<noteq>src; PRED v = Some u\<rbrakk> \<Longrightarrow> ndist v = Suc (ndist u)"
    assumes PRED_E: "\<lbrakk>v\<noteq>src; PRED v = Some u\<rbrakk> \<Longrightarrow> (u,v)\<in>E"
    assumes PRED_closed: "\<lbrakk> PRED v = Some u \<rbrakk> \<Longrightarrow> u\<in>dom PRED"
  begin
    lemma FIN_E[simp, intro!]: "finite E" using E_ss_VxV by simp
    lemma FIN_succ[simp, intro!]: "finite (E``{u})"
      by (auto intro: finite_Image)
  end

  locale nf_invar' = valid_PRED c src dst PRED for c src dst
    and PRED :: "node \<rightharpoonup> node"
    and C N :: "node set"
    and d :: nat
    +
    assumes VIS_eq: "dom PRED = N \<union> {u. \<exists>i\<le>d. u\<in>Vd i}"
    assumes C_ss: "C \<subseteq> Vd d"
    assumes N_eq: "N = Vd (d+1) \<inter> E``(Vd d - C)"

    assumes dst_ne_VIS: "dst \<notin> dom PRED"

  locale nf_invar = nf_invar' +
    assumes empty_assm: "C={} \<Longrightarrow> N={}"

  locale f_invar = valid_PRED c src dst PRED for c src dst
    and PRED :: "node \<rightharpoonup> node"
    and d :: nat
    +
    assumes dst_found: "dst \<in> dom PRED \<inter> Vd d"

  context Graph begin

    abbreviation "outer_loop_invar src dst \<equiv> \<lambda>(f,PRED,C,N,d).
      (f \<longrightarrow> f_invar c src dst PRED d) \<and>
      (\<not>f \<longrightarrow> nf_invar c src dst PRED C N d)

      "
    abbreviation "assn1 src dst \<equiv> \<lambda>(f,PRED,C,N,d).
      \<not>f \<and> nf_invar' c src dst PRED C N d"

  definition "add_succ_spec dst succ v PRED N \<equiv> ASSERT (N \<subseteq> dom PRED) \<then>
    SPEC (\<lambda>(f,PRED',N').
      case f of
        False \<Rightarrow> dst \<notin> succ - dom PRED
          \<and> PRED' = map_mmupd PRED (succ - dom PRED) v
          \<and> N' = N \<union> (succ - dom PRED)
      | True \<Rightarrow> dst \<in> succ - dom PRED
        \<and> PRED \<subseteq>\<^sub>m PRED'
        \<and> PRED' \<subseteq>\<^sub>m map_mmupd PRED (succ - dom PRED) v
        \<and> dst\<in>dom PRED'
  )"

  definition pre_bfs :: "node \<Rightarrow> node \<Rightarrow> (nat \<times> (node\<rightharpoonup>node)) option nres"
    where "pre_bfs src dst \<equiv> do {
    (f,PRED,_,_,d) \<leftarrow> WHILEIT (outer_loop_invar src dst)
      (\<lambda>(f,PRED,C,N,d). f=False \<and> C\<noteq>{})
      (\<lambda>(f,PRED,C,N,d). do {
        v \<leftarrow> SPEC (\<lambda>v. v\<in>C); let C = C-{v};
        ASSERT (v\<in>V);
        let succ = (E``{v});
        ASSERT (finite succ);
        (f,PRED,N) \<leftarrow> add_succ_spec dst succ v PRED N;
        if f then
          RETURN (f,PRED,C,N,d+1)
        else do {
          ASSERT (assn1 src dst (f,PRED,C,N,d));
          if (C={}) then do {
            let C=N;
            let N={};
            let d=d+1;
            RETURN (f,PRED,C,N,d)
          } else RETURN (f,PRED,C,N,d)
        }
      })
      (False,[src\<mapsto>src],{src},{},0::nat);
    if f then RETURN (Some (d, PRED)) else RETURN None
    }"

  subsection "Correctness Proof"

  lemma (in nf_invar') ndist_C[simp]: "\<lbrakk>v\<in>C\<rbrakk> \<Longrightarrow> ndist v = d"
    using C_ss by (auto simp: Vd_def)
  lemma (in nf_invar) CVdI: "\<lbrakk>u\<in>C\<rbrakk> \<Longrightarrow> u\<in>Vd d"
    using C_ss by (auto)

  lemma (in nf_invar) inPREDD:
    "\<lbrakk>PRED v = Some u\<rbrakk> \<Longrightarrow> v\<in>N \<or> (\<exists>i\<le>d. v\<in>Vd i)"
    using VIS_eq by (auto)

  lemma (in nf_invar') C_ss_VIS: "\<lbrakk>v\<in>C\<rbrakk> \<Longrightarrow> v\<in>dom PRED"
    using C_ss VIS_eq by blast

  lemma (in nf_invar) invar_succ_step:
    assumes "v\<in>C"
    assumes "dst \<notin> E``{v} - dom PRED"
    shows "nf_invar' c src dst
      (map_mmupd PRED (E``{v} - dom PRED) v)
      (C-{v})
      (N \<union> (E``{v} - dom PRED))
      d"
  proof -
    from C_ss_VIS[OF \<open>v\<in>C\<close>] dst_ne_VIS have "v\<noteq>dst" by auto

    show ?thesis
      using \<open>v\<in>C\<close> \<open>v\<noteq>dst\<close>
      apply unfold_locales
      apply simp
      apply simp
      apply (auto simp: map_mmupd_def) []

      apply (erule map_mmupdE)
      using PRED_dist apply blast
      apply (unfold VIS_eq) []
      apply clarify
      apply (metis CVdI Vd_succ in_Vd_conv)

      using PRED_E apply (auto elim!: map_mmupdE) []
      using PRED_closed apply (auto elim!: map_mmupdE dest: C_ss_VIS) []

      using VIS_eq apply auto []
      using C_ss apply auto []

      apply (unfold N_eq) []
      apply (frule CVdI)
      apply (auto) []
      apply (erule (1) Vd_succ)
      using VIS_eq apply (auto) []
      apply (auto dest!: inPREDD simp: N_eq in_Vd_conv) []

      using dst_ne_VIS assms(2) apply auto []
      done
  qed

  lemma invar_init: "\<lbrakk>src\<noteq>dst; src\<in>V; finite V\<rbrakk>
    \<Longrightarrow> nf_invar c src dst [src \<mapsto> src] {src} {} 0"
    apply unfold_locales
    apply (auto)
    apply (auto simp: pre_bfs_invar.Vd_def split: if_split_asm)
    done

  lemma (in nf_invar) invar_exit:
    assumes "dst\<in>C"
    shows "f_invar c src dst PRED d"
    apply unfold_locales
    using assms VIS_eq C_ss by auto

  lemma (in nf_invar) invar_C_ss_V: "u\<in>C \<Longrightarrow> u\<in>V"
    apply (drule CVdI)
    apply (auto simp: in_Vd_conv connected_inV_iff)
    done

  lemma (in nf_invar) invar_N_ss_Vis: "u\<in>N \<Longrightarrow> \<exists>v. PRED u = Some v"
    using VIS_eq by auto

  lemma (in pre_bfs_invar) Vdsucinter_conv[simp]:
    "Vd (Suc d) \<inter> E `` Vd d = Vd (Suc d)"
    apply (auto)
    by (metis Image_iff in_Vd_conv min_dist_suc)

  lemma (in nf_invar') invar_shift:
    assumes [simp]: "C={}"
    shows "nf_invar c src dst PRED N {} (Suc d)"
    apply unfold_locales
    apply vc_solve
    using VIS_eq N_eq[simplified] apply (auto simp add: le_Suc_eq) []
    using N_eq apply auto []
    using N_eq[simplified] apply auto []
    using dst_ne_VIS apply auto []
    done

  lemma (in nf_invar') invar_restore:
    assumes [simp]: "C\<noteq>{}"
    shows "nf_invar c src dst PRED C N d"
    apply unfold_locales by auto

  definition "bfs_spec src dst r \<equiv> (
    case r of None \<Rightarrow> \<not> connected src dst
            | Some (d,PRED) \<Rightarrow> connected src dst
                \<and> min_dist src dst = d
                \<and> valid_PRED c src PRED
                \<and> dst\<in>dom PRED)"

  lemma (in f_invar) invar_found:
    shows "bfs_spec src dst (Some (d,PRED))"
    unfolding bfs_spec_def
    apply simp
    using dst_found
    apply (auto simp: in_Vd_conv)
    by unfold_locales

  lemma (in nf_invar) invar_not_found:
    assumes [simp]: "C={}"
    shows "bfs_spec src dst None"
    unfolding bfs_spec_def
    apply simp
  proof (rule notI)
    have [simp]: "N={}" using empty_assm by simp

    assume C: "connected src dst"
    then obtain d' where dstd': "dst \<in> Vd d'"
      by (auto simp: in_Vd_conv)

    txt \<open>We make a case-distinction whether \<open>d'\<le>d\<close>:\<close>
    have "d'\<le>d \<or> Suc d \<le> d'" by auto
    moreover {
      assume "d'\<le>d"
      with VIS_eq dstd' have "dst \<in> dom PRED" by auto
      with dst_ne_VIS have False by auto
    } moreover {
      assume "Suc d \<le> d'"
      txt \<open>In the case \<open>d+1 \<le> d'\<close>, we also obtain a node
        that has a shortest path of length \<open>d+1\<close>:\<close>
      with min_dist_le[OF C] dstd' obtain v' where "v' \<in> Vd (Suc d)"
        by (auto simp: in_Vd_conv)
      txt \<open>However, the invariant states that such nodes are either in
        \<open>N\<close> or are successors of \<open>C\<close>. As \<open>N\<close>
        and \<open>C\<close> are both empty, we again get a contradiction.\<close>
      with N_eq have False by auto
    } ultimately show False by blast
  qed

  lemma map_le_mp: "\<lbrakk>m\<subseteq>\<^sub>mm'; m k = Some v\<rbrakk> \<Longrightarrow> m' k = Some v"
    by (force simp: map_le_def)

  lemma (in nf_invar) dst_notin_Vdd[intro, simp]: "i\<le>d \<Longrightarrow> dst\<notin>Vd i"
    using VIS_eq dst_ne_VIS by auto

  lemma (in nf_invar) invar_exit':
    assumes "u\<in>C" "(u,dst) \<in> E" "dst \<in> dom PRED'"
    assumes SS1: "PRED \<subseteq>\<^sub>m PRED'"
      and SS2: "PRED' \<subseteq>\<^sub>m map_mmupd PRED (E``{u} - dom PRED) u"
    shows "f_invar c src dst PRED' (Suc d)"
    apply unfold_locales
    apply simp_all

    using map_le_mp[OF SS1 PRED_src] apply simp

    apply (drule map_le_mp[OF SS2])
    apply (erule map_mmupdE)
    using PRED_dist apply auto []
    apply (unfold VIS_eq) []
    apply clarify
    using \<open>u\<in>C\<close>
    apply (metis CVdI Vd_succ in_Vd_conv)

    apply (drule map_le_mp[OF SS2])
    using PRED_E apply (auto elim!: map_mmupdE) []

    apply (drule map_le_mp[OF SS2])
    apply (erule map_mmupdE)
    using map_le_implies_dom_le[OF SS1]
    using PRED_closed apply (blast) []
    using C_ss_VIS[OF \<open>u\<in>C\<close>] map_le_implies_dom_le[OF SS1] apply blast
    using \<open>dst \<in> dom PRED'\<close> apply simp

    using \<open>u\<in>C\<close> CVdI[OF \<open>u\<in>C\<close>] \<open>(u,dst)\<in>E\<close>
    apply (auto) []
    apply (erule (1) Vd_succ)
    using VIS_eq apply (auto) []
    done

  definition "max_dist src \<equiv> Max (min_dist src`V)"

  definition "outer_loop_rel src \<equiv>
    inv_image (
        less_than_bool
        <*lex*> greater_bounded (max_dist src + 1)
        <*lex*> finite_psubset)
      (\<lambda>(f,PRED,C,N,d). (\<not>f,d,C))"
  lemma outer_loop_rel_wf:
    assumes "finite V"
    shows "wf (outer_loop_rel src)"
    using assms
    unfolding outer_loop_rel_def
    by auto

  lemma (in nf_invar) C_ne_max_dist:
    assumes "C\<noteq>{}"
    shows "d \<le> max_dist src"
  proof -
    from assms obtain u where "u\<in>C" by auto
    with C_ss have "u\<in>Vd d" by auto
    hence "min_dist src u = d" "u\<in>V"
      by (auto simp: in_Vd_conv connected_inV_iff)
    thus "d\<le>max_dist src"
      unfolding max_dist_def by auto
  qed

  lemma (in nf_invar) Vd_ss_V: "Vd d \<subseteq> V"
    by (auto simp: Vd_def connected_inV_iff)

  lemma (in nf_invar) finite_C[simp, intro!]: "finite C"
    using C_ss FIN_V Vd_ss_V by (blast intro: finite_subset)

  lemma (in nf_invar) finite_succ: "finite (E``{u})"
    by auto

  theorem pre_bfs_correct:
    assumes [simp]: "src\<in>V" "src\<noteq>dst"
    assumes [simp]: "finite V"
    shows "pre_bfs src dst \<le> SPEC (bfs_spec src dst)"
    unfolding pre_bfs_def add_succ_spec_def
    apply (intro refine_vcg)
    apply (rule outer_loop_rel_wf[where src=src])
    apply (vc_solve simp:
      invar_init
      nf_invar.invar_exit'
      nf_invar.invar_C_ss_V
      nf_invar.invar_succ_step
      nf_invar'.invar_shift
      nf_invar'.invar_restore
      f_invar.invar_found
      nf_invar.invar_not_found
      nf_invar.invar_N_ss_Vis
      nf_invar.finite_succ
      )
    apply (vc_solve
      simp: remove_subset outer_loop_rel_def
      simp: nf_invar.C_ne_max_dist nf_invar.finite_C)
    done

  (* Presentation for Paper *)
  definition bfs_core :: "node \<Rightarrow> node \<Rightarrow> (nat \<times> (node\<rightharpoonup>node)) option nres"
    where "bfs_core src dst \<equiv> do {
    (f,P,_,_,d) \<leftarrow> while\<^sub>T (\<lambda>(f,P,C,N,d). f=False \<and> C\<noteq>{})
      (\<lambda>(f,P,C,N,d). do {
        v \<leftarrow> spec v. v\<in>C; let C = C-{v};
        let succ = (E``{v});
        (f,P,N) \<leftarrow> add_succ_spec dst succ v P N;
        if f then
          return (f,P,C,N,d+1)
        else do {
          if (C={}) then do {
            let C=N; let N={}; let d=d+1;
            return (f,P,C,N,d)
          } else return (f,P,C,N,d)
        }
      })
      (False,[src\<mapsto>src],{src},{},0::nat);
    if f then return (Some (d, P)) else return None
    }"

  theorem
    assumes "src\<in>V" "src\<noteq>dst" "finite V"
    shows "bfs_core src dst \<le> (spec p. bfs_spec src dst p)"
    apply (rule order_trans[OF _ pre_bfs_correct])
    apply (rule refine_IdD)
    unfolding bfs_core_def pre_bfs_def
    apply refine_rcg
    apply refine_dref_type
    apply (vc_solve simp: assms)
    done

  subsection \<open>Extraction of Result Path\<close>

    definition "extract_rpath src dst PRED \<equiv> do {
      (_,p) \<leftarrow> WHILEIT
        (\<lambda>(v,p).
          v\<in>dom PRED
        \<and> isPath v p dst
        \<and> distinct (pathVertices v p)
        \<and> (\<forall>v'\<in>set (pathVertices v p).
            pre_bfs_invar.ndist c src v \<le> pre_bfs_invar.ndist c src v')
        \<and> pre_bfs_invar.ndist c src v + length p
          = pre_bfs_invar.ndist c src dst)
        (\<lambda>(v,p). v\<noteq>src) (\<lambda>(v,p). do {
        ASSERT (v\<in>dom PRED);
        let u=the (PRED v);
        let p = (u,v)#p;
        let v=u;
        RETURN (v,p)
      }) (dst,[]);
      RETURN p
    }"

  end

  context valid_PRED begin
    lemma extract_rpath_correct:
      assumes "dst\<in>dom PRED"
      shows "extract_rpath src dst PRED
        \<le> SPEC (\<lambda>p. isSimplePath src p dst \<and> length p = ndist dst)"
      using assms unfolding extract_rpath_def isSimplePath_def
      apply (refine_vcg wf_measure[where f="\<lambda>(d,_). ndist d"])
      apply (vc_solve simp: PRED_closed[THEN domD] PRED_E PRED_dist)
      apply auto
      done

  end

  context Graph begin

    definition "bfs src dst \<equiv> do {
      if src=dst then RETURN (Some [])
      else do {
        br \<leftarrow> pre_bfs src dst;
        case br of
          None \<Rightarrow> RETURN None
        | Some (d,PRED) \<Rightarrow> do {
            p \<leftarrow> extract_rpath src dst PRED;
            RETURN (Some p)
          }
      }
    }"

    lemma bfs_correct:
      assumes "src\<in>V" "finite V"
      shows "bfs src dst
        \<le> SPEC (\<lambda>
          None \<Rightarrow> \<not>connected src dst
        | Some p \<Rightarrow> isShortestPath src p dst)"
      unfolding bfs_def
      apply (refine_vcg
        pre_bfs_correct[THEN order_trans]
        valid_PRED.extract_rpath_correct[THEN order_trans]
        )
      using assms
      apply (vc_solve
        simp: bfs_spec_def isShortestPath_min_dist_def isSimplePath_def)
      done
  end

  (* Snippet for paper *)
  context Finite_Graph begin
    interpretation Refine_Monadic_Syntax .
    theorem
      assumes "src\<in>V"
      shows "bfs src dst \<le> (spec p. case p of
          None \<Rightarrow> \<not>connected src dst
        | Some p \<Rightarrow> isShortestPath src p dst)"
      unfolding bfs_def
      apply (refine_vcg
        pre_bfs_correct[THEN order_trans]
        valid_PRED.extract_rpath_correct[THEN order_trans]
        )
      using assms
      apply (vc_solve
        simp: bfs_spec_def isShortestPath_min_dist_def isSimplePath_def)
      done

  end

  subsection \<open>Inserting inner Loop and Successor Function\<close>
  context Graph begin

  definition "inner_loop dst succ u PRED N \<equiv> FOREACHci
    (\<lambda>it (f,PRED',N').
        PRED' = map_mmupd PRED ((succ - it) - dom PRED) u
      \<and> N' = N \<union> ((succ - it) - dom PRED)
      \<and> f = (dst\<in>(succ - it) - dom PRED)
    )
    (succ)
    (\<lambda>(f,PRED,N). \<not>f)
    (\<lambda>v (f,PRED,N). do {
      if v\<in>dom PRED then RETURN (f,PRED,N)
      else do {
        let PRED = PRED(v \<mapsto> u);
        ASSERT (v\<notin>N);
        let N = insert v N;
        RETURN (v=dst,PRED,N)
      }
    })
    (False,PRED,N)"

  lemma inner_loop_refine[refine]:
    (*assumes NSS: "N \<subseteq> dom PRED"*)
    assumes [simp]: "finite succ"
    assumes [simplified, simp]:
      "(succi,succ)\<in>Id" "(ui,u)\<in>Id" "(PREDi,PRED)\<in>Id" "(Ni,N)\<in>Id"
    shows "inner_loop dst succi ui PREDi Ni
      \<le> \<Down>Id (add_succ_spec dst succ u PRED N)"
    unfolding inner_loop_def add_succ_spec_def
    apply refine_vcg
    apply (auto simp: it_step_insert_iff; fail) +
    apply (auto simp: it_step_insert_iff fun_neq_ext_iff map_mmupd_def
      split: if_split_asm) []
    apply (auto simp: it_step_insert_iff split: bool.split; fail)
    apply (auto simp: it_step_insert_iff split: bool.split; fail)
    apply (auto simp: it_step_insert_iff split: bool.split; fail)
    apply (auto simp: it_step_insert_iff intro: map_mmupd_update_less
      split: bool.split; fail)
    done

  definition "inner_loop2 dst succl u PRED N \<equiv> nfoldli
    (succl) (\<lambda>(f,_,_). \<not>f) (\<lambda>v (f,PRED,N). do {
    if PRED v \<noteq> None then RETURN (f,PRED,N)
    else do {
      let PRED = PRED(v \<mapsto> u);
      ASSERT (v\<notin>N);
      let N = insert v N;
      RETURN ((v=dst),PRED,N)
    }
  }) (False,PRED,N)"

  lemma inner_loop2_refine:
    assumes SR: "(succl,succ)\<in>\<langle>Id\<rangle>list_set_rel"
    shows "inner_loop2 dst succl u PRED N \<le> \<Down>Id (inner_loop dst succ u PRED N)"
    using assms
    unfolding inner_loop2_def inner_loop_def
    apply (refine_rcg LFOci_refine SR)
    apply (vc_solve)
    apply auto
    done

  thm conc_trans[OF inner_loop2_refine inner_loop_refine, no_vars]

  lemma inner_loop2_correct:
    assumes "(succl, succ) \<in> \<langle>Id\<rangle>list_set_rel"
    (*assumes "N \<subseteq> dom PRED"*)
    assumes [simplified, simp]:
      "(dsti,dst)\<in>Id" "(ui, u) \<in> Id" "(PREDi, PRED) \<in> Id" "(Ni, N) \<in> Id"
    shows "inner_loop2 dsti succl ui PREDi Ni
      \<le> \<Down> Id (add_succ_spec dst succ u PRED N)"
    apply simp
    apply (rule conc_trans[OF inner_loop2_refine inner_loop_refine, simplified])
    using assms(1-2)
    apply (simp_all)
    done

  type_synonym bfs_state = "bool \<times> (node \<rightharpoonup> node) \<times> node set \<times> node set \<times> nat"

    context
      fixes succ :: "node \<Rightarrow> node list nres"
    begin
      definition init_state :: "node \<Rightarrow> bfs_state nres"
      where
        "init_state src \<equiv> RETURN (False,[src\<mapsto>src],{src},{},0::nat)"

      definition pre_bfs2 :: "node \<Rightarrow> node \<Rightarrow> (nat \<times> (node\<rightharpoonup>node)) option nres"
        where "pre_bfs2 src dst \<equiv> do {
        s \<leftarrow> init_state src;
        (f,PRED,_,_,d) \<leftarrow> WHILET (\<lambda>(f,PRED,C,N,d). f=False \<and> C\<noteq>{})
          (\<lambda>(f,PRED,C,N,d). do {
            ASSERT (C\<noteq>{});
            v \<leftarrow> op_set_pick C; let C = C-{v};
            ASSERT (v\<in>V);
            sl \<leftarrow> succ v;
            (f,PRED,N) \<leftarrow> inner_loop2 dst sl v PRED N;
            if f then
              RETURN (f,PRED,C,N,d+1)
            else do {
              ASSERT (assn1 src dst (f,PRED,C,N,d));
              if (C={}) then do {
                let C=N;
                let N={};
                let d=d+1;
                RETURN (f,PRED,C,N,d)
              } else RETURN (f,PRED,C,N,d)
            }
          })
          s;
        if f then RETURN (Some (d, PRED)) else RETURN None
        }"

      lemma pre_bfs2_refine:
        assumes succ_impl: "\<And>ui u. \<lbrakk>(ui,u)\<in>Id; u\<in>V\<rbrakk>
          \<Longrightarrow> succ ui \<le> SPEC (\<lambda>l. (l,E``{u}) \<in> \<langle>Id\<rangle>list_set_rel)"
        shows "pre_bfs2 src dst \<le>\<Down>Id (pre_bfs src dst)"
        unfolding pre_bfs_def pre_bfs2_def init_state_def
        apply (subst nres_monad1)
        apply (refine_rcg inner_loop2_correct succ_impl)
        apply refine_dref_type
        apply vc_solve (* Takes some time *)
        done

    end

    definition "bfs2 succ src dst \<equiv> do {
      if src=dst then
        RETURN (Some [])
      else do {
        br \<leftarrow> pre_bfs2 succ src dst;
        case br of
          None \<Rightarrow> RETURN None
        | Some (d,PRED) \<Rightarrow> do {
            p \<leftarrow> extract_rpath src dst PRED;
            RETURN (Some p)
          }
      }
    }"

  end

  lemma bfs2_refine_succ:
    assumes [refine]: "\<And>ui u. \<lbrakk>(ui,u)\<in>Id; u\<in>Graph.V c\<rbrakk>
      \<Longrightarrow> succi ui \<le> \<Down>Id (succ u)"
    assumes [simplified, simp]: "(si,s)\<in>Id" "(ti,t)\<in>Id" "(ci,c)\<in>Id"
    shows "Graph.bfs2 ci succi si ti \<le> \<Down>Id (Graph.bfs2 c succ s t)"
    unfolding Graph.bfs2_def Graph.pre_bfs2_def
    apply (refine_rcg
      param_nfoldli[param_fo, THEN nres_relD] nres_relI fun_relI)
    apply refine_dref_type
    apply vc_solve
    done

subsection \<open>Imperative Implementation\<close>

  context Impl_Succ begin
    definition op_bfs :: "'ga \<Rightarrow> node \<Rightarrow> node \<Rightarrow> path option nres"
      where [simp]: "op_bfs c s t \<equiv> Graph.bfs2 (absG c) (succ c) s t"

    lemma pat_op_dfs[pat_rules]:
      "Graph.bfs2$(absG$c)$(succ$c)$s$t \<equiv> UNPROTECT op_bfs$c$s$t" by simp

    sepref_register "PR_CONST op_bfs"
      :: "'ig \<Rightarrow> node \<Rightarrow> node \<Rightarrow> path option nres"

    type_synonym ibfs_state
      = "bool \<times> (node,node) i_map \<times> node set \<times> node set \<times> nat"

    sepref_register Graph.init_state :: "node \<Rightarrow> ibfs_state nres"
    schematic_goal init_state_impl:
      fixes src :: nat
      notes [id_rules] =
        itypeI[Pure.of src "TYPE(nat)"]
      shows "hn_refine (hn_val nat_rel src srci)
        (?c::?'c Heap) ?\<Gamma>' ?R (Graph.init_state src)"
      using [[id_debug, goals_limit = 1]]
      unfolding Graph.init_state_def
      apply (rewrite in "[src\<mapsto>src]" iam.fold_custom_empty)
      apply (subst ls.fold_custom_empty)
      apply (subst ls.fold_custom_empty)
      apply (rewrite in "insert src _" fold_set_insert_dj)
      apply (rewrite in "_(\<hole>\<mapsto>src)" fold_COPY)
      apply sepref
      done
    concrete_definition (in -) init_state_impl uses Impl_Succ.init_state_impl
    lemmas [sepref_fr_rules] = init_state_impl.refine[OF this_loc,to_hfref]

    schematic_goal bfs_impl:
      (*notes [sepref_opt_simps del] = imp_nfoldli_def
          -- \<open>Prevent the foreach-loop to be unfolded to a fixed-point,
              to produce more readable code for presentation purposes.\<close>*)
      notes [sepref_opt_simps] = heap_WHILET_def
      fixes s t :: nat
      notes [id_rules] =
        itypeI[Pure.of s "TYPE(nat)"]
        itypeI[Pure.of t "TYPE(nat)"]
        itypeI[Pure.of c "TYPE('ig)"]
        \<comment> \<open>Declare parameters to operation identification\<close>
      shows "hn_refine (
        hn_ctxt (isG) c ci
      * hn_val nat_rel s si
      * hn_val nat_rel t ti) (?c::?'c Heap) ?\<Gamma>' ?R (PR_CONST op_bfs c s t)"
      unfolding op_bfs_def PR_CONST_def
      unfolding Graph.bfs2_def Graph.pre_bfs2_def
        Graph.inner_loop2_def Graph.extract_rpath_def
      unfolding nres_monad_laws
      apply (rewrite in "nfoldli _ _ \<hole> _" fold_set_insert_dj)
      apply (subst HOL_list.fold_custom_empty)+
      apply (rewrite in "let N={} in _" ls.fold_custom_empty)
      using [[id_debug, goals_limit = 1]]
      apply sepref
      done

    concrete_definition (in -) bfs_impl uses Impl_Succ.bfs_impl
      \<comment> \<open>Extract generated implementation into constant\<close>
    prepare_code_thms (in -) bfs_impl_def

    lemmas bfs_impl_fr_rule = bfs_impl.refine[OF this_loc,to_hfref]

  end

  export_code bfs_impl checking SML_imp

end