section \<open> Design Signature and Core Laws \<close>

theory utp_des_core
imports "UTP1-KAT.utp_kleene"
begin

text \<open> UTP designs~\cite{Cavalcanti04,Hoare&98} are a subset of the alphabetised relations that
  use a boolean observational variable $ok$ to record the start and termination of a program. For
  more information on designs please see Chapter 3 of the UTP book~\cite{Hoare&98}, or
  the more accessible designs tutorial~\cite{Cavalcanti04}. \<close>

subsection \<open> Definitions \<close>

text \<open> Two named theorem sets exist are created to group theorems that, respectively, provide
  pre-postcondition definitions, and simplify operators to their normal design form. \<close>

named_theorems ndes and ndes_simp

alphabet des_vars =
  ok :: bool

text \<open>
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
\<close>

(*
interpretation des_vars: lens_interp "\<lambda>r. (ok\<^sub>v r, more r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation des_vars_rel:
  lens_interp "\<lambda>(r, r'). (ok\<^sub>v r, ok\<^sub>v r', more r, more r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done
*)

type_synonym '\<alpha> des  = "'\<alpha> des_vars_scheme"
type_synonym ('\<alpha>, '\<beta>) rel_des = "('\<alpha> des, '\<beta> des) urel"
type_synonym '\<alpha> hrel_des = "('\<alpha> des) hrel"

translations
  (type) "'\<alpha> des" <= (type) "'\<alpha> des_vars_scheme"
  (type) "'\<alpha> des" <= (type) "'\<alpha> des_vars_ext"
  (type) "('\<alpha>, '\<beta>) rel_des" <= (type) "('\<alpha> des, '\<beta> des) urel"
  (type) "'\<alpha> hrel_des" <= (type) "'\<alpha> des hrel"

notation des_vars.more\<^sub>L ("\<Sigma>\<^sub>D")

syntax
  "_svid_des_alpha"  :: "svid" ("\<^bold>v\<^sub>D")

translations
  "_svid_des_alpha" => "CONST des_vars.more\<^sub>L"

lemma ok_des_bij_lens: "bij_lens (ok +\<^sub>L \<Sigma>\<^sub>D)" (is "bij_lens ?P")
proof -
  have "?P \<approx>\<^sub>L 1\<^sub>L"
    by (meson des_vars.equivs(1) des_vars.equivs(2) des_vars.indeps(1) lens_equiv_sym lens_equiv_trans lens_plus_eq_left)
  thus ?thesis
    by (simp add: bij_lens_equiv_id)
qed

text \<open> Define the lens functor for designs \<close>

definition lmap_des_vars :: "('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> ('\<alpha> des_vars_scheme \<Longrightarrow> '\<beta> des_vars_scheme)" ("lmap\<^sub>D")
where [lens_defs]: "lmap_des_vars = lmap[des_vars]"

syntax "_lmap_des_vars" :: "salpha \<Rightarrow> salpha" ("lmap\<^sub>D[_]")
translations "_lmap_des_vars a" => "CONST lmap_des_vars a"

lemma lmap_des_vars: "vwb_lens f \<Longrightarrow> vwb_lens (lmap_des_vars f)"
  by (unfold_locales, auto simp add: lens_defs)

lemma lmap_id: "lmap\<^sub>D 1\<^sub>L = 1\<^sub>L"
  by (simp add: lens_defs fun_eq_iff)

lemma lmap_comp: "lmap\<^sub>D (f ;\<^sub>L g) = lmap\<^sub>D f ;\<^sub>L lmap\<^sub>D g"
  by (simp add: lens_defs fun_eq_iff)

text \<open> The following notations define liftings from non-design predicates into design
  predicates using alphabet extensions. \<close>

abbreviation lift_desr ("\<lceil>_\<rceil>\<^sub>D")
where "\<lceil>P\<rceil>\<^sub>D \<equiv> P \<oplus>\<^sub>p (\<Sigma>\<^sub>D \<times>\<^sub>L \<Sigma>\<^sub>D)"

utp_const lift_desr

abbreviation lift_pre_desr ("\<lceil>_\<rceil>\<^sub>D\<^sub><")
where "\<lceil>p\<rceil>\<^sub>D\<^sub>< \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub><\<rceil>\<^sub>D"

abbreviation lift_post_desr ("\<lceil>_\<rceil>\<^sub>D\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>D\<^sub>> \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub>>\<rceil>\<^sub>D"

abbreviation drop_desr ("\<lfloor>_\<rfloor>\<^sub>D")
where "\<lfloor>P\<rfloor>\<^sub>D \<equiv> P \<restriction>\<^sub>e (\<Sigma>\<^sub>D \<times>\<^sub>L \<Sigma>\<^sub>D)"

abbreviation dcond :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> '\<alpha> upred \<Rightarrow> ('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel_des"
where "dcond P b Q \<equiv> P \<triangleleft> \<lceil>b\<rceil>\<^sub>D\<^sub>< \<triangleright> Q"

syntax "_dcond" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(3_ \<triangleleft> _ \<triangleright>\<^sub>D/ _)" [52,0,53] 52)
translations "_dcond P b Q" == "CONST dcond P b Q"

definition design::"('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" (infixl "\<turnstile>" 59) where
[upred_defs]: "P \<turnstile> Q = ($ok \<and> P \<Rightarrow> $ok\<acute> \<and> Q)"

text \<open> An rdesign is a design that uses the Isabelle type system to prevent reference to ok in the
        assumption and commitment. \<close>

definition rdesign::"('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" (infixl "\<turnstile>\<^sub>r" 59) where
[upred_defs]: "(P \<turnstile>\<^sub>r Q) = \<lceil>P\<rceil>\<^sub>D \<turnstile> \<lceil>Q\<rceil>\<^sub>D"

text \<open> An ndesign is a normal design, i.e. where the assumption is a condition \<close>

definition ndesign::"'\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" (infixl "\<turnstile>\<^sub>n" 59) where
[upred_defs]: "(p \<turnstile>\<^sub>n Q) = (\<lceil>p\<rceil>\<^sub>< \<turnstile>\<^sub>r Q)"

definition skip_d :: "'\<alpha> hrel_des" ("II\<^sub>D") where
[upred_defs]: "II\<^sub>D \<equiv> (true \<turnstile>\<^sub>r II)"

definition bot_d :: "('\<alpha>, '\<beta>) rel_des" ("\<bottom>\<^sub>D") where
[upred_defs]: "\<bottom>\<^sub>D = (false \<turnstile> false)"

definition pre_design :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) urel" ("pre\<^sub>D") where
[upred_defs]: "pre\<^sub>D(P) = \<lfloor>\<not> P\<lbrakk>true,false/$ok,$ok\<acute>\<rbrakk>\<rfloor>\<^sub>D"

definition post_design :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) urel" ("post\<^sub>D") where
[upred_defs]: "post\<^sub>D(P) = \<lfloor>P\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>\<rfloor>\<^sub>D"

utp_const pre_design post_design

syntax
  "_ok_f"  :: "logic \<Rightarrow> logic" ("_\<^sup>f" [1000] 1000)
  "_ok_t"  :: "logic \<Rightarrow> logic" ("_\<^sup>t" [1000] 1000)
  "_top_d" :: "logic" ("\<top>\<^sub>D")

translations
  "P\<^sup>f" \<rightleftharpoons> "CONST usubst (CONST subst_upd id\<^sub>s (CONST out_var CONST ok) false) P"
  "P\<^sup>t" \<rightleftharpoons> "CONST usubst (CONST subst_upd id\<^sub>s (CONST out_var CONST ok) true) P"
  "\<top>\<^sub>D" => "CONST not_upred (CONST utp_expr.var (CONST in_var CONST ok))"

subsection \<open> Lifting, Unrestriction, and Substitution \<close>

lemma drop_desr_inv [simp]: "\<lfloor>\<lceil>P\<rceil>\<^sub>D\<rfloor>\<^sub>D = P"
  by (simp add: prod_mwb_lens)

lemma lift_desr_inv:
  fixes P :: "('\<alpha>, '\<beta>) rel_des"
  assumes "$ok \<sharp> P" "$ok\<acute> \<sharp> P"
  shows "\<lceil>\<lfloor>P\<rfloor>\<^sub>D\<rceil>\<^sub>D = P"
proof -
  have "bij_lens (\<Sigma>\<^sub>D \<times>\<^sub>L \<Sigma>\<^sub>D +\<^sub>L (in_var ok +\<^sub>L out_var ok) :: (_, '\<alpha> des_vars_scheme \<times> '\<beta> des_vars_scheme) lens)"
    (is "bij_lens (?P)")
  proof -
    have "?P \<approx>\<^sub>L (ok +\<^sub>L \<Sigma>\<^sub>D) \<times>\<^sub>L (ok +\<^sub>L \<Sigma>\<^sub>D)" (is "?P \<approx>\<^sub>L ?Q")
      apply (simp add: in_var_def out_var_def prod_as_plus)
      apply (simp add: prod_as_plus[THEN sym])
      apply (meson lens_equiv_sym lens_equiv_trans lens_indep_prod lens_plus_comm lens_plus_prod_exchange des_vars.indeps(1))
    done
    moreover have "bij_lens ?Q"
      by (simp add: ok_des_bij_lens prod_bij_lens)
    ultimately show ?thesis
      by (metis bij_lens_equiv lens_equiv_sym)
  qed

  with assms show ?thesis
    apply (rule_tac aext_arestr[of _ "in_var ok +\<^sub>L out_var ok"])
    apply (simp add: prod_mwb_lens)
    apply (simp)
    apply (metis alpha_in_var lens_indep_prod lens_indep_sym des_vars.indeps(1) out_var_def prod_as_plus)
    using unrest_var_comp apply blast
  done
qed

lemma unrest_out_des_lift [unrest]: "out\<alpha> \<sharp> p \<Longrightarrow> out\<alpha> \<sharp> \<lceil>p\<rceil>\<^sub>D"
  by (pred_simp)

lemma lift_dist_seq [simp]:
  "\<lceil>P ;; Q\<rceil>\<^sub>D = (\<lceil>P\<rceil>\<^sub>D ;; \<lceil>Q\<rceil>\<^sub>D)"
  by (rel_auto)

lemma lift_des_skip_dr_unit [simp]:
  "(\<lceil>P\<rceil>\<^sub>D ;; \<lceil>II\<rceil>\<^sub>D) = \<lceil>P\<rceil>\<^sub>D"
  "(\<lceil>II\<rceil>\<^sub>D ;; \<lceil>P\<rceil>\<^sub>D) = \<lceil>P\<rceil>\<^sub>D"
  by (rel_auto)+

lemma lift_des_skip_dr_unit_unrest: "$ok\<acute> \<sharp> P \<Longrightarrow> (P ;; \<lceil>II\<rceil>\<^sub>D) = P"
  by (rel_auto)

lemma state_subst_design [usubst]:
  "\<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> (P \<turnstile>\<^sub>r Q) = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P) \<turnstile>\<^sub>r (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> Q)"
  by (rel_auto)

lemma design_subst [usubst]:
  "\<lbrakk> $ok \<sharp>\<^sub>s \<sigma>; $ok\<acute> \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> (P \<turnstile> Q) = (\<sigma> \<dagger> P) \<turnstile> (\<sigma> \<dagger> Q)"
  by (simp add: design_def usubst usubst_apply_unrest)

lemma design_msubst [usubst]:
  "(P(x) \<turnstile> Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk> = (P(x)\<lbrakk>x\<rightarrow>v\<rbrakk> \<turnstile> Q(x)\<lbrakk>x\<rightarrow>v\<rbrakk>)"
  by (rel_auto)

lemma design_ok_false [usubst]: "(P \<turnstile> Q)\<lbrakk>false/$ok\<rbrakk> = true"
  by (simp add: design_def usubst)

lemma ok_pre: "($ok \<and> \<lceil>pre\<^sub>D(P)\<rceil>\<^sub>D) = ($ok \<and> (\<not> P\<^sup>f))"
  apply (simp add: pre_design_def alpha unrest usubst)
  apply (subst aext_arestr')
   apply (rel_simp)
  apply (rel_auto)
  done

lemma ok_post: "($ok \<and> \<lceil>post\<^sub>D(P)\<rceil>\<^sub>D) = ($ok \<and> (P\<^sup>t))"
  apply (simp add: post_design_def alpha unrest usubst)
  apply (subst aext_arestr')
   apply (rel_simp)
  apply (rel_auto)
  done

subsection \<open> Basic Design Laws \<close>

lemma design_export_ok: "P \<turnstile> Q = (P \<turnstile> ($ok \<and> Q))"
  by (rel_auto)

lemma design_export_ok': "P \<turnstile> Q = (P \<turnstile> ($ok\<acute> \<and> Q))"
  by (rel_auto)

lemma design_export_pre: "P \<turnstile> (P \<and> Q) = P \<turnstile> Q"
  by (rel_auto)

lemma design_export_spec: "P \<turnstile> (P \<Rightarrow> Q) = P \<turnstile> Q"
  by (rel_auto)

lemma design_ok_pre_conj: "($ok \<and> P) \<turnstile> Q = P \<turnstile> Q"
  by (rel_auto)

lemma true_is_design: "(false \<turnstile> true) = true"
  by (rel_auto)

lemma true_is_rdesign: "(false \<turnstile>\<^sub>r true) = true"
  by (rel_auto)

lemma bot_d_true: "\<bottom>\<^sub>D = true"
  by (rel_auto)

lemma bot_d_ndes_def [ndes_simp]: "\<bottom>\<^sub>D = (false \<turnstile>\<^sub>n true)"
  by (rel_auto)

lemma design_false_pre: "(false \<turnstile> P) = true"
  by (rel_auto)

lemma rdesign_false_pre: "(false \<turnstile>\<^sub>r P) = true"
  by (rel_auto)

lemma ndesign_false_pre: "(false \<turnstile>\<^sub>n P) = true"
  by (rel_auto)

lemma ndesign_miracle: "(true \<turnstile>\<^sub>n false) = \<top>\<^sub>D"
  by (rel_auto)

lemma top_d_ndes_def [ndes_simp]: "\<top>\<^sub>D = (true \<turnstile>\<^sub>n false)"
  by (rel_auto)

lemma skip_d_alt_def: "II\<^sub>D = true \<turnstile> II"
  by (rel_auto)

lemma skip_d_ndes_def [ndes_simp]: "II\<^sub>D = true \<turnstile>\<^sub>n II"
  by (rel_auto)

lemma design_subst_ok:
  "(P\<lbrakk>true/$ok\<rbrakk> \<turnstile> Q\<lbrakk>true/$ok\<rbrakk>) = (P \<turnstile> Q)"
  by (rel_auto)

lemma design_subst_ok_ok':
  "(P\<lbrakk>true/$ok\<rbrakk> \<turnstile> Q\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>) = (P \<turnstile> Q)"
proof -
  have "(P \<turnstile> Q) = (($ok \<and> P) \<turnstile> ($ok \<and> $ok\<acute> \<and> Q))"
    by (pred_auto)
  also have "... = (($ok \<and> P\<lbrakk>true/$ok\<rbrakk>) \<turnstile> ($ok \<and> ($ok\<acute> \<and> Q\<lbrakk>true/$ok\<acute>\<rbrakk>)\<lbrakk>true/$ok\<rbrakk>))"
    by (metis conj_eq_out_var_subst conj_pos_var_subst upred_eq_true utp_pred_laws.inf_commute ok_vwb_lens)
  also have "... = (($ok \<and> P\<lbrakk>true/$ok\<rbrakk>) \<turnstile> ($ok \<and> $ok\<acute> \<and> Q\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>))"
    by (simp add: usubst)
  also have "... = (P\<lbrakk>true/$ok\<rbrakk> \<turnstile> Q\<lbrakk>true,true/$ok,$ok\<acute>\<rbrakk>)"
    by (pred_auto)
  finally show ?thesis ..
qed

lemma design_subst_ok':
  "(P \<turnstile> Q\<lbrakk>true/$ok\<acute>\<rbrakk>) = (P \<turnstile> Q)"
proof -
  have "(P \<turnstile> Q) = (P \<turnstile> ($ok\<acute> \<and> Q))"
    by (pred_auto)
  also have "... = (P \<turnstile> ($ok\<acute> \<and> Q\<lbrakk>true/$ok\<acute>\<rbrakk>))"
    by (metis conj_eq_out_var_subst upred_eq_true utp_pred_laws.inf_commute ok_vwb_lens)
  also have "... = (P \<turnstile> Q\<lbrakk>true/$ok\<acute>\<rbrakk>)"
    by (pred_auto)
  finally show ?thesis ..
qed

subsection \<open> Sequential Composition Laws \<close>

theorem design_skip_idem [simp]:
  "(II\<^sub>D ;; II\<^sub>D) = II\<^sub>D"
  by (rel_auto)

theorem design_composition_subst:
  assumes
    "$ok\<acute> \<sharp> P1" "$ok \<sharp> P2"
  shows "((P1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) =
         (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (\<not> P2))) \<turnstile> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; Q2\<lbrakk>true/$ok\<rbrakk>))"
proof -
  have "((P1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) = (\<^bold>\<exists> ok\<^sub>0 \<bullet> ((P1 \<turnstile> Q1)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<acute>\<rbrakk> ;; (P2 \<turnstile> Q2)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<rbrakk>))"
    by (rule seqr_middle, simp)
  also have " ...
        = (((P1 \<turnstile> Q1)\<lbrakk>false/$ok\<acute>\<rbrakk> ;; (P2 \<turnstile> Q2)\<lbrakk>false/$ok\<rbrakk>)
            \<or> ((P1 \<turnstile> Q1)\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (P2 \<turnstile> Q2)\<lbrakk>true/$ok\<rbrakk>))"
    by (metis (no_types, lifting) calculation disj_comm ok_vwb_lens seqr_bool_split)
  also from assms
  have "... = ((($ok \<and> P1 \<Rightarrow> Q1\<lbrakk>true/$ok\<acute>\<rbrakk>) ;; (P2 \<Rightarrow> $ok\<acute> \<and> Q2\<lbrakk>true/$ok\<rbrakk>)) \<or> ((\<not> ($ok \<and> P1)) ;; true))"
    by (simp add: design_def usubst unrest, pred_auto)
  also have "... = ((\<not>$ok ;; true\<^sub>h) \<or> ((\<not>P1) ;; true) \<or> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (\<not>P2)) \<or> ($ok\<acute> \<and> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; Q2\<lbrakk>true/$ok\<rbrakk>)))"
    by (rel_auto)
  also have "... = (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (\<not> P2))) \<turnstile> (Q1\<lbrakk>true/$ok\<acute>\<rbrakk> ;; Q2\<lbrakk>true/$ok\<rbrakk>))"
    by (simp add: precond_right_unit design_def unrest, rel_auto)
  finally show ?thesis .
qed

theorem design_composition:
  assumes
    "$ok\<acute> \<sharp> P1" "$ok \<sharp> P2" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2"
  shows "((P1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) = (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile> (Q1 ;; Q2))"
  using assms by (simp add: design_composition_subst usubst)

theorem rdesign_composition:
  "((P1 \<turnstile>\<^sub>r Q1) ;; (P2 \<turnstile>\<^sub>r Q2)) = (((\<not> ((\<not> P1) ;; true)) \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile>\<^sub>r (Q1 ;; Q2))"
  by (simp add: rdesign_def design_composition unrest alpha)

theorem design_composition_cond:
  assumes
    "out\<alpha> \<sharp> p1" "$ok \<sharp> P2" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2"
  shows "((p1 \<turnstile> Q1) ;; (P2 \<turnstile> Q2)) = ((p1 \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile> (Q1 ;; Q2))"
  using assms
  by (simp add: design_composition unrest precond_right_unit)

theorem rdesign_composition_cond:
  assumes "out\<alpha> \<sharp> p1"
  shows "((p1 \<turnstile>\<^sub>r Q1) ;; (P2 \<turnstile>\<^sub>r Q2)) = ((p1 \<and> \<not> (Q1 ;; (\<not> P2))) \<turnstile>\<^sub>r (Q1 ;; Q2))"
  using assms
  by (simp add: rdesign_def design_composition_cond unrest alpha)

theorem design_composition_wp:
  assumes
    "ok \<sharp> p1" "ok \<sharp> p2"
    "$ok \<sharp> Q1" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2" "$ok\<acute> \<sharp> Q2"
  shows "((\<lceil>p1\<rceil>\<^sub>< \<turnstile> Q1) ;; (\<lceil>p2\<rceil>\<^sub>< \<turnstile> Q2)) = ((\<lceil>p1 \<and> Q1 wlp p2\<rceil>\<^sub><) \<turnstile> (Q1 ;; Q2))"
  using assms by (rel_blast)

theorem rdesign_composition_wp:
  "((\<lceil>p1\<rceil>\<^sub>< \<turnstile>\<^sub>r Q1) ;; (\<lceil>p2\<rceil>\<^sub>< \<turnstile>\<^sub>r Q2)) = ((\<lceil>p1 \<and> Q1 wlp p2\<rceil>\<^sub><) \<turnstile>\<^sub>r (Q1 ;; Q2))"
  by (rel_blast)

theorem ndesign_composition_wp [ndes_simp]:
  "((p1 \<turnstile>\<^sub>n Q1) ;; (p2 \<turnstile>\<^sub>n Q2)) = ((p1 \<and> Q1 wlp p2) \<turnstile>\<^sub>n (Q1 ;; Q2))"
  by (rel_blast)

theorem design_true_left_zero: "(true ;; (P \<turnstile> Q)) = true"
proof -
  have "(true ;; (P \<turnstile> Q)) = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>false/$ok\<rbrakk>) \<or> (true\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>))"
    by (rel_auto)
  also have "... = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; true\<^sub>h) \<or> (true ;; ((P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>)))"
    by (subst_tac, rel_auto)
  also have "... = true"
    by (subst_tac, simp add: precond_right_unit unrest)
  finally show ?thesis .
qed

theorem design_left_unit_hom:
  fixes P Q :: "'\<alpha> hrel_des"
  shows "(II\<^sub>D ;; (P \<turnstile>\<^sub>r Q)) = (P \<turnstile>\<^sub>r Q)"
proof -
  have "(II\<^sub>D ;; (P \<turnstile>\<^sub>r Q)) = ((true \<turnstile>\<^sub>r II) ;; (P \<turnstile>\<^sub>r Q))"
    by (simp add: skip_d_def)
  also have "... = (true \<and> \<not> (II ;; (\<not> P))) \<turnstile>\<^sub>r (II ;; Q)"
  proof -
    have "out\<alpha> \<sharp> true"
      by unrest_tac
    thus ?thesis
      using rdesign_composition_cond by blast
  qed
  also have "... = (\<not> (\<not> P)) \<turnstile>\<^sub>r Q"
    by simp
  finally show ?thesis by simp
qed

theorem rdesign_left_unit [simp]:
  "II\<^sub>D ;; (P \<turnstile>\<^sub>r Q) = (P \<turnstile>\<^sub>r Q)"
  by (rel_auto)

theorem design_right_semi_unit:
  "(P \<turnstile>\<^sub>r Q) ;; II\<^sub>D = ((\<not> (\<not> P) ;; true) \<turnstile>\<^sub>r Q)"
  by (simp add: skip_d_def rdesign_composition)

theorem design_right_cond_unit [simp]:
  assumes "out\<alpha> \<sharp> p"
  shows "(p \<turnstile>\<^sub>r Q) ;; II\<^sub>D = (p \<turnstile>\<^sub>r Q)"
  using assms
  by (simp add: skip_d_def rdesign_composition_cond)

theorem ndesign_left_unit [simp]:
  "II\<^sub>D ;; (p \<turnstile>\<^sub>n Q) = (p \<turnstile>\<^sub>n Q)"
  by (rel_auto)

theorem design_bot_left_zero: "(\<bottom>\<^sub>D ;; (P \<turnstile> Q)) = \<bottom>\<^sub>D"
  by (rel_auto)

theorem design_top_left_zero: "(\<top>\<^sub>D ;; (P \<turnstile> Q)) = \<top>\<^sub>D"
  by (rel_auto)

subsection \<open> Preconditions and Postconditions \<close>

theorem design_npre:
  "(P \<turnstile> Q)\<^sup>f = (\<not> $ok \<or> \<not> P\<^sup>f)"
  by (rel_auto)

theorem design_pre:
  "\<not> (P \<turnstile> Q)\<^sup>f = ($ok \<and> P\<^sup>f)"
  by (simp add: design_def, subst_tac)
     (metis (no_types, opaque_lifting) not_conj_deMorgans true_not_false(2) utp_pred_laws.compl_top_eq
            utp_pred_laws.sup.idem utp_pred_laws.sup_compl_top)

theorem design_post:
  "(P \<turnstile> Q)\<^sup>t = (($ok \<and> P\<^sup>t) \<Rightarrow> Q\<^sup>t)"
  by (rel_auto)

theorem rdesign_pre [simp]: "pre\<^sub>D(P \<turnstile>\<^sub>r Q) = P"
  by (pred_auto)

theorem rdesign_post [simp]: "post\<^sub>D(P \<turnstile>\<^sub>r Q) = (P \<Rightarrow> Q)"
  by (pred_auto)

theorem ndesign_pre [simp]: "pre\<^sub>D(p \<turnstile>\<^sub>n Q) = \<lceil>p\<rceil>\<^sub><"
  by (pred_auto)

theorem ndesign_post [simp]: "post\<^sub>D(p \<turnstile>\<^sub>n Q) = (\<lceil>p\<rceil>\<^sub>< \<Rightarrow> Q)"
  by (pred_auto)

lemma design_pre_choice [simp]:
  "pre\<^sub>D(P \<sqinter> Q) = (pre\<^sub>D(P) \<and> pre\<^sub>D(Q))"
  by (rel_auto)

lemma design_post_choice [simp]:
  "post\<^sub>D(P \<sqinter> Q) = (post\<^sub>D(P) \<or> post\<^sub>D(Q))"
  by (rel_auto)

lemma design_pre_condr [simp]:
  "pre\<^sub>D(P \<triangleleft> \<lceil>b\<rceil>\<^sub>D \<triangleright> Q) = (pre\<^sub>D(P) \<triangleleft> b \<triangleright> pre\<^sub>D(Q))"
  by (rel_auto)

lemma design_post_condr [simp]:
  "post\<^sub>D(P \<triangleleft> \<lceil>b\<rceil>\<^sub>D \<triangleright> Q) = (post\<^sub>D(P) \<triangleleft> b \<triangleright> post\<^sub>D(Q))"
  by (rel_auto)

lemma preD_USUP_mem: "pre\<^sub>D (\<Squnion> i\<in>A \<bullet> P i) = (\<Sqinter> i\<in>A \<bullet> pre\<^sub>D(P i))"
  by (rel_auto)

lemma preD_USUP_ind: "pre\<^sub>D (\<Squnion> i \<bullet> P i) = (\<Sqinter> i \<bullet> pre\<^sub>D(P i))"
  by (rel_auto)

subsection \<open> Distribution Laws \<close>

theorem design_choice:
  "(P\<^sub>1 \<turnstile> P\<^sub>2) \<sqinter> (Q\<^sub>1 \<turnstile> Q\<^sub>2) = ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> (P\<^sub>2 \<or> Q\<^sub>2))"
  by (rel_auto)

theorem rdesign_choice:
  "(P\<^sub>1 \<turnstile>\<^sub>r P\<^sub>2) \<sqinter> (Q\<^sub>1 \<turnstile>\<^sub>r Q\<^sub>2) = ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile>\<^sub>r (P\<^sub>2 \<or> Q\<^sub>2))"
  by (rel_auto)

theorem ndesign_choice [ndes_simp]:
  "(p\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2) \<sqinter> (q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2) = ((p\<^sub>1 \<and> q\<^sub>1) \<turnstile>\<^sub>n (P\<^sub>2 \<or> Q\<^sub>2))"
  by (rel_auto)

theorem ndesign_choice' [ndes_simp]:
  "((p\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2) \<or> (q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2)) = ((p\<^sub>1 \<and> q\<^sub>1) \<turnstile>\<^sub>n (P\<^sub>2 \<or> Q\<^sub>2))"
  by (rel_auto)

theorem design_inf:
  "(P\<^sub>1 \<turnstile> P\<^sub>2) \<squnion> (Q\<^sub>1 \<turnstile> Q\<^sub>2) = ((P\<^sub>1 \<or> Q\<^sub>1) \<turnstile> ((P\<^sub>1 \<Rightarrow> P\<^sub>2) \<and> (Q\<^sub>1 \<Rightarrow> Q\<^sub>2)))"
  by (rel_auto)

theorem rdesign_inf:
  "(P\<^sub>1 \<turnstile>\<^sub>r P\<^sub>2) \<squnion> (Q\<^sub>1 \<turnstile>\<^sub>r Q\<^sub>2) = ((P\<^sub>1 \<or> Q\<^sub>1) \<turnstile>\<^sub>r ((P\<^sub>1 \<Rightarrow> P\<^sub>2) \<and> (Q\<^sub>1 \<Rightarrow> Q\<^sub>2)))"
  by (rel_auto)

theorem ndesign_inf [ndes_simp]:
  "(p\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2) \<squnion> (q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2) = ((p\<^sub>1 \<or> q\<^sub>1) \<turnstile>\<^sub>n ((\<lceil>p\<^sub>1\<rceil>\<^sub>< \<Rightarrow> P\<^sub>2) \<and> (\<lceil>q\<^sub>1\<rceil>\<^sub>< \<Rightarrow> Q\<^sub>2)))"
  by (rel_auto)

theorem design_condr:
  "((P\<^sub>1 \<turnstile> P\<^sub>2) \<triangleleft> b \<triangleright> (Q\<^sub>1 \<turnstile> Q\<^sub>2)) = ((P\<^sub>1 \<triangleleft> b \<triangleright> Q\<^sub>1) \<turnstile> (P\<^sub>2 \<triangleleft> b \<triangleright> Q\<^sub>2))"
  by (rel_auto)

theorem ndesign_dcond [ndes_simp]:
  "((p\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2) \<triangleleft> b \<triangleright>\<^sub>D (q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2)) = ((p\<^sub>1 \<triangleleft> b \<triangleright> q\<^sub>1) \<turnstile>\<^sub>n (P\<^sub>2 \<triangleleft> b \<triangleright>\<^sub>r Q\<^sub>2))"
  by (rel_auto)

lemma design_UINF_mem:
  assumes "A \<noteq> {}"
  shows "(\<Sqinter> i \<in> A \<bullet> P(i) \<turnstile> Q(i)) = (\<Squnion> i \<in> A \<bullet> P(i)) \<turnstile> (\<Sqinter> i \<in> A \<bullet> Q(i))"
  using assms by (rel_auto)

lemma ndesign_UINF_mem [ndes_simp]:
  assumes "A \<noteq> {}"
  shows "(\<Sqinter> i \<in> A \<bullet> p(i) \<turnstile>\<^sub>n Q(i)) = (\<Squnion> i \<in> A \<bullet> p(i)) \<turnstile>\<^sub>n (\<Sqinter> i \<in> A \<bullet> Q(i))"
  using assms by (rel_auto)

lemma ndesign_UINF_ind [ndes_simp]:
  "(\<Sqinter> i \<bullet> p(i) \<turnstile>\<^sub>n Q(i)) = (\<Squnion> i \<bullet> p(i)) \<turnstile>\<^sub>n (\<Sqinter> i \<bullet> Q(i))"
  by (rel_auto)

lemma design_USUP_mem:
  "(\<Squnion> i \<in> A \<bullet> P(i) \<turnstile> Q(i)) = (\<Sqinter> i \<in> A \<bullet> P(i)) \<turnstile> (\<Squnion> i \<in> A \<bullet> P(i) \<Rightarrow> Q(i))"
  by (rel_auto)

lemma ndesign_USUP_mem [ndes_simp]:
  "(\<Squnion> i \<in> A \<bullet> p(i) \<turnstile>\<^sub>n Q(i)) = (\<Sqinter> i \<in> A \<bullet> p(i)) \<turnstile>\<^sub>n (\<Squnion> i \<in> A \<bullet> \<lceil>p(i)\<rceil>\<^sub>< \<Rightarrow> Q(i))"
  by (rel_auto)

lemma ndesign_USUP_ind [ndes_simp]:
  "(\<Squnion> i \<bullet> p(i) \<turnstile>\<^sub>n Q(i)) = (\<Sqinter> i \<bullet> p(i)) \<turnstile>\<^sub>n (\<Squnion> i \<bullet> \<lceil>p(i)\<rceil>\<^sub>< \<Rightarrow> Q(i))"
  by (rel_auto)

subsection \<open> Refinement Introduction \<close>

lemma ndesign_eq_intro:
  assumes "p\<^sub>1 = q\<^sub>1" "P\<^sub>2 = Q\<^sub>2"
  shows "p\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2 = q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2"
  by (simp add: assms)

theorem design_refinement:
  assumes
    "$ok \<sharp> P1" "$ok\<acute> \<sharp> P1" "$ok \<sharp> P2" "$ok\<acute> \<sharp> P2"
    "$ok \<sharp> Q1" "$ok\<acute> \<sharp> Q1" "$ok \<sharp> Q2" "$ok\<acute> \<sharp> Q2"
  shows "(P1 \<turnstile> Q1 \<sqsubseteq> P2 \<turnstile> Q2) \<longleftrightarrow> (`P1 \<Rightarrow> P2` \<and> `P1 \<and> Q2 \<Rightarrow> Q1`)"
proof -
  have "(P1 \<turnstile> Q1) \<sqsubseteq> (P2 \<turnstile> Q2) \<longleftrightarrow> `($ok \<and> P2 \<Rightarrow> $ok\<acute> \<and> Q2) \<Rightarrow> ($ok \<and> P1 \<Rightarrow> $ok\<acute> \<and> Q1)`"
    by (pred_auto)
  also with assms have "... = `(P2 \<Rightarrow> $ok\<acute> \<and> Q2) \<Rightarrow> (P1 \<Rightarrow> $ok\<acute> \<and> Q1)`"
    by (subst subst_bool_split[of "in_var ok"], simp_all, subst_tac)
  also with assms have "... = `(\<not> P2 \<Rightarrow> \<not> P1) \<and> ((P2 \<Rightarrow> Q2) \<Rightarrow> P1 \<Rightarrow> Q1)`"
    by (subst subst_bool_split[of "out_var ok"], simp_all, subst_tac)
  also have "... \<longleftrightarrow> `(P1 \<Rightarrow> P2)` \<and> `P1 \<and> Q2 \<Rightarrow> Q1`"
    by (pred_auto)
  finally show ?thesis .
qed

theorem rdesign_refinement:
  "(P1 \<turnstile>\<^sub>r Q1 \<sqsubseteq> P2 \<turnstile>\<^sub>r Q2) \<longleftrightarrow> (`P1 \<Rightarrow> P2` \<and> `P1 \<and> Q2 \<Rightarrow> Q1`)"
  by (rel_auto)

lemma design_refine_intro:
  assumes "`P1 \<Rightarrow> P2`" "`P1 \<and> Q2 \<Rightarrow> Q1`"
  shows "P1 \<turnstile> Q1 \<sqsubseteq> P2 \<turnstile> Q2"
  using assms unfolding upred_defs
  by (pred_auto)

lemma design_refine_intro':
  assumes "P\<^sub>2 \<sqsubseteq> P\<^sub>1" "Q\<^sub>1 \<sqsubseteq> (P\<^sub>1 \<and> Q\<^sub>2)"
  shows "P\<^sub>1 \<turnstile> Q\<^sub>1 \<sqsubseteq> P\<^sub>2 \<turnstile> Q\<^sub>2"
  using assms design_refine_intro[of P\<^sub>1 P\<^sub>2 Q\<^sub>2 Q\<^sub>1] by (simp add: refBy_order)

lemma rdesign_refine_intro:
  assumes "`P1 \<Rightarrow> P2`" "`P1 \<and> Q2 \<Rightarrow> Q1`"
  shows "P1 \<turnstile>\<^sub>r Q1 \<sqsubseteq> P2 \<turnstile>\<^sub>r Q2"
  using assms unfolding upred_defs
  by (pred_auto)

lemma rdesign_refine_intro':
  assumes "P2 \<sqsubseteq> P1" "Q1 \<sqsubseteq> (P1 \<and> Q2)"
  shows "P1 \<turnstile>\<^sub>r Q1 \<sqsubseteq> P2 \<turnstile>\<^sub>r Q2"
  using assms unfolding upred_defs
  by (pred_auto)

lemma ndesign_refinement:
  "p1 \<turnstile>\<^sub>n Q1 \<sqsubseteq> p2 \<turnstile>\<^sub>n Q2 \<longleftrightarrow> (`p1 \<Rightarrow> p2` \<and> `\<lceil>p1\<rceil>\<^sub>< \<and> Q2 \<Rightarrow> Q1`)"
  by (simp add: ndesign_def rdesign_def design_refinement unrest, rel_auto)

lemma ndesign_refinement':
  "p1 \<turnstile>\<^sub>n Q1 \<sqsubseteq> p2 \<turnstile>\<^sub>n Q2 \<longleftrightarrow> (`p1 \<Rightarrow> p2` \<and> Q1 \<sqsubseteq> ?[p1] ;; Q2)"
  by (simp add: ndesign_refinement, rel_auto)

lemma ndesign_refine_intro:
  assumes "`p1 \<Rightarrow> p2`" "Q1 \<sqsubseteq> ?[p1] ;; Q2"
  shows "p1 \<turnstile>\<^sub>n Q1 \<sqsubseteq> p2 \<turnstile>\<^sub>n Q2"
  by (simp add: ndesign_refinement' assms)

lemma design_top:
  "(P \<turnstile> Q) \<sqsubseteq> \<top>\<^sub>D"
  by (rel_auto)

lemma design_bottom:
  "\<bottom>\<^sub>D \<sqsubseteq> (P \<turnstile> Q)"
  by (rel_auto)

lemma design_refine_thms:
  assumes "P \<sqsubseteq> Q"
  shows "`pre\<^sub>D(P) \<Rightarrow> pre\<^sub>D(Q)`" "`pre\<^sub>D(P) \<and> post\<^sub>D(Q) \<Rightarrow> post\<^sub>D(P)`"
  apply (metis assms design_pre_choice disj_comm disj_upred_def order_refl rdesign_refinement utp_pred_laws.le_iff_sup)
  apply (metis assms conj_comm design_post_choice disj_upred_def refBy_order semilattice_sup_class.le_iff_sup utp_pred_laws.inf.coboundedI1)
done

end


section \<open>Additions to Lars Noschinski's Graph Library\<close>
theory More_Graph_Theory
  imports "Graph_Theory.Graph_Theory"
begin

lemma vwalkE2:
  assumes "vwalk p G"
  obtains u where "p = [u]" "u \<in> verts G"
    | u v es where "p = u # v # es" "(u,v) \<in> arcs_ends G" "vwalk (v # es) G"
  by (metis assms list.sel(1) vwalkE vwalk_consE vwalk_singleton vwalk_to_vpath.cases)

lemma (in wf_digraph) reachable_vwalk_conv2:
  "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v \<longleftrightarrow> (u = v \<and> u \<in> verts G \<or> (\<exists>vs. vwalk (u # vs @ [v]) G))"
  unfolding reachable_vwalk_conv
  apply (rule iffI)
   apply (elim exE conjE, erule vwalkE2, (simp; fail),
      metis last.simps last_snoc list.distinct(1) list.sel(1) rev_exhaust vwalk_Cons_Cons)
  apply force
  done

context pre_digraph
begin

definition
  "scc_graph = \<lparr>
    verts = sccs_verts,
    arcs = {(x, y). \<exists>a \<in> x. \<exists>b \<in> y. x \<noteq> y \<and> x \<in> sccs_verts \<and> y \<in> sccs_verts \<and> a \<rightarrow> b},
    tail = fst,
    head = snd
  \<rparr>"

interpretation scc_digraph: loopfree_digraph scc_graph
  by standard (auto simp: scc_graph_def)

lemmas scc_digraphI = scc_digraph.loopfree_digraph_axioms

end

context wf_digraph
begin

interpretation scc_digraph: loopfree_digraph scc_graph
  by (rule scc_digraphI)

lemma scc_graph_edgeE:
  assumes \<open>x \<rightarrow>\<^bsub>scc_graph\<^esub> y\<close> obtains a b where
    "a \<in> x" "b \<in> y" "a \<rightarrow> b" "x \<in> sccs_verts" "y \<in> sccs_verts" "x \<noteq> y"
    using assms by (force simp: scc_graph_def dest!: in_arcs_imp_in_arcs_ends)

lemma same_sccI:
  assumes "S \<in> sccs_verts" "x \<in> S" "x \<rightarrow>\<^sup>* y" "y \<rightarrow>\<^sup>* x"
  shows "y \<in> S"
  using assms by (auto simp: in_sccs_verts_conv_reachable)

lemma scc_graph_reachable1E:
  assumes \<open>x \<rightarrow>\<^sup>+\<^bsub>scc_graph\<^esub> y\<close> obtains a b where
    "x \<in> sccs_verts " "y \<in> sccs_verts " "x \<noteq> y" "a \<in> x" "b \<in> y" "a \<rightarrow>\<^sup>+ b"
  using assms
proof (atomize_elim, induction)
  case (base y)
  then show ?case
    by (auto elim!: scc_graph_edgeE)
next
  case (step y z)
  then obtain a b where IH: "x \<in> sccs_verts" "y \<in> sccs_verts" "a \<in> x" "b \<in> y" "a \<rightarrow>\<^sup>+ b" "x \<noteq> y"
    by auto
  from \<open>y \<rightarrow>\<^bsub>scc_graph\<^esub> z\<close> obtain b' c where *:
    "b' \<in> y" "c \<in> z" "b' \<rightarrow> c" "y \<in> sccs_verts" "z \<in> sccs_verts"
    by (elim scc_graph_edgeE)
  with \<open>b \<in> y\<close> have "b \<rightarrow>\<^sup>* b'"
    by (simp add: in_sccs_verts_conv_reachable)
  with \<open>b' \<rightarrow> c\<close> \<open>a \<rightarrow>\<^sup>+ b\<close> have "a \<rightarrow>\<^sup>+ c"
    using reachable1_reachable_trans by blast
  moreover have "x \<noteq> z"
  proof (rule ccontr, simp)
    assume "x = z"
    with \<open>a \<in> x\<close> \<open>c \<in> z\<close> \<open>x \<in> _\<close> have "c \<rightarrow>\<^sup>* a"
      by (simp add: in_sccs_verts_conv_reachable)
    with \<open>b \<rightarrow>\<^sup>* b'\<close> \<open>b' \<rightarrow> c\<close> have "b \<rightarrow>\<^sup>* a" \<comment> \<open>XXX: This should really be \<open>by simp\<close>\<close>
      by (meson reachable_adj_trans reachable_trans)
    with IH have "b \<in> x"
      by - (rule same_sccI, auto)
    with sccs_verts_disjoint IH show False
      by auto
  qed
  ultimately show ?case
    using IH * by auto
qed

end

locale dag = wf_digraph +
  assumes acyclic: "x \<rightarrow>\<^sup>+ x \<Longrightarrow> False"

locale fin_dag = fin_digraph + dag

context wf_digraph
begin

interpretation scc_digraph: loopfree_digraph scc_graph
  by (rule scc_digraphI)

interpretation scc_digraph: dag scc_graph
  by standard (auto elim: scc_graph_reachable1E)

lemmas scc_digraphI = scc_digraph.dag_axioms

end

context fin_digraph
begin

interpretation scc_digraph: dag scc_graph
  thm scc_digraphI
  by (rule scc_digraphI)

interpretation scc_digraph: fin_dag scc_graph
  apply standard
  unfolding scc_graph_def
  subgoal finite_verts
    by (simp add: finite_sccs_verts)
  subgoal finite_arcs
    using finite_sccs_verts
    by - (rule finite_subset[where B = "{(x, y). x \<in> sccs_verts \<and> y \<in> sccs_verts}"], auto)
  done

lemmas scc_digraphI = scc_digraph.fin_dag_axioms

end

subsection \<open>Helper lemmas for directed tree\<close>

lemma (in wf_digraph) awalk_not_distinct:
  assumes "finite (verts G)" and "awalk u p v" and "length p \<ge> card (verts G)"
  shows "\<not> distinct (awalk_verts u p)"
proof -
  have *: "length (awalk_verts u p) > length p"
    by (induction p arbitrary: u) auto

  show ?thesis
  proof(cases "length p = 0")
    case True
    with assms show ?thesis unfolding awalk_def by simp
  next
    case False
    with assms * have "length (awalk_verts u p) > card (verts G)"
      by auto
    moreover
    have "set (awalk_verts u p) \<subseteq> verts G" using assms(2) by blast
    ultimately show ?thesis using assms(1)
      by (induction p arbitrary: u)
         (auto, metis card_subset_eq distinct_card less_antisym)
  qed
qed

lemma (in wf_digraph) awalk_del_vert:
  "\<lbrakk> awalk u p v; x \<notin> set (awalk_verts u p) \<rbrakk> \<Longrightarrow> pre_digraph.awalk (del_vert x) u p v"
proof(induction p arbitrary: u)
  case Nil
  then have "set (awalk_verts u []) = {u}" by auto
  with Nil have "x \<noteq> u" by simp
  moreover
  from Nil have "u = v" unfolding awalk_def by auto
  ultimately show ?case using Nil
    by (simp add: awalk_hd_in_verts pre_digraph.verts_del_vert
        wf_digraph.awalk_Nil_iff wf_digraph_del_vert)
next
  case (Cons a p)
  then obtain u' where u': "pre_digraph.awalk (del_vert x) u' p v"
    using awalk_Cons_iff by auto
  moreover
  from Cons.prems have "head G a \<noteq> x"
    using hd_in_awalk_verts(1) awalk_Cons_iff by auto
  ultimately show ?case using Cons
    by (auto simp: awalk_Cons_iff head_del_vert pre_digraph.del_vert_simps(2)
        tail_del_vert wf_digraph.awalk_Cons_iff wf_digraph_del_vert)
qed

text \<open>This is an alternative formulation of @{thm pre_digraph.arcs_del_vert}.\<close>
lemma (in pre_digraph) arcs_del_vert2:
  "arcs (del_vert v) = arcs G - in_arcs G v - out_arcs G v"
  using arcs_del_vert by force

lemma (in wf_digraph) sp_non_neg_if_w_non_neg:
  assumes w_non_neg: "\<forall>e \<in> arcs G. w e \<ge> 0"
  shows "\<mu> w u v \<ge> 0"
proof(cases "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v")
  case True
  have *: "awalk u p v \<Longrightarrow> awalk_cost w p \<ge> 0" for p
    by (simp add: pos_cost_pos_awalk_cost w_non_neg)
  then show ?thesis unfolding \<mu>_def
    by (metis (mono_tags, lifting) INF_less_iff ereal_less_eq(5) mem_Collect_eq not_less)
next
  case False
  then show ?thesis by (simp add: shortest_path_inf)
qed

end


theory TopoS_Impl
imports TopoS_Library TopoS_Composition_Theory_impl
    "Lib/ML_GraphViz"
    TopoS_Stateful_Policy_impl
begin

section {* ML Visualization Interface *}

subsection{*Utility Functions*}

  fun rembiflowdups :: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
    "rembiflowdups [] = []" |
    "rembiflowdups ((s,r)#as) = (if (s,r) \<in> set as \<or> (r,s) \<in> set as then rembiflowdups as else (s,r)#rembiflowdups as)"

  lemma rembiflowdups_complete: "\<lbrakk> \<forall>(s,r) \<in> set x. (r,s) \<in> set x \<rbrakk> \<Longrightarrow> set (rembiflowdups x) \<union> set (backlinks (rembiflowdups x)) = set x"
    proof
      assume a: "\<forall>(s,r) \<in> set x. (r,s) \<in> set x"
      have subset1: "set (rembiflowdups x) \<subseteq> set x"
        apply(induction x)
         apply(simp)
        apply(clarsimp)
        apply(simp split: split_if_asm)
         by(blast)+
      have set_backlinks_simp: "\<And> x. \<forall>(s,r) \<in> set x. (r,s) \<in> set x \<Longrightarrow> set (backlinks x) = set x"
        apply(simp add: backlinks_set)
        apply(rule)
         by fast+
      have subset2: "set (backlinks (rembiflowdups x)) \<subseteq> set x"
        apply(subst set_backlinks_simp[OF a, symmetric])
        by(simp add: backlinks_subset subset1)

      from subset1 subset2
      show "set (rembiflowdups x) \<union> set (backlinks (rembiflowdups x)) \<subseteq> set x" by blast
    next
      show "set x \<subseteq> set (rembiflowdups x) \<union> set (backlinks (rembiflowdups x))"
        apply(rule)
        apply(induction x)
         apply(simp)
        apply(rename_tac a as e)
        apply(simp)
        apply(erule disjE)
         apply(simp)
         defer
         apply fastforce
        apply(case_tac a)
        apply(rename_tac s r)
        apply(case_tac "(s,r) \<notin> set as \<and> (r,s) \<notin> set as")
         apply(simp)
        apply(simp add: backlinks_set)
        by blast
      qed

  text{*only for prettyprinting*}
  definition filter_for_biflows:: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
    "filter_for_biflows E \<equiv> [e \<leftarrow> E. (snd e, fst e) \<in> set E]"

  definition filter_for_uniflows:: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
    "filter_for_uniflows E \<equiv> [e \<leftarrow> E. (snd e, fst e) \<notin> set E]"

  lemma filter_for_biflows_correct: "\<forall>(s,r) \<in> set (filter_for_biflows E). (r,s) \<in> set (filter_for_biflows E)"
    unfolding filter_for_biflows_def
    by(induction E, auto)

  lemma filter_for_biflows_un_filter_for_uniflows: "set (filter_for_biflows E) \<union> set (filter_for_uniflows E) = set E"
    apply(simp add: filter_for_biflows_def filter_for_uniflows_def) by blast

  definition partition_by_biflows :: "('a \<times> 'a) list \<Rightarrow> (('a \<times> 'a) list \<times> ('a \<times> 'a) list)" where
    "partition_by_biflows E \<equiv> (rembiflowdups (filter_for_biflows E), remdups (filter_for_uniflows E))"

  lemma partition_by_biflows_correct: "case partition_by_biflows E of (biflows, uniflows) \<Rightarrow> set biflows \<union> set (backlinks (biflows)) \<union> set uniflows = set E"
    apply(simp add: partition_by_biflows_def)
    by(simp add: filter_for_biflows_un_filter_for_uniflows filter_for_biflows_correct rembiflowdups_complete)

  lemma "partition_by_biflows [(1::int, 1::int), (1,2), (2, 1), (1,3)] = ([(1, 1), (2, 1)], [(1, 3)])" by eval

ML{*
(*apply args to f. f ist best supplied using @{const_name "name_of_function"} *)
fun apply_function (ctx: Proof.context) (f: string) (args: term list) : term =
  let
    val _ = writeln ("applying "^f^" to ");
    val _ = List.map (fn t => Pretty.writeln (Syntax.pretty_term (Config.put show_types true ctx) t)) args;
    (*val t_eval = Code_Evaluation.dynamic_value_strict thy t;*)
    (* $ associates to the left, give f its arguments*)
    val applied_untyped_uneval : term = List.foldl (fn (t, a) => a $ t) (Const (f, dummyT)) args;
    val applied_uneval: term = Syntax.check_term ctx applied_untyped_uneval;
  in
    applied_uneval |>  Code_Evaluation.dynamic_value_strict ctx
  end;

(*ctx -> thy -> edges -> (biflows, uniflows)*)
fun partition_by_biflows (ctx: Proof.context) (t: term) : (term * term) =
  apply_function ctx @{const_name "partition_by_biflows"} [t] |> HOLogic.dest_prod

local
  fun get_tune_node_format (edges: term) : term -> string -> string =
    if (fastype_of edges) = @{typ "(TopoS_Vertices.vString \<times> TopoS_Vertices.vString) list"}
    then
      tune_Vstring_format
    else
      Graphviz.default_tune_node_format;

  fun evalutae_term (ctx: Proof.context) (edges: term) : term =
    case Code_Evaluation.dynamic_value ctx edges
      of SOME x => x
      | NONE => raise TERM ("could not evaluate", []);
in
  fun visualize_edges (ctx: Proof.context) (edges: term) (coloredges: (string * term) list): int =
    let
      val _ = writeln("visualize_edges");
      val (biflows, uniflows) = partition_by_biflows ctx edges;
    in
      Graphviz.visualize_graph_pretty ctx (get_tune_node_format edges) ([
      ("", uniflows),
      ("edge [dir=\"none\", color=\"#000000\"]", biflows)] @ coloredges) (*dir=none, dir=both*)
    end

  (*iterate over the edges in ML, usefull for printing them in certain formats*)
  fun iterate_edges_ML (ctx: Proof.context) (edges: term) (all: (string*string) -> unit) (bi: (string*string) -> unit) (uni: (string*string) -> unit): unit =
    let
      val _ = writeln("iterate_edges_ML");
      val tune_node_format = (get_tune_node_format edges);
      val evaluated_edges : term = evalutae_term ctx edges;
      val (biflows, uniflows) = partition_by_biflows ctx evaluated_edges;
      fun node_to_string (n: term) : string = n |> Syntax.pretty_term ctx |> Pretty.string_of |> ATP_Util.unyxml |> tune_node_format n
          handle Subscript => let
            val _ = writeln ("Subscript Exception in iterate_edges_ML: node_to_string");
          in "ERROR" end;
    in
      let
        fun edge_to_list (es: term) : (term * term) list = es |> HOLogic.dest_list |> map HOLogic.dest_prod;
        fun edge_to_string (es: (term * term) list) : (string * string) list =
          List.map (fn (v1, v2) => (node_to_string v1, node_to_string v2)) es
          handle Subscript => let
            val _ = writeln ("Subscript Exception in iterate_edges_ML: edge_to_string");
            val _ = List.map (fn (v1, _) => Pretty.writeln (Syntax.pretty_term ctx v1)) es;
            val _ = List.map (fn (_, v2) => Pretty.writeln (Syntax.pretty_term ctx v2)) es;
            in [] end;
      in
        edge_to_list evaluated_edges |> edge_to_string |> List.map all;
        edge_to_list biflows |> edge_to_string |> List.map bi;
        edge_to_list uniflows |> edge_to_string |> List.map uni;
        ()
      end
      handle Subscript => writeln ("Subscript Exception in iterate_edges_ML")
    end;

end
*}

ML_val{*
local
  val (biflows, uniflows) = partition_by_biflows @{context} @{term "[(1::int, 1::int), (1,2), (2, 1), (1,3)]"};
in
  val _ = Pretty.writeln (Syntax.pretty_term (Config.put show_types true @{context}) biflows);
  val _ = Pretty.writeln (Syntax.pretty_term (Config.put show_types true @{context}) uniflows);
end;

val t = fastype_of @{term "[(TopoS_Vertices.V ''x'', 2::nat)]"}

(*
visualize_edges @{context} @{theory} @{term "[(1::int, 1::int), (1,2), (2, 1), (1,3)]"} []; *)
*}

ML {*
(*M: security requirements, list
  G: list_graph*)
fun vizualize_graph (ctx: Proof.context) (M: term) (G: term): unit =
  let
    val all_fulfilled = apply_function ctx @{const_name "all_security_requirements_fulfilled"} [M, G];
    val edges = apply_function ctx @{const_name "edgesL"} [G];
  in
    if all_fulfilled = @{term "False"} then
      (let
        val offending = apply_function ctx @{const_name "implc_get_offending_flows"} [M, G];
        val offending_flat = apply_function ctx @{const_name "List.remdups"} [apply_function ctx @{const_name "List.concat"} [offending]];
      in
       writeln("offending flows:");
       Pretty.writeln (Syntax.pretty_term ctx offending);
       visualize_edges ctx edges [("edge [dir=\"arrow\", style=dashed, color=\"#FF0000\", constraint=false]", offending_flat)];
      () end)
    else if all_fulfilled <> @{term "True"} then raise ERROR "all_fulfilled neither False nor True" else (
       writeln("check TRUE");
       writeln("All valid:");
       visualize_edges ctx edges [];
      ())
  end;
*}

end


(*
 * Copyright 2018, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

(*
 * Given a list of mappings "[(k1, v1), (k2, v2), ...]", define a function that performs the mapping.
 * If none of the keys match, the default value is returned.
 * If multiple keys match, the first one is used. (So having duplicate keys is useless.)
 *
 * Analogue of C-parser's StaticFun but without the linorder requirement.
 * Uses an assoc-list instead of binary tree. This makes the setup cost O(n^2) but
 * the lookup cost is unchanged (we prove the same equations as StaticFun does).
 *
 * TODO: move to l4v/lib (or further upstream)
 *)
theory AssocLookup imports
  Main
begin

fun assoc_lookup :: "('a \<times> 'b) list \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b" where
    "assoc_lookup [] def _ = def"
  | "assoc_lookup ((k, v) # ls) def x = (if x = k then v else assoc_lookup ls def x)"

(* These versions are better for simp performance *)
lemma assoc_lookup_simps[simp]:
  "assoc_lookup [] def x = def"
  "assoc_lookup ((k, v) # ls) def k = v"
  (* make_assoc_fun shouldn't need this one *)
  (*"x = k \<Longrightarrow> assoc_lookup ((k, v) # ls) def x = v"*)
  "x \<noteq> k \<Longrightarrow> assoc_lookup ((k, v) # ls) def x = assoc_lookup ls def x"
  by simp_all
declare assoc_lookup.simps[simp del]

(*
 * Main interface.
 * Note that all types in "assocs" and "default" need to match,
 * this procedure doesn't do type unification. *)
ML \<open>
structure AssocLookup = struct

fun make_assoc_fun
        (assocs: (term*term) list) (default: term)
        (name: string) (eqn_names: string list)
        ctxt = let
  (* define lookup function *)
  val [key_typ, val_typ] = case assocs of ((k, v) :: _) => map type_of [k, v]
                                        | _ => error "make_assoc_fun: empty list"
  val alist_term = HOLogic.mk_list (HOLogic.mk_prodT (key_typ, val_typ)) (map HOLogic.mk_prod assocs)
  val assoc_lookupT = HOLogic.listT (HOLogic.mk_prodT (key_typ, val_typ)) --> val_typ --> key_typ --> val_typ
  val defn = Const (@{const_name assoc_lookup}, assoc_lookupT) $ alist_term $ default
  val ((f_term, (_, f_def)), ctxt) =
          Local_Theory.define ((Binding.name name, NoSyn),
                              ((Thm.def_binding (Binding.name name), []), defn)) ctxt
  val proof_ctxt = ctxt addsimps [f_def]
  (* generate lookup equations for function *)
  val eqns = eqn_names ~~ assocs
        |> Par_List.map (fn (name, (k, v)) => let
            val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (betapply (f_term, k), v))
            val thm = Goal.prove ctxt [] [] prop (K (
                        simp_tac proof_ctxt 1))
            in (name, thm)
            end)
  (* store the equations by eqn_names *)
  val grouped_eqns = eqns
        |> sort_by fst
        |> partition_eq (fn (e1, e2) => fst e1 = fst e2)
  val (_, ctxt) = Local_Theory.notes (map (fn eqns =>
        ((Binding.name (fst (hd eqns)), []), [(map snd eqns, [])])) grouped_eqns) ctxt
  in ctxt end

end
\<close>

(* Test: *)
(*
local_setup \<open>
AssocLookup.make_assoc_fun
  [(@{term "(''S'', 1::nat)"}, @{term "2::nat"}),
   (@{term "(''P'', 2::nat)"}, @{term "1::nat"}),
   (@{term "(''S'', 3::nat)"}, @{term "2+2::nat"})]
  @{term "42::nat"}
  "foo" ("foo1_simp" :: replicate 2 "foo23_simps")
\<close>
print_theorems
*)

end


theory Simps_Case_Conv_Examples imports
  "HOL-Library.Simps_Case_Conv"
begin

section \<open>Tests for the Simps<->Case conversion tools\<close>

fun foo where
  "foo (x # xs) Nil = 0" |
  "foo (x # xs) (y # ys) = foo [] []" |
  "foo Nil (y # ys) = 1" |
  "foo Nil Nil = 3"

fun bar where
  "bar x 0 y = 0 + x" |
  "bar x (Suc n) y = n + x"

definition
  split_rule_test :: "((nat => 'a) + ('b * (('b => 'a) option))) => ('a => nat) => nat"
where
 "split_rule_test x f = f (case x of Inl af \<Rightarrow> af 1
    | Inr (b, None) => inv f 0
    | Inr (b, Some g) => g b)"

definition test where "test x y = (case x of None => (case y of [] => 1 | _ # _ => 2) | Some x => x)"

definition nosplit where "nosplit x = x @ (case x of [] \<Rightarrow> [1] | xs \<Rightarrow> xs)"

text \<open>Function with complete, non-overlapping patterns\<close>
case_of_simps foo_cases1: foo.simps
lemma
  fixes xs :: "'a list" and ys :: "'b list"
  shows "foo xs ys = (case (xs, ys) of
    ( [], []) \<Rightarrow> 3
    | ([], y # ys) \<Rightarrow> 1
    | (x # xs, []) \<Rightarrow> 0
    | (x # xs, y # ys) \<Rightarrow> foo ([] :: 'a list) ([] :: 'b list))"
  by (fact foo_cases1)

text \<open>Redundant equations are ignored\<close>
case_of_simps foo_cases2: foo.simps foo.simps
lemma
  fixes xs :: "'a list" and ys :: "'b list"
  shows "foo xs ys = (case (xs, ys) of
    ( [], []) \<Rightarrow> 3
    | ([], y # ys) \<Rightarrow> 1
    | (x # xs, []) \<Rightarrow> 0
    | (x # xs, y # ys) \<Rightarrow> foo ([] :: 'a list) ([] :: 'b list))"
  by (fact foo_cases2)

text \<open>Variable patterns\<close>
case_of_simps bar_cases: bar.simps
print_theorems

text \<open>Case expression not at top level\<close>
simps_of_case split_rule_test_simps: split_rule_test_def
lemma
  "split_rule_test (Inl x) f = f (x 1)"
  "split_rule_test (Inr (x, None)) f = f (inv f 0)"
  "split_rule_test (Inr (x, Some y)) f = f (y x)"
  by (fact split_rule_test_simps)+

text \<open>Argument occurs both as case parameter and seperately\<close>
simps_of_case nosplit_simps1: nosplit_def
lemma
  "nosplit [] = [] @ [1]"
  "nosplit (x # xs) = (x # xs) @ x # xs"
  by (fact nosplit_simps1)+

text \<open>Nested case expressions\<close>
simps_of_case test_simps1: test_def
lemma
  "test None [] = 1"
  "test None (x # xs) = 2"
  "test (Some x) y = x"
  by (fact test_simps1)+

text \<open>Single-constructor patterns\<close>
case_of_simps fst_conv_simps: fst_conv
lemma "fst x = (case x of (a,b) \<Rightarrow> a)"
  by (fact fst_conv_simps)

text \<open>Partial split of case\<close>
simps_of_case nosplit_simps2: nosplit_def (splits: list.split)
lemma
  "nosplit [] = [] @ [1]"
  "nosplit (x # xs) = (x # xs) @ x # xs"
  by (fact nosplit_simps1)+

simps_of_case test_simps2: test_def (splits: option.split)
lemma
  "test None y = (case y of [] \<Rightarrow> 1 | x # xs \<Rightarrow> 2)"
  "test (Some x) y = x"
  by (fact test_simps2)+

text \<open>Reversal\<close>
case_of_simps test_def1: test_simps1
lemma
  "test x y = (case (x,y) of
    (None, []) \<Rightarrow> 1
  | (None, _#_) \<Rightarrow> 2
  | (Some x, _) \<Rightarrow> x)"
  by (fact test_def1)

text \<open>Case expressions on RHS\<close>
case_of_simps test_def2: test_simps2
lemma "test xs y = (case (xs, y) of (None, []) \<Rightarrow> 1 | (None, x # xa) \<Rightarrow> 2 | (Some x, y) \<Rightarrow> x)"
  by (fact test_def2)

text \<open>Partial split of simps\<close>
case_of_simps foo_cons_def: foo.simps(1,2)
lemma
  fixes xs :: "'a list" and ys :: "'b list"
  shows "foo (x # xs) ys = (case (x,xs,ys) of
      (_,_,[]) \<Rightarrow> 0
    | (_,_,_ # _) \<Rightarrow> foo ([] :: 'a list) ([] :: 'b list))"
  by (fact foo_cons_def)

end


(*  Title:      HOL/Auth/Guard/Guard_Public.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge

Lemmas on guarded messages for public protocols.
*)

theory Guard_Public imports Guard "../Public" Extensions begin

subsection\<open>Extensions to Theory \<open>Public\<close>\<close>

declare initState.simps [simp del]

subsubsection\<open>signature\<close>

definition sign :: "agent => msg => msg" where
"sign A X == \<lbrace>Agent A, X, Crypt (priK A) (Hash X)\<rbrace>"

lemma sign_inj [iff]: "(sign A X = sign A' X') = (A=A' & X=X')"
by (auto simp: sign_def)

subsubsection\<open>agent associated to a key\<close>

definition agt :: "key => agent" where
"agt K == SOME A. K = priK A | K = pubK A"

lemma agt_priK [simp]: "agt (priK A) = A"
by (simp add: agt_def)

lemma agt_pubK [simp]: "agt (pubK A) = A"
by (simp add: agt_def)

subsubsection\<open>basic facts about \<^term>\<open>initState\<close>\<close>

lemma no_Crypt_in_parts_init [simp]: "Crypt K X \<notin> parts (initState A)"
by (cases A, auto simp: initState.simps)

lemma no_Crypt_in_analz_init [simp]: "Crypt K X \<notin> analz (initState A)"
by auto

lemma no_priK_in_analz_init [simp]: "A \<notin> bad
\<Longrightarrow> Key (priK A) \<notin> analz (initState Spy)"
by (auto simp: initState.simps)

lemma priK_notin_initState_Friend [simp]: "A \<noteq> Friend C
\<Longrightarrow> Key (priK A) \<notin> parts (initState (Friend C))"
by (auto simp: initState.simps)

lemma keyset_init [iff]: "keyset (initState A)"
by (cases A, auto simp: keyset_def initState.simps)

subsubsection\<open>sets of private keys\<close>

definition priK_set :: "key set => bool" where
"priK_set Ks \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> (\<exists>A. K = priK A)"

lemma in_priK_set: "\<lbrakk>priK_set Ks; K \<in> Ks\<rbrakk> \<Longrightarrow> \<exists>A. K = priK A"
by (simp add: priK_set_def)

lemma priK_set1 [iff]: "priK_set {priK A}"
by (simp add: priK_set_def)

lemma priK_set2 [iff]: "priK_set {priK A, priK B}"
by (simp add: priK_set_def)

subsubsection\<open>sets of good keys\<close>

definition good :: "key set => bool" where
"good Ks == \<forall>K. K \<in> Ks \<longrightarrow> agt K \<notin> bad"

lemma in_good: "\<lbrakk>good Ks; K \<in> Ks\<rbrakk> \<Longrightarrow> agt K \<notin> bad"
by (simp add: good_def)

lemma good1 [simp]: "A \<notin> bad \<Longrightarrow> good {priK A}"
by (simp add: good_def)

lemma good2 [simp]: "\<lbrakk>A \<notin> bad; B \<notin> bad\<rbrakk> \<Longrightarrow> good {priK A, priK B}"
by (simp add: good_def)

subsubsection\<open>greatest nonce used in a trace, 0 if there is no nonce\<close>

primrec greatest :: "event list => nat"
where
  "greatest [] = 0"
| "greatest (ev # evs) = max (greatest_msg (msg ev)) (greatest evs)"

lemma greatest_is_greatest: "Nonce n \<in> used evs \<Longrightarrow> n \<le> greatest evs"
apply (induct evs, auto simp: initState.simps)
apply (drule used_sub_parts_used, safe)
apply (drule greatest_msg_is_greatest, arith)
by simp

subsubsection\<open>function giving a new nonce\<close>

definition new :: "event list \<Rightarrow> nat" where
"new evs \<equiv> Suc (greatest evs)"

lemma new_isnt_used [iff]: "Nonce (new evs) \<notin> used evs"
by (clarify, drule greatest_is_greatest, auto simp: new_def)

subsection\<open>Proofs About Guarded Messages\<close>

subsubsection\<open>small hack necessary because priK is defined as the inverse of pubK\<close>

lemma pubK_is_invKey_priK: "pubK A = invKey (priK A)"
by simp

lemmas pubK_is_invKey_priK_substI = pubK_is_invKey_priK [THEN ssubst]

lemmas invKey_invKey_substI = invKey [THEN ssubst]

lemma "Nonce n \<in> parts {X} \<Longrightarrow> Crypt (pubK A) X \<in> guard n {priK A}"
apply (rule pubK_is_invKey_priK_substI, rule invKey_invKey_substI)
by (rule Guard_Nonce, simp+)

subsubsection\<open>guardedness results\<close>

lemma sign_guard [intro]: "X \<in> guard n Ks \<Longrightarrow> sign A X \<in> guard n Ks"
by (auto simp: sign_def)

lemma Guard_init [iff]: "Guard n Ks (initState B)"
by (induct B, auto simp: Guard_def initState.simps)

lemma Guard_knows_max': "Guard n Ks (knows_max' C evs)
\<Longrightarrow> Guard n Ks (knows_max C evs)"
by (simp add: knows_max_def)

lemma Nonce_not_used_Guard_spies [dest]: "Nonce n \<notin> used evs
\<Longrightarrow> Guard n Ks (spies evs)"
by (auto simp: Guard_def dest: not_used_not_known parts_sub)

lemma Nonce_not_used_Guard [dest]: "\<lbrakk>evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> Guard n Ks (knows (Friend C) evs)"
by (auto simp: Guard_def dest: known_used parts_trans)

lemma Nonce_not_used_Guard_max [dest]: "\<lbrakk>evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> Guard n Ks (knows_max (Friend C) evs)"
by (auto simp: Guard_def dest: known_max_used parts_trans)

lemma Nonce_not_used_Guard_max' [dest]: "\<lbrakk>evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> Guard n Ks (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in Guard_mono)
by (auto simp: knows_max_def)

subsubsection\<open>regular protocols\<close>

definition regular :: "event list set \<Rightarrow> bool" where
"regular p \<equiv> \<forall>evs A. evs \<in> p \<longrightarrow> (Key (priK A) \<in> parts (spies evs)) = (A \<in> bad)"

lemma priK_parts_iff_bad [simp]: "\<lbrakk>evs \<in> p; regular p\<rbrakk> \<Longrightarrow>
(Key (priK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (auto simp: regular_def)

lemma priK_analz_iff_bad [simp]: "\<lbrakk>evs \<in> p; regular p\<rbrakk> \<Longrightarrow>
(Key (priK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Guard_Nonce_analz: "\<lbrakk>Guard n Ks (spies evs); evs \<in> p;
priK_set Ks; good Ks; regular p\<rbrakk> \<Longrightarrow> Nonce n \<notin> analz (spies evs)"
apply (clarify, simp only: knows_decomp)
apply (drule Guard_invKey_keyset, simp+, safe)
apply (drule in_good, simp)
apply (drule in_priK_set, simp+, clarify)
apply (frule_tac A=A in priK_analz_iff_bad)
by (simp add: knows_decomp)+

end


text_raw\<open>
\twocolumn
\columnsep 2pc          %    Space between columns
\textwidth 42pc         % Width of text line.
\part{Documentation}
\label{part2}
\<close>
section\<open>Configuration Translation\<close>
text_raw\<open>\label{sec:conv}\<close>
text\<open>
All the results we present in this section are formalized and verified in Isabelle/HOL~\cite{nipkow2002isabelle}.
This means that their formal correctness can be trusted a level close to absolute certainty.
The definitions and lemmas stated here are merely a repetition of lemmas stated in other theory files.
This means that they have been directly set to this document from Isabelle and no typos or hidden assumptions are possible.
Additionally, it allows us to omit various helper lemmas that do not help the understanding.
However, it causes some notation inaccuracy, as type and function definitions are stated as lemmas or schematic goals.
\<close>
theory OpenFlow_Documentation
(*<*)
imports
  LinuxRouter_OpenFlow_Translation
  Featherweight_OpenFlow_Comparison
  "~~/src/HOL/Library/LaTeXsugar"
begin
(*>*)

subsection\<open>Linux Firewall Model\<close>
text_raw\<open>\label{sec:lfw}\<close>
text\<open>We want to write a program that translates the configuration of a linux firewall to that of an OpenFlow switch.
We furthermore want to verify that translation.
For this purpose, we need a clear definition of the behavior of the two device types -- we need their models and semantics.
In case of a linux firewall, this is problematic because a linux firewall is a highly complex device that is ultimately capable of general purpose computation.
Creating a comprehensive semantics that encompasses all possible configuration types of a linux firewall is thus
highly non-trivial and not useful for the purpose of analysis.
We decided to approach the problem from the other side: we created a model that includes only the most basic features. (This implies neglecting IPv6.)
Fortunately, many of the highly complex features are rarely essential and even our basic model is still of some use.
\<close>

text\<open>We first divided the firewall into subsystems.
Given a routing table @{term rt}, the firewall rules @{term fw},
  the routing decision for a packet @{term p} can be obtained by @{term "routing_table_semantics rt (p_dst p)"},
  the firewall decision by @{term "simple_fw fw p"}.
We draft the first description of our linux router model:
\begin{enumerate}
  \item The destination MAC address of an arriving packet is checked: Does it match the MAC address of the ingress port?
  If it does, we continue, otherwise, the packet is discarded.
  \item The routing decision @{term "rd \<equiv> routing_table_semantics rt p"} is obtained.
  \item The packet's output interface is updated based on @{term rd}\footnote{Note that we assume a packet model with input and output interfaces. The origin of this is explained in Section~\ref{sec:lfwfw}}.
  \item The firewall is queried for a decision: @{term "simple_fw fw p"}. If the decision is to @{const[names_short] simple_action.Drop}, the packet is discarded.
  \item The next hop is computed: If @{term rd} provides a next hop, that is used.
    Otherwise, the destination address of the packet is used.
  \item The MAC address of the next hop is looked up; the packet is updated with it and sent.
\end{enumerate}
We decided that this description is best formalized as an abortable program in the option monad:\<close>
lemma "simple_linux_router rt fw mlf ifl p \<equiv> do {
	_ \<leftarrow> iface_packet_check ifl p;
	let rd (* routing decision *) = routing_table_semantics rt (p_dst p);
	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
	let fd (* firewall decision *) = simple_fw fw p;
	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
	let nh = (case next_hop rd of None \<Rightarrow> p_dst p | Some a \<Rightarrow> a);
	ma \<leftarrow> mlf nh;
	Some (p\<lparr>p_l2dst := ma\<rparr>)
}"
unfolding fromMaybe_def[symmetric] by(fact simple_linux_router_def)
text\<open>where @{term "mlf :: ipv4addr \<Rightarrow> 48 word"} is a function that looks up the MAC address for an IP address.\<close>

text\<open>There are already a few important aspects that have not been modelled, but they are not core essential for the functionality of a firewall.
Namely, there is no local traffic from/to the firewall.
This is problematic since this model can not generate ARP replies — thus, an equivalent OpenFlow device will not do so, either.
Furthermore, this model is problematic because it requires access to a function that looks up a MAC address,
something that may not be known at the time of time running a translation to an OpenFlow configuration.
\<close>
text\<open>It is possible to circumvent these problems by inserting static ARP table entries in the directly connected devices
and looking up their MAC addresses \emph{a priori}.
A test-wise implementation of the translation based on this model showed acceptable results.
However, we deemed the \emph{a priori} lookup of the MAC addresses to be rather inelegant and built a second model.\<close>
definition "simple_linux_router_altered rt fw ifl p \<equiv> do {
	let rd = routing_table_semantics rt (p_dst p);
	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
		_ \<leftarrow> if p_oiface p = p_iiface p then None else Some ();
	let fd = simple_fw fw p;
	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
	Some p
}"
(* TODO: Would a router actually forward a packet on the same interface? *)
text\<open>In this model, all access to the MAC layer has been eliminated.
This is done by the approximation that the firewall will be asked to route a packet
(i.e. be addressed on the MAC layer) iff the destination IP address of the packet causes it to be routed out on a different interface.
Because this model does not insert destination MAC addresses, the destination MAC address has to be already correct when the packet is sent.
This can only be achieved by changing the subnet of all connected device, moving them into one common subnet\footnote{There are cases where this is not possible — A limitation of our system.}.
\<close>
text\<open>
While a test-wise implementation based on this model also showed acceptable results, the model is still problematic.
The check @{term "p_oiface p = p_iiface p"} and the firewall require access to the output interface.
The details of why this cannot be provided are be elaborated in Section~\ref{sec:convi}.
The intuitive explanation is that an OpenFlow match can not have a field for the output interface.
We thus simplified the model even further:
\<close>
lemma "simple_linux_router_nol12 rt fw p \<equiv> do {
	let rd = routing_table_semantics rt (p_dst p);
	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
	let fd = simple_fw fw p;
	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
	Some p
}" by(fact simple_linux_router_nol12_def)
text\<open>We continue with this definition as a basis for our translation.
Even this strongly altered version and the original linux firewall still behave the same in a substantial amount of cases:\<close>
theorem
	"\<lbrakk>iface_packet_check ifl pii \<noteq> None;
	mlf (case next_hop (routing_table_semantics rt (p_dst pii)) of None \<Rightarrow> p_dst pii | Some a \<Rightarrow> a) \<noteq> None\<rbrakk> \<Longrightarrow>
	\<exists>x. map_option (\<lambda>p. p\<lparr>p_l2dst := x\<rparr>) (simple_linux_router_nol12 rt fw pii) = simple_linux_router rt fw mlf ifl pii"
by(fact rtr_nomac_eq[unfolded fromMaybe_def])
text\<open>The conditions are to be read as ``The check whether a received packet has the correct destination MAC never returns @{const False}'' and
``The next hop MAC address for all packets can be looked up''.
Obviously, these conditions do not hold for all packets.
We will show an example where this makes a difference in Section~\ref{sec:mnex}.\<close>

subsubsection\<open>Routing Table\<close>
text_raw\<open>\label{sec:lfwr}\<close>
text\<open>
The routing system in linux features multiple tables and a system that can use the iptables firewall and an additional match language to select a routing table.
Based on our directive, we only focused on the single most used \texttt{main} routing table.\<close>
text\<open>
We define a routing table entry to be a record (named tuple) of a prefix match, a metric and the routing action, which in turn is a record of an output interface and an optional next-hop address.\<close>
schematic_goal "(?rtbl_entry :: ('a::len) routing_rule) = \<lparr> routing_match = PrefixMatch pfx len, metric = met, routing_action = \<lparr> output_iface = oif_string, next_hop = (h :: 'a word option) \<rparr> \<rparr>" ..
text\<open>A routing table is then a list of these entries:\<close>
lemma "(rtbl :: ('a :: len) prefix_routing) = (rtbl :: 'a routing_rule list)" by rule
text\<open>Not all members of the type @{type prefix_routing} are sane routing tables. There are three different validity criteria that we require so that our definitions are adequate.
\begin{itemize}
  \item The prefixes have to be 0 in bits exceeding their length.
  \item There has to be a default rule, i.e. one with prefix length 0. With the condition above, that implies that all its prefix bits are zero and it thus matches any address.
  \item The entries have to be sorted by prefix length and metric.
\end{itemize}
The first two are set into code in the following way:
\<close>
lemma "valid_prefix (PrefixMatch pfx len) \<equiv> pfx && (2 ^ (32 - len) - 1) = (0 :: 32 word)"
unfolding valid_prefix_def pfxm_mask_def mask_def by (simp add: word_bw_comms(1))
lemma "has_default_route rt \<longleftrightarrow> (\<exists>r \<in> set rt. pfxm_length (routing_match r) = 0)"
by(fact has_default_route_alt)
text\<open>The third is not needed in any of the further proofs, so we omit it.\<close>

text\<open>The semantics of a routing table is to simply traverse the list until a matching entry is found.\<close>
schematic_goal "routing_table_semantics (rt_entry # rt) dst_addr = (if prefix_match_semantics (routing_match rt_entry) dst_addr then routing_action rt_entry else routing_table_semantics rt dst_addr)" by(fact routing_table_semantics.simps)
text\<open>If no matching entry is found, the behavior is undefined.\<close>

subsubsection\<open>iptables Firewall\<close>
text_raw\<open>\label{sec:lfwfw}\<close>
text\<open>The firewall subsystem in a linux router is not any less complex than any of the of the other systems.
Fortunately, this complexity has been dealt with in~\cite{diekmann2016verified,Iptables_Semantics-AFP} already and we can directly use the result.\<close>
text\<open>In short, one of the results is that a complex \emph{iptables} configuration can be simplified to be represented by a single list of matches that only support the following match conditions:
\begin{itemize}
  \item (String) prefix matches on the input and output interfaces.
  \item A @{type prefix_match} on the source and destination IP address.
  \item An exact match on the layer 4 protocol.
  \item Interval matches on the source or destination port, e.g. @{term "p\<^sub>d \<in> {(1::16 word)..1023}"}
\end{itemize}
The model/type of the packet is adjusted to fit that: it is a record of the fields matched on.
This also means that input and output interface are coded to the packet.
Given that this information is usually stored alongside the packet content, this can be deemed a reasonable model.
In case the output interface is not needed (e.g., when evaluating an OpenFlow table), it can simply be left blank.

Obviously, a simplification into the above match type cannot always produce an equivalent firewall, and the set of accepted packets has to be over- or underapproximated.
The reader interested in the details of this is strongly referred to~\cite{diekmann2016verified}; we are simply going to continue with the result: @{const simple_fw}.
\<close>
text\<open>One property of the simplification is worth noting here: The simplified firewall does not know state and the simplification approximates stateful matches by stateless ones.
Thus, the overapproximation of a stateful firewall ruleset that begins with accepting packets of established connections usually begins with a rule that accepts all packets.
Dealing with this by writing a meaningful simplification of stateful firewalls is future work.
\<close>

subsection\<open>OpenFlow Switch Model\<close>
text\<open>In this section, we present our model of an OpenFlow switch.
The requirements for this model are derived from the fact that it models devices that are the target of a configuration translation.
This has two implications:
\begin{itemize}
\item All configurations that are representable in our model should produce the correct behavior wrt. their semantics.
  The problem is that correct here means that the behavior is the same that any real device would produce.
  Since we cannot possibly account for all device types, we instead focus on those that conform to the OpenFlow specifications.
  To account for the multiple different versions of the specification (e.g.~\cite{specification10,specification15}), we tried making our model a subset of
  both the oldest stable version 1.0~\cite{specification10} and the newest available specification version 1.5.1~\cite{specification15}.
\item Conversely, our model does not need to represent all possible behavior of an OpenFlow switch, just the behavior that can be invoked by the result of our translation.
  This is especially useful regarding for controller interaction, but also for MPLS or VLANs, which we did not model in Section \ref{sec:lfw}.
\end{itemize}\<close>

text\<open>More concretely, we set the following rough outline for our model.
\begin{itemize}
  \item A switch consists of a single flow table.
  \item A flow table entry consists of a priority, a match condition and an action list.
  \item The only possible action (we require) is to forward the packet on a port.
  \item We do not model controller interaction.
\end{itemize}
Additionally, we decided that we wanted to be able to ensure the validity of the flow table in all qualities,
i.e. we want to model the conditions `no overlapping flow entries appear', `all match conditions have their necessary preconditions'.
The details of this are explained in the following sections.
\<close>

subsubsection\<open>Matching Flow Table entries\<close>
text_raw\<open>\label{sec:of_match}\<close>
text\<open>Table 3 of Section 3.1 of \cite{specification10} gives a list of required packet fields that can be used to match packets.
This directly translates into the type for a match expression on a single field:\<close>

schematic_goal "(field_match :: of_match_field) \<in> {
  IngressPort (?s::string),
  EtherSrc (?as::48 word), EtherDst (?ad::48 word),
	EtherType (?t::16 word),
	VlanId (?i::16 word), VlanPriority (?p::16 word),
	IPv4Src (?pms::32 prefix_match),
	IPv4Dst (?pmd::32 prefix_match),
	IPv4Proto (?ipp :: 8 word),
	L4Src (?ps :: 16 word) (?ms :: 16 word),
	L4Dst (?pd :: 16 word) (?md :: 16 word)
}" by(fact of_match_field_typeset)
text\<open>
Two things are worth additional mention: L3 and L4 ``addressess''.
The @{term IPv4Src} and @{term IPv4Dst} matches are specified as ``can be subnet masked'' in~\cite{specification10},
  whereras~\cite{specification15} states clearly that arbitrary bitmasks can be used. We took the conservative approach here.
Our alteration of @{term L4Src} and @{term L4Dst} is more grave. While~\cite{specification10} does not state anything about layer 4 ports and masks,
\cite{specification15} specifically forbids using masks on them.
Nevertheless, OpenVSwitch \cite{openvswitch} and some other implementations support them.
We will explain in detail why we must include bitmasks on layer 4 ports to obtain a meaningful translation in Section~\ref{sec:convi}.\<close>

text\<open>One @{type of_match_field} is not enough to classify a packet.
To match packets, we thus use entire sets of match fields.
As Guha \emph{et al.}~\cite{guha2013machine} noted\footnote{See also: \cite[\<section>2.3]{michaelis2016middlebox}}, executing a set of given @{type of_match_field}s on a packet requires careful consideration.
For example, it is not meaningful to use @{term IPv4Dst} if the given packet is not actually an IP packet, i.e.
@{term IPv4Dst} has the prerequisite of @{term "EtherType 0x0800"} being among the match fields.
Guha \emph{et al.} decided to use the fact that the preconditions can be arranged on a directed acyclic graph (or rather: an acyclic forest).
They evaluated match conditions in a manner following that graph:
first, all field matches without preconditions are evaluated.
Upon evaluating a field match (e.g., @{term "EtherType 0x0800"}), the matches that had their precondition fulfilled by it
  (e.g., @{term IPv4Src} and @{term IPv4Src} in this example) are evalutated.
This mirrors the faulty behavior of some implementations (see \cite{guha2013machine}).
Adopting that behavior into our model would mean that any packet matches against the field match set @{term "{IPv4Dst (PrefixMatch 134744072 32)}"}
instead of just those destined for 8.8.8.8 or causing an error. We found this to be unsatisfactory.\<close>

text\<open>To solve this problem, we made three definitions.
The first, @{term match_no_prereq} matches an @{type of_match_field} against a packet without considering prerequisites.
The second, @{term prerequisites}, checks for a given @{type of_match_field} whether its prerequisites are in a set of given match fields.
Especially:
\<close>
lemma
  "prerequisites (VlanPriority pri) m = (\<exists>id. let v = VlanId id in v \<in> m \<and> prerequisites v m)"
  "prerequisites (IPv4Proto pr) m = (let v = EtherType 0x0800 in v \<in> m \<and> prerequisites v m)"
  "prerequisites (IPv4Src a) m = (let v = EtherType 0x0800 in v \<in> m \<and> prerequisites v m)"
  "prerequisites (IPv4Dst a) m = (let v = EtherType 0x0800 in v \<in> m \<and> prerequisites v m)"
  "prerequisites (L4Src p msk) m = (\<exists>proto \<in> {TCP,UDP,L4_Protocol.SCTP}. let v = IPv4Proto proto in v \<in> m \<and> prerequisites v m)"
  "prerequisites (L4Dst p msk) m = prerequisites (L4Src undefined undefined) m"
  by(fact prerequisites.simps)+
text\<open>Then, to actually match a set of @{type of_match_field} against a packet, we use the option type:\<close>
lemma "OF_match_fields m p =
  (if \<exists>f \<in> m. \<not>prerequisites f m then None else
    if \<forall>f \<in> m. match_no_prereq f p then Some True else Some False)"
by(fact OF_match_fields_alt)

subsubsection\<open>Evaluating a Flow Table\<close>
text\<open>In the previous section, we explained how we match the set of match fields belonging to a single flow entry against a packet.
This section explains how the correct flow entry from a table can be selected.
To prevent to much entanglement with the previous section, we assume an arbitrary match function @{term "\<gamma> :: 'match_field set \<Rightarrow> 'packet \<Rightarrow> bool"}.
This function @{term "\<gamma>"} takes the match condition @{term m} from a flow entry @{term "OFEntry (priority::16 word) (m::'match_field set) action"}
and decides whether a packet matches those.\<close>

text\<open>The flow table is simply a list of flow table entries @{type flow_entry_match}.
Deciding the right flow entry to use for a given packet is explained in the OpenFlow specification \cite{specification10}, Section 3.4:
\begin{quote}
  Packets are matched against flow entries based on prioritization.
  An entry that specifies an exact match (i.e., has no wildcards) is always the highest priority\footnote{This behavior has been deprecated.}.
  All wildcard entries have a priority associated with them.
  Higher priority entries must match before lower priority ones.
  If multiple entries have the same priority, the switch is free to choose any ordering.
\end{quote}
We use the term ``overlapping'' for  the flow entries that can cause a packet to match multiple flow entries with the same priority.
Guha \emph{et al.}~\cite{guha2013machine} have dealt with overlapping.
However, the semantics for a flow table they presented \cite[Figure 5]{guha2013machine}
  is slightly different from what they actually used in their theory files.
We have tried to reproduce the original inductive definition (while keeping our abstraction @{term \<gamma>}),
 in Isabelle/HOL\footnote{The original is written in Coq~\cite{barras1997coq} and we can not use it directly.}:\<close>
lemma "\<gamma> (ofe_fields fe) p = True \<Longrightarrow>
 \<forall>fe' \<in> set (ft1 @ ft2). ofe_prio fe' > ofe_prio fe \<longrightarrow> \<gamma> (ofe_fields fe') p = False \<Longrightarrow>
 guha_table_semantics \<gamma> (ft1 @ fe # ft2) p (Some (ofe_action fe))"
 "\<forall>fe \<in> set ft. \<gamma> (ofe_fields fe) p = False \<Longrightarrow>
 guha_table_semantics \<gamma> ft p None" by(fact guha_matched guha_unmatched)+
text\<open>Guha \emph{et al.} have deliberately made their semantics non-deterministic, to match the fact that the switch ``may choose any ordering''.
This can lead to undesired results:\<close>

text\<open>Instead, we decided to follow Section 5.3 of the specification \cite{specification15}, which states:
\begin{quote}
  If there are multiple matching flow entries, the selected flow entry is explicitly undefined.
\end{quote}
This still leaves some room for interpretation, but it clearly states that overlapping flow entries are undefined behavior,
  and undefined behavior should not be invoked.
Thus, we came up with a semantics that clearly indicates when undefined behavior has been invoked:\<close>
lemma
  "OF_priority_match \<gamma> flow_entries packet = (
  let m  = filter (\<lambda>f. \<gamma> (ofe_fields f) packet) flow_entries;
  	  m' = filter (\<lambda>f. \<forall>fo \<in> set m. ofe_prio fo \<le> ofe_prio f) m in
  	case m' of []  \<Rightarrow> NoAction
             | [s] \<Rightarrow> Action (ofe_action s)
             |  _  \<Rightarrow> Undefined)"
unfolding OF_priority_match_def ..
text\<open>The definition works the following way\footnote{Note that the order of the flow table entries is irrelevant.
We could have made this definition on sets but chose not to for consistency.}:
\begin{enumerate}
  \item The flow table is filtered for those entries that match, the result is called $m$.
  \item $m$ is filtered again, leaving only those entries for which no entries with lower priority could be found, i.e. the matching flow table entries with minimal priority. The result is called $m'$.
  \item A case distinction on $m'$ is made. If only one matching entry was found, its action is returned for execution.
  If $m$ is empty, the flow table semantics returns @{term NoAction} to indicate that the flow table does not decide an action for the packet.
  If,  not zero or one entry is found, but more, the special value @{term Undefined} for indicating undefined behavior is returned.
\end{enumerate}
The use of @{term Undefined} immediately raises the question in which condition it cannot occur.
We give the following definition:\<close>
lemma "check_no_overlap \<gamma> ft = (\<forall>a \<in> set ft. \<forall>b \<in> set ft. (a \<noteq> b \<and> ofe_prio a = ofe_prio b) \<longrightarrow> \<not>(\<exists>p. \<gamma> (ofe_fields a) p \<and> \<gamma> (ofe_fields b) p))" unfolding check_no_overlap_alt check_no_overlap2_def by force
text\<open>Together with distinctness of the flow table, this provides the abscence of @{term Undefined}\footnote{It is slightly stronger than necessary, overlapping rules might be shadowed and thus never influence the behavior.}:\<close>
lemma "\<lbrakk>check_no_overlap \<gamma> ft; distinct ft\<rbrakk> \<Longrightarrow>
  OF_priority_match \<gamma> ft p \<noteq> Undefined" by (simp add: no_overlapsI no_overlaps_not_unefined)

text\<open>Given the absence of overlapping or duplicate flow entries, we can show two interesting equivalences.
the first is the equality to the semantics defined by Guha \emph{et al.}:\<close>
lemma "\<lbrakk>check_no_overlap \<gamma> ft; distinct ft\<rbrakk> \<Longrightarrow>
OF_priority_match \<gamma> ft p = option_to_ftb d \<longleftrightarrow> guha_table_semantics \<gamma> ft p d"
by (simp add: guha_equal no_overlapsI)
text\<open>where @{term option_to_ftb} maps between the return type of @{term OF_priority_match} and an option type as one would expect.\<close>

text\<open>The second equality for @{term OF_priority_match} is one that helps reasoning about flow tables.
We define a simple recursive traversal for flow tables:\<close>
lemma
  "OF_match_linear \<gamma> [] p = NoAction"
  "OF_match_linear \<gamma> (a#as) p = (if \<gamma> (ofe_fields a) p then Action (ofe_action a) else OF_match_linear \<gamma> as p)"
by(fact OF_match_linear.simps)+
text\<open>For this definition to be equivalent, we need the flow table to be sorted:\<close>
lemma"
	\<lbrakk>no_overlaps \<gamma> f ;sorted_descending (map ofe_prio f)\<rbrakk> \<Longrightarrow>
	OF_match_linear \<gamma> f p = OF_priority_match \<gamma> f p"
by(fact  OF_eq)

text\<open>As the last step, we implemented a serialization function for flow entries; it has to remain unverified.
The serialization function deals with one little inaccuracy: We have modelled the @{term IngressPort} match to use the interface name, but OpenFlow requires numerical interface IDs instead.
We deemed that pulling this translation step into the main translation would only make the correctness lemma of the translation more complicated while not increasing the confidence in the correctness significantly.
We thus made replacing interface names by their ID part of the serialization.
\<close>

text\<open>Having collected all important definitions and models, we can move on to the conversion.\<close>
(*text\<open>\todo{Maybe I should make a sweet little subsection that merges this all into a single model definition.}\<close>*)

subsection\<open>Translation Implementation\<close>
text_raw\<open>\label{sec:convi}\<close>
text\<open>This section explains how the functions that are executed sequentially in a linux firewall can be compressed into a single OpenFlow table.
Creating this flow table in a single step would be immensely complicated.
We thus divided the task into several steps using the following key insights:
\begin{itemize}
  \item All steps that are executed in the linux router can be formulated as a firewall, more specifically, a generalization of @{term simple_fw} that allows arbitrary actions instead of just accept and drop.
  \item A function that computes the conjunction of two @{term simple_fw} matches is already present.
    Extending this to a function that computes the join of two firewalls is relatively simple. This is explained in Section \ref{sec:fwconj}
\end{itemize}
\<close>
subsubsection\<open>Chaining Firewalls\<close>
text_raw\<open>\label{sec:fwconj}\<close>
text\<open>This section explains how to compute the join of two firewalls.\<close>
text\<open>The basis of this is a generalization of @{const simple_fw}.
Instead of only allowing @{const simple_action.Accept} or @{const simple_action.Drop} as actions, it allows arbitrary actions. The type of the function that evaluates this generalized simple firewall is
@{term "generalized_sfw :: ('i::len simple_match \<times> 'a) list \<Rightarrow> ('i, 'b) simple_packet_scheme \<Rightarrow> ('i simple_match \<times> 'a) option"}.
The definition is straightforward:\<close>
lemma
"generalized_sfw [] p = None"
"generalized_sfw (a # as) p = (if (case a of (m,_) \<Rightarrow> simple_matches m p) then Some a else generalized_sfw as p)"
	by(fact generalized_sfw_simps)+
text\<open>Based on that, we asked: if @{term fw\<^sub>1} makes the decision @{term a} (where @{term a} is the second element of the result tuple from @{const generalized_sfw}) and @{term fw\<^sub>2} makes the decision @{term b}, how can we compute the firewall that
makes the decision @{term "(a,b)"}\footnote{Note that tuples are right-associative in Isabelle/HOL, i.e., @{term "(a::'a,(b,c)::('b\<times>'c))"} is a pair of @{term a} and the pair @{term "(b,c)"}}.
One possible answer is given by the following definition:
\<close>
lemma "generalized_fw_join l1 l2 \<equiv> [(u,a,b). (m1,a) \<leftarrow> l1, (m2,b) \<leftarrow> l2, u \<leftarrow> (case simple_match_and m1 m2 of None \<Rightarrow> [] | Some s \<Rightarrow> [s])]"
by(fact generalized_fw_join_def[unfolded option2list_def])+
text\<open>This definition validates the following lemma:\<close>
lemma "generalized_sfw (generalized_fw_join fw\<^sub>1 fw\<^sub>2) p = Some (u, d\<^sub>1,d\<^sub>2) \<longleftrightarrow> (\<exists>r\<^sub>1 r\<^sub>2. generalized_sfw fw\<^sub>1 p = Some (r\<^sub>1,d\<^sub>1) \<and> generalized_sfw fw\<^sub>2 p = Some (r\<^sub>2,d\<^sub>2) \<and> Some u = simple_match_and r\<^sub>1 r\<^sub>2)"
  by(force dest: generalized_fw_joinD generalized_fw_joinI intro: Some_to_the[symmetric])
text\<open>Thus, @{const generalized_fw_join} has a number of applications.
For example, it could be used to compute a firewall ruleset that represents two firewalls that are executed in sequence.
\<close>
definition "simple_action_conj a b \<equiv> (if a = simple_action.Accept \<and> b = simple_action.Accept then simple_action.Accept else simple_action.Drop)"
definition "simple_rule_conj \<equiv> (uncurry SimpleRule \<circ> apsnd (uncurry simple_action_conj))"
theorem "simple_fw rs\<^sub>1 p = Decision FinalAllow \<and> simple_fw rs\<^sub>2 p = Decision FinalAllow \<longleftrightarrow>
simple_fw (map simple_rule_conj (generalized_fw_join (map simple_rule_dtor rs\<^sub>1) (map simple_rule_dtor rs\<^sub>2))) p = Decision FinalAllow"
unfolding simple_rule_conj_def simple_action_conj_def[abs_def] using simple_fw_join by(force simp add: comp_def apsnd_def map_prod_def case_prod_unfold uncurry_def[abs_def])
text\<open>Using the join, it should be possible to compute any $n$-ary logical operation on firewalls.
We will use it for something somewhat different in the next section.\<close>

subsubsection\<open>Translation Implementation\<close>

text_raw\<open>
\begin{figure*}
\begin{framed}
\<close>
lemma "lr_of_tran rt fw ifs \<equiv>
if \<not> (no_oif_match fw \<and> has_default_policy fw \<and> simple_fw_valid fw	\<and> valid_prefixes rt \<and> has_default_route rt \<and> distinct ifs)
  then Inl ''Error in creating OpenFlow table: prerequisites not satisifed''
  else (
let
  nfw = map simple_rule_dtor fw;
  frt = map (\<lambda>r. (route2match r, output_iface (routing_action r))) rt;
  nrd = generalized_fw_join frt nfw;
  ard = (map (apfst of_nat) \<circ> annotate_rlen) nrd
  in
  if length nrd < unat (max_word :: 16 word)
  then Inr (pack_OF_entries ifs ard)
  else Inl ''Error in creating OpenFlow table: priority number space exhausted''
)"
unfolding Let_def lr_of_tran_def lr_of_tran_fbs_def lr_of_tran_s1_def comp_def route2match_def by force

text_raw\<open>
  \end{framed}
  \caption{Function for translating a @{typ "'i::len simple_rule list"}, a @{typ "'i routing_rule list"}, and a list of interfaces to a flow table.}
  \label{fig:convi}
\end{figure*}
\<close>

text\<open>
This section shows the actual definition of the translation function, in Figure~\ref{fig:convi}.
Before beginning the translation, the definition checks whether the necessary preconditions are valid.
This first two steps are to convert @{term fw} and @{term rt} to lists that can be evaluated by @{const generalized_sfw}.
For @{term fw}, this is done by @{term "map simple_rule_dtor"}, which just deconstructs @{type simple_rule}s into tuples of match and action.
For @{term rt}, we made a firewall ruleset with rules that use prefix matches on the destination IP address.
The next step is to join the two rulesets.
 The result of the join is a ruleset with rules @{term r} that only match if both, the corresponding firewall rule @{term fwr} and the corresponding routing rule @{term rr} matches.
The data accompanying @{term r} is the port from @{term rr} and the firewall decision from @{term fwr}.
Next, descending priorities are added to the rules using @{term "map (apfst word_of_nat) \<circ> annotate_rlen"}.
If the number of rules is too large to fit into the $2^{16}$ priority classes, an error is returned.
Otherwise, the function @{const pack_OF_entries} is used to convert the @{typ "(16 word \<times> 32 simple_match \<times> char list \<times> simple_action) list"} to an OpenFlow table.
While converting the @{typ "char list \<times> simple_action"} tuple is straightforward, converting the @{type simple_match} to an equivalent list of @{typ "of_match_field set"} is non-trivial.
This is done by the function @{const simple_match_to_of_match}.
\<close>
text\<open>The main difficulties for @{const simple_match_to_of_match} lie in making sure that the prerequisites are satisfied
 and in the fact that a @{type simple_match} operates on slightly stronger match expressions.
\begin{itemize}
  \item A @{type simple_match} allows a (string) prefix match on the input and output interfaces.
    Given a list of existing interfaces on the router @{term ifs}, the function has to insert flow entries for each interface matching the prefix.
  \item A @{type simple_match} can match ports by an interval. Now it becomes obvious why Section~\ref{sec:of_match} added bitmasks to @{const L4Src} and @{const L4Dst}.
    Using the algorithm to split word intervals into intervals that can be represented by prefix matches from~\cite{diekmann2016verified},
      we can efficiently represent the original interval by a few (32 in the worst case) prefix matches and insert flow entries for each of them.%
      \footnote{It might be possible to represent the interval match more efficiently than a split into prefixes. However, that would produce overlapping matches (which is not a problem if we assing separate priorities)
        and we did not have a verified implementation of an algorithm that does so.}
\end{itemize}
The following lemma characterizes @{const simple_match_to_of_match}:
\<close>
lemma simple_match_to_of_match:
assumes
  "simple_match_valid r"
  "p_iiface p \<in> set ifs"
  "match_iface (oiface r) (p_oiface p)"
  "p_l2type p = 0x800"
shows
  "simple_matches r p \<longleftrightarrow> (\<exists>gr \<in> set (simple_match_to_of_match r ifs). OF_match_fields gr p = Some True)"
using assms simple_match_to_of_matchD simple_match_to_of_matchI by blast

text\<open>The assumptions are to be read as follows:
\begin{itemize}
  \item The match @{term r} has to be valid, i.e. it has to use @{const valid_prefix} matches, and it cannot use anything other than $0$-$65535$ for the port matches unless its protocol match ensures @{const TCP}, @{const UDP} or @{const L4_Protocol.SCTP}.
  \item @{const simple_match_to_of_match} cannot produce rules for packets that have input interfaces that are not named in the interface list.
  \item The output interface of @{term p} has to match the output interface match of @{term r}. This is a weakened formulation of @{term "oiface r = ifaceAny"}, since @{thm[display] match_ifaceAny[no_vars]}.
    We require this because OpenFlow field matches cannot be used to match on the output port — they are supposed to match a packet and decide an output port.
  \item The @{type simple_match} type was designed for IP(v4) packets, we limit ourselves to them.
\end{itemize}
The conclusion then states that the @{type simple_match} @{term r} matches iff an element of the result of @{const simple_match_to_of_match} matches.
The third assumption is part of the explanation why we did not use @{const simple_linux_router_altered}:
@{const simple_match_to_of_match} cannot deal with output interface matches.
Thus, before passing a generalized simple firewall to @{const pack_OF_entries}, we would have to set the output ports to @{const ifaceAny}.
A system replace output interface matches with destination IP addresses has already been formalized and will be published in a future version of \cite{Iptables_Semantics-AFP}.
For now, we limit ourselves to firewalls that do not do output port matching, i.e., we require @{term "no_oif_match fw"}.
\<close>

text_raw\<open>\begin{figure*}
\begin{framed}
\<close>
theorem
fixes
  p :: "(32, 'a) simple_packet_ext_scheme"
assumes
  "p_iiface p \<in> set ifs" and "p_l2type p = 0x800"
  "lr_of_tran rt fw ifs = Inr oft"
shows
  "OF_priority_match OF_match_fields_safe oft p = Action [Forward oif] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = (Some (p\<lparr>p_oiface := oif\<rparr>))"
  "OF_priority_match OF_match_fields_safe oft p = Action [] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = None"
  "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction" "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined"
  "OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
  "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
using assms lr_of_tran_correct by simp_all
text_raw\<open>
\end{framed}
\caption{Central theorem on @{const lr_of_tran}}
\label{fig:central}
\end{figure*}
\<close>

text\<open>
Given discussed properties, we present the central theorem for our translation in Figure~\ref{fig:central}.
The first two assumptions are limitations on the traffic we make a statement about.
Obviously, we will never see any packets with an input interface that is not in the interface list.
Furthermore, we do not state anything about non-IPv4 traffic. (The traffic will remain unmatched in by the flow table, but we have not verified that.)
The last assumption is that the translation does not return a run-time error.
The translation will return a run-time error if the rules can not be assigned priorities from a 16 bit integer,
or when one of the following conditions on the input data is not satisifed:\<close>
lemma "
  \<not> no_oif_match fw \<or>
  \<not> has_default_policy fw \<or>
  \<not> simple_fw_valid fw	\<or>
  \<not> valid_prefixes rt \<or>
  \<not> has_default_route rt \<or>
  \<not> distinct ifs \<Longrightarrow>
\<exists>err. lr_of_tran rt fw ifs = Inl err" unfolding lr_of_tran_def by(simp split: if_splits)

subsubsection\<open>Comparison to Exodus\<close>
text\<open>
  We are not the first researchers to attempt automated static migration to SDN.
  The (only) other attempt we are aware of is \emph{Exodus} by Nelson \emph{et al.}~\cite{nelson2015exodus}.
\<close>
text\<open>
There are some fundamental differences between Exodus and our work:
\begin{itemize}
  \item Exodus focuses on Cisco IOS instead of linux.
  \item Exodus does not produce OpenFlow rulesets, but FlowLog~\cite{nelson2014tierless} controller programs.
  \item Exodus is not limited to using a single flow table.
  \item Exodus requires continuous controller interaction for some of its functions.
  \item Exodus attempts to support as much functionality as possible and has implemented support for dynamic routing, VLANs and NAT.
  \item Nelson \emph{et al.} reject the idea that the translation could or should be proven correct.
\end{itemize}
\<close>

(*<*)
end
(*>*)