(*  Title:       BinaryFunctor
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter BinaryFunctor

theory BinaryFunctor
imports ProductCategory NaturalTransformation
begin

  text\<open>
    This theory develops various properties of binary functors, which are functors
    defined on product categories.
\<close>

  locale binary_functor =
    A1: category A1 +
    A2: category A2 +
    B: category B +
    A1xA2: product_category A1 A2 +
    "functor" A1xA2.comp B F
  for A1 :: "'a1 comp"     (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
  and A2 :: "'a2 comp"     (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
  and B :: "'b comp"       (infixr "\<cdot>\<^sub>B" 55)
  and F :: "'a1 * 'a2 \<Rightarrow> 'b"
  begin

    notation A1.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1 _\<guillemotright>")
    notation A2.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>2 _\<guillemotright>")

  end

  text\<open>
    A product functor is a binary functor obtained by placing two functors in parallel.
\<close>

  locale product_functor =
    A1: category A1 +
    A2: category A2 +
    B1: category B1 +
    B2: category B2 +
    F1: "functor" A1 B1 F1 +
    F2: "functor" A2 B2 F2 +
    A1xA2: product_category A1 A2 +
    B1xB2: product_category B1 B2
  for A1 :: "'a1 comp"     (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
  and A2 :: "'a2 comp"     (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
  and B1 :: "'b1 comp"     (infixr "\<cdot>\<^sub>B\<^sub>1" 55)
  and B2 :: "'b2 comp"     (infixr "\<cdot>\<^sub>B\<^sub>2" 55)
  and F1 :: "'a1 \<Rightarrow> 'b1"
  and F2 :: "'a2 \<Rightarrow> 'b2"
  begin

    notation A1xA2.comp    (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
    notation B1xB2.comp    (infixr "\<cdot>\<^sub>B\<^sub>1\<^sub>x\<^sub>B\<^sub>2" 55)
    notation A1.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1 _\<guillemotright>")
    notation A2.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>2 _\<guillemotright>")
    notation B1.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B\<^sub>1 _\<guillemotright>")
    notation B2.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B\<^sub>2 _\<guillemotright>")
    notation A1xA2.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
    notation B1xB2.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B\<^sub>1\<^sub>x\<^sub>B\<^sub>2 _\<guillemotright>")

    definition map
    where "map f = (if A1.arr (fst f) \<and> A2.arr (snd f)
                    then (F1 (fst f), F2 (snd f)) else B1xB2.null)"

    lemma map_simp [simp]:
    assumes "A1xA2.arr f"
    shows "map f = (F1 (fst f), F2 (snd f))"
      using assms map_def by simp

    lemma is_functor:
    shows "functor A1xA2.comp B1xB2.comp map"
      using B1xB2.dom_char B1xB2.cod_char
      apply (unfold_locales)
      using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
          apply auto[4]
      using A1xA2.seqE map_simp by fastforce

  end

  sublocale product_functor \<subseteq> "functor" A1xA2.comp B1xB2.comp map
    using is_functor by auto
  sublocale product_functor \<subseteq> binary_functor A1 A2 B1xB2.comp map ..

  text\<open>
    A symmetry functor is a binary functor that exchanges its two arguments.
\<close>

  locale symmetry_functor =
  A1: category A1 +
  A2: category A2 +
  A1xA2: product_category A1 A2 +
  A2xA1: product_category A2 A1
  for A1 :: "'a1 comp"     (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
  and A2 :: "'a2 comp"     (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
  begin

    notation A1xA2.comp    (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
    notation A2xA1.comp    (infixr "\<cdot>\<^sub>A\<^sub>2\<^sub>x\<^sub>A\<^sub>1" 55)
    notation A1xA2.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
    notation A2xA1.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>2\<^sub>x\<^sub>A\<^sub>1 _\<guillemotright>")

    definition map :: "'a1 * 'a2 \<Rightarrow> 'a2 * 'a1"
    where "map f = (if A1xA2.arr f then (snd f, fst f) else A2xA1.null)"

    lemma map_simp [simp]:
    assumes "A1xA2.arr f"
    shows "map f = (snd f, fst f)"
      using assms map_def by meson

    lemma is_functor:
    shows "functor A1xA2.comp A2xA1.comp map"
      using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
      apply (unfold_locales)
          apply auto[4]
      by force

  end

  sublocale symmetry_functor \<subseteq> "functor" A1xA2.comp A2xA1.comp map
    using is_functor by auto
  sublocale symmetry_functor \<subseteq> binary_functor A1 A2 A2xA1.comp map ..

  context binary_functor
  begin

    abbreviation sym
    where "sym \<equiv> (\<lambda>f. F (snd f, fst f))"

    lemma sym_is_binary_functor:
    shows "binary_functor A2 A1 B sym"
    proof -
      interpret A2xA1: product_category A2 A1 ..
      interpret S: symmetry_functor A2 A1 ..
      interpret SF: composite_functor A2xA1.comp A1xA2.comp B S.map F ..
      have "binary_functor A2 A1 B (F o S.map)" ..
      moreover have "F o S.map = (\<lambda>f. F (snd f, fst f))"
        using is_extensional SF.is_extensional S.map_def by fastforce
      ultimately show ?thesis using sym_def by auto
    qed

    text\<open>
      Fixing one or the other argument of a binary functor to be an identity
      yields a functor of the other argument.
\<close>

    lemma fixing_ide_gives_functor_1:
    assumes "A1.ide a1"
    shows "functor A2 B (\<lambda>f2. F (a1, f2))"
      using assms
      apply unfold_locales
      using is_extensional
          apply auto[4]
      by (metis A1.ideD(1) A1.comp_ide_self A1xA2.comp_simp A1xA2.seq_char fst_conv
          preserves_comp_2 snd_conv)

    lemma fixing_ide_gives_functor_2:
    assumes "A2.ide a2"
    shows "functor A1 B (\<lambda>f1. F (f1, a2))"
      using assms
      apply (unfold_locales)
      using is_extensional
          apply auto[4]
      by (metis A1xA2.comp_simp A1xA2.seq_char A2.ideD(1) A2.comp_ide_self fst_conv
          preserves_comp_2 snd_conv)

    text\<open>
      Fixing one or the other argument of a binary functor to be an arrow
      yields a natural transformation.
\<close>

    lemma fixing_arr_gives_natural_transformation_1:
    assumes "A1.arr f1"
    shows "natural_transformation A2 B (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2))
                                       (\<lambda>f2. F (f1, f2))"
    proof -
      let ?Fdom = "\<lambda>f2. F (A1.dom f1, f2)"
      interpret Fdom: "functor" A2 B ?Fdom using assms fixing_ide_gives_functor_1 by auto
      let ?Fcod = "\<lambda>f2. F (A1.cod f1, f2)"
      interpret Fcod: "functor" A2 B ?Fcod using assms fixing_ide_gives_functor_1 by auto
      let ?\<tau> = "\<lambda>f2. F (f1, f2)"
      show "natural_transformation A2 B ?Fdom ?Fcod ?\<tau>"
        using assms
        apply unfold_locales
        using is_extensional
            apply auto[3]
        using A1xA2.arr_char preserves_comp A1.comp_cod_arr A1xA2.comp_char A2.comp_arr_dom
         apply (metis fst_conv snd_conv)
        using A1xA2.arr_char preserves_comp A2.comp_cod_arr A1xA2.comp_char A1.comp_arr_dom
        by (metis fst_conv snd_conv)
    qed

    lemma fixing_arr_gives_natural_transformation_2:
    assumes "A2.arr f2"
    shows "natural_transformation A1 B (\<lambda>f1. F (f1, A2.dom f2)) (\<lambda>f1. F (f1, A2.cod f2))
                                       (\<lambda>f1. F (f1, f2))"
    proof -
      interpret F': binary_functor A2 A1 B sym
        using assms(1) sym_is_binary_functor by auto
      have "natural_transformation A1 B (\<lambda>f1. sym (A2.dom f2, f1)) (\<lambda>f1. sym (A2.cod f2, f1))
                                        (\<lambda>f1. sym (f2, f1))"
        using assms F'.fixing_arr_gives_natural_transformation_1 by fast
      thus ?thesis by simp
    qed

    text\<open>
      Fixing one or the other argument of a binary functor to be a composite arrow
      yields a natural transformation that is a vertical composite.
\<close>

    lemma preserves_comp_1:
    assumes "A1.seq f1' f1"
    shows "(\<lambda>f2. F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2)) =
                 vertical_composite.map A2 B (\<lambda>f2. F (f1, f2)) (\<lambda>f2. F (f1', f2))"
    proof -
      interpret \<tau>: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
                                               \<open>\<lambda>f2. F (f1, f2)\<close>
        using assms fixing_arr_gives_natural_transformation_1 by blast
      interpret \<tau>': natural_transformation A2 B \<open>\<lambda>f2. F (A1.cod f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1', f2)\<close>
                                                \<open>\<lambda>f2. F (f1', f2)\<close>
        using assms fixing_arr_gives_natural_transformation_1 A1.seqE by metis
      interpret \<tau>'o\<tau>: vertical_composite A2 B
                        \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1', f2)\<close>
                        \<open>\<lambda>f2. F (f1, f2)\<close> \<open>\<lambda>f2. F (f1', f2)\<close> ..
      show "(\<lambda>f2. F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2)) = \<tau>'o\<tau>.map"
      proof
        fix f2
        have "\<not>A2.arr f2 \<Longrightarrow> F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2"
          using \<tau>'o\<tau>.is_extensional is_extensional by simp
        moreover have "A2.arr f2 \<Longrightarrow> F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2"
        proof -
          assume f2: "A2.arr f2"
          have "F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = B (F (f1', f2)) (F (f1, A2.dom f2))"
            using assms f2 preserves_comp A1xA2.arr_char A1xA2.comp_char A2.comp_arr_dom
            by (metis fst_conv snd_conv)
          also have "... = \<tau>'o\<tau>.map f2"
            using f2 \<tau>'o\<tau>.map_simp_2 by simp
          finally show "F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2" by auto
        qed
        ultimately show "F (f1' \<cdot>\<^sub>A\<^sub>1 f1, f2) = \<tau>'o\<tau>.map f2" by blast
      qed
    qed

    lemma preserves_comp_2:
    assumes "A2.seq f2' f2"
    shows "(\<lambda>f1. F (f1, f2' \<cdot>\<^sub>A\<^sub>2 f2)) =
                 vertical_composite.map A1 B (\<lambda>f1. F (f1, f2)) (\<lambda>f1. F (f1, f2'))"
    proof -
      interpret F': binary_functor A2 A1 B sym
        using assms(1) sym_is_binary_functor by auto
      have "(\<lambda>f1. sym (f2' \<cdot>\<^sub>A\<^sub>2 f2, f1)) =
                 vertical_composite.map A1 B (\<lambda>f1. sym (f2, f1)) (\<lambda>f1. sym (f2', f1))"
        using assms F'.preserves_comp_1 by fastforce
      thus ?thesis by simp
    qed

  end

  text\<open>
    A binary functor transformation is a natural transformation between binary functors.
    We need a certain property of such transformations; namely, that if one or the
    other argument is fixed to be an identity, the result is a natural transformation.
\<close>

  locale binary_functor_transformation =
    A1: category A1 +
    A2: category A2 +
    B: category B +
    A1xA2: product_category A1 A2 +
    F: binary_functor A1 A2 B F +
    G: binary_functor A1 A2 B G +
    natural_transformation A1xA2.comp B F G \<tau>
  for A1 :: "'a1 comp"     (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
  and A2 :: "'a2 comp"     (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
  and B :: "'b comp"       (infixr "\<cdot>\<^sub>B" 55)
  and F :: "'a1 * 'a2 \<Rightarrow> 'b"
  and G :: "'a1 * 'a2 \<Rightarrow> 'b"
  and \<tau> :: "'a1 * 'a2 \<Rightarrow> 'b"
  begin

    notation A1xA2.comp    (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
    notation A1xA2.in_hom  ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")

    lemma fixing_ide_gives_natural_transformation_1:
    assumes "A1.ide a1"
    shows "natural_transformation A2 B (\<lambda>f2. F (a1, f2)) (\<lambda>f2. G (a1, f2)) (\<lambda>f2. \<tau> (a1, f2))"
    proof -
      interpret Fa1: "functor" A2 B \<open>\<lambda>f2. F (a1, f2)\<close>
        using assms F.fixing_ide_gives_functor_1 by simp
      interpret Ga1: "functor" A2 B \<open>\<lambda>f2. G (a1, f2)\<close>
        using assms "G.fixing_ide_gives_functor_1" by simp
      show ?thesis
        using assms is_extensional is_natural_1 is_natural_2
        apply (unfold_locales, auto)
         apply (metis A1.ide_char)
        by (metis A1.ide_char)
    qed

    lemma fixing_ide_gives_natural_transformation_2:
    assumes "A2.ide a2"
    shows "natural_transformation A1 B (\<lambda>f1. F (f1, a2)) (\<lambda>f1. G (f1, a2)) (\<lambda>f1. \<tau> (f1, a2))"
    proof -
      interpret Fa2: "functor" A1 B \<open>\<lambda>f1. F (f1, a2)\<close>
        using assms F.fixing_ide_gives_functor_2 by simp
      interpret Ga2: "functor" A1 B \<open>\<lambda>f1. G (f1, a2)\<close>
        using assms "G.fixing_ide_gives_functor_2" by simp
      show ?thesis
        using assms is_extensional is_natural_1 is_natural_2
        apply (unfold_locales, auto)
         apply (metis A2.ide_char)
        by (metis A2.ide_char)
    qed

  end

end


(*  Title:       ONode_Lifting.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Lifting rules for (open) nodes"

theory ONode_Lifting
imports AWN OAWN_SOS OInvariants
begin

lemma node_net_state':
  assumes "s \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
    shows "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)"
  using assms proof induction
    fix s
    assume "s \<in> init (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
    then obtain \<sigma> \<zeta> where "s = (\<sigma>, NodeS i \<zeta> R\<^sub>i)"
      by (auto simp: onode_comps)
    thus "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)" by auto
  next
    fix s a \<sigma>'
    assume rt: "s \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and ih: "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)"
       and "U (fst s) \<sigma>'"
    then obtain \<sigma> \<zeta> R
      where "(\<sigma>, NodeS i \<zeta> R)  \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
        and "U \<sigma> \<sigma>'" and "snd s = NodeS i \<zeta> R" by auto
    from this(1-2)
      have "(\<sigma>', NodeS i \<zeta> R) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
        by - (erule(1) oreachable_other')
    with \<open>snd s = NodeS i \<zeta> R\<close> show "\<exists>\<sigma> \<zeta> R. (\<sigma>', snd s) = (\<sigma>, NodeS i \<zeta> R)" by simp
  next
    fix s a s'
    assume rt: "s \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and ih: "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)"
       and tr: "(s, a, s') \<in> trans (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "S (fst s) (fst s') a"
     from ih obtain \<sigma> \<zeta> R where "s = (\<sigma>, NodeS i \<zeta> R)" by auto
     with tr have "((\<sigma>, NodeS i \<zeta> R), a, s') \<in> onode_sos (trans T)"
       by (simp add: onode_comps)
     then obtain \<sigma>' \<zeta>' R' where "s' = (\<sigma>', NodeS i \<zeta>' R')"
       using onode_sos_dest_is_net_state' by metis
     with tr \<open>s = (\<sigma>, NodeS i \<zeta> R)\<close> show "\<exists>\<sigma> \<zeta> R. s' = (\<sigma>, NodeS i \<zeta> R)"
       by simp
  qed

lemma node_net_state:
  assumes "(\<sigma>, s) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
    shows "\<exists>\<zeta> R. s = NodeS i \<zeta> R"
  using assms
  by (metis Pair_inject node_net_state')

lemma node_net_state_trans [elim]:
  assumes sor: "(\<sigma>, s) \<in> oreachable (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o) S U"
      and str: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o)"
  obtains \<zeta> R \<zeta>' R'
    where "s = NodeS i \<zeta> R"
      and "s' = NodeS i \<zeta>' R'"
  proof -
    assume *: "\<And>\<zeta> R \<zeta>' R'. s = NodeS i \<zeta> R \<Longrightarrow> s' = NodeS i \<zeta>' R' \<Longrightarrow> thesis"
    from sor obtain \<zeta> R where "s = NodeS i \<zeta> R"
      by (metis node_net_state)
    moreover with str obtain \<zeta>' R' where "s' = NodeS i \<zeta>' R'"
      by (simp only: onode_comps)
         (metis onode_sos_dest_is_net_state'')
    ultimately show thesis by (rule *)
  qed

lemma nodemap_induct' [consumes, case_names init other local]:
  assumes "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      and init: "\<And>\<sigma> \<zeta>. (\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) \<Longrightarrow> P (\<sigma>, NodeS ii \<zeta> R\<^sub>i)"
      and other: "\<And>\<sigma> \<zeta> R \<sigma>' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    U \<sigma> \<sigma>'; P (\<sigma>, NodeS ii \<zeta> R) \<rbrakk> \<Longrightarrow> P (\<sigma>', NodeS ii \<zeta> R)"
      and local: "\<And>\<sigma> \<zeta> R \<sigma>' \<zeta>' R' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    ((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o);
                    S \<sigma> \<sigma>' a; P (\<sigma>, NodeS ii \<zeta> R) \<rbrakk> \<Longrightarrow> P (\<sigma>', NodeS ii \<zeta>' R')"
    shows "P (\<sigma>, NodeS ii \<zeta> R)"
  using assms(1) proof induction
    fix s
    assume "s \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
    hence "s \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by (rule oreachable_init)
    with \<open>s \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)\<close> obtain \<sigma> \<zeta> where "s = (\<sigma>, NodeS ii \<zeta> R\<^sub>i)"
      using node_net_state by (simp add: onode_comps) metis
    with \<open>s \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)\<close> and init show "P s" by simp
  next
    fix s a \<sigma>'
    assume sr: "s \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and "U (fst s) \<sigma>'"
       and "P s"
    from sr obtain \<sigma> \<zeta> R where "s = (\<sigma>, NodeS ii \<zeta> R)"
      using node_net_state' by metis
    with sr \<open>U (fst s) \<sigma>'\<close> \<open>P s\<close> show "P (\<sigma>', snd s)"
    by simp (metis other)
  next
    fix s a s'
    assume sr: "s \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and tr: "(s, a, s') \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "S (fst s) (fst s') a"
       and "P s"
    from this(1-3) have "s' \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by - (erule(2) oreachable_local)
    then obtain \<sigma>' \<zeta>' R' where [simp]: "s' = (\<sigma>', NodeS ii \<zeta>' R')"
      using node_net_state' by metis
    from sr and \<open>P s\<close> obtain \<sigma> \<zeta> R
      where [simp]: "s = (\<sigma>, NodeS ii \<zeta> R)"
        and A1: "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
        and A4: "P (\<sigma>, NodeS ii \<zeta> R)"
      using node_net_state' by metis
    with tr and \<open>S (fst s) (fst s') a\<close>
      have A2: "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
       and A3: "S \<sigma> \<sigma>' a" by simp_all
    from A1 A2 A3 A4 have "P (\<sigma>', NodeS ii \<zeta>' R')" by (rule local)
    thus "P s'" by simp
  qed

lemma nodemap_induct [consumes, case_names init step]:
  assumes "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      and init: "\<And>\<sigma> \<zeta>. (\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) \<Longrightarrow> P \<sigma> \<zeta> R\<^sub>i"
      and other: "\<And>\<sigma> \<zeta> R \<sigma>' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    U \<sigma> \<sigma>'; P \<sigma> \<zeta> R \<rbrakk> \<Longrightarrow> P \<sigma>' \<zeta> R"
      and local: "\<And>\<sigma> \<zeta> R \<sigma>' \<zeta>' R' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    ((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o);
                    S \<sigma> \<sigma>' a; P \<sigma> \<zeta> R \<rbrakk> \<Longrightarrow> P \<sigma>' \<zeta>' R'"
    shows "P \<sigma> \<zeta> R"
  using assms(1) proof (induction "(\<sigma>, NodeS ii \<zeta> R)" arbitrary: \<sigma> \<zeta> R)
    fix \<sigma> \<zeta> R
    assume a1: "(\<sigma>, NodeS ii \<zeta> R) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
    hence "R = R\<^sub>i" by (simp add: init_onode_comp)
    with a1 have "(\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)" by simp
    with init and \<open>R = R\<^sub>i\<close> show "P \<sigma> \<zeta> R" by simp
  next
    fix st a \<sigma>' \<zeta>' R'
    assume "st \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and tr: "(st, a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "S (fst st) (fst (\<sigma>', NodeS ii \<zeta>' R')) a"
       and IH: "\<And>\<sigma> \<zeta> R. st = (\<sigma>, NodeS ii \<zeta> R) \<Longrightarrow> P \<sigma> \<zeta> R"
    from this(1) obtain \<sigma> \<zeta> R where "st = (\<sigma>, NodeS ii \<zeta> R)"
                                and "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by (metis node_net_state')
    note this(2)
    moreover from tr and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close>
      have "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)" by simp
    moreover from \<open>S (fst st) (fst (\<sigma>', NodeS ii \<zeta>' R')) a\<close> and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close>
      have "S \<sigma> \<sigma>' a" by simp
    moreover from IH and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close> have "P \<sigma> \<zeta> R" .
    ultimately show "P \<sigma>' \<zeta>' R'" by (rule local)
  next
    fix st \<sigma>' \<zeta> R
    assume "st \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and "U (fst st) \<sigma>'"
       and "snd st = NodeS ii \<zeta> R"
       and IH: "\<And>\<sigma> \<zeta> R. st = (\<sigma>, NodeS ii \<zeta> R) \<Longrightarrow> P \<sigma> \<zeta> R"
    from this(1,3) obtain \<sigma> where "st = (\<sigma>, NodeS ii \<zeta> R)"
                              and "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by (metis surjective_pairing)
    note this(2)
    moreover from \<open>U (fst st) \<sigma>'\<close> and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close> have "U \<sigma> \<sigma>'" by simp
    moreover from IH and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close> have "P \<sigma> \<zeta> R" .
    ultimately show "P \<sigma>' \<zeta> R" by (rule other)
  qed

lemma node_addressD [dest, simp]:
  assumes "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
    shows "i = ii"
  using assms by (clarsimp dest!: node_net_state')

lemma node_proc_reachable [dest]:
  assumes "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                         (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      and sgivesu: "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
  proof -
    from assms(1) have "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                             (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      by - (frule node_addressD, simp)
    thus ?thesis
    proof (induction rule: nodemap_induct)
      fix \<sigma> \<zeta>
      assume "(\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
      hence "(\<sigma>, \<zeta>) \<in> init T" by (auto simp: onode_comps)
      thus "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
        by (rule oreachable_init)
    next
      fix \<sigma> \<zeta> R \<sigma>' \<zeta>' R' a
      assume "other U {ii} \<sigma> \<sigma>'"
         and "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      thus "(\<sigma>', \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
        by - (rule oreachable_other')
    next
      fix \<sigma> \<zeta> R \<sigma>' \<zeta>' R' a
      assume rs: "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                         (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
         and tr: "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
         and ow: "otherwith S {ii} (oarrivemsg I) \<sigma> \<sigma>' a"
         and ih: "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"

      from ow have *: "\<sigma>' ii = \<sigma> ii \<Longrightarrow> other U {ii} \<sigma> \<sigma>'"
        by (clarsimp elim!: otherwithE) (rule otherI, simp_all, metis sgivesu)
      from tr have "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> onode_sos (trans T)"
        by (simp add: onode_comps)
      thus "(\<sigma>', \<zeta>') \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      proof cases
        case onode_bcast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_gcast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_ucast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_notucast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_deliver
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_tau
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_receive
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case (onode_arrive m)
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_connect1
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_connect2
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_connect_other
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_disconnect1
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_disconnect2
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_disconnect_other
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      qed
    qed
  qed

lemma node_proc_reachable_statelessassm [dest]:
  assumes "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                         (otherwith (\<lambda>_ _. True) {ii} (oarrivemsg I))
                                         (other (\<lambda>_ _. True) {ii})"
    shows "(\<sigma>, \<zeta>) \<in> oreachable T
                               (otherwith (\<lambda>_ _. True) {ii} (orecvmsg I)) (other (\<lambda>_ _. True) {ii})"
  using assms
  by (rule node_proc_reachable) simp_all

lemma node_lift:
  assumes "T \<Turnstile> (otherwith S {ii} (orecvmsg I), other U {ii} \<rightarrow>) global P"
      and "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile> (otherwith S {ii} (oarrivemsg I), other U {ii} \<rightarrow>) global P"
  proof (rule oinvariant_oreachableI)
    fix \<sigma> \<zeta>
    assume "(\<sigma>, \<zeta>) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
    moreover then obtain i s R where "\<zeta> = NodeS i s R"
      by (metis node_net_state)
    ultimately have "(\<sigma>, NodeS i s R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                                   (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      by simp
    hence "(\<sigma>, s) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      by - (erule node_proc_reachable, erule assms(2))
    with assms(1) show "global P (\<sigma>, \<zeta>)"
      by (metis fst_conv globalsimp oinvariantD)
  qed

lemma node_lift_step [intro]:
  assumes pinv: "T \<Turnstile>\<^sub>A (otherwith S {i} (orecvmsg I), other U {i} \<rightarrow>) globala (\<lambda>(\<sigma>, _, \<sigma>'). Q \<sigma> \<sigma>')"
      and other: "\<And>\<sigma> \<sigma>'. other U {i} \<sigma> \<sigma>' \<Longrightarrow> Q \<sigma> \<sigma>'"
      and sgivesu: "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith S {i} (oarrivemsg I), other U {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). Q \<sigma> \<sigma>')"
    (is "_ \<Turnstile>\<^sub>A (?S, ?U \<rightarrow>) _")
  proof (rule ostep_invariantI, simp)
    fix \<sigma> s a \<sigma>' s'
    assume rs: "(\<sigma>, s) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
       and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
       and ow: "?S \<sigma> \<sigma>' a"
    from ow have *: "\<sigma>' i = \<sigma> i \<Longrightarrow> other U {i} \<sigma> \<sigma>'"
      by (clarsimp elim!: otherwithE) (rule otherI, simp_all, metis sgivesu)
    from rs tr obtain \<zeta> R
      where [simp]: "s = NodeS i \<zeta> R"
        and "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
      by (metis node_net_state)
    from this(2) have or: "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {i} (orecvmsg I)) ?U"
      by (rule node_proc_reachable [OF _ assms(3)])
    from tr have "((\<sigma>, NodeS i \<zeta> R), a, (\<sigma>', s')) \<in> onode_sos (trans T)"
      by (simp add: onode_comps)
    thus "Q \<sigma> \<sigma>'"
    proof cases
      fix m \<zeta>'
      assume "a = R:*cast(m)"
         and tr': "((\<sigma>, \<zeta>), broadcast m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (broadcast m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix D m \<zeta>'
      assume "a = (R \<inter> D):*cast(m)"
         and tr': "((\<sigma>, \<zeta>), groupcast D m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (groupcast D m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d m \<zeta>'
      assume "a = {d}:*cast(m)"
         and tr': "((\<sigma>, \<zeta>), unicast d m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (unicast d m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d \<zeta>'
      assume "a = \<tau>"
         and tr': "((\<sigma>, \<zeta>), \<not>unicast d, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (\<not>unicast d)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d \<zeta>'
      assume "a = i:deliver(d)"
         and tr': "((\<sigma>, \<zeta>), deliver d, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (deliver d)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix \<zeta>'
      assume "a = \<tau>"
         and tr': "((\<sigma>, \<zeta>), \<tau>, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' \<tau>"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix m \<zeta>'
      assume "a = {i}\<not>{}:arrive(m)"
         and tr': "((\<sigma>, \<zeta>), receive m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (receive m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix m
      assume "a = {}\<not>{i}:arrive(m)"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = connect(i, i')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = connect(i', i)"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i' i''
      assume "a = connect(i', i'')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = disconnect(i, i')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = disconnect(i', i)"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i' i''
      assume "a = disconnect(i', i'')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    qed
  qed

lemma node_lift_step_statelessassm [intro]:
  assumes "T \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
      and "\<And>\<xi>. Q \<xi> \<xi>"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
  proof -
    from assms(1)
      have "T \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (orecvmsg I), other (\<lambda>_ _. True) {i} \<rightarrow>)
                  globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
        by rule auto
    with assms(2) have "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (oarrivemsg I),
                                          other (\<lambda>_ _. True) {i} \<rightarrow>)
                                         globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
      by - (rule node_lift_step, auto)
    thus ?thesis by rule auto
  qed

lemma node_lift_anycast [intro]:
  assumes pinv: "T \<Turnstile>\<^sub>A (otherwith S {i} (orecvmsg I), other U {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (Q \<sigma> \<sigma>') a)"
      and "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith S {i} (oarrivemsg I), other U {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (Q \<sigma> \<sigma>') a)"
    (is "_ \<Turnstile>\<^sub>A (?S, ?U \<rightarrow>) _")
  proof (rule ostep_invariantI, simp)
    fix \<sigma> s a \<sigma>' s'
    assume rs: "(\<sigma>, s) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
       and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "?S \<sigma> \<sigma>' a"
    from this(1-2) obtain \<zeta> R
      where [simp]: "s = NodeS i \<zeta> R"
        and "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
      by (metis node_net_state)
    from this(2) have "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {i} (orecvmsg I)) ?U"
      by (rule node_proc_reachable [OF _ assms(2)])
    moreover from tr have "((\<sigma>, NodeS i \<zeta> R), a, (\<sigma>', s')) \<in> onode_sos (trans T)"
      by (simp add: onode_comps)
    ultimately show "castmsg (Q \<sigma> \<sigma>') a" using \<open>?S \<sigma> \<sigma>' a\<close>
      by - (erule onode_sos.cases, auto elim!: otherwithE dest!: ostep_invariantD [OF pinv])
  qed

lemma node_lift_anycast_statelessassm [intro]:
  assumes pinv: "T \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (Q \<sigma> \<sigma>') a)"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (Q \<sigma> \<sigma>') a)"
    (is "_ \<Turnstile>\<^sub>A (?S, _ \<rightarrow>) _")
  proof -
    from assms(1)
      have "T \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (orecvmsg I), other (\<lambda>_ _. True) {i} \<rightarrow>)
                  globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (Q \<sigma> \<sigma>') a)"
        by rule auto
    hence "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (oarrivemsg I), other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (Q \<sigma> \<sigma>') a)"
      by (rule node_lift_anycast) simp_all
    thus ?thesis
      by rule auto
  qed

lemma node_local_deliver:
  "\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (S, U \<rightarrow>) globala (\<lambda>(_, a, _). \<forall>j. j\<noteq>i \<longrightarrow> (\<forall>d. a \<noteq> j:deliver(d)))"
  proof (rule ostep_invariantI, simp)
    fix \<sigma> s a \<sigma>' s'
    assume "(\<sigma>, s) \<in> oreachable (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o) S U"
       and "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o)"
       and "S \<sigma> \<sigma>' a"
    moreover from this(1-2) obtain \<zeta> R \<zeta>' R' where "s = NodeS i \<zeta> R" and "s' = NodeS i \<zeta>' R'" ..
    ultimately show "\<forall>j. j\<noteq>i \<longrightarrow> (\<forall>d. a \<noteq> j:deliver(d))"
      by (cases a) (auto simp add: onode_comps)
  qed

lemma node_tau_deliver_unchanged:
  "\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (S, U \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>'). a = \<tau> \<or> (\<exists>i d. a = i:deliver(d))
                                                     \<longrightarrow> (\<forall>j. j\<noteq>i \<longrightarrow> \<sigma>' j = \<sigma> j))"
  proof (rule ostep_invariantI, clarsimp simp only: globalasimp snd_conv fst_conv)
    fix \<sigma> s a \<sigma>' s' j
    assume "(\<sigma>, s) \<in> oreachable (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o) S U"
       and "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o)"
       and "S \<sigma> \<sigma>' a"
       and "a = \<tau> \<or> (\<exists>i d. a = i:deliver(d))"
       and "j \<noteq> i"
    moreover from this(1-2) obtain \<zeta> R \<zeta>' R' where "s = NodeS i \<zeta> R" and "s' = NodeS i \<zeta>' R'" ..
    ultimately show "\<sigma>' j = \<sigma> j"
      by (cases a) (auto simp del: step_node_tau simp add: onode_comps)
  qed

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Specification of Maps}\<close>
theory MapSpec
imports ICF_Spec_Base
begin
text_raw\<open>\label{thy:MapSpec}\<close>

(*@intf Map
  @abstype 'k\<rightharpoonup>'v
  This interface specifies maps from keys to values.
*)

text \<open>
  This theory specifies map operations by means of mapping to
  HOL's map type, i.e. @{typ "'k \<rightharpoonup> 'v"}.
\<close>

type_synonym ('k,'v,'s) map_\<alpha> = "'s \<Rightarrow> 'k \<rightharpoonup> 'v"
type_synonym ('k,'v,'s) map_invar = "'s \<Rightarrow> bool"
locale map =
  fixes \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"                 \<comment> \<open>Abstraction to map datatype\<close>
  fixes invar :: "'s \<Rightarrow> bool"                 \<comment> \<open>Invariant\<close>

locale map_no_invar = map +
  assumes invar[simp, intro!]: "\<And>s. invar s"

subsection "Basic Map Functions"

subsubsection "Empty Map"
type_synonym ('k,'v,'s) map_empty = "unit \<Rightarrow> 's"
locale map_empty = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "\<alpha> (empty ()) = Map.empty"
    "invar (empty ())"

subsubsection "Lookup"
type_synonym ('k,'v,'s) map_lookup = "'k \<Rightarrow> 's \<Rightarrow> 'v option"
locale map_lookup = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes lookup :: "'u \<Rightarrow> 's \<Rightarrow> 'v option"
  assumes lookup_correct:
    "invar m \<Longrightarrow> lookup k m = \<alpha> m k"

subsubsection "Update"
type_synonym ('k,'v,'s) map_update = "'k \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
locale map_update = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes update :: "'u \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
  assumes update_correct:
    "invar m \<Longrightarrow> \<alpha> (update k v m) = (\<alpha> m)(k \<mapsto> v)"
    "invar m \<Longrightarrow> invar (update k v m)"

subsubsection "Disjoint Update"
type_synonym ('k,'v,'s) map_update_dj = "'k \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
locale map_update_dj = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes update_dj :: "'u \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
  assumes update_dj_correct:
    "\<lbrakk>invar m; k\<notin>dom (\<alpha> m)\<rbrakk> \<Longrightarrow> \<alpha> (update_dj k v m) = (\<alpha> m)(k \<mapsto> v)"
    "\<lbrakk>invar m; k\<notin>dom (\<alpha> m)\<rbrakk> \<Longrightarrow> invar (update_dj k v m)"

subsubsection "Delete"
type_synonym ('k,'v,'s) map_delete = "'k \<Rightarrow> 's \<Rightarrow> 's"
locale map_delete = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes delete :: "'u \<Rightarrow> 's \<Rightarrow> 's"
  assumes delete_correct:
    "invar m \<Longrightarrow> \<alpha> (delete k m) = (\<alpha> m) |` (-{k})"
    "invar m \<Longrightarrow> invar (delete k m)"

subsubsection "Add"
type_synonym ('k,'v,'s) map_add = "'s \<Rightarrow> 's \<Rightarrow> 's"
locale map_add = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes add :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  assumes add_correct:
    "invar m1 \<Longrightarrow> invar m2 \<Longrightarrow> \<alpha> (add m1 m2) = \<alpha> m1 ++ \<alpha> m2"
    "invar m1 \<Longrightarrow> invar m2 \<Longrightarrow> invar (add m1 m2)"

type_synonym ('k,'v,'s) map_add_dj = "'s \<Rightarrow> 's \<Rightarrow> 's"
locale map_add_dj = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes add_dj :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  assumes add_dj_correct:
    "\<lbrakk>invar m1; invar m2; dom (\<alpha> m1) \<inter> dom (\<alpha> m2) = {}\<rbrakk> \<Longrightarrow> \<alpha> (add_dj m1 m2) = \<alpha> m1 ++ \<alpha> m2"
    "\<lbrakk>invar m1; invar m2; dom (\<alpha> m1) \<inter> dom (\<alpha> m2) = {} \<rbrakk> \<Longrightarrow> invar (add_dj m1 m2)"

subsubsection "Emptiness Check"
type_synonym ('k,'v,'s) map_isEmpty = "'s \<Rightarrow> bool"
locale map_isEmpty = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct : "invar m \<Longrightarrow> isEmpty m \<longleftrightarrow> \<alpha> m = Map.empty"

subsubsection "Singleton Maps"
type_synonym ('k,'v,'s) map_sng = "'k \<Rightarrow> 'v \<Rightarrow> 's"
locale map_sng = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes sng :: "'u \<Rightarrow> 'v \<Rightarrow> 's"
  assumes sng_correct :
    "\<alpha> (sng k v) = [k \<mapsto> v]"
    "invar (sng k v)"

type_synonym ('k,'v,'s) map_isSng = "'s \<Rightarrow> bool"
locale map_isSng = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'k \<rightharpoonup> 'v"
  fixes isSng :: "'s \<Rightarrow> bool"
  assumes isSng_correct:
    "invar s \<Longrightarrow> isSng s \<longleftrightarrow> (\<exists>k v. \<alpha> s = [k \<mapsto> v])"
begin
  lemma isSng_correct_exists1 :
    "invar s \<Longrightarrow> (isSng s \<longleftrightarrow> (\<exists>!k. \<exists>v. (\<alpha> s k = Some v)))"
    apply (auto simp add: isSng_correct split: if_split_asm)
    apply (rule_tac x=k in exI)
    apply (rule_tac x=v in exI)
    apply (rule ext)
    apply (case_tac "\<alpha> s x")
    apply auto
    apply force
    done

  lemma isSng_correct_card :
    "invar s \<Longrightarrow> (isSng s \<longleftrightarrow> (card (dom (\<alpha> s)) = 1))"
    by (auto simp add: isSng_correct card_Suc_eq dom_eq_singleton_conv)

end

subsubsection "Finite Maps"
locale finite_map = map +
  assumes finite[simp, intro!]: "invar m \<Longrightarrow> finite (dom (\<alpha> m))"

subsubsection "Size"
type_synonym ('k,'v,'s) map_size = "'s \<Rightarrow> nat"
locale map_size = finite_map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes size :: "'s \<Rightarrow> nat"
  assumes size_correct: "invar s \<Longrightarrow> size s = card (dom (\<alpha> s))"

type_synonym ('k,'v,'s) map_size_abort = "nat \<Rightarrow> 's \<Rightarrow> nat"
locale map_size_abort = finite_map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes size_abort :: "nat \<Rightarrow> 's \<Rightarrow> nat"
  assumes size_abort_correct: "invar s \<Longrightarrow> size_abort m s = min m (card (dom (\<alpha> s)))"

subsubsection "Iterators"
text \<open>
  An iteration combinator over a map applies a function to a state for each
  map entry, in arbitrary order.
  Proving of properties is done by invariant reasoning.
  An iterator can also contain a continuation condition. Iteration is
  interrupted if the condition becomes false.
\<close>

(* Deprecated *)
(*locale map_iteratei = finite_map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes iteratei :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"

  assumes iteratei_rule: "invar m \<Longrightarrow> map_iterator (iteratei m) (\<alpha> m)"
begin
  lemma iteratei_rule_P:
    assumes "invar m"
        and I0: "I (dom (\<alpha> m)) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                    \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iteratei_rule_insert_P:
    assumes
      "invar m"
      "I {} \<sigma>0"
      "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
          \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      "!!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
      "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> dom (\<alpha> m);
               \<not> (c \<sigma>);
               I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_insert_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iterate_rule_P:
    "\<lbrakk>
      invar m;
      I (dom (\<alpha> m)) \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar m;
      I {} \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>);
      !!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_insert_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast
end

lemma map_iteratei_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator (iti m) (\<alpha> m)"
  shows "map_iteratei \<alpha> invar iti"
proof
  fix m
  assume invar_m: "invar m"
  from assms(1)[OF invar_m] show it_OK: "map_iterator (iti m) (\<alpha> m)" .

  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
qed
*)

type_synonym ('k,'v,'s) map_list_it
  = "'s \<Rightarrow> ('k\<times>'v,('k\<times>'v) list) set_iterator"
locale poly_map_iteratei_defs =
  fixes list_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator"
begin
  definition iteratei :: "'s \<Rightarrow> ('u\<times>'v,'\<sigma>) set_iterator"
    where "iteratei S \<equiv> it_to_it (list_it S)"

  abbreviation "iterate m \<equiv> iteratei m (\<lambda>_. True)"
end

locale poly_map_iteratei =
  finite_map + poly_map_iteratei_defs list_it
  for list_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator" +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  assumes list_it_correct: "invar m \<Longrightarrow> map_iterator (list_it m) (\<alpha> m)"
begin
  lemma iteratei_correct: "invar S \<Longrightarrow> map_iterator (iteratei S) (\<alpha> S)"
    unfolding iteratei_def
    apply (rule it_to_it_correct)
    by (rule list_it_correct)

  lemma pi_iteratei[icf_proper_iteratorI]:
    "proper_it (iteratei S) (iteratei S)"
    unfolding iteratei_def
    by (intro icf_proper_iteratorI)

  lemma iteratei_rule_P:
    assumes "invar m"
    and I0: "I (map_to_set (\<alpha> m)) \<sigma>0"
    and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; (k,v) \<in> it; it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (it - {(k,v)}) (f (k, v) \<sigma>)"
    and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> map_to_set (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    apply (rule set_iterator_rule_P[OF iteratei_correct])
    apply fact
    apply fact
    apply (case_tac x, simp add: IP)
    apply fact
    apply fact
    done

  lemma iteratei_rule_insert_P:
    assumes "invar m"
    and "I {} \<sigma>0"
    and "!!k v it \<sigma>. \<lbrakk> c \<sigma>; (k,v) \<in> (map_to_set (\<alpha> m) - it);
                       it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (insert (k,v) it) (f (k, v) \<sigma>)"
    and "!!\<sigma>. I (map_to_set (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
    and "!!\<sigma> it. \<lbrakk> it \<subseteq> map_to_set (\<alpha> m); it \<noteq> map_to_set (\<alpha> m);
                  \<not> (c \<sigma>);
                  I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    apply (rule set_iterator_rule_insert_P[OF iteratei_correct])
    apply fact
    apply fact
    apply (case_tac x, simp add: assms)
    apply fact
    apply fact
    done

  lemma iterate_rule_P:
    assumes "invar m"
    and I0: "I (map_to_set (\<alpha> m)) \<sigma>0"
    and IP: "!!k v it \<sigma>. \<lbrakk> (k,v) \<in> it; it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (it - {(k,v)}) (f (k, v) \<sigma>)"
    and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterate m f \<sigma>0)"
    apply (rule iteratei_rule_P)
    apply fact
    apply (rule I0)
    apply (rule IP, assumption+) []
    apply (rule IF, assumption)
    apply simp
    done

  lemma iterate_rule_insert_P:
    assumes "invar m"
    and I0: "I {} \<sigma>0"
    and "!!k v it \<sigma>. \<lbrakk> (k,v) \<in> (map_to_set (\<alpha> m) - it);
                       it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (insert (k,v) it) (f (k, v) \<sigma>)"
    and "!!\<sigma>. I (map_to_set (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterate m f \<sigma>0)"
    apply (rule iteratei_rule_insert_P)
    apply fact
    apply (rule I0)
    apply (rule assms, assumption+) []
    apply (rule assms, assumption)
    apply simp
    done

  lemma old_iteratei_rule_P:
    assumes "invar m"
    and I0: "I (dom (\<alpha> m)) \<sigma>0"
    and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using assms
    by (rule map_iterator_rule_P[OF iteratei_correct])

  lemma old_iteratei_rule_insert_P:
    assumes "invar m"
    and "I {} \<sigma>0"
    and "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v;
                       it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
    and "!!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
    and "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> dom (\<alpha> m);
                  \<not> (c \<sigma>);
                  I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using assms by (rule map_iterator_rule_insert_P[OF iteratei_correct])

  lemma old_iterate_rule_P:
    "\<lbrakk>
      invar m;
      I (dom (\<alpha> m)) \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iterate m f \<sigma>0)"
    using old_iteratei_rule_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

  lemma old_iterate_rule_insert_P:
    "\<lbrakk>
      invar m;
      I {} \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v;
                    it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>);
      !!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using old_iteratei_rule_insert_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

  end

subsubsection "Bounded Quantification"
type_synonym ('k,'v,'s) map_ball = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
locale map_ball = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes ball :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
  assumes ball_correct: "invar m \<Longrightarrow> ball m P \<longleftrightarrow> (\<forall>u v. \<alpha> m u = Some v \<longrightarrow> P (u, v))"

type_synonym ('k,'v,'s) map_bex = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
locale map_bex = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes bex :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
  assumes bex_correct:
    "invar m \<Longrightarrow> bex m P \<longleftrightarrow> (\<exists>u v. \<alpha> m u = Some v \<and> P (u, v))"

subsubsection "Selection of Entry"
type_synonym ('k,'v,'s,'r) map_sel = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> 'r option) \<Rightarrow> 'r option"
locale map_sel = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes sel :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> 'r option) \<Rightarrow> 'r option"
  assumes selE:
  "\<lbrakk> invar m; \<alpha> m u = Some v; f (u, v) = Some r;
     !!u v r. \<lbrakk> sel m f = Some r; \<alpha> m u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> Q
   \<rbrakk> \<Longrightarrow> Q"
  assumes selI:
    "\<lbrakk> invar m; \<forall>u v. \<alpha> m u = Some v \<longrightarrow> f (u, v) = None \<rbrakk> \<Longrightarrow> sel m f = None"

begin
  lemma sel_someE:
    "\<lbrakk> invar m; sel m f = Some r;
       !!u v. \<lbrakk> \<alpha> m u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
    apply (cases "\<exists>u v r. \<alpha> m u = Some v \<and> f (u, v) = Some r")
    apply safe
    apply (erule_tac u=u and v=v and r=ra in selE)
    apply assumption
    apply assumption
    apply simp
    apply (auto)
    apply (drule (1) selI)
    apply simp
    done

  lemma sel_noneD: "\<lbrakk>invar m; sel m f = None; \<alpha> m u = Some v\<rbrakk> \<Longrightarrow> f (u, v) = None"
    apply (rule ccontr)
    apply simp
    apply (erule exE)
    apply (erule_tac f=f and u=u and v=v and r=y in selE)
    apply auto
    done

end

  \<comment> \<open>Equivalent description of sel-map properties\<close>
lemma map_sel_altI:
  assumes S1:
    "!!s f r P. \<lbrakk> invar s; sel s f = Some r;
                  !!u v. \<lbrakk>\<alpha> s u = Some v; f (u, v) = Some r\<rbrakk> \<Longrightarrow> P
                \<rbrakk> \<Longrightarrow> P"
  assumes S2:
    "!!s f u v. \<lbrakk>invar s; sel s f = None; \<alpha> s u = Some v\<rbrakk> \<Longrightarrow> f (u, v) = None"
  shows "map_sel \<alpha> invar sel"
proof -
  show ?thesis
    apply (unfold_locales)
    apply (case_tac "sel m f")
    apply (force dest: S2)
    apply (force elim: S1)
    apply (case_tac "sel m f")
    apply assumption
    apply (force elim: S1)
    done
qed

subsubsection "Selection of Entry (without mapping)"
type_synonym ('k,'v,'s) map_sel' = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k\<times>'v) option"
locale map_sel' = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes sel' :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('u\<times>'v) option"
  assumes sel'E:
  "\<lbrakk> invar m; \<alpha> m u = Some v; P (u, v);
     !!u v. \<lbrakk> sel' m P = Some (u,v); \<alpha> m u = Some v; P (u, v)\<rbrakk> \<Longrightarrow> Q
   \<rbrakk> \<Longrightarrow> Q"
  assumes sel'I:
    "\<lbrakk> invar m; \<forall>u v. \<alpha> m u = Some v \<longrightarrow> \<not> P (u, v) \<rbrakk> \<Longrightarrow> sel' m P = None"

begin
  lemma sel'_someE:
    "\<lbrakk> invar m; sel' m P = Some (u,v);
       !!u v. \<lbrakk> \<alpha> m u = Some v; P (u, v) \<rbrakk> \<Longrightarrow> thesis
     \<rbrakk> \<Longrightarrow> thesis"
    apply (cases "\<exists>u v. \<alpha> m u = Some v \<and> P (u, v)")
    apply safe
    apply (erule_tac u=ua and v=va in sel'E)
    apply assumption
    apply assumption
    apply simp
    apply (auto)
    apply (drule (1) sel'I)
    apply simp
    done

  lemma sel'_noneD: "\<lbrakk>invar m; sel' m P = None; \<alpha> m u = Some v\<rbrakk> \<Longrightarrow> \<not> P (u, v)"
    apply (rule ccontr)
    apply simp
    apply (erule (2) sel'E[where P=P])
    apply auto
    done

  lemma sel'_SomeD:
    "\<lbrakk> sel' m P = Some (u, v); invar m \<rbrakk> \<Longrightarrow> \<alpha> m u = Some v \<and> P (u, v)"
    apply(cases "\<exists>u' v'. \<alpha> m u' = Some v' \<and> P (u', v')")
     apply clarsimp
     apply(erule (2) sel'E[where P=P])
     apply simp
    apply(clarsimp)
    apply(drule (1) sel'I)
    apply simp
    done
end

subsubsection "Map to List Conversion"
type_synonym ('k,'v,'s) map_to_list = "'s \<Rightarrow> ('k\<times>'v) list"
locale map_to_list = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes to_list :: "'s \<Rightarrow> ('u\<times>'v) list"
  assumes to_list_correct:
    "invar m \<Longrightarrow> map_of (to_list m) = \<alpha> m"
    "invar m \<Longrightarrow> distinct (map fst (to_list m))"

subsubsection "List to Map Conversion"
type_synonym ('k,'v,'s) list_to_map = "('k\<times>'v) list \<Rightarrow> 's"
locale list_to_map = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes to_map :: "('u\<times>'v) list \<Rightarrow> 's"
  assumes to_map_correct:
    "\<alpha> (to_map l) = map_of l"
    "invar (to_map l)"

subsubsection "Image of a Map"

text \<open>This locale allows to apply a function to both the keys and
 the values of a map while at the same time filtering entries.\<close>

definition transforms_to_unique_keys ::
  "('u1 \<rightharpoonup> 'v1) \<Rightarrow> ('u1 \<times> 'v1 \<rightharpoonup> ('u2 \<times> 'v2)) \<Rightarrow> bool"
  where
  "transforms_to_unique_keys m f \<equiv> (\<forall>k1 k2 v1 v2 k' v1' v2'. (
         m k1 = Some v1 \<and>
         m k2 = Some v2 \<and>
         f (k1, v1) = Some (k', v1') \<and>
         f (k2, v2) = Some (k', v2')) -->
       (k1 = k2))"

type_synonym ('k1,'v1,'m1,'k2,'v2,'m2) map_image_filter
  = "('k1 \<times> 'v1 \<Rightarrow> ('k2 \<times> 'v2) option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"

locale map_image_filter = m1: map \<alpha>1 invar1 + m2: map \<alpha>2 invar2
  for \<alpha>1 :: "'m1 \<Rightarrow> 'u1 \<rightharpoonup> 'v1" and invar1
  and \<alpha>2 :: "'m2 \<Rightarrow> 'u2 \<rightharpoonup> 'v2" and invar2
  +
  fixes map_image_filter :: "('u1 \<times> 'v1 \<Rightarrow> ('u2 \<times> 'v2) option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
  assumes map_image_filter_correct_aux1:
    "\<And>k' v'.
     \<lbrakk>invar1 m; transforms_to_unique_keys (\<alpha>1 m) f\<rbrakk> \<Longrightarrow>
     (invar2 (map_image_filter f m) \<and>
      ((\<alpha>2 (map_image_filter f m) k' = Some v') \<longleftrightarrow>
       (\<exists>k v. (\<alpha>1 m k = Some v) \<and> f (k, v) = Some (k', v'))))"
begin

  (*Let's use a definition for the precondition *)

  lemma map_image_filter_correct_aux2 :
    assumes "invar1 m"
      and "transforms_to_unique_keys (\<alpha>1 m) f"
    shows "(\<alpha>2 (map_image_filter f m) k' = None) \<longleftrightarrow>
      (\<forall>k v v'. \<alpha>1 m k = Some v \<longrightarrow> f (k, v) \<noteq> Some (k', v'))"
  proof -
    note map_image_filter_correct_aux1 [OF assms]
    have Some_eq: "\<And>v'. (\<alpha>2 (map_image_filter f m) k' = Some v') =
          (\<exists>k v. \<alpha>1 m k = Some v \<and> f (k, v) = Some (k', v'))"
      by (simp add: map_image_filter_correct_aux1 [OF assms])

    have intro_some: "(\<alpha>2 (map_image_filter f m) k' = None) \<longleftrightarrow>
                      (\<forall>v'. \<alpha>2 (map_image_filter f m) k' \<noteq> Some v')" by auto

    from intro_some Some_eq show ?thesis by auto
  qed

  lemmas map_image_filter_correct =
     conjunct1 [OF map_image_filter_correct_aux1]
     conjunct2 [OF map_image_filter_correct_aux1]
     map_image_filter_correct_aux2
end

text \<open>Most of the time the mapping function is only applied to values. Then,
  the precondition disapears.\<close>
type_synonym ('k,'v1,'m1,'k2,'v2,'m2) map_value_image_filter
  = "('k \<Rightarrow> 'v1 \<Rightarrow> 'v2 option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"

locale map_value_image_filter = m1: map \<alpha>1 invar1 + m2: map \<alpha>2 invar2
  for \<alpha>1 :: "'m1 \<Rightarrow> 'u \<rightharpoonup> 'v1" and invar1
  and \<alpha>2 :: "'m2 \<Rightarrow> 'u \<rightharpoonup> 'v2" and invar2
  +
  fixes map_value_image_filter :: "('u \<Rightarrow> 'v1 \<Rightarrow> 'v2 option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
  assumes map_value_image_filter_correct_aux:
    "invar1 m \<Longrightarrow>
     invar2 (map_value_image_filter f m) \<and>
     (\<alpha>2 (map_value_image_filter f m) =
      (\<lambda>k. Option.bind (\<alpha>1 m k) (f k)))"
begin

  lemmas map_value_image_filter_correct =
    conjunct1[OF map_value_image_filter_correct_aux]
    conjunct2[OF map_value_image_filter_correct_aux]

  lemma map_value_image_filter_correct_alt :
    "invar1 m \<Longrightarrow>
     invar2 (map_value_image_filter f m)"
    "invar1 m \<Longrightarrow>
     (\<alpha>2 (map_value_image_filter f m) k = Some v') \<longleftrightarrow>
     (\<exists>v. (\<alpha>1 m k = Some v) \<and> f k v = Some v')"
    "invar1 m \<Longrightarrow>
     (\<alpha>2 (map_value_image_filter f m) k = None) \<longleftrightarrow>
     (\<forall>v. (\<alpha>1 m k = Some v) --> f k v = None)"
  proof -
    assume invar_m : "invar1 m"
    note aux = map_value_image_filter_correct_aux [OF invar_m]

    from aux show "invar2 (map_value_image_filter f m)" by simp
    from aux show "(\<alpha>2 (map_value_image_filter f m) k = Some v') \<longleftrightarrow>
     (\<exists>v. (\<alpha>1 m k = Some v) \<and> f k v = Some v')"
      by (cases "\<alpha>1 m k", simp_all)
    from aux show "(\<alpha>2 (map_value_image_filter f m) k = None) \<longleftrightarrow>
     (\<forall>v. (\<alpha>1 m k = Some v) --> f k v = None)"
      by (cases "\<alpha>1 m k", simp_all)
  qed
end

type_synonym ('k,'v,'m1,'m2) map_restrict = "('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
locale map_restrict = m1: map \<alpha>1 invar1 + m2: map \<alpha>2 invar2
  for \<alpha>1 :: "'m1 \<Rightarrow> 'u \<rightharpoonup> 'v" and invar1
  and \<alpha>2 :: "'m2 \<Rightarrow> 'u \<rightharpoonup> 'v" and invar2
  +
  fixes restrict :: "('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
  assumes restrict_correct_aux1 :
    "invar1 m \<Longrightarrow> \<alpha>2 (restrict P m) = \<alpha>1 m |` {k. \<exists>v. \<alpha>1 m k = Some v \<and> P (k, v)}"
    "invar1 m \<Longrightarrow> invar2 (restrict P m)"
begin
  lemma restrict_correct_aux2 :
    "invar1 m \<Longrightarrow> \<alpha>2 (restrict (\<lambda>(k,_). P k) m) = \<alpha>1 m |` {k. P k}"
  proof -
    assume invar_m : "invar1 m"
    have "\<alpha>1 m |` {k. (\<exists>v. \<alpha>1 m k = Some v) \<and> P k} = \<alpha>1 m |` {k. P k}"
      (is "\<alpha>1 m |` ?A1 = \<alpha>1 m |` ?A2")
    proof
      fix k
      show "(\<alpha>1 m |` ?A1) k = (\<alpha>1 m |` ?A2) k"
      proof (cases "k \<in> ?A2")
        case False thus ?thesis by simp
      next
        case True
        hence P_k : "P k" by simp

        show ?thesis
          by (cases "\<alpha>1 m k", simp_all add: P_k)
      qed
    qed
    with invar_m show "\<alpha>2 (restrict (\<lambda>(k, _). P k) m) = \<alpha>1 m |` {k. P k}"
      by (simp add: restrict_correct_aux1)
  qed

  lemmas restrict_correct =
     restrict_correct_aux1
     restrict_correct_aux2
end

subsection "Ordered Maps"
  locale ordered_map = map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar

  locale ordered_finite_map = finite_map \<alpha> invar + ordered_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar

subsubsection \<open>Ordered Iteration\<close>
  (* Deprecated *)
(*
  locale map_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_linord (iterateoi m) (\<alpha> m)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m c f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j; \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_linord (itoi m) (\<alpha> m)"
  shows "map_iterateoi \<alpha> invar itoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_linord (itoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed

  locale map_reverse_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes reverse_iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_rev_linord (reverse_iterateoi m) (\<alpha> m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m c f \<sigma>0)"
    using map_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_rev_linord_rule_P[OF reverse_iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_reverse_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_rev_linord (ritoi m) (\<alpha> m)"
  shows "map_reverse_iterateoi \<alpha> invar ritoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_rev_linord (ritoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_rev_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed
*)

locale poly_map_iterateoi_defs =
  fixes olist_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator"
begin
  definition iterateoi :: "'s \<Rightarrow> ('u\<times>'v,'\<sigma>) set_iterator"
    where "iterateoi S \<equiv> it_to_it (olist_it S)"

  abbreviation "iterateo m \<equiv> iterateoi m (\<lambda>_. True)"
end

locale poly_map_iterateoi =
  finite_map \<alpha> invar + poly_map_iterateoi_defs list_ordered_it
  for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v"
  and invar
  and list_ordered_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator" +
  assumes list_ordered_it_correct: "invar m
    \<Longrightarrow> map_iterator_linord (list_ordered_it m) (\<alpha> m)"
begin
  lemma iterateoi_correct: "invar S \<Longrightarrow> map_iterator_linord (iterateoi S) (\<alpha> S)"
    unfolding iterateoi_def
    apply (rule it_to_it_map_linord_correct)
    by (rule list_ordered_it_correct)

  lemma pi_iterateoi[icf_proper_iteratorI]:
    "proper_it (iterateoi S) (iterateoi S)"
    unfolding iterateoi_def
    by (intro icf_proper_iteratorI)

  lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      c \<sigma>;
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<le>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<le>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    assumes II: "!!\<sigma> it. \<lbrakk>
      it \<subseteq> dom (\<alpha> m);
      it \<noteq> {};
      \<not> c \<sigma>;
      I it \<sigma>;
      \<And>k j. \<lbrakk>k\<in>it; j\<in>dom (\<alpha> m) - it\<rbrakk> \<Longrightarrow> j\<le>k
    \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iterateoi m c f \<sigma>0)"
    using assms by (rule map_iterator_linord_rule_P[OF iterateoi_correct])

  lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<le>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<le>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterateo m f \<sigma>0)"
    using assms
      map_iterator_linord_rule_P[OF iterateoi_correct, of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

end

type_synonym ('k,'v,'s) map_list_rev_it
  = "'s \<Rightarrow> ('k\<times>'v,('k\<times>'v) list) set_iterator"

locale poly_map_rev_iterateoi_defs =
  fixes list_rev_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator"
begin
  definition rev_iterateoi :: "'s \<Rightarrow> ('u\<times>'v,'\<sigma>) set_iterator"
    where "rev_iterateoi S \<equiv> it_to_it (list_rev_it S)"

  abbreviation "rev_iterateo m \<equiv> rev_iterateoi m (\<lambda>_. True)"
  abbreviation "reverse_iterateoi \<equiv> rev_iterateoi"
  abbreviation "reverse_iterateo \<equiv> rev_iterateo"
end

locale poly_map_rev_iterateoi =
  finite_map \<alpha> invar + poly_map_rev_iterateoi_defs list_rev_it
  for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v"
  and invar
  and list_rev_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator" +
  assumes list_rev_it_correct:
    "invar m \<Longrightarrow> map_iterator_rev_linord (list_rev_it m) (\<alpha> m)"
begin
  lemma rev_iterateoi_correct:
    "invar S \<Longrightarrow> map_iterator_rev_linord (rev_iterateoi S) (\<alpha> S)"
    unfolding rev_iterateoi_def
    apply (rule it_to_it_map_rev_linord_correct)
    by (rule list_rev_it_correct)

  lemma pi_rev_iterateoi[icf_proper_iteratorI]:
    "proper_it (rev_iterateoi S) (rev_iterateoi S)"
    unfolding rev_iterateoi_def
    by (intro icf_proper_iteratorI)

  lemma rev_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      c \<sigma>;
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<ge>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<ge>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    assumes II: "!!\<sigma> it. \<lbrakk>
      it \<subseteq> dom (\<alpha> m);
      it \<noteq> {};
      \<not> c \<sigma>;
      I it \<sigma>;
      \<And>k j. \<lbrakk>k\<in>it; j\<in>dom (\<alpha> m) - it\<rbrakk> \<Longrightarrow> j\<ge>k
    \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (rev_iterateoi m c f \<sigma>0)"
    using assms by (rule map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct])

  lemma rev_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<ge>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<ge>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (rev_iterateo m f \<sigma>0)"
    using assms
      map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct,
        of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

end

subsubsection \<open>Minimal and Maximal Elements\<close>

  type_synonym ('k,'v,'s) map_min
    = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
  locale map_min = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes min :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('u \<times> 'v) option"
    assumes min_correct:
      "\<lbrakk> invar s; rel_of (\<alpha> s) P \<noteq> {} \<rbrakk> \<Longrightarrow> min s P \<in> Some ` rel_of (\<alpha> s) P"
      "\<lbrakk> invar s; (k,v) \<in> rel_of (\<alpha> s) P \<rbrakk> \<Longrightarrow> fst (the (min s P)) \<le> k"
      "\<lbrakk> invar s; rel_of (\<alpha> s) P = {} \<rbrakk> \<Longrightarrow> min s P = None"
  begin
   lemma minE:
     assumes A: "invar s" "rel_of (\<alpha> s) P \<noteq> {}"
     obtains k v where
     "min s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P" "\<forall>(k',v')\<in>rel_of (\<alpha> s) P. k \<le> k'"
   proof -
     from min_correct(1)[OF A] have MIS: "min s P \<in> Some ` rel_of (\<alpha> s) P" .
     then obtain k v where KV: "min s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P"
       by auto
     show thesis
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule min_correct(2)[OF \<open>invar s\<close>])
       apply (simp add: KV(1))
       done
   qed

   lemmas minI = min_correct(3)

   lemma min_Some:
     "\<lbrakk> invar s; min s P = Some (k,v) \<rbrakk> \<Longrightarrow> (k,v)\<in>rel_of (\<alpha> s) P"
     "\<lbrakk> invar s; min s P = Some (k,v); (k',v')\<in>rel_of (\<alpha> s) P \<rbrakk> \<Longrightarrow> k\<le>k'"
     apply -
     apply (cases "rel_of (\<alpha> s) P = {}")
     apply (drule (1) min_correct(3))
     apply simp
     apply (erule (1) minE)
     apply auto [1]
     apply (drule (1) min_correct(2))
     apply auto
     done

   lemma min_None:
     "\<lbrakk> invar s; min s P = None \<rbrakk> \<Longrightarrow> rel_of (\<alpha> s) P = {}"
     apply (cases "rel_of (\<alpha> s) P = {}")
     apply simp
     apply (drule (1) min_correct(1))
     apply auto
     done

  end

  type_synonym ('k,'v,'s) map_max
    = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
  locale map_max = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes max :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('u \<times> 'v) option"
    assumes max_correct:
      "\<lbrakk> invar s; rel_of (\<alpha> s) P \<noteq> {} \<rbrakk> \<Longrightarrow> max s P \<in> Some ` rel_of (\<alpha> s) P"
      "\<lbrakk> invar s; (k,v) \<in> rel_of (\<alpha> s) P \<rbrakk> \<Longrightarrow> fst (the (max s P)) \<ge> k"
      "\<lbrakk> invar s; rel_of (\<alpha> s) P = {} \<rbrakk> \<Longrightarrow> max s P = None"
  begin
   lemma maxE:
     assumes A: "invar s" "rel_of (\<alpha> s) P \<noteq> {}"
     obtains k v where
     "max s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P" "\<forall>(k',v')\<in>rel_of (\<alpha> s) P. k \<ge> k'"
   proof -
     from max_correct(1)[OF A] have MIS: "max s P \<in> Some ` rel_of (\<alpha> s) P" .
     then obtain k v where KV: "max s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P"
       by auto
     show thesis
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule max_correct(2)[OF \<open>invar s\<close>])
       apply (simp add: KV(1))
       done
   qed

   lemmas maxI = max_correct(3)

  end

subsubsection "Conversion to List"
  type_synonym ('k,'v,'s) map_to_sorted_list
    = "'s \<Rightarrow> ('k \<times> 'v) list"
  locale map_to_sorted_list = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes to_sorted_list :: "'s \<Rightarrow> ('u\<times>'v) list"
    assumes to_sorted_list_correct:
    "invar m \<Longrightarrow> map_of (to_sorted_list m) = \<alpha> m"
    "invar m \<Longrightarrow> distinct (map fst (to_sorted_list m))"
    "invar m \<Longrightarrow> sorted (map fst (to_sorted_list m))"

  type_synonym ('k,'v,'s) map_to_rev_list
    = "'s \<Rightarrow> ('k \<times> 'v) list"
  locale map_to_rev_list = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes to_rev_list :: "'s \<Rightarrow> ('u\<times>'v) list"
    assumes to_rev_list_correct:
    "invar m \<Longrightarrow> map_of (to_rev_list m) = \<alpha> m"
    "invar m \<Longrightarrow> distinct (map fst (to_rev_list m))"
    "invar m \<Longrightarrow> sorted (rev (map fst (to_rev_list m)))"

subsection "Record Based Interface"

  record ('k,'v,'s) map_ops =
    map_op_\<alpha> :: "('k,'v,'s) map_\<alpha>"
    map_op_invar :: "('k,'v,'s) map_invar"
    map_op_empty :: "('k,'v,'s) map_empty"
    map_op_lookup :: "('k,'v,'s) map_lookup"
    map_op_update :: "('k,'v,'s) map_update"
    map_op_update_dj :: "('k,'v,'s) map_update_dj"
    map_op_delete :: "('k,'v,'s) map_delete"
    map_op_list_it :: "('k,'v,'s) map_list_it"
    map_op_sng :: "('k,'v,'s) map_sng"
    map_op_restrict :: "('k,'v,'s,'s) map_restrict"
    map_op_add :: "('k,'v,'s) map_add"
    map_op_add_dj :: "('k,'v,'s) map_add_dj"
    map_op_isEmpty :: "('k,'v,'s) map_isEmpty"
    map_op_isSng :: "('k,'v,'s) map_isSng"
    map_op_ball :: "('k,'v,'s) map_ball"
    map_op_bex :: "('k,'v,'s) map_bex"
    map_op_size :: "('k,'v,'s) map_size"
    map_op_size_abort :: "('k,'v,'s) map_size_abort"
    map_op_sel :: "('k,'v,'s) map_sel'"
    map_op_to_list :: "('k,'v,'s) map_to_list"
    map_op_to_map :: "('k,'v,'s) list_to_map"

  locale StdMapDefs = poly_map_iteratei_defs "map_op_list_it ops"
    for ops :: "('k,'v,'s,'more) map_ops_scheme"
  begin
    abbreviation \<alpha> where "\<alpha> == map_op_\<alpha> ops"
    abbreviation invar where "invar == map_op_invar ops"
    abbreviation empty where "empty == map_op_empty ops"
    abbreviation lookup where "lookup == map_op_lookup ops"
    abbreviation update where "update == map_op_update ops"
    abbreviation update_dj where "update_dj == map_op_update_dj ops"
    abbreviation delete where "delete == map_op_delete ops"
    abbreviation list_it where "list_it == map_op_list_it ops"
    abbreviation sng where "sng == map_op_sng ops"
    abbreviation restrict where "restrict == map_op_restrict ops"
    abbreviation add where "add == map_op_add ops"
    abbreviation add_dj where "add_dj == map_op_add_dj ops"
    abbreviation isEmpty where "isEmpty == map_op_isEmpty ops"
    abbreviation isSng where "isSng == map_op_isSng ops"
    abbreviation ball where "ball == map_op_ball ops"
    abbreviation bex where "bex == map_op_bex ops"
    abbreviation size where "size == map_op_size ops"
    abbreviation size_abort where "size_abort == map_op_size_abort ops"
    abbreviation sel where "sel == map_op_sel ops"
    abbreviation to_list where "to_list == map_op_to_list ops"
    abbreviation to_map where "to_map == map_op_to_map ops"
  end

  locale StdMap = StdMapDefs ops +
    map \<alpha> invar +
    map_empty \<alpha> invar empty +
    map_lookup \<alpha> invar lookup  +
    map_update \<alpha> invar update  +
    map_update_dj \<alpha> invar update_dj +
    map_delete \<alpha> invar delete  +
    poly_map_iteratei \<alpha> invar list_it +
    map_sng \<alpha> invar sng  +
    map_restrict \<alpha> invar \<alpha> invar restrict +
    map_add \<alpha> invar add  +
    map_add_dj \<alpha> invar add_dj +
    map_isEmpty \<alpha> invar isEmpty  +
    map_isSng \<alpha> invar isSng  +
    map_ball \<alpha> invar ball  +
    map_bex \<alpha> invar bex  +
    map_size \<alpha> invar size +
    map_size_abort \<alpha> invar size_abort +
    map_sel' \<alpha> invar sel  +
    map_to_list \<alpha> invar to_list  +
    list_to_map \<alpha> invar to_map
    for ops :: "('k,'v,'s,'more) map_ops_scheme"
  begin
    lemmas correct =
      empty_correct
      sng_correct
      lookup_correct
      update_correct
      update_dj_correct
      delete_correct
      restrict_correct
      add_correct
      add_dj_correct
      isEmpty_correct
      isSng_correct
      ball_correct
      bex_correct
      size_correct
      size_abort_correct
      to_list_correct
      to_map_correct
  end

  lemmas StdMap_intro = StdMap.intro[rem_dup_prems]

  locale StdMap_no_invar = StdMap + map_no_invar \<alpha> invar

  record ('k,'v,'s) omap_ops = "('k,'v,'s) map_ops" +
    map_op_ordered_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"
    map_op_rev_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"
    map_op_min :: "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
    map_op_max :: "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
    map_op_to_sorted_list :: "'s \<Rightarrow> ('k \<times> 'v) list"
    map_op_to_rev_list :: "'s \<Rightarrow> ('k \<times> 'v) list"

  locale StdOMapDefs = StdMapDefs ops
    + poly_map_iterateoi_defs "map_op_ordered_list_it ops"
    + poly_map_rev_iterateoi_defs "map_op_rev_list_it ops"
    for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
  begin
    abbreviation ordered_list_it where "ordered_list_it
      \<equiv> map_op_ordered_list_it ops"
    abbreviation rev_list_it where "rev_list_it
      \<equiv> map_op_rev_list_it ops"
    abbreviation min where "min == map_op_min ops"
    abbreviation max where "max == map_op_max ops"
    abbreviation to_sorted_list where
      "to_sorted_list \<equiv> map_op_to_sorted_list ops"
    abbreviation to_rev_list where "to_rev_list \<equiv> map_op_to_rev_list ops"
  end

  locale StdOMap =
    StdOMapDefs ops +
    StdMap ops +
    poly_map_iterateoi \<alpha> invar ordered_list_it +
    poly_map_rev_iterateoi \<alpha> invar rev_list_it +
    map_min \<alpha> invar min +
    map_max \<alpha> invar max +
    map_to_sorted_list \<alpha> invar to_sorted_list +
    map_to_rev_list \<alpha> invar to_rev_list
    for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
  begin
  end

  lemmas StdOMap_intro =
    StdOMap.intro[OF StdMap_intro, rem_dup_prems]

end


theory SINVAR_ACLcommunicateWith
imports "../TopoS_Helper"
begin
subsection {* SecurityInvariant ACLcommunicateWith *}
text{*An access control list strategy that says that hosts must only transitively access each other if allowed*}

text{*Warning: this transitive model has exponential computational complexity*}

datatype 'v access_list = AccessList "'v list"

definition default_node_properties :: "'v access_list"
  where  "default_node_properties \<equiv> AccessList []"

fun accesses_okay :: "'v access_list \<Rightarrow> 'v set \<Rightarrow> bool" where
  "accesses_okay (AccessList ACL) accesses = (\<forall> a \<in> accesses. a \<in> set ACL)"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v access_list) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> v \<in> nodes G. accesses_okay (nP v) (succ_tran G v))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v access_list) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

    from a3 have "\<And>v ACL. v \<in> N \<Longrightarrow> nP v = AccessList ACL \<Longrightarrow> accesses_okay (nP v) (succ_tran \<lparr>nodes = N, edges = E\<rparr> v)" by fastforce
    hence "\<And>v ACL. v \<in> N \<Longrightarrow> nP v = AccessList ACL \<Longrightarrow> (\<forall> a \<in> (succ_tran \<lparr>nodes = N, edges = E\<rparr> v). a \<in> set ACL)" by simp
    from this a2 have g2: "\<And>v ACL. v \<in> N \<Longrightarrow> nP v = AccessList ACL \<Longrightarrow> (\<forall> a \<in> (succ_tran \<lparr>nodes = N, edges = E'\<rparr> v). a \<in> set ACL)"
      using succ_tran_mono[OF a1] by blast

    thus "sinvar \<lparr>nodes = N, edges = E'\<rparr> nP"
      apply(clarsimp)
      apply(rename_tac v)
      apply(case_tac "(nP v)")
      apply(simp)
      done
qed

lemma accesses_okay_empty: "accesses_okay (nP v) {}"
  by(case_tac "nP v", simp_all)

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
and verify_globals = verify_globals
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF valid_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
    apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops False_set succ_tran_empty accesses_okay_empty)[1]
   apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma unique_default_example: "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_2 = {}"
apply (simp add: succ_tran_def)
by (metis Domain.DomainI Domain_empty Domain_insert distinct_vertices12 singleton_iff trancl_domain)

interpretation ACLcommunicateWith: SecurityInvariant_ACS
where default_node_properties = SINVAR_ACLcommunicateWith.default_node_properties
and sinvar = SINVAR_ACLcommunicateWith.sinvar
and verify_globals = verify_globals
  unfolding SINVAR_ACLcommunicateWith.default_node_properties_def
  apply unfold_locales

   apply simp
   apply(subst(asm) SecurityInvariant_withOffendingFlows.set_offending_flows_simp, simp)
   apply(clarsimp)
   apply (metis accesses_okay_empty)

  apply(erule default_uniqueness_by_counterexample_ACS)
  apply(case_tac "otherbot")
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: split_split_asm split_split)
  apply(simp add: List.neq_Nil_conv)
  apply(erule exE)
  apply(rename_tac canAccessThis)
  apply(case_tac "canAccessThis = vertex_1")
   apply(rule_tac x="\<lparr> nodes={canAccessThis,vertex_2}, edges = {(vertex_2,canAccessThis)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: valid_graph_def)
   apply(rule_tac x="(\<lambda> x. AccessList [])(vertex_1 := AccessList [], vertex_2 := AccessList [])" in exI, simp)
   apply(simp add: example_simps)
   apply(rule_tac x="{(vertex_2,vertex_1)}" in exI, simp)
   apply(simp add: example_simps)
   apply(fastforce)

  apply(rule_tac x="\<lparr> nodes={vertex_1,canAccessThis}, edges = {(vertex_1,canAccessThis)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(rule_tac x="(\<lambda> x. AccessList [])(vertex_1 := AccessList [], canAccessThis := AccessList [])" in exI, simp)
  apply(simp add: example_simps)
  apply(rule_tac x="{(vertex_1,canAccessThis)}" in exI, simp)
  apply(simp add: example_simps)
  apply(fastforce)
 done

  lemma TopoS_ACLcommunicateWith: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end