theory TopoS_withOffendingFlows
imports TopoS_Interface
begin

section \<open>@{term SecurityInvariant} Instantiation Helpers\<close>

text\<open>
  The security invariant locales are set up hierarchically to ease instantiation proofs.
  The first locale, @{term SecurityInvariant_withOffendingFlows} has no assumptions, thus instantiations is for free.
  The first step focuses on monotonicity,
\<close>

context SecurityInvariant_withOffendingFlows
begin
  text\<open>We define the monotonicity of \<open>sinvar\<close>:

  @{term "(\<And> nP N E' E. wf_graph \<lparr> nodes = N, edges = E \<rparr>  \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> sinvar \<lparr> nodes = N, edges = E \<rparr> nP \<Longrightarrow> sinvar \<lparr> nodes = N, edges = E' \<rparr> nP )"}

  Having a valid invariant, removing edges retains the validity. I.e.\ prohibiting more, is more or equally secure.
\<close>

  definition sinvar_mono :: "bool" where
    "sinvar_mono \<longleftrightarrow> (\<forall> nP N E' E.
      wf_graph \<lparr> nodes = N, edges = E \<rparr> \<and>
      E' \<subseteq> E \<and>
      sinvar \<lparr> nodes = N, edges = E \<rparr> nP \<longrightarrow> sinvar \<lparr> nodes = N, edges = E' \<rparr> nP )"

  text\<open>
    If one can show @{const sinvar_mono}, then the instantiation of the @{term SecurityInvariant_preliminaries} locale is tremendously simplified.
\<close>

  lemma sinvar_mono_I_proofrule_simple:
  "\<lbrakk> (\<forall> G nP. sinvar G nP = (\<forall> (e1, e2) \<in> edges G. P e1 e2 nP) ) \<rbrakk> \<Longrightarrow> sinvar_mono"
  apply(simp add: sinvar_mono_def)
  apply(clarify)
  apply(fast)
  done

  lemma sinvar_mono_I_proofrule:
  "\<lbrakk> (\<forall> nP (G:: 'v graph). sinvar G nP = (\<forall> (e1, e2) \<in> edges G. P e1 e2 nP G) );
    (\<forall> nP e1 e2 N E' E.
      wf_graph \<lparr> nodes = N, edges = E \<rparr> \<and>
      (e1,e2) \<in> E \<and>
      E' \<subseteq> E \<and>
      P e1 e2 nP \<lparr>nodes = N, edges = E\<rparr> \<longrightarrow> P e1 e2 nP \<lparr>nodes = N, edges = E'\<rparr>) \<rbrakk> \<Longrightarrow> sinvar_mono"
  unfolding sinvar_mono_def
  proof(clarify)
    fix nP N E' E
    assume AllForm: "(\<forall> nP (G:: 'v graph). sinvar G nP = (\<forall> (e1, e2) \<in> edges G. P e1 e2 nP G) )"
    and Pmono: "\<forall>nP e1 e2 N E' E. wf_graph \<lparr> nodes = N, edges = E \<rparr> \<and> (e1,e2) \<in> E \<and> E' \<subseteq> E \<and> P e1 e2 nP \<lparr>nodes = N, edges = E\<rparr> \<longrightarrow> P e1 e2 nP \<lparr>nodes = N, edges = E'\<rparr>"
    and wfG: "wf_graph \<lparr>nodes = N, edges = E\<rparr>"
    and E'subset: "E' \<subseteq> E"
    and evalE: "sinvar \<lparr>nodes = N, edges = E\<rparr> nP"

    from Pmono have Pmono1:
      "\<And>nP N E' E. wf_graph \<lparr> nodes = N, edges = E \<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> (\<forall>(e1,e2) \<in> E. P e1 e2 nP \<lparr>nodes = N, edges = E\<rparr> \<longrightarrow> P e1 e2 nP \<lparr>nodes = N, edges = E'\<rparr>)"
    by blast

    from AllForm have "sinvar \<lparr>nodes = N, edges = E\<rparr> nP = (\<forall> (e1, e2) \<in> E. P e1 e2 nP \<lparr>nodes = N, edges = E\<rparr>)" by force
    from this evalE have "(\<forall> (e1, e2) \<in> E. P e1 e2 nP \<lparr>nodes = N, edges = E\<rparr>)" by simp
    from Pmono1[OF wfG E'subset, of "nP"] this have "\<forall>(e1, e2) \<in> E. P e1 e2 nP \<lparr>nodes = N, edges = E'\<rparr>" by fast
    from this E'subset have "\<forall>(e1, e2) \<in> E'. P e1 e2 nP \<lparr>nodes = N, edges = E'\<rparr>" by fast
    from this have "\<forall>(e1, e2) \<in> (edges \<lparr>nodes = N, edges = E'\<rparr>). P e1 e2 nP \<lparr>nodes = N, edges = E'\<rparr>" by simp
    from this AllForm show "sinvar \<lparr>nodes = N, edges = E'\<rparr> nP" by presburger
  qed

   text\<open>Invariant violations do not disappear if we add more flows.\<close>
   lemma sinvar_mono_imp_negative_mono:
   "sinvar_mono \<Longrightarrow> wf_graph \<lparr> nodes = N, edges = E \<rparr> \<Longrightarrow>  E' \<subseteq> E \<Longrightarrow>
   \<not> sinvar \<lparr> nodes = N, edges = E' \<rparr> nP \<Longrightarrow> \<not> sinvar \<lparr> nodes = N, edges = E \<rparr> nP"
   unfolding sinvar_mono_def by(blast)

  corollary sinvar_mono_imp_negative_delete_edge_mono:
   "sinvar_mono \<Longrightarrow> wf_graph G \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> \<not> sinvar (delete_edges G Y) nP \<Longrightarrow> \<not> sinvar (delete_edges G X) nP "
  proof -
   assume sinvar_mono
   and "wf_graph G" and "X \<subseteq> Y" and "\<not> sinvar (delete_edges G Y) nP"
   from delete_edges_wf[OF \<open>wf_graph G\<close>] have valid_G_delete: "wf_graph \<lparr>nodes = nodes G, edges = edges G - X\<rparr>" by(simp add: delete_edges_simp2)
   from \<open>X \<subseteq> Y\<close> have "edges G - Y \<subseteq> edges G - X" by blast
   with \<open>sinvar_mono\<close> sinvar_mono_def valid_G_delete have
    "sinvar \<lparr>nodes = nodes G, edges = edges G - X\<rparr> nP \<Longrightarrow> sinvar \<lparr>nodes = nodes G, edges = edges G - Y\<rparr> nP" by blast
   hence "sinvar (delete_edges G X) nP \<Longrightarrow> sinvar (delete_edges G Y) nP" by(simp add: delete_edges_simp2)
   with \<open>\<not> sinvar (delete_edges G Y) nP\<close> show ?thesis by blast
  qed

  (*lemma mono_offending_flows_min_set:
  assumes mono_isoffending: "(\<forall> ff f' G nP. is_offending_flows ff G nP \<longrightarrow> is_offending_flows (f' \<union> ff) G nP)"
  and offending: "is_offending_flows_min_set As G nP"
  shows "sinvar (delete_edges G (As \<union> Bs)) nP"
  proof -
    from offending have "is_offending_flows As G nP" using is_offending_flows_min_set_def by simp
    from mono_isoffending this have "is_offending_flows (Bs \<union> As) G nP" by simp
    hence "is_offending_flows (As \<union> Bs) G nP" by (metis Un_commute)
    from this is_offending_flows_def show ?thesis by simp
  qed*)

  (*use this to show locale preliminaries from mono*)
  lemma sinvar_mono_imp_is_offending_flows_mono:
  assumes mono: "sinvar_mono"
  and wfG: "wf_graph G"
  shows "is_offending_flows FF G nP  \<Longrightarrow> is_offending_flows (FF \<union> F) G nP"
  proof -
    from wfG have wfG': "wf_graph \<lparr>nodes = nodes G, edges = {(e1, e2). (e1, e2) \<in> edges G \<and> (e1, e2) \<notin> FF}\<rparr>"
      by (metis delete_edges_def delete_edges_wf)
    from mono have sinvarE: "(\<And> nP N E' E. wf_graph \<lparr> nodes = N, edges = E \<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> sinvar \<lparr> nodes = N, edges = E \<rparr> nP \<Longrightarrow> sinvar \<lparr> nodes = N, edges = E' \<rparr> nP )"
      unfolding sinvar_mono_def
      by metis
    have "\<And> G FF F. {(e1, e2). (e1, e2) \<in> edges G \<and> (e1, e2) \<notin> FF \<and> (e1, e2) \<notin> F} \<subseteq> {(e1, e2). (e1, e2) \<in> edges G \<and> (e1, e2) \<notin> FF} "
      by(rule Collect_mono) (simp)
    from sinvarE[OF wfG' this]
    show "is_offending_flows FF G nP \<Longrightarrow> is_offending_flows (FF \<union> F) G nP"
      by(simp add: is_offending_flows_def delete_edges_def)
  qed

  (*use this to show locale sinvar_mono*)
  lemma sinvar_mono_imp_sinvar_mono:
  "sinvar_mono \<Longrightarrow> wf_graph \<lparr> nodes = N, edges = E \<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> sinvar \<lparr> nodes = N, edges = E \<rparr> nP \<Longrightarrow>
        sinvar \<lparr> nodes = N, edges = E' \<rparr> nP"
  apply(simp add: sinvar_mono_def)
  by blast

end

subsection \<open>Offending Flows Not Empty Helper Lemmata\<close>
context SecurityInvariant_withOffendingFlows
begin
  text \<open>Give an over-approximation of offending flows (e.g. all edges) and get back a
          minimal set\<close>
  (*offending_overapproximation keepingInOffendingApproximation G nP*)
  fun minimalize_offending_overapprox :: "('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow>
  'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> ('v \<times> 'v) list" where
  "minimalize_offending_overapprox [] keep _ _ = keep" |
  "minimalize_offending_overapprox (f#fs) keep G nP = (if sinvar (delete_edges_list G (fs@keep)) nP then
      minimalize_offending_overapprox fs keep G nP
    else
      minimalize_offending_overapprox fs (f#keep) G nP
    )"

  text\<open>The graph we check in @{const minimalize_offending_overapprox},
  @{term "G minus (fs \<union> keep)"} is the graph from the \<open>offending_flows_min_set\<close> condition.
  We add @{term f} and remove it.\<close>

  (*lemma minimalize_offending_overapprox_not_in:
  "f \<notin> set fs \<Longrightarrow> f \<notin> set keep \<Longrightarrow> f \<notin> set (minimalize_offending_overapprox fs keep G nP)"
   apply(induction fs arbitrary: keep)
    by(simp_all)*)

  (*lemma offending_min_set_ab_in_fs: "wf_graph (G::'v graph) \<Longrightarrow> (a,b) \<in> edges G \<Longrightarrow>
       is_offending_flows_min_set ({(a, b)} \<union> fs) G nP \<Longrightarrow>
       sinvar (delete_edges G fs) nP \<Longrightarrow>
       (a,b) \<in> fs"
  apply(rule ccontr)
  apply(simp add: is_offending_flows_min_set_def)
  apply(clarify)
  apply(simp add: add_delete_edges)
  done*)

  lemma minimalize_offending_overapprox_subset:
  "set (minimalize_offending_overapprox ff keeps G nP) \<subseteq> set ff \<union> set keeps"
   proof(induction ff arbitrary: keeps)
   case Nil
    thus ?case by simp
   next
   case (Cons a ff)
    from Cons have case1: "(sinvar (delete_edges_list G (ff @ keeps)) nP \<Longrightarrow>
     set (minimalize_offending_overapprox ff keeps G nP) \<subseteq> insert a (set ff \<union> set keeps))"
      by blast
     from Cons have case2: "(\<not> sinvar (delete_edges_list G (ff @ keeps)) nP \<Longrightarrow>
     set (minimalize_offending_overapprox ff (a # keeps) G nP) \<subseteq> insert a (set ff \<union> set keeps))"
      by fastforce
    from case1 case2 show ?case by simp
   qed

  lemma not_model_mono_imp_addedge_mono:
  assumes mono: "sinvar_mono"
   and vG: "wf_graph G" and ain: "(a1,a2) \<in> edges G" and xy: "X \<subseteq> Y" and ns: "\<not> sinvar (add_edge a1 a2 (delete_edges G (Y))) nP"
  shows "\<not> sinvar (add_edge a1 a2 (delete_edges G X)) nP"
   proof -
      have wf_graph_add_delete_edge_simp:
        "\<And>Y. add_edge a1 a2 (delete_edges G Y) = (delete_edges G (Y - {(a1,a2)}))"
        apply(simp add: delete_edges_simp2 add_edge_def)
        apply(rule conjI)
         using ain apply (metis insert_absorb vG wf_graph.E_wfD(1) wf_graph.E_wfD(2))
         apply(auto simp add: ain)
        done
      from this ns have 1: "\<not> sinvar (delete_edges G (Y - {(a1, a2)})) nP" by simp
      have 2: "X - {(a1, a2)} \<subseteq> Y - {(a1, a2)}" by (metis Diff_mono subset_refl xy)
      from sinvar_mono_imp_negative_delete_edge_mono[OF mono] vG have
        "\<And>X Y. X \<subseteq> Y \<Longrightarrow> \<not> sinvar (delete_edges G Y) nP \<Longrightarrow> \<not> sinvar (delete_edges G X) nP" by blast
      from this[OF 2 1] have "\<not> sinvar (delete_edges G (X - {(a1, a2)})) nP" by simp
      from this wf_graph_add_delete_edge_simp[symmetric] show ?thesis by simp
   qed

  theorem is_offending_flows_min_set_minimalize_offending_overapprox:
      assumes mono: "sinvar_mono"
      and vG: "wf_graph G" and iO: "is_offending_flows (set ff) G nP" and sF: "set ff \<subseteq> edges G" and dF: "distinct ff"
      shows "is_offending_flows_min_set (set (minimalize_offending_overapprox ff [] G nP)) G nP"
              (is "is_offending_flows_min_set ?minset G nP")
  proof -
    from iO have "sinvar (delete_edges G (set ff)) nP" by (metis is_offending_flows_def)

    \<comment> \<open>@{term "sinvar"} holds if we delete @{term "ff"}.
        With the following generalized statement, we show that it also holds if we delete @{term "minimalize_offending_overapprox ff []"}\<close>
    {
      fix keeps
      \<comment> \<open>Generalized for arbitrary @{term keeps}\<close>
        have "sinvar (delete_edges G (set ff \<union> set keeps)) nP \<Longrightarrow>
          sinvar (delete_edges G (set (minimalize_offending_overapprox ff keeps G nP))) nP"
         apply(induction ff arbitrary: keeps)
          apply(simp)
         apply(simp)
         apply(rule impI)
         apply(simp add:delete_edges_list_union)
         done
    }
    \<comment> \<open>@{term "keeps = []"}\<close>
    note minimalize_offending_overapprox_maintains_evalmodel=this[of "[]"]

    from \<open>sinvar (delete_edges G (set ff)) nP\<close> minimalize_offending_overapprox_maintains_evalmodel have
      "sinvar (delete_edges G ?minset) nP" by simp
    hence 1: "is_offending_flows ?minset G nP" by (metis iO is_offending_flows_def)

    txt\<open>We need to show minimality of @{term "minimalize_offending_overapprox ff []"}.
      Minimality means @{term "\<forall>(e1, e2)\<in>?minset. \<not> sinvar (add_edge e1 e2 (delete_edges G ?minset)) nP"}.
      We show the following generalized fact.
\<close>
    {
      fix ff keeps
      have "\<forall> x \<in> set ff. x \<notin> set keeps \<Longrightarrow>
        \<forall> x \<in> set ff. x \<in> edges G \<Longrightarrow>
        distinct ff \<Longrightarrow>
        \<forall>(e1, e2)\<in> set keeps.
           \<not> sinvar (add_edge e1 e2 (delete_edges G (set (minimalize_offending_overapprox ff keeps G nP)))) nP \<Longrightarrow>
        \<forall>(e1, e2)\<in>set (minimalize_offending_overapprox ff keeps G nP).
           \<not> sinvar (add_edge e1 e2 (delete_edges G (set (minimalize_offending_overapprox ff keeps G nP)))) nP"
       proof(induction ff arbitrary: keeps)
       case Nil
        from Nil show ?case by(simp)
       next
       case (Cons a ff)
        assume not_in_keeps: "\<forall>x\<in>set (a # ff). x \<notin> set keeps"
          hence a_not_in_keeps: "a \<notin> set keeps" by simp
        assume in_edges: "\<forall>x\<in>set (a # ff). x \<in> edges G"
          hence ff_in_edges: "\<forall>x\<in>set ff. x \<in> edges G" and a_in_edges: "a \<in> edges G" by simp_all
        assume distinct: "distinct (a # ff)"
          hence ff_distinct: "distinct ff" and a_not_in_ff: "a \<notin> set ff "by simp_all
        assume minimal: "\<forall>(e1, e2)\<in>set keeps.
          \<not> sinvar (add_edge e1 e2 (delete_edges G (set (minimalize_offending_overapprox (a # ff) keeps G nP)))) nP"

        have delete_edges_list_union_insert: "\<And> f fs keep. delete_edges_list G (f#fs@keep) = delete_edges G ({f} \<union> set fs \<union> set keep)"
        by(simp add: graph_ops delete_edges_list_set)

        let ?goal="?case" \<comment> \<open>we show this by case distinction\<close>
        show ?case
        proof(cases "sinvar (delete_edges_list G (ff@keeps)) nP")
        case True
          from True have "sinvar (delete_edges_list G (ff@keeps)) nP" .
          from this Cons show ?goal using delete_edges_list_union by simp
        next
        case False
          (*MONO=Cons.prems(1)"*)
           { \<comment> \<open>a lemma we only need once here\<close>
              fix a ff keeps
              assume mono: "sinvar_mono" and ankeeps: "a \<notin> set keeps"
              and anff: "a \<notin> set ff" and aE: "a \<in> edges G"
              and nsinvar: "\<not> sinvar (delete_edges_list G (ff @ keeps)) nP"
              have "\<not> sinvar (add_edge (fst a) (snd a) (delete_edges G (set (minimalize_offending_overapprox (a # ff) keeps G nP)))) nP"
              proof -
                { fix F Fs keep
                  from vG have "F \<in> edges G \<Longrightarrow> F \<notin> set Fs \<Longrightarrow> F \<notin> set keep \<Longrightarrow>
                    (add_edge (fst F) (snd F) (delete_edges_list G (F#Fs@keep))) = (delete_edges_list G (Fs@keep))"
                  apply(simp add:delete_edges_list_union delete_edges_list_union_insert)
                  apply(simp add: graph_ops)
                  apply(rule conjI)
                   apply(simp add: wf_graph_def)
                   apply blast
                  apply(simp add: wf_graph_def)
                  by fastforce
                } note delete_edges_list_add_add_iff=this
                from aE have "(fst a, snd a) \<in> edges G" by simp
                from delete_edges_list_add_add_iff[of a ff keeps] have
                  "delete_edges_list G (ff @ keeps) = add_edge (fst a) (snd a) (delete_edges_list G (a # ff @ keeps))"
                  by (metis aE anff ankeeps)
                from this nsinvar have "\<not> sinvar (add_edge (fst a) (snd a) (delete_edges_list G (a # ff @ keeps))) nP" by simp
                from this delete_edges_list_union_insert have 1:
                  "\<not> sinvar (add_edge (fst a) (snd a) (delete_edges G (insert a (set ff \<union> set keeps)))) nP" by (metis insert_is_Un sup_assoc)

                from minimalize_offending_overapprox_subset[of "ff" "a#keeps" G nP] have
                  "set (minimalize_offending_overapprox ff (a # keeps) G nP) \<subseteq> insert a (set ff \<union> set keeps)" by simp

                from not_model_mono_imp_addedge_mono[OF mono vG \<open>(fst a, snd a) \<in> edges G\<close> this 1] show ?thesis
                  by (metis minimalize_offending_overapprox.simps(2) nsinvar)
              qed
           } note not_model_mono_imp_addedge_mono_minimalize_offending_overapprox=this

          from not_model_mono_imp_addedge_mono_minimalize_offending_overapprox[OF mono a_not_in_keeps a_not_in_ff a_in_edges False] have a_minimal: "
          \<not> sinvar (add_edge (fst a) (snd a) (delete_edges G (set (minimalize_offending_overapprox (a # ff) keeps G nP)))) nP"
          by simp
          from minimal a_minimal
          have a_keeps_minimal: "\<forall>(e1, e2)\<in>set (a # keeps).
          \<not> sinvar (add_edge e1 e2 (delete_edges G (set (minimalize_offending_overapprox ff (a # keeps) G nP)))) nP"
            using False by fastforce
          from Cons.prems have a_not_in_keeps: "\<forall>x\<in>set ff. x \<notin> set (a#keeps)" by auto
          from Cons.IH[OF a_not_in_keeps ff_in_edges ff_distinct a_keeps_minimal] have IH:
            "\<forall>(e1, e2)\<in>set (minimalize_offending_overapprox ff (a # keeps) G nP).
           \<not> sinvar (add_edge e1 e2 (delete_edges G (set (minimalize_offending_overapprox ff (a # keeps) G nP)))) nP" .

          from False have "\<not> sinvar (delete_edges G (set ff \<union> set keeps)) nP " using delete_edges_list_union by metis
          from this have "set (minimalize_offending_overapprox (a # ff) keeps G nP) =
            set (minimalize_offending_overapprox ff (a#keeps) G nP)"
            by(simp add: delete_edges_list_union)
          from this IH have ?goal by presburger
          thus ?goal .
        qed
      qed
    } note mono_imp_minimalize_offending_overapprox_minimal=this[of ff "[]"]

    from mono_imp_minimalize_offending_overapprox_minimal[OF _ _ dF] sF have 2:
      "\<forall>(e1, e2)\<in>?minset. \<not> sinvar (add_edge e1 e2 (delete_edges G ?minset)) nP"
    by auto
    from 1 2 show ?thesis
      by(simp add: is_offending_flows_def is_offending_flows_min_set_def)
  qed

  corollary mono_imp_set_offending_flows_not_empty:
  assumes mono_sinvar: "sinvar_mono"
  and vG: "wf_graph G" and iO: "is_offending_flows (set ff) G nP" and sS: "set ff \<subseteq> edges G" and dF: "distinct ff"
  shows
    "set_offending_flows G nP \<noteq> {}"
  proof -
    from iO SecurityInvariant_withOffendingFlows.is_offending_flows_def have nS: "\<not> sinvar G nP" by metis
    from sinvar_mono_imp_negative_delete_edge_mono[OF mono_sinvar] have negative_delete_edge_mono:
      "\<forall> G nP X Y. wf_graph G \<and> X \<subseteq> Y \<and> \<not> sinvar (delete_edges G (Y)) nP \<longrightarrow> \<not> sinvar (delete_edges G X) nP" by blast

    from is_offending_flows_min_set_minimalize_offending_overapprox[OF mono_sinvar vG iO sS dF]
     have "is_offending_flows_min_set (set (minimalize_offending_overapprox ff [] G nP)) G nP" by simp
    from this set_offending_flows_def sS have
      "(set (minimalize_offending_overapprox ff [] G nP)) \<in> set_offending_flows G nP"
      using minimalize_offending_overapprox_subset[where keeps="[]"] by fastforce
    thus ?thesis by blast
   qed

   text\<open>
   To show that @{const set_offending_flows} is not empty, the previous corollary @{thm mono_imp_set_offending_flows_not_empty} is very useful.
   Just select @{term "set ff = edges G"}.
\<close>

   text\<open>
   If there exists a security violations,
   there a means to fix it if and only if the network in which nobody communicates with anyone fulfills the security requirement
\<close>
   theorem valid_empty_edges_iff_exists_offending_flows:
    assumes mono: "sinvar_mono" and wfG: "wf_graph G" and noteval: "\<not> sinvar G nP"
    shows "sinvar \<lparr> nodes = nodes G, edges = {} \<rparr> nP \<longleftrightarrow> set_offending_flows G nP \<noteq> {}"
   proof
      assume a: "sinvar \<lparr> nodes = nodes G, edges = {} \<rparr> nP"

      from finite_distinct_list[OF wf_graph.finiteE] wfG
      obtain list_edges where list_edges_props: "set list_edges = edges G \<and> distinct list_edges" by blast
      hence listedges_subseteq_edges: "set list_edges \<subseteq> edges G" by blast

      have empty_edge_graph_simp: "(delete_edges G (edges G)) = \<lparr> nodes = nodes G, edges = {} \<rparr>" by(auto simp add: graph_ops)
      from a is_offending_flows_def noteval list_edges_props empty_edge_graph_simp
        have overapprox: "is_offending_flows (set list_edges) G nP" by auto

      from mono_imp_set_offending_flows_not_empty[OF mono wfG overapprox listedges_subseteq_edges] list_edges_props
      show "set_offending_flows G nP \<noteq> {}" by simp
    next
      assume a: "set_offending_flows G nP \<noteq> {}"

      from a obtain f where f_props: "f \<subseteq> edges G \<and> is_offending_flows_min_set f G nP" using set_offending_flows_def by fastforce

      from f_props have "sinvar (delete_edges G f) nP" using is_offending_flows_min_set_def is_offending_flows_def by simp
        hence evalGf: "sinvar \<lparr>nodes = nodes G, edges = {(e1, e2). (e1, e2) \<in> edges G \<and> (e1, e2) \<notin> f}\<rparr> nP" by(simp add: delete_edges_def)
      from delete_edges_wf[OF wfG, unfolded delete_edges_def]
        have wfGf: "wf_graph \<lparr>nodes = nodes G, edges = {(e1, e2). (e1, e2) \<in> edges G \<and> (e1, e2) \<notin> f}\<rparr>" by simp
      have emptyseqGf: "{} \<subseteq>  {(e1, e2). (e1, e2) \<in> edges G \<and> (e1, e2) \<notin> f}" by simp

      from mono[unfolded sinvar_mono_def] evalGf wfGf emptyseqGf have "sinvar \<lparr>nodes = nodes G, edges = {}\<rparr> nP" by blast
      thus "sinvar \<lparr>nodes = nodes G, edges = {}\<rparr> nP" .
  qed

  text\<open>
  @{const minimalize_offending_overapprox} not only computes a set where @{const is_offending_flows_min_set} holds, but it also returns a subset of the input.
\<close>
  lemma minimalize_offending_overapprox_keeps_keeps: "(set keeps) \<subseteq> set (minimalize_offending_overapprox ff keeps G nP)"
    proof(induction ff keeps G nP rule: minimalize_offending_overapprox.induct)
    qed(simp_all)

  lemma minimalize_offending_overapprox_subseteq_input: "set (minimalize_offending_overapprox ff keeps G nP) \<subseteq> (set ff) \<union> (set keeps)"
    proof(induction ff keeps G nP rule: minimalize_offending_overapprox.induct)
    case 1 thus ?case by simp
    next
    case 2 thus ?case by(simp add: delete_edges_list_set delete_edges_simp2) blast
    qed

end

context SecurityInvariant_preliminaries
  begin
    text\<open>@{const sinvar_mono} naturally holds in @{const SecurityInvariant_preliminaries}\<close>
    lemma sinvar_monoI: "sinvar_mono"
      unfolding sinvar_mono_def using mono_sinvar by blast

    text\<open>Note: due to monotonicity, the minimality also holds for arbitrary subsets\<close>
    lemma assumes "wf_graph G" and "is_offending_flows_min_set F G nP" and "F \<subseteq> edges G" and "E \<subseteq> F" and "E \<noteq> {}"
          shows "\<not> sinvar \<lparr> nodes = nodes G, edges = ((edges G) - F) \<union> E \<rparr> nP"
    proof -
      from sinvar_mono_imp_negative_delete_edge_mono[OF sinvar_monoI \<open>wf_graph G\<close>] have negative_delete_edge_mono:
      "\<And>X Y. X \<subseteq> Y \<Longrightarrow> \<not> sinvar \<lparr> nodes = nodes G, edges = (edges G) - Y \<rparr> nP \<Longrightarrow> \<not> sinvar \<lparr> nodes = nodes G, edges = edges G - X \<rparr> nP"
        using delete_edges_simp2 by metis
      from assms(2) have "(\<forall>(e1, e2)\<in>F. \<not> sinvar (add_edge e1 e2 (delete_edges G F)) nP)"
      unfolding is_offending_flows_min_set_def by simp
      with \<open>wf_graph G\<close> have min: "(\<forall>(e1, e2)\<in>F. \<not> sinvar \<lparr> nodes = nodes G, edges = ((edges G) - F) \<union> {(e1,e2)} \<rparr> nP)"
        apply(simp add: delete_edges_simp2 add_edge_def)
        apply(rule, rename_tac x, case_tac x, rename_tac e1 e2, simp)
        apply(erule_tac x="(e1, e2)" in ballE)
         apply(simp_all)
        apply(subgoal_tac "insert e1 (insert e2 (nodes G)) = nodes G")
         apply(simp)
        by (metis assms(3) insert_absorb rev_subsetD wf_graph.E_wfD(1) wf_graph.E_wfD(2))
      from \<open>E \<noteq> {}\<close> obtain e where "e \<in> E" by blast
      with min \<open>E \<subseteq> F\<close> have mine: "\<not> sinvar \<lparr> nodes = nodes G, edges = ((edges G) - F) \<union> {e} \<rparr> nP" by fast
      have e1: "edges G - (F - {e}) = insert e (edges G - F)" using DiffD2 \<open>e \<in> E\<close> assms(3) assms(4) by auto
      have e2: "edges G - (F - E) = ((edges G) - F) \<union> E" using assms(3) assms(4) by auto
      from negative_delete_edge_mono[where Y="F - {e}" and X="F - E"] \<open>e \<in> E\<close> have
      "\<not> sinvar \<lparr>nodes = nodes G, edges = edges G - (F - {e})\<rparr> nP \<Longrightarrow> \<not> sinvar \<lparr>nodes = nodes G, edges = edges G - (F - E)\<rparr> nP" by blast
      with mine e1 e2 show ?thesis by simp
    qed

    text\<open>The algorithm @{const minimalize_offending_overapprox} is correct\<close>
    lemma minimalize_offending_overapprox_sound:
      "\<lbrakk> wf_graph G; is_offending_flows (set ff) G nP; set ff \<subseteq> edges G; distinct ff \<rbrakk>
        \<Longrightarrow> is_offending_flows_min_set (set (minimalize_offending_overapprox ff [] G nP)) G nP "
    using is_offending_flows_min_set_minimalize_offending_overapprox sinvar_monoI by blast

    text\<open>
      If @{term "\<not> sinvar G nP"}
      Given a list ff, (ff is distinct and a subset of G's edges)
      such that \<open>sinvar (V, E - ff) nP\<close>
      @{const minimalize_offending_overapprox} minimizes ff such that we get an offending flows
      Note: choosing ff = edges G is a good choice!
\<close>
    theorem minimalize_offending_overapprox_gives_back_an_offending_flow:
      "\<lbrakk> wf_graph G; is_offending_flows (set ff) G nP; set ff \<subseteq> edges G; distinct ff \<rbrakk>
        \<Longrightarrow>
         (set (minimalize_offending_overapprox ff [] G nP)) \<in> set_offending_flows G nP"
    apply(frule(3) minimalize_offending_overapprox_sound)
    apply(simp add: set_offending_flows_def)
    using minimalize_offending_overapprox_subseteq_input[where keeps="[]", simplified] by blast

    (*TODO better minimality condition for keeps*)
    (*lemma  minimalize_offending_overapprox_sound_fixKeep:
      "\<lbrakk> wf_graph G; is_offending_flows (set (ff @ keeps)) G nP; \<forall> x \<in> set ff. x \<notin> set keeps; \<forall> x \<in> set ff. x \<in> edges G; distinct ff;
        \<forall>(e1, e2)\<in> set keeps. \<not> sinvar (add_edge e1 e2 (delete_edges G (set (minimalize_offending_overapprox ff keeps G nP)))) nP \<rbrakk>
        \<Longrightarrow>
         is_offending_flows_min_set (set (minimalize_offending_overapprox ff keeps G nP)) G nP \<and> set keeps \<subseteq> (set (minimalize_offending_overapprox ff keeps G nP))"
       apply(rule conjI)
        apply(simp only: is_offending_flows_min_set_def)
        apply(rule conjI)
         apply(simp add: is_offending_flows_def is_offending_flows_min_set_def)
         apply(simp add:minimalize_offending_overapprox_maintains_evalmodel)
        apply(rule mono_imp_minimalize_offending_overapprox_minimal)
             apply (metis sinvar_monoI sinvar_mono_imp_negative_delete_edge_mono)
            apply(simp)
           apply(simp)
          apply(simp)
         apply(simp)
        apply(simp)

       apply(thin_tac "?x")+
       apply(induction ff keeps G nP rule: minimalize_offending_overapprox.induct)
        apply(simp_all)
      done*)

end

text\<open>A version which acts on configured security invariants.
      I.e. there is no type @{typ 'a} for the host attributes in it.\<close>
fun minimalize_offending_overapprox :: "('v graph \<Rightarrow> bool) \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow>
'v graph \<Rightarrow>('v \<times> 'v) list" where
"minimalize_offending_overapprox _ [] keep _ = keep" |
"minimalize_offending_overapprox m (f#fs) keep G = (if m (delete_edges_list G (fs@keep)) then
    minimalize_offending_overapprox m fs keep G
  else
    minimalize_offending_overapprox m fs (f#keep) G
  )"

lemma minimalize_offending_overapprox_boundnP:
shows "minimalize_offending_overapprox (\<lambda>G. m G nP) fs keeps G =
         SecurityInvariant_withOffendingFlows.minimalize_offending_overapprox m fs keeps G nP"
  apply(induction fs arbitrary: keeps)
   apply(simp add: SecurityInvariant_withOffendingFlows.minimalize_offending_overapprox.simps; fail)
  apply(simp add: SecurityInvariant_withOffendingFlows.minimalize_offending_overapprox.simps)
  done

context SecurityInvariant_withOffendingFlows
begin

    text\<open>If there is a violation and there are no offending flows, there does not exist a possibility to fix the violation by
          tightening the policy. @{thm valid_empty_edges_iff_exists_offending_flows} already hints this.\<close>
    lemma mono_imp_emptyoffending_eq_nevervalid:
       "\<lbrakk> sinvar_mono; wf_graph G; \<not> sinvar G nP; set_offending_flows G nP = {}\<rbrakk> \<Longrightarrow>
        \<not> (\<exists> F \<subseteq> edges G. sinvar (delete_edges G F) nP)"
    proof -
      assume mono: "sinvar_mono"
      and wfG: "wf_graph G"
      and a1:  "\<not> sinvar G nP"
      and a2: "set_offending_flows G nP = {}"

      from wfG have wfG': "wf_graph \<lparr>nodes = nodes G, edges = edges G\<rparr>" by(simp add:wf_graph_def)

      from a2 set_offending_flows_def have "\<forall>f \<subseteq> edges G. \<not> is_offending_flows_min_set f G nP" by simp
      from this is_offending_flows_min_set_def is_offending_flows_def a1 have notdeleteconj:
        "\<forall>f \<subseteq> edges G.
          \<not> sinvar (delete_edges G f) nP \<or>
          \<not> ((\<forall>(e1, e2)\<in>f. \<not> sinvar (add_edge e1 e2 (delete_edges G f)) nP))"
      by simp
      have "\<forall>f\<subseteq>edges G. \<not> sinvar (delete_edges G f) nP"
      proof (rule allI, rule impI)
        fix f
        assume "f \<subseteq> edges G"
        from this notdeleteconj have
         "\<not> sinvar (delete_edges G f) nP \<or>
          \<not> ((\<forall>(e1, e2)\<in>f. \<not> sinvar (add_edge e1 e2 (delete_edges G f)) nP))" by simp
        from this show "\<not> sinvar (delete_edges G f) nP"
          proof
            assume "\<not> sinvar (delete_edges G f) nP" thus "\<not> sinvar (delete_edges G f) nP" .
          next
            assume "\<not> (\<forall>(e1, e2)\<in>f. \<not> sinvar (add_edge e1 e2 (delete_edges G f)) nP)"
            hence "\<exists>(e1,e2)\<in>f. sinvar (add_edge e1 e2 (delete_edges G f)) nP" by(auto)
            from this obtain e1 e2 where e1e2cond: "(e1,e2)\<in>f \<and> sinvar (add_edge e1 e2 (delete_edges G f)) nP" by blast

            from \<open>f \<subseteq> edges G\<close> wfG have "finite f" apply(simp add: wf_graph_def) by (metis rev_finite_subset)
            from this obtain listf where listf: "set listf = f \<and> distinct listf" by (metis finite_distinct_list)

            from e1e2cond \<open>f \<subseteq> edges G\<close> have Geq:
            "(add_edge e1 e2 (delete_edges G f)) = \<lparr> nodes = nodes G, edges = edges G - f \<union> {(e1,e2)}\<rparr>"
              apply(simp add: graph_ops wfG')
              apply(clarify)
               using wfG[unfolded wf_graph_def] by force

            from this[symmetric] add_edge_wf[OF delete_edges_wf[OF wfG]] have
              "wf_graph \<lparr>nodes = nodes G, edges = edges G - f \<union> {(e1, e2)}\<rparr>" by simp
            from mono this  have mono'':
              "\<And> E'. E' \<subseteq> edges G - f \<union> {(e1, e2)} \<Longrightarrow>
                sinvar \<lparr>nodes = nodes G, edges = edges G - f \<union> {(e1, e2)}\<rparr> nP \<Longrightarrow>
                sinvar \<lparr>nodes = nodes G, edges = E'\<rparr> nP" unfolding sinvar_mono_def by blast

            from e1e2cond Geq have "sinvar \<lparr> nodes = nodes G, edges = edges G - f \<union> {(e1,e2)}\<rparr> nP" by simp
            from this mono'' have "sinvar \<lparr> nodes = nodes G, edges = edges G - f\<rparr> nP" by auto
            hence overapprox: "sinvar (delete_edges G f) nP" by (simp add: delete_edges_simp2)
            (*Interesting, the opposite of what we want to show holds ...*)

            from a1 overapprox have "is_offending_flows f G nP" by(simp add: is_offending_flows_def)
            from this listf have c1: "is_offending_flows (set listf) G nP" by(simp add: is_offending_flows_def)
            from listf \<open>f \<subseteq> edges G\<close> have c2: "set listf \<subseteq> edges G" by simp

            from mono_imp_set_offending_flows_not_empty[OF mono wfG c1 c2 conjunct2[OF listf]] have
              "set_offending_flows G nP \<noteq> {}" .
            from this a2 have "False" by simp
            (*I knew this can't be!*)

            thus "\<not> sinvar (delete_edges G f) nP" by simp
          qed
      qed
      thus ?thesis by simp
    qed
end

(*
text{* Old version of security invariant gave @{term "F \<in> set_offending_flows G nP"} and @{term "sinvar (delete_edges G F) nP"}
  as assumption for @{text "default_secure"}. We can conclude this from mono. *}
context SecurityInvariant_withOffendingFlows
begin
  lemma mono_exists_offending_flows:
  "\<lbrakk> sinvar_mono; wf_graph G; is_offending_flows (set ff) G nP; set ff \<subseteq> edges G; distinct ff \<rbrakk>
    \<Longrightarrow> \<exists>F. F \<in> set_offending_flows G nP \<and> sinvar (delete_edges G F) nP"
    apply(frule mono_imp_set_offending_flows_not_empty[of G nP ff])
         apply(simp_all add:is_offending_flows_def)
    apply(simp add: set_offending_flows_def)
    apply(erule exE)
    apply(rename_tac exF)
    apply(clarify)
    apply(rule_tac x="exF" in exI)
    apply(rule conjI)
     apply(simp)
    apply(rule conjI)
     apply(simp)
    apply(simp add:is_offending_flows_min_set_def is_offending_flows_def)
  done
end
*)

subsection \<open>Monotonicity of offending flows\<close>
  context SecurityInvariant_preliminaries
  begin

    (*todo: simplify proof*)
    text\<open>If there is some @{term "F'"} in the offending flows of a small graph and you have a bigger graph,
          you can extend @{term "F'"} by some @{term "Fadd"} and minimality in @{term F} is preserved\<close>
    lemma minimality_offending_flows_mono_edges_graph_extend:
    "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>; E' \<subseteq> E; Fadd \<inter> E' = {}; F' \<in> set_offending_flows \<lparr>nodes = V, edges = E'\<rparr> nP \<rbrakk> \<Longrightarrow>
            (\<forall>(e1, e2)\<in>F'. \<not> sinvar (add_edge e1 e2 (delete_edges \<lparr>nodes = V, edges = E \<rparr> (F' \<union> Fadd))) nP)"
    proof -
      assume a1: "wf_graph \<lparr> nodes = V, edges = E \<rparr>"
      and    a2: "E' \<subseteq> E"
      and    a3: "Fadd \<inter> E' = {}"
      and    a4: "F' \<in> set_offending_flows \<lparr>nodes = V, edges = E'\<rparr> nP"

      from a4 have "F' \<subseteq> E'" by(simp add: set_offending_flows_def)

      obtain Eadd where Eadd_prop: "E' \<union> Eadd = E" and "E' \<inter> Eadd = {}" using a2 by blast

      have Fadd_notinE': "\<And>Fadd. Fadd \<inter> E' = {} \<Longrightarrow>  E' - (F' \<union> Fadd) =  E' - F'" by blast
      from \<open>F' \<subseteq> E'\<close> a1[simplified wf_graph_def] a2 have FinV1: "fst ` F' \<subseteq> V" and FinV2: "snd ` F' \<subseteq> V"
      proof -
        from a1 have "fst ` E \<subseteq> V" by(simp add: wf_graph_def)
        with \<open>F' \<subseteq> E'\<close> a2 show "fst ` F' \<subseteq> V" by fast
        from a1 have "snd ` E \<subseteq> V" by(simp add: wf_graph_def)
        with \<open>F' \<subseteq> E'\<close> a2 show "snd ` F' \<subseteq> V" by fast
      qed
      hence insert_e1_e2_V: "\<forall> (e1, e2) \<in> F'. insert e1 (insert e2 V) = V" by auto
      hence add_edge_F: "\<forall> (e1, e2) \<in> F'. add_edge e1 e2 \<lparr>nodes = V, edges = E' - F' \<rparr> =  \<lparr>nodes = V, edges = (E' - F') \<union> {(e1, e2)}\<rparr>"
        by(simp add: add_edge_def)

      have Fadd_notinE': "\<And>Fadd. Fadd \<inter> E' = {} \<Longrightarrow>  E' - (F' \<union> Fadd) =  E' - F'" by blast
       from \<open>F' \<subseteq> E'\<close> this have Fadd_notinF: "\<And>Fadd. Fadd \<inter> E' = {} \<Longrightarrow>  F' \<inter> Fadd = {}" by blast

      have Fadd_subseteq_Eadd: "\<And>Fadd. (Fadd \<inter> E' = {} \<and> Fadd \<subseteq> E) = (Fadd \<subseteq> Eadd)"
        proof(rule iffI, goal_cases)
        case 1 thus ?case using Eadd_prop a2 by blast
        next
        case 2 thus ?case using Eadd_prop a2 \<open>E' \<inter> Eadd = {}\<close> by blast
        qed

      from a4 have "(\<forall>(e1, e2)\<in>F'. \<not> sinvar (add_edge e1 e2 \<lparr>nodes = V, edges = E' - F'\<rparr>) nP)"
        by(simp add: set_offending_flows_def is_offending_flows_min_set_def delete_edges_simp2)
      with add_edge_F have noteval_F: "\<forall>(e1, e2)\<in>F'. \<not> sinvar \<lparr>nodes = V, edges = (E' - F') \<union> {(e1, e2)}\<rparr> nP"
        by fastforce

      (*proof rule that preserves the tuple*)
      have tupleBallI: "\<And>A P. (\<And>e1 e2. (e1, e2)\<in>A \<Longrightarrow> P (e1, e2)) \<Longrightarrow> ALL (e1, e2):A. P (e1, e2)" by force
      have "\<forall>(e1, e2)\<in>F'. \<not> sinvar \<lparr>nodes = V, edges = (E - (F' \<union> Fadd)) \<union> {(e1, e2)}\<rparr> nP"
      proof(rule tupleBallI)
        fix e1 e2
        assume f2: "(e1, e2) \<in> F'"
           with a3 have gFadd1: "\<not> sinvar \<lparr>nodes = V, edges = (E' - (F' \<union> Fadd)) \<union> {(e1, e2)}\<rparr> nP"
           using Fadd_notinE' noteval_F by fastforce

           from a1 FinV1 FinV2 a3 f2 have gFadd2:
             "wf_graph \<lparr>nodes = V, edges = (E - (F' \<union> Fadd)) \<union> {(e1, e2)}\<rparr>"
             by(auto simp add: wf_graph_def)
           from a2 a3 f2 have gFadd3:
                "(E' - (F' \<union> Fadd)) \<union> {(e1, e2)} \<subseteq> (E - (F' \<union> Fadd)) \<union> {(e1, e2)}" by blast

           from mono_sinvar[OF gFadd2 gFadd3] gFadd1
           show "\<not> sinvar \<lparr>nodes = V, edges = (E - (F' \<union> Fadd)) \<union> {(e1, e2)}\<rparr> nP" by blast
       qed
       thus ?thesis
        apply(simp add: delete_edges_simp2 Fadd_notinE' add_edge_def)
        apply(clarify)
        using insert_e1_e2_V by fastforce
    qed

    text\<open>The minimality condition of the offending flows also holds if we increase the graph.\<close>
    corollary minimality_offending_flows_mono_edges_graph:
      "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>;
         E' \<subseteq> E;
         F \<in> set_offending_flows \<lparr>nodes = V, edges = E'\<rparr> nP \<rbrakk> \<Longrightarrow>
      \<forall>(e1, e2)\<in>F. \<not> sinvar (add_edge e1 e2 (delete_edges \<lparr>nodes = V, edges = E \<rparr> F)) nP"
      using minimality_offending_flows_mono_edges_graph_extend[where Fadd="{}", simplified] by presburger

    text\<open>all sets in the set of offending flows are monotonic, hence, for a larger graph, they can be extended to match the smaller graph. I.e. everything is monotonic.\<close>
    theorem mono_extend_set_offending_flows: "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>; E' \<subseteq> E; F' \<in> set_offending_flows \<lparr> nodes = V, edges = E' \<rparr> nP \<rbrakk> \<Longrightarrow>
        \<exists> F \<in> set_offending_flows \<lparr> nodes = V, edges = E \<rparr> nP. F' \<subseteq> F"
      proof -
        fix F'V E E'
        assume a1: "wf_graph \<lparr> nodes = V, edges = E \<rparr>"
        and    a2: "E' \<subseteq> E"
        and    a4: "F' \<in> set_offending_flows \<lparr>nodes = V, edges = E'\<rparr> nP"

        \<comment> \<open>Idea: @{text "F = F' \<union> minimize (E - E')"}\<close>

        have "\<And>f. wf_graph (delete_edges \<lparr>nodes = V, edges = E\<rparr> f)"
        using delete_edges_wf[OF a1] by fast
        hence wf1: "\<And>f. wf_graph \<lparr>nodes = V, edges = E -f\<rparr>"
        by(simp add: delete_edges_simp2)

        obtain Eadd where Eadd_prop: "E' \<union> Eadd = E" and "E' \<inter> Eadd = {}" using a2 by blast

        from a4 have "F' \<subseteq> E'" by(simp add: set_offending_flows_def)

        from wf1 have wf2: "wf_graph \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr>"
          apply(subgoal_tac "E' - F' \<union> Eadd = E - F'")
           apply fastforce
          using Eadd_prop \<open>E' \<inter> Eadd = {}\<close> \<open>F' \<subseteq> E'\<close> by fast

        from a4 have offending_F: "\<not> sinvar \<lparr>nodes = V, edges = E'\<rparr> nP"
          by(simp add: set_offending_flows_def is_offending_flows_min_set_def is_offending_flows_def)
        from this mono_sinvar[OF a1 a2] have
          goal_noteval: "\<not> sinvar \<lparr>nodes = V, edges = E\<rparr> nP" by blast

         from a4 have eval_E_minus_FEadd_simp: "sinvar \<lparr>nodes = V, edges = E' - F'\<rparr> nP"
           by(simp add: set_offending_flows_def is_offending_flows_min_set_def is_offending_flows_def delete_edges_simp2)
        (* moreover have "E - (F' \<union> Eadd) = E' - F'"  using `E' \<inter> Eadd = {}` Eadd_prop by blast
         ultimately have eval_E_minus_FEadd: "sinvar (delete_edges \<lparr>nodes = V, edges = E\<rparr> (F' \<union> Eadd)) nP"
           by(simp add: delete_edges_simp2)*)

        show "\<exists> F \<in> set_offending_flows \<lparr> nodes = V, edges = E \<rparr> nP. F' \<subseteq> F"
        proof(cases "\<not> sinvar \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP")
          assume assumption_new_violation: "\<not> sinvar \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP"
          from a1 have "finite Eadd"
            apply(simp add: wf_graph_def)
            using Eadd_prop wf_graph.finiteE by blast
          from this obtain Eadd_list where Eadd_list_prop: "set Eadd_list = Eadd" and "distinct Eadd_list" by (metis finite_distinct_list)
          from a1 have "finite E'"
            apply(simp add: wf_graph_def)
            using Eadd_prop by blast
          from this obtain E'_list where E'_list_prop: "set E'_list = E'" and "distinct E'_list" by (metis finite_distinct_list)
          from \<open>finite E'\<close> \<open>F' \<subseteq> E'\<close> obtain F'_list where "set F'_list = F'" and "distinct F'_list" by (metis finite_distinct_list rev_finite_subset)

          have "E' - F' \<union> Eadd - Eadd = E' - F'" using Eadd_prop \<open>E' \<inter> Eadd = {}\<close> \<open>F' \<subseteq> E'\<close> by blast
          with assumption_new_violation eval_E_minus_FEadd_simp have
            "is_offending_flows (set (Eadd_list)) \<lparr>nodes = V, edges = (E' - F') \<union> Eadd\<rparr> nP"
            by (simp add: Eadd_list_prop delete_edges_simp2 is_offending_flows_def)
          from minimalize_offending_overapprox_sound[OF wf2 this _ \<open>distinct Eadd_list\<close>] have
            "is_offending_flows_min_set
              (set (minimalize_offending_overapprox Eadd_list []
                 \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP)) \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP"
            by(simp add: Eadd_list_prop)
          with minimalize_offending_overapprox_subseteq_input[of "Eadd_list" "[]" "\<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr>" "nP", simplified Eadd_list_prop]
          obtain Fadd where Fadd_prop: "is_offending_flows_min_set Fadd \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP" and "Fadd \<subseteq> Eadd" by auto

          have graph_edges_simp_helper: "E' - F' \<union> Eadd - Fadd =  E - (F' \<union> Fadd)"
            using \<open>E' \<inter> Eadd = {}\<close> Eadd_prop \<open>F' \<subseteq> E'\<close> by blast

          from Fadd_prop graph_edges_simp_helper have
            goal_eval_Fadd: "sinvar (delete_edges \<lparr>nodes = V, edges = E\<rparr> (F' \<union> Fadd)) nP" and
            pre_goal_minimal_Fadd: "(\<forall>(e1, e2)\<in>Fadd. \<not> sinvar (add_edge e1 e2 (delete_edges \<lparr>nodes = V, edges = E \<rparr> (F' \<union> Fadd))) nP)"
            by(simp add: is_offending_flows_min_set_def is_offending_flows_def delete_edges_simp2)+

          from \<open>E' \<inter> Eadd = {}\<close> \<open>Fadd \<subseteq> Eadd\<close> have "Fadd \<inter> E' = {}" by blast
          from minimality_offending_flows_mono_edges_graph_extend[OF a1 \<open>E' \<subseteq> E\<close> \<open>Fadd \<inter> E' = {}\<close> a4]
          have mono_delete_edges_minimal: "(\<forall>(e1, e2)\<in>F'. \<not> sinvar (add_edge e1 e2 (delete_edges \<lparr>nodes = V, edges = E \<rparr> (F' \<union> Fadd))) nP)" .

          from mono_delete_edges_minimal pre_goal_minimal_Fadd have goal_minimal:
            "\<forall>(e1, e2)\<in>F' \<union> Fadd. \<not> sinvar (add_edge e1 e2 (delete_edges \<lparr>nodes = V, edges = E\<rparr> (F' \<union> Fadd))) nP" by fastforce

           from Eadd_prop \<open>Fadd \<subseteq> Eadd\<close> \<open>F' \<subseteq> E'\<close> have goal_subset: "F' \<subseteq> E \<and> Fadd \<subseteq> E" by blast

          show "\<exists> F \<in> set_offending_flows \<lparr> nodes = V, edges = E \<rparr> nP. F' \<subseteq> F"
              apply(simp add: set_offending_flows_def is_offending_flows_min_set_def is_offending_flows_def)
              apply(rule_tac x="F' \<union> Fadd" in exI)
              apply(simp add: goal_noteval goal_eval_Fadd goal_minimal goal_subset)
             done
      next
          assume "\<not> \<not> sinvar \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP"
          hence assumption_no_new_violation: "sinvar \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP" by simp
          from this  \<open>F' \<subseteq> E'\<close> \<open>E' \<inter> Eadd = {}\<close>  have "sinvar \<lparr>nodes = V, edges = E - F'\<rparr> nP"
            proof(subst Eadd_prop[symmetric])
              assume a1: "F' \<subseteq> E'"
              assume a2: "E' \<inter> Eadd = {}"
              assume a3: "sinvar \<lparr>nodes = V, edges = E' - F' \<union> Eadd\<rparr> nP"
              have "\<And>x\<^sub>1. x\<^sub>1 \<inter> E' - Eadd = x\<^sub>1 \<inter> E'"
                using a2 Un_Diff_Int by auto
              hence "F' - Eadd = F'"
                using a1 by auto
              hence "{} \<union> (Eadd - F') = Eadd"
                using Int_Diff Un_Diff_Int sup_commute by auto
              thus "sinvar \<lparr>nodes = V, edges = E' \<union> Eadd - F'\<rparr> nP"
                using a3 by (metis Un_Diff sup_bot.left_neutral)
            qed
          from this have goal_eval: "sinvar (delete_edges \<lparr>nodes = V, edges = E\<rparr> F') nP"
          by(simp add: delete_edges_simp2)

          from Eadd_prop \<open>F' \<subseteq> E'\<close> have goal_subset: "F' \<subseteq> E" by(blast)

          from minimality_offending_flows_mono_edges_graph[OF a1 a2 a4]
          have goal_minimal: "(\<forall>(e1, e2)\<in>F'. \<not> sinvar (add_edge e1 e2 (delete_edges \<lparr>nodes = V, edges = E \<rparr> F')) nP)" .

          show "\<exists> F \<in> set_offending_flows \<lparr> nodes = V, edges = E \<rparr> nP. F' \<subseteq> F"
              apply(simp add: set_offending_flows_def is_offending_flows_min_set_def is_offending_flows_def)
              apply(rule_tac x="F'" in exI)
              apply(simp add: goal_noteval goal_subset goal_minimal goal_eval)
            done
         qed
    qed

    text\<open>The offending flows are monotonic.\<close>
    corollary offending_flows_union_mono: "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>; E' \<subseteq> E \<rbrakk> \<Longrightarrow>
      \<Union> (set_offending_flows \<lparr> nodes = V, edges = E' \<rparr> nP) \<subseteq> \<Union> (set_offending_flows \<lparr> nodes = V, edges = E \<rparr> nP)"
      apply(clarify)
      apply(drule(2) mono_extend_set_offending_flows)
      by blast

   (* I guess set_offending_flows = {{e}} does not hold. Consider the Dependability invariant:
      having a wf graph.
      Add an edge s.t. a dependability violation occurs.
      The offending flows now contains the new edge ans all edges on the path from the node with the violation to the end of the new edge. *)
   lemma set_offending_flows_insert_contains_new:
   "\<lbrakk> wf_graph \<lparr> nodes = V, edges = insert e E \<rparr>; set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP = {}; set_offending_flows \<lparr>nodes = V, edges = insert e E\<rparr> nP \<noteq> {} \<rbrakk> \<Longrightarrow>
      {e} \<in> set_offending_flows \<lparr>nodes = V, edges = insert e E\<rparr> nP"
     proof -
       assume wfG: "wf_graph \<lparr> nodes = V, edges = insert e E \<rparr>"
       and    a1: "set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP = {}"
       and    a2: "set_offending_flows \<lparr>nodes = V, edges = insert e E\<rparr> nP \<noteq> {}"

       from a1 a2 have "e \<notin> E" by (metis insert_absorb)

       from a1 have a1': "\<forall>F \<subseteq> E. \<not> is_offending_flows_min_set F \<lparr>nodes = V, edges = E\<rparr> nP"
         by(simp add: set_offending_flows_def)
       from a2 have a2': "\<exists>F \<subseteq> insert e E. is_offending_flows_min_set F \<lparr>nodes = V, edges = insert e E\<rparr> nP"
        by(simp add: set_offending_flows_def)

       from wfG have wfG': "wf_graph \<lparr> nodes = V, edges = E \<rparr>" by(simp add:wf_graph_def)

       from a1 defined_offending[OF wfG'] have evalG: "sinvar \<lparr>nodes = V, edges = E \<rparr> nP" by blast
       from sinvar_monoI[unfolded sinvar_mono_def] wfG' this
       have goal_eval: "sinvar \<lparr>nodes = V, edges = E - {e}\<rparr> nP" by (metis Diff_subset)

       from sinvar_no_offending a2 have goal_not_eval: "\<not> sinvar \<lparr>nodes = V, edges = insert e E\<rparr> nP" by blast

       obtain a b where e: "e = (a,b)" by (cases e) blast
       with wfG have insert_e_V: "insert a (insert b V) = V" by(auto simp add: wf_graph_def)

       from a1' a2' have min_set_e: "is_offending_flows_min_set {e} \<lparr>nodes = V, edges = insert e E\<rparr> nP"
        apply(simp add: is_offending_flows_min_set_def is_offending_flows_def add_edge_def delete_edges_simp2 goal_not_eval goal_eval)
        using goal_not_eval by(simp add: e insert_e_V)

       thus "{e} \<in> set_offending_flows \<lparr>nodes = V, edges = insert e E\<rparr> nP"
        by(simp add: set_offending_flows_def)
    qed

end

    value "Pow {1::int, 2, 3} \<union> {{8}, {9}}"
    value "\<Union> x\<in>Pow {1::int, 2, 3}. \<Union> y \<in> {{8::int}, {9}}. {x \<union> y}"

    (*similar to \<times>_def*)
    \<comment> \<open>combines powerset of A with B\<close>
    definition pow_combine :: "'x set \<Rightarrow> 'x set set \<Rightarrow> 'x set set" where
      "pow_combine A B \<equiv> (\<Union> X \<in> Pow A. \<Union> Y \<in> B. {X \<union> Y}) \<union> Pow A"

    value "pow_combine {1::int,2} {{5::int, 6}, {8}}"
    value "pow_combine {1::int,2} {}"

    lemma pow_combine_mono:
    fixes S :: "'a set set"
    and   X :: "'a set"
    and   Y :: "'a set"
    assumes a1: "\<forall> F \<in> S. F \<subseteq> X"
    shows "\<forall> F \<in> pow_combine Y S. F \<subseteq> Y \<union> X"
    apply(simp add: pow_combine_def)
    apply(rule)
    apply(simp)
    by (metis Pow_iff assms sup.coboundedI1 sup.orderE sup.orderI sup_assoc)

    lemma "S \<subseteq> pow_combine X S" by(auto simp add: pow_combine_def)
    lemma "Pow X \<subseteq> pow_combine X S" by(auto simp add: pow_combine_def)

    lemma rule_pow_combine_fixfst: "B \<subseteq> C \<Longrightarrow> pow_combine A B \<subseteq> pow_combine A C"
      by(auto simp add: pow_combine_def)

    value "pow_combine {1::int,2} {{5::int, 6}, {1}} \<subseteq> pow_combine {1::int,2} {{5::int, 6}, {8}}"

    lemma rule_pow_combine_fixfst_Union: "\<Union> B \<subseteq> \<Union> C \<Longrightarrow> \<Union> (pow_combine A B) \<subseteq> \<Union> (pow_combine A C)"
      apply(rule)
      apply(fastforce simp: pow_combine_def)
    done

    (*does the following hold?
      (set_offending_flows \<lparr>nodes = V, edges = E \<union> X\<rparr> nP) \<subseteq> pow_combine X (set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP)

      I guess not:  ^D  I'm convinced this does not hold!
      Graph:   A -> B -> C
      E = A -> B
      E \<union> X = A -> B -> C

      model is A and C are interfering

      set_offending_flows(E \<union> X) = {{(A,B)}, {B,C}}
       set_offending_flows(E) = {}
      pow_combine X set_offending_flows(E) = {{}, {C}}

      the {(A,B)} is the problem here such that subset does not hold.

      It holds if
        \<forall> F \<in> (set_offending_flows \<lparr>nodes = V, edges = E \<union> X\<rparr> nP). F \<subseteq> X
      however, then (set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP) = {} which renders the whole statement useless
     *)

  context SecurityInvariant_preliminaries
  begin

    lemma offending_partition_subset_empty:
    assumes a1:"\<forall> F \<in> (set_offending_flows \<lparr>nodes = V, edges = E \<union> X\<rparr> nP). F \<subseteq> X"
    and wfGEX: "wf_graph \<lparr>nodes = V, edges = E \<union> X\<rparr>"
    and disj: "E \<inter> X = {}"
    shows "(set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP) = {}"
    proof(rule ccontr)
      assume c: "set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP \<noteq> {}"
      from this obtain F' where F'_prop: "F' \<in> set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP" by blast
      from F'_prop have "F' \<subseteq> E" using set_offending_flows_def by simp
      from mono_extend_set_offending_flows[OF wfGEX _ F'_prop] have
        "\<exists>F\<in>set_offending_flows \<lparr>nodes = V, edges = E \<union> X\<rparr> nP. F' \<subseteq> F" by blast
      from this a1 have "F' \<subseteq> X" by fast
      from F'_prop have "{} \<noteq> F'" by (metis empty_offending_contra)
      from \<open>F' \<subseteq> X\<close> \<open>F' \<subseteq> E\<close> disj \<open>{} \<noteq> F'\<close>
      show "False" by blast
    qed

    corollary partitioned_offending_subseteq_pow_combine:
    assumes wfGEX: "wf_graph \<lparr>nodes = V, edges = E \<union> X\<rparr>"
    and disj: "E \<inter> X = {}"
    and partitioned_offending: "\<forall> F \<in> (set_offending_flows \<lparr>nodes = V, edges = E \<union> X\<rparr> nP). F \<subseteq> X" (*offending does not contain E*)
    shows "(set_offending_flows \<lparr>nodes = V, edges = E \<union> X\<rparr> nP) \<subseteq> pow_combine X (set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP)"
    apply(subst offending_partition_subset_empty[OF partitioned_offending wfGEX disj])
    apply(simp add: pow_combine_def)
    apply(rule)
    apply(simp)
    using partitioned_offending by simp
  end

  context SecurityInvariant_preliminaries
  begin

    text\<open>Knowing that the \<open>\<Union> offending is \<subseteq> X\<close>, removing something from the graphs's edges,
           it also disappears from the offending flows.\<close>
    lemma Un_set_offending_flows_bound_minus:
    assumes wfG: "wf_graph \<lparr> nodes = V, edges = E \<rparr>"
    and     Foffending: "\<Union>(set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP) \<subseteq> X"
    shows   "\<Union>(set_offending_flows \<lparr>nodes = V, edges = E - {f}\<rparr> nP) \<subseteq> X - {f}"
    proof -
      from wfG have wfG': "wf_graph \<lparr> nodes = V, edges = E - {f} \<rparr>"
        by(auto simp add: wf_graph_def finite_subset)

      from offending_flows_union_mono[OF wfG, where E'="E - {f}"] have
        "\<Union>(set_offending_flows \<lparr>nodes = V, edges = E - {f}\<rparr> nP) - {f} \<subseteq> \<Union>(set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP) - {f}" by blast
      also have
        "\<Union>(set_offending_flows \<lparr>nodes = V, edges = E - {f}\<rparr> nP) \<subseteq> \<Union>(set_offending_flows \<lparr>nodes = V, edges = E - {f}\<rparr> nP) - {f}"
        apply(simp add: set_offending_flows_simp[OF wfG']) by blast
      ultimately have Un_set_offending_flows_minus:
        "\<Union>(set_offending_flows \<lparr>nodes = V, edges = E - {f}\<rparr> nP) \<subseteq> \<Union>(set_offending_flows \<lparr>nodes = V, edges = E \<rparr> nP) - {f}"
        by blast

      from Foffending Un_set_offending_flows_minus
      show ?thesis by blast
    qed

  text\<open>
    If the offending flows are bound by some @{term X},
    the we can remove all finite @{term "E'"}from the graph's edges
    and the offending flows from the smaller graph are bound by @{term "X - E'"}.
\<close>
    lemma Un_set_offending_flows_bound_minus_subseteq:
    assumes wfG: "wf_graph \<lparr> nodes = V, edges = E \<rparr>"
    and     Foffending: "\<Union> (set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP) \<subseteq> X"
    shows   "\<Union> (set_offending_flows \<lparr>nodes = V, edges = E - E'\<rparr> nP) \<subseteq> X - E'"
    proof -
      from wfG have wfG': "wf_graph \<lparr> nodes = V, edges = E - E' \<rparr>"
        by(auto simp add: wf_graph_def finite_subset)

      from offending_flows_union_mono[OF wfG, where E'="E - E'"] have
        "\<Union>(set_offending_flows \<lparr>nodes = V, edges = E - E'\<rparr> nP) - E' \<subseteq> \<Union>(set_offending_flows \<lparr>nodes = V, edges = E\<rparr> nP) - E'" by blast
      also have
        "\<Union>(set_offending_flows \<lparr>nodes = V, edges = E - E'\<rparr> nP) \<subseteq> \<Union>(set_offending_flows \<lparr>nodes = V, edges = E - E'\<rparr> nP) - E'"
        apply(simp add: set_offending_flows_simp[OF wfG']) by blast
      ultimately have Un_set_offending_flows_minus:
        "\<Union> (set_offending_flows \<lparr>nodes = V, edges = E - E'\<rparr> nP) \<subseteq> \<Union> (set_offending_flows \<lparr>nodes = V, edges = E \<rparr> nP) - E'"
        by blast

      from Foffending Un_set_offending_flows_minus
      show ?thesis by blast
    qed

  corollary Un_set_offending_flows_bound_minus_subseteq':
    "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>;
    \<Union> (set_offending_flows \<lparr> nodes = V, edges = E \<rparr> nP) \<subseteq> X \<rbrakk> \<Longrightarrow>
    \<Union> (set_offending_flows \<lparr> nodes = V, edges = E - E' \<rparr> nP) \<subseteq> X - E'"
    apply(drule(1) Un_set_offending_flows_bound_minus_subseteq) by blast

  end

end


header {* \isaheader{Breadth First Search}*}
theory Breadth_First_Search
imports "../Refine_Monadic"
begin

text {*
  This is a slightly modified version of Task~5 of our submission to
  the VSTTE 2011 verification competition
  (@{url "https://sites.google.com/site/vstte2012/compet"}). The task was to
  formalize a breadth-first-search algorithm.
*}

text {*
  With Isabelle's locale-construct, we put ourselves into a context where
  the @{text "succ"}-function is fixed.
  We assume finitely branching graphs here, as our
  foreach-construct is only defined for finite sets.
*}
locale Graph =
  fixes succ :: "'vertex \<Rightarrow> 'vertex set"
  assumes [simp, intro!]: "finite (succ v)"
begin

  subsection {* Distances in a Graph *}
  text {*
    We start over by defining the basic notions of paths and shortest paths.
    *}

  text {* A path is expressed by the @{text "dist"}-predicate. Intuitively,
    @{text "dist v d v'"} means that there is a path of length @{text "d"}
    between @{text "v"} and @{text "v'"}.

    The definition of the @{text "dist"}-predicate is done inductively, i.e.,
    as the least solution of the following constraints:
    *}
  inductive dist :: "'vertex \<Rightarrow> nat \<Rightarrow> 'vertex \<Rightarrow> bool" where
    dist_z: "dist v 0 v" |
    dist_suc: "\<lbrakk>dist v d vh; v' \<in> succ vh \<rbrakk> \<Longrightarrow> dist v (Suc d) v'"

  text {*
    Next, we define a predicate that expresses that the shortest path between
    @{text "v"} and @{text "v'"} has length @{text "d"}.
    This is the case if there is a path of length @{text "d"}, but there
    is no shorter path.
    *}
  definition "min_dist v v' = (LEAST d. dist v d v')"
  definition "conn v v' = (\<exists>d. dist v d v')"

  subsubsection {* Properties *}
  text {*
    In this subsection, we prove some properties of paths.
    *}

  lemma
    shows connI[intro]: "dist v d v' \<Longrightarrow> conn v v'"
      and connI_id[intro]: "conn v v"
      and connI_succ[intro]: "conn v v' \<Longrightarrow> v'' \<in> succ v' \<Longrightarrow> conn v v''"
    by (auto simp: conn_def intro: dist_suc dist_z)

  lemma min_distI2:
    "\<lbrakk> conn v v' ; \<And>d. \<lbrakk> dist v d v'; \<And>d'. dist v d' v' \<Longrightarrow> d \<le> d' \<rbrakk> \<Longrightarrow> Q d \<rbrakk>
      \<Longrightarrow> Q (min_dist v v')"
    unfolding min_dist_def
    by (rule LeastI2_wellorder[where Q=Q and a="SOME d. dist v d v'"])
       (auto simp: conn_def intro: someI)

  lemma min_distI_eq:
    "\<lbrakk> dist v d v'; \<And>d'. dist v d' v' \<Longrightarrow> d \<le> d' \<rbrakk> \<Longrightarrow> min_dist v v' = d"
    by (force intro: min_distI2 simp: conn_def)

  text {* Two nodes are connected by a path of length @{text "0"},
    iff they are equal. *}
  lemma dist_z_iff[simp]: "dist v 0 v' \<longleftrightarrow> v'=v"
    by (auto elim: dist.cases intro: dist.intros)

  text {* The same holds for @{text "min_dist"}, i.e.,
    the shortest path between two nodes has length @{text "0"},
    iff these nodes are equal. *}
  lemma min_dist_z[simp]: "min_dist v v = 0"
    by (rule min_distI2) (auto intro: dist_z)

  text {* We also provide introduction and destruction rules for the
    pattern @{text "min_dist v v' = Suc d"}.
    *}

  lemma min_dist_succ:
    "\<lbrakk> conn v v'; v'' \<in> succ v' \<rbrakk> \<Longrightarrow> min_dist v v'' \<le> Suc (min_dist v v') "
    by (rule min_distI2[where v'=v'])
       (auto elim: dist.cases intro!: min_dist_minD dist_suc)

  lemma min_dist_suc:
    assumes c: "conn v v'" "min_dist v v' = Suc d"
    shows "\<exists>v''. conn v v'' \<and> v' \<in> succ v'' \<and> min_dist v v'' = d"
  proof -
    from min_dist_is_dist[OF c(1)]
    have "min_dist v v' = Suc d \<longrightarrow> ?thesis"
    proof cases
      case (dist_suc d' v'') then show ?thesis
        using min_dist_succ[of v v'' v'] min_dist_minD[of v d v'']
        by (auto simp: connI)
    qed simp
    with c show ?thesis by simp
  qed

  text {*
    If there is a node with a shortest path of length @{text "d"},
    then, for any @{text "d'<d"}, there is also a node with a shortest path
    of length @{text "d'"}.
    *}
  lemma min_dist_less:
    assumes "conn src v" "min_dist src v = d" and "d' < d"
    shows "\<exists>v'. conn src v' \<and> min_dist src v' = d'"
    using assms
  proof (induct d arbitrary: v)
    case (Suc d) with min_dist_suc[of src v] show ?case
      by (cases "d' = d") auto
  qed auto

  text {*
    Lemma @{text "min_dist_less"} can be weakened to @{text "d'\<le>d"}.
    *}

  corollary min_dist_le:
    assumes c: "conn src v" and d': "d' \<le> min_dist src v"
    shows "\<exists>v'. conn src v' \<and> min_dist src v' = d'"
    using min_dist_less[OF c, of "min_dist src v" d'] d' c
    by (auto simp: le_less)

  subsection {* Invariants *}
  text {*
    In our framework, it is convenient to annotate the invariants and
    auxiliary assertions into the program. Thus, we have to define the
    invariants first.
    *}

  text {*
    The invariant for the outer loop is split into two parts:
    The first part already holds before
    the @{text "if C={}"} check, the second part only holds again
    at the end of the loop body.
    *}

  text {*
    The first part of the invariant, @{text "bfs_invar'"},
    intuitively states the following:
    If the loop is not {\em break}ed, then we have:
    \begin{itemize}
      \item The next-node set @{text "N"} is a subset of @{text "V"}, and
        the destination node is not contained into @{text "V-(C\<union>N)"},
      \item all nodes in the current-node set @{text "C"} have a shortest
        path of length @{text "d"},
      \item all nodes in the next-node set @{text "N"} have a shortest path
        of length @{text "d+1"},
      \item all nodes in the visited set @{text "V"} have a shortest path
        of length at most @{text "d+1"},
      \item all nodes with a path shorter than @{text "d"} are already in
        @{text "V"}, and
      \item all nodes with a shortest path of length @{text "d+1"} are either
        in the next-node set @{text "N"}, or they are undiscovered successors
        of a node in the current-node set.
    \end{itemize}

    If the loop has been {\em break}ed, @{text "d"} is the distance of the
    shortest path between @{text "src"} and @{text "dst"}.
    *}

  definition "bfs_invar' src dst \<sigma> \<equiv> let (f,V,C,N,d)=\<sigma> in
    (\<not>f \<longrightarrow> (
      N \<subseteq> V \<and> dst \<notin> V - (C \<union> N) \<and>
      (\<forall>v\<in>C. conn src v \<and> min_dist src v = d) \<and>
      (\<forall>v\<in>N. conn src v \<and> min_dist src v = Suc d) \<and>
      (\<forall>v\<in>V. conn src v \<and> min_dist src v \<le> Suc d) \<and>
      (\<forall>v. conn src v \<and> min_dist src v \<le> d \<longrightarrow> v \<in> V) \<and>
      (\<forall>v. conn src v \<and> min_dist src v = Suc d \<longrightarrow> v \<in> N \<union> ((\<Union>(succ`C)) - V))
    )) \<and> (
    f \<longrightarrow> conn src dst \<and> min_dist src dst = d
    )"

  text {*
    The second part of the invariant, @{text "empty_assm"}, just states
    that @{text "C"} can only be empty if @{text "N"} is also empty.
    *}
  definition "empty_assm \<sigma> \<equiv> let (f,V,C,N,d)=\<sigma> in
    C={} \<longrightarrow> N={}"

  text {*
    Finally, we define the invariant of the outer loop, @{text "bfs_invar"},
    as the conjunction of both parts:
    *}
  definition "bfs_invar src dst \<sigma> \<equiv> bfs_invar' src dst \<sigma> \<and>
    empty_assm \<sigma>"

  text {*
    The invariant of the inner foreach-loop states that
    the successors that have already been processed (@{text "succ v - it"}),
    have been added to @{text "V"} and have also been added to
    @{text "N'"} if they are not in @{text "V"}.
    *}
  definition "FE_invar V N v it \<sigma> \<equiv> let (V',N')=\<sigma> in
    V'=V \<union> (succ v - it) \<and>
    N'=N \<union> ((succ v - it) - V)"

  subsection {* Algorithm *}
  text {*
    The following algorithm is a straightforward transcription of the
    algorithm given in the assignment to the monadic style featured by our
    framework.
    We briefly explain the (mainly syntactic) differences:
    \begin{itemize}
      \item The initialization of the variables occur after the loop in
          our formulation. This is just a syntactic difference, as our loop
          construct has the form @{text "WHILEI I c f \<sigma>\<^sub>0"}, where @{text "\<sigma>\<^sub>0"}
          is the initial state, and @{text "I"} is the loop invariant;
      \item We translated the textual specification
        {\em remove one vertex @{text "v"} from @{text "C"}} as accurately as
        possible: The statement @{text "v \<leftarrow> SPEC (\<lambda>v. v\<in>C)"}
        nondeterministically assigns a node from @{text "C"} to @{text "v"},
        that is then removed in the next statement;
      \item In our monad, we have no notion of loop-breaking (yet). Hence we
        added an additional boolean variable @{text "f"} that indicates that
        the loop shall terminate. The @{text "RETURN"}-statements used in our
        program are the return-operator of the monad, and must not be mixed up
        with the return-statement given in the original program, that is
        modeled by breaking the loop. The if-statement after the loop takes
        care to return the right value;
      \item We added an else-branch to the if-statement that checks
        whether we reached the destination node;
      \item We added an assertion of the first part of the invariant to the
        program text, moreover, we annotated invariants at the loops.
        We also added an assertion @{text "w\<notin>N"} into the inner loop. This
        is merely an optimization, that will allow us to implement the
        insert operation more efficiently;
      \item Each conditional branch in the loop body ends with a
        @{text "RETURN"}-statement. This is required by the monadic style;
      \item Failure is modeled by an option-datatype. The result
        @{text "Some d"} means that the integer @{text "d"} is returned,
        the result @{text "None"} means that a failure is returned.
    \end{itemize}
    *}

  text_raw {* \clearpage *}

  definition bfs :: "'vertex \<Rightarrow> 'vertex \<Rightarrow>
    (nat option nres)"
    where "bfs src dst \<equiv> do {
    (f,_,_,_,d) \<leftarrow> WHILEI (bfs_invar src dst) (\<lambda>(f,V,C,N,d). f=False \<and> C\<noteq>{})
      (\<lambda>(f,V,C,N,d). do {
        v \<leftarrow> SPEC (\<lambda>v. v\<in>C); let C = C-{v};
        if v=dst then RETURN (True,{},{},{},d)
        else do {
          (V,N) \<leftarrow> FOREACHi (FE_invar V N v) (succ v) (\<lambda>w (V,N).
            if (w\<notin>V) then do {
              ASSERT (w\<notin>N);
              RETURN (insert w V, insert w N)
            } else RETURN (V,N)
          ) (V,N);
          ASSERT (bfs_invar' src dst (f,V,C,N,d));
          if (C={}) then do {
            let C=N;
            let N={};
            let d=d+1;
            RETURN (f,V,C,N,d)
          } else RETURN (f,V,C,N,d)
        }
      })
      (False,{src},{src},{},0::nat);
    if f then RETURN (Some d) else RETURN None
    }"

  subsection "Verification Tasks"
  text {*
    In order to make the proof more readable, we have extracted the
    difficult verification conditions and proved them in separate lemmas.
    The other verification conditions are proved automatically by Isabelle/HOL
    during the proof of the main theorem.

    Due to the timing constraints of the competition, the verification
    conditions are mostly proved in Isabelle's apply-style, that is faster
    to write for the experienced user, but harder to read by a human.

    Exemplarily, we formulated the last proof in the proof language
    {\em Isar}, that allows one to write human-readable proofs and verify
    them with Isabelle/HOL.
    *}

  text {*
    The first part of the invariant is preserved if we take a node from
    @{text "C"}, and add its successors that are not in @{text "V"} to
    @{text "N"}.
    This is the verification condition for the assertion after the
    foreach-loop.
    *}
  lemma invar_succ_step:
    assumes "bfs_invar' src dst (False, V, C, N, d)"
    assumes "v\<in>C"
    assumes "v\<noteq>dst"
    shows "bfs_invar' src dst
            (False, V \<union> succ v, C - {v}, N \<union> (succ v - V), d)"
    using assms
  proof (simp (no_asm_use) add: bfs_invar'_def, intro conjI)
    case goal6 then show ?case
      by (metis Un_iff Diff_iff connI_succ le_SucE min_dist_succ)
  next
    case goal7 then show ?case
      by (metis Un_iff connI_succ min_dist_succ)
  qed blast+

  text {*
    The first part of the invariant is preserved if the
    @{text "if C={}"}-statement is executed.
    This is the verification condition for the
    loop-invariant. Note that preservation of the second part of the
    invariant is proven easily inside the main proof.
    *}
  lemma invar_empty_step:
    assumes "bfs_invar' src dst (False, V, {}, N, d)"
    shows "bfs_invar' src dst (False, V, N, {}, Suc d)"
    using assms
  proof (simp (no_asm_use) add: bfs_invar'_def, intro conjI impI allI)
    case goal3 then show ?case
      by (metis le_SucI)
  next
    case goal4 then show ?case
      by (metis le_SucE subsetD)
  next
    case (goal5 v) then show ?case
      using min_dist_suc[of src v "Suc d"] by metis
  next
    case goal6 then show ?case
      by (metis Suc_n_not_le_n)
  qed blast+

  text {* The invariant holds initially. *}
  lemma invar_init: "bfs_invar src dst (False, {src}, {src}, {}, 0)"
    by (auto simp: bfs_invar_def bfs_invar'_def empty_assm_def)
       (metis min_dist_suc min_dist_z_iff)

  text {* The invariant is preserved if we break the loop. *}
  lemma invar_break:
    assumes "bfs_invar src dst (False, V, C, N, d)"
    assumes "dst\<in>C"
    shows "bfs_invar src dst (True, {}, {}, {}, d)"
    using assms unfolding bfs_invar_def bfs_invar'_def empty_assm_def
    by auto

  text {* If we have {\em break}ed the loop, the invariant implies
    that we, indeed, returned the shortest path. *}
  lemma invar_final_succeed:
    assumes "bfs_invar' src dst (True, V, C, N, d)"
    shows "min_dist src dst = d"
    using assms unfolding bfs_invar'_def
    by auto

  text {* If the loop terminated normally, there is no path between
    @{text "src"} and @{text "dst"}.

    The lemma is formulated as deriving a contradiction from the fact
    that there is a path and the loop terminated normally.

    Note the proof language {\em Isar} that was used here.
    It allows one to write human-readable proofs in a theorem prover.
    *}
  lemma invar_final_fail:
    assumes C: "conn src dst" -- {* There is a path between
      @{text "src"} and @{text "dst"}. *}
    assumes INV: "bfs_invar' src dst (False, V, {}, {}, d)"
    shows False
  proof -
    txt {* We make a case-distinction whether @{text "d'\<le>d"}: *}
    have "min_dist src dst \<le> d \<or> d + 1 \<le> min_dist src dst" by auto
    moreover {
      txt {* Due to the invariant, any node with a path of
        length at most @{text "d"} is contained in @{text "V"}
        *}
      from INV have "\<forall>v. conn src v \<and> min_dist src v \<le> d \<longrightarrow> v\<in>V"
        unfolding bfs_invar'_def by auto
      moreover
      txt {* This applies in the first case, hence we obtain that
        @{text "dst\<in>V"} *}
      assume A: "min_dist src dst \<le> d"
      moreover from C have "dist src (min_dist src dst) dst"
        by (blast intro: min_dist_is_dist)
      ultimately have "dst\<in>V" by blast
      txt {* However, as @{text "C"} and @{text "N"} are empty, the invariant
        also implies that @{text "dst"} is not in @{text "V"}: *}
      moreover from INV have "dst\<notin>V" unfolding bfs_invar'_def by auto
      txt {* This yields a contradiction: *}
      ultimately have False by blast
    } moreover {
      txt {* In the case @{text "d+1 \<le> d'"}, we also obtain a node
        that has a shortest path of length @{text "d+1"}: *}
      assume "d+1 \<le> min_dist src dst"
      with min_dist_le[OF C] obtain v' where
        "conn src v'" "min_dist src v' = d + 1"
        by auto
      txt {* However, the invariant states that such nodes are either in
        @{text "N"} or are successors of @{text "C"}. As @{text "N"}
        and @{text "C"} are both empty, we again get a contradiction. *}
      with INV have False unfolding bfs_invar'_def by auto
    } ultimately show ?thesis by blast
  qed

  text {*
    Finally, we prove our algorithm correct:
    The following theorem solves both verification tasks.

    Note that a proposition of the form @{text "S \<sqsubseteq> SPEC \<Phi>"} states partial
    correctness in our framework, i.e., @{text "S"} refines the
    specification @{text "\<Phi>"}.

    The actual specification that we prove here
    precisely reflects the two verification tasks: {\em If the algorithm fails,
    there is no path between @{text "src"} and @{text "dst"}, otherwise
    it returns the length of the shortest path.}

    The proof of this theorem first applies the verification condition
    generator (@{text "apply (intro refine_vcg)"}), and then uses the
    lemmas proved beforehand to discharge the verification conditions.
    During the @{text "auto"}-methods, some trivial verification conditions,
    e.g., those concerning the invariant of the inner loop, are discharged
    automatically.
    During the proof, we gradually unfold the definition of the loop
    invariant.
    *}
  definition "bfs_spec src dst \<equiv> SPEC (
    \<lambda>r. case r of None \<Rightarrow> \<not> conn src dst
              | Some d \<Rightarrow> conn src dst \<and> min_dist src dst = d)"
  theorem bfs_correct: "bfs src dst \<le> bfs_spec src dst"
    unfolding bfs_def bfs_spec_def
    apply (intro refine_vcg)

    unfolding FE_invar_def
    apply (auto simp:
      intro: invar_init invar_break )

    unfolding bfs_invar_def
    apply (auto simp:
      intro: invar_succ_step invar_empty_step invar_final_succeed)

    unfolding empty_assm_def
    apply (auto intro: invar_final_fail)

    unfolding bfs_invar'_def
    apply auto
    done

end

end


theory Jech imports ZF begin
context
  fixes S
  fixes W defines W_def : "W == {x∈S. x∉x}"
begin

lemma ex_1_2' : " ¬ ( Pow(S) ⊆ S )"
  apply (rule notI)
  apply (rule case_split[where P="W∈W"])
  apply (rule notE[where P="W∈W"])
    apply (rule CollectD2[where A=S])
    apply (fold W_def)
    apply assumption
   apply assumption
  apply (rule notE[where P="W∈W"])
   apply assumption
  apply (unfold W_def)
   apply (rule CollectI)
   apply (fold W_def)
   prefer 2
  apply assumption
  (*subgoal*)
   apply (unfold subset_def)
   apply (unfold Ball_def)
    apply (rule mp[where P="W∈Pow(S)"])
     apply (rule spec[where x=W])
     apply assumption
    apply (rule PowI)
    apply (unfold W_def)
    apply (unfold subset_def)
    apply (unfold Ball_def)
    apply (rule allI)
    apply (rule impI)
    apply (rule CollectD1)
    apply assumption
  done
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_regexp_RecEps
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise Eps s) =
      (case s of
        nil2 => True
        | cons2 x y => False))"
  oops

end


\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Set-Theoretic Dependent Pair Type (\<Sum>-type)\<close>
theory TSPairs
  imports Sets
begin

definition [typedef]: "Dep_Pair A B \<equiv> type (\<lambda>p. (\<exists>x : A. \<exists>y : B x. p = \<langle>x, y\<rangle>))"

bundle isa_set_dependent_pairs_syntax
begin
syntax
  "_Dep_Pair" :: \<open>[pttrn, set type, set \<Rightarrow> set type] \<Rightarrow> set\<close> ("\<Sum>_ : _./ _" [0, 0, 100])
end
bundle no_isa_set_dependent_pairs_syntax
begin
no_syntax
  "_Dep_Pair" :: \<open>[pttrn, set type, set \<Rightarrow> set type] \<Rightarrow> set\<close> ("\<Sum>_ : _./ _" [0, 0, 100])
end
unbundle isa_set_dependent_pairs_syntax

translations
  "\<Sum>x : A. B" \<rightleftharpoons> "CONST Dep_Pair A (\<lambda>x. B)"

abbreviation "Pair A B \<equiv> \<Sum>_ : A. B"

bundle isa_set_pairs_syntax begin notation Pair (infixl "\<times>" 80) end
bundle no_isa_set_pairs_syntax begin no_notation Pair (infixl "\<times>" 80) end
unbundle isa_set_pairs_syntax

lemma mem_dep_pairs_iff_Dep_Pair:
  "p \<in> (\<Sum>x \<in> A. (B x)) \<longleftrightarrow> p : \<Sum>x : Element A. (Element (B x))"
  by unfold_types auto

soft_type_translation
  "p \<in> \<Sum>x \<in> A. (B x)" \<rightleftharpoons> "p : \<Sum>x : Element A. (Element (B x))"
  using mem_dep_pairs_iff_Dep_Pair by auto

(* TODO: this translation should be automatic whenever it is needed *)
lemma Element_dep_pairs_iff_Dep_Pair:
  "p : Element (\<Sum>x \<in> A. (B x)) \<longleftrightarrow> p : \<Sum>x : Element A. (Element (B x))"
  using mem_dep_pairs_iff_Dep_Pair by (auto iff: mem_iff_Element)

lemma pair_type [type]: "pair : (x : A) \<Rightarrow> B x \<Rightarrow> \<Sum>x : A. (B x)"
  by unfold_types auto

lemma Dep_PairE [elim!]:
  assumes "p : \<Sum>x : A. (B x)"
  obtains x y where "x : A" "y : B x" "p = \<langle>x, y\<rangle>"
  using assms unfolding Dep_Pair_def meaning_of_type by auto

lemma Dep_Pair_covariant_fst:
  "p : \<Sum>x : A. (B x) \<Longrightarrow> (\<And>x. x : A \<Longrightarrow> x : A') \<Longrightarrow> p : \<Sum>x : A'. (B x)"
  by auto

lemma Dep_Pair_covariant_snd:
  assumes "p : \<Sum>x : A. (B x)"
  and "\<And>x y. x : A \<Longrightarrow> y : B x \<Longrightarrow> p = \<langle>x, y\<rangle> \<Longrightarrow> y : B' x"
  shows "p : \<Sum>x : A. (B' x)"
  using assms by force

lemma
  fst_type [type]: "fst : (\<Sum>x : A. (B x)) \<Rightarrow> A" and
  snd_type [type]: "snd : (p : \<Sum>x : A. (B x)) \<Rightarrow> B (fst p)"
  by unfold_types auto

lemma uncurry_type [type]:
  "uncurry : ((x : A) \<Rightarrow> (y : B x) \<Rightarrow> C \<langle>x, y\<rangle>) \<Rightarrow> (p : \<Sum>x : A. (B x)) \<Rightarrow> C p"
  unfolding uncurry_def by unfold_types auto

(*TODO: if f is a lambda abstraction, the derivator must use backward_derive
rules to prove its type before being able to apply it to uncurry_type together
with Dep_fun_typeE; so we need to create this backward_derive rule to guide
the derivator*)
lemma uncurry_app_type [backward_derive]:
  assumes "f : (a : A) \<Rightarrow> (b : B a) \<Rightarrow> C \<langle>a, b\<rangle>"
  shows "uncurry f : (p : \<Sum>x : A. (B x)) \<Rightarrow> C p"
  by discharge_types

lemma pair_Dep_Pair_iff [iff]: "\<langle>x, y\<rangle> : \<Sum>x : A. (B x) \<longleftrightarrow> x : A \<and> y : B x"
  by auto

lemma fst_type_if_Dep_Pair: "\<langle>x, y\<rangle> : \<Sum>x : A. (B x) \<Longrightarrow> x : A"
  using pair_Dep_Pair_iff by simp

lemma snd_type_if_Dep_Pair: "\<langle>x, y\<rangle> : \<Sum>x : A. (B x) \<Longrightarrow> y : B x"
  using pair_Dep_Pair_iff by simp

lemma Dep_Pair_cong [cong]:
  assumes "\<And>x. x : A \<longleftrightarrow> x : A'"
  and "\<And>x y. x : A' \<Longrightarrow> y : B x \<longleftrightarrow> y : B' x"
  shows "(p : \<Sum>x : A. (B x)) \<longleftrightarrow> (p : \<Sum>x : A'. (B' x))"
proof
  assume "p : \<Sum>x : A'. (B' x)"
  then obtain x y where "x : A'" "y : B' x" "p = \<langle>x, y\<rangle>" by auto
  moreover from assms have "x : A" "y : B x" by auto
  ultimately show "p : \<Sum>x : A. (B x)" by auto
qed (auto simp: assms)

lemma Dep_Pair_pair_fst_snd_eq [simp]: "p : \<Sum>x : A. (B x) \<Longrightarrow> \<langle>fst p, snd p\<rangle> = p"
  by auto

text \<open>Splitting quantifiers:\<close>

lemma tbex_Dep_Pair_iff_tbex_tbex [iff]:
  "(\<exists>p : \<Sum>x : A. (B x). P p) \<longleftrightarrow> (\<exists>x : A. \<exists>y : B x. P \<langle>x, y\<rangle>)"
  by auto

lemma tball_Dep_Pair_iff_tball_tball [iff]:
  "(\<forall>p : \<Sum>x : A. (B x). P p) \<longleftrightarrow> (\<forall>x : A. \<forall>y : B x. P \<langle>x, y\<rangle>)"
  by auto

lemma swap_type [type]: "swap : A \<times> B \<Rightarrow> B \<times> A"
  unfolding swap_def by discharge_types

end


theory list_concat_fmap_bind
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun fmap :: "('a => 'b) => 'a list => 'b list" where
"fmap x (Nil2) = Nil2"
| "fmap x (Cons2 z xs) = Cons2 (x z) (fmap x xs)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun bind :: "'a list => ('a => 'b list) => 'b list" where
"bind (Nil2) y = Nil2"
| "bind (Cons2 z xs) y = append (y z) (bind xs y)"

fun concat2 :: "('a list) list => 'a list" where
"concat2 (Nil2) = Nil2"
| "concat2 (Cons2 xs xss) = append xs (concat2 xss)"

(*hipster fmap append bind concat2 *)

hipster fmap append bind concat2

lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes fmap.simps append.simps bind.simps concat2.simps)

lemma lemma_aa [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes fmap.simps append.simps bind.simps concat2.simps)

lemma lemma_ab [thy_expl]: "append (fmap x2 y2) (fmap x2 z2) = fmap x2 (append y2 z2)"
by (hipster_induct_schemes fmap.simps append.simps bind.simps concat2.simps)

lemma lemma_ac [thy_expl]: "append (bind x1 y1) (bind z1 y1) = bind (append x1 z1) y1"
by (hipster_induct_schemes fmap.simps append.simps bind.simps concat2.simps)

theorem x0 :
  "!! (f :: ('a => 'b list)) (xs :: 'a list) .
     (concat2 (fmap f xs)) = (bind xs f)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section \<open>Finite Fields\<close>

theory Field
  imports
    "Finite_Fields.Ring_Characteristic"
    "HOL-Algebra.Ring_Divisibility"
    "HOL-Algebra.IntRing"
begin

text \<open>In some applications it is more convenient to work with natural numbers instead of
@{term "ZFact p"} whose elements are cosets. To support that use case the following definition
introduces an additive and multiplicative structure on @{term "{..<p}"}. After verifying that
the function @{term "zfact_iso"} and its inverse are homomorphisms, the ring and field property
can be transfered from @{term "ZFact p"} to to the structure on @{term "{..<p}"}.\<close>

lemma zfact_iso_0:
  assumes "n > 0"
  shows "zfact_iso n 0 = \<zero>\<^bsub>ZFact (int n)\<^esub>"
proof -
  let ?I = "Idl\<^bsub>\<Z>\<^esub> {int n}"
  have ideal_I: "ideal ?I \<Z>"
    by (simp add: int.genideal_ideal)

  interpret i:ideal "?I" "\<Z>" using ideal_I by simp
  interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) ?I"
   using i.rcos_ring_hom_ring ZFact_def by auto

  show ?thesis
    by (simp add:zfact_iso_def ZFact_def)
qed

lemma zfact_prime_is_field:
  assumes "Factorial_Ring.prime (p :: nat)"
  shows "field (ZFact (int p))"
  using zfact_prime_is_finite_field[OF assms] finite_field_def by auto

definition mod_ring :: "nat => nat ring"
  where "mod_ring n = \<lparr>
    carrier = {..<n},
    mult = (\<lambda> x y. (x * y) mod n),
    one = 1,
    zero = 0,
    add = (\<lambda> x y. (x + y) mod n) \<rparr>"

definition zfact_iso_inv :: "nat \<Rightarrow> int set \<Rightarrow> nat" where
  "zfact_iso_inv p = inv_into {..<p} (zfact_iso p)"

lemma zfact_iso_inv_0:
  assumes n_ge_0: "n > 0"
  shows "zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> = 0"
  unfolding zfact_iso_inv_def zfact_iso_0[OF n_ge_0, symmetric] using n_ge_0
  by (rule inv_into_f_f[OF zfact_iso_inj], simp add:mod_ring_def)

lemma zfact_coset:
  assumes n_ge_0: "n > 0"
  assumes "x \<in> carrier (ZFact (int n))"
  defines "I \<equiv> Idl\<^bsub>\<Z>\<^esub> {int n}"
  shows "x = I +>\<^bsub>\<Z>\<^esub> (int (zfact_iso_inv n x))"
proof -
  have "x \<in> zfact_iso n ` {..<n}"
    using assms zfact_iso_ran by simp
  hence "zfact_iso n (zfact_iso_inv n x) = x"
    unfolding zfact_iso_inv_def by (rule f_inv_into_f)
  thus ?thesis unfolding zfact_iso_def I_def by blast
qed

lemma zfact_iso_inv_is_ring_iso:
  assumes n_ge_1: "n > 1"
  shows "zfact_iso_inv n \<in> ring_iso (ZFact (int n)) (mod_ring n)"
proof (rule ring_iso_memI)
  interpret r:cring "(ZFact (int n))"
    using ZFact_is_cring by simp

  define I where "I = Idl\<^bsub>\<Z>\<^esub> {int n}"

  have n_ge_0: "n > 0" using n_ge_1 by simp

  interpret i:ideal "I" "\<Z>"
    unfolding I_def using int.genideal_ideal by simp

  interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) I"
   using i.rcos_ring_hom_ring ZFact_def I_def by auto

  show
    "\<And>x. x \<in> carrier (ZFact (int n)) \<Longrightarrow> zfact_iso_inv n x \<in> carrier (mod_ring n)"
  proof -
    fix x
    assume "x \<in> carrier (ZFact (int n))"
    hence "zfact_iso_inv n x \<in> {..<n}"
      unfolding zfact_iso_inv_def
      using zfact_iso_ran[OF n_ge_0] inv_into_into by metis

    thus "zfact_iso_inv n x \<in> carrier (mod_ring n)"
      unfolding mod_ring_def by simp
  qed

  show "\<And>x y. x \<in> carrier (ZFact (int n)) \<Longrightarrow> y \<in> carrier (ZFact (int n)) \<Longrightarrow>
    zfact_iso_inv n (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) =
    zfact_iso_inv n x \<otimes>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
  proof -
    fix x y
    assume x_carr: "x \<in> carrier (ZFact (int n))"
    define x' where "x' = zfact_iso_inv n x"
    assume y_carr: "y \<in> carrier (ZFact (int n))"
    define y' where "y' = zfact_iso_inv n y"
    have "x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<otimes>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
      unfolding x'_def y'_def
      using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' * int y'))"
      by simp
    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' * y') mod n)))"
      unfolding I_def zmod_int by (rule int_cosetI[OF n_ge_0],simp)
    also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<otimes>\<^bsub>mod_ring n\<^esub> y'))"
      unfolding mod_ring_def by simp
    also have "... = zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')"
      unfolding zfact_iso_def I_def by simp
    finally have a:"x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')"
      by simp
    have b:"x' \<otimes>\<^bsub>mod_ring n\<^esub> y' \<in> {..<n}"
      using mod_ring_def n_ge_0 by auto
    have "zfact_iso_inv n (zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')) = x' \<otimes>\<^bsub>mod_ring n\<^esub> y'"
      unfolding zfact_iso_inv_def
      by (rule inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
    thus
      "zfact_iso_inv n (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) =
      zfact_iso_inv n x \<otimes>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
      using a x'_def y'_def by simp
  qed

  show "\<And>x y. x \<in> carrier (ZFact (int n)) \<Longrightarrow> y \<in> carrier (ZFact (int n)) \<Longrightarrow>
    zfact_iso_inv n (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) =
    zfact_iso_inv n x \<oplus>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
  proof -
    fix x y
    assume x_carr: "x \<in> carrier (ZFact (int n))"
    define x' where "x' = zfact_iso_inv n x"
    assume y_carr: "y \<in> carrier (ZFact (int n))"
    define y' where "y' = zfact_iso_inv n y"
    have "x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<oplus>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
      unfolding x'_def y'_def
      using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' + int y'))"
      by simp
    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' + y') mod n)))"
      unfolding I_def zmod_int by (rule int_cosetI[OF n_ge_0],simp)
    also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<oplus>\<^bsub>mod_ring n\<^esub> y'))"
      unfolding mod_ring_def by simp
    also have "... = zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')"
      unfolding zfact_iso_def I_def by simp
    finally have a:"x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')"
      by simp
    have b:"x' \<oplus>\<^bsub>mod_ring n\<^esub> y' \<in> {..<n}"
      using mod_ring_def n_ge_0 by auto
    have "zfact_iso_inv n (zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')) = x' \<oplus>\<^bsub>mod_ring n\<^esub> y'"
      unfolding zfact_iso_inv_def
      by (rule inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
    thus
      "zfact_iso_inv n (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) =
      zfact_iso_inv n x \<oplus>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
      using a x'_def y'_def by simp
  qed

  have "\<one>\<^bsub>ZFact (int n)\<^esub> = zfact_iso n (\<one>\<^bsub>mod_ring n\<^esub>)"
    by (simp add:zfact_iso_def ZFact_def I_def[symmetric] mod_ring_def)

  thus "zfact_iso_inv n \<one>\<^bsub>ZFact (int n)\<^esub> = \<one>\<^bsub>mod_ring n\<^esub>"
    unfolding zfact_iso_inv_def mod_ring_def
    using inv_into_f_f[OF zfact_iso_inj] n_ge_1 by simp

  show "bij_betw (zfact_iso_inv n) (carrier (ZFact (int n))) (carrier (mod_ring n))"
    using zfact_iso_inv_def mod_ring_def zfact_iso_bij[OF n_ge_0] bij_betw_inv_into
    by force
qed

lemma mod_ring_finite:
  "finite (carrier (mod_ring n))"
  by (simp add:mod_ring_def)

lemma mod_ring_carr:
  "x \<in> carrier (mod_ring n) \<longleftrightarrow>  x < n"
  by (simp add:mod_ring_def)

lemma mod_ring_is_cring:
  assumes n_ge_1: "n > 1"
  shows "cring (mod_ring n)"
proof -
  have n_ge_0: "n > 0" using n_ge_1 by simp

  interpret cring "ZFact (int n)"
    using ZFact_is_cring by simp

  have "cring ((mod_ring n) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr>)"
    by (rule ring_iso_imp_img_cring[OF zfact_iso_inv_is_ring_iso[OF n_ge_1]])
  moreover have
    "(mod_ring n) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr> = mod_ring n"
    using zfact_iso_inv_0[OF n_ge_0]
    by (simp add:mod_ring_def)
  ultimately show ?thesis by simp
qed

lemma zfact_iso_is_ring_iso:
  assumes n_ge_1: "n > 1"
  shows "zfact_iso n \<in> ring_iso (mod_ring n) (ZFact (int n))"
proof -
  have r:"ring (ZFact (int n))"
    using ZFact_is_cring cring.axioms(1) by blast

  interpret s: ring "(mod_ring n)"
    using mod_ring_is_cring cring.axioms(1) n_ge_1 by blast
  have n_ge_0: "n > 0" using n_ge_1 by linarith

  have
    "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n)
      \<in> ring_iso (mod_ring n) (ZFact (int n))"
    using ring_iso_set_sym[OF r zfact_iso_inv_is_ring_iso[OF n_ge_1]] by simp
  moreover have "\<And>x. x \<in> carrier (mod_ring n) \<Longrightarrow>
    inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
  proof -
    fix x
    assume "x \<in> carrier (mod_ring n)"
    hence "x \<in> {..<n}" by (simp add:mod_ring_def)
    thus "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
      unfolding zfact_iso_inv_def
      by (simp add:inv_into_inv_into_eq[OF zfact_iso_bij[OF n_ge_0]])
  qed

  ultimately show ?thesis
    using s.ring_iso_restrict by blast
qed

text \<open>If @{term "p"} is a prime than @{term "mod_ring p"} is a field:\<close>

lemma mod_ring_is_field:
  assumes"Factorial_Ring.prime p"
  shows "field (mod_ring p)"
proof -
  have p_ge_0: "p > 0" using assms prime_gt_0_nat by blast
  have p_ge_1: "p > 1" using assms prime_gt_1_nat by blast

  interpret field "ZFact (int p)"
    using zfact_prime_is_field[OF assms] by simp

  have "field ((mod_ring p) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr>)"
    by (rule ring_iso_imp_img_field[OF zfact_iso_inv_is_ring_iso[OF p_ge_1]])

  moreover have
    "(mod_ring p) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr> = mod_ring p"
    using zfact_iso_inv_0[OF p_ge_0]
    by (simp add:mod_ring_def)
  ultimately show ?thesis by simp
qed

end