theory PF_Primitive_Translation
imports
  "../PF_Firewall_Common"
  "../PF_Primitive_Matchers"
  "../PF_Primitives"
  PF_Matching_Ternary
  IP_Addresses.CIDR_Split
  Iptables_Semantics.Negation_Type
  PF_Negation_Type_Matching
  PF_Predicates
  "../PF_Optimize_Match_Exprs"
begin

(* normalize matches to representation closest to simple_matcher *)

fun match_or :: "'a list \<Rightarrow> 'a match_expr" where
"match_or [] = MatchNot MatchAny" |
"match_or (x#xs) = MatchOr (Match x) (match_or xs)"

(* -------------- Ports -------------- *)

(* words wrap \<rightarrow> needs explicit check for 0 and max_word *)
value "(WordInterval (max_word + 1) max_word)::16 wordinterval"

fun normalize_ports' :: "16 word opspec \<Rightarrow> 16 wordinterval" where
"normalize_ports' (Unary (Eq p)) = (WordInterval p p)" |
"normalize_ports' (Unary (NEq p)) = wordinterval_setminus wordinterval_UNIV (WordInterval p p)" |
"normalize_ports' (Unary (GtEq p)) = (WordInterval p max_word)" |
"normalize_ports' (Unary (Gt p)) = (if (p = max_word)
                                     then Empty_WordInterval
                                     else (WordInterval (p + 1) max_word))" |
"normalize_ports' (Unary (LtEq p)) = (WordInterval 0 p)" |
"normalize_ports' (Unary (Lt p)) = (if (p = 0)
                                     then Empty_WordInterval
                                     else (WordInterval 0 (p - 1)))" |
"normalize_ports' (Binary (RangeIncl from to)) = (WordInterval from to)" |
"normalize_ports' (Binary (RangeExcl from to)) =
  (if (from = max_word \<or> to = 0)
    then Empty_WordInterval
    else (WordInterval (from + 1) (to -1)))" |
"normalize_ports' (Binary (RangeComp from to)) =
  wordinterval_setminus wordinterval_UNIV (WordInterval from to)"

lemma normalize_ports' :
"match_port spec p \<longleftrightarrow> wordinterval_element p (normalize_ports' spec)"
  unfolding match_port_def using linorder_not_less
  by (induction spec rule: normalize_ports'.induct)
     (auto simp add: inc_le word_Suc_le minus_one_helper3 minus_one_helper5)

fun normalize_ports :: "common_primitive match_expr \<Rightarrow> common_primitive match_expr" where
"normalize_ports (Match (common_primitive.Src_Ports (L4Ports proto p))) =
 match_or (map (\<lambda>(l,u). (common_primitive.Src_Ports (L4Ports proto (Binary (RangeIncl l u)))))
            (wi2l (normalize_ports' p)))" |
"normalize_ports (Match (common_primitive.Dst_Ports (L4Ports proto p))) =
 match_or (map (\<lambda>(l,u). (common_primitive.Dst_Ports (L4Ports proto (Binary (RangeIncl l u)))))
            (wi2l (normalize_ports' p)))" |
"normalize_ports (MatchNot m) = (MatchNot (normalize_ports m))" |
"normalize_ports (MatchAnd m1 m2) = (MatchAnd (normalize_ports m1) (normalize_ports m2))" |
"normalize_ports m = m"

lemma ternary_to_bool_eq:
  assumes "ternary_to_bool e1 = ternary_to_bool e2"
  shows "e1 = e2"
  using assms by(cases e1;cases e2;auto)

lemma src_ports_disjunction_helper:
"ternary_to_bool
  (ternary_ternary_eval
    (map_match_tac (common_matcher ctx) p
      (match_or
        (map (\<lambda>(l, u). Src_Ports (L4Ports proto (Binary (RangeIncl l u)))) l)))) =
 Some (proto = (p_proto p) \<and>(p_sport p) \<in> (\<Union>x\<in>set l. wordinterval_to_set (l2wi l)))"
proof(induction l rule: l2wi.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case
    by (auto simp add:MatchOr_def eval_ternary_idempotence_Not
                      eval_ternary_simps_simple match_port_def ternary_to_bool_bool_to_ternary)
next
  case (3 l u)
  then show ?case
    by (cases "(proto = p_proto p) \<and> (l \<le> p_sport p \<and> p_sport p \<le> u)")
       (auto simp add: eval_ternary_idempotence_Not MatchOr_def
                       eval_ternary_simps_simple match_port_def ternary_to_bool_bool_to_ternary)
qed

lemma dst_ports_disjunction_helper:
"ternary_to_bool
(ternary_ternary_eval
     (map_match_tac (common_matcher ctx) p
       (match_or
         (map (\<lambda>(l, u). Dst_Ports (L4Ports proto (Binary (RangeIncl l u)))) l)))) =
 Some ((proto = p_proto p) \<and> (p_dport p) \<in> (\<Union>x\<in>set l. wordinterval_to_set (l2wi l)))"
proof(induction l rule: l2wi.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case
    by (auto simp add:MatchOr_def eval_ternary_idempotence_Not
                      eval_ternary_simps_simple match_port_def ternary_to_bool_bool_to_ternary)
next
  case (3 l u)
  then show ?case
    by (cases "(proto = p_proto p) \<and> (l \<le> p_dport p \<and> p_dport p \<le> u)")
       (auto simp add: eval_ternary_idempotence_Not MatchOr_def
                       eval_ternary_simps_simple match_port_def ternary_to_bool_bool_to_ternary)
qed

lemma normalize_ports_preserves_semantics':
"ternary_ternary_eval (map_match_tac (common_matcher ctx) packet m) =
 ternary_ternary_eval (map_match_tac (common_matcher ctx) packet (normalize_ports m))"
proof(induction m rule:normalize_ports.induct)
  case (1 proto p)
  have "ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) packet (match_expr.Match (Src_Ports (L4Ports proto p))))) =
        ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) packet (normalize_ports (match_expr.Match (Src_Ports (L4Ports proto p))))))"
    apply (simp add:normalize_ports' MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple
                    ternary_to_bool_bool_to_ternary src_ports_disjunction_helper l2wi_wi2l)
    using l2wi_wi2l by force
  then show ?case using ternary_to_bool_eq by auto
next
  case (2 proto p)
  have "ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) packet (match_expr.Match (Dst_Ports (L4Ports proto p))))) =
        ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) packet (normalize_ports (match_expr.Match (Dst_Ports (L4Ports proto p))))))"
    apply (simp add:normalize_ports' MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple
                    ternary_to_bool_bool_to_ternary dst_ports_disjunction_helper l2wi_wi2l)
    using l2wi_wi2l by force
  then show ?case using ternary_to_bool_eq by auto
qed simp+

lemma normalize_ports_preserves_semantics:
 "matches (common_matcher ctx, \<alpha>) m a d p \<longleftrightarrow> matches (common_matcher ctx, \<alpha>) (normalize_ports m) a d p"
  apply(simp add:matches_def) using normalize_ports_preserves_semantics' by auto

(* FIXME remove after Isabelle2018 *)

lemma [simp]:
  "normalized_ports
          (match_or (map (\<lambda>(l, u). Src_Ports (L4Ports proto (Binary (RangeIncl l u)))) xs))"
  by (induction xs) (auto simp: MatchOr_def normalized_ports_def)

lemma [simp]:
  "normalized_ports
          (match_or (map (\<lambda>(l, u). Dst_Ports (L4Ports proto (Binary (RangeIncl l u)))) xs))"
  by (induction xs) (auto simp: MatchOr_def normalized_ports_def)

lemma normalize_ports_ok:
  "normalized_ports (normalize_ports m)"
by (induction m rule:normalize_ports.induct)
   ((simp add:normalized_ports_def; fail) | simp)+

definition normalize_ports_rs :: "common_primitive ruleset \<Rightarrow> common_primitive ruleset" where
"normalize_ports_rs = optimize_matches normalize_ports"

lemma normalize_ports_rs_ok:
  assumes "simple_ruleset rs"
  shows "normalized_ports_rs (normalize_ports_rs rs)"
  unfolding normalized_ports_rs_def normalize_ports_rs_def
  using optimize_matches_preserves_all_PfRules_P'[where f="normalize_ports"]
    assms normalize_ports_ok by auto

lemma normalize_ports_rs_preserves_semantics:
  assumes "simple_ruleset rs"
      and "good_matcher (common_matcher ctx,\<alpha>)"
    shows "pf_approx rs (common_matcher ctx,\<alpha>) p =
           pf_approx (normalize_ports_rs rs) (common_matcher ctx,\<alpha>) p"
  unfolding normalize_ports_rs_def
  using optimize_matches_preserves_semantics assms normalize_ports_preserves_semantics
  by metis

lemma src_ports_good_primitive_helper:
"all_match (good_primitive ctx)
     (match_or
       (map (\<lambda>(l, u). Src_Ports (L4Ports proto (Binary (RangeIncl l u)))) l))"
proof (induction l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  then show ?case by(cases a) (auto simp:MatchOr_def)
qed

lemma dst_ports_good_primitive_helper:
"all_match (good_primitive ctx)
     (match_or
       (map (\<lambda>(l, u). Dst_Ports (L4Ports proto (Binary (RangeIncl l u)))) l))"
proof (induction l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  then show ?case by(cases a) (auto simp:MatchOr_def)
qed

lemma normalize_ports_preserves_good_match_expr:
  assumes "good_match_expr ctx m"
  shows "good_match_expr ctx (normalize_ports m)"
  using assms unfolding good_match_expr_def
proof (induction m rule:normalize_ports.induct)
  case (1 proto p)
  then show ?case by (simp add: src_ports_good_primitive_helper)
next
  case (2 proto p)
  then show ?case by (simp add: dst_ports_good_primitive_helper)
qed auto

lemma normalize_ports_rs_preserves_simple_ruleset:
  assumes "simple_ruleset rs"
    shows "simple_ruleset (normalize_ports_rs rs)"
  unfolding normalize_ports_rs_def using assms optimize_matches_simple_ruleset by blast

lemma normalize_ports_rs_preserves_wf_ruleset:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "wf_ruleset ctx (normalize_ports_rs rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. good_match_expr ctx (normalize_ports (pf_rule.get_match r))) rs"
    using assms proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by(cases a)
        (auto simp add:normalize_ports_preserves_good_match_expr
                       simple_ruleset_def wf_ruleset_def)
  qed
  then have "all_PfRules_P (\<lambda>r. good_match_expr ctx (pf_rule.get_match r))
                  (normalize_ports_rs rs)" unfolding normalize_ports_rs_def
    using optimize_matches_preserves_all_PfRules_P assms by simp
  then show ?thesis
    using assms normalize_ports_rs_preserves_simple_ruleset simple_ruleset_wf_ruleset
    by simp
qed

lemma normalize_ports_no_tables_src_helper:
"no_tables
        (match_or
          (map (\<lambda>(l, u). Src_Ports (L4Ports proto (Binary (RangeIncl l u))))
            l))"
  by (induction l) (auto simp:MatchOr_def no_tables_def)

lemma normalize_ports_no_tables_dst_helper:
"no_tables
        (match_or
          (map (\<lambda>(l, u). Dst_Ports (L4Ports proto (Binary (RangeIncl l u))))
            l))"
  by (induction l) (auto simp:MatchOr_def no_tables_def)

lemma normalize_ports_preserves_no_tables:
  assumes "no_tables m"
  shows "no_tables (normalize_ports m)"
  using assms apply (induction m rule:normalize_ports.induct)
  by (auto simp:normalize_ports_no_tables_src_helper
                normalize_ports_no_tables_dst_helper)
     (auto simp:no_tables_def)

lemma normalize_ports_rs_preserves_no_tables_rs:
  assumes "simple_ruleset rs"
      and "no_tables_rs rs"
    shows "no_tables_rs (normalize_ports_rs rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. (no_tables (normalize_ports (pf_rule.get_match r)))) rs" using assms
  proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by (cases a)
        (auto simp:normalize_ports_preserves_no_tables
                   simple_ruleset_def no_tables_rs_def)
  qed
  then have "all_PfRules_P (\<lambda>r. no_tables (pf_rule.get_match r))
                  (normalize_ports_rs rs)" unfolding normalize_ports_rs_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis unfolding normalize_ports_rs_def no_tables_rs_def
  using assms normalize_ports_rs_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

(* -------------- Tables -------------- *)

fun remove_tables ::"pfcontext \<Rightarrow> common_primitive match_expr \<Rightarrow> common_primitive match_expr" where
"remove_tables ctx (Match (common_primitive.Src (Hostspec (Table name)))) =
  (MatchOr
    (match_or
      (map (\<lambda> a. (common_primitive.Src (Hostspec (Address (IPv4 a)))))
        (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name)))))
    (match_or
      (map (\<lambda> a. (common_primitive.Src (Hostspec (Address (IPv6 a)))))
        (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v6 (lookup_table ctx name))))))" |
"remove_tables ctx (Match (common_primitive.Dst (Table name))) =
  (MatchOr
    (match_or
      (map (\<lambda> a. (common_primitive.Dst (Address (IPv4 a))))
        (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name)))))
    (match_or
      (map (\<lambda> a. (common_primitive.Dst (Address (IPv6 a))))
        (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v6 (lookup_table ctx name))))))" |
"remove_tables ctx (MatchNot m) = (MatchNot (remove_tables ctx m))" |
"remove_tables ctx (MatchAnd m1 m2) = (MatchAnd (remove_tables ctx m1) (remove_tables ctx m2))" |
"remove_tables ctx m = m"

lemma common_matcher_Src_IPv6_TernaryFalse[simp]:
"ternary_ternary_eval (map_match_tac (common_matcher ctx) p
(match_or (map (\<lambda>a. Src (Hostspec (Address (IPv6 a)))) l))) = TernaryFalse"
  by (induction l)
     (simp add:matches_def MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple(1))+

lemma common_matcher_Dst_IPv6_TernaryFalse[simp]:
"ternary_ternary_eval (map_match_tac (common_matcher ctx) p
(match_or (map (\<lambda>a. Dst (Address (IPv6 a))) l))) = TernaryFalse"
  by (induction l)
     (simp add:matches_def MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple(1))+

lemma src_addr_disjunction_helper:
  assumes "\<forall> x\<in>set l. valid_prefix x"
  shows "ternary_to_bool
(ternary_ternary_eval
     (map_match_tac (common_matcher ctx) p
       (match_or
         (map (\<lambda>a. Src (Hostspec (Address (IPv4 a)))) l)))) =
 Some ((p_src p) \<in> (\<Union>x\<in>set l. prefix_to_wordset x))"
  using assms
proof(induction l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  then show ?case
    by (cases "p_src p \<in> prefix_to_wordset a")
       (simp add:MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple
                 prefix_match_semantics_wordset)+
qed

lemma dst_addr_disjunction_helper:
  assumes "\<forall> x\<in>set l. valid_prefix x"
  shows "ternary_to_bool
(ternary_ternary_eval
     (map_match_tac (common_matcher ctx) p
       (match_or
         (map (\<lambda>a. Dst (Address (IPv4 a))) l)))) =
 Some ((p_dst p) \<in> (\<Union>x\<in>set l. prefix_to_wordset x))"
  using assms
proof(induction l)
  case Nil
  then show ?case by simp
next
  case (Cons a l)
  then show ?case
    by (cases "p_dst p \<in> prefix_to_wordset a")
       (simp add:MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple
                 prefix_match_semantics_wordset)+
qed

lemma remove_tables_preserves_semantics' :
  assumes "good_match_expr ctx m"
  shows "ternary_ternary_eval (map_match_tac (common_matcher ctx) p m) =
         ternary_ternary_eval (map_match_tac (common_matcher ctx) p (remove_tables ctx m))"
  using assms
proof(induction m rule:remove_tables.induct)
  case (1 ctx name)
  then have "ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) p (match_expr.Match (Src (Hostspec (Table name)))))) =
             ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) p (remove_tables ctx (match_expr.Match (Src (Hostspec (Table name)))))))"
    by (simp add:good_match_expr_def MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple ternary_to_bool_bool_to_ternary
                 src_addr_disjunction_helper[of "wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name))" _ _]
                 match_table_v4_wordinterval
                 wordinterval_CIDR_split_prefixmatch_all_valid_Ball wordinterval_CIDR_split_prefixmatch)
  then show ?case using ternary_to_bool_eq by auto
next
  case (2 ctx name)
  then have "ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) p (match_expr.Match (Dst (Table name))))) =
             ternary_to_bool (ternary_ternary_eval (map_match_tac (common_matcher ctx) p (remove_tables ctx (match_expr.Match (Dst (Table name))))))"
    by (simp add:good_match_expr_def MatchOr_def eval_ternary_idempotence_Not eval_ternary_simps_simple ternary_to_bool_bool_to_ternary
                 dst_addr_disjunction_helper[of "wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name))" _ _]
                 match_table_v4_wordinterval
                 wordinterval_CIDR_split_prefixmatch_all_valid_Ball wordinterval_CIDR_split_prefixmatch)
  then show ?case using ternary_to_bool_eq by auto
qed (simp add:good_match_expr_def)+

lemma remove_tables_preserves_semantics :
  assumes "good_match_expr ctx m"
  shows "matches (common_matcher ctx, \<alpha>) m a d p \<longleftrightarrow>
         matches (common_matcher ctx, \<alpha>) (remove_tables ctx m) a d p"
  using assms by (simp add:good_match_expr_def matches_def remove_tables_preserves_semantics')

lemma [simp]:
  "no_tables
          (match_or (map (\<lambda>a. Src (Hostspec (Address (IPv4 a)))) xs))"
  by (induction xs) (auto simp: MatchOr_def no_tables_def)

lemma [simp]:
  "no_tables
          (match_or (map (\<lambda>a. Src (Hostspec (Address (IPv6 a)))) xs))"
  by (induction xs) (auto simp: MatchOr_def no_tables_def)

lemma [simp]:
  "no_tables
          (match_or (map (\<lambda>a. Dst (Address (IPv4 a))) xs))"
  by (induction xs) (auto simp: MatchOr_def no_tables_def)

lemma [simp]:
  "no_tables
          (match_or (map (\<lambda>a. Dst (Address (IPv6 a))) xs))"
  by (induction xs) (auto simp: MatchOr_def no_tables_def)

lemma remove_tables_ok:
  "(no_tables (remove_tables ctx m))"
proof(induction ctx m rule:remove_tables.induct)
  case (1 ctx name)
  then have "no_tables (match_or
         (map (\<lambda>a. Src (Hostspec (Address (IPv4 a))))
           (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name)))))" by simp
  moreover have "no_tables (match_or
         (map (\<lambda>a. Src (Hostspec (Address (IPv6 a))))
           (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v6 (lookup_table ctx name)))))" by simp
  ultimately show ?case by (simp add:MatchOr_def no_tables_def)
next
  case (2 ctx name)
  then have "no_tables (match_or
         (map (\<lambda>a. Dst (Address (IPv4 a)))
           (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name)))))" by simp
  moreover have "no_tables (match_or
         (map (\<lambda>a. Dst (Address (IPv6 a)))
           (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v6 (lookup_table ctx name)))))" by simp
  ultimately show ?case by (simp add:MatchOr_def no_tables_def)
qed (simp add:no_tables_def)+

definition remove_tables_rs :: "pfcontext \<Rightarrow> common_primitive ruleset \<Rightarrow> common_primitive ruleset" where
"remove_tables_rs ctx = optimize_matches (remove_tables ctx)"

lemma remove_tables_rs_preserves_semantics:
  assumes "wf_ruleset ctx rs"
      and "simple_ruleset rs"
      and "good_matcher (common_matcher ctx,\<alpha>)"
    shows "pf_approx rs (common_matcher ctx,\<alpha>) p =
           pf_approx (remove_tables_rs ctx rs) (common_matcher ctx,\<alpha>) p"
proof(-)
  have "\<forall>r\<in>set rs.
       case r of PfRule r \<Rightarrow> pf_rule.get_action r \<noteq> ActionMatch \<and> good_match_expr ctx (pf_rule.get_match r)
       | Anchor _ _ \<Rightarrow> True" using assms(1) assms(2) unfolding wf_ruleset_def simple_ruleset_def
    by (simp add: line.case_eq_if)
  have "(\<And>m a d. a \<noteq> ActionMatch \<and> good_match_expr ctx m \<Longrightarrow>
  matches (common_matcher ctx,\<alpha>) (remove_tables ctx m) a d p = matches(common_matcher ctx,\<alpha>) m a d p)"
    using remove_tables_preserves_semantics good_matcher_def assms(3)
    by blast

  show ?thesis unfolding remove_tables_rs_def
    apply (rule optimize_matches_generic[symmetric])
    by fact+
qed

lemma src_ipv4_good_match_expr_helper:
  assumes "\<forall> p \<in> set l. valid_prefix p"
  shows
 "good_match_expr ctx
   (match_or
     (map (\<lambda>a. Src (Hostspec (Address (IPv4 a))))
       l))"
  using assms
  by (induction l) (auto simp:good_match_expr_def MatchOr_def)

lemma src_ipv6_good_match_expr_helper:
  assumes "\<forall> p \<in> set l. valid_prefix p"
  shows
 "good_match_expr ctx
   (match_or
     (map (\<lambda>a. Src (Hostspec (Address (IPv6 a))))
       l))"
  using assms
  by (induction l) (auto simp:good_match_expr_def MatchOr_def)

lemma dst_ipv4_good_match_expr_helper:
  assumes "\<forall> p \<in> set l. valid_prefix p"
  shows
 "good_match_expr ctx
   (match_or
     (map (\<lambda>a. Dst (Address (IPv4 a)))
       l))"
  using assms
  by (induction l) (auto simp:good_match_expr_def MatchOr_def)

lemma dst_ipv6_good_match_expr_helper:
  assumes "\<forall> p \<in> set l. valid_prefix p"
  shows
 "good_match_expr ctx
   (match_or
     (map (\<lambda>a. Dst (Address (IPv6 a)))
       l))"
  using assms
  by (induction l) (auto simp:good_match_expr_def MatchOr_def)

lemma remove_tables_preserves_good_match_expr:
  assumes "good_match_expr ctx m"
  shows "good_match_expr ctx (remove_tables ctx m)"
  using assms
proof(induction m rule:remove_tables.induct)
  case (1 ctx name)
  have "good_match_expr ctx
         (match_or
           (map (\<lambda>a. Src (Hostspec (Address (IPv4 a))))
             (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name)))))"
    using src_ipv4_good_match_expr_helper wordinterval_CIDR_split_prefixmatch_all_valid_Ball by blast
  moreover have "good_match_expr ctx
                  (match_or
                    (map (\<lambda>a. Src (Hostspec (Address (IPv6 a))))
                      (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v6 (lookup_table ctx name)))))"
    using src_ipv6_good_match_expr_helper wordinterval_CIDR_split_prefixmatch_all_valid_Ball by blast
  ultimately show ?case by (auto simp:MatchOr_def good_match_expr_def)
next
  case (2 ctx name)
  have "good_match_expr ctx
         (match_or
           (map (\<lambda>a. Dst (Address (IPv4 a)))
             (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v4 (lookup_table ctx name)))))"
    using dst_ipv4_good_match_expr_helper wordinterval_CIDR_split_prefixmatch_all_valid_Ball by blast
  moreover have "good_match_expr ctx
                  (match_or
                    (map (\<lambda>a. Dst (Address (IPv6 a)))
                      (wordinterval_CIDR_split_prefixmatch (table_to_wordinterval_v6 (lookup_table ctx name)))))"
    using dst_ipv6_good_match_expr_helper wordinterval_CIDR_split_prefixmatch_all_valid_Ball by blast
  ultimately show ?case by (auto simp:MatchOr_def good_match_expr_def)
qed (auto simp:MatchOr_def good_match_expr_def)

lemma remove_tables_rs_preserves_simple_ruleset:
  assumes "simple_ruleset rs"
    shows "simple_ruleset (remove_tables_rs ctx rs)"
  unfolding remove_tables_rs_def using assms optimize_matches_simple_ruleset by blast

lemma remove_tables_rs_preserves_wf_ruleset:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "wf_ruleset ctx (remove_tables_rs ctx rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. good_match_expr ctx (remove_tables ctx (pf_rule.get_match r))) rs"
    using assms proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by(cases a)
        (auto simp add:remove_tables_preserves_good_match_expr
                       simple_ruleset_def wf_ruleset_def)
  qed
  then have "all_PfRules_P (\<lambda>r. good_match_expr ctx (pf_rule.get_match r))
                  (remove_tables_rs ctx rs)" unfolding remove_tables_rs_def
    using optimize_matches_preserves_all_PfRules_P assms by simp
  then show ?thesis
    using assms remove_tables_rs_preserves_simple_ruleset simple_ruleset_wf_ruleset
    by simp
qed

lemma remove_tables_rs_ok:
  assumes "simple_ruleset rs"
  shows "no_tables_rs (remove_tables_rs ctx rs)"
  unfolding no_tables_rs_def remove_tables_rs_def
  using optimize_matches_preserves_all_PfRules_P'[where f="remove_tables ctx"]
    assms remove_tables_ok by auto

(* -------------- IPv6 -------------- *)

fun remove_ipv6 :: "common_primitive match_expr \<Rightarrow> common_primitive match_expr" where
"remove_ipv6 (Match (Src (Hostspec (Address (IPv6 _))))) = MatchNone" |
"remove_ipv6 (Match (Dst (Address (IPv6 _)))) = MatchNone" |
"remove_ipv6 (Match (Address_Family Inet)) = MatchAny" |
"remove_ipv6 (Match (Address_Family Inet6)) = MatchNone" |
"remove_ipv6 MatchAny = MatchAny" |
"remove_ipv6 (Match m) = (Match m)" |
"remove_ipv6 (MatchNot m) = (MatchNot (remove_ipv6 m))" |
"remove_ipv6 (MatchAnd m1 m2) = (MatchAnd (remove_ipv6 m1) (remove_ipv6 m2))"

lemma remove_ipv6_preserves_semantics':
"ternary_ternary_eval (map_match_tac (common_matcher ctx) p m) =
 ternary_ternary_eval (map_match_tac (common_matcher ctx) p (remove_ipv6 m))"
  by (induction m rule:remove_ipv6.induct) (auto simp:MatchNone_def)

lemma remove_ipv6_preserves_semantics:
  "matches (common_matcher ctx,\<alpha>) m a d p = matches (common_matcher ctx,\<alpha>) (remove_ipv6 m) a d p"
  unfolding matches_def using remove_ipv6_preserves_semantics' by auto

definition ipv4_only :: "common_primitive ruleset \<Rightarrow> common_primitive ruleset" where
"ipv4_only = optimize_matches remove_ipv6"

lemma ipv4_only_preserves_semantics:
  assumes "simple_ruleset rs"
      and "good_matcher (common_matcher ctx,\<alpha>)"
    shows "pf_approx rs (common_matcher ctx,\<alpha>) p =
           pf_approx (ipv4_only rs) (common_matcher ctx,\<alpha>) p"
  unfolding ipv4_only_def
  using optimize_matches_preserves_semantics assms remove_ipv6_preserves_semantics
  by metis

lemma remove_ipv6_preserves_good_match_expr:
  assumes "good_match_expr ctx m"
  shows "good_match_expr ctx (remove_ipv6 m)"
  using assms by (induction m rule:remove_ipv6.induct)
                 (auto simp:good_match_expr_def MatchNone_def)

lemma ipv4_only_preserves_simple_ruleset:
  assumes "simple_ruleset rs"
  shows "simple_ruleset (ipv4_only rs)"
  using assms by (auto simp:ipv4_only_def optimize_matches_simple_ruleset)

lemma ipv4_only_preserves_wf_ruleset:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "wf_ruleset ctx (ipv4_only rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. good_match_expr ctx (remove_ipv6 (pf_rule.get_match r))) rs"
  using assms proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by(cases a)
        (auto simp add:remove_ipv6_preserves_good_match_expr
                       simple_ruleset_def wf_ruleset_def)
  qed
  then have "all_PfRules_P (\<lambda>r. good_match_expr ctx (pf_rule.get_match r))
                  (ipv4_only rs)" unfolding ipv4_only_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis
  using assms ipv4_only_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

lemma remove_ipv6_preserves_no_tables:
  assumes "no_tables m"
  shows "no_tables (remove_ipv6 m)"
  using assms apply (induction m rule:remove_ipv6.induct)
  by (auto simp:no_tables_def MatchNone_def)

lemma ipv4_only_preserves_no_tables_rs:
  assumes "simple_ruleset rs"
    and "no_tables_rs rs"
  shows "no_tables_rs (ipv4_only rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. (no_tables (remove_ipv6 (pf_rule.get_match r)))) rs" using assms
  proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by (cases a)
        (auto simp:remove_ipv6_preserves_no_tables
                   simple_ruleset_def no_tables_rs_def)
  qed
  then have "all_PfRules_P (\<lambda>r. no_tables (pf_rule.get_match r))
                  (ipv4_only rs)" unfolding ipv4_only_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis unfolding ipv4_only_def no_tables_rs_def
  using assms ipv4_only_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

lemma remove_ipv6_preserves_normalized_ports:
  assumes "normalized_ports m"
  shows "normalized_ports (remove_ipv6 m)"
  using assms apply (induction m rule:remove_ipv6.induct)
  by (auto simp:normalized_ports_def MatchNone_def)

lemma ipv4_only_preserves_normalized_ports_rs:
  assumes "simple_ruleset rs"
    and "normalized_ports_rs rs"
  shows "normalized_ports_rs (ipv4_only rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. normalized_ports (remove_ipv6 (pf_rule.get_match r))) rs" using assms
  proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by (cases a)
        (auto simp:remove_ipv6_preserves_normalized_ports
                   simple_ruleset_def normalized_ports_rs_def)
  qed
  then have "all_PfRules_P (\<lambda>r. normalized_ports (pf_rule.get_match r))
                  (ipv4_only rs)" unfolding ipv4_only_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis unfolding ipv4_only_def normalized_ports_rs_def
  using assms ipv4_only_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

lemma no_ipv6_ok: "no_ipv6 (remove_ipv6 m)"
  by (induction m rule:remove_ipv6.induct) (auto simp: no_ipv6_def MatchNone_def)

lemma no_af_ok: "no_af (remove_ipv6 m)"
  by (induction m rule:remove_ipv6.induct) (auto simp: no_af_def MatchNone_def)

lemma ipv4_only_no_ipv6:
  assumes "simple_ruleset rs"
  shows "no_ipv6_rs (ipv4_only rs)"
  unfolding no_ipv6_rs_def ipv4_only_def
  using optimize_matches_preserves_all_PfRules_P' assms no_ipv6_ok by auto

lemma ipv4_only_no_af:
  assumes "simple_ruleset rs"
  shows "no_af_rs (ipv4_only rs)"
  unfolding no_af_rs_def ipv4_only_def
  using optimize_matches_preserves_all_PfRules_P' assms no_af_ok by auto

(* -------------- AnyHost -------------- *)

fun remove_match_any' ::  "common_primitive match_expr \<Rightarrow> common_primitive match_expr" where
"remove_match_any' (Match (Src (Hostspec AnyHost))) = MatchAny" |
"remove_match_any' (Match (Dst AnyHost)) = MatchAny" |
"remove_match_any' (Match m) = (Match m)" |
"remove_match_any' MatchAny = MatchAny" |
"remove_match_any' (MatchNot m) = (MatchNot (remove_match_any' m))" |
"remove_match_any' (MatchAnd m1 m2) = (MatchAnd (remove_match_any' m1) (remove_match_any' m2))"

lemma remove_match_any'_ok: "no_anyhost (remove_match_any' m)"
  by (induction m rule:remove_match_any'.induct) (auto simp: no_anyhost_def MatchNone_def)

lemma remove_match_any'_preserves_semantics':
"ternary_ternary_eval (map_match_tac (common_matcher ctx) p m) =
 ternary_ternary_eval (map_match_tac (common_matcher ctx) p (remove_match_any' m))"
  by (induction m rule:remove_match_any'.induct) (auto simp:MatchNone_def)

lemma remove_match_any'_preserves_semantics:
  "matches (common_matcher ctx,\<alpha>) m a d p = matches (common_matcher ctx,\<alpha>) (remove_match_any' m) a d p"
  unfolding matches_def using remove_match_any'_preserves_semantics' by auto

definition remove_match_any :: "common_primitive ruleset \<Rightarrow> common_primitive ruleset" where
"remove_match_any = optimize_matches remove_match_any'"

lemma remove_match_any_preserves_semantics:
  assumes "simple_ruleset rs"
      and "good_matcher (common_matcher ctx,\<alpha>)"
    shows "pf_approx rs (common_matcher ctx,\<alpha>) p =
           pf_approx (remove_match_any rs) (common_matcher ctx,\<alpha>) p"
  unfolding remove_match_any_def
  using optimize_matches_preserves_semantics assms remove_match_any'_preserves_semantics
  by metis

lemma remove_match_any_ok:
  assumes "simple_ruleset rs"
  shows "no_anyhost_rs (remove_match_any rs)"
  unfolding no_anyhost_rs_def remove_match_any_def
  using optimize_matches_preserves_all_PfRules_P' assms remove_match_any'_ok by auto

lemma remove_match_any_preserves_simple_ruleset:
  assumes "simple_ruleset rs"
  shows "simple_ruleset (remove_match_any rs)"
  using assms by (auto simp:remove_match_any_def optimize_matches_simple_ruleset)

lemma remove_match_any'_preserves_good_match_expr:
  assumes "good_match_expr ctx m"
  shows "good_match_expr ctx (remove_match_any' m)"
  using assms by (induction m rule:remove_match_any'.induct)
                 (auto simp:good_match_expr_def MatchNone_def)

lemma remove_match_any_preserves_wf_ruleset:
  assumes "simple_ruleset rs"
  and "wf_ruleset ctx rs"
shows "wf_ruleset ctx (remove_match_any rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. good_match_expr ctx (remove_match_any' (pf_rule.get_match r))) rs"
  using assms proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by(cases a)
        (auto simp add:remove_match_any'_preserves_good_match_expr
                       simple_ruleset_def wf_ruleset_def)
  qed
  then have "all_PfRules_P (\<lambda>r. good_match_expr ctx (pf_rule.get_match r))
                  (remove_match_any rs)" unfolding remove_match_any_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis
  using assms remove_match_any_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

lemma remove_match_any'_preserves_no_tables:
  assumes "no_tables m"
  shows "no_tables (remove_match_any' m)"
  using assms apply (induction m rule:remove_match_any'.induct)
  by (auto simp:no_tables_def MatchNone_def)

lemma remove_match_any_preserves_no_tables_rs:
  assumes "simple_ruleset rs"
    and "no_tables_rs rs"
  shows "no_tables_rs (remove_match_any rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. (no_tables (remove_match_any' (pf_rule.get_match r)))) rs" using assms
  proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by (cases a)
        (auto simp:remove_match_any'_preserves_no_tables
                   simple_ruleset_def no_tables_rs_def)
  qed
  then have "all_PfRules_P (\<lambda>r. no_tables (pf_rule.get_match r))
                  (remove_match_any rs)" unfolding remove_match_any_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis unfolding ipv4_only_def no_tables_rs_def by simp
qed

lemma remove_match_any'_preserves_normalized_ports:
  assumes "normalized_ports m"
  shows "normalized_ports (remove_match_any' m)"
  using assms apply (induction m rule:remove_match_any'.induct)
  by (auto simp:normalized_ports_def MatchNone_def)

lemma remove_match_any_preserves_normalized_ports_rs:
  assumes "simple_ruleset rs"
    and "normalized_ports_rs rs"
  shows "normalized_ports_rs (remove_match_any rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. normalized_ports (remove_match_any' (pf_rule.get_match r))) rs" using assms
  proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by (cases a)
        (auto simp:remove_match_any'_preserves_normalized_ports
                   simple_ruleset_def normalized_ports_rs_def)
  qed
  then have "all_PfRules_P (\<lambda>r. normalized_ports (pf_rule.get_match r))
                  (remove_match_any rs)" unfolding remove_match_any_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis unfolding remove_match_any_def normalized_ports_rs_def
  using assms remove_match_any_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

lemma remove_match_any'_preserves_no_ipv6:
  assumes "no_ipv6 m"
  shows "no_ipv6 (remove_match_any' m)"
  using assms apply (induction m rule:remove_match_any'.induct)
  by (auto simp:no_ipv6_def MatchNone_def)

lemma remove_match_any_preserves_no_ipv6_rs:
  assumes "simple_ruleset rs"
    and "no_ipv6_rs rs"
  shows "no_ipv6_rs (remove_match_any rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. no_ipv6 (remove_match_any' (pf_rule.get_match r))) rs" using assms
  proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by (cases a)
        (auto simp:remove_match_any'_preserves_no_ipv6
                   simple_ruleset_def no_ipv6_rs_def)
  qed
  then have "all_PfRules_P (\<lambda>r. no_ipv6 (pf_rule.get_match r))
                  (remove_match_any rs)" unfolding remove_match_any_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis unfolding remove_match_any_def no_ipv6_rs_def
  using assms remove_match_any_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

lemma remove_match_any'_preserves_no_af:
  assumes "no_af m"
  shows "no_af (remove_match_any' m)"
  using assms apply (induction m rule:remove_match_any'.induct)
  by (auto simp:no_af_def MatchNone_def)

lemma remove_match_any_preserves_no_af_rs:
  assumes "simple_ruleset rs"
    and "no_af_rs rs"
  shows "no_af_rs (remove_match_any rs)"
proof(-)
  have "all_PfRules_P (\<lambda>r. no_af (remove_match_any' (pf_rule.get_match r))) rs" using assms
  proof(induction rs)
    case Nil
    then show ?case by simp
  next
    case (Cons a rs)
    then show ?case by (cases a)
        (auto simp:remove_match_any'_preserves_no_af
                   simple_ruleset_def no_af_rs_def)
  qed
  then have "all_PfRules_P (\<lambda>r. no_af (pf_rule.get_match r))
                  (remove_match_any rs)" unfolding remove_match_any_def
    using assms optimize_matches_preserves_all_PfRules_P by simp
  then show ?thesis unfolding remove_match_any_def no_af_rs_def
  using assms remove_match_any_preserves_simple_ruleset simple_ruleset_wf_ruleset
  by simp
qed

definition primitive_transformations :: "pfcontext \<Rightarrow> common_primitive ruleset \<Rightarrow> common_primitive ruleset" where
"primitive_transformations ctx rs =
(remove_match_any
(ipv4_only
(normalize_ports_rs
(remove_tables_rs ctx rs))))"

lemma primitive_transformations_preserves_semantics:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
      and "good_matcher (common_matcher ctx,\<alpha>)"
    shows "pf_approx rs (common_matcher ctx,\<alpha>) p = pf_approx (primitive_transformations ctx rs) (common_matcher ctx,\<alpha>) p"
  unfolding primitive_transformations_def
  using assms
 remove_tables_rs_preserves_simple_ruleset
 normalize_ports_rs_preserves_simple_ruleset
 ipv4_only_preserves_simple_ruleset
 remove_match_any_preserves_simple_ruleset
 remove_tables_rs_preserves_semantics
 normalize_ports_rs_preserves_semantics
 ipv4_only_preserves_semantics
 remove_match_any_preserves_semantics
  by metis

lemma primitive_transformations_simple_ruleset:
  assumes "simple_ruleset rs"
    shows "simple_ruleset (primitive_transformations ctx rs)"
  unfolding primitive_transformations_def using assms
 remove_tables_rs_preserves_simple_ruleset
 normalize_ports_rs_preserves_simple_ruleset
 ipv4_only_preserves_simple_ruleset
 remove_match_any_preserves_simple_ruleset
  by auto

lemma primitive_transformations_wf_ruleset:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "wf_ruleset ctx (primitive_transformations ctx rs)"
  unfolding primitive_transformations_def using assms
remove_tables_rs_preserves_wf_ruleset remove_tables_rs_preserves_simple_ruleset
normalize_ports_rs_preserves_wf_ruleset normalize_ports_rs_preserves_simple_ruleset
ipv4_only_preserves_wf_ruleset ipv4_only_preserves_simple_ruleset
remove_match_any_preserves_wf_ruleset remove_match_any_preserves_simple_ruleset
  by auto

lemma primitive_transformations_no_tables:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "no_tables_rs (primitive_transformations ctx rs)"
  unfolding primitive_transformations_def using assms
remove_tables_rs_preserves_wf_ruleset remove_tables_rs_preserves_simple_ruleset remove_tables_rs_ok
normalize_ports_rs_preserves_wf_ruleset normalize_ports_rs_preserves_simple_ruleset normalize_ports_rs_preserves_no_tables_rs
ipv4_only_preserves_wf_ruleset ipv4_only_preserves_simple_ruleset ipv4_only_preserves_no_tables_rs
remove_match_any_preserves_wf_ruleset remove_match_any_preserves_simple_ruleset remove_match_any_preserves_no_tables_rs
  by simp

lemma primitive_transformations_normalized_ports:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "normalized_ports_rs (primitive_transformations ctx rs)"
  unfolding primitive_transformations_def using assms
remove_tables_rs_preserves_wf_ruleset remove_tables_rs_preserves_simple_ruleset
normalize_ports_rs_preserves_wf_ruleset normalize_ports_rs_preserves_simple_ruleset normalize_ports_rs_ok
ipv4_only_preserves_wf_ruleset ipv4_only_preserves_simple_ruleset ipv4_only_preserves_normalized_ports_rs
remove_match_any_preserves_wf_ruleset remove_match_any_preserves_simple_ruleset remove_match_any_preserves_normalized_ports_rs
  by simp

lemma primitive_transformations_no_ipv6:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "no_ipv6_rs (primitive_transformations ctx rs)"
  unfolding primitive_transformations_def using assms
remove_tables_rs_preserves_wf_ruleset remove_tables_rs_preserves_simple_ruleset
normalize_ports_rs_preserves_wf_ruleset normalize_ports_rs_preserves_simple_ruleset
ipv4_only_preserves_wf_ruleset ipv4_only_preserves_simple_ruleset ipv4_only_no_ipv6
remove_match_any_preserves_wf_ruleset remove_match_any_preserves_simple_ruleset remove_match_any_preserves_no_ipv6_rs
  by simp

lemma primitive_transformations_no_af:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "no_af_rs (primitive_transformations ctx rs)"
  unfolding primitive_transformations_def using assms
remove_tables_rs_preserves_wf_ruleset remove_tables_rs_preserves_simple_ruleset
normalize_ports_rs_preserves_wf_ruleset normalize_ports_rs_preserves_simple_ruleset
ipv4_only_preserves_wf_ruleset ipv4_only_preserves_simple_ruleset ipv4_only_no_af
remove_match_any_preserves_wf_ruleset remove_match_any_preserves_simple_ruleset remove_match_any_preserves_no_af_rs
  by simp

lemma primitive_transformations_no_anyhost:
  assumes "simple_ruleset rs"
      and "wf_ruleset ctx rs"
    shows "no_anyhost_rs (primitive_transformations ctx rs)"
  unfolding primitive_transformations_def using assms
remove_tables_rs_preserves_wf_ruleset remove_tables_rs_preserves_simple_ruleset
normalize_ports_rs_preserves_wf_ruleset normalize_ports_rs_preserves_simple_ruleset
ipv4_only_preserves_wf_ruleset ipv4_only_preserves_simple_ruleset ipv4_only_no_af
remove_match_any_preserves_wf_ruleset remove_match_any_preserves_simple_ruleset remove_match_any_ok
  by simp

lemmas primitive_transformations_ok = primitive_transformations_preserves_semantics primitive_transformations_simple_ruleset primitive_transformations_wf_ruleset primitive_transformations_no_tables primitive_transformations_normalized_ports primitive_transformations_no_ipv6 primitive_transformations_no_af primitive_transformations_no_anyhost
end


theory bit_types
  imports Main HOL.Bit_Operations
begin
datatype byte =
Byte (digit0: bool) (digit1: bool) (digit2: bool) (digit3: bool)
     (digit4: bool) (digit5: bool) (digit6: bool) (digit7: bool)
type_synonym word = "(byte * byte)"
type_synonym dword = "(byte * byte * byte * byte)"
type_synonym lword = "(byte * byte * byte * byte * byte * byte * byte * byte)"

context comm_semiring_1
begin

definition of_byte :: \<open>byte \<Rightarrow> 'a\<close>
  where \<open>of_byte c = horner_sum of_bool 2 [digit0 c, digit1 c, digit2 c, digit3 c, digit4 c, digit5 c, digit6 c, digit7 c]\<close>

lemma of_byte_Byte [simp]:
  \<open>of_byte (Byte b0 b1 b2 b3 b4 b5 b6 b7) =
    horner_sum of_bool 2 [b0, b1, b2, b3, b4, b5, b6, b7]\<close>
  by (simp add: of_byte_def)

end

lemma (in comm_semiring_1) of_nat_of_char:
  \<open>of_nat (of_byte c) = of_byte c\<close>
  by (cases c) simp

lemma (in comm_ring_1) of_int_of_char:
  \<open>of_int (of_byte c) = of_byte c\<close>
  by (cases c) simp

lemma nat_of_byte [simp]:
  \<open>nat (of_byte c) = of_byte c\<close>
  by (cases c) (simp only: of_byte_Byte nat_horner_sum)

context unique_euclidean_semiring_with_bit_operations
begin
definition byte_of :: \<open>'a \<Rightarrow> byte\<close>
  where \<open>byte_of n = Byte (bit n 0) (bit n 1) (bit n 2) (bit n 3) (bit n 4) (bit n 5) (bit n 6) (bit n 7)\<close>
end

definition byte_of_integer :: "integer \<Rightarrow> byte"
  where [code_abbrev]: "byte_of_integer = byte_of"

definition integer_of_byte :: "byte \<Rightarrow> integer"
  where [code_abbrev]: "integer_of_byte = of_byte"

lemma byte_of_integer_code [code]:
  "byte_of_integer k = (let
     (q0, b0) = bit_cut_integer k;
     (q1, b1) = bit_cut_integer q0;
     (q2, b2) = bit_cut_integer q1;
     (q3, b3) = bit_cut_integer q2;
     (q4, b4) = bit_cut_integer q3;
     (q5, b5) = bit_cut_integer q4;
     (q6, b6) = bit_cut_integer q5;
     (_, b7) = bit_cut_integer q6
    in Byte b0 b1 b2 b3 b4 b5 b6 b7)"
  by (simp add: bit_cut_integer_def byte_of_integer_def byte_of_def div_mult2_numeral_eq bit_iff_odd_drop_bit drop_bit_eq_div)

lemma integer_of_byte_code [code]:
  "integer_of_byte (Byte b0 b1 b2 b3 b4 b5 b6 b7) =
    ((((((of_bool b7 * 2 + of_bool b6) * 2 +
      of_bool b5) * 2 + of_bool b4) * 2 +
        of_bool b3) * 2 + of_bool b2) * 2 +
          of_bool b1) * 2 + of_bool b0"
  by (simp add: integer_of_byte_def of_byte_def)

end


theory PropResPI_PPS
  imports PropResPI.Propositional_Resolution Propositional_Proof_Systems.CNF_Sema
(* Uuuh, I smell naming clashes. *)
begin

locale PRPI_PPS = propositional_atoms
begin

primrec pplit_of_prlit :: "'a Literal \<Rightarrow> 'a literal" where
"pplit_of_prlit (Pos a) = a\<^sup>+" |
"pplit_of_prlit (Neg a) = a\<inverse>"
primrec prlit_of_pplit :: "'a literal \<Rightarrow> 'a Literal" where
"prlit_of_pplit (a\<^sup>+) = (Pos a)" |
"prlit_of_pplit (a\<inverse>) = (Neg a)"
definition "ppcnf_of_prform = (op ` \<circ> op `) pplit_of_prlit"
definition "prform_of_ppcnf = (op ` \<circ> op `) prlit_of_pplit"

definition "ppval_of_printerp (I :: 'a Interpretation) \<equiv> (\<lambda>n. n \<in> I)"
definition "printerp_of_ppval \<A> = Collect \<A>"

lemmas ppprdefs = ppcnf_of_prform_def prform_of_ppcnf_def
                 ppval_of_printerp_def printerp_of_ppval_def

lemma ppprlit: "lit_semantics v (pplit_of_prlit x) = validate_literal (printerp_of_ppval v) x"
  by(cases x; simp add: ppprdefs)

lemma pppr_vicf: "cnf_semantics (ppval_of_printerp I) (ppcnf_of_prform S) = validate_formula I S"
proof -
  have "lit_semantics (\<lambda>n. n \<in> I) (pplit_of_prlit x) = I \<Turnstile> x" for x
    by(cases x; simp)
  hence "Bex (pplit_of_prlit ` x) (lit_semantics (\<lambda>n. n \<in> I)) = I \<Turnstile> x" for x
    unfolding bex_simps validate_clause.simps Bex_def[symmetric]
    by presburger
  thus ?thesis
    unfolding ppprdefs comp_def Ball_def[symmetric]
            cnf_semantics_def clause_semantics_def validate_formula.simps
    unfolding ball_simps
    by presburger
qed

lemma pppr_ivcf: "cnf_semantics \<A> (ppcnf_of_prform S) = validate_formula (printerp_of_ppval \<A>) S"
  unfolding pppr_vicf[symmetric]
  unfolding ppval_of_printerp_def printerp_of_ppval_def
  by simp

lemma pppr_ivfc: "validate_formula (printerp_of_ppval \<A>) (prform_of_ppcnf C) = cnf_semantics \<A> C"
proof -
  have "pplit_of_prlit (prlit_of_pplit x) = x" for x
    by(cases x; simp)
  thus ?thesis
    unfolding pppr_vicf[symmetric]
    unfolding ppval_of_printerp_def printerp_of_ppval_def
    unfolding ppprdefs comp_def image_comp
    by simp
qed

lemma pppr_vifc: "validate_formula I (prform_of_ppcnf C) = cnf_semantics (ppval_of_printerp I) C"
  using pppr_ivcf pppr_ivfc pppr_vicf by blast


theory ShortestPathNeg

(*
  This theory uses the graph library and
  several lemmas that were proven in the
  shortest path theory
*)
imports ShortestPath

begin
section \<open>Shortest Path (with general edge costs)\<close>
(*
  In this locale we assume we are given a
  wellformed directed graph $G = (V,E)$ with
  finite $V$ and $E$ (this is the assumption
  $graphG$). Moreover, a source vertex $s$ in
  $V$ . In addition, a cost function c, a function
 $num:V\to \Nat$, $parent\dash edge:V\to E \cup $*)
locale shortest_paths_locale_step1 =
  fixes G :: "('a, 'b) pre_digraph" (structure)
  fixes s :: "'a"
  fixes c :: "'b \<Rightarrow> real"
  fixes num :: "'a \<Rightarrow> nat"
  fixes parent_edge :: "'a \<Rightarrow> 'b option"
  fixes dist :: "'a  \<Rightarrow> ereal"
  assumes graphG: "fin_digraph G"
  assumes s_assms:
    "s \<in> verts G"
    "dist s \<noteq> \<infinity>"
    "parent_edge s = None"
    "num s = 0"
  assumes  parent_num_assms:
    "\<And>v.  \<lbrakk>v \<in> verts G; v \<noteq> s; dist v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
    (\<exists>e \<in> arcs G. parent_edge v = Some e \<and>
    head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
    num v  = num (tail G e) + 1)"
 (* assumes noPedge: "\<And>e. e\<in>arcs G \<Longrightarrow>
    dist (tail G e) \<noteq> \<infinity> \<Longrightarrow> dist (head G e) \<noteq> \<infinity>"*)

sublocale shortest_paths_locale_step1 \<subseteq> fin_digraph G
  using graphG by auto

definition (in shortest_paths_locale_step1) enum :: "'a \<Rightarrow> enat" where
  "enum v = (if (dist v = \<infinity> \<or> dist v = - \<infinity>) then \<infinity> else num v)"

locale shortest_paths_locale_step2 =
  shortest_paths_locale_step1 +
  basic_just_sp G dist c s enum +
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"

lemma (in basic_sp) noPedge:
  "\<And>e. e\<in>arcs G \<Longrightarrow>
    dist (tail G e) \<noteq> \<infinity> \<Longrightarrow> dist (head G e) \<noteq> \<infinity>"
  by (case_tac "dist (head G e)") (fastforce dest: trian)+

function (in shortest_paths_locale_step1) pwalk :: "'a \<Rightarrow> 'b list"
where
  "pwalk v =
    (if (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G)
      then []
      else pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]
    )"
by auto
termination (in shortest_paths_locale_step1)
  using parent_num_assms
  by (relation "measure num", auto, fastforce)

lemma (in shortest_paths_locale_step1) pwalk_simps:
  "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G \<Longrightarrow> pwalk v = []"
  "v \<noteq> s \<Longrightarrow> dist v \<noteq> \<infinity> \<Longrightarrow> v \<in> verts G \<Longrightarrow>
    pwalk v = pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]"
by auto

definition (in shortest_paths_locale_step1) pwalk_verts :: "'a  \<Rightarrow> 'a set" where
  "pwalk_verts v = {u. u \<in> set (awalk_verts s (pwalk v))}"

locale shortest_paths_locale_step3 =
  shortest_paths_locale_step2 +
  fixes C :: "('a \<times>('b awalk)) set"
  assumes C_se:
    "C \<subseteq> {(u, p). dist u \<noteq> \<infinity> \<and> awalk u p u \<and> awalk_cost c p < 0}"
  assumes int_neg_cyc:
    "\<And>v. v \<in> verts G \<Longrightarrow> dist v = -\<infinity> \<Longrightarrow>
      (fst ` C) \<inter> pwalk_verts v  \<noteq> {}"

locale shortest_paths_locale_step2_pred =
  shortest_paths_locale_step1 +
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes bj: "basic_just_sp_pred G dist c s enum pred"
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"

sublocale shortest_paths_locale_step2_pred \<subseteq> shortest_paths_locale_step2
  using shortest_paths_locale_step2_pred_axioms
  unfolding shortest_paths_locale_step2_pred_def
   shortest_paths_locale_step2_pred_axioms_def
   shortest_paths_locale_step2_def
   shortest_paths_locale_step2_axioms_def
   basic_just_sp_pred_def
   basic_just_sp_def
   basic_just_sp_axioms_def
   basic_just_sp_pred_axioms_def
  by blast

locale shortest_paths_locale_step3_pred =
  shortest_paths_locale_step2_pred +
  fixes C :: "('a \<times> ('b awalk)) set"
  assumes C_se:
    "C \<subseteq> {(u, p). dist u \<noteq> \<infinity> \<and> awalk u p u \<and> awalk_cost c p < 0}"
  assumes int_neg_cyc:
    "\<And>v. v \<in> verts G \<Longrightarrow> dist v = -\<infinity> \<Longrightarrow>
      (fst ` C) \<inter> pwalk_verts v \<noteq> {}"

sublocale shortest_paths_locale_step3_pred \<subseteq> shortest_paths_locale_step3
  using shortest_paths_locale_step3_pred_axioms
  unfolding shortest_paths_locale_step3_pred_def
   shortest_paths_locale_step3_pred_axioms_def
   shortest_paths_locale_step3_def
   shortest_paths_locale_step3_axioms_def
   shortest_paths_locale_step2_pred_def
   shortest_paths_locale_step2_pred_axioms_def
   shortest_paths_locale_step2_def
   shortest_paths_locale_step2_axioms_def
   basic_just_sp_pred_def
   basic_just_sp_def
   basic_just_sp_axioms_def
   basic_just_sp_pred_axioms_def
  by blast

lemma (in shortest_paths_locale_step1) num_s_is_min:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows "num v > 0"
     using parent_num_assms[OF assms] by fastforce

lemma (in shortest_paths_locale_step1) path_from_root_Vr_ex:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows  "\<exists>e. s \<rightarrow>\<^sup>* tail G e \<and>
          e \<in> arcs G \<and> head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
          parent_edge v = Some e \<and> num v = num (tail G e) + 1"
using assms
proof(induct "num v - 1" arbitrary : v)
case 0
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF 0(2-4)] by fast
  have "tail G e = s"
    using num_s_is_min[OF tail_in_verts [OF ee(1)] _ ee(3)]
    ee(5) 0(1) by auto
  then show ?case using ee by auto
next
case (Suc n')
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF Suc(3-5)] by fast
  then have ss: "tail G e \<noteq> s"
    using num_s_is_min tail_in_verts
    Suc(2) s_assms(4) by force
  have nst: "n' = num (tail G e) - 1"
    using ee(5) Suc(2) by presburger
  obtain e' where reach: "s \<rightarrow>\<^sup>* tail G e'" and
    e': "e' \<in> arcs G" "head G e' = tail G e" "dist (tail G e') \<noteq> \<infinity>"
    using Suc(1)[OF nst tail_in_verts[OF ee(1)] ss ee(3)] by blast
  then have "s \<rightarrow>\<^sup>* tail G e"
    by (metis arc_implies_awalk reachable_awalk reachable_trans)
  then show ?case using e' ee by auto
qed

lemma (in shortest_paths_locale_step1) path_from_root_Vr:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "s \<rightarrow>\<^sup>* v"
proof(cases "v = s")
case True thus ?thesis using assms by simp
next
case False
  obtain e where "s \<rightarrow>\<^sup>* tail G e" "e \<in> arcs G" "head G e = v"
      using path_from_root_Vr_ex[OF assms(1) False assms(2)] by blast
  then have "s \<rightarrow>\<^sup>* tail G e" "tail G e \<rightarrow> v"
    by (auto intro: in_arcs_imp_in_arcs_ends)
  then show ?thesis by (rule reachable_adj_trans)
qed

lemma (in shortest_paths_locale_step1) \<mu>_V_less_inf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "\<mu> c s v \<noteq> \<infinity>"
  using assms path_from_root_Vr \<mu>_reach_conv by force

lemma (in shortest_paths_locale_step2) enum_not0:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "enum v \<noteq> \<infinity>"
  shows "enum v \<noteq> enat 0"
     using parent_num_assms[OF assms(1,2)] assms unfolding enum_def by auto

lemma (in shortest_paths_locale_step2) dist_Vf_\<mu>:
  fixes v :: 'a
  assumes vG: "v \<in> verts G"
  assumes "\<exists>r. dist v = ereal r"
  shows "dist v = \<mu> c s v"
proof -
  have ds: "dist s =  0"
    using assms source_val unfolding enum_def by force
  have ews:"awalk s [] s"
    using s_assms(1) unfolding awalk_def by simp
  have mu: "\<mu> c s s = ereal 0"
    using min_cost_le_walk_cost[OF ews, where c=c]
    awalk_cost_Nil ds  dist_le_\<mu>[OF s_assms(1)] zero_ereal_def
    by simp
  thus ?thesis
    using ds assms dist_le_\<mu>[OF vG]
    dist_ge_\<mu>[OF vG _ _ mu ds enum_not0]
    unfolding enum_def by fastforce
qed

lemma (in shortest_paths_locale_step1) pwalk_awalk:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "awalk s (pwalk v) v"
proof (cases "v=s")
case True
  thus ?thesis
    using assms pwalk.simps[where v=v]
    awalk_Nil_iff by presburger
next
case False
  from assms show ?thesis
  proof (induct rule: pwalk.induct)
    fix v
    let ?e = "the (parent_edge v)"
    let ?u = "tail G ?e"
    assume ewu: "\<not> (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G) \<Longrightarrow>
                 ?u \<in> verts G \<Longrightarrow> dist ?u \<noteq> \<infinity> \<Longrightarrow>
                 awalk s (pwalk ?u) ?u"
    assume vG: "v \<in> verts G"
    assume dv: "dist v \<noteq> \<infinity>"
    thus "awalk s (pwalk v) v "
    proof (cases "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G")
    case True
      thus ?thesis
        using pwalk.simps vG dv
        awalk_Nil_iff by fastforce
    next
    case False
      obtain e  where ee:
        "e \<in>arcs G"
        "parent_edge v = Some e"
        "head G e = v"
        "dist (tail G e) \<noteq> \<infinity>"
        using parent_num_assms False by blast
      hence "awalk s (pwalk ?u) ?u"
        using ewu[OF False] tail_in_verts by simp
      hence "awalk s (pwalk (tail G e) @ [e]) v"
        using ee(1-3) vG
        by (auto simp: awalk_simps simp del: pwalk.simps)
      also have "pwalk (tail G e) @ [e] = pwalk v"
        using False ee(2) unfolding pwalk.simps[where v=v] by auto
      finally show ?thesis .
    qed
  qed
qed

lemma (in shortest_paths_locale_step3) \<mu>_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v = - \<infinity>"
  shows "\<mu> c s v = - \<infinity>"
proof -
  have "awalk s (pwalk v) v"
    using pwalk_awalk assms by force
moreover
  obtain w where ww: "w \<in> fst ` C \<inter> pwalk_verts v"
    using int_neg_cyc[OF assms] by blast
  then obtain q where
     "awalk w q w"
     "awalk_cost c q < 0"
     using C_se by auto
moreover
  have "w \<in> set (awalk_verts s (pwalk v))"
    using ww unfolding pwalk_verts_def by fast
ultimately
  show ?thesis using  neg_cycle_imp_inf_\<mu> by force
qed

lemma (in shortest_paths_locale_step3) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
proof(cases "dist v")
show " \<And>r. dist v = ereal r \<Longrightarrow> dist v = \<mu> c s v"
  using dist_Vf_\<mu>[OF assms] by simp
next
show "dist v = \<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_V_less_inf[OF assms]
  dist_le_\<mu>[OF assms] by simp
next
show "dist v = -\<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_ninf[OF assms] by simp
qed

corollary (in shortest_paths_locale_step3_pred) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  by (simp add: assms correct_shortest_path)

end


(*  Title:      HOL/UNITY/Follows.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section\<open>The Follows Relation of Charpentier and Sivilotte\<close>

theory Follows
imports SubstAx ListOrder "~~/src/HOL/Library/Multiset"
begin

definition Follows :: "['a => 'b::{order}, 'a => 'b::{order}] => 'a program set" (infixl "Fols" 65) where
   "f Fols g == Increasing g \<inter> Increasing f Int
                Always {s. f s \<le> g s} Int
                (\<Inter>k. {s. k \<le> g s} LeadsTo {s. k \<le> f s})"

(*Does this hold for "invariant"?*)
lemma mono_Always_o:
     "mono h ==> Always {s. f s \<le> g s} \<subseteq> Always {s. h (f s) \<le> h (g s)}"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: monoD)
done

lemma mono_LeadsTo_o:
     "mono (h::'a::order => 'b::order)
      ==> (\<Inter>j. {s. j \<le> g s} LeadsTo {s. j \<le> f s}) \<subseteq>
          (\<Inter>k. {s. k \<le> h (g s)} LeadsTo {s. k \<le> h (f s)})"
apply auto
apply (rule single_LeadsTo_I)
apply (drule_tac x = "g s" in spec)
apply (erule LeadsTo_weaken)
apply (blast intro: monoD order_trans)+
done

lemma Follows_constant [iff]: "F \<in> (%s. c) Fols (%s. c)"
by (simp add: Follows_def)

lemma mono_Follows_o:
  assumes "mono h"
  shows "f Fols g \<subseteq> (h o f) Fols (h o g)"
proof
  fix x
  assume "x \<in> f Fols g"
  with assms show "x \<in> (h \<circ> f) Fols (h \<circ> g)"
  by (auto simp add: Follows_def mono_Increasing_o [THEN [2] rev_subsetD]
    mono_Always_o [THEN [2] rev_subsetD]
    mono_LeadsTo_o [THEN [2] rev_subsetD, THEN INT_D])
qed

lemma mono_Follows_apply:
     "mono h ==> f Fols g \<subseteq> (%x. h (f x)) Fols (%x. h (g x))"
apply (drule mono_Follows_o)
apply (force simp add: o_def)
done

lemma Follows_trans:
     "[| F \<in> f Fols g;  F \<in> g Fols h |] ==> F \<in> f Fols h"
apply (simp add: Follows_def)
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: order_trans LeadsTo_Trans)
done

subsection\<open>Destruction rules\<close>

lemma Follows_Increasing1: "F \<in> f Fols g ==> F \<in> Increasing f"
by (simp add: Follows_def)

lemma Follows_Increasing2: "F \<in> f Fols g ==> F \<in> Increasing g"
by (simp add: Follows_def)

lemma Follows_Bounded: "F \<in> f Fols g ==> F \<in> Always {s. f s \<le> g s}"
by (simp add: Follows_def)

lemma Follows_LeadsTo:
     "F \<in> f Fols g ==> F \<in> {s. k \<le> g s} LeadsTo {s. k \<le> f s}"
by (simp add: Follows_def)

lemma Follows_LeadsTo_pfixLe:
     "F \<in> f Fols g ==> F \<in> {s. k pfixLe g s} LeadsTo {s. k pfixLe f s}"
apply (rule single_LeadsTo_I, clarify)
apply (drule_tac k="g s" in Follows_LeadsTo)
apply (erule LeadsTo_weaken)
 apply blast
apply (blast intro: pfixLe_trans prefix_imp_pfixLe)
done

lemma Follows_LeadsTo_pfixGe:
     "F \<in> f Fols g ==> F \<in> {s. k pfixGe g s} LeadsTo {s. k pfixGe f s}"
apply (rule single_LeadsTo_I, clarify)
apply (drule_tac k="g s" in Follows_LeadsTo)
apply (erule LeadsTo_weaken)
 apply blast
apply (blast intro: pfixGe_trans prefix_imp_pfixGe)
done

lemma Always_Follows1:
     "[| F \<in> Always {s. f s = f' s}; F \<in> f Fols g |] ==> F \<in> f' Fols g"

apply (simp add: Follows_def Increasing_def Stable_def, auto)
apply (erule_tac [3] Always_LeadsTo_weaken)
apply (erule_tac A = "{s. x \<le> f s}" and A' = "{s. x \<le> f s}"
       in Always_Constrains_weaken, auto)
apply (drule Always_Int_I, assumption)
apply (force intro: Always_weaken)
done

lemma Always_Follows2:
     "[| F \<in> Always {s. g s = g' s}; F \<in> f Fols g |] ==> F \<in> f Fols g'"
apply (simp add: Follows_def Increasing_def Stable_def, auto)
apply (erule_tac [3] Always_LeadsTo_weaken)
apply (erule_tac A = "{s. x \<le> g s}" and A' = "{s. x \<le> g s}"
       in Always_Constrains_weaken, auto)
apply (drule Always_Int_I, assumption)
apply (force intro: Always_weaken)
done

subsection\<open>Union properties (with the subset ordering)\<close>

(*Can replace "Un" by any sup.  But existing max only works for linorders.*)

lemma increasing_Un:
    "[| F \<in> increasing f;  F \<in> increasing g |]
     ==> F \<in> increasing (%s. (f s) \<union> (g s))"
apply (simp add: increasing_def stable_def constrains_def, auto)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (blast dest!: bspec)
done

lemma Increasing_Un:
    "[| F \<in> Increasing f;  F \<in> Increasing g |]
     ==> F \<in> Increasing (%s. (f s) \<union> (g s))"
apply (auto simp add: Increasing_def Stable_def Constrains_def
                      stable_def constrains_def)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (blast dest!: bspec)
done

lemma Always_Un:
     "[| F \<in> Always {s. f' s \<le> f s}; F \<in> Always {s. g' s \<le> g s} |]
      ==> F \<in> Always {s. f' s \<union> g' s \<le> f s \<union> g s}"
by (simp add: Always_eq_includes_reachable, blast)

(*Lemma to re-use the argument that one variable increases (progress)
  while the other variable doesn't decrease (safety)*)
lemma Follows_Un_lemma:
     "[| F \<in> Increasing f; F \<in> Increasing g;
         F \<in> Increasing g'; F \<in> Always {s. f' s \<le> f s};
         \<forall>k. F \<in> {s. k \<le> f s} LeadsTo {s. k \<le> f' s} |]
      ==> F \<in> {s. k \<le> f s \<union> g s} LeadsTo {s. k \<le> f' s \<union> g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in IncreasingD)
apply (drule_tac x = "g s" in IncreasingD)
apply (rule LeadsTo_weaken)
apply (rule PSP_Stable)
apply (erule_tac x = "f s" in spec)
apply (erule Stable_Int, assumption, blast+)
done

lemma Follows_Un:
    "[| F \<in> f' Fols f;  F \<in> g' Fols g |]
     ==> F \<in> (%s. (f' s) \<union> (g' s)) Fols (%s. (f s) \<union> (g s))"
apply (simp add: Follows_def Increasing_Un Always_Un del: Un_subset_iff sup.bounded_iff, auto)
apply (rule LeadsTo_Trans)
apply (blast intro: Follows_Un_lemma)
(*Weakening is used to exchange Un's arguments*)
apply (blast intro: Follows_Un_lemma [THEN LeadsTo_weaken])
done

subsection\<open>Multiset union properties (with the multiset ordering)\<close>

lemma increasing_union:
    "[| F \<in> increasing f;  F \<in> increasing g |]
     ==> F \<in> increasing (%s. (f s) + (g s :: ('a::order) multiset))"
apply (simp add: increasing_def stable_def constrains_def, auto)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (drule bspec, assumption)
apply (blast intro: add_mono order_trans)
done

lemma Increasing_union:
    "[| F \<in> Increasing f;  F \<in> Increasing g |]
     ==> F \<in> Increasing (%s. (f s) + (g s :: ('a::order) multiset))"
apply (auto simp add: Increasing_def Stable_def Constrains_def
                      stable_def constrains_def)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (drule bspec, assumption)
apply (blast intro: add_mono order_trans)
done

lemma Always_union:
     "[| F \<in> Always {s. f' s \<le> f s}; F \<in> Always {s. g' s \<le> g s} |]
      ==> F \<in> Always {s. f' s + g' s \<le> f s + (g s :: ('a::order) multiset)}"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: add_mono)
done

(*Except the last line, IDENTICAL to the proof script for Follows_Un_lemma*)
lemma Follows_union_lemma:
     "[| F \<in> Increasing f; F \<in> Increasing g;
         F \<in> Increasing g'; F \<in> Always {s. f' s \<le> f s};
         \<forall>k::('a::order) multiset.
           F \<in> {s. k \<le> f s} LeadsTo {s. k \<le> f' s} |]
      ==> F \<in> {s. k \<le> f s + g s} LeadsTo {s. k \<le> f' s + g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in IncreasingD)
apply (drule_tac x = "g s" in IncreasingD)
apply (rule LeadsTo_weaken)
apply (rule PSP_Stable)
apply (erule_tac x = "f s" in spec)
apply (erule Stable_Int, assumption, blast)
apply (blast intro: add_mono order_trans)
done

(*The !! is there to influence to effect of permutative rewriting at the end*)
lemma Follows_union:
     "!!g g' ::'b => ('a::order) multiset.
        [| F \<in> f' Fols f;  F \<in> g' Fols g |]
        ==> F \<in> (%s. (f' s) + (g' s)) Fols (%s. (f s) + (g s))"
apply (simp add: Follows_def)
apply (simp add: Increasing_union Always_union, auto)
apply (rule LeadsTo_Trans)
apply (blast intro: Follows_union_lemma)
(*now exchange union's arguments*)
apply (simp add: union_commute)
apply (blast intro: Follows_union_lemma)
done

lemma Follows_sum:
     "!!f ::['c,'b] => ('a::order) multiset.
        [| \<forall>i \<in> I. F \<in> f' i Fols f i;  finite I |]
        ==> F \<in> (%s. \<Sum>i \<in> I. f' i s) Fols (%s. \<Sum>i \<in> I. f i s)"
apply (erule rev_mp)
apply (erule finite_induct, simp)
apply (simp add: Follows_union)
done

(*Currently UNUSED, but possibly of interest*)
lemma Increasing_imp_Stable_pfixGe:
     "F \<in> Increasing func ==> F \<in> Stable {s. h pfixGe (func s)}"
apply (simp add: Increasing_def Stable_def Constrains_def constrains_def)
apply (blast intro: trans_Ge [THEN trans_genPrefix, THEN transD]
                    prefix_imp_pfixGe)
done

(*Currently UNUSED, but possibly of interest*)
lemma LeadsTo_le_imp_pfixGe:
     "\<forall>z. F \<in> {s. z \<le> f s} LeadsTo {s. z \<le> g s}
      ==> F \<in> {s. z pfixGe f s} LeadsTo {s. z pfixGe g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in spec)
apply (erule LeadsTo_weaken)
 prefer 2
 apply (blast intro: trans_Ge [THEN trans_genPrefix, THEN transD]
                     prefix_imp_pfixGe, blast)
done

end