theory Ports_Normalize
imports Common_Primitive_Lemmas
begin

section\<open>Normalizing L4 Ports\<close>
subsection\<open>Defining Normalized Ports\<close>

  fun normalized_src_ports :: "'i::len common_primitive match_expr \<Rightarrow> bool" where
    "normalized_src_ports MatchAny = True" |
    "normalized_src_ports (Match (Src_Ports (L4Ports _ []))) = True" |
    "normalized_src_ports (Match (Src_Ports (L4Ports _ [_]))) = True" |
    "normalized_src_ports (Match (Src_Ports _)) = False" |
    "normalized_src_ports (Match _) = True" |
    "normalized_src_ports (MatchNot (Match (Src_Ports _))) = False" |
    "normalized_src_ports (MatchNot (Match _)) = True" |
    "normalized_src_ports (MatchAnd m1 m2) = (normalized_src_ports m1 \<and> normalized_src_ports m2)" |
    "normalized_src_ports (MatchNot (MatchAnd _ _)) = False" |
    "normalized_src_ports (MatchNot (MatchNot _)) = False" |
    "normalized_src_ports (MatchNot MatchAny) = True"

  fun normalized_dst_ports :: "'i::len common_primitive match_expr \<Rightarrow> bool" where
    "normalized_dst_ports MatchAny = True" |
    "normalized_dst_ports (Match (Dst_Ports (L4Ports _ []))) = True" |
    "normalized_dst_ports (Match (Dst_Ports (L4Ports _ [_]))) = True" |
    "normalized_dst_ports (Match (Dst_Ports _)) = False" |
    "normalized_dst_ports (Match _) = True" |
    "normalized_dst_ports (MatchNot (Match (Dst_Ports _))) = False" |
    "normalized_dst_ports (MatchNot (Match _)) = True" |
    "normalized_dst_ports (MatchAnd m1 m2) = (normalized_dst_ports m1 \<and> normalized_dst_ports m2)" |
    "normalized_dst_ports (MatchNot (MatchAnd _ _)) = False" |
    "normalized_dst_ports (MatchNot (MatchNot _)) = False" |
    "normalized_dst_ports (MatchNot MatchAny) = True"

  lemma normalized_src_ports_def2: "normalized_src_ports ms = normalized_n_primitive (is_Src_Ports, src_ports_sel) (\<lambda>ps. case ps of L4Ports _ pts \<Rightarrow> length pts \<le> 1) ms"
    by(induction ms rule: normalized_src_ports.induct, simp_all)
  lemma normalized_dst_ports_def2: "normalized_dst_ports ms = normalized_n_primitive (is_Dst_Ports, dst_ports_sel) (\<lambda>ps. case ps of L4Ports _ pts \<Rightarrow> length pts \<le> 1) ms"
    by(induction ms rule: normalized_dst_ports.induct, simp_all)

text\<open>Idea: first, remove all negated matches, then @{const normalize_match},
  then only work with @{const primitive_extractor} on @{const Pos} ones.
  They only need an intersect and split later on.

  This is not very efficient because normalizing nnf will blow up a lot.
  but we can tune performance later on go for correctness first!
  Anything with @{const MatchOr} and @{const normalize_match} later is a bit inefficient.
\<close>

subsection\<open>Compressing Positive Matches on Ports into a Single Match\<close>
(*compressing positive matches on ports into a single match*)

  fun l4_ports_compress :: "ipt_l4_ports list \<Rightarrow> ipt_l4_ports match_compress" where
    "l4_ports_compress [] = MatchesAll" |
    "l4_ports_compress [L4Ports proto ps] = MatchExpr (L4Ports proto (wi2l (wordinterval_compress (l2wi ps))))" |
    "l4_ports_compress (L4Ports proto1 ps1 # L4Ports proto2 ps2 # pss) =
      (if
          proto1 \<noteq> proto2
       then
         CannotMatch
       else
         l4_ports_compress (L4Ports proto1 (wi2l (wordinterval_intersection (l2wi ps1) (l2wi ps2))) # pss)
      )"

  value[code] "l4_ports_compress [L4Ports TCP [(22,22), (23,23)]]"

  (*only for src*)
  lemma raw_ports_compress_src_CannotMatch:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic \<beta>"
  and c: "l4_ports_compress pss = CannotMatch"
  shows "\<not> matches (\<beta>, \<alpha>) (alist_and (map (Pos \<circ> Src_Ports) pss)) a p"
  using c apply(induction pss rule: l4_ports_compress.induct)
    apply(simp; fail)
   apply(simp; fail)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic] bunch_of_lemmata_about_matches split: if_split_asm)
   apply meson
  by(simp add: l2wi_wi2l ports_to_set_wordinterval)

  lemma raw_ports_compress_dst_CannotMatch:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic \<beta>"
  and c: "l4_ports_compress pss = CannotMatch"
  shows "\<not> matches (\<beta>, \<alpha>) (alist_and (map (Pos \<circ> Dst_Ports) pss)) a p"
  using c apply(induction pss rule: l4_ports_compress.induct)
    apply(simp; fail)
   apply(simp; fail)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic] bunch_of_lemmata_about_matches split: if_split_asm)
   apply meson
  by(simp add: l2wi_wi2l ports_to_set_wordinterval)

  lemma l4_ports_compress_length_Matchall: "length pss > 0 \<Longrightarrow> l4_ports_compress pss \<noteq> MatchesAll"
    by(induction pss rule: l4_ports_compress.induct) simp+

  lemma raw_ports_compress_src_MatchExpr:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic \<beta>"
  and c: "l4_ports_compress pss = MatchExpr m"
  shows "matches (\<beta>, \<alpha>) (Match (Src_Ports m)) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) (alist_and (map (Pos \<circ> Src_Ports) pss)) a p"
  using c apply(induction pss arbitrary: m rule: l4_ports_compress.induct)
    apply(simp add: bunch_of_lemmata_about_matches; fail)
   subgoal
   apply(simp add: bunch_of_lemmata_about_matches)
   apply(drule sym, simp)
   by(simp add: primitive_matcher_generic.Ports_single[OF generic] wordinterval_compress l2wi_wi2l ports_to_set_wordinterval)
  apply(case_tac m)
  apply(simp add: bunch_of_lemmata_about_matches split: if_split_asm)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic])
  apply(simp add: l2wi_wi2l ports_to_set_wordinterval)
  by fastforce

  lemma raw_ports_compress_dst_MatchExpr:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic \<beta>"
  and c: "l4_ports_compress pss = MatchExpr m"
  shows "matches (\<beta>, \<alpha>) (Match (Dst_Ports m)) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) (alist_and (map (Pos \<circ> Dst_Ports) pss)) a p"
  using c apply(induction pss arbitrary: m rule: l4_ports_compress.induct)
    apply(simp add: bunch_of_lemmata_about_matches; fail)
   subgoal
   apply(simp add: bunch_of_lemmata_about_matches)
   apply(drule sym, simp)
   by(simp add: primitive_matcher_generic.Ports_single[OF generic] wordinterval_compress l2wi_wi2l ports_to_set_wordinterval)
  apply(case_tac m)
  apply(simp add: bunch_of_lemmata_about_matches split: if_split_asm)
  apply(simp add: primitive_matcher_generic.Ports_single[OF generic])
  apply(simp add: l2wi_wi2l ports_to_set_wordinterval)
  by fastforce

subsection\<open>Rewriting Negated Matches on Ports\<close>

  fun l4_ports_negate_one
    :: "(ipt_l4_ports \<Rightarrow> 'i common_primitive) \<Rightarrow> ipt_l4_ports \<Rightarrow> ('i::len common_primitive) match_expr"
  where
    "l4_ports_negate_one C (L4Ports proto pts) = MatchOr
           (MatchNot (Match (Prot (Proto proto))))
            (Match (C (L4Ports proto (raw_ports_invert pts))))"

  lemma l4_ports_negate_one:
  fixes p :: "('i::len, 'a) tagged_packet_scheme"
  assumes generic: "primitive_matcher_generic \<beta>"
  shows "matches (\<beta>, \<alpha>) (l4_ports_negate_one Src_Ports ports) a p \<longleftrightarrow>
          matches (\<beta>, \<alpha>) (MatchNot (Match (Src_Ports ports))) a p"
  and "matches (\<beta>, \<alpha>) (l4_ports_negate_one Dst_Ports ports) a p \<longleftrightarrow>
          matches (\<beta>, \<alpha>) (MatchNot (Match (Dst_Ports ports))) a p"
    apply(case_tac [!] ports)
    by(auto simp add: primitive_matcher_generic.Ports_single_not[OF generic]
                    MatchOr bunch_of_lemmata_about_matches
                    primitive_matcher_generic.Prot_single_not[OF generic]
                    primitive_matcher_generic.Ports_single[OF generic]
                    raw_ports_invert)

  lemma l4_ports_negate_one_nodisc:
    "\<forall>a. \<not> disc (C a) \<Longrightarrow> \<forall>a. \<not> disc (Prot a) \<Longrightarrow> \<not> has_disc disc (l4_ports_negate_one C pt)"
      apply(cases pt)
      by(simp add: MatchOr_def)

  lemma l4_ports_negate_one_not_has_disc_negated_generic:
    assumes noProt: "\<forall>a. \<not> disc (Prot a)"
    shows "\<not> has_disc_negated disc False (l4_ports_negate_one C ports)"
    apply(cases ports, rename_tac proto pts)
    by(simp add: MatchOr_def noProt)

  lemma l4_ports_negate_one_not_has_disc_negated:
    "\<not> has_disc_negated is_Src_Ports False (l4_ports_negate_one Src_Ports ports)"
    "\<not> has_disc_negated is_Dst_Ports False (l4_ports_negate_one Dst_Ports ports)"
    by(simp add: l4_ports_negate_one_not_has_disc_negated_generic)+

  lemma negated_normalized_folded_ports_nodisc:
    "\<forall>a. \<not> disc (C a) \<Longrightarrow> (\<forall>a. \<not> disc (Prot a)) \<or> pts = [] \<Longrightarrow>
     m \<in> set (normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) pts))) \<Longrightarrow>
      \<not> has_disc disc m"
    apply(subgoal_tac "\<not> has_disc disc (andfold_MatchExp (map (l4_ports_negate_one C) pts))")
     prefer 2
     apply(rule andfold_MatchExp_not_discI)
     apply(simp)
     apply(elim disjE)
      using l4_ports_negate_one_nodisc apply blast
     apply(simp; fail)
    using normalize_match_preserves_nodisc by blast

  lemma negated_normalized_folded_ports_normalized_n_primitive:
    "\<forall>a. \<not> disc (C a) \<Longrightarrow> (\<forall>a. \<not> disc (Prot a)) \<or> pts = [] \<Longrightarrow>
     x \<in> set (normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) pts))) \<Longrightarrow>
      normalized_n_primitive (disc, sel) f x"
    apply(rule normalized_n_primitive_if_no_primitive)
     using normalized_nnf_match_normalize_match apply blast
    apply(rule negated_normalized_folded_ports_nodisc)
    by simp_all

  text\<open>beware, the result is not nnf normalized!\<close>
  lemma "\<not> normalized_nnf_match (l4_ports_negate_one C ports)"
    by(cases ports) (simp add: MatchOr_def)

  text\<open>Warning: does not preserve negated primitive property in general.
       Might be violated for @{const Prot}. We will nnf normalize after applying the function.\<close>
  lemma "\<forall>a. \<not> disc (C a) \<Longrightarrow> \<not> normalized_n_primitive (disc, sel) f (l4_ports_negate_one C a)"
    by(cases a)(simp add: MatchOr_def)

  declare l4_ports_negate_one.simps[simp del]

  lemma "((normalize_match (l4_ports_negate_one Src_Ports (L4Ports TCP [(22,22),(80,90)]))):: 32 common_primitive match_expr list)
    =
    [ MatchNot (Match (Prot (Proto TCP)))
    , Match (Src_Ports (L4Ports 6 [(0, 21), (23, 79), (91, 0xFFFF)]))]" by eval

  (*TODO: this one is generic, move?*)
  definition rewrite_negated_primitives
    :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> (*disc_sel C*)
        (('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'a match_expr) \<Rightarrow> (*negate_one function*)
        'a match_expr \<Rightarrow> 'a match_expr" where
    "rewrite_negated_primitives disc_sel C negate m \<equiv>
        let (spts, rst) = primitive_extractor disc_sel m
        in if getNeg spts = [] then m else
          MatchAnd
            (andfold_MatchExp (map (negate C) (getNeg spts)))
            (MatchAnd
              (andfold_MatchExp (map (Match \<circ> C) (getPos spts))) (*TODO: compress all the positive ports into one?*)
            rst)"

  text\<open>It does nothing of there is not even a negated primitive in it\<close>
  lemma rewrite_negated_primitives_unchanged_if_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and noDisc: "\<not> has_disc_negated disc False m"
  shows "rewrite_negated_primitives (disc,sel) C negate_f m = m"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    using noDisc by blast

  lemma rewrite_negated_primitives_normalized_no_modification:
    assumes wf_disc_sel: "wf_disc_sel (disc, sel) C"
    and disc_p: "\<not> has_disc_negated disc False m"
    and n: "normalized_nnf_match m"
    and a: "a \<in> set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m))"
    shows "a = m"
    proof -
      from rewrite_negated_primitives_unchanged_if_not_has_disc_negated[OF n wf_disc_sel disc_p]
      have m: "rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m = m" by simp
      from a show ?thesis
        apply(subst(asm) m)
        using normalize_match_already_normalized[OF n] by fastforce
    qed

  lemma rewrite_negated_primitives_preserves_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc, sel) C"
  and nodisc: "\<not> has_disc disc2 m"
  and noNeg: "\<not> has_disc_negated disc False m"
  and disc2_noC: "\<forall>a. \<not> disc2 (C a)"
  shows "\<not> has_disc disc2 (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)"
    apply(subst rewrite_negated_primitives_unchanged_if_not_has_disc_negated)
    using n wf_disc_sel noNeg nodisc by(simp)+

  lemma rewrite_negated_primitives:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel disc_sel C"
  and negate_f: "\<forall>pts. matches \<gamma> (negate_f C pts) a p \<longleftrightarrow> matches \<gamma> (MatchNot (Match (C pts))) a p"
  shows "matches \<gamma> (rewrite_negated_primitives disc_sel C negate_f m) a p \<longleftrightarrow> matches \<gamma> m a p"
  proof -
    obtain spts rst where pext: "primitive_extractor disc_sel m = (spts, rst)"
      by(cases "primitive_extractor disc_sel m") simp
    obtain disc sel where disc_sel: "disc_sel = (disc, sel)" by(cases disc_sel) simp
    with wf_disc_sel have wf_disc_sel': "wf_disc_sel (disc, sel) C" by simp
    from disc_sel pext have pext': "primitive_extractor (disc, sel) m = (spts, rst)" by simp

    have "matches \<gamma> (andfold_MatchExp (map (negate_f C) (getNeg spts))) a p \<and>
          matches \<gamma> (andfold_MatchExp (map (Match \<circ> C) (getPos spts))) a p \<and> matches \<gamma> rst a p \<longleftrightarrow>
       matches \<gamma> m a p"
      apply(subst primitive_extractor_correct(1)[OF n wf_disc_sel' pext', symmetric])
      apply(simp add: andfold_MatchExp_matches)
      apply(simp add: negate_f)
      using alist_and_NegPos_map_getNeg_getPos_matches by fast
    thus ?thesis by(simp add: rewrite_negated_primitives_def pext bunch_of_lemmata_about_matches)
  qed

  lemma rewrite_negated_primitives_not_has_disc:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and nodisc: "\<not> has_disc disc2 m"
  (*only need a condition for negate_f if it is actually applied*)
  and negate_f: "has_disc_negated disc False m \<Longrightarrow> \<forall>pts. \<not> has_disc disc2 (negate_f C pts)"
  and no_disc: "\<forall>a. \<not> disc2 (C a)"
  shows  "\<not> has_disc disc2 (rewrite_negated_primitives (disc,sel) C negate_f m)"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    apply(intro conjI impI)
       using nodisc apply(simp; fail)
      apply(rule andfold_MatchExp_not_discI)
      apply(simp add: negate_f; fail)
     using andfold_MatchExp_not_disc_mapMatch no_disc apply blast
     using nodisc by blast

  lemma rewrite_negated_primitives_not_has_disc_negated:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and negate_f: "has_disc_negated disc False m \<Longrightarrow> \<forall>pts. \<not> has_disc_negated disc False (negate_f C pts)"
  shows  "\<not> has_disc_negated disc False (rewrite_negated_primitives (disc,sel) C negate_f m)"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    apply(intro conjI impI)
       apply blast
      apply(rule andfold_MatchExp_not_disc_negatedI)
      apply(simp add: negate_f; fail)
     using andfold_MatchExp_not_disc_negated_mapMatch apply blast
    using has_disc_negated_has_disc by blast

  lemma rewrite_negated_primitives_preserves_not_has_disc_negated:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and negate_f: "has_disc_negated disc False m \<Longrightarrow> \<forall>pts. \<not> has_disc_negated disc2 False (negate_f C pts)"
  and no_disc: "\<not> has_disc_negated disc2 False m"
  shows  "\<not> has_disc_negated disc2 False (rewrite_negated_primitives (disc,sel) C negate_f m)"
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(8)[OF n wf_disc_sel])
    apply(intro conjI impI)
       using no_disc apply blast
      apply(rule andfold_MatchExp_not_disc_negatedI)
      apply(simp add: negate_f; fail)
     using andfold_MatchExp_not_disc_negated_mapMatch apply blast
    apply(drule primitive_extractor_correct(6)[OF n wf_disc_sel, where neg=False])
    using no_disc by blast

  lemma rewrite_negated_primitives_normalized_preserves_unrelated_helper:
    assumes wf_disc_sel: "wf_disc_sel (disc, sel) C"
    and disc: "\<forall>a. \<not> disc2 (C a)"
    and disc_p: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated disc False m" (*either we do not disc on protocol or the is no negated port*)
    shows "normalized_nnf_match m \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f m \<Longrightarrow>
         a \<in> set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f  a"
    proof -
      have helper_a_normalized: "a \<in> MatchAnd x ` (\<Union>x\<in>set spts. MatchAnd x ` set (normalize_match rst)) \<Longrightarrow>
        normalized_n_primitive (disc, sel) f x \<Longrightarrow>
        (\<forall>s \<in> set spts. normalized_n_primitive (disc, sel) f s) \<Longrightarrow>
        normalized_n_primitive (disc, sel) f rst \<Longrightarrow>
             normalized_n_primitive (disc, sel) f a"
        for a x spts rst f disc and sel::"'a common_primitive \<Rightarrow> 'b"
        apply(subgoal_tac "\<exists> s r. a = MatchAnd x (MatchAnd s r) \<and> s \<in> set spts \<and> r \<in> set (normalize_match rst)")
         prefer 2
         apply blast
        apply(elim exE conjE, rename_tac s r)
        apply(simp)
        using normalize_match_preserves_normalized_n_primitive by blast

    show "normalized_nnf_match m \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f m \<Longrightarrow>
         a \<in> set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f  a"
    apply(case_tac "\<not> has_disc_negated disc False m")
     subgoal
     using rewrite_negated_primitives_normalized_no_modification[OF wf_disc_sel] by blast
    apply(simp add: rewrite_negated_primitives_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac spts rst)
    apply(simp)
    apply(subgoal_tac "normalized_n_primitive (disc2, sel2) f rst")
     prefer 2 subgoal for spts rst
     thm primitive_extractor_correct(5)[OF _ wf_disc_sel]
     apply(drule primitive_extractor_correct(5)[OF _ wf_disc_sel, where P="f"])
      apply blast
     by(simp)
    apply(insert disc_p, simp)
    apply(drule(1) primitive_extractor_correct(8)[OF _ wf_disc_sel])
    apply(simp)
    apply(elim bexE)
    apply(erule helper_a_normalized)
      subgoal for spts
      apply(rule_tac pts="(getNeg spts)" in negated_normalized_folded_ports_normalized_n_primitive[where C=C])
        using disc apply(simp; fail)
       using disc_p primitive_extractor_correct(8)[OF _ wf_disc_sel] apply blast
      by simp
     subgoal for x
     apply(intro ballI)
     apply(rule andfold_MatchExp_normalized_normalized_n_primitive_single[where C=C])
       using disc disc_p by(simp)+
    by blast
  qed

  definition rewrite_negated_src_ports
    :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
    "rewrite_negated_src_ports m \<equiv>
          rewrite_negated_primitives (is_Src_Ports, src_ports_sel) Src_Ports l4_ports_negate_one m"

  definition rewrite_negated_dst_ports
    :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
    "rewrite_negated_dst_ports m \<equiv>
          rewrite_negated_primitives (is_Dst_Ports, dst_ports_sel) Dst_Ports l4_ports_negate_one m"

  value "rewrite_negated_src_ports (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))"
  value "rewrite_negated_src_ports (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Extra ''foobar'')))
                 ))"

  lemma rewrite_negated_src_ports:
  assumes generic: "primitive_matcher_generic \<beta>"  and n: "normalized_nnf_match m"
  shows "matches (\<beta>, \<alpha>) (rewrite_negated_src_ports m) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) m a p"
  apply(simp add: rewrite_negated_src_ports_def)
  apply(rule rewrite_negated_primitives)
    by(simp add: l4_ports_negate_one[OF generic] n wf_disc_sel_common_primitive(1))+

  lemma rewrite_negated_dst_ports:
  assumes generic: "primitive_matcher_generic \<beta>"  and n: "normalized_nnf_match m"
  shows "matches (\<beta>, \<alpha>) (rewrite_negated_dst_ports m) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) m a p"
  apply(simp add: rewrite_negated_dst_ports_def)
  apply(rule rewrite_negated_primitives)
    by(simp add: l4_ports_negate_one[OF generic] n wf_disc_sel_common_primitive(2))+

  lemma rewrite_negated_src_ports_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  shows  "\<not> has_disc_negated is_Src_Ports False (rewrite_negated_src_ports m)"
    apply(simp add: rewrite_negated_src_ports_def)
    apply(rule rewrite_negated_primitives_not_has_disc_negated)
      by(simp add: n wf_disc_sel_common_primitive(1) l4_ports_negate_one_not_has_disc_negated)+

  lemma rewrite_negated_dst_ports_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  shows  "\<not> has_disc_negated is_Dst_Ports False (rewrite_negated_dst_ports m)"
    apply(simp add: rewrite_negated_dst_ports_def)
    apply(rule rewrite_negated_primitives_not_has_disc_negated)
      by(simp add: n wf_disc_sel_common_primitive(2) l4_ports_negate_one_not_has_disc_negated)+

  lemma "\<not> has_disc_negated disc t m \<Longrightarrow> \<forall>m' \<in> set (normalize_match m). \<not> has_disc_negated disc t m'"
    by(fact i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day)

  corollary normalize_rewrite_negated_src_ports_not_has_disc_negated:
  assumes n: "normalized_nnf_match m"
  shows "\<forall>m' \<in> set (normalize_match (rewrite_negated_src_ports m)). \<not> has_disc_negated is_Src_Ports False m'"
    apply(rule i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day)
    apply(rule rewrite_negated_src_ports_not_has_disc_negated)
    using n by simp

subsection\<open>Normalizing Positive Matches on Ports\<close>
(*now normalizing the match expression which does not have negated ports*)

(*creates a disjunction where all interval lists only have one element*)
  fun singletonize_L4Ports :: "ipt_l4_ports \<Rightarrow> ipt_l4_ports list" where
    "singletonize_L4Ports (L4Ports proto pts) = map (\<lambda>p. L4Ports proto [p]) pts"

  lemma singletonize_L4Ports_src: assumes generic: "primitive_matcher_generic \<beta>"
   shows "match_list (\<beta>, \<alpha>) (map (Match \<circ> Src_Ports) (singletonize_L4Ports pts)) a p \<longleftrightarrow>
    matches (\<beta>, \<alpha>) (Match (Src_Ports pts)) a p"
    apply(cases pts)
    apply(simp add: match_list_matches primitive_matcher_generic.Ports_single[OF generic])
    apply(simp add: ports_to_set)
    by auto

  lemma singletonize_L4Ports_dst: assumes generic: "primitive_matcher_generic \<beta>"
   shows "match_list (\<beta>, \<alpha>) (map (Match \<circ> Dst_Ports) (singletonize_L4Ports pts)) a p \<longleftrightarrow>
    matches (\<beta>, \<alpha>) (Match (Dst_Ports pts)) a p"
    apply(cases pts)
    apply(simp add: match_list_matches primitive_matcher_generic.Ports_single[OF generic])
    apply(simp add: ports_to_set)
    by auto

  lemma singletonize_L4Ports_normalized_generic:
    assumes wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and "m' \<in> (\<lambda>spt. Match (C spt)) ` set (singletonize_L4Ports pt)"
    shows "normalized_n_primitive (disc, sel) (case_ipt_l4_ports (\<lambda>x pts. length pts \<le> 1))  m'"
    using assms
    apply(case_tac pt)
    apply(simp)
    apply(induction m')
        by(auto simp: wf_disc_sel.simps)

  lemma singletonize_L4Ports_normalized_src_ports:
    "m' \<in> (\<lambda>spt. Match (Src_Ports spt)) ` set (singletonize_L4Ports pt) \<Longrightarrow> normalized_src_ports m'"
    apply(simp add: normalized_src_ports_def2)
    using singletonize_L4Ports_normalized_generic[OF wf_disc_sel_common_primitive(1)] by blast

  lemma singletonize_L4Ports_normalized_dst_ports:
    "m' \<in> (\<lambda>spt. Match (Dst_Ports spt)) ` set (singletonize_L4Ports pt) \<Longrightarrow> normalized_dst_ports m'"
    apply(simp add: normalized_dst_ports_def2)
    using singletonize_L4Ports_normalized_generic[OF wf_disc_sel_common_primitive(2)] by blast

  declare singletonize_L4Ports.simps[simp del]

  lemma normalized_ports_singletonize_combine_rst:
    assumes wf_disc_sel: "wf_disc_sel (disc,sel) C"
    shows "normalized_n_primitive (disc, sel) (case_ipt_l4_ports (\<lambda>x pts. length pts \<le> 1)) rst \<Longrightarrow>
    m' \<in> (\<lambda>spt. MatchAnd (Match (C spt)) rst) ` set (singletonize_L4Ports pt) \<Longrightarrow>
    normalized_n_primitive (disc, sel) (case_ipt_l4_ports (\<lambda>x pts. length pts \<le> 1)) m'"
   apply simp
   apply(rule normalized_n_primitive_MatchAnd_combine_map)
     apply(simp_all)
   using singletonize_L4Ports_normalized_generic[OF wf_disc_sel] by fastforce

  text\<open>Normalizing match expressions such that at most one port will exist in it.
       Returns a list of match expressions (splits one firewall rule into several rules).\<close>
  definition normalize_positive_ports_step
    :: "(('i::len common_primitive \<Rightarrow> bool) \<times> ('i common_primitive \<Rightarrow> ipt_l4_ports)) \<Rightarrow>
       (ipt_l4_ports \<Rightarrow> 'i common_primitive) \<Rightarrow>
       'i common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list" where
    "normalize_positive_ports_step disc_sel C m \<equiv>
        let (spts, rst) = primitive_extractor disc_sel m in
        case (getPos spts, getNeg spts)
          of (pspts, []) \<Rightarrow> (case l4_ports_compress pspts of CannotMatch \<Rightarrow> []
                                                          |  MatchesAll \<Rightarrow> [rst]
                                                          |  MatchExpr m \<Rightarrow> map (\<lambda>spt. (MatchAnd (Match (C spt)) rst)) (singletonize_L4Ports m)
                            )
          |  (_, _) \<Rightarrow> undefined"

  lemma normalize_positive_ports_step_nnf:
    assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and noneg: "\<not> has_disc_negated disc False m"
    shows "m' \<in> set (normalize_positive_ports_step (disc,sel) C m) \<Longrightarrow> normalized_nnf_match m'"
    apply(simp add: normalize_positive_ports_step_def)
    apply(elim exE conjE, rename_tac rst spts)
    apply(drule sym) (*switch primitive_extrartor = *)
    apply(frule primitive_extractor_correct(2)[OF n wf_disc_sel])
    apply(subgoal_tac "getNeg spts = []") (*duplication above*)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel])
      using noneg by simp+
    apply(simp split: match_compress.split_asm)
    by fastforce

  lemma normalize_positive_ports_step_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"  and wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and noneg: "\<not> has_disc_negated disc False m"
    shows "\<forall>m' \<in> set (normalize_positive_ports_step (disc,sel) C m).
            normalized_n_primitive (disc,sel) (\<lambda>ps. case ps of L4Ports _ pts \<Rightarrow> length pts \<le> 1) m'"
  unfolding normalize_positive_ports_step_def
    apply(intro ballI, rename_tac m')
    apply(simp)
    apply(elim exE conjE, rename_tac rst spts)
    apply(drule sym) (*switch primitive_extrartor = *)
    apply(frule primitive_extractor_correct(2)[OF n wf_disc_sel])
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply(subgoal_tac "getNeg spts = []") (*duplication above*)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel])
      using noneg by simp+
    apply(subgoal_tac "normalized_n_primitive (disc,sel) (\<lambda>ps. case ps of L4Ports _ pts \<Rightarrow> length pts \<le> 1) rst")
     prefer 2 subgoal
     by(drule(2) normalized_n_primitive_if_no_primitive)
    apply(simp split: match_compress.split_asm)
    using normalized_ports_singletonize_combine_rst[OF wf_disc_sel] by blast

  definition normalize_positive_src_ports :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list" where
    "normalize_positive_src_ports = normalize_positive_ports_step (is_Src_Ports, src_ports_sel) Src_Ports"
  definition normalize_positive_dst_ports :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list" where
    "normalize_positive_dst_ports = normalize_positive_ports_step (is_Dst_Ports, dst_ports_sel) Dst_Ports"

  (*TODO: into next lemmas?*)
  lemma noNeg_mapNegPos_helper: "getNeg ls = [] \<Longrightarrow>
           map (Pos \<circ> C) (getPos ls) = NegPos_map C ls"
    by(induction ls rule: getPos.induct) simp+

  lemma normalize_positive_src_ports:
    assumes generic: "primitive_matcher_generic \<beta>"
    and n: "normalized_nnf_match m"
    and noneg: "\<not> has_disc_negated is_Src_Ports False m"
    shows
        "match_list (\<beta>, \<alpha>) (normalize_positive_src_ports m) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) m a p"
    apply(simp add: normalize_positive_src_ports_def normalize_positive_ports_step_def)
    apply(case_tac "primitive_extractor (is_Src_Ports, src_ports_sel) m", rename_tac spts rst)
    apply(simp)
    apply(subgoal_tac "getNeg spts = []") (*needs assumption for this step *)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel_common_primitive(1)])
      using noneg by simp+
    apply(simp)
    apply(drule primitive_extractor_correct(1)[OF n wf_disc_sel_common_primitive(1), where \<gamma>="(\<beta>, \<alpha>)" and a=a and p=p])
    apply(case_tac "l4_ports_compress (getPos spts)")
       apply(simp)
       apply(drule raw_ports_compress_src_CannotMatch[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
       apply(simp add: noNeg_mapNegPos_helper; fail)
      apply(simp)
      apply(drule raw_ports_compress_MatchesAll[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
      apply(simp add: noNeg_mapNegPos_helper; fail)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(drule raw_ports_compress_src_MatchExpr[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
     apply(insert singletonize_L4Ports_src[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
     apply(simp add: match_list_matches)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(simp add: noNeg_mapNegPos_helper; fail)
    done

  (*copy & paste, TODO generalize*)
  lemma normalize_positive_dst_ports:
    assumes generic: "primitive_matcher_generic \<beta>"
    and n: "normalized_nnf_match m"
    and noneg: "\<not> has_disc_negated is_Dst_Ports False m"
    shows "match_list (\<beta>, \<alpha>) (normalize_positive_dst_ports m) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) m a p"
    apply(simp add: normalize_positive_dst_ports_def normalize_positive_ports_step_def)
    apply(case_tac "primitive_extractor (is_Dst_Ports, dst_ports_sel) m", rename_tac spts rst)
    apply(simp)
    apply(subgoal_tac "getNeg spts = []") (*needs assumption for this step *)
     prefer 2 subgoal
     apply(drule primitive_extractor_correct(8)[OF n wf_disc_sel_common_primitive(2)])
      using noneg by simp+
    apply(simp)
    apply(drule primitive_extractor_correct(1)[OF n wf_disc_sel_common_primitive(2), where \<gamma>="(\<beta>, \<alpha>)" and a=a and p=p])
    apply(case_tac "l4_ports_compress (getPos spts)")
       apply(simp)
       apply(drule raw_ports_compress_dst_CannotMatch[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
       apply(simp add: noNeg_mapNegPos_helper; fail)
      apply(simp)
      apply(drule raw_ports_compress_MatchesAll(2)[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
      apply(simp add: noNeg_mapNegPos_helper; fail)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(drule raw_ports_compress_dst_MatchExpr[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
     apply(insert singletonize_L4Ports_dst[OF generic, where \<alpha>=\<alpha> and a=a and p=p])
     apply(simp add: match_list_matches)
     apply(simp add: bunch_of_lemmata_about_matches)
     apply(simp add: noNeg_mapNegPos_helper; fail)
    done

  lemma normalize_positive_src_ports_nnf:
    assumes n: "normalized_nnf_match m"
    and noneg: "\<not> has_disc_negated is_Src_Ports False m"
    shows "m' \<in> set (normalize_positive_src_ports m) \<Longrightarrow> normalized_nnf_match m'"
    apply(rule normalize_positive_ports_step_nnf[OF n wf_disc_sel_common_primitive(1) noneg])
    by(simp add: normalize_positive_src_ports_def)
  lemma normalize_positive_dst_ports_nnf:
    assumes n: "normalized_nnf_match m"
    and noneg: "\<not> has_disc_negated is_Dst_Ports False m"
    shows "m' \<in> set (normalize_positive_dst_ports m) \<Longrightarrow> normalized_nnf_match m'"
    apply(rule normalize_positive_ports_step_nnf[OF n wf_disc_sel_common_primitive(2) noneg])
    by(simp add: normalize_positive_dst_ports_def)

  lemma normalize_positive_src_ports_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
    and noneg: "\<not> has_disc_negated is_Src_Ports False m"
    shows "\<forall>m' \<in> set (normalize_positive_src_ports m). normalized_src_ports m'"
    unfolding normalized_src_ports_def2
    unfolding normalize_positive_src_ports_def
    using normalize_positive_ports_step_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1) noneg] by blast

  lemma normalize_positive_dst_ports_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
    and noneg: "\<not> has_disc_negated is_Dst_Ports False m"
    shows "\<forall>m' \<in> set (normalize_positive_dst_ports m). normalized_dst_ports m'"
    unfolding normalized_dst_ports_def2
    unfolding normalize_positive_dst_ports_def
    using normalize_positive_ports_step_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2) noneg] by blast

subsection\<open>Complete Normalization\<close>

  definition normalize_ports_generic
    :: "('i common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list) \<Rightarrow>
        ('i common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr) \<Rightarrow>
       'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list"
  where
    "normalize_ports_generic normalize_pos rewrite_neg m = concat (map normalize_pos (normalize_match (rewrite_neg m)))"

  lemma normalize_ports_generic_nnf:
    assumes n: "normalized_nnf_match m"
    and inset: "m' \<in> set (normalize_ports_generic normalize_pos rewrite_neg m)"
    and noNeg: "\<not> has_disc_negated disc False (rewrite_neg m)"
    and normalize_nnf_pos: "\<And>m m'.
        normalized_nnf_match  m \<Longrightarrow> \<not> has_disc_negated disc False m \<Longrightarrow>
          m' \<in> set (normalize_pos m) \<Longrightarrow> normalized_nnf_match m'"
    shows "normalized_nnf_match m'"
    using inset apply(simp add: normalize_ports_generic_def)
    apply(elim bexE, rename_tac a)
    apply(subgoal_tac "normalized_nnf_match a")
     prefer 2
     using normalized_nnf_match_normalize_match apply blast
    apply(erule normalize_nnf_pos, simp_all)
    apply(rule not_has_disc_normalize_match)
     using noNeg n by blast+

  lemma normalize_ports_generic:
    assumes n: "normalized_nnf_match m"
    and normalize_pos: "\<And>m. normalized_nnf_match m \<Longrightarrow> \<not> has_disc_negated disc False m \<Longrightarrow>
                          match_list \<gamma> (normalize_pos m) a p \<longleftrightarrow> matches \<gamma> m a p"
    and rewrite_neg: "\<And>m. normalized_nnf_match m \<Longrightarrow>
                          matches \<gamma> (rewrite_neg m) a p = matches \<gamma> m a p"
    and noNeg: "\<And>m. normalized_nnf_match m \<Longrightarrow> \<not> has_disc_negated disc False (rewrite_neg m)"
    shows
        "match_list \<gamma> (normalize_ports_generic normalize_pos rewrite_neg m) a p \<longleftrightarrow> matches \<gamma> m a p"
    unfolding normalize_ports_generic_def
    proof
      have 1: "ls \<in> set (normalize_match (rewrite_neg m)) \<Longrightarrow>
          match_list \<gamma> (normalize_pos ls) a p \<Longrightarrow> normalized_nnf_match ls \<Longrightarrow> matches \<gamma> m a p"
      for ls
      apply(subst(asm) normalize_pos)
        subgoal using normalized_nnf_match_normalize_match by blast
       subgoal apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
        using noNeg n apply blast
       by blast
      apply(subgoal_tac "matches \<gamma> (rewrite_neg m) a p")
       using rewrite_neg[OF n] apply blast
      using in_normalized_matches[where \<gamma>=\<gamma> and a=a and p=p] by blast

      show "match_list \<gamma> (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p \<Longrightarrow> matches \<gamma> m a p"
      apply(simp add: match_list_concat)
      apply(clarify, rename_tac ls)
      apply(subgoal_tac "normalized_nnf_match ls")
       using 1 apply(simp; fail)
      using normalized_nnf_match_normalize_match by blast
    next
      have 1: "ls \<in> set (normalize_match (rewrite_neg m)) \<Longrightarrow>
          matches \<gamma> ls a p \<Longrightarrow>
          normalized_nnf_match ls \<Longrightarrow>
          match_list \<gamma> (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p" for ls
       apply(simp add: match_list_concat)
       apply(rule_tac x=ls in bexI)
        prefer 2 apply(simp; fail)
       apply(subst normalize_pos)
         apply(simp_all)
       apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
        using noNeg n apply blast
       by blast
      show "matches \<gamma> m a p \<Longrightarrow> match_list \<gamma> (concat (map normalize_pos (normalize_match (rewrite_neg m)))) a p"
       apply(subst(asm) rewrite_neg[OF n, symmetric])
       apply(subst(asm) matches_to_match_list_normalize)
       apply(subst(asm) match_list_matches)
       apply(elim bexE, rename_tac ls)
       apply(subgoal_tac "normalized_nnf_match ls")
        using 1 apply blast
       using normalized_nnf_match_normalize_match by blast
    qed

  lemma normalize_ports_generic_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"  and wf_disc_sel: "wf_disc_sel (disc,sel) C"
    and noNeg: "\<And>m. normalized_nnf_match m \<Longrightarrow> \<not> has_disc_negated disc False (rewrite_neg m)"
    and normalize_nnf_pos: "\<And>m m'.
        normalized_nnf_match  m \<Longrightarrow> \<not> has_disc_negated disc False m \<Longrightarrow>
          m' \<in> set (normalize_pos m) \<Longrightarrow> normalized_nnf_match m'"
    and normalize_pos: "\<And>m m'.
        normalized_nnf_match m \<Longrightarrow>  \<not> has_disc_negated disc False m \<Longrightarrow>
          \<forall>m'\<in>set (normalize_pos m).
                 normalized_n_primitive (disc,sel) (\<lambda>ps. case ps of L4Ports _ pts \<Rightarrow> length pts \<le> 1) m'"
    shows "\<forall>m' \<in> set (normalize_ports_generic normalize_pos rewrite_neg m).
             normalized_n_primitive (disc,sel) (\<lambda>ps. case ps of L4Ports _ pts \<Rightarrow> length pts \<le> 1) m'"
  unfolding normalize_ports_generic_def
  apply(intro ballI, rename_tac m')
  apply(simp)
  apply(elim bexE, rename_tac a)
  apply(subgoal_tac "normalized_nnf_match a")
   prefer 2
   using normalized_nnf_match_normalize_match apply blast
  apply(subgoal_tac "\<not> has_disc_negated disc False a")
   prefer 2
   subgoal for ls (*TODO: same is already above!*)
    apply(rule_tac m="rewrite_neg m" in not_has_disc_normalize_match)
     using noNeg n apply blast
    by blast
  apply(subgoal_tac "normalized_nnf_match m'")
   prefer 2
   using normalize_nnf_pos apply blast
  using normalize_pos by blast

  lemma normalize_ports_generic_normalize_positive_ports_step_erule:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "\<forall>a. \<not> disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and P: "P (disc2, sel2) m"
      and P1: "\<And>a. normalized_nnf_match a \<Longrightarrow>
                a \<in> set (normalize_match (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m)) \<Longrightarrow>
                P (disc2, sel2) a"
      and P2: "\<And>a dpts rst. normalized_nnf_match a \<Longrightarrow>
                    primitive_extractor (disc, sel) a = (dpts, rst) \<Longrightarrow>
                    getNeg dpts = [] \<Longrightarrow> P (disc2, sel2) a \<Longrightarrow> P (disc2, sel2) rst"
      and P3: "\<And> a spt rst. P (disc2, sel2) rst \<Longrightarrow> P (disc2, sel2) (MatchAnd (Match (C spt)) rst)"
    shows "m' \<in> set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m) \<Longrightarrow>
          P (disc2, sel2) m'"
    using P apply(simp add: normalize_ports_generic_def)
    apply(elim bexE, rename_tac a)
    apply(subgoal_tac "normalized_nnf_match a")
     prefer 2 using normalized_nnf_match_normalize_match apply blast
    apply(simp add: normalize_positive_ports_step_def)
    apply(elim exE conjE, rename_tac rst dpts)
    apply(drule sym) (*primitive extractor*)
    apply(subgoal_tac "getNeg dpts = []")
     prefer 2 subgoal for a rst dpts
     apply(erule iffD1[OF primitive_extractor_correct(8)[OF _ wf_disc_sel]])
      apply(simp; fail)
     apply(rule not_has_disc_normalize_match)
      apply(simp_all)
     apply(rule rewrite_negated_primitives_not_has_disc_negated[OF n wf_disc_sel])
     apply(intro allI)
     apply(rule l4_ports_negate_one_not_has_disc_negated_generic)
     by(simp add: noProt)
    apply(subgoal_tac "P (disc2, sel2) a")
     prefer 2 subgoal
     apply(rule P1)
     by(simp)
    apply(frule_tac a=a in P2)
      apply blast+
    apply(simp split: match_compress.split_asm)
    using P3 by auto

  (*disc is is_Src_Ports or is_Dst_Ports*)
  lemma normalize_ports_generic_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "\<forall>a. \<not> disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and disc2_noC: "\<forall>a. \<not> disc2 (C a)"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated disc False m"
    shows "m' \<in> set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m) \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f m \<Longrightarrow>
          normalized_n_primitive (disc2, sel2) f m'"
    thm normalize_ports_generic_normalize_positive_ports_step_erule
    apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
        apply(simp_all add: disc2_noC disc2_noProt)
     apply(rule rewrite_negated_primitives_normalized_preserves_unrelated_helper[OF wf_disc_sel _ _ n])
        apply(simp_all add: disc2_noC disc2_noProt)
    thm primitive_extractor_correct(5)[OF _ wf_disc_sel, where P=f]
    apply(frule_tac m=a in primitive_extractor_correct(5)[OF _ wf_disc_sel, where P=f])
     by blast+

  lemma normalize_ports_generic_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" and nodisc: "\<not> has_disc disc2 m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "\<forall>a. \<not> disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and disc2_noC: "\<forall>a. \<not> disc2 (C a)"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated disc False m"
     shows "m'\<in> set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m)
      \<Longrightarrow> \<not> has_disc disc2 m'"
    apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
        apply(simp_all add: disc2_noC disc2_noProt nodisc)
     subgoal for a
     thm normalize_match_preserves_nodisc
     apply(rule_tac m="rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m" in normalize_match_preserves_nodisc)
      apply(simp_all)
     apply(insert disc2_noProt)
     apply(elim disjE)
      thm rewrite_negated_primitives_not_has_disc[of _ disc2]
      subgoal apply(rule rewrite_negated_primitives_not_has_disc[OF n wf_disc_sel nodisc _ disc2_noC])
      using l4_ports_negate_one_nodisc[OF disc2_noC] by blast
     using rewrite_negated_primitives_preserves_not_has_disc[OF n wf_disc_sel nodisc _ disc2_noC] by blast
    apply(frule_tac m=a in primitive_extractor_correct(4)[OF _ wf_disc_sel])
     by blast+

  lemma normalize_ports_generic_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" and nodisc: "\<not> has_disc_negated disc2 False m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and noProt: "\<forall>a. \<not> disc (Prot a)" (*disc is src_ports or dst_ports anyway*)
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated disc False m"
     shows "m'\<in> set (normalize_ports_generic (normalize_positive_ports_step (disc, sel) C) (rewrite_negated_primitives (disc, sel) C l4_ports_negate_one) m)
      \<Longrightarrow> \<not> has_disc_negated disc2 False m'"
    apply(rule normalize_ports_generic_normalize_positive_ports_step_erule[OF n wf_disc_sel noProt])
        apply(simp_all add: disc2_noProt nodisc)
     subgoal for a
     apply(rule_tac m="rewrite_negated_primitives (disc, sel) C l4_ports_negate_one m" in not_has_disc_normalize_match)
      apply(simp_all)
     thm rewrite_negated_primitives_preserves_not_has_disc_negated[OF n wf_disc_sel ]
     apply(rule rewrite_negated_primitives_preserves_not_has_disc_negated[OF n wf_disc_sel ])
      using disc2_noProt l4_ports_negate_one_not_has_disc_negated_generic apply blast
     using nodisc by blast
    subgoal for a dpts rst
    apply(frule_tac m=a and as=dpts and ms=rst and neg=False in primitive_extractor_correct(6)[OF _ wf_disc_sel])
     by blast+
   done

  definition normalize_src_ports
    :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list"
  where
    "normalize_src_ports m = normalize_ports_generic normalize_positive_src_ports rewrite_negated_src_ports m"

  definition normalize_dst_ports
    :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list"
  where
    "normalize_dst_ports m = normalize_ports_generic normalize_positive_dst_ports rewrite_negated_dst_ports m"

  lemma normalize_src_ports:
    assumes generic: "primitive_matcher_generic \<beta>"
    and n: "normalized_nnf_match m"
    shows "match_list (\<beta>, \<alpha>) (normalize_src_ports m) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) m a p"
     apply(simp add: normalize_src_ports_def)
     apply(rule normalize_ports_generic[OF n])
       using normalize_positive_src_ports[OF generic]
             rewrite_negated_src_ports[OF generic, where \<alpha>=\<alpha> and a=a and p=p]
             rewrite_negated_src_ports_not_has_disc_negated by blast+

  lemma normalize_dst_ports:
    assumes generic: "primitive_matcher_generic \<beta>"
    and n: "normalized_nnf_match m"
    shows "match_list (\<beta>, \<alpha>) (normalize_dst_ports m) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) m a p"
     apply(simp add: normalize_dst_ports_def)
     apply(rule normalize_ports_generic[OF n])
       using normalize_positive_dst_ports[OF generic]
             rewrite_negated_dst_ports[OF generic, where \<alpha>=\<alpha> and a=a and p=p]
             rewrite_negated_dst_ports_not_has_disc_negated by blast+

  lemma normalize_src_ports_normalized_n_primitive:
    assumes n:"normalized_nnf_match m"
    shows "\<forall>m' \<in> set (normalize_src_ports m). normalized_src_ports m'"
  unfolding normalize_src_ports_def normalized_src_ports_def2
  apply(rule normalize_ports_generic_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1)])
    using rewrite_negated_src_ports_not_has_disc_negated apply blast
   using normalize_positive_src_ports_nnf apply blast
  unfolding normalized_src_ports_def2[symmetric]
  using normalize_positive_src_ports_normalized_n_primitive by blast

  lemma normalize_dst_ports_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
    shows "\<forall>m' \<in> set (normalize_dst_ports m). normalized_dst_ports m'"
  unfolding normalize_dst_ports_def normalized_dst_ports_def2
  apply(rule normalize_ports_generic_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2)])
    using rewrite_negated_dst_ports_not_has_disc_negated apply blast
   using normalize_positive_dst_ports_nnf apply blast
  unfolding normalized_dst_ports_def2[symmetric]
  using normalize_positive_dst_ports_normalized_n_primitive by blast

  lemma normalize_src_ports_nnf:
    assumes n: "normalized_nnf_match m"
    shows "m' \<in> set (normalize_src_ports m) \<Longrightarrow> normalized_nnf_match m'"
    apply(simp add: normalize_src_ports_def)
    apply(erule normalize_ports_generic_nnf[OF n])
     using n rewrite_negated_src_ports_not_has_disc_negated apply blast
    using normalize_positive_src_ports_nnf by blast

  lemma normalize_dst_ports_nnf:
    assumes n: "normalized_nnf_match m"
    shows "m' \<in> set (normalize_dst_ports m) \<Longrightarrow> normalized_nnf_match m'"
    apply(simp add: normalize_dst_ports_def)
    apply(erule normalize_ports_generic_nnf[OF n])
     using n rewrite_negated_dst_ports_not_has_disc_negated apply blast
    using normalize_positive_dst_ports_nnf by blast

  lemma normalize_src_ports_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and disc2_noC: "\<forall>a. \<not> disc2 (Src_Ports a)"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated is_Src_Ports False m"
    shows "m' \<in> set (normalize_src_ports m) \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f  m \<Longrightarrow>
          normalized_n_primitive (disc2, sel2) f m'"
      apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF n wf_disc_sel_common_primitive(1)])
      by(simp_all add: disc2_noC disc2_noProt normalize_src_ports_def normalize_ports_generic_def
                normalize_positive_src_ports_def rewrite_negated_src_ports_def)

  lemma normalize_dst_ports_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and disc2_noC: "\<forall>a. \<not> disc2 (Dst_Ports a)"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated is_Dst_Ports False m"
    shows "m' \<in> set (normalize_dst_ports m) \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f  m \<Longrightarrow>
          normalized_n_primitive (disc2, sel2) f m'"
      apply(rule normalize_ports_generic_preserves_normalized_n_primitive[OF n wf_disc_sel_common_primitive(2)])
      by(simp_all add: disc2_noC disc2_noProt normalize_dst_ports_def normalize_ports_generic_def
                normalize_positive_dst_ports_def rewrite_negated_dst_ports_def)

  lemma normalize_src_ports_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" and nodisc: "\<not> has_disc disc2 m"
      and disc2_noC: "\<forall>a. \<not> disc2 (Src_Ports a)"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated is_Src_Ports False m"
     shows "m'\<in> set (normalize_src_ports m)
      \<Longrightarrow> \<not> has_disc disc2 m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc[OF n nodisc wf_disc_sel_common_primitive(1)])
      apply(simp add: disc2_noC disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_src_ports_def normalize_src_ports_def rewrite_negated_src_ports_def)

  lemma normalize_dst_ports_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m" and nodisc: "\<not> has_disc disc2 m"
      and disc2_noC: "\<forall>a. \<not> disc2 (Dst_Ports a)"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated is_Dst_Ports False m"
     shows "m'\<in> set (normalize_dst_ports m)
      \<Longrightarrow> \<not> has_disc disc2 m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc[OF n nodisc wf_disc_sel_common_primitive(2)])
      apply(simp add: disc2_noC disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_dst_ports_def normalize_dst_ports_def rewrite_negated_dst_ports_def)

  lemma normalize_src_ports_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" and nodisc: "\<not> has_disc_negated disc2 False m"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated is_Src_Ports False m"
     shows "m'\<in> set (normalize_src_ports m)
      \<Longrightarrow> \<not> has_disc_negated disc2 False m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc_negated[OF n nodisc wf_disc_sel_common_primitive(1)])
      apply(simp add: disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_src_ports_def normalize_src_ports_def rewrite_negated_src_ports_def)

  lemma normalize_dst_ports_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m" and nodisc: "\<not> has_disc_negated disc2 False m"
      and disc2_noProt: "(\<forall>a. \<not> disc2 (Prot a)) \<or> \<not> has_disc_negated is_Dst_Ports False m"
     shows "m'\<in> set (normalize_dst_ports m)
      \<Longrightarrow> \<not> has_disc_negated disc2 False m'"
  apply(rule normalize_ports_generic_preserves_normalized_not_has_disc_negated[OF n nodisc wf_disc_sel_common_primitive(2)])
      apply(simp add: disc2_noProt)+
  by (simp add: normalize_ports_generic_def normalize_positive_dst_ports_def normalize_dst_ports_def rewrite_negated_dst_ports_def)

value[code] "normalize_src_ports
                (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))"

lemma "map opt_MatchAny_match_expr (normalize_src_ports
                (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto TCP)))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))) =
 [MatchAnd (MatchNot (Match (Prot (Proto UDP)))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP)))),
  MatchAnd (Match (Src_Ports (L4Ports UDP [(0, 79)]))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP)))),
  MatchAnd (Match (Src_Ports (L4Ports UDP [(81, 0xFFFF)]))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto TCP))))]" by eval

lemma "map opt_MatchAny_match_expr (normalize_src_ports
                (MatchAnd (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (127, 0, 0, 0)) 8)))
                   (MatchAnd (Match (Prot (Proto ICMP)))
                     (MatchAnd (Match (Src_Ports (L4Ports TCP [(22,22)])))
                        (MatchNot (Match (Src_Ports (L4Ports UDP [(80,80)]))))
                 ))))
 =
[MatchAnd (Match (Src_Ports (L4Ports TCP [(22, 22)])))
   (MatchAnd (MatchNot (Match (Prot (Proto UDP)))) (MatchAnd (Match (Dst (IpAddrNetmask 0x7F000000 8))) (Match (Prot (Proto ICMP)))))]" by eval

lemma "map opt_MatchAny_match_expr (normalize_src_ports
                (MatchAnd (Match ((Src_Ports (L4Ports UDP [(21,21), (22,22)])) :: 32 common_primitive))
                  (Match (Prot (Proto UDP)))))
  =
[MatchAnd (Match (Src_Ports (L4Ports UDP [(21, 22)]))) (Match (Prot (Proto UDP)))]" by eval

lemma "normalize_match (andfold_MatchExp (map (l4_ports_negate_one C) [])) = [MatchAny]" by(simp)

(*scratch*)
(*TODO: move?*)
  (*TODO: add nnf_normalization directly afterwards?*)
  definition replace_primitive_matchexpr
    :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> (*disc_sel*)
        ('b negation_type \<Rightarrow> 'a match_expr) \<Rightarrow> (*replace function*)
        'a match_expr \<Rightarrow> 'a match_expr" where
    "replace_primitive_matchexpr disc_sel replace_f m \<equiv>
        let (as, rst) = primitive_extractor disc_sel m
        in if as = [] then m else
          MatchAnd
            (andfold_MatchExp (map replace_f as))
            rst"

  text\<open>It does nothing of there is not even a primitive in it\<close>
  lemma replace_primitive_matchexpr_unchanged_if_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc,sel) C" (*any C*)
  and noDisc: "\<not> has_disc disc m"
  shows "replace_primitive_matchexpr (disc,sel) replace_f m = m"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
     using noDisc by blast+

  (*lemma replace_primitive_matchexpr_preserves_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and wf_disc_sel: "wf_disc_sel (disc, sel) C'"
  and nodisc: "\<not> has_disc disc2 m"
  and noNeg: "\<not> has_disc disc m"
  and disc2_noC: "\<forall>a. \<not> disc2 (C a)"
  shows "\<not> has_disc disc2 (replace_primitive_matchexpr (disc, sel) negate_f m)"
    apply(subst replace_primitive_matchexpr_unchanged_if_not_has_disc)
    using n wf_disc_sel noNeg nodisc by(simp)+*)

  lemma replace_primitive_matchexpr:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel disc_sel C"
  and replace_f: "\<forall>pt. matches \<gamma> (replace_f pt) a p \<longleftrightarrow>
                        matches \<gamma> (negation_type_to_match_expr_f C pt) a p"
  shows "matches \<gamma> (replace_primitive_matchexpr disc_sel replace_f m) a p \<longleftrightarrow> matches \<gamma> m a p"
  proof -
    obtain spts rst where pext: "primitive_extractor disc_sel m = (spts, rst)"
      by(cases "primitive_extractor disc_sel m") simp
    obtain disc sel where disc_sel: "disc_sel = (disc, sel)" by(cases disc_sel) simp
    with wf_disc_sel have wf_disc_sel': "wf_disc_sel (disc, sel) C" by simp
    from disc_sel pext have pext': "primitive_extractor (disc, sel) m = (spts, rst)" by simp

    have "matches \<gamma> (andfold_MatchExp (map replace_f spts)) a p \<and> matches \<gamma> rst a p \<longleftrightarrow>
       matches \<gamma> m a p"
      apply(subst primitive_extractor_correct(1)[OF n wf_disc_sel' pext', symmetric])
      apply(simp add: andfold_MatchExp_matches)
      apply(simp add: replace_f)
      using alist_and_negation_type_to_match_expr_f_matches by fast
    thus ?thesis by(simp add: replace_primitive_matchexpr_def pext bunch_of_lemmata_about_matches)
  qed

  lemma replace_primitive_matchexpr_replaces_disc:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc, sel) C"
  and replace_f: "\<forall>a. \<not> has_disc disc (replace_f a)"
  shows "\<not> has_disc disc (replace_primitive_matchexpr (disc, sel) replace_f m)"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(3)[OF n wf_disc_sel])
    apply simp
    apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
    apply simp
    apply(case_tac "\<not> has_disc disc m")
     apply(simp)
    apply(simp)
    apply(frule(1) primitive_extractor_correct(9)[OF n wf_disc_sel])
    apply(simp)
    apply(rule MatchExpr_Fold.andfold_MatchExp_not_discI)
    using replace_f by simp

  lemma replace_primitive_matchexpr_preserves_not_has_disc:
  assumes n: "normalized_nnf_match m" and wf_disc_sel: "wf_disc_sel (disc,sel) C"
  and nodisc: "\<not> has_disc disc2 m"
  and replace_f: "has_disc disc m \<Longrightarrow> \<forall>pts. \<not> has_disc disc2 (replace_f pts)"
  shows "\<not> has_disc disc2 (replace_primitive_matchexpr (disc,sel) replace_f m)"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc,sel) m", rename_tac spts rst)
    apply(simp)
    apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
    apply(case_tac "\<not> has_disc disc m")
     subgoal
     apply(frule primitive_extractor_correct(7)[OF n wf_disc_sel])
     using nodisc by blast
    apply(simp)
    apply(intro conjI impI)
      using nodisc apply(simp; fail)
     apply(rule andfold_MatchExp_not_discI)
     apply(simp add: replace_f; fail)
    using nodisc by blast

  lemma normalize_replace_primitive_matchexpr_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and replace_f:
        "\<And>a m'. m' \<in> set (normalize_match (replace_f a)) \<Longrightarrow> normalized_n_primitive (disc2, sel2) f m'"
      and nprim: "normalized_n_primitive (disc2, sel2) f m"
      and m': "m' \<in> set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))"
    shows "normalized_n_primitive (disc2, sel2) f m'"
  proof -
    have x: "x \<in> set (normalize_match (andfold_MatchExp (map replace_f as))) \<Longrightarrow>
          normalized_n_primitive (disc2, sel2) f x" for x as
      apply(rule normalize_andfold_MatchExp_normalized_n_primitive )
       apply(simp_all)
      using replace_f by blast
    from m' show ?thesis
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
    apply(simp split: if_split_asm)
     using normalize_match_preserves_normalized_n_primitive nprim apply blast
    apply(frule_tac P=f in primitive_extractor_correct(5)[OF n wf_disc_sel])
    apply(clarify)
    apply(simp)
    apply(intro conjI)
     prefer 2
     using normalize_match_preserves_normalized_n_primitive nprim apply blast
    by(simp add: x)
  qed

  lemma normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and nodisc: "\<not> has_disc disc2 m"
      and replace_f: "\<And>a. \<not> has_disc disc2 (replace_f a)"
     shows "m'\<in> set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))
      \<Longrightarrow> \<not> has_disc disc2 m'"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
    apply(simp split: if_split_asm)
     using nodisc normalize_match_preserves_nodisc apply blast
    apply(frule primitive_extractor_correct(4)[OF n wf_disc_sel])
    apply(elim bexE, rename_tac x)
    apply(erule Set.imageE, rename_tac xright) (*m' = MatchAnd x xright*)
    apply(simp)
    apply(intro conjI)
     apply(rule normalize_match_preserves_nodisc, simp_all)
     apply(rule andfold_MatchExp_not_discI, simp)
     using replace_f apply blast
    apply(rule normalize_match_preserves_nodisc)
     apply(insert nodisc)
     by(simp_all)

  lemma normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m"
      and wf_disc_sel: "wf_disc_sel (disc, sel) C"
      and nodisc: "\<not> has_disc_negated disc2 neg m"
      and replace_f: "\<And>a. \<not> has_disc_negated disc2 neg (replace_f a)"
     shows "m'\<in> set (normalize_match (replace_primitive_matchexpr (disc,sel) replace_f m))
      \<Longrightarrow> \<not> has_disc_negated disc2 neg m'"
    apply(simp add: replace_primitive_matchexpr_def)
    apply(case_tac "primitive_extractor (disc, sel) m", rename_tac as rst)
    apply(simp split: if_split_asm)
     using nodisc not_has_disc_normalize_match apply blast
    apply(frule primitive_extractor_correct(6)[OF n wf_disc_sel, where neg=neg])
    apply(elim bexE, rename_tac x)
    apply(erule Set.imageE, rename_tac xright) (*m' = MatchAnd x xright*)
    apply(simp)
    apply(intro conjI)
     apply(rule not_has_disc_normalize_match, simp_all)
     apply(rule andfold_MatchExp_not_disc_negatedI, simp)
     using replace_f apply blast
    apply(rule not_has_disc_normalize_match)
     apply(insert nodisc)
     by(simp_all)

  corollary normalize_replace_primitive_matchexpr:
    assumes n: "normalized_nnf_match m"
    and replace_f:
      "\<And>m. normalized_nnf_match m \<Longrightarrow>
      matches \<gamma> (replace_primitive_matchexpr disc_sel replace_f m) a p \<longleftrightarrow> matches \<gamma> m a p"
    shows
        "match_list \<gamma> (normalize_match (replace_primitive_matchexpr disc_sel replace_f m)) a p \<longleftrightarrow>
          matches \<gamma> m a p"
     by(simp add: matches_to_match_list_normalize[symmetric] replace_f n)

  fun rewrite_MultiportPorts_one
    :: "ipt_l4_ports negation_type\<Rightarrow> 'i::len common_primitive match_expr" where
    "rewrite_MultiportPorts_one (Pos pts) =
        MatchOr (Match (Src_Ports pts)) (Match (Dst_Ports pts))" |
    "rewrite_MultiportPorts_one (Neg pts) =
        MatchAnd (MatchNot (Match (Src_Ports pts))) (MatchNot (Match (Dst_Ports pts)))"

  lemma rewrite_MultiportPorts_one:
  assumes generic: "primitive_matcher_generic \<beta>" and n: "normalized_nnf_match m"
  shows
    "matches (\<beta>, \<alpha>) (replace_primitive_matchexpr (is_MultiportPorts, multiportports_sel) rewrite_MultiportPorts_one m) a p \<longleftrightarrow>
      matches (\<beta>, \<alpha>) m a p"
    apply(rule replace_primitive_matchexpr[OF n wf_disc_sel_common_primitive(11)])
    apply(rule allI, rename_tac pt)
    apply(case_tac pt)
     apply(simp add: primitive_matcher_generic.MultiportPorts_single_rewrite_MatchOr[OF generic]; fail)
    apply(simp add: primitive_matcher_generic.MultiportPorts_single_not_rewrite_MatchAnd[OF generic]; fail)
    done

  lemma "\<forall>a. \<not> disc (Src_Ports a) \<Longrightarrow> \<forall>a. \<not> disc (Dst_Ports a) \<Longrightarrow>
          normalized_n_primitive (disc, sel) f m \<Longrightarrow>
         \<forall>m' \<in> set (normalize_match (rewrite_MultiportPorts_one a)).
            normalized_n_primitive (disc, sel) f m'"
    apply(cases a)
     by(simp_all add: MatchOr_def)

  lemma rewrite_MultiportPorts_one_nodisc:
    "\<forall>a. \<not> disc (Src_Ports a) \<Longrightarrow> \<forall>a. \<not> disc (Dst_Ports a) \<Longrightarrow>
          \<not> has_disc disc (rewrite_MultiportPorts_one a)"
    "\<forall>a. \<not> disc (Src_Ports a) \<Longrightarrow> \<forall>a. \<not> disc (Dst_Ports a) \<Longrightarrow>
          \<not> has_disc_negated disc neg (rewrite_MultiportPorts_one a)"
    by(cases a, simp_all add: MatchOr_def)+

  definition rewrite_MultiportPorts
    :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list" where
    "rewrite_MultiportPorts m \<equiv> normalize_match
        (replace_primitive_matchexpr (is_MultiportPorts, multiportports_sel) rewrite_MultiportPorts_one m)"

  lemma rewrite_MultiportPorts:
    assumes generic: "primitive_matcher_generic \<beta>"
    and n: "normalized_nnf_match m"
    shows
        "match_list (\<beta>, \<alpha>) (rewrite_MultiportPorts m) a p \<longleftrightarrow> matches (\<beta>, \<alpha>) m a p"
    unfolding rewrite_MultiportPorts_def
    apply(intro normalize_replace_primitive_matchexpr[OF n])
    by(simp add: rewrite_MultiportPorts_one[OF generic])

  lemma rewrite_MultiportPorts_normalized_nnf_match:
      "m' \<in> set (rewrite_MultiportPorts m) \<Longrightarrow> normalized_nnf_match m'"
    apply(simp add: rewrite_MultiportPorts_def)
    using normalized_nnf_match_normalize_match by blast

  text\<open>It does nothing of there is not even the primitive in it\<close>
  lemma rewrite_MultiportPorts_unchanged_if_not_has_disc:
  assumes n: "normalized_nnf_match m"
  and noDisc: "\<not> has_disc is_MultiportPorts m"
  shows "rewrite_MultiportPorts m = [m]"
    apply(simp add: rewrite_MultiportPorts_def)
    apply(subst replace_primitive_matchexpr_unchanged_if_not_has_disc[OF n
            wf_disc_sel_common_primitive(11) noDisc])
    using n by(fact normalize_match_already_normalized)

  lemma rewrite_MultiportPorts_preserves_normalized_n_primitive:
    assumes n: "normalized_nnf_match m"
      and disc2_noSrcPorts: "\<forall>a. \<not> disc2 (Src_Ports a)"
      and disc2_noDstPorts: "\<forall>a. \<not> disc2 (Dst_Ports a)"
    shows "m' \<in> set (rewrite_MultiportPorts m) \<Longrightarrow>
         normalized_n_primitive (disc2, sel2) f  m \<Longrightarrow>
          normalized_n_primitive (disc2, sel2) f m'"
      unfolding rewrite_MultiportPorts_def
      apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_n_primitive[OF
                  n wf_disc_sel_common_primitive(11)])
        apply simp_all
      apply(rename_tac a a')
      apply(case_tac a)
       apply(simp_all add: MatchOr_def)
       using disc2_noSrcPorts disc2_noDstPorts by fastforce+

  lemma rewrite_MultiportPorts_preserves_normalized_not_has_disc:
    assumes n: "normalized_nnf_match m"
      and nodisc: "\<not> has_disc disc2 m"
      and disc2_noSrcPorts: "\<forall>a. \<not> disc2 (Src_Ports a)"
      and disc2_noDstPorts: "\<forall>a. \<not> disc2 (Dst_Ports a)"
     shows "m'\<in> set (rewrite_MultiportPorts m)
      \<Longrightarrow> \<not> has_disc disc2 m'"
  apply(simp add: rewrite_MultiportPorts_def)
  apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc[OF n wf_disc_sel_common_primitive(11) nodisc])
   by(simp_all add: rewrite_MultiportPorts_one_nodisc disc2_noSrcPorts disc2_noDstPorts)

  lemma rewrite_MultiportPorts_preserves_normalized_not_has_disc_negated:
    assumes n: "normalized_nnf_match m"
      and nodisc: "\<not> has_disc_negated disc2 neg m"
      and disc2_noSrcPorts: "\<forall>a. \<not> disc2 (Src_Ports a)"
      and disc2_noDstPorts: "\<forall>a. \<not> disc2 (Dst_Ports a)"
     shows "m'\<in> set (rewrite_MultiportPorts m)
      \<Longrightarrow> \<not> has_disc_negated disc2 neg m'"
  apply(simp add: rewrite_MultiportPorts_def)
  apply(rule normalize_replace_primitive_matchexpr_preserves_normalized_not_has_disc_negated[OF n wf_disc_sel_common_primitive(11) nodisc])
   by(simp_all add: rewrite_MultiportPorts_one_nodisc disc2_noSrcPorts disc2_noDstPorts)

  lemma rewrite_MultiportPorts_removes_MultiportsPorts:
    assumes n: "normalized_nnf_match m"
    shows "m' \<in> set (rewrite_MultiportPorts m) \<Longrightarrow> \<not> has_disc is_MultiportPorts m'"
    apply(simp add: rewrite_MultiportPorts_def)
    apply(rule normalize_match_preserves_nodisc)
     apply(simp_all)
    apply(rule replace_primitive_matchexpr_replaces_disc[OF n wf_disc_sel_common_primitive(11)])
    apply(intro allI, rename_tac a)
    by(case_tac a, simp_all add: MatchOr_def)

end


section \<open>Nondeterministic Büchi Transition Automata Combinations\<close>

theory NBTA_Combine
imports NBTA NGBTA
begin

  global_interpretation degeneralization: automaton_degeneralization_run
    ngbta ngbta.alphabet ngbta.initial ngbta.transition ngbta.accepting "\<lambda> P w r p. gen infs P (p ## r ||| w ||| r)"
    nbta nbta.alphabet nbta.initial nbta.transition nbta.accepting "\<lambda> P w r p. infs P (p ## r ||| w ||| r)"
    id "\<lambda> ((p, k), a, (q, l)). ((p, a, q), k)"
    defines degeneralize = degeneralization.degeneralize
  proof
    fix w :: "'a stream"
    fix r :: "'b stream"
    fix cs p k
    let ?f = "\<lambda> ((p, k), a, (q, l)). ((p, a, q), k)"
    let ?s = "sscan (count cs \<circ> id) (p ## r ||| w ||| r) k"
    have "infs (degen cs \<circ> ?f) ((p, k) ## (r ||| ?s) ||| w ||| (r ||| ?s)) \<longleftrightarrow>
      infs (degen cs) (smap ?f ((p, k) ## (r ||| ?s) ||| w ||| (r ||| ?s)))"
      by (simp add: comp_def)
    also have "smap ?f ((p, k) ## (r ||| ?s) ||| w ||| (r ||| ?s)) = (p ## r ||| w ||| r) ||| k ## ?s"
      by (coinduction arbitrary: p k r w) (auto simp: eq_scons simp flip: szip_unfold sscan_scons)
    also have "\<dots> = (p ## r ||| w ||| r) ||| k ## sscan (count cs) (p ## r ||| w ||| r) k" by simp
    also have "infs (degen cs) \<dots> = gen infs cs (p ## r ||| w ||| r)" using degen_infs by this
    finally show "infs (degen cs \<circ> ?f) ((p, k) ## (r ||| ?s) ||| w ||| (r ||| ?s)) \<longleftrightarrow>
      gen infs cs (p ## r ||| w ||| r)" by this
  qed

  lemmas degeneralize_language[simp] = degeneralization.degeneralize_language[folded NBTA.language_def]
  lemmas degeneralize_nodes_finite[iff] = degeneralization.degeneralize_nodes_finite[folded NBTA.nodes_def]

  global_interpretation intersection: automaton_intersection_run
    nbta nbta.alphabet nbta.initial nbta.transition nbta.accepting "\<lambda> P w r p. infs P (p ## r ||| w ||| r)"
    nbta nbta.alphabet nbta.initial nbta.transition nbta.accepting "\<lambda> P w r p. infs P (p ## r ||| w ||| r)"
    ngbta ngbta.alphabet ngbta.initial ngbta.transition ngbta.accepting "\<lambda> P w r p. gen infs P (p ## r ||| w ||| r)"
    "\<lambda> c\<^sub>1 c\<^sub>2. [c\<^sub>1 \<circ> (\<lambda> ((p\<^sub>1, p\<^sub>2), a, (q\<^sub>1, q\<^sub>2)). (p\<^sub>1, a, q\<^sub>1)), c\<^sub>2 \<circ> (\<lambda> ((p\<^sub>1, p\<^sub>2), a, (q\<^sub>1, q\<^sub>2)). (p\<^sub>2, a, q\<^sub>2))]"
    defines intersect' = intersection.product
  proof
    fix w :: "'a stream"
    fix u :: "'b stream"
    fix v :: "'c stream"
    fix c\<^sub>1 c\<^sub>2 p q
    let ?tfst = "\<lambda> ((p\<^sub>1, p\<^sub>2), a, (q\<^sub>1, q\<^sub>2)). (p\<^sub>1, a, q\<^sub>1)"
    let ?tsnd = "\<lambda> ((p\<^sub>1, p\<^sub>2), a, (q\<^sub>1, q\<^sub>2)). (p\<^sub>2, a, q\<^sub>2)"
    have "gen infs [c\<^sub>1 \<circ> ?tfst, c\<^sub>2 \<circ> ?tsnd] ((p, q) ## (u ||| v) ||| w ||| u ||| v) \<longleftrightarrow>
      infs c\<^sub>1 (smap ?tfst ((p, q) ## (u ||| v) ||| w ||| u ||| v)) \<and>
      infs c\<^sub>2 (smap ?tsnd ((p, q) ## (u ||| v) ||| w ||| u ||| v))"
      unfolding gen_def by (simp add: comp_def)
    also have "smap ?tfst ((p, q) ## (u ||| v) ||| w ||| u ||| v) = p ## u ||| w ||| u"
      by (coinduction arbitrary: p q u v w) (auto simp flip: szip_unfold, metis stream.collapse)
    also have "smap ?tsnd ((p, q) ## (u ||| v) ||| w ||| u ||| v) = q ## v ||| w ||| v"
      by (coinduction arbitrary: p q u v w) (auto simp flip: szip_unfold, metis stream.collapse)
    finally show "gen infs [c\<^sub>1 \<circ> ?tfst, c\<^sub>2 \<circ> ?tsnd] ((p, q) ## (u ||| v) ||| w ||| u ||| v) \<longleftrightarrow>
      infs c\<^sub>1 (p ## u ||| w ||| u) \<and> infs c\<^sub>2 (q ## v ||| w ||| v)" by this
  qed

  lemmas intersect'_language[simp] = intersection.product_language[folded NGBTA.language_def]
  lemmas intersect'_nodes_finite[intro] = intersection.product_nodes_finite[folded NGBTA.nodes_def]

  global_interpretation union: automaton_union_run
    nbta nbta.alphabet nbta.initial nbta.transition nbta.accepting "\<lambda> P w r p. infs P (p ## r ||| w ||| r)"
    nbta nbta.alphabet nbta.initial nbta.transition nbta.accepting "\<lambda> P w r p. infs P (p ## r ||| w ||| r)"
    nbta nbta.alphabet nbta.initial nbta.transition nbta.accepting "\<lambda> P w r p. infs P (p ## r ||| w ||| r)"
    "\<lambda> c\<^sub>1 c\<^sub>2 m. case m of (Inl p, a, Inl q) \<Rightarrow> c\<^sub>1 (p, a, q) | (Inr p, a, Inr q) \<Rightarrow> c\<^sub>2 (p, a, q)"
    defines union = union.sum
    by (unfold_locales) (auto simp add: szip_smap_fold comp_def case_prod_unfold simp flip: stream.map)

  lemmas union_language = union.sum_language
  lemmas union_nodes_finite = union.sum_nodes_finite

  abbreviation intersect where "intersect A B \<equiv> degeneralize (intersect' A B)"

  lemma intersect_language[simp]: "NBTA.language (intersect A B) = NBTA.language A \<inter> NBTA.language B"
    by simp
  lemma intersect_nodes_finite[intro]:
    assumes "finite (NBTA.nodes A)" "finite (NBTA.nodes B)"
    shows "finite (NBTA.nodes (intersect A B))"
    using intersect'_nodes_finite assms by simp

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* License: BSD, terms see file ./LICENSE *)

theory Addr_Type
imports "HOL-Word.Word"
begin

type_synonym addr_bitsize = "32"
type_synonym addr = "addr_bitsize word"
definition addr_bitsize :: nat where "addr_bitsize \<equiv> 32"
definition addr_align :: nat where "addr_align \<equiv> 2"
declare addr_align_def[simp]

definition addr_card :: nat where
  "addr_card \<equiv> card (UNIV::addr set)"

declare addr_bitsize_def[simp]

lemma addr_card:
  "addr_card = 2^addr_bitsize"
  by (simp add: addr_card_def card_word)

lemma len_of_addr_card:
  "2 ^ len_of TYPE(addr_bitsize) = addr_card"
  by (simp add: addr_card)

lemma of_nat_addr_card [simp]:
  "of_nat addr_card = (0::addr)"
  by (simp add: addr_card)

end


theory Coll_Test
imports
  "../../Refine_Dflt"
  "Succ_Graph"
begin

declare [[autoref_trace_failed_id]]

context begin interpretation autoref_syn .

schematic_lemma "(?c::?'c,
  RETURN (({(1::nat,2::nat),(3,4)}):::(\<langle>\<langle>nat_rel,nat_rel\<rangle>prod_rel\<rangle>(map2set_rel (ahm_rel ?bhc))) )
)\<in>?R"
  apply autoref_monadic
  done

term dflt_ahs_rel

schematic_lemma "(?c::?'c, \<lambda>(a::'a::hashable) (b::'a::hashable).
  ({(a,b)}:::\<langle>?Rk::(?'b::hashable\<times>_) set\<rangle>dflt_ahs_rel)
)\<in>?R"
  apply (autoref (keep_goal))
  done

subsection "Foreach-Loops"
schematic_lemma "(?c::?'c,
  FOREACH {1,2,3::nat} (\<lambda>i s. RETURN (i+s)) 0
)\<in>?R"
  apply autoref_monadic
  done

schematic_lemma "(?c::?'c,
  FOREACH (map_to_set [1::nat\<mapsto>True, 2\<mapsto>False]) (\<lambda>(k,v) s. RETURN (k+s)) 0
)\<in>?R"
  apply autoref_monadic
  done

(* TODO: generic algorithm for bounded hash code of sets! *)
schematic_lemma "(?c::?'c,
  FOREACH
    (map_to_set ([{1::nat}\<mapsto>True, {2}\<mapsto>False]:::\<langle>\<langle>nat_rel\<rangle>dflt_rs_rel,bool_rel\<rangle>(rbt_map_rel ?cmp)))
    (\<lambda>(k,v) s. RETURN (v\<and>s)) False
)\<in>?R"
  apply autoref_monadic
  done

subsection "Array Hash Map Tests"

schematic_lemma
  "(?f::?'c, \<lambda>m. (m)(1::nat\<mapsto>2::nat)) \<in> ?R"
  apply (autoref (keep_goal))
  done

schematic_lemma
  "(?f::?'c, \<lambda>m. (m:::\<langle>Id,Id\<rangle>dflt_ahm_rel)(1::nat\<mapsto>2::nat)) \<in> ?R"
apply (autoref (keep_goal))
done

schematic_lemma
  "(?f::?'c, Map.empty:::\<langle>Id,Id\<rangle>dflt_ahm_rel) \<in> ?R"
apply (autoref)
done

schematic_lemma
  fixes mi m
  (* TODO: Obviously, we cannot override the tyREL-rule for
    "nat\<rightharpoonup>nat" with this: *)
  assumes [autoref_rules]: "(mi,m)\<in>\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel"
  shows "(?f::?'c,
    RETURN (card (dom (m:::\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel)))) \<in> ?R"
  apply (autoref_monadic)
  done

(* Optimizations *)

subsection "List Map Tests"

definition foo::"(nat\<rightharpoonup>nat) nres" where "foo \<equiv>
  do {
    let X = Map.empty;
    ASSERT (1 \<notin> dom X);
    RETURN (X(1 \<mapsto> 2))
  }"

schematic_lemma list_map_update_dj_test:
  "(?f::?'c, foo ::: \<langle>\<langle>Id,Id\<rangle>list_map_rel\<rangle>nres_rel) \<in> ?R"
  unfolding foo_def
  apply autoref_monadic
  done

schematic_lemma
  "(?f::?'c, [1::nat \<mapsto> 2::nat, 3\<mapsto>4] ::: \<langle>nat_rel,nat_rel\<rangle>list_map_rel) \<in> ?R"
  apply autoref
  done

schematic_lemma list_map_test:
  "(?f::?'c, RETURN (([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel) |`(-{1}))) \<in> ?R"
apply (autoref_monadic)
done
concrete_definition list_map_test uses list_map_test
value list_map_test

(* Why does this work:*)
schematic_lemma
  "(?f::?'c, RETURN (card (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel)))) \<in> ?R"
apply (autoref_monadic)
done

(* But this doesn't? This is not specific to list_map;
   it doesn't work with dflt_rbt_rel either.*)
(*schematic_lemma
  "(?f::?'c, RETURN (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel))) \<in> ?R"
apply (autoref_monadic)
done*)

subsection "Array-Map Tests"

term "{1,2::nat} \<union> {3,4}"

schematic_lemma array_set_test_code:
  "(?f::?'c, RETURN (({1,2::nat} \<union> {3,4}
       ::: \<langle>nat_rel\<rangle>iam_set_rel )))\<in>?R"
by (autoref_monadic (trace))

concrete_definition array_set_test uses array_set_test_code
print_theorems
value array_set_test

schematic_lemma
  "(?f::?'c, RETURN (({1} ::: \<langle>nat_rel\<rangle>dflt_rs_rel) = {}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (card {1,2,3::nat}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (\<forall>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (\<exists>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_lemma
  "(?f::?'c, RETURN (({1} ::: \<langle>nat_rel\<rangle>iam_set_rel) = {}))\<in>?R"
  apply (autoref_monadic (trace))
  done

schematic_lemma
  assumes [autoref_rules]: "(f,f')\<in>nat_rel\<rightarrow>Rb"
  shows "(?f::?'c,f' 3)\<in>?R"
  by (autoref)

schematic_lemma "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) ::: \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) ::: \<langle>Id\<rangle>list_set_rel)
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) ::: \<langle>Id\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c,
  RETURN (card (dom ([ 1::nat \<mapsto> True, 2\<mapsto>False ] ::: \<langle>Id,Id\<rangle>dflt_rm_rel )))
)\<in>?R"
  by autoref_monadic

text {* A hairy case for the operator identification heuristics for maps: *}
schematic_lemma
  shows "(?f::?'c,
  \<lambda>m (x::'a::linorder) (y::'b::linorder). case_option
    None
    (\<lambda>m'. m' y)
    (m x)
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma
  shows "(?f::?'c,
  \<lambda>m (x::'a::hashable) (y::'b::hashable). case_option
    None
    (\<lambda>m'. m' y)
    (m x)
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma
  shows "(?f::?'c,
  \<lambda>m (x::'a::hashable) (y::'b::linorder). case_option
    None
    (\<lambda>m'. m' y)
    (m (x:::Id))
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  {1,2::'a::numeral} \<times> {3,4::'a}
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  {1,2::'a::{numeral,hashable}} \<times> ({3,4::'a} ::: \<langle>Id\<rangle>dflt_ahs_rel)
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  {1,2::nat} \<times> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  {1,2::nat} \<inter> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) ::: \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

(* TODO: ty_REL hint is ignored. Reason: Seems to not properly work with GAs! *)
schematic_lemma
  notes [autoref_tyrel] = ty_REL[where 'a = "(nat\<times>nat) set"
    and R="\<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel"]
  shows "(?f::?'c,
    RETURN (({1,2::nat} \<times> {3,4::nat}))
  )\<in>?R"
  by autoref_monadic

(* TODO: Iterator optimization does not capture
    foldli ((map fst \<circ> rbt_to_list) x)
pattern!
*)

text {* We have an optimized version for add on red-black trees *}
schematic_lemma "(?f::?'c,
  [ 1::nat \<mapsto> True, 2::nat \<mapsto> False ] ++ [ 3::nat \<mapsto> True, 4::nat \<mapsto> False ]
)\<in>?R"
  by (autoref (keep_goal))

text {* The optimized version is also transfered through the map2set converter *}
schematic_lemma "(?f::?'c,
  {1,2::nat} \<union> {3,4}
)\<in>?R"
  by (autoref (keep_goal))

text {* For list-sets, the generic version is used *}
schematic_lemma "(?f::?'c,
  {1,2::nat} \<union> {3,4} ::: \<langle>Id\<rangle>list_set_rel
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  ({{1::nat}:::\<langle>Id\<rangle> map2set_rel dflt_rm_rel} )
  \<union> ({{2,3,4,5,5,6,7,8,98,9,0}})
)\<in>?R"
  by (autoref (keep_goal))

text {* The next two lemmas demonstrate optimization: The insert-operation
  is translated by @{term "op #"} *}
schematic_lemma "(?f::?'c, {1,2,3,4::nat}:::\<langle>Id\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_lemma
  "(?f::?'c, {{1},{2},{3},{4::nat}}:::\<langle>?R'::(?'d\<times>_) set\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}:::\<langle>Id\<rangle>dflt_rs_rel))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c, do {
  let s = ({1,2,3::nat}:::\<langle>Id\<rangle>dflt_rs_rel);
  FOREACH s (\<lambda>n s. RETURN (n+s)) 0
}
)\<in>?R"
  by autoref_monadic

schematic_lemma "(?f::?'c, do {
  let s = ({{1,2,3::nat}, {}, {1,2}});
  FOREACH s (\<lambda>n s. RETURN (n \<union> s)) {}
}
)\<in>?R"
  by (autoref_monadic)

schematic_lemma "(?f::?'c,
  ({{1::nat}} )
  \<union> ({{2,3,4,5,5,6,7,8,98,9,0}})
)\<in>?R"
  by (autoref (keep_goal))

schematic_lemma "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_lemma "(?f::?'c,
  [ 1::nat \<mapsto> [ 2::nat \<mapsto> 3::nat, 1::nat \<mapsto> 3::nat ] ]
)\<in>?R"
  apply (autoref (keep_goal))
  done

end

text {* Indirect Annotation *}
consts
  rel_set1 :: rel_name
  rel_set2 :: rel_name

context begin interpretation autoref_syn .

definition
  "algo \<equiv> ( {1,2,3::nat}::#rel_set1, {1,2,3::nat}::#rel_set2 )"

schematic_lemma
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>list_set_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

schematic_lemma
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

text {* A witness of the red algorithm is a node on the stack and a path
  to this node *}
type_synonym 'v red_witness = "('v list \<times> 'v) option"
text {* Prepend node to red witness *}
fun prep_wit_red :: "'v \<Rightarrow> 'v red_witness \<Rightarrow> 'v red_witness" where
  "prep_wit_red v None = None"
| "prep_wit_red v (Some (p,u)) = Some (v#p,u)"

text {*
  Initial witness for node @{text "u"} with onstack successor @{text "v"}
  *}
definition red_init_witness :: "'v \<Rightarrow> 'v \<Rightarrow> 'v red_witness" where
  "red_init_witness u v = Some ([u],v)"

definition red_dfs where
  "red_dfs E onstack V u \<equiv>
    REC\<^sub>T (\<lambda>D (V,u). do {
      let V=(insert u V);

      (* Check whether we have a successor on stack *)
      brk \<leftarrow> FOREACH\<^sub>C (E``{u}) (\<lambda>brk. brk=None)
        (\<lambda>t _. if t\<in>onstack then RETURN (red_init_witness u t) else RETURN None)
        None;

      (* Recurse for successors *)
      case brk of
        None \<Rightarrow>
          FOREACH\<^sub>C ((E``{u})) (\<lambda>(V,brk). brk=None)
            (\<lambda>t (V,_).
              if t\<notin>V then do {
                (V,brk) \<leftarrow> D (V,t);
                RETURN (V,prep_wit_red u brk)
              } else RETURN (V,None))
            (V,None)
      | _ \<Rightarrow> RETURN (V,brk)
    }) (V,u)
  "

abbreviation "i_red_witness \<equiv> \<langle>\<langle>\<langle>i_nat\<rangle>\<^sub>ii_list,i_nat\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option"
lemma [autoref_itype]:
  "red_init_witness ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_witness"
  "prep_wit_red ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_witness \<rightarrow>\<^sub>i i_red_witness"
  by auto

abbreviation "red_witness_rel \<equiv> \<langle>\<langle>\<langle>nat_rel\<rangle>list_rel,nat_rel\<rangle>prod_rel\<rangle>option_rel"

lemma [autoref_rules_raw]:
  "(red_init_witness,red_init_witness) \<in> nat_rel\<rightarrow>nat_rel\<rightarrow>red_witness_rel"
  "(prep_wit_red,prep_wit_red) \<in> nat_rel \<rightarrow> red_witness_rel \<rightarrow> red_witness_rel"
  by (auto)

(*schematic_lemma
  "(?f, RECT (\<lambda>D x. D x)) \<in> (?R::(?'c\<times>_) set)"
  apply (autoref (keep_goal))
  done*)

schematic_lemma red_dfs_impl:
  notes [[goals_limit = 1]]
  fixes u'::"nat" and V'::"nat set"
  assumes [autoref_rules]:
    "(u,u')\<in>nat_rel"
    "(V,V')\<in>\<langle>nat_rel\<rangle>dflt_rs_rel"
    "(onstack,onstack')\<in>\<langle>nat_rel\<rangle>dflt_rs_rel"
    "(E,E')\<in>\<langle>nat_rel\<rangle>slg_rel"
  shows "(?f, red_dfs E' onstack' V' u') \<in> (?R::(?'c\<times>_) set)"
  apply -
  unfolding red_dfs_def
  apply (autoref_monadic (trace))
  done

concrete_definition red_dfs_impl for E onstack V u uses red_dfs_impl

prepare_code_thms red_dfs_impl_def

export_code red_dfs_impl in SML

end
end