theory No_Spoof
imports Common_Primitive_Lemmas
        Ipassmt
begin

section\<open>No Spoofing\<close>
(* we do this in ternary (not simple firewall) to support negated interfaces *)
  text\<open>assumes: @{const simple_ruleset}\<close>

subsection\<open>Spoofing Protection\<close>
  text\<open>
  No spoofing means:
  Every packet that is (potentially) allowed by the firewall and comes from an interface \<open>iface\<close>
  must have a Source IP Address in the assigned range \<open>iface\<close>.

  ``potentially allowed'' means we use the upper closure.
  The definition states: For all interfaces which are configured, every packet that comes from this
  interface and is allowed by the firewall must be in the IP range of that interface.
\<close>

text\<open>We add @{typ "'pkt_ext itself"} as a parameter to have the type of a generic, extensible packet
     in the definition.\<close>
  definition no_spoofing :: "'pkt_ext itself \<Rightarrow> 'i::len ipassignment \<Rightarrow> 'i::len common_primitive rule list \<Rightarrow> bool" where
    "no_spoofing TYPE('pkt_ext) ipassmt rs \<equiv> \<forall> iface \<in> dom ipassmt. \<forall>p :: ('i,'pkt_ext) tagged_packet_scheme.
        ((common_matcher, in_doubt_allow),p\<lparr>p_iiface:=iface_sel iface\<rparr>\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow) \<longrightarrow>
            p_src p \<in> (ipcidr_union_set (set (the (ipassmt iface))))"

  text \<open>This is how it looks like for an IPv4 simple packet: We add @{type unit} because a
        @{typ "32 tagged_packet"} does not have any additional fields.\<close>
  lemma "no_spoofing TYPE(unit) ipassmt rs \<longleftrightarrow>
    (\<forall> iface \<in> dom ipassmt. \<forall>p :: 32 tagged_packet.
      ((common_matcher, in_doubt_allow),p\<lparr>p_iiface:=iface_sel iface\<rparr>\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow)
         \<longrightarrow> p_src p \<in> (ipcidr_union_set (set (the (ipassmt iface)))))"
    unfolding no_spoofing_def by blast

  text\<open>The definition is sound (if that can be said about a definition):
          if @{const no_spoofing} certifies your ruleset, then your ruleset prohibits spoofing.
         The definition may not be complete:
          @{const no_spoofing} may return @{const False} even though your ruleset prevents spoofing
          (should only occur if some strange and unknown primitives occur)\<close>

  text\<open>Technical note: The definition can can be thought of as protection from OUTGOING spoofing.
        OUTGOING means: I define my interfaces and their IP addresses. For all interfaces,
                        only the assigned IP addresses may pass the firewall.
                        This definition is simple for e.g. local sub-networks.
                        Example: @{term "[Iface ''eth0'' \<mapsto> {(ipv4addr_of_dotdecimal (192,168,0,0), 24)}]"}

        If I want spoofing protection from the Internet, I need to specify the range of the Internet IP addresses.
        Example: @{term "[Iface ''evil_internet'' \<mapsto> {everything_that_does_not_belong_to_me}]"}.
          This is also a good opportunity to exclude the private IP space, link local, and probably multicast space.
        See @{const all_but_those_ips} to easily specify these ranges.

        See examples below. Check Example 3 why it can be thought of as OUTGOING spoofing.\<close>

(*
and now code to check spoofing protection
*)
context
begin
  text\<open>The set of any ip addresses which may match for a fixed \<open>iface\<close> (overapproximation)\<close>
  private definition get_exists_matching_src_ips :: "iface \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i word set" where
    "get_exists_matching_src_ips iface m \<equiv> let (i_matches, _) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if (\<forall> is \<in> set i_matches. (case is of Pos i \<Rightarrow> match_iface i (iface_sel iface)
                                                  | Neg i \<Rightarrow> \<not> match_iface i (iface_sel iface)))
              then
                (let (ip_matches, _) = (primitive_extractor (is_Src, src_sel) m) in
                if ip_matches = []
                then
                  UNIV
                else
                  \<Inter> ips \<in> set (ip_matches). (case ips of Pos ip \<Rightarrow> ipt_iprange_to_set ip | Neg ip \<Rightarrow> - ipt_iprange_to_set ip))
              else
                {}"

  (*when we replace the set by a 32 wordinterval, we should get executable code*)
  lemma "primitive_extractor (is_Src, src_sel)
      (MatchAnd (Match (Src (IpAddrNetmask (0::ipv4addr) 30))) (Match (IIface (Iface ''eth0'')))) =
      ([Pos (IpAddrNetmask 0 30)], MatchAnd MatchAny (Match (IIface (Iface ''eth0''))))" by eval

 private lemma get_exists_matching_src_ips_subset:
    assumes "normalized_nnf_match m"
    shows "{ip. (\<exists>p :: ('i::len, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p\<lparr>p_iiface:= iface_sel iface, p_src:= ip\<rparr>))} \<subseteq>
           get_exists_matching_src_ips iface m"
  proof -
    let ?\<gamma>="(common_matcher, in_doubt_allow)"

    { fix ip_matches rest src_ip i_matches rest2 and p :: "('i, 'a) tagged_packet_scheme"
      assume a1: "primitive_extractor (is_Src, src_sel) m = (ip_matches, rest)"
      and a2: "matches ?\<gamma> m a (p\<lparr>p_iiface := iface_sel iface, p_src := src_ip\<rparr>)"
      let ?p="(p\<lparr>p_iiface := iface_sel iface, p_src := src_ip\<rparr>)"

      from primitive_extractor_negation_type_matching1[OF wf_disc_sel_common_primitive(3) assms a1 a2]
           match_simplematcher_SrcDst[where p = ?p] match_simplematcher_SrcDst_not[where p="?p"]
       have ip_matches: "(\<forall>ip\<in>set (getPos ip_matches). p_src ?p \<in> ipt_iprange_to_set ip) \<and>
                         (\<forall>ip\<in>set (getNeg ip_matches). p_src ?p \<in> - ipt_iprange_to_set ip)" by simp
      from ip_matches have "\<forall>x \<in> set ip_matches. src_ip \<in> (case x of Pos x \<Rightarrow> ipt_iprange_to_set x | Neg ip \<Rightarrow> - ipt_iprange_to_set ip)"
        apply(simp)
        apply(simp  split: negation_type.split)
        apply(safe)
         using NegPos_set apply fast+
      done
    } note 1=this

    { fix ip_matches rest src_ip i_matches rest2 and p :: "('i, 'a) tagged_packet_scheme"
      assume a1: "primitive_extractor (is_Iiface, iiface_sel) m = (i_matches, rest2)"
         and a2: "matches ?\<gamma> m a (p\<lparr>p_iiface := iface_sel iface, p_src := src_ip\<rparr>)"
      let ?p="(p\<lparr>p_iiface := iface_sel iface, p_src := src_ip\<rparr>)"

      from primitive_extractor_negation_type_matching1[OF wf_disc_sel_common_primitive(5) assms a1 a2]
           primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher, where p = ?p]
           primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher, where p = ?p]
      have iface_matches: "(\<forall>i\<in>set (getPos i_matches). match_iface i (p_iiface ?p)) \<and>
                           (\<forall>i\<in>set (getNeg i_matches). \<not> match_iface i (p_iiface ?p))" by simp
      hence 2: "(\<forall>x\<in>set i_matches. case x of Pos i \<Rightarrow> match_iface i (iface_sel iface) | Neg i \<Rightarrow> \<not> match_iface i (iface_sel iface))"
        apply(simp add: split: negation_type.split)
        apply(safe)
        using NegPos_set apply fast+
      done

    } note 2=this

    from 1 2 show ?thesis
      unfolding get_exists_matching_src_ips_def
      by(clarsimp)
  qed

  lemma common_primitive_not_has_primitive_expand:
        "\<not> has_primitive (m::'i::len common_primitive match_expr) \<longleftrightarrow>
         \<not> has_disc is_Dst m \<and>
         \<not> has_disc is_Src m \<and>
         \<not> has_disc is_Iiface m \<and>
         \<not> has_disc is_Oiface m \<and>
         \<not> has_disc is_Prot m \<and>
         \<not> has_disc is_Src_Ports m \<and>
         \<not> has_disc is_Dst_Ports m \<and>
         \<not> has_disc is_MultiportPorts m \<and>
         \<not> has_disc is_L4_Flags m \<and>
         \<not> has_disc is_CT_State m \<and>
         \<not> has_disc is_Extra m"
  apply(induction m)
     apply(simp_all)
    apply(rename_tac x, case_tac x, simp_all)
   by blast

  (*matcheq_matchAny is undefined for primitives. this is the proper way to call it!*)
  lemma "\<not> has_primitive m \<and> matcheq_matchAny m \<longleftrightarrow> (if \<not> has_primitive m then matcheq_matchAny m else False)"
    by simp

  text\<open>The set of ip addresses which definitely match for a fixed \<open>iface\<close> (underapproximation)\<close>
  private definition get_all_matching_src_ips :: "iface \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i word set" where
    "get_all_matching_src_ips iface m \<equiv> let (i_matches, rest1) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if (\<forall> is \<in> set i_matches. (case is of Pos i \<Rightarrow> match_iface i (iface_sel iface)
                                                  | Neg i \<Rightarrow> \<not> match_iface i (iface_sel iface)))
              then
                (let (ip_matches, rest2) = (primitive_extractor (is_Src, src_sel) rest1) in
                if \<not> has_primitive rest2 \<and> matcheq_matchAny rest2
                then
                  if ip_matches = []
                  then
                    UNIV
                  else
                    \<Inter> ips \<in> set (ip_matches). (case ips of Pos ip \<Rightarrow> ipt_iprange_to_set ip | Neg ip \<Rightarrow> - ipt_iprange_to_set ip)
                else
                  {})
              else
                {}"

 private lemma get_all_matching_src_ips:
    assumes "normalized_nnf_match m"
    shows "get_all_matching_src_ips iface m \<subseteq>
            {ip. (\<forall>p::('i::len, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p\<lparr>p_iiface:= iface_sel iface, p_src:= ip\<rparr>))}"
  proof
    fix ip
    assume a: "ip \<in> get_all_matching_src_ips iface m"
    obtain i_matches rest1 where select1: "primitive_extractor (is_Iiface, iiface_sel) m = (i_matches, rest1)" by fastforce
    show "ip \<in> {ip. \<forall>p :: ('i, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>)}"
    proof(cases "\<forall> is \<in> set i_matches. (case is of Pos i \<Rightarrow> match_iface i (iface_sel iface)
                                                 | Neg i \<Rightarrow> \<not>match_iface i (iface_sel iface))")
    case False
      have "get_all_matching_src_ips iface m = {}"
        unfolding get_all_matching_src_ips_def
        using select1 False by auto
      with a show ?thesis by simp
    next
    case True
      let ?\<gamma>="(common_matcher, in_doubt_allow) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
      let ?p="\<lambda>p::('i, 'a) tagged_packet_scheme. p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>"
      obtain ip_matches rest2 where select2: "primitive_extractor (is_Src, src_sel) rest1 = (ip_matches, rest2)" by fastforce

      let ?noDisc="\<not> has_primitive rest2"

      have get_all_matching_src_ips_caseTrue: "get_all_matching_src_ips iface m =
            (if ?noDisc \<and> matcheq_matchAny rest2
             then if ip_matches = []
                  then UNIV
                  else \<Inter>((case_negation_type ipt_iprange_to_set (\<lambda>ip. - ipt_iprange_to_set ip) ` (set ip_matches)))
              else {})"
      unfolding get_all_matching_src_ips_def
      by(simp add: True select1 select2)

      from True have "(\<forall>m\<in>set (getPos i_matches). matches ?\<gamma> (Match (IIface m)) a (?p p)) \<and>
                      (\<forall>m\<in>set (getNeg i_matches). matches ?\<gamma> (MatchNot (Match (IIface m))) a (?p p))"
       for p :: "('i, 'a) tagged_packet_scheme"
        by(simp add: negation_type_forall_split
            primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
            primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      hence matches_iface: "matches ?\<gamma> (alist_and (NegPos_map IIface i_matches)) a (?p p)"
        for p :: "('i,'a) tagged_packet_scheme"
        by(simp add: matches_alist_and NegPos_map_simps)

      show ?thesis
      proof(cases "?noDisc \<and> matcheq_matchAny rest2")
      case False
        assume F: "\<not> (?noDisc \<and> matcheq_matchAny rest2)"
        with get_all_matching_src_ips_caseTrue have "get_all_matching_src_ips iface m = {}" by presburger
        with a have False by simp
        thus ?thesis ..
      next
      case True
        assume F: "?noDisc \<and> matcheq_matchAny rest2"
        with get_all_matching_src_ips_caseTrue have "get_all_matching_src_ips iface m =
            (if ip_matches = []
             then UNIV
             else \<Inter>((case_negation_type ipt_iprange_to_set (\<lambda>ip. - ipt_iprange_to_set ip) ` (set ip_matches))))" by presburger

        from primitive_extractor_correct[OF assms wf_disc_sel_common_primitive(5) select1] have
          select1_matches: "matches ?\<gamma> (alist_and (NegPos_map IIface i_matches)) a p \<and> matches ?\<gamma> rest1 a p \<longleftrightarrow> matches ?\<gamma> m a p"
          and normalized1: "normalized_nnf_match rest1" for p :: "('i,'a) tagged_packet_scheme"
          apply -
            apply fast+
          done
        from select1_matches matches_iface have
          rest1_matches: "matches ?\<gamma> rest1 a (?p p) \<longleftrightarrow> matches ?\<gamma> m a (?p p)" for p :: "('i, 'a) tagged_packet_scheme" by blast

        from primitive_extractor_correct[OF normalized1 wf_disc_sel_common_primitive(3) select2] have
          select2_matches: "matches ?\<gamma> (alist_and (NegPos_map Src ip_matches)) a p \<and> matches ?\<gamma> rest2 a p \<longleftrightarrow>
                            matches ?\<gamma> rest1 a p" for p :: "('i, 'a) tagged_packet_scheme"
        by fast
        with F matcheq_matchAny have "matches ?\<gamma> rest2 a p" for p :: "('i, 'a) tagged_packet_scheme" by metis
        with select2_matches rest1_matches have ip_src_matches:
          "matches ?\<gamma> (alist_and (NegPos_map Src ip_matches)) a (?p p) \<longleftrightarrow> matches ?\<gamma> m a (?p p)"
          for p :: "('i, 'a) tagged_packet_scheme" by simp

        have case_nil: "\<And>p. ip_matches = [] \<Longrightarrow> matches ?\<gamma> (alist_and (NegPos_map Src ip_matches)) a p"
          by(simp add: bunch_of_lemmata_about_matches)

        have case_list: "\<And>p. \<forall>x\<in>set ip_matches. (case x of Pos i \<Rightarrow> ip \<in> ipt_iprange_to_set i
                                                          | Neg i \<Rightarrow> ip \<in> - ipt_iprange_to_set i) \<Longrightarrow>
            matches ?\<gamma> (alist_and (NegPos_map Src ip_matches)) a (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>)"
          apply(simp add: matches_alist_and NegPos_map_simps)
          apply(simp add: negation_type_forall_split match_simplematcher_SrcDst_not match_simplematcher_SrcDst)
          done

        from a show "ip \<in> {ip. \<forall>p :: ('i, 'a) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m a (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>)}"
          unfolding get_all_matching_src_ips_caseTrue
          proof(clarsimp split: if_split_asm)
            fix p :: "('i, 'a) tagged_packet_scheme"
            assume "ip_matches = []"
            with case_nil have "matches ?\<gamma> (alist_and (NegPos_map Src ip_matches)) a (?p p)" by simp
            with ip_src_matches show "matches ?\<gamma> m a (?p p)" by simp
          next
            fix p :: "('i, 'a) tagged_packet_scheme"
            assume "\<forall>x\<in>set ip_matches. ip \<in> (case x of Pos x \<Rightarrow> ipt_iprange_to_set x | Neg ip \<Rightarrow> - ipt_iprange_to_set ip)"
            hence "\<forall>x\<in>set ip_matches. case x of Pos i \<Rightarrow> ip \<in> ipt_iprange_to_set i | Neg i \<Rightarrow> ip \<in> - ipt_iprange_to_set i"
             by(simp_all split: negation_type.split negation_type.split_asm)
            with case_list have "matches ?\<gamma> (alist_and (NegPos_map Src ip_matches)) a (?p p)" .
            with ip_src_matches show "matches ?\<gamma> m a (?p p)" by simp
          qed
       qed
     qed
  qed

  private definition get_exists_matching_src_ips_executable
    :: "iface \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i wordinterval" where
    "get_exists_matching_src_ips_executable iface m \<equiv> let (i_matches, _) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if (\<forall> is \<in> set i_matches. (case is of Pos i \<Rightarrow> match_iface i (iface_sel iface)
                                                  | Neg i \<Rightarrow> \<not>match_iface i (iface_sel iface)))
              then
                (let (ip_matches, _) = (primitive_extractor (is_Src, src_sel) m) in
                if ip_matches = []
                then
                  wordinterval_UNIV
                else
                  l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval ip_matches))
              else
                Empty_WordInterval"
  (*WOW, such horrible proof!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)
  lemma get_exists_matching_src_ips_executable:
    "wordinterval_to_set (get_exists_matching_src_ips_executable iface m) = get_exists_matching_src_ips iface m"
    apply(simp add: get_exists_matching_src_ips_executable_def get_exists_matching_src_ips_def)
    apply(case_tac "primitive_extractor (is_Iiface, iiface_sel) m")
    apply(case_tac "primitive_extractor (is_Src, src_sel) m")
    apply(simp)
    apply(simp add: l2wi_negation_type_intersect)
    apply(simp add: NegPos_map_simps)
    apply(safe)
         apply(simp_all add: ipt_iprange_to_interval)
      apply(rename_tac i_matches rest1 a b x xa)
      apply(case_tac xa)
       apply(simp_all add: NegPos_set)
       using ipt_iprange_to_interval apply fast+
     apply(rename_tac i_matches rest1 a b x aa ab ba)
     apply(erule_tac x="Pos aa" in ballE)
      apply(simp_all add: NegPos_set)
    using NegPos_set(2) by fastforce

  lemma "(get_exists_matching_src_ips_executable (Iface ''eth0'')
      (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0''))))) =
      RangeUnion (WordInterval 0 0xC0A7FFFF) (WordInterval 0xC0A80100 0xFFFFFFFF)" by eval

  private definition get_all_matching_src_ips_executable
    :: "iface \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i wordinterval" where
    "get_all_matching_src_ips_executable iface m \<equiv> let (i_matches, rest1) = (primitive_extractor (is_Iiface, iiface_sel) m) in
              if (\<forall> is \<in> set i_matches. (case is of Pos i \<Rightarrow> match_iface i (iface_sel iface)
                                                  | Neg i \<Rightarrow> \<not>match_iface i (iface_sel iface)))
              then
                (let (ip_matches, rest2) = (primitive_extractor (is_Src, src_sel) rest1) in
                if \<not> has_primitive rest2 \<and> matcheq_matchAny rest2
                then
                  if ip_matches = []
                  then
                    wordinterval_UNIV
                  else
                    l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval ip_matches)
                else
                  Empty_WordInterval)
              else
                Empty_WordInterval"
  (*WOW, such horrible proof!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*)
  lemma get_all_matching_src_ips_executable:
    "wordinterval_to_set (get_all_matching_src_ips_executable iface m) = get_all_matching_src_ips iface m"
    apply(simp add: get_all_matching_src_ips_executable_def get_all_matching_src_ips_def)
    apply(case_tac "primitive_extractor (is_Iiface, iiface_sel) m")
    apply(simp, rename_tac i_matches rest1)
    apply(case_tac "primitive_extractor (is_Src, src_sel) rest1")
    apply(simp)
    apply(simp add: l2wi_negation_type_intersect)
    apply(simp add: NegPos_map_simps)
    apply(safe)
         apply(simp_all add: ipt_iprange_to_interval)
      apply(rename_tac i_matches rest1 a b x xa)
      apply(case_tac xa)
       apply(simp_all add: NegPos_set)
       using ipt_iprange_to_interval apply fast+
     apply(rename_tac i_matches rest1 a b x aa ab ba)
     apply(erule_tac x="Pos aa" in ballE)
      apply(simp_all add: NegPos_set)
    apply(erule_tac x="Neg aa" in ballE)
     apply(simp_all add: NegPos_set)
    done
  lemma "(get_all_matching_src_ips_executable (Iface ''eth0'')
      (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0''))))) =
      RangeUnion (WordInterval 0 0xC0A7FFFF) (WordInterval 0xC0A80100 0xFFFFFFFF)" by eval

  text\<open>The following algorithm sound but not complete.\<close>
  (*alowed: set ip ips potentially allowed for iface
    denied: set of ips definitely dropped for iface*)
  private fun no_spoofing_algorithm
    :: "iface \<Rightarrow> 'i::len ipassignment \<Rightarrow> 'i common_primitive rule list \<Rightarrow> 'i word set \<Rightarrow> 'i word set \<Rightarrow> bool" where
    "no_spoofing_algorithm iface ipassmt [] allowed denied1  \<longleftrightarrow>
      (allowed - denied1) \<subseteq> ipcidr_union_set (set (the (ipassmt iface)))" |
    "no_spoofing_algorithm iface ipassmt ((Rule m Accept)#rs) allowed denied1 = no_spoofing_algorithm iface ipassmt rs
        (allowed \<union> get_exists_matching_src_ips iface m) denied1" |
    "no_spoofing_algorithm iface ipassmt ((Rule m Drop)#rs) allowed denied1 = no_spoofing_algorithm iface ipassmt rs
         allowed (denied1 \<union> (get_all_matching_src_ips iface m - allowed))"  |
    "no_spoofing_algorithm _ _ _ _ _  = undefined"

  private fun no_spoofing_algorithm_executable
    :: "iface \<Rightarrow> (iface \<rightharpoonup> ('i::len word \<times> nat) list) \<Rightarrow> 'i common_primitive rule list
          \<Rightarrow> 'i wordinterval \<Rightarrow> 'i wordinterval \<Rightarrow> bool" where
    "no_spoofing_algorithm_executable iface ipassmt [] allowed denied1  \<longleftrightarrow>
      wordinterval_subset (wordinterval_setminus allowed denied1) (l2wi (map ipcidr_to_interval (the (ipassmt iface))))" |
    "no_spoofing_algorithm_executable iface ipassmt ((Rule m Accept)#rs) allowed denied1 = no_spoofing_algorithm_executable iface ipassmt rs
        (wordinterval_union allowed (get_exists_matching_src_ips_executable iface m)) denied1" |
    "no_spoofing_algorithm_executable iface ipassmt ((Rule m Drop)#rs) allowed denied1 = no_spoofing_algorithm_executable iface ipassmt rs
         allowed (wordinterval_union denied1 (wordinterval_setminus (get_all_matching_src_ips_executable iface m) allowed))"  |
    "no_spoofing_algorithm_executable _ _ _ _ _  = undefined"

  lemma no_spoofing_algorithm_executable: "no_spoofing_algorithm_executable iface ipassmt rs allowed denied \<longleftrightarrow>
         no_spoofing_algorithm iface ipassmt rs (wordinterval_to_set allowed) (wordinterval_to_set denied)"
  proof(induction iface ipassmt rs allowed denied rule: no_spoofing_algorithm_executable.induct)
  case (1 iface ipassmt allowed denied1)
    have "(\<Union>a\<in>set (the (ipassmt iface)). case ipcidr_to_interval a of (x, xa) \<Rightarrow> {x..xa}) =
          (\<Union>x\<in>set (the (ipassmt iface)). uncurry ipset_from_cidr x)"
    by(simp add: ipcidr_to_interval_def uncurry_def ipset_from_cidr_ipcidr_to_interval)
    with 1 show ?case by(simp add: ipcidr_union_set_uncurry l2wi)
  next
  case 2 thus ?case by(simp add: get_exists_matching_src_ips_executable get_all_matching_src_ips_executable)
  next
  case 3 thus ?case by(simp add: get_exists_matching_src_ips_executable get_all_matching_src_ips_executable)
  qed(simp_all)

  private definition "nospoof TYPE('pkt_ext) iface ipassmt rs = (\<forall>p :: ('i::len,'pkt_ext) tagged_packet_scheme.
          (approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface:=iface_sel iface\<rparr>) rs Undecided = Decision FinalAllow) \<longrightarrow>
              p_src p \<in> (ipcidr_union_set (set (the (ipassmt iface)))))"
  private definition "setbydecision TYPE('pkt_ext) iface rs dec = {ip. \<exists>p :: ('i::len,'pkt_ext) tagged_packet_scheme. approximating_bigstep_fun (common_matcher, in_doubt_allow)
                           (p\<lparr>p_iiface:=iface_sel iface, p_src := ip\<rparr>) rs Undecided = Decision dec}"

  private lemma nospoof_setbydecision:
    fixes rs :: "'i::len common_primitive rule list"
    shows "nospoof TYPE('pkt_ext) iface ipassmt rs \<longleftrightarrow>
          setbydecision TYPE('pkt_ext) iface rs FinalAllow \<subseteq> (ipcidr_union_set (set (the (ipassmt iface))))"
  proof
    assume a: "nospoof TYPE('pkt_ext) iface ipassmt rs"
    have packet_update_iface_simp: "p\<lparr>p_iiface := iface_sel iface, p_src := x\<rparr> = p\<lparr>p_src := x, p_iiface := iface_sel iface\<rparr>"
      for p::"('i::len, 'p) tagged_packet_scheme" and x by simp

    from a show "setbydecision TYPE('pkt_ext) iface rs FinalAllow \<subseteq> ipcidr_union_set (set (the (ipassmt iface)))"
      apply(simp add: nospoof_def setbydecision_def)
      apply(safe)
      apply(rename_tac x p)
      apply(erule_tac x="p\<lparr>p_iiface := iface_sel iface, p_src := x\<rparr>" in allE)
      apply(simp)
      apply(simp add: packet_update_iface_simp)
      done
  next
    assume a1: "setbydecision TYPE('pkt_ext) iface rs FinalAllow \<subseteq> ipcidr_union_set (set (the (ipassmt iface)))"
    show "nospoof TYPE('pkt_ext) iface ipassmt rs"
      unfolding nospoof_def
      proof(safe)
        fix p :: "('i::len,'pkt_ext) tagged_packet_scheme"
        assume a2: "approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface := iface_sel iface\<rparr>) rs Undecided = Decision FinalAllow"
        \<comment> \<open>In @{text setbydecision_fix_p}the @{text \<exists>} quantifier is gone and we consider this set for @{term p}.\<close>
        let ?setbydecision_fix_p="{ip. approximating_bigstep_fun (common_matcher, in_doubt_allow)
          (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>) rs Undecided = Decision FinalAllow}"
        from a1 a2 have 1: "?setbydecision_fix_p \<subseteq> ipcidr_union_set (set (the (ipassmt iface)))" by(simp add: nospoof_def setbydecision_def) blast
        from a2 have 2: "p_src p \<in> ?setbydecision_fix_p" by simp
        from 1 2 show "p_src p \<in> ipcidr_union_set (set (the (ipassmt iface)))" by blast
      qed
  qed

  private definition "setbydecision_all TYPE('pkt_ext) iface rs dec = {ip. \<forall>p :: ('i::len,'pkt_ext) tagged_packet_scheme.
    approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface:=iface_sel iface, p_src := ip\<rparr>) rs Undecided = Decision dec}"

  private lemma setbydecision_setbydecision_all_Allow:
    "(setbydecision TYPE('pkt_ext) iface rs FinalAllow - setbydecision_all TYPE('pkt_ext) iface rs FinalDeny) =
      setbydecision TYPE('pkt_ext) iface rs FinalAllow"
    apply(safe)
    apply(simp add: setbydecision_def setbydecision_all_def)
    done
  private lemma setbydecision_setbydecision_all_Deny:
    "(setbydecision TYPE('pkt_ext) iface rs FinalDeny - setbydecision_all TYPE('pkt_ext) iface rs FinalAllow) =
      setbydecision TYPE('pkt_ext) iface rs FinalDeny"
    apply(safe)
    apply(simp add: setbydecision_def setbydecision_all_def)
    done

  private lemma setbydecision_append:
    "simple_ruleset (rs1 @ rs2) \<Longrightarrow>
      setbydecision TYPE('pkt_ext) iface (rs1 @ rs2) FinalAllow =
        setbydecision TYPE('pkt_ext) iface rs1 FinalAllow \<union> {ip. \<exists>p :: ('i::len,'pkt_ext) tagged_packet_scheme. approximating_bigstep_fun (common_matcher, in_doubt_allow)
         (p\<lparr>p_iiface:=iface_sel iface, p_src := ip\<rparr>) rs2 Undecided = Decision FinalAllow \<and>
          approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface:=iface_sel iface, p_src := ip\<rparr>) rs1 Undecided = Undecided}"
      apply(simp add: setbydecision_def)
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_cong)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
      by blast

  private lemma not_FinalAllow: "foo \<noteq> Decision FinalAllow \<longleftrightarrow> foo = Decision FinalDeny \<or> foo = Undecided"
    apply(cases foo)
     apply simp_all
    apply(rename_tac x2)
    apply(case_tac x2)
     apply(simp_all)
    done

  private lemma setbydecision_all_appendAccept: "simple_ruleset (rs @ [Rule r Accept]) \<Longrightarrow>
    setbydecision_all TYPE('pkt_ext) iface rs FinalDeny = setbydecision_all TYPE('pkt_ext) iface (rs @ [Rule r Accept]) FinalDeny"
      apply(simp add: setbydecision_all_def)
      apply(rule Set.Collect_cong)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
      apply(simp add: not_FinalAllow)
      done

  private lemma setbydecision_all_append_subset: "simple_ruleset (rs1 @ rs2) \<Longrightarrow>
            setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny \<union> {ip. \<forall>p :: ('i::len,'pkt_ext) tagged_packet_scheme.
            approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface:=iface_sel iface, p_src := ip\<rparr>) rs2 Undecided = Decision FinalDeny \<and>
            approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface:=iface_sel iface, p_src := ip\<rparr>) rs1 Undecided = Undecided}
            \<subseteq>
            setbydecision_all TYPE('pkt_ext) iface (rs1 @ rs2) FinalDeny"
      unfolding setbydecision_all_def
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_mono)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset)
      apply(simp add: not_FinalAllow)
      done

  private lemma "setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny \<union>
                 {ip. \<forall>p :: ('i::len,'pkt_ext) tagged_packet_scheme.
                 approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>) rs1 Undecided = Undecided}
                 \<subseteq>
                 - setbydecision TYPE('pkt_ext) iface rs1 FinalAllow"
      unfolding setbydecision_all_def
      unfolding setbydecision_def
      apply(subst Set.Collect_neg_eq[symmetric])
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_mono)
      by(simp)

  private lemma Collect_minus_eq: "{x. P x} - {x. Q x} = {x. P x \<and> \<not> Q x}" by blast
  private lemma setbydecision_all_append_subset2:
      "simple_ruleset (rs1 @ rs2) \<Longrightarrow>
       setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny \<union>
      (setbydecision_all TYPE('pkt_ext) iface rs2 FinalDeny -
       setbydecision TYPE('pkt_ext) iface rs1 FinalAllow)
     \<subseteq> setbydecision_all TYPE('pkt_ext) iface (rs1 @ rs2) FinalDeny"
      unfolding setbydecision_all_def
      unfolding setbydecision_def
      apply(subst Collect_minus_eq)
      apply(subst Set.Collect_disj_eq[symmetric])
      apply(rule Set.Collect_mono)
      apply(subst approximating_bigstep_fun_seq_Undecided_t_wf)
       apply(simp add: simple_imp_good_ruleset good_imp_wf_ruleset; fail)
      apply(intro impI allI)
      apply(simp add: not_FinalAllow)
      apply(case_tac "approximating_bigstep_fun (common_matcher, in_doubt_allow) (p\<lparr>p_iiface := iface_sel iface, p_src := x\<rparr>) rs1 Undecided")
       subgoal by(elim disjE) simp_all
      apply(rename_tac x2)
      apply(case_tac x2)
       prefer 2
       apply simp
      apply(elim disjE)
       apply(simp)
      by blast

  private lemma "setbydecision_all TYPE('pkt_ext) iface rs FinalDeny \<subseteq> - setbydecision TYPE('pkt_ext) iface rs FinalAllow"
      apply(simp add: setbydecision_def setbydecision_all_def)
      apply(subst Set.Collect_neg_eq[symmetric])
      apply(rule Set.Collect_mono)
      apply(simp)
      done

  private lemma no_spoofing_algorithm_sound_generalized:
  fixes rs1 :: "'i::len common_primitive rule list"
  shows "simple_ruleset rs1 \<Longrightarrow> simple_ruleset rs2 \<Longrightarrow>
        (\<forall>r \<in> set rs2. normalized_nnf_match (get_match r)) \<Longrightarrow>
        setbydecision TYPE('pkt_ext) iface rs1 FinalAllow \<subseteq> allowed \<Longrightarrow>
        denied1 \<subseteq> setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny \<Longrightarrow>
        no_spoofing_algorithm iface ipassmt rs2 allowed denied1 \<Longrightarrow>
        nospoof TYPE('pkt_ext) iface ipassmt (rs1@rs2)"
  proof(induction iface ipassmt rs2 allowed denied1 arbitrary: rs1 allowed denied1 rule: no_spoofing_algorithm.induct)
  case (1 iface ipassmt)
    from 1 have "allowed - denied1 \<subseteq> ipcidr_union_set (set (the (ipassmt iface)))"
      by(simp)
    with 1 have "setbydecision TYPE('pkt_ext) iface rs1 FinalAllow - setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny
          \<subseteq> ipcidr_union_set (set (the (ipassmt iface)))"
      by blast
    thus ?case
      by(simp add: nospoof_setbydecision setbydecision_setbydecision_all_Allow)
  next
  case (2 iface ipassmt m rs)
    from 2(2) have simple_rs1: "simple_ruleset rs1" by(simp add: simple_ruleset_def)
    hence simple_rs': "simple_ruleset (rs1 @ [Rule m Accept])" by(simp add: simple_ruleset_def)
    from 2(3) have simple_rs: "simple_ruleset rs" by(simp add: simple_ruleset_def)
    with 2 have IH: "\<And>rs' allowed denied1.
      simple_ruleset rs' \<Longrightarrow>
      setbydecision TYPE('pkt_ext) iface rs' FinalAllow \<subseteq> allowed \<Longrightarrow>
      denied1 \<subseteq> setbydecision_all TYPE('pkt_ext) iface rs' FinalDeny \<Longrightarrow>
      no_spoofing_algorithm iface ipassmt rs allowed denied1 \<Longrightarrow> nospoof TYPE('pkt_ext) iface ipassmt (rs' @ rs)"
      by(simp)
    from 2(5) have "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalAllow \<subseteq>
      (allowed \<union> {ip. \<exists>p :: ('i::len,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Accept (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>)})"
      apply(simp add: setbydecision_append[OF simple_rs'])
      by blast
    with get_exists_matching_src_ips_subset 2(4) have allowed: "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalAllow \<subseteq> (allowed \<union> get_exists_matching_src_ips iface m)"
      by fastforce

    from 2(6) setbydecision_all_appendAccept[OF simple_rs', where 'pkt_ext = 'pkt_ext] have denied1:
      "denied1 \<subseteq> setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Accept]) FinalDeny" by simp

    from 2(7) have no_spoofing_algorithm_prems: "no_spoofing_algorithm iface ipassmt rs
         (allowed \<union> get_exists_matching_src_ips iface m) denied1"
      by(simp)

    from IH[OF simple_rs' allowed denied1 no_spoofing_algorithm_prems] have "nospoof TYPE('pkt_ext) iface ipassmt ((rs1 @ [Rule m Accept]) @ rs)" by blast
    thus ?case by(simp)
  next
  case (3 iface ipassmt m rs)
    from 3(2) have simple_rs1: "simple_ruleset rs1" by(simp add: simple_ruleset_def)
    hence simple_rs': "simple_ruleset (rs1 @ [Rule m Drop])" by(simp add: simple_ruleset_def)
    from 3(3) have simple_rs: "simple_ruleset rs" by(simp add: simple_ruleset_def)
    with 3 have IH: "\<And>rs' allowed denied1.
      simple_ruleset rs' \<Longrightarrow>
      setbydecision TYPE('pkt_ext) iface rs' FinalAllow \<subseteq> allowed \<Longrightarrow>
      denied1 \<subseteq> setbydecision_all TYPE('pkt_ext) iface rs' FinalDeny \<Longrightarrow>
      no_spoofing_algorithm iface ipassmt rs allowed denied1 \<Longrightarrow> nospoof TYPE('pkt_ext) iface ipassmt (rs' @ rs)"
      by(simp)
    from 3(5) simple_rs' have allowed: "setbydecision TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalAllow \<subseteq> allowed "
      by(simp add: setbydecision_append)

    have "{ip. \<forall>p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>)} \<subseteq>
          setbydecision_all TYPE('pkt_ext) iface [Rule m Drop] FinalDeny" by(simp add: setbydecision_all_def)
    with 3(5) have "setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny \<union> ({ip. \<forall>p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>)} - allowed) \<subseteq>
          setbydecision_all TYPE('pkt_ext) iface rs1 FinalDeny \<union> (setbydecision_all TYPE('pkt_ext) iface [Rule m Drop] FinalDeny - setbydecision TYPE('pkt_ext) iface rs1 FinalAllow)"
      by blast
    with 3(6) setbydecision_all_append_subset2[OF simple_rs', of iface] have
     "denied1 \<union> ({ip. \<forall>p :: ('i,'pkt_ext) tagged_packet_scheme. matches (common_matcher, in_doubt_allow) m Drop (p\<lparr>p_iiface := iface_sel iface, p_src := ip\<rparr>)} - allowed) \<subseteq>
      setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalDeny"
      by blast
    with get_all_matching_src_ips 3(4) have denied1:
     "denied1 \<union> (get_all_matching_src_ips iface m - allowed) \<subseteq> setbydecision_all TYPE('pkt_ext) iface (rs1 @ [Rule m Drop]) FinalDeny"
      by force

    from 3(7) have no_spoofing_algorithm_prems: "no_spoofing_algorithm iface ipassmt rs allowed
     (denied1 \<union> (get_all_matching_src_ips iface m - allowed))"
      apply(simp)
      done

    from IH[OF simple_rs' allowed denied1 no_spoofing_algorithm_prems] have "nospoof TYPE('pkt_ext) iface ipassmt ((rs1 @ [Rule m Drop]) @ rs)" by blast
    thus ?case by(simp)
  next
  case "4_1" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_2" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_3" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_4" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_5" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_6" thus ?case by(simp add: simple_ruleset_def)
  next
  case "4_7" thus ?case by(simp add: simple_ruleset_def)
  qed

  definition no_spoofing_iface :: "iface \<Rightarrow> 'i::len ipassignment \<Rightarrow> 'i common_primitive rule list \<Rightarrow> bool" where
    "no_spoofing_iface iface ipassmt rs \<equiv> no_spoofing_algorithm iface ipassmt rs {} {}"

  lemma[code]: "no_spoofing_iface iface ipassmt rs =
      no_spoofing_algorithm_executable iface ipassmt rs Empty_WordInterval Empty_WordInterval"
    by(simp add: no_spoofing_iface_def no_spoofing_algorithm_executable)

  private corollary no_spoofing_algorithm_sound: "simple_ruleset rs \<Longrightarrow> \<forall>r\<in>set rs. normalized_nnf_match (get_match r) \<Longrightarrow>
        no_spoofing_iface iface ipassmt rs  \<Longrightarrow> nospoof TYPE('pkt_ext) iface ipassmt rs"
    unfolding no_spoofing_iface_def
    apply(rule no_spoofing_algorithm_sound_generalized[of "[]" rs iface "{}" "{}", simplified])
        apply(simp_all)
     apply(simp add: simple_ruleset_def)
    apply(simp add: setbydecision_def)
    done

  text\<open>The @{const nospoof} definition used throughout the proofs corresponds to checking @{const no_spoofing} for all interfaces\<close>
  private lemma nospoof: "simple_ruleset rs \<Longrightarrow> (\<forall>iface \<in> dom ipassmt. nospoof TYPE('pkt_ext) iface ipassmt rs) \<longleftrightarrow> no_spoofing TYPE('pkt_ext) ipassmt rs"
    unfolding nospoof_def no_spoofing_def
    apply(drule simple_imp_good_ruleset)
    apply(subst approximating_semantics_iff_fun_good_ruleset)
    apply(simp_all)
    done

  theorem no_spoofing_iface: "simple_ruleset rs \<Longrightarrow> \<forall>r\<in>set rs. normalized_nnf_match (get_match r) \<Longrightarrow>
        \<forall>iface \<in> dom ipassmt. no_spoofing_iface iface ipassmt rs  \<Longrightarrow> no_spoofing TYPE('pkt_ext) ipassmt rs"
    by(auto dest: nospoof no_spoofing_algorithm_sound)

text\<open>Examples\<close>
  text\<open>Example 1:
    Ruleset: Accept all non-spoofed packets, drop rest.
  \<close>
  lemma "no_spoofing_iface
      (Iface ''eth0'')
          [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth0'')))) action.Accept,
           Rule MatchAny action.Drop]" by eval
  lemma "no_spoofing TYPE('pkt_ext)
          [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth0'')))) action.Accept,
           Rule MatchAny action.Drop]"
    apply(rule no_spoofing_iface)
      apply(simp_all add: simple_ruleset_def) (*simple and nnf*)
    by eval (*executable spoofing alogorithm*)

  text\<open>Example 2:
    Ruleset: Drop packets from a spoofed IP range, allow rest.
    Handles negated interfaces correctly.
  \<close>
  lemma "no_spoofing TYPE('pkt_ext)
      [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
      [Rule (MatchAnd (Match (IIface (Iface ''wlan+''))) (Match (Extra ''no idea what this is''))) action.Accept, \<comment> \<open>not interesting for spoofing\<close>
       Rule (MatchNot (Match (IIface (Iface ''eth0+'')))) action.Accept, \<comment> \<open>not interesting for spoofing\<close>
       Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop, \<comment> \<open>spoof-protect here\<close>
       Rule MatchAny action.Accept]
          "
    apply(rule no_spoofing_iface)
      apply(simp_all add: simple_ruleset_def)
    by eval

  text\<open>Example 3:
    Accidentally, matching on wlan+, spoofed packets for eth0 are allowed.
    First, we prove that there actually is no spoofing protection. Then we show that our algorithm finds out.
\<close>
  lemma "\<not> no_spoofing TYPE('pkt_ext)
          [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchNot (Match (IIface (Iface ''wlan+'')))) action.Accept, \<comment> \<open>accidently allow everything for eth0\<close>
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop,
           Rule MatchAny action.Accept]
          "
     apply(simp add: no_spoofing_def)
     apply(rule_tac x="p\<lparr>p_src := 0\<rparr>" in exI) (*any p*)
     apply(simp add: range_0_max_UNIV ipcidr_union_set_def)
      apply(intro conjI)
      apply(subst approximating_semantics_iff_fun_good_ruleset)
       apply(simp add: good_ruleset_def; fail)
      apply(simp add: bunch_of_lemmata_about_matches
          match_simplematcher_SrcDst_not
          primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
          primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      apply(intro impI, thin_tac _)
      apply eval
     apply eval
     done

   lemma "\<not> no_spoofing_iface
          (Iface ''eth0'')
          [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchNot (Match (IIface (Iface ''wlan+'')))) action.Accept, \<comment> \<open>accidently allow everything for eth0\<close>
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24)))) (Match (IIface (Iface ''eth0'')))) action.Drop,
           Rule MatchAny action.Accept]
          " by eval

  text\<open>Example 4:
    Ruleset: Drop packets coming from the wrong interface, allow the rest.
    Warning: this does not prevent spoofing for eth0!
    Explanation: someone on eth0 can send a packet e.g. with source IP 8.8.8.8
    The ruleset only prevents spoofing of 192.168.0.0/24 for other interfaces
\<close>
   lemma "\<not> no_spoofing TYPE('pkt_ext) [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (MatchNot (Match (IIface (Iface ''eth0''))))) action.Drop,
           Rule MatchAny action.Accept]"
     apply(simp add: no_spoofing_def)
     apply(rule_tac x="p\<lparr>p_src := 0\<rparr>" in exI) (*any p*)
     apply(simp add: range_0_max_UNIV ipcidr_union_set_def)
      apply(intro conjI)
      apply(subst approximating_semantics_iff_fun_good_ruleset)
       apply(simp add: good_ruleset_def; fail)
      apply(simp add: bunch_of_lemmata_about_matches
          primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
          primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      apply(intro impI, thin_tac _)
      apply eval
     apply eval
     done

  text\<open>Our algorithm detects it.\<close>
  lemma "\<not> no_spoofing_iface
          (Iface ''eth0'')
          [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (MatchNot (Match (IIface (Iface ''eth0''))))) action.Drop,
           Rule MatchAny action.Accept]" by eval

  text\<open>Example 5:
    Spoofing protection but the algorithm fails.
    The algorithm @{const no_spoofing_iface} is only sound, not complete.
    The ruleset first drops spoofed packets for TCP and then drops spoofed packets for \<open>\<not> TCP\<close>.
    The algorithm cannot detect that \<open>TCP \<union> \<not>TCP\<close> together will match all spoofed packets.\<close>

  lemma "no_spoofing TYPE('pkt_ext) [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                          (Match (Prot (Proto TCP))))) action.Drop,
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                          (MatchNot (Match (Prot (Proto TCP)))))) action.Drop,
           Rule MatchAny action.Accept]" (is "no_spoofing TYPE('pkt_ext) ?ipassmt ?rs")
  proof -
    have 1: "\<forall>p. (common_matcher, in_doubt_allow),p\<turnstile> \<langle>?rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow \<longleftrightarrow>
                 approximating_bigstep_fun (common_matcher, in_doubt_allow) p ?rs Undecided = Decision FinalAllow"
      by(subst approximating_semantics_iff_fun_good_ruleset) (simp_all add: good_ruleset_def)
    show ?thesis
      unfolding no_spoofing_def
      apply(simp add: 1 ipcidr_union_set_def)
      apply(simp add: bunch_of_lemmata_about_matches
          primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]
          primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
      apply(simp add: match_iface.simps match_simplematcher_SrcDst_not
                      primitive_matcher_generic.Prot_single[OF primitive_matcher_generic_common_matcher]
                      primitive_matcher_generic.Prot_single_not[OF primitive_matcher_generic_common_matcher])
      done
  qed
  text\<open>Spoofing protection but the algorithm cannot certify spoofing protection.\<close>
  lemma "\<not> no_spoofing_iface
          (Iface ''eth0'')
          [Iface ''eth0'' \<mapsto> [(ipv4addr_of_dotdecimal (192,168,0,0), 24)]]
          [Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                (Match (Prot (Proto TCP))))) action.Drop,
           Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))))
                (MatchAnd (Match (IIface (Iface ''eth0'')))
                (MatchNot (Match (Prot (Proto TCP)))))) action.Drop,
           Rule MatchAny action.Accept]" by eval

end

lemma "no_spoofing_iface (Iface ''eth1.1011'')
                         ([Iface ''eth1.1011'' \<mapsto> [(ipv4addr_of_dotdecimal (131,159,14,0), 24)]]:: 32 ipassignment)
  [Rule (MatchNot (Match (IIface (Iface ''eth1.1011+'')))) action.Accept,
   Rule (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (131,159,14,0)) 24)))) (Match (IIface (Iface ''eth1.1011'')))) action.Drop,
   Rule MatchAny action.Accept]" by eval

text\<open>We only check accepted packets.
      If there is no default rule (this will never happen if parsed from iptables!), the result is unfinished.\<close>
lemma "no_spoofing_iface (Iface ''eth1.1011'')
                         ([Iface ''eth1.1011'' \<mapsto> [(ipv4addr_of_dotdecimal (131,159,14,0), 24)]]:: 32 ipassignment)
  [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8))) Drop]" by eval

end


(*  Title:      HOL/Basic_BNFs.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012

Registration of basic types as bounded natural functors.
*)

section \<open>Registration of Basic Types as Bounded Natural Functors\<close>

theory Basic_BNFs
imports BNF_Def
begin

inductive_set setl :: "'a + 'b \<Rightarrow> 'a set" for s :: "'a + 'b" where
  "s = Inl x \<Longrightarrow> x \<in> setl s"
inductive_set setr :: "'a + 'b \<Rightarrow> 'b set" for s :: "'a + 'b" where
  "s = Inr x \<Longrightarrow> x \<in> setr s"

lemma sum_set_defs[code]:
  "setl = (\<lambda>x. case x of Inl z => {z} | _ => {})"
  "setr = (\<lambda>x. case x of Inr z => {z} | _ => {})"
  by (auto simp: fun_eq_iff intro: setl.intros setr.intros elim: setl.cases setr.cases split: sum.splits)

lemma rel_sum_simps[code, simp]:
  "rel_sum R1 R2 (Inl a1) (Inl b1) = R1 a1 b1"
  "rel_sum R1 R2 (Inl a1) (Inr b2) = False"
  "rel_sum R1 R2 (Inr a2) (Inl b1) = False"
  "rel_sum R1 R2 (Inr a2) (Inr b2) = R2 a2 b2"
  by (auto intro: rel_sum.intros elim: rel_sum.cases)

inductive
   pred_sum :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a + 'b \<Rightarrow> bool" for P1 P2
where
  "P1 a \<Longrightarrow> pred_sum P1 P2 (Inl a)"
| "P2 b \<Longrightarrow> pred_sum P1 P2 (Inr b)"

lemma pred_sum_inject[code, simp]:
  "pred_sum P1 P2 (Inl a) \<longleftrightarrow> P1 a"
  "pred_sum P1 P2 (Inr b) \<longleftrightarrow> P2 b"
  by (simp add: pred_sum.simps)+

bnf "'a + 'b"
  map: map_sum
  sets: setl setr
  bd: natLeq
  wits: Inl Inr
  rel: rel_sum
  pred: pred_sum
proof -
  show "map_sum id id = id" by (rule map_sum.id)
next
  fix f1 :: "'o \<Rightarrow> 's" and f2 :: "'p \<Rightarrow> 't" and g1 :: "'s \<Rightarrow> 'q" and g2 :: "'t \<Rightarrow> 'r"
  show "map_sum (g1 o f1) (g2 o f2) = map_sum g1 g2 o map_sum f1 f2"
    by (rule map_sum.comp[symmetric])
next
  fix x and f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r" and g1 g2
  assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
         a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
  thus "map_sum f1 f2 x = map_sum g1 g2 x"
  proof (cases x)
    case Inl thus ?thesis using a1 by (clarsimp simp: sum_set_defs(1))
  next
    case Inr thus ?thesis using a2 by (clarsimp simp: sum_set_defs(2))
  qed
next
  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
  show "setl o map_sum f1 f2 = image f1 o setl"
    by (rule ext, unfold o_apply) (simp add: sum_set_defs(1) split: sum.split)
next
  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
  show "setr o map_sum f1 f2 = image f2 o setr"
    by (rule ext, unfold o_apply) (simp add: sum_set_defs(2) split: sum.split)
next
  show "card_order natLeq" by (rule natLeq_card_order)
next
  show "cinfinite natLeq" by (rule natLeq_cinfinite)
next
  fix x :: "'o + 'p"
  show "|setl x| \<le>o natLeq"
    apply (rule ordLess_imp_ordLeq)
    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
    by (simp add: sum_set_defs(1) split: sum.split)
next
  fix x :: "'o + 'p"
  show "|setr x| \<le>o natLeq"
    apply (rule ordLess_imp_ordLeq)
    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
    by (simp add: sum_set_defs(2) split: sum.split)
next
  fix R1 R2 S1 S2
  show "rel_sum R1 R2 OO rel_sum S1 S2 \<le> rel_sum (R1 OO S1) (R2 OO S2)"
    by (force elim: rel_sum.cases)
next
  fix R S
  show "rel_sum R S = (\<lambda>x y.
    \<exists>z. (setl z \<subseteq> {(x, y). R x y} \<and> setr z \<subseteq> {(x, y). S x y}) \<and>
    map_sum fst fst z = x \<and> map_sum snd snd z = y)"
  unfolding sum_set_defs relcompp.simps conversep.simps fun_eq_iff
  by (fastforce elim: rel_sum.cases split: sum.splits)
qed (auto simp: sum_set_defs fun_eq_iff pred_sum.simps split: sum.splits)

inductive_set fsts :: "'a \<times> 'b \<Rightarrow> 'a set" for p :: "'a \<times> 'b" where
  "fst p \<in> fsts p"
inductive_set snds :: "'a \<times> 'b \<Rightarrow> 'b set" for p :: "'a \<times> 'b" where
  "snd p \<in> snds p"

lemma prod_set_defs[code]: "fsts = (\<lambda>p. {fst p})" "snds = (\<lambda>p. {snd p})"
  by (auto intro: fsts.intros snds.intros elim: fsts.cases snds.cases)

inductive
  rel_prod :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b \<times> 'd \<Rightarrow> bool" for R1 R2
where
  "\<lbrakk>R1 a b; R2 c d\<rbrakk> \<Longrightarrow> rel_prod R1 R2 (a, c) (b, d)"

inductive
  pred_prod :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" for P1 P2
where
  "\<lbrakk>P1 a; P2 b\<rbrakk> \<Longrightarrow> pred_prod P1 P2 (a, b)"

lemma rel_prod_inject [code, simp]:
  "rel_prod R1 R2 (a, b) (c, d) \<longleftrightarrow> R1 a c \<and> R2 b d"
  by (auto intro: rel_prod.intros elim: rel_prod.cases)

lemma pred_prod_inject [code, simp]:
  "pred_prod P1 P2 (a, b) \<longleftrightarrow> P1 a \<and> P2 b"
  by (auto intro: pred_prod.intros elim: pred_prod.cases)

lemma rel_prod_conv:
  "rel_prod R1 R2 = (\<lambda>(a, b) (c, d). R1 a c \<and> R2 b d)"
  by (rule ext, rule ext) auto

definition
  pred_fun :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "pred_fun A B = (\<lambda>f. \<forall>x. A x \<longrightarrow> B (f x))"

lemma pred_funI: "(\<And>x. A x \<Longrightarrow> B (f x)) \<Longrightarrow> pred_fun A B f"
  unfolding pred_fun_def by simp

bnf "'a \<times> 'b"
  map: map_prod
  sets: fsts snds
  bd: natLeq
  rel: rel_prod
  pred: pred_prod
proof (unfold prod_set_defs)
  show "map_prod id id = id" by (rule map_prod.id)
next
  fix f1 f2 g1 g2
  show "map_prod (g1 o f1) (g2 o f2) = map_prod g1 g2 o map_prod f1 f2"
    by (rule map_prod.comp[symmetric])
next
  fix x f1 f2 g1 g2
  assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
  thus "map_prod f1 f2 x = map_prod g1 g2 x" by (cases x) simp
next
  fix f1 f2
  show "(\<lambda>x. {fst x}) o map_prod f1 f2 = image f1 o (\<lambda>x. {fst x})"
    by (rule ext, unfold o_apply) simp
next
  fix f1 f2
  show "(\<lambda>x. {snd x}) o map_prod f1 f2 = image f2 o (\<lambda>x. {snd x})"
    by (rule ext, unfold o_apply) simp
next
  show "card_order natLeq" by (rule natLeq_card_order)
next
  show "cinfinite natLeq" by (rule natLeq_cinfinite)
next
  fix x
  show "|{fst x}| \<le>o natLeq"
    by (rule ordLess_imp_ordLeq) (simp add: finite_iff_ordLess_natLeq[symmetric])
next
  fix x
  show "|{snd x}| \<le>o natLeq"
    by (rule ordLess_imp_ordLeq) (simp add: finite_iff_ordLess_natLeq[symmetric])
next
  fix R1 R2 S1 S2
  show "rel_prod R1 R2 OO rel_prod S1 S2 \<le> rel_prod (R1 OO S1) (R2 OO S2)" by auto
next
  fix R S
  show "rel_prod R S = (\<lambda>x y.
    \<exists>z. ({fst z} \<subseteq> {(x, y). R x y} \<and> {snd z} \<subseteq> {(x, y). S x y}) \<and>
      map_prod fst fst z = x \<and> map_prod snd snd z = y)"
  unfolding prod_set_defs rel_prod_inject relcompp.simps conversep.simps fun_eq_iff
  by auto
qed auto

bnf "'a \<Rightarrow> 'b"
  map: "op \<circ>"
  sets: range
  bd: "natLeq +c |UNIV :: 'a set|"
  rel: "rel_fun op ="
  pred: "pred_fun (\<lambda>_. True)"
proof
  fix f show "id \<circ> f = id f" by simp
next
  fix f g show "op \<circ> (g \<circ> f) = op \<circ> g \<circ> op \<circ> f"
  unfolding comp_def[abs_def] ..
next
  fix x f g
  assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
  thus "f \<circ> x = g \<circ> x" by auto
next
  fix f show "range \<circ> op \<circ> f = op ` f \<circ> range"
    by (auto simp add: fun_eq_iff)
next
  show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
  apply (rule card_order_csum)
  apply (rule natLeq_card_order)
  by (rule card_of_card_order_on)
(*  *)
  show "cinfinite (natLeq +c ?U)"
    apply (rule cinfinite_csum)
    apply (rule disjI1)
    by (rule natLeq_cinfinite)
next
  fix f :: "'d => 'a"
  have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
  also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
  finally show "|range f| \<le>o natLeq +c ?U" .
next
  fix R S
  show "rel_fun op = R OO rel_fun op = S \<le> rel_fun op = (R OO S)" by (auto simp: rel_fun_def)
next
  fix R
  show "rel_fun op = R = (\<lambda>x y.
    \<exists>z. range z \<subseteq> {(x, y). R x y} \<and> fst \<circ> z = x \<and> snd \<circ> z = y)"
  unfolding rel_fun_def subset_iff by (force simp: fun_eq_iff[symmetric])
qed (auto simp: pred_fun_def)

end


section \<open>Syntactic Matching in the Simplifier\<close>
theory Syntax_Match
imports Main
begin

subsection \<open>Non-Matching\<close>

text \<open>
  We define the vebt_predicates \<open>syntax_nomatch\<close>
  and \<open>syntax_fo_nomatch\<close>. The expression
  \<open>syntax_nomatch pattern object\<close> is simplified to true only if
  the term \<open>pattern\<close> syntactically matches the term \<open>object\<close>.
  Note that, semantically, \<open>syntax_nomatch pattern object\<close> is always
  true. While \<open>syntax_nomatch\<close> does higher-order matching,
  \<open>syntax_fo_nomatch\<close> does first-order matching.

  The intended application of these vebt_predicates are as guards for simplification
  rules, enforcing additional syntactic restrictions on the applicability of
  the simplification rule.
\<close>
definition syntax_nomatch :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  where syntax_nomatch_def: "syntax_nomatch pat obj \<equiv> True"
definition syntax_fo_nomatch :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  where syntax_fo_nomatch_def: "syntax_fo_nomatch pat obj \<equiv> True"

(* Prevent simplifier to simplify inside syntax_xx vebt_predicates *)
lemma [cong]: "syntax_fo_nomatch x y = syntax_fo_nomatch x y" by simp
lemma [cong]: "syntax_nomatch x y = syntax_nomatch x y" by simp

ML \<open>
structure Syntax_Match = struct
  val nomatch_thm = @{thm syntax_nomatch_def};
  val fo_nomatch_thm = @{thm syntax_fo_nomatch_def};

  fun fo_nomatch_simproc ctxt credex = let
    (*val ctxt = Simplifier.the_context ss;*)
    val thy = Proof_Context.theory_of ctxt;

    val redex = Thm.term_of credex;
    val (_,[pat,obj]) = strip_comb redex;

    fun fo_matches po = (Pattern.first_order_match
      thy po (Vartab.empty, Vartab.empty); true) handle Pattern.MATCH => false;
  in
    if fo_matches (pat,obj) then NONE else SOME fo_nomatch_thm
  end

  fun nomatch_simproc ctxt credex = let
    (*val ctxt = Simplifier.the_context ss;*)
    val thy = Proof_Context.theory_of ctxt;

    val redex = Thm.term_of credex;
    val (_,[pat,obj]) = strip_comb redex;
  in
    if Pattern.matches thy (pat,obj) then NONE else SOME nomatch_thm
  end
end
\<close>
simproc_setup nomatch ("syntax_nomatch pat obj")
  = \<open>K Syntax_Match.nomatch_simproc\<close>
simproc_setup fo_nomatch ("syntax_fo_nomatch pat obj")
  = \<open>K Syntax_Match.fo_nomatch_simproc\<close>

subsection \<open>Examples\<close>
subsubsection \<open>Ordering AC-structures\<close>
text \<open>
  Currently, the simplifier rules for ac-rewriting only work when
  associativity groups to the right. Here, we define rules that work for
  associativity grouping to the left. They are useful for operators where
  syntax is parsed (and pretty-printed) left-associative.
\<close>

locale ac_operator =
  fixes f
  assumes right_assoc: "f (f a b) c = f a (f b c)"
  assumes commute: "f a b = f b a"
begin
  lemmas left_assoc = right_assoc[symmetric]
  lemma left_commute: "f a (f b c) = f b (f a c)"
    apply (simp add: left_assoc)
    apply (simp add: commute)
    done

  lemmas right_ac = right_assoc left_commute commute

  lemma right_commute: "f (f a b) c = f (f a c) b"
    by (simp add: right_ac)

  lemma safe_commute: "syntax_fo_nomatch (f x y) a \<Longrightarrow> f a b = f b a"
    by (simp add: right_ac)

  lemmas left_ac = left_assoc right_commute safe_commute
end

interpretation mult: ac_operator "(*) ::'a::ab_semigroup_mult \<Rightarrow> _ \<Rightarrow> _"
  apply unfold_locales
  apply (simp_all add: ac_simps)
  done

interpretation add: ac_operator "(+) ::'a::ab_semigroup_add \<Rightarrow> _ \<Rightarrow> _"
  apply unfold_locales
  apply (simp_all add: ac_simps)
  done

text \<open>Attention: \<open>conj_assoc\<close> is in standard simpset, it has to be
  removed when using \<open>conj.left_ac\<close> !\<close>
interpretation conj: ac_operator "(\<and>)"
  by unfold_locales auto
interpretation disj: ac_operator "(\<or>)"
  by unfold_locales auto

end


header {* Extension of Association Lists *}

theory AList_ext imports
  "~~/src/HOL/Library/AList_Mapping"
  "~~/src/HOL/Library/List_lexord"
  "~~/src/HOL/Library/Product_Lexorder"
begin

text {*
Association lists in Isabelle are implemented in the theory @{text AList} and extended by
the theory @{text AList_Mapping}, which links association lists with mappings.
However, we found the two theories to lack several useful lemmata, which we tried to remedy
in our extension of association lists.
Furthermore, we defined some short-hand notation for frequently used expressions.
*}

definition is_alist :: "('a \<times> 'b) list \<Rightarrow> bool" where
  "is_alist l \<equiv> distinct (map fst l)"

definition lookup :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b" where
  "lookup l k \<equiv> the (Mapping.lookup (Mapping l) k)"

definition keys :: "('a \<times> 'b) list \<Rightarrow> 'a set" where
  "keys l \<equiv> Mapping.keys (Mapping l)"

(*<*)
definition values_related where
  "values_related r l1 l2 \<equiv> \<forall>(k1, v1) \<in> set l1. \<forall>(k2, v2) \<in> set l2. k1 = k2 \<longrightarrow> r v1 v2"

definition values_leq where
  "values_leq \<equiv> values_related less_eq"

lemma alist_keys_fst_set[simp]: "keys l = fst ` set l"
by (induct l) (auto simp add: keys_def)

lemma alist_fst_map: "is_alist l1 \<Longrightarrow> map fst l1 = map fst l2 \<Longrightarrow> is_alist l2"
by (simp add: is_alist_def)

lemma alist_empty[simp]: "is_alist []"
by (simp add: is_alist_def)

lemma keys_fst_map: "set (map fst l) = keys l"
by (induct l) (auto simp add: keys_def)

lemma key_in_fst[simp]: "(k, v) \<in> A \<Longrightarrow> k \<in> fst ` A"
by (rule Set.image_eqI) simp_all

lemma lookup_from_existence: "is_alist l \<Longrightarrow> (k, v) \<in> set l \<Longrightarrow> lookup l k = v"
by (simp add: lookup_def is_alist_def)

lemma existence_from_lookup: "is_alist l \<Longrightarrow> k \<in> keys l \<Longrightarrow> lookup l k = v \<Longrightarrow> (k, v) \<in> set l"
by (auto simp add: keys_def lookup_def is_alist_def)

lemma lookup_predicate: "is_alist l \<Longrightarrow> (k, v) \<in> set l \<Longrightarrow> P k v \<Longrightarrow> P k (lookup l k)"
by (induct l) (auto simp add: lookup_def is_alist_def)

lemma lookup_forall: "\<forall>(k, v) \<in> set l. P k v \<Longrightarrow> k \<in> keys l \<Longrightarrow> P k (lookup l k)"
by (induct l) (auto simp add: lookup_def)

(* TODO: improve proof speed! *)
lemma alist_partition_distr: "is_alist l \<Longrightarrow> (yes, no) = partition P l \<Longrightarrow> is_alist (yes @ no)"
unfolding is_alist_def apply (induct l arbitrary: yes no) by auto

lemma alist_distr: "is_alist (l1 @ l2) = (is_alist l1 \<and> is_alist l2 \<and> keys l1 \<inter> keys l2 = {})"
by (induct l1, auto simp add: is_alist_def)

lemma alist_distr_fst_map:
  assumes "map fst l = map fst l1 @ map fst l2"
      and "is_alist l1"
      and "is_alist l2"
      and "keys l1 \<inter> keys l2 = {}"
    shows "is_alist l"
using assms by (induct l1, auto simp add: is_alist_def)

lemma alist_values_equal: "is_alist l \<Longrightarrow> (k, v1) \<in> set l \<Longrightarrow> (k, v2) \<in> set l \<Longrightarrow> v1 = v2"
by (induct l) (auto simp add: is_alist_def)

lemma alist_filter: "is_alist l \<Longrightarrow> is_alist (filter P l)"
by (induct l) (auto simp add: is_alist_def)

lemma alist_map_alist: "is_alist l \<Longrightarrow> is_alist (map (\<lambda>(a, b). (a, f b)) l)"
by (induct l) (auto simp add: is_alist_def)

lemma alist_map_values_equal:
  "is_alist l \<Longrightarrow> (k, v) \<in> set l \<Longrightarrow> (k, v') \<in> set (map (\<lambda>(k, v). (k, f k v)) l) \<Longrightarrow> v' = f k v"
by (induct l) (auto simp add: is_alist_def, force)

lemma map_fst_map: "map fst (map (\<lambda>(k, v). (k, f v)) l) = map fst l"
by (induct l) auto

lemma map_keys_equal: "keys (map (\<lambda>(k, v). (k, f v)) l) = keys l"
by (induct l) auto

lemma alist_superset_lookup_equal:
  assumes "set l \<subseteq> keys A"
      and "is_alist A"
      and "is_alist B"
      and "set A \<subseteq> set B"
      and "k \<in> set l"
    shows "lookup A k = lookup B k"
proof -
  have "(k, lookup A k) \<in> set A" using existence_from_lookup assms(1,2,5) by force
  then have 1: "(k, lookup A k) \<in> set B" using assms(4) by auto

  have "(k, lookup B k) \<in> set B" using existence_from_lookup assms by force
  then show ?thesis using 1 alist_values_equal assms(3) by force
qed

lemma alist_subset_values_equal:
  assumes "set l2 \<subseteq> set l1"
      and "is_alist l1"
      and "is_alist l2"
      and "k \<in> keys l2"
      and "(k, v) \<in> set l1"
    shows "(k, v) \<in> set l2"
proof -
  have 1: "(k, lookup l2 k) \<in> set l2" using assms(3-4) by (metis existence_from_lookup)
  then have "(k, lookup l2 k) \<in> set l1" using assms(1) by auto
  then have "lookup l2 k = v" using assms(2,5) by (metis lookup_from_existence)
  then show ?thesis using 1 by auto
qed

lemma lookup_in_snd: "k \<in> keys l \<Longrightarrow> (lookup l) k \<in> snd ` set l"
by (induct l) (auto simp add: lookup_def)

lemma lookup_map_in_snd: "set ks \<subseteq> keys l \<Longrightarrow> set (map (lookup l) ks) \<subseteq> snd ` set l"
by (metis (hide_lams, no_types) image_set image_subsetI in_mono lookup_in_snd)

lemma lookup_values_predicate:
  assumes "set ks \<subseteq> keys l"
      and "\<forall>(k, v) \<in> set l. P v"
    shows "\<forall>v \<in> set (map (lookup l) ks). P v"
proof -
  have "\<forall>v \<in> snd ` set l. P v" using assms(2) by auto
  then show ?thesis using lookup_map_in_snd[OF assms(1)] by (metis in_mono)
qed

lemma map_ran_smaller:
  assumes "\<forall>(k, v) \<in> set xs. f k v \<le> v"
      and "ys = map_ran f xs"
    shows "ys \<le> (xs :: ('a :: order \<times> 'b :: order) list)"
proof -
  have "length ys = length xs" using assms(2) unfolding map_ran_def by auto
  then show ?thesis using assms apply (induct rule: list_induct2) by auto
qed

lemma map_ran_lex:
  assumes "\<forall>(k, v) \<in> set xs. ((k, f k v), (k, v)) \<in> r\<^sup>="
      and "ys = map_ran f xs"
      and "xs \<noteq> ys"
    shows "(ys, xs) \<in> lex r"
proof -
  have "length ys = length xs" using assms(2) unfolding map_ran_def by auto
  then show ?thesis using assms by (induct rule: list_induct2) auto
qed

lemma values_leq_cons:
  assumes "values_leq xs ys"
      and "x \<le> y"
      and "k \<notin> keys xs \<union> keys ys"
    shows "values_leq ((k, x) # xs) ((k,y) # ys)"
using assms unfolding values_leq_def values_related_def by auto

lemma map_ran_values_leq:
  assumes "\<forall>(k, v) \<in> set xs. f k v \<le> v"
      and "ys = map_ran f xs"
      and "is_alist xs"
    shows "values_leq ys xs"
proof -
  have "length ys = length xs" using assms(2) unfolding map_ran_def by auto
  then show ?thesis using assms proof (induct rule: list_induct2)
    case (Cons x xs y ys)
    then have "is_alist ys" using alist_distr[of "[y]" ys, simplified] by auto
    then have I: "values_leq xs ys" using Cons by auto

    def  k \<equiv> "fst y"
    def vx \<equiv> "snd x"
    def vy \<equiv> "snd y"

    have FF: "fst y = fst x" using Cons(4) by (metis (mono_tags) fst_conv list.inject map.simps(2)
      map_ran_def split_conv surjective_pairing)
    have XP: "x = (k, vx)" unfolding k_def vx_def FF by auto
    have YP: "y = (k, vy)" unfolding k_def vy_def by auto

    have XY: "vx = f k vy" using Cons(4) unfolding XP YP by auto
    have LE: "vx \<le> vy" unfolding XY using Cons(3) unfolding k_def vy_def by auto
    have AL: "is_alist (x # xs)" using distinct_map_ran[of "y # ys"] Cons(4-5)
      unfolding is_alist_def by auto

    have NX: "k \<notin> keys xs" using k_def FF AL   alist_distr[of "[x]" xs] by auto
    have NY: "k \<notin> keys ys" using k_def Cons(5) alist_distr[of "[y]" ys] by auto
    have NU: "k \<notin> keys xs \<union> keys ys" using NX NY by auto
    show ?case unfolding XP YP using values_leq_cons[OF I LE NU] .
  qed (auto simp add: values_leq_def values_related_def)
qed

lemma list_all2_alist:
  assumes "map fst xs = map fst ys"
      and "is_alist xs"
      and "(k, v1) \<in> set xs"
      and "(k, v2) \<in> set ys"
      and "list_all2 P xs ys"
    shows "P (k, v1) (k, v2)"
proof -
  have "length xs = length ys" using assms(1) by (metis length_map)
  then show ?thesis using assms proof (induct rule: list_induct2)
    case (Cons x xs y ys)
    have MF: "map fst xs = map fst ys" using Cons(3) by auto
    have AX: "is_alist xs" using Cons(4) alist_distr[of "[x]" xs] by auto
    have LA: "list_all2 P xs ys" using Cons(7) by auto
    have AY: "is_alist (y#ys)" using Cons(3-4) by (metis alist_fst_map)

    show ?case
    proof (cases "(k, v1) \<in> set xs")
      case True
      then have "k \<in> keys ys" using MF by (metis alist_keys_fst_set key_in_fst keys_fst_map)
      then have "k \<notin> keys [y]" using AY unfolding is_alist_def keys_def by auto
      then have "(k, v2) \<in> set ys" using Cons(6) AY unfolding keys_def is_alist_def by auto
      then show ?thesis using True Cons(2)[OF MF AX _ _ LA] by auto
    next
      case False
      then have V1: "x = (k, v1)" using Cons(5) by auto
      then have "fst y = k" using Cons(3) by auto
      then have V2: "y = (k, v2)" using Cons(6) AY
        by (metis alist_values_equal fst_conv in_set_member member_rec(1) surj_pair)
      show ?thesis using Cons(7,1) unfolding V1 V2 by auto
    qed
  qed auto
qed

end


section \<open> Dynamic Logic \<close>

theory utp_dynlog
  imports utp_sequent utp_wp
begin

subsection \<open> Definitions \<close>

named_theorems dynlog_simp and dynlog_intro

definition dBox :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<beta> upred \<Rightarrow> '\<alpha> upred" ("\<^bold>[_\<^bold>]_" [0,999] 999)
where [upred_defs]: "dBox A \<Phi> = A wlp \<Phi>"

definition dDia :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<beta> upred \<Rightarrow> '\<alpha> upred" ("\<^bold><_\<^bold>>_" [0,999] 999)
where [upred_defs]: "dDia A \<Phi> = A wp \<Phi>"

utp_const dBox(0) dDia(0)

lemma dDia_dBox_def: "\<^bold><A\<^bold>>\<Phi> = (\<not> \<^bold>[A\<^bold>](\<not> \<Phi>))"
  by (simp add: dBox_def dDia_def wp_wlp_conjugate)

text \<open> Correspondence between Hoare logic and Dynamic Logic \<close>

lemma hoare_as_dynlog: "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u = (p \<tturnstile> \<^bold>[Q\<^bold>]r)"
  by (rel_auto)

subsection \<open> Box Laws \<close>

lemma dBox_false [dynlog_simp]: "\<^bold>[false\<^bold>]\<Phi> = true"
  by (rel_auto)

lemma dBox_skip [dynlog_simp]: "\<^bold>[II\<^bold>]\<Phi> = \<Phi>"
  by (rel_auto)

lemma dBox_assigns [dynlog_simp]: "\<^bold>[\<langle>\<sigma>\<rangle>\<^sub>a\<^bold>]\<Phi> = (\<sigma> \<dagger> \<Phi>)"
  by (simp add: dBox_def wlp_assigns_r)

lemma dBox_choice [dynlog_simp]: "\<^bold>[P \<sqinter> Q\<^bold>]\<Phi> = (\<^bold>[P\<^bold>]\<Phi> \<and> \<^bold>[Q\<^bold>]\<Phi>)"
  by (rel_auto)

lemma dBox_seq: "\<^bold>[P ;; Q\<^bold>]\<Phi> = \<^bold>[P\<^bold>]\<^bold>[Q\<^bold>]\<Phi>"
  by (simp add: dBox_def wlp_seq_r)

lemma dBox_star_unfold: "\<^bold>[P\<^sup>\<star>\<^bold>]\<Phi> = (\<Phi> \<and> \<^bold>[P\<^bold>]\<^bold>[P\<^sup>\<star>\<^bold>]\<Phi>)"
  by (metis dBox_choice dBox_seq dBox_skip ustar_unfoldl)

lemma dBox_star_induct: "`(\<Phi> \<and> \<^bold>[P\<^sup>\<star>\<^bold>](\<Phi> \<Rightarrow> \<^bold>[P\<^bold>]\<Phi>)) \<Rightarrow> \<^bold>[P\<^sup>\<star>\<^bold>]\<Phi>`"
  by (rel_simp, metis (mono_tags, lifting) mem_Collect_eq rtrancl_induct)

lemma dBox_test: "\<^bold>[?[p]\<^bold>]\<Phi> = (p \<Rightarrow> \<Phi>)"
  by (rel_auto)

subsection \<open> Diamond Laws \<close>

lemma dDia_false [dynlog_simp]: "\<^bold><false\<^bold>>\<Phi> = false"
  by (simp add: dBox_false dDia_dBox_def)

lemma dDia_skip [dynlog_simp]: "\<^bold><II\<^bold>>\<Phi> = \<Phi>"
  by (simp add: dBox_skip dDia_dBox_def)

lemma dDia_assigns [dynlog_simp]: "\<^bold><\<langle>\<sigma>\<rangle>\<^sub>a\<^bold>>\<Phi> = (\<sigma> \<dagger> \<Phi>)"
  by (simp add: dBox_assigns dDia_dBox_def subst_not)

lemma dDia_choice: "\<^bold><P \<sqinter> Q\<^bold>>\<Phi> = (\<^bold><P\<^bold>>\<Phi> \<or> \<^bold><Q\<^bold>>\<Phi>)"
  by (simp add: dBox_def dDia_dBox_def wlp_choice)

lemma dDia_seq: "\<^bold><P ;; Q\<^bold>>\<Phi> = \<^bold><P\<^bold>>\<^bold><Q\<^bold>>\<Phi>"
  by (simp add: dBox_def dDia_dBox_def wlp_seq_r)

lemma dDia_test: "\<^bold><?[p]\<^bold>>\<Phi> = (p \<and> \<Phi>)"
  by (rel_auto)

subsection \<open> Sequent Laws \<close>

lemma sBoxSeq [dynlog_simp]: "\<Gamma> \<tturnstile> \<^bold>[P ;; Q\<^bold>]\<Phi> \<equiv> \<Gamma> \<tturnstile> \<^bold>[P\<^bold>]\<^bold>[Q\<^bold>]\<Phi>"
  by (simp add: dBox_def wlp_seq_r)

lemma sBoxTest [dynlog_intro]: "\<Gamma> \<tturnstile> (b \<Rightarrow> \<Psi>) \<Longrightarrow> \<Gamma> \<tturnstile> \<^bold>[?[b]\<^bold>]\<Psi>"
  by (rel_auto)

lemma sBoxAssignFwd [dynlog_intro]:
  assumes "vwb_lens x" "\<And> x\<^sub>0. ((\<Gamma>\<lbrakk>\<guillemotleft>x\<^sub>0\<guillemotright>/&x\<rbrakk> \<and> &x = v\<lbrakk>\<guillemotleft>x\<^sub>0\<guillemotright>/&x\<rbrakk>) \<tturnstile> \<Phi>)"
  shows "(\<Gamma> \<tturnstile> \<^bold>[x := v\<^bold>]\<Phi>)"
proof -
  have "\<lbrace>\<Gamma>\<rbrace> x := v ;; II \<lbrace>\<Phi>\<rbrace>\<^sub>u"
    by (metis (no_types) assigns_init_hoare_general assms(1) assms(2) dBox_skip hoare_as_dynlog utp_pred_laws.inf_commute)
  then show ?thesis
    by (simp add: hoare_as_dynlog)
qed

lemma sBoxAssignFwd_simp [dynlog_simp]: "\<lbrakk> vwb_lens x; x \<sharp> v; x \<sharp> \<Gamma> \<rbrakk> \<Longrightarrow> (\<Gamma> \<tturnstile> \<^bold>[x := v\<^bold>]\<Phi>) = ((&x = v \<and> \<Gamma>) \<tturnstile> \<Phi>)"
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put)

lemma sBoxIndStar: "\<tturnstile> [\<Phi> \<Rightarrow> \<^bold>[P\<^bold>]\<Phi>]\<^sub>u \<Longrightarrow> \<Phi> \<tturnstile> \<^bold>[P\<^sup>\<star>\<^bold>]\<Phi>"
  by (rel_simp, metis (mono_tags, lifting) mem_Collect_eq rtrancl_induct)

end