theory TopoS_withOffendingFlows
imports TopoS_Interface
begin

section {*@{term SecurityInvariant} Instantiation Helpers*}

text{*
  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,
*}

context SecurityInvariant_withOffendingFlows
begin
  text{*We define the monotonicity of @{text "sinvar"}:

  @{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.
  *}

  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{*
    If one can show @{const sinvar_mono}, then the instantiation of the @{term SecurityInvariant_preliminaries} locale is tremendously simplified.
  *}

  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{*Invariant violations do not disappear if we add more flows. *}
   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 `wf_graph G`] have valid_G_delete: "wf_graph \<lparr>nodes = nodes G, edges = edges G - X\<rparr>" by(simp add: delete_edges_simp2)
   from `X \<subseteq> Y` have "edges G - Y \<subseteq> edges G - X" by blast
   with `sinvar_mono` 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 `\<not> sinvar (delete_edges G Y) nP` 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 {*Offending Flows Not Empty Helper Lemmata*}
context SecurityInvariant_withOffendingFlows
begin
  text {* Give an over-approximation of offending flows (e.g. all edges) and get back a
          minimal set *}
  (*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{* The graph we check in @{const minimalize_offending_overapprox},
  @{term "G minus (fs \<union> keep)"} is the graph from the @{text offending_flows_min_set} condition.
  We add @{term f} and remove it.*}

  (*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)

    --{*@{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 []"}*}
    {
      fix keeps
      --{* Generalized for arbitrary @{term keeps}*}
        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
    }
    --{*@{term "keeps = []"}*}
    note minimalize_offending_overapprox_maintains_evalmodel=this[of "[]"]

    from `sinvar (delete_edges G (set ff)) nP` 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{*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.
      *}
    {
      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" --"we show this by case distinction"
        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)"*)
           { --"a lemma we only need once here"
              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 `(fst a, snd a) \<in> edges G` 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{*
   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"}.
   *}

   text{*
   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
   *}
   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{*
  @{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.
  *}
  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{* @{const sinvar_mono} naturally holds in @{const SecurityInvariant_preliminaries} *}
    lemma sinvar_monoI: "sinvar_mono"
      unfolding sinvar_mono_def using mono_sinvar by blast

    text{*Note: due to monotonicity, the minimality also holds for arbitrary subsets *}
    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 `wf_graph G`] 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 `wf_graph G` 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 set_rev_mp wf_graph.E_wfD(1) wf_graph.E_wfD(2))
      from `E \<noteq> {}` obtain e where "e \<in> E" by blast
      with min `E \<subseteq> F` 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 `e \<in> E` 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"] `e \<in> E` 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{* The algorithm @{const minimalize_offending_overapprox} is correct *}
    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{*
      If @{term "\<not> sinvar G nP"}
      Given a list ff, (ff is distinct and a subset of G's edges)
      such that @{text "sinvar (V, E - ff) nP"}
      @{const minimalize_offending_overapprox} minimizes ff such that we get an offending flows
      Note: choosing ff = edges G is a good choice!
    *}
    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{*A version which acts on configured security invariants.
      I.e. there is no type @{typ 'a} for the host attributes in it.*}
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{*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. *}
    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 `f \<subseteq> edges G` 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 `f \<subseteq> edges G` 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 `f \<subseteq> edges G` 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 {* Monotonicity of offending flows *}
  context SecurityInvariant_preliminaries
  begin

    (*todo: simplify proof*)
    text{*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 *}
    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 `F' \<subseteq> E'` 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 `F' \<subseteq> E'` a2 show "fst ` F' \<subseteq> V" by fast
        from a1 have "snd ` E \<subseteq> V" by(simp add: wf_graph_def)
        with `F' \<subseteq> E'` 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 `F' \<subseteq> E'` 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 `E' \<inter> Eadd = {}` 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{* The minimality condition of the offending flows also holds if we increase the graph.  *}
    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{* 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. *}
    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"

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

        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 `E' \<inter> Eadd = {}` `F' \<subseteq> E'` 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 `finite E'` `F' \<subseteq> E'` 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 `E' \<inter> Eadd = {}` `F' \<subseteq> E'` 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 _ `distinct Eadd_list`] 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 `E' \<inter> Eadd = {}` Eadd_prop `F' \<subseteq> E'` 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 `E' \<inter> Eadd = {}` `Fadd \<subseteq> Eadd` have "Fadd \<inter> E' = {}" by blast
          from minimality_offending_flows_mono_edges_graph_extend[OF a1 `E' \<subseteq> E` `Fadd \<inter> E' = {}` 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 `Fadd \<subseteq> Eadd` `F' \<subseteq> E'` 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  `F' \<subseteq> E'` `E' \<inter> Eadd = {}`  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 `F' \<subseteq> E'` 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{* The offending flows are monotonic. *}
    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*)
    --"combines powerset of A with B"
    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 `F' \<subseteq> X` `F' \<subseteq> E` disj `{} \<noteq> F'`
      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{* Knowing that the @{text "\<Union> offending is \<subseteq> X"}, removing something from the graphs's edges,
           it also disappears from the offending flows. *}
    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{*
    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'"}.
  *}
    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


theory Simplifying
  imports "Lexer"
begin

section {* Lexer including simplifications *}

fun F_RIGHT where
  "F_RIGHT f v = Right (f v)"

fun F_LEFT where
  "F_LEFT f v = Left (f v)"

fun F_ALT where
  "F_ALT f\<^sub>1 f\<^sub>2 (Right v) = Right (f\<^sub>2 v)"
| "F_ALT f\<^sub>1 f\<^sub>2 (Left v) = Left (f\<^sub>1 v)"
| "F_ALT f1 f2 v = v"

fun F_SEQ1 where
  "F_SEQ1 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 Void) (f\<^sub>2 v)"

fun F_SEQ2 where
  "F_SEQ2 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 v) (f\<^sub>2 Void)"

fun F_SEQ where
  "F_SEQ f\<^sub>1 f\<^sub>2 (Seq v\<^sub>1 v\<^sub>2) = Seq (f\<^sub>1 v\<^sub>1) (f\<^sub>2 v\<^sub>2)"
| "F_SEQ f1 f2 v = v"

fun simp_ALT where
  "simp_ALT (ZERO, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_RIGHT f\<^sub>2)"
| "simp_ALT (r\<^sub>1, f\<^sub>1) (ZERO, f\<^sub>2) = (r\<^sub>1, F_LEFT f\<^sub>1)"
| "simp_ALT (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (ALT r\<^sub>1 r\<^sub>2, F_ALT f\<^sub>1 f\<^sub>2)"

(* where is ZERO *)
fun simp_SEQ where
  "simp_SEQ (ONE, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_SEQ1 f\<^sub>1 f\<^sub>2)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (ONE, f\<^sub>2) = (r\<^sub>1, F_SEQ2 f\<^sub>1 f\<^sub>2)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (SEQ r\<^sub>1 r\<^sub>2, F_SEQ f\<^sub>1 f\<^sub>2)"

lemma simp_SEQ_simps[simp]:
  "simp_SEQ p1 p2 = (if (fst p1 = ONE) then (fst p2, F_SEQ1 (snd p1) (snd p2))
                    else (if (fst p2 = ONE) then (fst p1, F_SEQ2 (snd p1) (snd p2))
                    else (SEQ (fst p1) (fst p2), F_SEQ (snd p1) (snd p2))))"
by (induct p1 p2 rule: simp_SEQ.induct) (auto)

lemma simp_ALT_simps[simp]:
  "simp_ALT p1 p2 = (if (fst p1 = ZERO) then (fst p2, F_RIGHT (snd p2))
                    else (if (fst p2 = ZERO) then (fst p1, F_LEFT (snd p1))
                    else (ALT (fst p1) (fst p2), F_ALT (snd p1) (snd p2))))"
by (induct p1 p2 rule: simp_ALT.induct) (auto)

fun
  simp :: "rexp \<Rightarrow> rexp * (val \<Rightarrow> val)"
where
  "simp (ALT r1 r2) = simp_ALT (simp r1) (simp r2)"
| "simp (SEQ r1 r2) = simp_SEQ (simp r1) (simp r2)"
| "simp r = (r, id)"

fun
  slexer :: "rexp \<Rightarrow> string \<Rightarrow> val option"
where
  "slexer r [] = (if nullable r then Some(mkeps r) else None)"
| "slexer r (c#s) = (let (rs, fr) = simp (der c r) in
                         (case (slexer rs s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c (fr v))))"

lemma slexer_better_simp:
  "slexer r (c#s) = (case (slexer (fst (simp (der c r))) s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c ((snd (simp (der c r))) v)))"
by (auto split: prod.split option.split)

lemma L_fst_simp:
  shows "L(r) = L(fst (simp r))"
by (induct r) (auto)

lemma Posix_simp:
  assumes "s \<in> (fst (simp r)) \<rightarrow> v"
  shows "s \<in> r \<rightarrow> ((snd (simp r)) v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case (ALT r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (ALT r1 r2)) \<rightarrow> v" by fact
  consider (ZERO_ZERO) "fst (simp r1) = ZERO" "fst (simp r2) = ZERO"
         | (ZERO_NZERO) "fst (simp r1) = ZERO" "fst (simp r2) \<noteq> ZERO"
         | (NZERO_ZERO) "fst (simp r1) \<noteq> ZERO" "fst (simp r2) = ZERO"
         | (NZERO_NZERO) "fst (simp r1) \<noteq> ZERO" "fst (simp r2) \<noteq> ZERO" by auto
  then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
    proof(cases)
      case (ZERO_ZERO)
      with as have "s \<in> ZERO \<rightarrow> v" by simp
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" by (rule Posix_elims(1))
    next
      case (ZERO_NZERO)
      with as have "s \<in> fst (simp r2) \<rightarrow> v" by simp
      with IH2 have "s \<in> r2 \<rightarrow> snd (simp r2) v" by simp
      moreover
      from ZERO_NZERO have "fst (simp r1) = ZERO" by simp
      then have "L (fst (simp r1)) = {}" by simp
      then have "L r1 = {}" using L_fst_simp by simp
      then have "s \<notin> L r1" by simp
      ultimately have "s \<in> ALT r1 r2 \<rightarrow> Right (snd (simp r2) v)" by (rule Posix_ALT2)
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
      using ZERO_NZERO by simp
    next
      case (NZERO_ZERO)
      with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
      with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      then have "s \<in> ALT r1 r2 \<rightarrow> Left (snd (simp r1) v)" by (rule Posix_ALT1)
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_ZERO by simp
    next
      case (NZERO_NZERO)
      with as have "s \<in> ALT (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then consider (Left) v1 where "v = Left v1" "s \<in> (fst (simp r1)) \<rightarrow> v1"
                  | (Right) v2 where "v = Right v2" "s \<in> (fst (simp r2)) \<rightarrow> v2" "s \<notin> L (fst (simp r1))"
                  by (erule_tac Posix_elims(4))
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
      proof(cases)
        case (Left)
        then have "v = Left v1" "s \<in> r1 \<rightarrow> (snd (simp r1) v1)" using IH1 by simp_all
        then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_NZERO
          by (simp_all add: Posix_ALT1)
      next
        case (Right)
        then have "v = Right v2" "s \<in> r2 \<rightarrow> (snd (simp r2) v2)" "s \<notin> L r1" using IH2 L_fst_simp by simp_all
        then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_NZERO
          by (simp_all add: Posix_ALT2)
      qed
    qed
next
  case (SEQ r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (SEQ r1 r2)) \<rightarrow> v" by fact
  consider (ONE_ONE) "fst (simp r1) = ONE" "fst (simp r2) = ONE"
         | (ONE_NONE) "fst (simp r1) = ONE" "fst (simp r2) \<noteq> ONE"
         | (NONE_ONE) "fst (simp r1) \<noteq> ONE" "fst (simp r2) = ONE"
         | (NONE_NONE) "fst (simp r1) \<noteq> ONE" "fst (simp r2) \<noteq> ONE" by auto
  then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v"
  proof(cases)
      case (ONE_ONE)
      with as have b: "s \<in> ONE \<rightarrow> v" by simp
      from b have "s \<in> r1 \<rightarrow> snd (simp r1) v" using IH1 ONE_ONE by simp
      moreover
      from b have c: "s = []" "v = Void" using Posix_elims(2) by auto
      moreover
      have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
      then have "[] \<in> fst (simp r2) \<rightarrow> Void" using ONE_ONE by simp
      then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "([] @ []) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) Void)"
        using Posix_SEQ by blast
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using c ONE_ONE by simp
    next
      case (ONE_NONE)
      with as have b: "s \<in> fst (simp r2) \<rightarrow> v" by simp
      from b have "s \<in> r2 \<rightarrow> snd (simp r2) v" using IH2 ONE_NONE by simp
      moreover
      have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
      then have "[] \<in> fst (simp r1) \<rightarrow> Void" using ONE_NONE by simp
      then have "[] \<in> r1 \<rightarrow> snd (simp r1) Void" using IH1 by simp
      moreover
      from ONE_NONE(1) have "L (fst (simp r1)) = {[]}" by simp
      then have "L r1 = {[]}" by (simp add: L_fst_simp[symmetric])
      ultimately have "([] @ s) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) v)"
        by(rule_tac Posix_SEQ) auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using ONE_NONE by simp
    next
      case (NONE_ONE)
        with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
        with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      moreover
        have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
        then have "[] \<in> fst (simp r2) \<rightarrow> Void" using NONE_ONE by simp
        then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "(s @ []) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) v) (snd (simp r2) Void)"
        by(rule_tac Posix_SEQ) auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using NONE_ONE by simp
    next
      case (NONE_NONE)
      with as have "s \<in> SEQ (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then obtain s1 s2 v1 v2 where eqs: "s = s1 @ s2" "v = Seq v1 v2"
                     "s1 \<in> (fst (simp r1)) \<rightarrow> v1" "s2 \<in> (fst (simp r2)) \<rightarrow> v2"
                     "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)"
                     by (erule_tac Posix_elims(5)) (auto simp add: L_fst_simp[symmetric])
      then have "s1 \<in> r1 \<rightarrow> (snd (simp r1) v1)" "s2 \<in> r2 \<rightarrow> (snd (simp r2) v2)"
        using IH1 IH2 by auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using eqs NONE_NONE
        by(auto intro: Posix_SEQ)
    qed
qed (simp_all)

lemma slexer_correctness:
  shows "slexer r s = lexer r s"
proof(induct s arbitrary: r)
  case Nil
  show "slexer r [] = lexer r []" by simp
next
  case (Cons c s r)
  have IH: "\<And>r. slexer r s = lexer r s" by fact
  show "slexer r (c # s) = lexer r (c # s)"
   proof (cases "s \<in> L (der c r)")
     case True
       assume a1: "s \<in> L (der c r)"
       then obtain v1 where a2: "lexer (der c r) s = Some v1" "s \<in> der c r \<rightarrow> v1"
         using lexer_correct_Some by auto
       from a1 have "s \<in> L (fst (simp (der c r)))" using L_fst_simp[symmetric] by simp
       then obtain v2 where a3: "lexer (fst (simp (der c r))) s = Some v2" "s \<in> (fst (simp (der c r))) \<rightarrow> v2"
          using lexer_correct_Some by auto
       then have a4: "slexer (fst (simp (der c r))) s = Some v2" using IH by simp
       from a3(2) have "s \<in> der c r \<rightarrow> (snd (simp (der c r))) v2" using Posix_simp by simp
       with a2(2) have "v1 = (snd (simp (der c r))) v2" using Posix_determ by simp
       with a2(1) a4 show "slexer r (c # s) = lexer r (c # s)" by (auto split: prod.split)
     next
     case False
       assume b1: "s \<notin> L (der c r)"
       then have "lexer (der c r) s = None" using lexer_correct_None by simp
       moreover
       from b1 have "s \<notin> L (fst (simp (der c r)))" using L_fst_simp[symmetric] by simp
       then have "lexer (fst (simp (der c r))) s = None" using lexer_correct_None by simp
       then have "slexer (fst (simp (der c r))) s = None" using IH by simp
       ultimately show "slexer r (c # s) = lexer r (c # s)"
         by (simp del: slexer.simps add: slexer_better_simp)
   qed
 qed

(*
fun simp2_ALT where
  "simp2_ALT ZERO r2 seen = (r2, seen)"
| "simp2_ALT r1 ZERO seen = (r1, seen)"
| "simp2_ALT r1 r2 seen = (ALT r1 r2, seen)"

fun simp2_SEQ where
  "simp2_SEQ ZERO r2 seen = (ZERO, seen)"
| "simp2_SEQ r1 ZERO seen = (ZERO, seen)"
| "simp2_SEQ ONE r2 seen = (r2, seen \<union> {r2})"
| "simp2_SEQ r1 ONE seen = (r1, seen \<union> {r1})"
| "simp2_SEQ r1 r2 seen = (SEQ r1 r2, seen \<union> {SEQ r1 r2})"

fun
  simp2 :: "rexp \<Rightarrow> rexp set \<Rightarrow> rexp * rexp set"
where
  "simp2 (ALT r1 r2) seen =
      (let (r1s, seen1) = simp2 r1 seen in
       let (r2s, seen2) = simp2 r2 seen1
       in simp2_ALT r1s r2s seen2)"
| "simp2 (SEQ r1 r2) seen =
      (let (r1s, _) = simp2 r1 {} in
       let (r2s, _) = simp2 r2 {}
       in if (SEQ r1s r2s \<in> seen) then (ZERO, seen)
       else simp2_SEQ r1s r2s seen)"
| "simp2 r seen = (if r \<in> seen then (ZERO, seen) else (r, seen \<union> {r}))"

lemma simp2_ALT[simp]:
  shows "L (fst (simp2_ALT r1 r2 seen)) = L r1 \<union> L r2"
  apply(induct r1 r2 seen rule: simp2_ALT.induct)
  apply(simp_all)
  done

lemma test1:
  shows "snd (simp2_ALT r1 r2 rs) = rs"
  apply(induct r1 r2 rs rule: simp2_ALT.induct)
  apply(auto)
  done

lemma test2:
  shows "rs \<subseteq> snd (simp2_SEQ r1 r2 rs)"
  apply(induct r1 r2 rs rule: simp2_SEQ.induct)
  apply(auto)
  done

lemma test3:
  shows "rs \<subseteq> snd (simp2 r rs)"
  apply(induct r rs rule: simp2.induct)
  apply(auto split: prod.split)
  apply (metis set_mp test1)
  by (meson set_mp test2)

lemma test3a:
  shows "\<Union>(L ` snd (simp2 r rs)) \<subseteq> L(r) \<union> (\<Union> (L ` rs))"
  apply(induct r rs rule: simp2.induct)
  apply(auto split: prod.split simp add: Sequ_def)
  apply (smt UN_iff Un_iff set_mp test1)

lemma test:
  assumes "(\<Union>r' \<in> rs. L r') \<subseteq> L r"
  shows "L(fst (simp2 r rs)) \<subseteq> L(r)"
  using assms
  apply(induct r arbitrary: rs)
  apply(simp only: simp2.simps)
  apply(simp)
  apply(simp only: simp2.simps)
  apply(simp)
  apply(simp only: simp2.simps)
  apply(simp)
  prefer 3
  apply(simp only: simp2.simps)
  apply(simp)
  prefer 2
  apply(simp only: simp2.simps)
   apply(simp)
   apply(subst prod.split)
  apply(rule allI)+
   apply(rule impI)
  apply(subst prod.split)
  apply(rule allI)+
   apply(rule impI)
   apply(simp)
   apply(drule_tac x="rs" in meta_spec)
  apply(simp)
  apply(drule_tac x="x2" in meta_spec)
   apply(simp)
   apply(auto)[1]
    apply(subgoal_tac "rs \<subseteq> x2a")
     prefer 2
  apply (metis order_trans prod.sel(2) test3)

   apply(rule antisym)
  prefer 2
    apply(simp)
    apply(rule conjI)
     apply(drule meta_mp)
  prefer 2
      apply(simp)
      apply(auto)[1]
    apply(auto)[1]

  thm prod.split
   apply(auto split: prod.split)[1]
     apply(drule_tac x="rs" in meta_spec)
     apply(drule_tac x="rs" in meta_spec)
     apply(simp)
     apply(rule_tac x="SEQ x1 x1a" in bexI)
      apply(simp add: Sequ_def)

      apply(auto)[1]
     apply(simp)
  apply(subgoal_tac "L (fst (simp2_SEQ x1 x1a rs)) \<subseteq> L x1 \<union> L x1a")
     apply(frule_tac x="{}" in meta_spec)
  apply(rotate_tac 1)
     apply(frule_tac x="{}" in meta_spec)
     apply(simp)

     apply(rule_tac x="SEQ x1 x1a" in bexI)
      apply(simp add: Sequ_def)
      apply(auto)[1]
  apply(simp)
  using L.simps(2) apply blast
  prefer 3
  apply(simp only: simp2.simps)
    apply(simp)
  using L.simps(3) apply blast
  prefer 2
   apply(simp add: Sequ_def)
   apply(auto)[1]
  oops
*)
end


(*  Title:      HOL/Imperative_HOL/ex/SatChecker.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section {* An efficient checker for proofs from a SAT solver *}

theory SatChecker
imports "~~/src/HOL/Library/RBT_Impl" Sorted_List "../Imperative_HOL"
begin

section{* General settings and functions for our representation of clauses *}

subsection{* Types for Literals, Clauses and ProofSteps *}
text {* We encode Literals as integers and Clauses as sorted Lists. *}

type_synonym ClauseId = nat
type_synonym Lit = int
type_synonym Clause = "Lit list"

text {* This resembles exactly to Isat's Proof Steps *}

type_synonym Resolvants = "ClauseId * (Lit * ClauseId) list"
datatype ProofStep =
  ProofDone bool
  | Root ClauseId Clause
  | Conflict ClauseId Resolvants
  | Delete ClauseId
  | Xstep ClauseId ClauseId

subsection{* Interpretation of Literals, Clauses, and an array of Clauses *}
text {* Specific definitions for Literals as integers *}

definition compl :: "Lit \<Rightarrow> Lit"
where
  "compl a = -a"

definition interpLit :: "(nat \<Rightarrow> bool) \<Rightarrow> Lit \<Rightarrow> bool"
where
  "interpLit assgnmt lit = (if lit > 0 then assgnmt (nat lit) else (if (lit < 0) then \<not> (assgnmt (nat (- lit))) else undefined))"

lemma interpLit_compl[simp]:
  assumes lit_not_zero: "lit \<noteq> 0"
  shows "interpLit a (compl lit) = (\<not> interpLit a lit)"
unfolding interpLit_def compl_def using lit_not_zero by auto

lemma compl_compl_is_id[simp]:
  "compl (compl x) = x"
unfolding compl_def by simp

lemma compl_not_zero[simp]:
  "(compl x \<noteq> 0) = (x \<noteq> 0)"
unfolding compl_def by simp

lemma compl_exists: "\<exists>l'. l = compl l'"
unfolding compl_def by arith

text {* Specific definitions for Clauses as sorted lists *}

definition interpClause :: "(nat \<Rightarrow> bool) \<Rightarrow> Clause \<Rightarrow> bool"
where
  "interpClause assgnmt cl = (\<exists> l \<in> set cl. interpLit assgnmt l)"

lemma interpClause_empty[simp]:
  "interpClause a [] = False"
unfolding interpClause_def by simp

lemma interpClause_sort[simp]: "interpClause a (sort clause) = interpClause a clause"
unfolding interpClause_def
by simp

lemma interpClause_remdups[simp]: "interpClause a (remdups clause) = interpClause a clause"
unfolding interpClause_def
by simp

definition
  "inconsistent cs = (\<forall>a.\<exists>c\<in>set cs. \<not> interpClause a c)"

lemma interpClause_resolvants':
  assumes lit_not_zero: "lit \<noteq> 0"
  assumes resolv_clauses: "lit \<in> cli" "compl lit \<in> clj"
  assumes interp: "\<exists>x \<in> cli. interpLit a x" "\<exists>x \<in> clj. interpLit a x"
  shows "\<exists>x \<in> (cli - {lit} \<union> (clj - {compl lit})). interpLit a x"
proof -
  from resolv_clauses interp have "(\<exists>l \<in> cli - {lit}. interpLit a l) \<or> interpLit a lit"
    "(\<exists>l \<in> clj - {compl lit}. interpLit a l) \<or> interpLit a (compl lit)" by auto
  with lit_not_zero show ?thesis by (fastforce simp add: bex_Un)
qed

lemma interpClause_resolvants:
  assumes lit_not_zero: "lit \<noteq> 0"
  assumes sorted_and_distinct: "sorted cli" "distinct cli" "sorted clj" "distinct clj"
  assumes resolv_clauses: "lit \<in> set cli" "compl lit \<in> set clj"
  assumes interp: "interpClause a cli" "interpClause a clj"
  shows "interpClause a (merge (remove lit cli) (remove (compl lit) clj))"
proof -
  from lit_not_zero resolv_clauses interp sorted_and_distinct show ?thesis
    unfolding interpClause_def
    using interpClause_resolvants' by simp
qed

definition correctClause :: "Clause list \<Rightarrow> Clause \<Rightarrow> bool"
where
  "correctClause rootcls cl = (\<forall>a. (\<forall>rcl \<in> set rootcls. interpClause a rcl) \<longrightarrow> (interpClause a cl))"

lemma correctClause_resolvants:
  assumes lit_not_zero: "lit \<noteq> 0"
  assumes sorted_and_distinct: "sorted cli" "distinct cli" "sorted clj" "distinct clj"
  assumes resolv_clauses: "lit \<in> set cli" "compl lit \<in> set clj"
  assumes correct: "correctClause r cli" "correctClause r clj"
  shows "correctClause r (merge (remove lit cli) (remove (compl lit) clj))"
  using assms interpClause_resolvants unfolding correctClause_def by auto

lemma implies_empty_inconsistent:
  "correctClause cs [] \<Longrightarrow> inconsistent cs"
unfolding inconsistent_def correctClause_def
by auto

text {* Specific definition for derived clauses in the Array *}

definition
  array_ran :: "('a\<Colon>heap) option array \<Rightarrow> heap \<Rightarrow> 'a set" where
  "array_ran a h = {e. Some e \<in> set (Array.get h a)}"
    -- {*FIXME*}

lemma array_ranI: "\<lbrakk> Some b = Array.get h a ! i; i < Array.length h a \<rbrakk> \<Longrightarrow> b \<in> array_ran a h"
unfolding array_ran_def Array.length_def by simp

lemma array_ran_upd_array_Some:
  assumes "cl \<in> array_ran a (Array.update a i (Some b) h)"
  shows "cl \<in> array_ran a h \<or> cl = b"
proof -
  have "set (Array.get h a[i := Some b]) \<subseteq> insert (Some b) (set (Array.get h a))" by (rule set_update_subset_insert)
  with assms show ?thesis
    unfolding array_ran_def Array.update_def by fastforce
qed

lemma array_ran_upd_array_None:
  assumes "cl \<in> array_ran a (Array.update a i None h)"
  shows "cl \<in> array_ran a h"
proof -
  have "set (Array.get h a[i := None]) \<subseteq> insert None (set (Array.get h a))" by (rule set_update_subset_insert)
  with assms show ?thesis
    unfolding array_ran_def Array.update_def by auto
qed

definition correctArray :: "Clause list \<Rightarrow> Clause option array \<Rightarrow> heap \<Rightarrow> bool"
where
  "correctArray rootcls a h =
  (\<forall>cl \<in> array_ran a h. correctClause rootcls cl \<and> sorted cl \<and> distinct cl)"

lemma correctArray_update:
  assumes "correctArray rcs a h"
  assumes "correctClause rcs c" "sorted c" "distinct c"
  shows "correctArray rcs a (Array.update a i (Some c) h)"
  using assms
  unfolding correctArray_def
  by (auto dest:array_ran_upd_array_Some)

lemma correctClause_mono:
  assumes "correctClause rcs c"
  assumes "set rcs \<subseteq> set rcs'"
  shows "correctClause rcs' c"
  using assms unfolding correctClause_def
  by auto

section{* Improved version of SatChecker *}

text{* This version just uses a single list traversal. *}

subsection{* Function definitions *}

primrec res_mem :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "res_mem l [] = raise ''MiniSatChecked.res_thm: Cannot find literal''"
| "res_mem l (x#xs) = (if (x = l) then return xs else do { v \<leftarrow> res_mem l xs; return (x # v) })"

fun resolve1 :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "resolve1 l (x#xs) (y#ys) =
  (if (x = l) then return (merge xs (y#ys))
  else (if (x < y) then do { v \<leftarrow> resolve1 l xs (y#ys); return (x # v) }
  else (if (x > y) then do { v \<leftarrow> resolve1 l (x#xs) ys; return (y # v) }
  else do { v \<leftarrow> resolve1 l xs ys; return (x # v) })))"
| "resolve1 l [] ys = raise ''MiniSatChecked.res_thm: Cannot find literal''"
| "resolve1 l xs [] = res_mem l xs"

fun resolve2 :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "resolve2 l (x#xs) (y#ys) =
  (if (y = l) then return (merge (x#xs) ys)
  else (if (x < y) then do { v \<leftarrow> resolve2 l xs (y#ys); return (x # v) }
  else (if (x > y) then do { v \<leftarrow> resolve2 l (x#xs) ys; return (y # v) }
  else do { v \<leftarrow> resolve2 l xs ys; return (x # v) })))"
  | "resolve2 l xs [] = raise ''MiniSatChecked.res_thm: Cannot find literal''"
  | "resolve2 l [] ys = res_mem l ys"

fun res_thm' :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "res_thm' l (x#xs) (y#ys) =
  (if (x = l \<or> x = compl l) then resolve2 (compl x) xs (y#ys)
  else (if (y = l \<or> y = compl l) then resolve1 (compl y) (x#xs) ys
  else (if (x < y) then (res_thm' l xs (y#ys)) \<guillemotright>= (\<lambda>v. return (x # v))
  else (if (x > y) then (res_thm' l (x#xs) ys) \<guillemotright>= (\<lambda>v. return (y # v))
  else (res_thm' l xs ys) \<guillemotright>= (\<lambda>v. return (x # v))))))"
| "res_thm' l [] ys = raise (''MiniSatChecked.res_thm: Cannot find literal'')"
| "res_thm' l xs [] = raise (''MiniSatChecked.res_thm: Cannot find literal'')"

declare res_mem.simps [simp del] resolve1.simps [simp del] resolve2.simps [simp del] res_thm'.simps [simp del]

subsection {* Proofs about these functions *}

lemma res_mem:
assumes "effect (res_mem l xs) h h' r"
  shows "l \<in> set xs \<and> r = remove1 l xs"
using assms
proof (induct xs arbitrary: r)
  case Nil
  thus ?case unfolding res_mem.simps by (auto elim: effect_raiseE)
next
  case (Cons x xs')
  thus ?case
    unfolding res_mem.simps
    by (elim effect_raiseE effect_returnE effect_ifE effect_bindE) auto
qed

lemma resolve1_Inv:
assumes "effect (resolve1 l xs ys) h h' r"
  shows "l \<in> set xs \<and> r = merge (remove1 l xs) ys"
using assms
proof (induct xs ys arbitrary: r rule: resolve1.induct)
  case (1 l x xs y ys r)
  thus ?case
    unfolding resolve1.simps
    by (elim effect_bindE effect_ifE effect_returnE) auto
next
  case (2 l ys r)
  thus ?case
    unfolding resolve1.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding resolve1.simps
    by (fastforce dest!: res_mem)
qed

lemma resolve2_Inv:
  assumes "effect (resolve2 l xs ys) h h' r"
  shows "l \<in> set ys \<and> r = merge xs (remove1 l ys)"
using assms
proof (induct xs ys arbitrary: r rule: resolve2.induct)
  case (1 l x xs y ys r)
  thus ?case
    unfolding resolve2.simps
    by (elim effect_bindE effect_ifE effect_returnE) auto
next
  case (2 l ys r)
  thus ?case
    unfolding resolve2.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding resolve2.simps
    by (fastforce dest!: res_mem)
qed

lemma res_thm'_Inv:
assumes "effect (res_thm' l xs ys) h h' r"
shows "\<exists>l'. (l' \<in> set xs \<and> compl l' \<in> set ys \<and> (l' = compl l \<or> l' = l)) \<and> r = merge (remove1 l' xs) (remove1 (compl l') ys)"
using assms
proof (induct xs ys arbitrary: r rule: res_thm'.induct)
case (1 l x xs y ys r)
(* There are five cases for res_thm: We will consider them one after another: *)
  {
    assume cond: "x = l \<or> x = compl l"
    assume resolve2: "effect (resolve2 (compl x) xs (y # ys)) h h' r"
    from resolve2_Inv [OF resolve2] cond have ?case
      apply -
      by (rule exI[of _ "x"]) fastforce
  } moreover
  {
    assume cond: "\<not> (x = l \<or> x = compl l)" "y = l \<or> y = compl l"
    assume resolve1: "effect (resolve1 (compl y) (x # xs) ys) h h' r"
    from resolve1_Inv [OF resolve1] cond have ?case
      apply -
      by (rule exI[of _ "compl y"]) fastforce
  } moreover
  {
    fix r'
    assume cond: "\<not> (x = l \<or> x = compl l)" "\<not> (y = l \<or> y = compl l)" "x < y"
    assume res_thm: "effect (res_thm' l xs (y # ys)) h h' r'"
    assume return: "r = x # r'"
    from "1.hyps"(1) [OF cond res_thm] cond return have ?case by auto
  } moreover
  {
    fix r'
    assume cond: "\<not> (x = l \<or> x = compl l)" "\<not> (y = l \<or> y = compl l)" "\<not> x < y" "y < x"
    assume res_thm: "effect (res_thm' l (x # xs) ys) h h' r'"
    assume return: "r = y # r'"
    from "1.hyps"(2) [OF cond res_thm] cond return have ?case by auto
  } moreover
  {
    fix r'
    assume cond: "\<not> (x = l \<or> x = compl l)" "\<not> (y = l \<or> y = compl l)" "\<not> x < y" "\<not> y < x"
    assume res_thm: "effect (res_thm' l xs ys) h h' r'"
    assume return: "r = x # r'"
    from "1.hyps"(3) [OF cond res_thm] cond return have ?case by auto
  } moreover
  note "1.prems"
  ultimately show ?case
    unfolding res_thm'.simps
    apply (elim effect_bindE effect_ifE effect_returnE)
    apply simp
    apply simp
    apply simp
    apply simp
    apply fastforce
    done
next
  case (2 l ys r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
qed

lemma res_mem_no_heap:
assumes "effect (res_mem l xs) h h' r"
  shows "h = h'"
using assms
apply (induct xs arbitrary: r)
unfolding res_mem.simps
apply (elim effect_raiseE)
apply auto
apply (elim effect_ifE effect_bindE effect_raiseE effect_returnE)
apply auto
done

lemma resolve1_no_heap:
assumes "effect (resolve1 l xs ys) h h' r"
  shows "h = h'"
using assms
apply (induct xs ys arbitrary: r rule: resolve1.induct)
unfolding resolve1.simps
apply (elim effect_bindE effect_ifE effect_returnE effect_raiseE)
apply (auto simp add: res_mem_no_heap)
by (elim effect_raiseE) auto

lemma resolve2_no_heap:
assumes "effect (resolve2 l xs ys) h h' r"
  shows "h = h'"
using assms
apply (induct xs ys arbitrary: r rule: resolve2.induct)
unfolding resolve2.simps
apply (elim effect_bindE effect_ifE effect_returnE effect_raiseE)
apply (auto simp add: res_mem_no_heap)
by (elim effect_raiseE) auto

lemma res_thm'_no_heap:
  assumes "effect (res_thm' l xs ys) h h' r"
  shows "h = h'"
  using assms
proof (induct xs ys arbitrary: r rule: res_thm'.induct)
  case (1 l x xs y ys r)
  thus ?thesis
    unfolding res_thm'.simps
    by (elim effect_bindE effect_ifE effect_returnE)
  (auto simp add: resolve1_no_heap resolve2_no_heap)
next
  case (2 l ys r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
qed

lemma res_thm'_Inv2:
  assumes res_thm: "effect (res_thm' l xs ys) h h' rcl"
  assumes l_not_null: "l \<noteq> 0"
  assumes ys: "correctClause r ys \<and> sorted ys \<and> distinct ys"
  assumes xs: "correctClause r xs \<and> sorted xs \<and> distinct xs"
  shows "correctClause r rcl \<and> sorted rcl \<and> distinct rcl"
proof -
  from res_thm'_Inv [OF res_thm] xs ys l_not_null show ?thesis
    apply (auto simp add: sorted_remove1)
    unfolding correctClause_def
    apply (auto simp add: remove1_eq_remove)
    prefer 2
    apply (rule interpClause_resolvants)
    apply simp_all
    apply (insert compl_exists [of l])
    apply auto
    apply (rule interpClause_resolvants)
    apply simp_all
    done
qed

subsection {* res_thm and doProofStep *}

definition get_clause :: "Clause option array \<Rightarrow> ClauseId \<Rightarrow> Clause Heap"
where
  "get_clause a i =
       do { c \<leftarrow> Array.nth a i;
           (case c of None \<Rightarrow> raise (''Clause not found'')
                    | Some x \<Rightarrow> return x)
       }"

primrec res_thm2 :: "Clause option array \<Rightarrow> (Lit * ClauseId) \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "res_thm2 a (l, j) cli =
  ( if l = 0 then raise(''Illegal literal'')
    else
     do { clj \<leftarrow> get_clause a j;
         res_thm' l cli clj
     })"

primrec
  foldM :: "('a \<Rightarrow> 'b \<Rightarrow> 'b Heap) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b Heap"
where
  "foldM f [] s = return s"
  | "foldM f (x#xs) s = f x s \<guillemotright>= foldM f xs"

fun doProofStep2 :: "Clause option array \<Rightarrow> ProofStep \<Rightarrow> Clause list \<Rightarrow> Clause list Heap"
where
  "doProofStep2 a (Conflict saveTo (i, rs)) rcs =
  do {
     cli \<leftarrow> get_clause a i;
     result \<leftarrow> foldM (res_thm2 a) rs cli;
     Array.upd saveTo (Some result) a;
     return rcs
  }"
| "doProofStep2 a (Delete cid) rcs = do { Array.upd cid None a; return rcs }"
| "doProofStep2 a (Root cid clause) rcs = do { Array.upd cid (Some (remdups (sort clause))) a; return (clause # rcs) }"
| "doProofStep2 a (Xstep cid1 cid2) rcs = raise ''MiniSatChecked.doProofStep: Xstep constructor found.''"
| "doProofStep2 a (ProofDone b) rcs = raise ''MiniSatChecked.doProofStep: ProofDone constructor found.''"

definition checker :: "nat \<Rightarrow> ProofStep list \<Rightarrow> nat \<Rightarrow> Clause list Heap"
where
  "checker n p i =
  do {
     a \<leftarrow> Array.new n None;
     rcs \<leftarrow> foldM (doProofStep2 a) p [];
     ec \<leftarrow> Array.nth a i;
     (if ec = Some [] then return rcs
                else raise(''No empty clause''))
  }"

lemma effect_case_option:
  assumes "effect (case x of None \<Rightarrow> n | Some y \<Rightarrow> s y) h h' r"
  obtains "x = None" "effect n h h' r"
         | y where "x = Some y" "effect (s y) h h' r"
  using assms unfolding effect_def by (auto split: option.splits)

lemma res_thm2_Inv:
  assumes res_thm: "effect (res_thm2 a (l, j) cli) h h' rs"
  assumes correct_a: "correctArray r a h"
  assumes correct_cli: "correctClause r cli \<and> sorted cli \<and> distinct cli"
  shows "h = h' \<and> correctClause r rs \<and> sorted rs \<and> distinct rs"
proof -
  from res_thm have l_not_zero: "l \<noteq> 0"
    by (auto elim: effect_raiseE)
  {
    fix clj
    let ?rs = "merge (remove l cli) (remove (compl l) clj)"
    let ?rs' = "merge (remove (compl l) cli) (remove l clj)"
    assume "h = h'" "Some clj = Array.get h' a ! j" "j < Array.length h' a"
    with correct_a have clj: "correctClause r clj" "sorted clj" "distinct clj"
      unfolding correctArray_def by (auto intro: array_ranI)
    with clj l_not_zero correct_cli
    have "(l \<in> set cli \<and> compl l \<in> set clj
      \<longrightarrow> correctClause r ?rs \<and> sorted ?rs \<and> distinct ?rs) \<and>
      (compl l \<in> set cli \<and> l \<in> set clj
      \<longrightarrow> correctClause r ?rs' \<and> sorted ?rs' \<and> distinct ?rs')"
      apply (auto intro!: correctClause_resolvants)
      apply (insert compl_exists [of l])
      by (auto intro!: correctClause_resolvants)
  }
  {
    fix v clj
    assume "Some clj = Array.get h a ! j" "j < Array.length h a"
    with correct_a have clj: "correctClause r clj \<and> sorted clj \<and> distinct clj"
      unfolding correctArray_def by (auto intro: array_ranI)
    assume "effect (res_thm' l cli clj) h h' rs"
    from res_thm'_no_heap[OF this] res_thm'_Inv2[OF this l_not_zero clj correct_cli]
    have "h = h' \<and> correctClause r rs \<and> sorted rs \<and> distinct rs" by simp
  }
  with assms show ?thesis
    unfolding res_thm2.simps get_clause_def
    by (elim effect_bindE effect_ifE effect_nthE effect_raiseE effect_returnE effect_case_option) auto
qed

lemma foldM_Inv2:
  assumes "effect (foldM (res_thm2 a) rs cli) h h' rcl"
  assumes correct_a: "correctArray r a h"
  assumes correct_cli: "correctClause r cli \<and> sorted cli \<and> distinct cli"
  shows "h = h' \<and> correctClause r rcl \<and> sorted rcl \<and> distinct rcl"
using assms
proof (induct rs arbitrary: h h' cli)
  case Nil thus ?case
    unfolding foldM.simps
    by (elim effect_returnE) auto
next
  case (Cons x xs)
  {
    fix h1 ret
    obtain l j where x_is: "x = (l, j)" by fastforce
    assume res_thm2: "effect (res_thm2 a x cli) h h1 ret"
    with x_is have res_thm2': "effect (res_thm2 a (l, j) cli) h h1 ret" by simp
    note step = res_thm2_Inv [OF res_thm2' Cons.prems(2) Cons.prems(3)]
    from step have ret: "correctClause r ret \<and> sorted ret \<and> distinct ret" by simp
    from step Cons.prems(2) have correct_a: "correctArray r a h1"  by simp
    assume foldM: "effect (foldM (res_thm2 a) xs ret) h1 h' rcl"
    from step Cons.hyps [OF foldM correct_a ret] have
    "h = h' \<and> correctClause r rcl \<and> sorted rcl \<and> distinct rcl" by auto
  }
  with Cons show ?case
    unfolding foldM.simps
    by (elim effect_bindE) auto
qed

lemma step_correct2:
  assumes effect: "effect (doProofStep2 a step rcs) h h' res"
  assumes correctArray: "correctArray rcs a h"
  shows "correctArray res a h'"
proof (cases "(a,step,rcs)" rule: doProofStep2.cases)
  case (1 a saveTo i rs rcs)
  with effect correctArray
  show ?thesis
    apply auto
    apply (auto simp: get_clause_def elim!: effect_bindE effect_nthE)
    apply (auto elim!: effect_bindE effect_nthE effect_case_option effect_raiseE
      effect_returnE effect_updE)
    apply (frule foldM_Inv2)
    apply assumption
    apply (simp add: correctArray_def)
    apply (drule_tac x="y" in bspec)
    apply (rule array_ranI[where i=i])
    by (auto intro: correctArray_update)
next
  case (2 a cid rcs)
  with effect correctArray
  show ?thesis
    by (auto simp: correctArray_def elim!: effect_bindE effect_updE effect_returnE
     dest: array_ran_upd_array_None)
next
  case (3 a cid c rcs)
  with effect correctArray
  show ?thesis
    apply (auto elim!: effect_bindE effect_updE effect_returnE)
    apply (auto simp: correctArray_def dest!: array_ran_upd_array_Some)
    apply (auto intro: correctClause_mono)
    by (auto simp: correctClause_def)
next
  case 4
  with effect correctArray
  show ?thesis by (auto elim: effect_raiseE)
next
  case 5
  with effect correctArray
  show ?thesis by (auto elim: effect_raiseE)
qed

theorem fold_steps_correct:
  assumes "effect (foldM (doProofStep2 a) steps rcs) h h' res"
  assumes "correctArray rcs a h"
  shows "correctArray res a h'"
using assms
by (induct steps arbitrary: rcs h h' res)
 (auto elim!: effect_bindE effect_returnE dest:step_correct2)

theorem checker_soundness:
  assumes "effect (checker n p i) h h' cs"
  shows "inconsistent cs"
using assms unfolding checker_def
apply (elim effect_bindE effect_nthE effect_ifE effect_returnE effect_raiseE effect_newE)
prefer 2 apply simp
apply auto
apply (drule fold_steps_correct)
apply (simp add: correctArray_def array_ran_def)
apply (rule implies_empty_inconsistent)
apply (simp add:correctArray_def)
apply (drule bspec)
by (rule array_ranI, auto)

section {* Functional version with Lists as Array *}

subsection {* List specific definitions *}

definition list_ran :: "'a option list \<Rightarrow> 'a set"
where
  "list_ran xs = {e. Some e \<in> set xs }"

lemma list_ranI: "\<lbrakk> i < List.length xs; xs ! i = Some b \<rbrakk> \<Longrightarrow> b \<in> list_ran xs"
unfolding list_ran_def by (drule sym, simp)

lemma list_ran_update_Some:
  "cl \<in> list_ran (xs[i := (Some b)]) \<Longrightarrow> cl \<in> list_ran xs \<or> cl = b"
proof -
  assume assms: "cl \<in> list_ran (xs[i := (Some b)])"
  have "set (xs[i := Some b]) \<subseteq> insert (Some b) (set xs)"
    by (simp only: set_update_subset_insert)
  with assms have "Some cl \<in> insert (Some b) (set xs)"
    unfolding list_ran_def by fastforce
  thus ?thesis
    unfolding list_ran_def by auto
qed

lemma list_ran_update_None:
  "cl \<in> list_ran (xs[i := None]) \<Longrightarrow> cl \<in> list_ran xs"
proof -
  assume assms: "cl \<in> list_ran (xs[i := None])"
  have "set (xs[i := None]) \<subseteq> insert None (set xs)"
    by (simp only: set_update_subset_insert)
  with assms show ?thesis
    unfolding list_ran_def by auto
qed

definition correctList :: "Clause list \<Rightarrow> Clause option list \<Rightarrow> bool"
where
  "correctList rootcls xs =
  (\<forall>cl \<in> list_ran xs. correctClause rootcls cl \<and> sorted cl \<and> distinct cl)"

subsection {* Checker functions *}

primrec lres_thm :: "Clause option list \<Rightarrow> (Lit * ClauseId) \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "lres_thm xs (l, j) cli = (if (j < List.length xs) then (case (xs ! j) of
  None \<Rightarrow> raise (''MiniSatChecked.res_thm: No resolvant clause in thms array for Conflict step.'')
  | Some clj \<Rightarrow> res_thm' l cli clj
 ) else raise ''Error'')"

fun ldoProofStep :: " ProofStep \<Rightarrow> (Clause option list  * Clause list) \<Rightarrow> (Clause option list * Clause list) Heap"
where
  "ldoProofStep (Conflict saveTo (i, rs)) (xs, rcl) =
     (case (xs ! i) of
       None \<Rightarrow> raise (''MiniSatChecked.doProofStep: No starting clause in thms array for Conflict step.'')
     | Some cli \<Rightarrow> do {
                      result \<leftarrow> foldM (lres_thm xs) rs cli ;
                      return ((xs[saveTo:=Some result]), rcl)
                   })"
| "ldoProofStep (Delete cid) (xs, rcl) = return (xs[cid:=None], rcl)"
| "ldoProofStep (Root cid clause) (xs, rcl) = return (xs[cid:=Some (sort clause)], (remdups(sort clause)) # rcl)"
| "ldoProofStep (Xstep cid1 cid2) (xs, rcl) = raise ''MiniSatChecked.doProofStep: Xstep constructor found.''"
| "ldoProofStep (ProofDone b) (xs, rcl) = raise ''MiniSatChecked.doProofStep: ProofDone constructor found.''"

definition lchecker :: "nat \<Rightarrow> ProofStep list \<Rightarrow> nat \<Rightarrow> Clause list Heap"
where
  "lchecker n p i =
  do {
     rcs \<leftarrow> foldM (ldoProofStep) p ([], []);
     (if (fst rcs ! i) = Some [] then return (snd rcs)
                else raise(''No empty clause''))
  }"

section {* Functional version with RedBlackTrees *}

primrec tres_thm :: "(ClauseId, Clause) RBT_Impl.rbt \<Rightarrow> Lit \<times> ClauseId \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "tres_thm t (l, j) cli =
  (case (rbt_lookup t j) of
     None \<Rightarrow> raise (''MiniSatChecked.res_thm: No resolvant clause in thms array for Conflict step.'')
   | Some clj \<Rightarrow> res_thm' l cli clj)"

fun tdoProofStep :: " ProofStep \<Rightarrow> ((ClauseId, Clause) RBT_Impl.rbt * Clause list) \<Rightarrow> ((ClauseId, Clause) RBT_Impl.rbt * Clause list) Heap"
where
  "tdoProofStep (Conflict saveTo (i, rs)) (t, rcl) =
     (case (rbt_lookup t i) of
       None \<Rightarrow> raise (''MiniSatChecked.doProofStep: No starting clause in thms array for Conflict step.'')
     | Some cli \<Rightarrow> do {
                      result \<leftarrow> foldM (tres_thm t) rs cli;
                      return ((rbt_insert saveTo result t), rcl)
                   })"
| "tdoProofStep (Delete cid) (t, rcl) = return ((rbt_delete cid t), rcl)"
| "tdoProofStep (Root cid clause) (t, rcl) = return (rbt_insert cid (sort clause) t, (remdups(sort clause)) # rcl)"
| "tdoProofStep (Xstep cid1 cid2) (t, rcl) = raise ''MiniSatChecked.doProofStep: Xstep constructor found.''"
| "tdoProofStep (ProofDone b) (t, rcl) = raise ''MiniSatChecked.doProofStep: ProofDone constructor found.''"

definition tchecker :: "nat \<Rightarrow> ProofStep list \<Rightarrow> nat \<Rightarrow> Clause list Heap"
where
  "tchecker n p i =
  do {
     rcs \<leftarrow> foldM (tdoProofStep) p (RBT_Impl.Empty, []);
     (if (rbt_lookup (fst rcs) i) = Some [] then return (snd rcs)
                else raise(''No empty clause''))
  }"

export_code checker tchecker lchecker checking SML

end