theory Sequential_Composition_Ref
  imports "Basic_Modules/Component_Types/Electoral_Module_Ref"
        Verified_Voting_Rule_Construction.Sequential_Composition
        Refine_Imperative_HOL.Sepref
begin

definition seq_opt :: "'a :: {default, heap, hashable} Electoral_Module \<Rightarrow>
  'a Electoral_Module
  \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
  'a Result nres"
  where "seq_opt m n A p \<equiv> do {
  let (e, r, d) = m A p;
  ASSERT (finite d);
  let newA = d;
  ASSERT(newA \<subseteq> A);
  ASSERT (finite_profile A p);
  let newp = limit_profile newA p;
  ASSERT (finite_profile newA newp);
  let (ne, nr, nd) = n newA newp;
   RETURN (e \<union> ne, r \<union> nr, nd) }"

lemma seq_opt_correct:
  fixes m n :: "'a :: {default, heap, hashable} Electoral_Module"
  assumes em_m: "electoral_module m" and
  em_n: "electoral_module n"
shows "(uncurry (seq_opt m n), uncurry (RETURN oo (sequential_composition' m n))) \<in>
  [\<lambda> (A, p). finite_profile A p]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>\<langle>Id \<times>\<^sub>r Id\<rangle>set_rel\<rangle>list_rel) \<rightarrow>
  \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel"
  unfolding comp_apply seq_opt_def
  apply (intro frefI) apply clarsimp
  using assms apply (refine_vcg)
    apply auto
  subgoal unfolding electoral_module_def
    by (metis def_presv_fin_prof em_m snd_conv)
  apply (metis defer_in_alts snd_conv subsetD)
  by (metis def_presv_fin_prof limit_profile.elims snd_conv)

locale Seqcomp_Impl =
  fixes m n :: "'a :: {default, heap, hashable} Electoral_Module"
  fixes m_sep n_sep :: "'a :: {default, heap, hashable} Electoral_Module_Sep"
assumes em_m: "electoral_module m" and
  em_n: "electoral_module n"
  assumes m_sep_correct: "(uncurry m_sep, uncurry (RETURN oo m)) \<in> elec_mod_seprel id_assn"
  assumes n_sep_correct: "(uncurry n_sep, uncurry (RETURN oo n)) \<in> elec_mod_seprel id_assn"
begin

  lemma this_loc: "Seqcomp_Impl m n m_sep n_sep" by unfold_locales

  sepref_register m
  sepref_register n

  declare m_sep_correct[sepref_fr_rules]
  declare n_sep_correct[sepref_fr_rules]

schematic_goal seqcomp_sepimpl:
  "(uncurry ?f2, uncurry (seq_opt m n)) \<in> elec_mod_seprel id_assn"
  unfolding seq_opt_def
  by sepref

concrete_definition (in -) seqcomp_sep_uc uses Seqcomp_Impl.seqcomp_sepimpl
  prepare_code_thms (in -) seqcomp_sep_uc_def
lemmas  seqcomp_sep_ucp_refine = seqcomp_sep_uc.refine[OF this_loc]

schematic_goal seqcomp_sepcurried:
 "?curried = curry (seqcomp_sep_uc m_sep n_sep)" by auto

concrete_definition (in -) seqcomp_sep uses Seqcomp_Impl.seqcomp_sepcurried

theorem seqcomp_sep_correct:
  shows "(uncurry (seqcomp_sep m_sep n_sep), uncurry (RETURN oo (PR_CONST (m \<triangleright> n))))
\<in> elec_mod_seprel id_assn"
    using seqcomp_sep_ucp_refine[FCOMP seq_opt_correct, OF em_m em_n]
    unfolding seqcomp_alt_eq seqcomp_sep_def
    by (simp)

end

abbreviation comp4 (infixl "oooo" 55) where "f oooo g \<equiv> \<lambda>x. f ooo (g x)"

(*theorem seqcomp_sep_correct [sepref_fr_rules]:
  shows "(uncurry3 (seqcomp_sep), uncurry3 (RETURN oooo sequential_composition))
   \<in> [\<lambda> (((m,n),a),b). electoral_module m \<and>
  electoral_module n \<and> finite_profile a b]\<^sub>a (elec_mod_assn_atom nat_assn)\<^sup>k *\<^sub>a
    (elec_mod_assn_atom nat_assn)\<^sup>k
    *\<^sub>a (alts_set_impl_assn nat_assn)\<^sup>k *\<^sub>a (list_assn (ballot_assn nat_assn))\<^sup>k
        \<rightarrow> (result_impl_assn nat_assn)"
  apply (intro hfrefI)
  using Seqcomp_Impl.seqcomp_sep_correct
  unfolding Seqcomp_Impl_def
  unfolding hn_refine_def  hfref_def elec_mod_assn_atom_def hfref_def
  apply (sep_auto simp del: sequential_composition.simps) done

sepref_register "sequential_composition"

declare seqcomp_sep_correct [sepref_fr_rules]

sepref_decl_op seqi: "(uncurry3 sequential_composition)" ::
  "\<langle>elec_mod_rel_orig R, \<langle>elec_mod_rel_orig R, elec_mod_rel_orig R\<rangle>fun_rel\<rangle>fun_rel" where
  "R = (Id)" apply standard apply (rule nres_relI) unfolding elec_mod_rel_orig_def apply auto
  done*)

abbreviation sequence_opt
     (infix "\<triangleright>sep" 50) where
  "m \<triangleright>sep n \<equiv> seqcomp_sep m n"

end


(*  Title:      HOL/Auth/OtwayRees_AN.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Otway-Rees Protocol as Modified by Abadi and Needham\<close>

theory OtwayRees_AN imports Public begin

text\<open>
This simplified version has minimal encryption and explicit messages.

Note that the formalization does not even assume that nonces are fresh.
This is because the protocol does not rely on uniqueness of nonces for
security, only for freshness, and the proof script does not prove freshness
properties.

From page 11 of
  Abadi and Needham (1996).
  Prudent Engineering Practice for Cryptographic Protocols.
  IEEE Trans. SE 22 (1)
\<close>

inductive_set otway :: "event list set"
  where
   Nil: \<comment>\<open>The empty trace\<close>
        "[] \<in> otway"

 | Fake: \<comment>\<open>The Spy may say anything he can say.  The sender field is correct,
            but agents don't use that information.\<close>
         "[| evsf \<in> otway;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> otway"

 | Reception: \<comment>\<open>A message that has been sent can be received by the
                  intended recipient.\<close>
              "[| evsr \<in> otway;  Says A B X \<in>set evsr |]
               ==> Gets B X # evsr \<in> otway"

 | OR1:  \<comment>\<open>Alice initiates a protocol run\<close>
         "evs1 \<in> otway
          ==> Says A B \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> # evs1 \<in> otway"

 | OR2:  \<comment>\<open>Bob's response to Alice's message.\<close>
         "[| evs2 \<in> otway;
             Gets B \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> \<in>set evs2 |]
          ==> Says B Server \<lbrace>Agent A, Agent B, Nonce NA, Nonce NB\<rbrace>
                 # evs2 \<in> otway"

 | OR3:  \<comment>\<open>The Server receives Bob's message.  Then he sends a new
           session key to Bob with a packet for forwarding to Alice.\<close>
         "[| evs3 \<in> otway;  Key KAB \<notin> used evs3;
             Gets Server \<lbrace>Agent A, Agent B, Nonce NA, Nonce NB\<rbrace>
               \<in>set evs3 |]
          ==> Says Server B
               \<lbrace>Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B, Key KAB\<rbrace>,
                 Crypt (shrK B) \<lbrace>Nonce NB, Agent A, Agent B, Key KAB\<rbrace>\<rbrace>
              # evs3 \<in> otway"

 | OR4:  \<comment>\<open>Bob receives the Server's (?) message and compares the Nonces with
             those in the message he previously sent the Server.
             Need @{term "B \<noteq> Server"} because we allow messages to self.\<close>
         "[| evs4 \<in> otway;  B \<noteq> Server;
             Says B Server \<lbrace>Agent A, Agent B, Nonce NA, Nonce NB\<rbrace> \<in>set evs4;
             Gets B \<lbrace>X, Crypt(shrK B)\<lbrace>Nonce NB,Agent A,Agent B,Key K\<rbrace>\<rbrace>
               \<in>set evs4 |]
          ==> Says B A X # evs4 \<in> otway"

 | Oops: \<comment>\<open>This message models possible leaks of session keys.  The nonces
             identify the protocol run.\<close>
         "[| evso \<in> otway;
             Says Server B
                      \<lbrace>Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B, Key K\<rbrace>,
                        Crypt (shrK B) \<lbrace>Nonce NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
               \<in>set evso |]
          ==> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> otway"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "[| B \<noteq> Server; Key K \<notin> used [] |]
      ==> \<exists>evs \<in> otway.
           Says B A (Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B, Key K\<rbrace>)
             \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] otway.Nil
                    [THEN otway.OR1, THEN otway.Reception,
                     THEN otway.OR2, THEN otway.Reception,
                     THEN otway.OR3, THEN otway.Reception, THEN otway.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says [dest!]:
     "[| Gets B X \<in> set evs; evs \<in> otway |] ==> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule otway.induct, auto)

text\<open>For reasoning about the encrypted portion of messages\<close>

lemma OR4_analz_knows_Spy:
     "[| Gets B \<lbrace>X, Crypt(shrK B) X'\<rbrace> \<in> set evs;  evs \<in> otway |]
      ==> X \<in> analz (knows Spy evs)"
by blast

text\<open>Theorems of the form @{term "X \<notin> parts (spies evs)"} imply that
NOBODY sends messages containing X!\<close>

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> otway ==> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule otway.induct, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> otway ==> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> otway|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

subsection\<open>Proofs involving analz\<close>

text\<open>Describes the form of K and NA when the Server sends this message.\<close>
lemma Says_Server_message_form:
     "[| Says Server B
            \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
              Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         evs \<in> otway |]
      ==> K \<notin> range shrK & (\<exists>i. NA = Nonce i) & (\<exists>j. NB = Nonce j)"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

text\<open>Session keys are not used to encrypt other session keys\<close>

text\<open>The equality makes the induction hypothesis easier to apply\<close>
lemma analz_image_freshK [rule_format]:
 "evs \<in> otway ==>
   \<forall>K KK. KK <= -(range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule otway.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] OR4_analz_knows_Spy, analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
  "[| evs \<in> otway;  KAB \<notin> range shrK |] ==>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's message.\<close>
lemma unique_session_keys:
     "[| Says Server B
          \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, K\<rbrace>,
            Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, K\<rbrace>\<rbrace>
         \<in> set evs;
        Says Server B'
          \<lbrace>Crypt (shrK A') \<lbrace>NA', Agent A', Agent B', K\<rbrace>,
            Crypt (shrK B') \<lbrace>NB', Agent A', Agent B', K\<rbrace>\<rbrace>
         \<in> set evs;
        evs \<in> otway |]
     ==> A=A' & B=B' & NA=NA' & NB=NB'"
apply (erule rev_mp, erule rev_mp, erule otway.induct, simp_all)
apply blast+  \<comment>\<open>OR3 and OR4\<close>
done

subsection\<open>Authenticity properties relating to NA\<close>

text\<open>If the encrypted message appears then it originated with the Server!\<close>
lemma NA_Crypt_imp_Server_msg [rule_format]:
    "[| A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
     ==> Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace> \<in> parts (knows Spy evs)
       --> (\<exists>NB. Says Server B
                    \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                      Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                    \<in> set evs)"
apply (erule otway.induct, force)
apply (simp_all add: ex_disj_distrib)
apply blast+  \<comment>\<open>Fake, OR3\<close>
done

text\<open>Corollary: if A receives B's OR4 message then it originated with the
      Server. Freshness may be inferred from nonce NA.\<close>
lemma A_trusts_OR4:
     "[| Says B' A (Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>) \<in> set evs;
         A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> \<exists>NB. Says Server B
                  \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                    Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast intro!: NA_Crypt_imp_Server_msg)

text\<open>Crucial secrecy property: Spy does not see the keys sent in msg OR3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having @{term "A=Spy"}\<close>
lemma secrecy_lemma:
     "[| A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
      ==> Says Server B
           \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
             Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
          \<in> set evs -->
          Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs -->
          Key K \<notin> analz (knows Spy evs)"
apply (erule otway.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (drule_tac [6] OR4_analz_knows_Spy)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes)
apply spy_analz  \<comment>\<open>Fake\<close>
apply (blast dest: unique_session_keys)+  \<comment>\<open>OR3, OR4, Oops\<close>
done

lemma Spy_not_see_encrypted_key:
     "[| Says Server B
            \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
              Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
  by (metis secrecy_lemma)

text\<open>A's guarantee.  The Oops premise quantifies over NB because A cannot know
  what it is.\<close>
lemma A_gets_good_key:
     "[| Says B' A (Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>) \<in> set evs;
         \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
  by (metis A_trusts_OR4 secrecy_lemma)

subsection\<open>Authenticity properties relating to NB\<close>

text\<open>If the encrypted message appears then it originated with the Server!\<close>
lemma NB_Crypt_imp_Server_msg [rule_format]:
 "[| B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
  ==> Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace> \<in> parts (knows Spy evs)
      --> (\<exists>NA. Says Server B
                   \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                     Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                   \<in> set evs)"
apply (erule otway.induct, force, simp_all add: ex_disj_distrib)
apply blast+  \<comment>\<open>Fake, OR3\<close>
done

text\<open>Guarantee for B: if it gets a well-formed certificate then the Server
  has sent the correct message in round 3.\<close>
lemma B_trusts_OR3:
     "[| Says S B \<lbrace>X, Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> \<exists>NA. Says Server B
                   \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                     Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                   \<in> set evs"
by (blast intro!: NB_Crypt_imp_Server_msg)

text\<open>The obvious combination of \<open>B_trusts_OR3\<close> with
      \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma B_gets_good_key:
     "[| Gets B \<lbrace>X, Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
          \<in> set evs;
         \<forall>NA. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: B_trusts_OR3 Spy_not_see_encrypted_key)

end


theory Semantics_Ternary
imports Matching_Ternary "../Common/List_Misc"
begin

section\<open>Embedded Ternary-Matching Big Step Semantics\<close>

subsection\<open>Ternary Semantics (Big Step)\<close>

inductive approximating_bigstep :: "('a, 'p) match_tac \<Rightarrow> 'p \<Rightarrow> 'a rule list \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool"
  ("_,_\<turnstile> \<langle>_, _\<rangle> \<Rightarrow>\<^sub>\<alpha> _"  [60,60,20,98,98] 89)
  for \<gamma> and p where
skip:  "\<gamma>,p\<turnstile> \<langle>[], t\<rangle> \<Rightarrow>\<^sub>\<alpha> t" |
accept:  "\<lbrakk>matches \<gamma> m Accept p\<rbrakk> \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>[Rule m Accept], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow" |
drop:  "\<lbrakk>matches \<gamma> m Drop p\<rbrakk> \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>[Rule m Drop], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny" |
reject:  "\<lbrakk>matches \<gamma> m Reject p\<rbrakk> \<Longrightarrow>  \<gamma>,p\<turnstile> \<langle>[Rule m Reject], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny" |
log:   "\<lbrakk>matches \<gamma> m Log p\<rbrakk> \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>[Rule m Log], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Undecided" |
empty:   "\<lbrakk>matches \<gamma> m Empty p\<rbrakk> \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>[Rule m Empty], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Undecided" |
nomatch:  "\<lbrakk>\<not> matches \<gamma> m a p\<rbrakk> \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>[Rule m a], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Undecided" |
decision:  "\<gamma>,p\<turnstile> \<langle>rs, Decision X\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision X" |
seq:  "\<lbrakk>\<gamma>,p\<turnstile> \<langle>rs\<^sub>1, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t; \<gamma>,p\<turnstile> \<langle>rs\<^sub>2, t\<rangle> \<Rightarrow>\<^sub>\<alpha> t'\<rbrakk> \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>rs\<^sub>1@rs\<^sub>2, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t'"

thm approximating_bigstep.induct[of \<gamma> p rs s t P]
(*tuned induction rule*)
lemma approximating_bigstep_induct[case_names Skip Allow Deny Log Nomatch Decision Seq, induct pred: approximating_bigstep] : "\<gamma>,p\<turnstile> \<langle>rs,s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow>
(\<And>t. P [] t t) \<Longrightarrow>
(\<And>m a. matches \<gamma> m a p \<Longrightarrow> a = Accept \<Longrightarrow> P [Rule m a] Undecided (Decision FinalAllow)) \<Longrightarrow>
(\<And>m a. matches \<gamma> m a p \<Longrightarrow> a = Drop \<or> a = Reject \<Longrightarrow> P [Rule m a] Undecided (Decision FinalDeny)) \<Longrightarrow>
(\<And>m a. matches \<gamma> m a p \<Longrightarrow> a = Log \<or> a = Empty \<Longrightarrow> P [Rule m a] Undecided Undecided) \<Longrightarrow>
(\<And>m a. \<not> matches \<gamma> m a p \<Longrightarrow> P [Rule m a] Undecided Undecided) \<Longrightarrow>
(\<And>rs X. P rs (Decision X) (Decision X)) \<Longrightarrow>
(\<And>rs rs\<^sub>1 rs\<^sub>2 t t'. rs = rs\<^sub>1 @ rs\<^sub>2 \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>rs\<^sub>1,Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> P rs\<^sub>1 Undecided t \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>rs\<^sub>2,t\<rangle> \<Rightarrow>\<^sub>\<alpha> t' \<Longrightarrow> P rs\<^sub>2 t t' \<Longrightarrow> P rs Undecided t')
   \<Longrightarrow> P rs s t"
by (induction rule: approximating_bigstep.induct) (simp_all)

lemma skipD: "\<gamma>,p\<turnstile> \<langle>[], s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> s = t"
by (induction "[]::'a rule list" s t rule: approximating_bigstep_induct) (simp_all)

lemma decisionD: "\<gamma>,p\<turnstile> \<langle>rs, Decision X\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> t = Decision X"
by (induction rs "Decision X" t rule: approximating_bigstep_induct) (simp_all)

lemma acceptD: "\<gamma>,p\<turnstile> \<langle>[Rule m Accept], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> matches \<gamma> m Accept p \<Longrightarrow> t = Decision FinalAllow"
proof (induction "[Rule m Accept]" Undecided t rule: approximating_bigstep_induct)
  case Seq thus ?case by (metis list_app_singletonE skipD)
qed(simp_all)

lemma rejectD: "\<gamma>,p\<turnstile> \<langle>[Rule m Reject], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> matches \<gamma> m Reject p \<Longrightarrow> t = Decision FinalDeny"
apply (induction "[Rule m Reject]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemma logD: "\<gamma>,p\<turnstile> \<langle>[Rule m Log], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> t = Undecided"
apply (induction "[Rule m Log]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemma emptyD: "\<gamma>,p\<turnstile> \<langle>[Rule m Empty], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> t = Undecided"
apply (induction "[Rule m Empty]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemma nomatchD: "\<gamma>,p\<turnstile> \<langle>[Rule m a], Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> \<not> matches \<gamma> m a p \<Longrightarrow> t = Undecided"
apply (induction "[Rule m a]" Undecided t rule: approximating_bigstep_induct)
by(auto dest: skipD elim!: rules_singleton_rev_E)

lemmas approximating_bigstepD = skipD acceptD dropD rejectD logD emptyD nomatchD decisionD

lemma approximating_bigstep_to_undecided: "\<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> Undecided \<Longrightarrow> s = Undecided"
  by (metis decisionD state.exhaust)

lemma approximating_bigstep_to_decision1: "\<gamma>,p\<turnstile> \<langle>rs, Decision Y\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision X \<Longrightarrow> Y = X"
  by (metis decisionD state.inject)

lemma nomatch_fst: "\<not> matches \<gamma> m a p \<Longrightarrow>  \<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>Rule m a # rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
  apply(cases s)
   apply(clarify)
   apply(drule nomatch)
   apply(drule(1) seq)
   apply (simp; fail)
  apply(clarify)
  apply(drule decisionD)
  apply(clarify)
 apply(simp add: decision)
done

lemma seq':
  assumes "rs = rs\<^sub>1 @ rs\<^sub>2" "\<gamma>,p\<turnstile> \<langle>rs\<^sub>1,s\<rangle> \<Rightarrow>\<^sub>\<alpha> t" "\<gamma>,p\<turnstile> \<langle>rs\<^sub>2,t\<rangle> \<Rightarrow>\<^sub>\<alpha> t'"
  shows "\<gamma>,p\<turnstile> \<langle>rs,s\<rangle> \<Rightarrow>\<^sub>\<alpha> t'"
using assms by (cases s) (auto intro: seq decision dest: decisionD)

lemma seq_split:
  assumes "\<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t" "rs = rs\<^sub>1@rs\<^sub>2"
  obtains t' where "\<gamma>,p\<turnstile> \<langle>rs\<^sub>1,s\<rangle> \<Rightarrow>\<^sub>\<alpha> t'" "\<gamma>,p\<turnstile> \<langle>rs\<^sub>2,t'\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
  using assms
  proof (induction rs s t arbitrary: rs\<^sub>1 rs\<^sub>2 thesis rule: approximating_bigstep_induct)
    case Allow thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case Deny thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case Log thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case Nomatch thus ?case by (auto dest: skipD elim!: rules_singleton_rev_E intro: approximating_bigstep.intros)
  next
    case (Seq rs rsa rsb t t')
    hence rs: "rsa @ rsb = rs\<^sub>1 @ rs\<^sub>2" by simp
    note List.append_eq_append_conv_if[simp]
    from rs show ?case
      proof (cases rule: list_app_eq_cases)
        case longer
        with Seq have t1: "\<gamma>,p\<turnstile> \<langle>take (length rsa) rs\<^sub>1, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
          by simp
        from Seq longer obtain t2
          where t2a: "\<gamma>,p\<turnstile> \<langle>drop (length rsa) rs\<^sub>1,t\<rangle> \<Rightarrow>\<^sub>\<alpha> t2"
            and rs2_t2: "\<gamma>,p\<turnstile> \<langle>rs\<^sub>2,t2\<rangle> \<Rightarrow>\<^sub>\<alpha> t'"
          by blast
        with t1 rs2_t2 have "\<gamma>,p\<turnstile> \<langle>take (length rsa) rs\<^sub>1 @ drop (length rsa) rs\<^sub>1,Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t2"
          by (blast intro: approximating_bigstep.seq)
        with Seq rs2_t2 show ?thesis
          by simp
      next
        case shorter
        with rs have rsa': "rsa = rs\<^sub>1 @ take (length rsa - length rs\<^sub>1) rs\<^sub>2"
          by (metis append_eq_conv_conj length_drop)
        from shorter rs have rsb': "rsb = drop (length rsa - length rs\<^sub>1) rs\<^sub>2"
          by (metis append_eq_conv_conj length_drop)
        from Seq rsa' obtain t1
          where t1a: "\<gamma>,p\<turnstile> \<langle>rs\<^sub>1,Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t1"
            and t1b: "\<gamma>,p\<turnstile> \<langle>take (length rsa - length rs\<^sub>1) rs\<^sub>2,t1\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
          by blast
        from rsb' Seq.hyps have t2: "\<gamma>,p\<turnstile> \<langle>drop (length rsa - length rs\<^sub>1) rs\<^sub>2,t\<rangle> \<Rightarrow>\<^sub>\<alpha> t'"
          by blast
        with seq' t1b have "\<gamma>,p\<turnstile> \<langle>rs\<^sub>2,t1\<rangle> \<Rightarrow>\<^sub>\<alpha> t'" by (metis append_take_drop_id)
        with Seq t1a show ?thesis
          by fast
      qed
  qed (auto intro: approximating_bigstep.intros)

lemma seqE_fst:
  assumes "\<gamma>,p\<turnstile> \<langle>r#rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
  obtains t' where "\<gamma>,p\<turnstile> \<langle>[r],s\<rangle> \<Rightarrow>\<^sub>\<alpha> t'" "\<gamma>,p\<turnstile> \<langle>rs,t'\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
  using assms seq_split by (metis append_Cons append_Nil)

lemma seq_fst: assumes "\<gamma>,p\<turnstile> \<langle>[r], s\<rangle> \<Rightarrow>\<^sub>\<alpha> t" and "\<gamma>,p\<turnstile> \<langle>rs, t\<rangle> \<Rightarrow>\<^sub>\<alpha> t'" shows "\<gamma>,p\<turnstile> \<langle>r # rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t'"
proof(cases s)
  case Undecided with assms seq show "\<gamma>,p\<turnstile> \<langle>r # rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t'" by fastforce
  next
  case Decision with assms show "\<gamma>,p\<turnstile> \<langle>r # rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t'"
  by(auto simp: decision dest!: decisionD)
qed

subsection\<open>wf ruleset\<close>
  text\<open>
  A @{typ "'a rule list"} here is well-formed (for a packet) if
    \<^item> either the rules do not match
    \<^item> or the action is not @{const Call}, not @{const Return}, not @{const Unknown}
\<close>
  definition wf_ruleset :: "('a, 'p) match_tac \<Rightarrow> 'p \<Rightarrow> 'a rule list \<Rightarrow> bool" where
    "wf_ruleset \<gamma> p rs \<equiv> \<forall>r \<in> set rs.
      (\<not> matches \<gamma> (get_match r) (get_action r) p) \<or>
      (\<not>(\<exists>chain. get_action r = Call chain) \<and> get_action r \<noteq> Return \<and> \<not>(\<exists>chain. get_action r = Goto chain) \<and> get_action r \<noteq> Unknown)"

  lemma wf_ruleset_append: "wf_ruleset \<gamma> p (rs1@rs2) \<longleftrightarrow> wf_ruleset \<gamma> p rs1 \<and> wf_ruleset \<gamma> p rs2"
    by(auto simp add: wf_ruleset_def)
  lemma wf_rulesetD: assumes "wf_ruleset \<gamma> p (r # rs)" shows "wf_ruleset \<gamma> p [r]" and "wf_ruleset \<gamma> p rs"
    using assms by(auto simp add: wf_ruleset_def)
  lemma wf_ruleset_fst: "wf_ruleset \<gamma> p (Rule m a # rs) \<longleftrightarrow> wf_ruleset \<gamma> p [Rule m a] \<and> wf_ruleset \<gamma> p rs"
    by(auto simp add: wf_ruleset_def)
  lemma wf_ruleset_stripfst: "wf_ruleset \<gamma> p (r # rs) \<Longrightarrow> wf_ruleset \<gamma> p (rs)"
    by(simp add: wf_ruleset_def)
  lemma wf_ruleset_rest: "wf_ruleset \<gamma> p (Rule m a # rs) \<Longrightarrow> wf_ruleset \<gamma> p [Rule m a]"
    by(simp add: wf_ruleset_def)

subsection\<open>Ternary Semantics (Function)\<close>

fun approximating_bigstep_fun :: "('a, 'p) match_tac \<Rightarrow> 'p \<Rightarrow> 'a rule list \<Rightarrow> state \<Rightarrow> state" where
  "approximating_bigstep_fun \<gamma> p [] s = s" |
  "approximating_bigstep_fun \<gamma> p rs (Decision X) = (Decision X)" |
  "approximating_bigstep_fun \<gamma> p ((Rule m a)#rs) Undecided = (if
      \<not> matches \<gamma> m a p
    then
      approximating_bigstep_fun \<gamma> p rs Undecided
    else
      case a of Accept \<Rightarrow> Decision FinalAllow
              | Drop \<Rightarrow> Decision FinalDeny
              | Reject \<Rightarrow> Decision FinalDeny
              | Log \<Rightarrow> approximating_bigstep_fun \<gamma> p rs Undecided
              | Empty \<Rightarrow> approximating_bigstep_fun \<gamma> p rs Undecided
              (*unhalndled cases*)
              )"

(*tuned induction rule*)
lemma approximating_bigstep_fun_induct[case_names Empty Decision Nomatch Match] : "
(\<And>\<gamma> p s. P \<gamma> p [] s) \<Longrightarrow>
(\<And>\<gamma> p r rs X. P \<gamma> p (r # rs) (Decision X)) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    \<not> matches \<gamma> m a p \<Longrightarrow> P \<gamma> p rs Undecided \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    matches \<gamma> m a p \<Longrightarrow> (a = Log \<Longrightarrow> P \<gamma> p rs Undecided) \<Longrightarrow> (a = Empty \<Longrightarrow> P \<gamma> p rs Undecided) \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
P \<gamma> p rs s"
apply (rule approximating_bigstep_fun.induct[of P \<gamma> p rs s])
  apply (simp_all)
by metis

lemma Decision_approximating_bigstep_fun: "approximating_bigstep_fun \<gamma> p rs (Decision X) = Decision X"
  by(induction rs) (simp_all)

lemma approximating_bigstep_fun_induct_wf[case_names Empty Decision Nomatch MatchAccept MatchDrop MatchReject MatchLog MatchEmpty, consumes 1]:
  "wf_ruleset \<gamma> p rs \<Longrightarrow>
(\<And>\<gamma> p s. P \<gamma> p [] s) \<Longrightarrow>
(\<And>\<gamma> p r rs X. P \<gamma> p (r # rs) (Decision X)) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    \<not> matches \<gamma> m a p \<Longrightarrow> P \<gamma> p rs Undecided \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    matches \<gamma> m a p \<Longrightarrow> a = Accept  \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    matches \<gamma> m a p \<Longrightarrow> a = Drop \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    matches \<gamma> m a p \<Longrightarrow> a = Reject \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    matches \<gamma> m a p \<Longrightarrow> a = Log \<Longrightarrow> P \<gamma> p rs Undecided  \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
(\<And>\<gamma> p m a rs.
    matches \<gamma> m a p \<Longrightarrow> a = Empty \<Longrightarrow> P \<gamma> p rs Undecided \<Longrightarrow> P \<gamma> p (Rule m a # rs) Undecided) \<Longrightarrow>
P \<gamma> p rs s"
  proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct)
  case Empty thus ?case by blast
  next
  case Decision thus ?case by blast
  next
  case Nomatch thus ?case by(simp add: wf_ruleset_def)
  next
  case (Match \<gamma> p m a) thus ?case
    apply -
    apply(frule wf_rulesetD(1), drule wf_rulesetD(2))
    apply(simp)
    apply(cases a)
           apply(simp_all)
      apply(auto simp add: wf_ruleset_def)
    done
  qed

lemma just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided[case_names Undecided]:
      assumes "s = Undecided \<Longrightarrow> approximating_bigstep_fun \<gamma> p rs1 s = approximating_bigstep_fun \<gamma> p rs2 s"
      shows "approximating_bigstep_fun \<gamma> p rs1 s = approximating_bigstep_fun \<gamma> p rs2 s"
  proof(cases s)
  case Undecided thus ?thesis using assms by simp
  next
  case Decision thus ?thesis by (simp add: Decision_approximating_bigstep_fun)
  qed

subsubsection\<open>Append, Prepend, Postpend, Composition\<close>
  lemma approximating_bigstep_fun_seq_wf: "\<lbrakk> wf_ruleset \<gamma> p rs\<^sub>1\<rbrakk> \<Longrightarrow>
      approximating_bigstep_fun \<gamma> p (rs\<^sub>1 @ rs\<^sub>2) s = approximating_bigstep_fun \<gamma> p rs\<^sub>2 (approximating_bigstep_fun \<gamma> p rs\<^sub>1 s)"
   proof(induction \<gamma> p rs\<^sub>1 s rule: approximating_bigstep_fun_induct)
   qed(simp_all add: wf_ruleset_def Decision_approximating_bigstep_fun split: action.split)

  text\<open>The state transitions from @{const Undecided} to @{const Undecided} if all intermediate states are @{const Undecided}\<close>
 lemma approximating_bigstep_fun_seq_Undecided_wf: "\<lbrakk> wf_ruleset \<gamma> p (rs1@rs2)\<rbrakk> \<Longrightarrow>
      approximating_bigstep_fun \<gamma> p (rs1@rs2) Undecided = Undecided \<longleftrightarrow>
  approximating_bigstep_fun \<gamma> p rs1 Undecided = Undecided \<and> approximating_bigstep_fun \<gamma> p rs2 Undecided = Undecided"
    proof(induction \<gamma> p rs1 Undecided rule: approximating_bigstep_fun_induct)
    qed(simp_all add: wf_ruleset_def split: action.split)

  lemma approximating_bigstep_fun_seq_Undecided_t_wf: "\<lbrakk> wf_ruleset \<gamma> p (rs1@rs2)\<rbrakk> \<Longrightarrow>
      approximating_bigstep_fun \<gamma> p (rs1@rs2) Undecided = t \<longleftrightarrow>
  approximating_bigstep_fun \<gamma> p rs1 Undecided = Undecided \<and> approximating_bigstep_fun \<gamma> p rs2 Undecided = t \<or>
  approximating_bigstep_fun \<gamma> p rs1 Undecided = t \<and> t \<noteq> Undecided"
  proof(induction \<gamma> p rs1 Undecided rule: approximating_bigstep_fun_induct)
  case Empty thus ?case by(cases t) simp_all
  next
  case Nomatch thus ?case by(simp add: wf_ruleset_def)
  next
  case Match thus ?case by(auto simp add: wf_ruleset_def split: action.split)
  qed

  lemma approximating_bigstep_fun_wf_postpend: "wf_ruleset \<gamma> p rsA \<Longrightarrow> wf_ruleset \<gamma> p rsB \<Longrightarrow>
      approximating_bigstep_fun \<gamma> p rsA s = approximating_bigstep_fun \<gamma> p rsB s \<Longrightarrow>
      approximating_bigstep_fun \<gamma> p (rsA@rsC) s = approximating_bigstep_fun \<gamma> p (rsB@rsC) s"
  apply(induction \<gamma> p rsA s rule: approximating_bigstep_fun_induct_wf)
         apply(simp_all add: approximating_bigstep_fun_seq_wf)
     apply (metis Decision_approximating_bigstep_fun)+
  done

lemma approximating_bigstep_fun_singleton_prepend:
    assumes "approximating_bigstep_fun \<gamma> p rsB s = approximating_bigstep_fun \<gamma> p rsC s"
    shows "approximating_bigstep_fun \<gamma> p (r#rsB) s = approximating_bigstep_fun \<gamma> p (r#rsC) s"
  proof(cases s)
  case Decision thus ?thesis by(simp add: Decision_approximating_bigstep_fun)
  next
  case Undecided
  with assms show ?thesis by(cases r)(simp split: action.split)
  qed

subsection\<open>Equality with @{term "\<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t"} semantics\<close>
  lemma approximating_bigstep_wf: "\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Undecided \<Longrightarrow> wf_ruleset \<gamma> p rs"
  unfolding wf_ruleset_def
  proof(induction rs Undecided Undecided rule: approximating_bigstep_induct)
    case Skip thus ?case by simp
    next
    case Log thus ?case by auto
    next
    case Nomatch thus ?case by simp
    next
    case (Seq rs rs1 rs2 t)
      from Seq approximating_bigstep_to_undecided have "t = Undecided" by fast
      from this Seq show ?case by auto
  qed

  text\<open>only valid actions appear in this ruleset\<close>
  definition good_ruleset :: "'a rule list \<Rightarrow> bool" where
    "good_ruleset rs \<equiv> \<forall>r \<in> set rs. (\<not>(\<exists>chain. get_action r = Call chain) \<and> get_action r \<noteq> Return \<and> \<not>(\<exists>chain. get_action r = Goto chain) \<and> get_action r \<noteq> Unknown)"

  lemma good_ruleset_alt: "good_ruleset rs = (\<forall>r\<in>set rs. get_action r = Accept \<or> get_action r = Drop \<or>
                                                get_action r = Reject \<or> get_action r = Log  \<or> get_action r = Empty)"
      unfolding good_ruleset_def
      apply(rule Set.ball_cong)
       apply(simp_all)
      apply(rename_tac r)
      by(case_tac "get_action r")(simp_all)

  lemma good_ruleset_append: "good_ruleset (rs\<^sub>1 @ rs\<^sub>2) \<longleftrightarrow> good_ruleset rs\<^sub>1 \<and> good_ruleset rs\<^sub>2"
    by(simp add: good_ruleset_alt, blast)

  lemma good_ruleset_fst: "good_ruleset (r#rs) \<Longrightarrow> good_ruleset [r]"
    by(simp add: good_ruleset_def)
  lemma good_ruleset_tail: "good_ruleset (r#rs) \<Longrightarrow> good_ruleset rs"
    by(simp add: good_ruleset_def)

  text\<open>
    @{term good_ruleset} is stricter than @{term wf_ruleset}. It can be easily checked with running code!
\<close>
  lemma good_imp_wf_ruleset: "good_ruleset rs \<Longrightarrow> wf_ruleset \<gamma> p rs" by (metis good_ruleset_def wf_ruleset_def)

  lemma simple_imp_good_ruleset: "simple_ruleset rs \<Longrightarrow> good_ruleset rs"
    by(simp add: simple_ruleset_def good_ruleset_def, fastforce)

lemma approximating_bigstep_fun_seq_semantics: "\<lbrakk> \<gamma>,p\<turnstile> \<langle>rs\<^sub>1, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<rbrakk> \<Longrightarrow>
    approximating_bigstep_fun \<gamma> p (rs\<^sub>1 @ rs\<^sub>2) s = approximating_bigstep_fun \<gamma> p rs\<^sub>2 t"
  proof(induction rs\<^sub>1 s t arbitrary: rs\<^sub>2 rule: approximating_bigstep.induct)
  qed(simp_all add: Decision_approximating_bigstep_fun)

lemma approximating_semantics_imp_fun: "\<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<Longrightarrow> approximating_bigstep_fun \<gamma> p rs s = t"
  proof(induction rs s t rule: approximating_bigstep_induct)
  qed(auto simp add: approximating_bigstep_fun_seq_semantics Decision_approximating_bigstep_fun)

lemma approximating_fun_imp_semantics: assumes "wf_ruleset \<gamma> p rs"
      shows "approximating_bigstep_fun \<gamma> p rs s = t \<Longrightarrow> \<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
  using assms proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct_wf)
    case (Empty \<gamma> p s)
      thus "\<gamma>,p\<turnstile> \<langle>[], s\<rangle> \<Rightarrow>\<^sub>\<alpha> t"  using skip by(simp)
    next
    case (Decision \<gamma> p r rs X)
      hence "t = Decision X" by simp
      thus "\<gamma>,p\<turnstile> \<langle>r # rs, Decision X\<rangle> \<Rightarrow>\<^sub>\<alpha> t" using decision by fast
    next
    case (Nomatch \<gamma> p m a rs)
      thus "\<gamma>,p\<turnstile> \<langle>Rule m a # rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
        apply(rule_tac t=Undecided in seq_fst)
         apply(simp add: nomatch)
        apply(simp add: Nomatch.IH)
        done
    next
    case (MatchAccept \<gamma> p m a rs)
      hence "t = Decision FinalAllow" by simp
      thus ?case by (metis MatchAccept.hyps accept decision seq_fst)
    next
    case (MatchDrop \<gamma> p m a rs)
      hence "t = Decision FinalDeny" by simp
      thus ?case by (metis MatchDrop.hyps drop decision seq_fst)
    next
    case (MatchReject \<gamma> p m a rs)
      hence "t = Decision FinalDeny" by simp
      thus ?case by (metis MatchReject.hyps reject decision seq_fst)
    next
    case (MatchLog \<gamma> p m a rs)
      thus ?case
        apply(simp)
        apply(rule_tac t=Undecided in seq_fst)
         apply(simp add: log)
        apply(simp add: MatchLog.IH)
        done
    next
    case (MatchEmpty \<gamma> p m a rs)
      thus ?case
        apply(simp)
        apply(rule_tac t=Undecided in seq_fst)
         apply(simp add: empty)
        apply(simp add: MatchEmpty.IH)
        done
    qed

text\<open>Henceforth, we will use the @{term approximating_bigstep_fun} semantics, because they are easier.
We show that they are equal.
\<close>
theorem approximating_semantics_iff_fun: "wf_ruleset \<gamma> p rs \<Longrightarrow>
    \<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<longleftrightarrow> approximating_bigstep_fun \<gamma> p rs s = t"
by (metis approximating_fun_imp_semantics approximating_semantics_imp_fun)

corollary approximating_semantics_iff_fun_good_ruleset: "good_ruleset rs \<Longrightarrow>
    \<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<longleftrightarrow> approximating_bigstep_fun \<gamma> p rs s = t"
  by (metis approximating_semantics_iff_fun good_imp_wf_ruleset)

lemma approximating_bigstep_deterministic: "\<lbrakk> \<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t; \<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t' \<rbrakk> \<Longrightarrow> t = t'"
  proof(induction arbitrary: t' rule: approximating_bigstep_induct)
  case Seq thus ?case
    by (metis (hide_lams, mono_tags) append_Nil2 approximating_bigstep_fun.simps(1) approximating_bigstep_fun_seq_semantics)
  qed(auto dest: approximating_bigstepD)

lemma rm_LogEmpty_fun_semantics:
  "approximating_bigstep_fun \<gamma> p (rm_LogEmpty rs) s = approximating_bigstep_fun \<gamma> p rs s"
  proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct)
    case Empty thus ?case by(simp)
    next
    case Decision thus ?case by(simp add: Decision_approximating_bigstep_fun)
    next
    case (Nomatch \<gamma> p m a rs) thus ?case by(cases a,simp_all)
    next
    case (Match \<gamma> p m a rs) thus ?case by(cases a,simp_all)
  qed

(*we probably don't need the following*)
lemma "\<gamma>,p\<turnstile> \<langle>rm_LogEmpty rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t \<longleftrightarrow> \<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow>\<^sub>\<alpha> t"
apply(rule iffI)
 apply(induction rs arbitrary: s t)
  apply(simp_all)
 apply(rename_tac r rs s t)
 apply(case_tac r)
 apply(simp)
 apply(rename_tac m a)
 apply(case_tac a)
         apply(simp_all)
         apply(auto intro: approximating_bigstep.intros )
         apply(erule seqE_fst, simp add: seq_fst)
        apply(erule seqE_fst, simp add: seq_fst)
       apply (metis decision log nomatch_fst seq_fst state.exhaust)
      apply(erule seqE_fst, simp add: seq_fst)
     apply(erule seqE_fst, simp add: seq_fst)
    apply(erule seqE_fst, simp add: seq_fst)
   apply(erule seqE_fst, simp add: seq_fst)
  apply (metis decision empty nomatch_fst seq_fst state.exhaust)
 apply(erule seqE_fst, simp add: seq_fst)
apply(induction rs s t rule: approximating_bigstep_induct)
      apply(auto intro: approximating_bigstep.intros)
 apply(rename_tac m a)
 apply(case_tac a)
         apply(auto intro: approximating_bigstep.intros)
apply(rename_tac rs\<^sub>1 rs\<^sub>2 t t')
apply(drule_tac rs\<^sub>1="rm_LogEmpty rs\<^sub>1" and rs\<^sub>2="rm_LogEmpty rs\<^sub>2" in seq)
 apply(simp_all)
using rm_LogEmpty_seq apply metis
done

lemma rm_LogEmpty_simple_but_Reject:
  "good_ruleset rs \<Longrightarrow> \<forall>r \<in> set (rm_LogEmpty rs). get_action r = Accept \<or> get_action r = Reject \<or> get_action r = Drop"
  proof(induction rs)
  case Nil thus ?case by(simp add: good_ruleset_def)
  next
  case (Cons r rs) thus ?case
    apply(clarify)
    apply(cases r, rename_tac m a, simp)
    by(case_tac a) (auto simp add: good_ruleset_def)
  qed

lemma rw_Reject_fun_semantics:
  "wf_unknown_match_tac \<alpha> \<Longrightarrow>
  (approximating_bigstep_fun (\<beta>, \<alpha>) p (rw_Reject rs) s = approximating_bigstep_fun (\<beta>, \<alpha>) p rs s)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    thus ?case
      apply(case_tac r, rename_tac m a, simp)
      apply(case_tac a)
              apply(case_tac [!] s)
                      apply(auto dest: wf_unknown_match_tacD_False1 wf_unknown_match_tacD_False2)
      done
    qed

lemma rmLogEmpty_rwReject_good_to_simple: "good_ruleset rs \<Longrightarrow> simple_ruleset (rw_Reject (rm_LogEmpty rs))"
  apply(drule rm_LogEmpty_simple_but_Reject)
  apply(simp add: simple_ruleset_def)
  apply(induction rs)
   apply(simp_all)
  apply(rename_tac r rs)
  apply(case_tac r)
  apply(rename_tac m a)
  apply(case_tac a)
          apply(simp_all)
  done

subsection\<open>Matching\<close>
lemma optimize_matches_option_generic:
  assumes "\<forall> r \<in> set rs. P (get_match r) (get_action r)"
      and "(\<And>m m' a. P m a \<Longrightarrow> f m = Some m' \<Longrightarrow> matches \<gamma> m' a p = matches \<gamma> m a p)"
      and "(\<And>m a. P m a \<Longrightarrow> f m = None \<Longrightarrow> \<not> matches \<gamma> m a p)"
  shows "approximating_bigstep_fun \<gamma> p (optimize_matches_option f rs) s = approximating_bigstep_fun \<gamma> p rs s"
    using assms proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct)
      case Decision thus ?case by (simp add: Decision_approximating_bigstep_fun)
    next
      case (Nomatch \<gamma> p m a rs) thus ?case
        apply(simp)
        apply(cases "f m")
         apply(simp; fail)
        apply(simp del: approximating_bigstep_fun.simps)
        apply(rename_tac m')
        apply(subgoal_tac "\<not> matches \<gamma> m' a p")
         apply(simp; fail)
        using assms by blast
    next
      case (Match \<gamma> p m a rs) thus ?case
        apply(cases "f m")
         apply(simp; fail)
        apply(simp del: approximating_bigstep_fun.simps)
        apply(rename_tac m')
        apply(subgoal_tac "matches \<gamma> m' a p")
         apply(simp split: action.split; fail)
        using assms by blast
    qed(simp)

lemma optimize_matches_generic: "\<forall> r \<in> set rs. P (get_match r) (get_action r) \<Longrightarrow>
      (\<And>m a. P m a \<Longrightarrow> matches \<gamma> (f m) a p = matches \<gamma> m a p) \<Longrightarrow>
      approximating_bigstep_fun \<gamma> p (optimize_matches f rs) s = approximating_bigstep_fun \<gamma> p rs s"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_generic)
    apply(simp; fail)
   apply(simp split: if_split_asm)
   apply blast
  apply(simp split: if_split_asm)
  using matcheq_matchNone_not_matches by fast

lemma optimize_matches_matches_fst: "matches \<gamma> (f m) a p \<Longrightarrow> optimize_matches f (Rule m a # rs) = (Rule (f m) a)# optimize_matches f rs"
  apply(simp add: optimize_matches_def)
  by (meson matcheq_matchNone_not_matches)

lemma optimize_matches: "\<forall>m a. matches \<gamma> (f m) a p = matches \<gamma> m a p \<Longrightarrow> approximating_bigstep_fun \<gamma> p (optimize_matches f rs) s = approximating_bigstep_fun \<gamma> p rs s"
  using optimize_matches_generic[where P="\<lambda>_ _. True"] by metis

lemma optimize_matches_opt_MatchAny_match_expr: "approximating_bigstep_fun \<gamma> p (optimize_matches opt_MatchAny_match_expr rs) s = approximating_bigstep_fun \<gamma> p rs s"
using optimize_matches opt_MatchAny_match_expr_correct by metis

lemma optimize_matches_a: "\<forall>a m. matches \<gamma> m a = matches \<gamma> (f a m) a \<Longrightarrow> approximating_bigstep_fun \<gamma> p (optimize_matches_a f rs) s = approximating_bigstep_fun \<gamma> p rs s"
  proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct)
    case (Match \<gamma> p m a rs) thus ?case by(case_tac a)(simp_all add: optimize_matches_a_def)
  qed(simp_all add: optimize_matches_a_def)

lemma optimize_matches_a_simplers:
  assumes "simple_ruleset rs" and "\<forall>a m. a = Accept \<or> a = Drop \<longrightarrow> matches \<gamma> (f a m) a = matches \<gamma> m a"
  shows "approximating_bigstep_fun \<gamma> p (optimize_matches_a f rs) s = approximating_bigstep_fun \<gamma> p rs s"
proof -
  from assms(1) have "wf_ruleset \<gamma> p rs" by(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
  from \<open>wf_ruleset \<gamma> p rs\<close> assms show "approximating_bigstep_fun \<gamma> p (optimize_matches_a f rs) s = approximating_bigstep_fun \<gamma> p rs s"
    proof(induction \<gamma> p rs s rule: approximating_bigstep_fun_induct_wf)
    case Nomatch thus ?case
     apply(simp add: optimize_matches_a_def simple_ruleset_def)
     apply(safe)
      apply(simp_all)
    done
    next
    case MatchReject thus ?case by(simp add: optimize_matches_a_def simple_ruleset_def)
    qed(simp_all add: optimize_matches_a_def simple_ruleset_tail)
qed

lemma not_matches_removeAll: "\<not> matches \<gamma> m a p \<Longrightarrow>
  approximating_bigstep_fun \<gamma> p (removeAll (Rule m a) rs) Undecided = approximating_bigstep_fun \<gamma> p rs Undecided"
  apply(induction \<gamma> p rs Undecided rule: approximating_bigstep_fun.induct)
   apply(simp)
  apply(simp split: action.split)
  apply blast
  done

end


theory Ex_CFG
imports Monad2
begin
  term fold

  datatype err = STATIC_ERROR

  type_synonym state = "string \<Rightarrow> int"
  type_synonym label = string
  type_synonym proc_name = string
  type_synonym val = "int"

  datatype nt_instr = I_BASIC "state \<Rightarrow> state" | I_CALL proc_name

  datatype t_instr = TI_RETURN | TI_BR label | TI_CBR "state\<Rightarrow>bool" label label

  datatype bblock = BBLOCK (nt_instrs: "nt_instr list") (t_instr: "t_instr")

  type_synonym proc_body = "label \<rightharpoonup> bblock"
  type_synonym prog = "proc_name \<rightharpoonup> proc_body"

  context
    fixes \<pi> :: prog
  begin

    context
      fixes execute :: "proc_body \<times> label \<Rightarrow> (unit,unit,state,err) M"
    begin

      definition "exec_nt_instr ins \<equiv> case ins of
        I_BASIC f \<Rightarrow> doM { s\<leftarrow>get; set (f s)}
      | I_CALL p \<Rightarrow> doM {
          \<beta> \<leftarrow> lookup STATIC_ERROR \<pi> p;
          handle (doM {execute (\<beta>,''__start''); fail STATIC_ERROR}) (\<lambda>_. return ());
          return ()
        }"

      fun exec_t_instr where
        "exec_t_instr (TI_RETURN) = doM {
          raise ()
        }"
      | "exec_t_instr (TI_BR l) = return l"
      | "exec_t_instr (TI_CBR c l1 l2) = doM {
          s\<leftarrow>get;
          if c s then return l1 else return l2
      }"

      definition "execute_body \<equiv> \<lambda>(\<beta>,l). doM {
        bb \<leftarrow> lookup STATIC_ERROR \<beta> l;
        mfold' exec_nt_instr (nt_instrs bb);
        l \<leftarrow> exec_t_instr (t_instr bb);
        execute (\<beta>,l)
      }"
    end

    definition "execute \<equiv> REC execute_body"

    lemma mono_mfold[partial_function_mono]:
      "\<lbrakk>\<And>x s. M.mono_body (\<lambda>f. F f x s)\<rbrakk> \<Longrightarrow> M.mono_body (\<lambda>f. mfold (F f) xs s)"
      apply (induction xs arbitrary: s)
      apply simp_all
      apply pf_mono_prover
      apply pf_mono_prover
      apply simp_all
      done

    lemma mono_exec_ntinstr[partial_function_mono]: "M.mono_body (\<lambda>f. local.exec_nt_instr f ins)"
      by (cases ins; simp add: exec_nt_instr_def; pf_mono_prover)

    lemma mono_execute_body[partial_function_mono]: "\<And>x. M.mono_body (\<lambda>fa. local.execute_body fa x)"
      unfolding execute_body_def
      by pf_mono_prover

  end

  lemmas
        execute_unfold[code] = REC_unfold[OF execute_def, discharge_monos]
    and execute_partial = lrmwpe_REC_partial[OF execute_def, discharge_monos, consumes 1, case_names nonterm step]
    and execute_total = lrmwpe_REC_total[OF execute_def, discharge_monos, consumes 1, case_names wf step]
    and execute_sim[sim_rules] = sim_REC[OF execute_def execute_def, discharge_monos]

  term execute

  thm sim_rules

  lemma execute_sm_sim[sim_rules]:
    assumes "\<pi> \<subseteq>\<^sub>m \<pi>'"
    shows "sim (execute \<pi> \<beta>l) (execute \<pi>' \<beta>l)"
    using assms
    by (auto intro!: sim_rules split!: nt_instr.split simp: execute_body_def exec_nt_instr_def)

  fun wf_nt_instr where
    "wf_nt_instr \<pi> (I_BASIC f) \<longleftrightarrow> True"
  | "wf_nt_instr \<pi> (I_CALL p) \<longleftrightarrow> p\<in>dom \<pi>"

  fun wf_t_instr where
    "wf_t_instr \<pi> \<beta> (TI_RETURN) \<longleftrightarrow> True"
  | "wf_t_instr \<pi> \<beta> (TI_BR l) \<longleftrightarrow> l\<in>dom \<beta>"
  | "wf_t_instr \<pi> \<beta> (TI_CBR c l1 l2) \<longleftrightarrow> l1\<in>dom \<beta> \<and> l2\<in>dom \<beta>"

  fun wf_basic_block where
    "wf_basic_block \<pi> \<beta> (BBLOCK ntis ti) \<longleftrightarrow> (\<forall>nti\<in>List.set ntis. wf_nt_instr \<pi> nti) \<and> wf_t_instr \<pi> \<beta> ti"

  definition "wf_proc_body \<pi> b \<equiv> ''__start''\<in>dom b \<and> (\<forall>bb\<in>ran b. wf_basic_block \<pi> b bb)"

  definition "wf_prog \<pi> \<equiv> \<forall>b\<in>ran \<pi>. wf_proc_body \<pi> b"

  definition "wf_pos \<pi> \<equiv> \<lambda>(\<beta>,l). \<beta> \<in> ran \<pi> \<and> l\<in>dom \<beta>"

  lemma
    assumes "run (execute \<pi> \<beta>l) s = r"
    assumes "wf_pos \<pi> \<beta>l"
    assumes "wf_prog \<pi>"
    shows "mwp r True bot top bot"
    using assms(1,2)
  proof (induction rule: execute_partial)
    case (nonterm x s)
    then show ?case by simp
  next
    case (step f x s r)

    note step.IH[OF refl, THEN mwp_cons, intro!]

    obtain \<beta> l where [simp]: "x = (\<beta>,l)" by (cases x)
    with \<open>wf_pos \<pi> x\<close> obtain ntis ti where [simp]: "\<beta> l = Some (BBLOCK ntis ti)" and "\<beta>\<in>ran \<pi>"
      apply (auto simp: wf_pos_def)
      using bblock.exhaust by blast

    have [THEN mwp_cons, intro!]:
      "mwp (run (exec_nt_instr \<pi> f i) s) top bot bot top" if "wf_nt_instr \<pi> i" for i s
      using that
      apply (auto simp: run_simps exec_nt_instr_def split: nt_instr.splits option.split)
      by (metis (mono_tags, lifting) assms(3) old.prod.case ranI wf_pos_def wf_proc_body_def wf_prog_def)

    from \<open>wf_prog \<pi>\<close> \<open>\<beta>\<in>ran \<pi>\<close> have "wf_basic_block \<pi> \<beta> (BBLOCK ntis ti)"
      unfolding wf_prog_def wf_proc_body_def apply (auto)
      apply (meson \<open>\<beta> l = Some (BBLOCK ntis ti)\<close> ranI wf_basic_block.simps)
      apply (meson \<open>\<beta> l = Some (BBLOCK ntis ti)\<close> ranI wf_basic_block.simps)
      done
    hence WF_NTI: "(\<forall>nti\<in>List.set ntis. wf_nt_instr \<pi> nti)"
      and WF_TI: "wf_t_instr \<pi> \<beta> ti" by simp_all

    from WF_NTI have [THEN mwp_cons, intro!]:
      "mwp (run (mfold' (exec_nt_instr \<pi> f) ntis) s) top bot bot top"
      apply (induction ntis arbitrary: s)
      by (auto simp: run_simps)

    from WF_TI have [THEN mwp_cons, intro!]: "mwp (run (exec_t_instr ti) s) top bot top (\<lambda>l _. l\<in>dom \<beta>)" for s
      apply (cases ti)
      apply (auto simp: run_simps)
      done

    from step.hyps step.prems show ?case
      by (auto simp: execute_body_def run_simps wf_pos_def split: prod.splits option.splits)

  qed

end