theory Primitive_Normalization
imports Negation_Type_Matching
begin

section\<open>Primitive Normalization\<close>

subsection\<open>Normalized Primitives\<close>

text\<open>
  Test if a @{text disc} is in the match expression.
  For example, it call tell whether there are some matches for @{text "Src ip"}.
\<close>
fun has_disc :: "('a \<Rightarrow> bool) \<Rightarrow> 'a match_expr \<Rightarrow> bool" where
  "has_disc _ MatchAny = False" |
  "has_disc disc (Match a) = disc a" |
  "has_disc disc (MatchNot m) = has_disc disc m" |
  "has_disc disc (MatchAnd m1 m2) = (has_disc disc m1 \<or> has_disc disc m2)"

fun has_disc_negated :: "('a \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> 'a match_expr \<Rightarrow> bool" where
  "has_disc_negated _    _   MatchAny = False" |
  "has_disc_negated disc neg (Match a) = (if disc a then neg else False)" |
  "has_disc_negated disc neg (MatchNot m) = has_disc_negated disc (\<not> neg) m" |
  "has_disc_negated disc neg (MatchAnd m1 m2) = (has_disc_negated disc neg m1 \<or> has_disc_negated disc neg m2)"

lemma "\<not> has_disc_negated (\<lambda>x::nat. x = 0) False (MatchAnd (Match 0) (MatchNot (Match 1)))" by eval
lemma "has_disc_negated (\<lambda>x::nat. x = 0) False (MatchAnd (Match 0) (MatchNot (Match 0)))" by eval
lemma "has_disc_negated (\<lambda>x::nat. x = 0) True (MatchAnd (Match 0) (MatchNot (Match 1)))" by eval
lemma "\<not> has_disc_negated (\<lambda>x::nat. x = 0) True (MatchAnd (Match 1) (MatchNot (Match 0)))" by eval
lemma "has_disc_negated (\<lambda>x::nat. x = 0) True (MatchAnd (Match 0) (MatchNot (Match 0)))" by eval

-- "We want false on the right hand side, because this is how the algorithm should be started"
lemma has_disc_negated_MatchNot:
  "has_disc_negated disc True (MatchNot m) \<longleftrightarrow> has_disc_negated disc False m"
  "has_disc_negated disc True m \<longleftrightarrow> has_disc_negated disc False (MatchNot m)"
  by(induction m) (simp_all)

lemma has_disc_negated_has_disc: "has_disc_negated disc neg m \<Longrightarrow> has_disc disc m"
  apply(induction m arbitrary: neg)
     apply(simp_all split: if_split_asm)
  by blast

lemma has_disc_negated_positiv_has_disc: "has_disc_negated disc neg m \<or> has_disc_negated disc (\<not> neg) m \<longleftrightarrow> has_disc disc m"
by(induction disc neg m arbitrary: neg rule:has_disc_negated.induct) auto

lemma has_disc_negated_disj_split:
    "has_disc_negated (\<lambda>a. P a \<or> Q a) neg m \<longleftrightarrow> has_disc_negated P neg m \<or> has_disc_negated Q neg m"
  apply(induction "(\<lambda>a. P a \<or> Q a)" neg m rule: has_disc_negated.induct)
     apply(simp_all)
  by blast

lemma has_disc_alist_and: "has_disc disc (alist_and as) \<longleftrightarrow> (\<exists> a \<in> set as. has_disc disc (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_negated_alist_and: "has_disc_negated disc neg (alist_and as) \<longleftrightarrow> (\<exists> a \<in> set as. has_disc_negated disc neg (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)

lemma has_disc_alist_and': "has_disc disc (alist_and' as) \<longleftrightarrow> (\<exists> a \<in> set as. has_disc disc (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and'.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)
lemma has_disc_negated_alist_and': "has_disc_negated disc neg (alist_and' as) \<longleftrightarrow> (\<exists> a \<in> set as. has_disc_negated disc neg (negation_type_to_match_expr a))"
  proof(induction as rule: alist_and'.induct)
  qed(simp_all add: negation_type_to_match_expr_simps)

lemma has_disc_alist_and'_append:
  "has_disc disc' (alist_and' (ls1 @ ls2)) \<longleftrightarrow>
      has_disc disc' (alist_and' ls1) \<or> has_disc disc' (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
    apply(simp_all)
 apply(case_tac [!] ls2)
   apply(simp_all)
done
lemma has_disc_negated_alist_and'_append:
  "has_disc_negated disc' neg (alist_and' (ls1 @ ls2)) \<longleftrightarrow>
      has_disc_negated disc' neg (alist_and' ls1) \<or> has_disc_negated disc' neg (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
    apply(simp_all)
 apply(case_tac [!] ls2)
   apply(simp_all)
done

lemma match_list_to_match_expr_not_has_disc:
    "\<forall>a. \<not> disc (X a) \<Longrightarrow> \<not> has_disc disc (match_list_to_match_expr (map (Match \<circ> X) ls))"
  apply(induction ls)
   apply(simp; fail)
  by(simp add: MatchOr_def)

lemma "matches ((\<lambda>x _. bool_to_ternary (disc x)), (\<lambda>_ _. False)) (Match x) a p \<longleftrightarrow> has_disc disc (Match x)"
by(simp add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split )

fun normalized_n_primitive :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a match_expr \<Rightarrow> bool" where
  "normalized_n_primitive _ _ MatchAny = True" |
  "normalized_n_primitive (disc, sel) n (Match P) = (if disc P then n (sel P) else True)" |
  "normalized_n_primitive (disc, sel) n (MatchNot (Match P)) = (if disc P then False else True)" |
  "normalized_n_primitive (disc, sel) n (MatchAnd m1 m2) = (normalized_n_primitive (disc, sel) n m1 \<and> normalized_n_primitive (disc, sel) n m2)" |
  "normalized_n_primitive _ _ (MatchNot (MatchAnd _ _)) = False" |
  (*"normalized_n_primitive _ _ (MatchNot _) = True" *)
  "normalized_n_primitive _ _ (MatchNot (MatchNot _)) = False" | (*not nnf normalized*)
  "normalized_n_primitive _ _ (MatchNot MatchAny) = True"

lemma normalized_nnf_match_opt_MatchAny_match_expr:
  "normalized_nnf_match m \<Longrightarrow> normalized_nnf_match (opt_MatchAny_match_expr m)"
  proof-
  have "normalized_nnf_match m \<Longrightarrow> normalized_nnf_match (opt_MatchAny_match_expr_once m)"
  for m :: "'a match_expr"
  by(induction m rule: opt_MatchAny_match_expr_once.induct) (simp_all)
  thus "normalized_nnf_match m \<Longrightarrow> normalized_nnf_match (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(induction rule: repeat_stabilize_induct)
     by(simp)+
  qed

lemma normalized_n_primitive_opt_MatchAny_match_expr:
  "normalized_n_primitive disc_sel f m \<Longrightarrow> normalized_n_primitive disc_sel f (opt_MatchAny_match_expr m)"
  proof-

  have "normalized_n_primitive disc_sel f m \<Longrightarrow> normalized_n_primitive disc_sel f (opt_MatchAny_match_expr_once m)"
  for m
    proof-
    { fix disc::"('a \<Rightarrow> bool)" and sel::"('a \<Rightarrow> 'b)" and n m1 m2
      have "normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once m1) \<Longrightarrow>
           normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once m2) \<Longrightarrow>
           normalized_n_primitive (disc, sel) n m1 \<and> normalized_n_primitive (disc, sel) n m2 \<Longrightarrow>
           normalized_n_primitive (disc, sel) n (opt_MatchAny_match_expr_once (MatchAnd m1 m2))"
    by(induction "(MatchAnd m1 m2)" rule: opt_MatchAny_match_expr_once.induct) (auto)
    }note x=this
    assume "normalized_n_primitive disc_sel f m"
    thus ?thesis
      apply(induction disc_sel f m rule: normalized_n_primitive.induct)
            apply simp_all
      using x by simp
    qed
  from this show
    "normalized_n_primitive disc_sel f m \<Longrightarrow> normalized_n_primitive disc_sel f (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(induction rule: repeat_stabilize_induct)
     by(simp)+
  qed

lemma normalized_n_primitive_imp_not_disc_negated:
  "wf_disc_sel (disc,sel) C \<Longrightarrow> normalized_n_primitive (disc,sel) f m \<Longrightarrow> \<not> has_disc_negated disc False m"
  apply(induction "(disc,sel)" f m rule: normalized_n_primitive.induct)
  by(simp add: wf_disc_sel.simps split: if_split_asm)+

lemma normalized_n_primitive_alist_and: "normalized_n_primitive disc_sel P (alist_and as) \<longleftrightarrow>
      (\<forall> a \<in> set as. normalized_n_primitive disc_sel P (negation_type_to_match_expr a))"
  proof(induction as)
  case Nil thus ?case by simp
  next
  case (Cons a as) thus ?case
    apply(cases disc_sel, cases a)
    by(simp_all add: negation_type_to_match_expr_simps)
  qed

lemma normalized_n_primitive_alist_and': "normalized_n_primitive disc_sel P (alist_and' as) \<longleftrightarrow>
      (\<forall> a \<in> set as. normalized_n_primitive disc_sel P (negation_type_to_match_expr a))"
  apply(cases disc_sel)
  apply(induction as rule: alist_and'.induct)
      by(simp_all add: negation_type_to_match_expr_simps)

lemma not_has_disc_NegPos_map: "\<forall>a. \<not> disc (C a) \<Longrightarrow> \<forall>a\<in>set (NegPos_map C ls).
        \<not> has_disc disc (negation_type_to_match_expr a)"
by(induction C ls rule: NegPos_map.induct) (simp add: negation_type_to_match_expr_def)+

lemma not_has_disc_negated_NegPos_map: "\<forall>a. \<not> disc (C a) \<Longrightarrow> \<forall>a\<in>set (NegPos_map C ls).
        \<not> has_disc_negated disc False (negation_type_to_match_expr a)"
by(induction C ls rule: NegPos_map.induct) (simp add: negation_type_to_match_expr_def)+

lemma normalized_n_primitive_impossible_map: "\<forall>a. \<not> disc (C a) \<Longrightarrow>
  \<forall>m\<in>set (map (Match \<circ> (C \<circ> x)) ls).
     normalized_n_primitive (disc, sel) f m"
  apply(intro ballI)
  apply(induction ls)
   apply(simp; fail)
  apply(simp)
  apply(case_tac m, simp_all) (*3 cases are impossible*)
   apply(fastforce)
  by force

lemma normalized_n_primitive_alist_and'_append:
  "normalized_n_primitive (disc, sel) f (alist_and' (ls1 @ ls2)) \<longleftrightarrow>
      normalized_n_primitive (disc, sel) f (alist_and' ls1) \<and> normalized_n_primitive (disc, sel) f (alist_and' ls2)"
apply(induction ls1 arbitrary: ls2 rule: alist_and'.induct)
    apply(simp_all)
 apply(case_tac [!] ls2)
   apply(simp_all)
done

lemma normalized_n_primitive_if_no_primitive: "normalized_nnf_match m \<Longrightarrow> \<not> has_disc disc m \<Longrightarrow>
       normalized_n_primitive (disc, sel) f m"
  by(induction "(disc, sel)" f m rule: normalized_n_primitive.induct) (simp)+

lemma normalized_n_primitive_false_eq_notdisc: "normalized_nnf_match m \<Longrightarrow>
  normalized_n_primitive (disc, sel) (\<lambda>_. False) m \<longleftrightarrow> \<not> has_disc disc m"
proof -
  have "normalized_nnf_match m \<Longrightarrow> false = (\<lambda>_. False) \<Longrightarrow>
  \<not> has_disc disc m \<longleftrightarrow> normalized_n_primitive (disc, sel) false m" for false
  by(induction "(disc, sel)" false m rule: normalized_n_primitive.induct)
  (simp)+
  thus "normalized_nnf_match m \<Longrightarrow> ?thesis" by simp
qed

lemma normalized_n_primitive_MatchAnd_combine_map: "normalized_n_primitive disc_sel f rst \<Longrightarrow>
       \<forall>m' \<in> (\<lambda>spt. Match (C spt)) ` set pts. normalized_n_primitive disc_sel f m' \<Longrightarrow>
        m' \<in> (\<lambda>spt. MatchAnd (Match (C spt)) rst) ` set pts \<Longrightarrow> normalized_n_primitive disc_sel f m'"
  by(induction disc_sel f m' rule: normalized_n_primitive.induct)
     fastforce+

subsection\<open>Primitive Extractor\<close>

text\<open>
  The following function takes a tuple of functions (@{typ "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b))"}) and a @{typ "'a match_expr"}.
  The passed function tuple must be the discriminator and selector of the datatype package.
  @{text primitive_extractor} filters the @{typ "'a match_expr"} and returns a tuple.
  The first element of the returned tuple is the filtered primitive matches, the second element is the remaining match expression.

  It requires a @{const normalized_nnf_match}.
\<close>
fun primitive_extractor :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> 'a match_expr \<Rightarrow> ('b negation_type list \<times> 'a match_expr)" where
 "primitive_extractor _ MatchAny = ([], MatchAny)" |
 "primitive_extractor (disc,sel) (Match a) = (if disc a then ([Pos (sel a)], MatchAny) else ([], Match a))" |
 "primitive_extractor (disc,sel) (MatchNot (Match a)) = (if disc a then ([Neg (sel a)], MatchAny) else ([], MatchNot (Match a)))" |
 "primitive_extractor C (MatchAnd ms1 ms2) = (
        let (a1', ms1') = primitive_extractor C ms1;
            (a2', ms2') = primitive_extractor C ms2
        in (a1'@a2', MatchAnd ms1' ms2'))" |
 "primitive_extractor _ _ = undefined"

text\<open>
  The first part returned by @{const primitive_extractor}, here @{text as}:
    A list of primitive match expressions.
    For example, let @{text "m = MatchAnd (Src ip1) (Dst ip2)"} then, using the src @{text "(disc, sel)"}, the result is @{text "[ip1]"}.
    Note that @{text Src} is stripped from the result.

    The second part, here @{text ms} is the match expression which was not extracted.

    Together, the first and second part match iff @{text m} matches.
\<close>

(*unused*)
lemma primitive_extractor_fst_simp2:
  fixes m'::"'a match_expr \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr"
  shows "fst (case primitive_extractor (disc, sel) m1 of (a1', ms1') \<Rightarrow> case primitive_extractor (disc, sel) m2 of (a2', ms2') \<Rightarrow> (a1' @ a2', m' ms1' ms2')) =
           fst (primitive_extractor (disc, sel) m1) @ fst (primitive_extractor (disc, sel) m2)"
      apply(cases "primitive_extractor (disc, sel) m1", simp)
      apply(cases "primitive_extractor (disc, sel) m2", simp)
      done

theorem primitive_extractor_correct: assumes
  "normalized_nnf_match m" and "wf_disc_sel (disc, sel) C" and "primitive_extractor (disc, sel) m = (as, ms)"
  shows "matches \<gamma> (alist_and (NegPos_map C as)) a p \<and> matches \<gamma> ms a p \<longleftrightarrow> matches \<gamma> m a p"
  and "normalized_nnf_match ms"
  and "\<not> has_disc disc ms"
  and "\<forall>disc2. \<not> has_disc disc2 m \<longrightarrow> \<not> has_disc disc2 ms"
  and "\<forall>disc2 sel2. normalized_n_primitive (disc2, sel2) P m \<longrightarrow> normalized_n_primitive (disc2, sel2) P ms"
  and "\<forall>disc2. \<not> has_disc_negated disc2 neg m \<longrightarrow> \<not> has_disc_negated disc2 neg ms"
  and "\<not> has_disc disc m \<longleftrightarrow> as = [] \<and> ms = m"
  and "\<not> has_disc_negated disc False m \<longleftrightarrow> getNeg as = []"
  and "has_disc disc m \<Longrightarrow> as \<noteq> []"
proof -
  --"better simplification rule"
  from assms have assm3': "(as, ms) = primitive_extractor (disc, sel) m" by simp
  with assms(1) assms(2) show "matches \<gamma> (alist_and (NegPos_map C as)) a p \<and> matches \<gamma> ms a p \<longleftrightarrow> matches \<gamma> m a p"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 4 thus ?case
      apply(simp split: if_split_asm prod.split_asm add: NegPos_map_append)
      apply(auto simp add: alist_and_append bunch_of_lemmata_about_matches)
      done
    qed(simp_all add: bunch_of_lemmata_about_matches wf_disc_sel.simps split: if_split_asm)

  from assms(1) assm3' show "normalized_nnf_match ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
         case 2 thus ?case by(simp split: if_split_asm)
         next
         case 3 thus ?case by(simp split: if_split_asm)
         next
         case 4 thus ?case
           apply(clarify) (*if i don't clarify, the simplifier loops*)
           apply(simp split: prod.split_asm)
           done
    qed(simp_all)

  from assms(1) assm3' show "\<not> has_disc disc ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    qed(simp_all split: if_split_asm prod.split_asm)

  from assms(1) assm3' show "\<forall>disc2. \<not> has_disc disc2 m \<longrightarrow> \<not> has_disc disc2 ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
         case 2 thus ?case by(simp split: if_split_asm)
         next
         case 3 thus ?case by(simp split: if_split_asm)
         next
         case 4 thus ?case by(simp split: prod.split_asm)
    qed(simp_all)

  from assms(1) assm3' show "\<forall>disc2. \<not> has_disc_negated disc2 neg m \<longrightarrow> \<not> has_disc_negated disc2 neg ms"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
         case 2 thus ?case by(simp split: if_split_asm)
         next
         case 3 thus ?case by(simp split: if_split_asm)
         next
         case 4 thus ?case by(simp split: prod.split_asm)
    qed(simp_all)

  from assms(1) assm3' show "\<forall>disc2 sel2. normalized_n_primitive (disc2, sel2) P m \<longrightarrow> normalized_n_primitive (disc2, sel2) P ms"
    apply(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
          apply(simp)
         apply(simp split: if_split_asm)
        apply(simp split: if_split_asm)
       apply(simp split: prod.split_asm)
      apply(simp_all)
    done

   from assms(1) assm3' show "\<not> has_disc disc m \<longleftrightarrow> as = [] \<and> ms = m"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 2 thus ?case by(simp split: if_split_asm)
    next
    case 3 thus ?case by(simp split: if_split_asm)
    next
    case 4 thus ?case by(auto split: prod.split_asm)
    qed(simp_all)

   from assms(1) assm3' show "\<not> has_disc_negated disc False m \<longleftrightarrow> getNeg as = []"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 2 thus ?case by(simp split: if_split_asm)
    next
    case 3 thus ?case by(simp split: if_split_asm)
    next
    case 4 thus ?case by(simp add: getNeg_append split: prod.split_asm)
    qed(simp_all)

   from assms(1) assm3' show "has_disc disc m \<Longrightarrow> as \<noteq> []"
    proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
    case 4 thus ?case apply(simp split: prod.split_asm)
      by metis
    qed(simp_all)
qed

lemma has_disc_negated_primitive_extractor:
  assumes "normalized_nnf_match m"
  shows "has_disc_negated disc False m \<longleftrightarrow> (\<exists>a. Neg a \<in> set (fst (primitive_extractor (disc, sel) m)))"
proof -
  obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
  hence "has_disc_negated disc False m \<longleftrightarrow> (\<exists>a. Neg a \<in> set as)"
    using assms proof(induction m arbitrary: as ms)
    case Match thus ?case
       by(simp split: if_split_asm) fastforce
    next
    case (MatchNot m)
      thus ?case
      proof(induction m)
      case Match thus ?case by (simp, fastforce)
      qed(simp_all)
    next
    case (MatchAnd m1 m2) thus ?case
      apply(cases "primitive_extractor (disc, sel) m1")
      apply(cases "primitive_extractor (disc, sel) m2")
      by auto
  qed(simp_all split: if_split_asm)
  thus ?thesis using asms by simp
qed

(*if i extract something and put it together again unchanged, things do not change*)
lemma primitive_extractor_reassemble_preserves:
  "wf_disc_sel (disc, sel) C \<Longrightarrow>
   normalized_nnf_match m \<Longrightarrow>
   P m \<Longrightarrow>
   P MatchAny \<Longrightarrow>
   primitive_extractor (disc, sel) m = (as, ms) \<Longrightarrow> (*turn eqality around to simplify proof*)
   (\<And>m1 m2. P (MatchAnd m1 m2) \<longleftrightarrow> P m1 \<and> P m2) \<Longrightarrow>
   (\<And>ls1 ls2. P (alist_and' (ls1 @ ls2)) \<longleftrightarrow> P (alist_and' ls1) \<and> P (alist_and' ls2)) \<Longrightarrow>
   P (alist_and' (NegPos_map C as))"
  proof(induction "(disc, sel)" m  arbitrary: as ms rule: primitive_extractor.induct)
  case 2 thus ?case
    apply(simp split: if_split_asm)
    apply(clarify)
    by(simp add: wf_disc_sel.simps)
  next
  case 3 thus ?case
    apply(simp split: if_split_asm)
    apply(clarify)
    by(simp add: wf_disc_sel.simps)
  next
  case (4 m1 m2 as ms)
    from 4 show ?case
      apply(simp)
      apply(simp split: prod.split_asm)
      apply(clarify)
      apply(simp add: NegPos_map_append)
    done
qed(simp_all split: if_split_asm)

lemma primitive_extractor_reassemble_not_has_disc:
  "wf_disc_sel (disc, sel) C \<Longrightarrow>
   normalized_nnf_match m \<Longrightarrow> \<not> has_disc disc' m \<Longrightarrow>
   primitive_extractor (disc, sel) m = (as, ms) \<Longrightarrow>
     \<not> has_disc disc' (alist_and' (NegPos_map C as))"
  apply(rule primitive_extractor_reassemble_preserves)
        by(simp_all add: NegPos_map_append has_disc_alist_and'_append)

lemma primitive_extractor_reassemble_not_has_disc_negated:
  "wf_disc_sel (disc, sel) C \<Longrightarrow>
   normalized_nnf_match m \<Longrightarrow> \<not> has_disc_negated disc' neg m \<Longrightarrow>
   primitive_extractor (disc, sel) m = (as, ms) \<Longrightarrow>
     \<not> has_disc_negated disc' neg (alist_and' (NegPos_map C as))"
  apply(rule primitive_extractor_reassemble_preserves)
        by(simp_all add: NegPos_map_append has_disc_negated_alist_and'_append)

lemma primitive_extractor_reassemble_normalized_n_primitive:
  "wf_disc_sel (disc, sel) C \<Longrightarrow>
   normalized_nnf_match m \<Longrightarrow> normalized_n_primitive (disc1, sel1) f m \<Longrightarrow>
   primitive_extractor (disc, sel) m = (as, ms) \<Longrightarrow>
     normalized_n_primitive (disc1, sel1) f (alist_and' (NegPos_map C as))"
  apply(rule primitive_extractor_reassemble_preserves)
        by(simp_all add: NegPos_map_append normalized_n_primitive_alist_and'_append)

lemma primitive_extractor_matchesE: "wf_disc_sel (disc,sel) C \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> primitive_extractor (disc, sel) m = (as, ms)
  \<Longrightarrow>
  (normalized_nnf_match ms \<Longrightarrow> \<not> has_disc disc ms \<Longrightarrow> (\<forall>disc2. \<not> has_disc disc2 m \<longrightarrow> \<not> has_disc disc2 ms) \<Longrightarrow> matches_other \<longleftrightarrow>  matches \<gamma> ms a p)
  \<Longrightarrow>
  matches \<gamma> (alist_and (NegPos_map C as)) a p \<and> matches_other \<longleftrightarrow>  matches \<gamma> m a p"
using primitive_extractor_correct(1,2,3,4) by metis

lemma primitive_extractor_matches_lastE: "wf_disc_sel (disc,sel) C \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> primitive_extractor (disc, sel) m = (as, ms)
  \<Longrightarrow>
  (normalized_nnf_match ms \<Longrightarrow> \<not> has_disc disc ms \<Longrightarrow> (\<forall>disc2. \<not> has_disc disc2 m \<longrightarrow> \<not> has_disc disc2 ms) \<Longrightarrow> matches \<gamma> ms a p)
  \<Longrightarrow>
  matches \<gamma> (alist_and (NegPos_map C as)) a p  \<longleftrightarrow>  matches \<gamma> m a p"
using primitive_extractor_correct(1,2,3,4) by metis

text\<open>The lemmas @{thm primitive_extractor_matchesE} and @{thm primitive_extractor_matches_lastE} can be used as
  erule to solve goals about consecutive application of @{const primitive_extractor}.
  They should be used as @{text "primitive_extractor_matchesE[OF wf_disc_sel_for_first_extracted_thing]"}.
\<close>

subsection\<open>Normalizing and Optimizing Primitives\<close>
  text\<open>
    Normalize primitives by a function @{text f} with type @{typ "'b negation_type list \<Rightarrow> 'b list"}.
    @{typ "'b"} is a primitive type, e.g. ipt-ipv4range.
    @{text f} takes a conjunction list of negated primitives and must compress them such that:
    \begin{enumerate}
      \item no negation occurs in the output
      \item the output is a disjunction of the primitives, i.e. multiple primitives in one rule are compressed to at most one primitive (leading to multiple rules)
    \end{enumerate}
    Example with IP addresses:
    \begin{verbatim}
      f [10.8.0.0/16, 10.0.0.0/8] = [10.0.0.0/8]  f compresses to one range
      f [10.0.0.0, 192.168.0.01] = []    range is empty, rule can be dropped
      f [Neg 41] = [{0..40}, {42..ipv4max}]   one rule is translated into multiple rules to translate negation
      f [Neg 41, {20..50}, {30..50}] = [{30..40}, {42..50}]   input: conjunction list, output disjunction list!
    \end{verbatim}
\<close>
  definition normalize_primitive_extract :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow>
                               ('b \<Rightarrow> 'a) \<Rightarrow>
                               ('b negation_type list \<Rightarrow> 'b list) \<Rightarrow>
                               'a match_expr \<Rightarrow>
                               'a match_expr list" where
    "normalize_primitive_extract (disc_sel) C f m \<equiv> (case primitive_extractor (disc_sel) m
                of (spts, rst) \<Rightarrow> map (\<lambda>spt. (MatchAnd (Match (C spt))) rst) (f spts))"

                (*if f spts is empty, we get back an empty list. *)

  text\<open>
    If @{text f} has the properties described above, then @{const normalize_primitive_extract} is a valid transformation of a match expression\<close>
  lemma normalize_primitive_extract: assumes "normalized_nnf_match m" and "wf_disc_sel disc_sel C" and
        "\<forall>ml. (match_list \<gamma> (map (Match \<circ> C) (f ml)) a p \<longleftrightarrow> matches \<gamma> (alist_and (NegPos_map C ml)) a p)"
        shows "match_list \<gamma> (normalize_primitive_extract disc_sel C f m) a p \<longleftrightarrow> matches \<gamma> m a p"
    proof -
      obtain as ms where pe: "primitive_extractor disc_sel m = (as, ms)" by fastforce

      from pe primitive_extractor_correct(1)[OF assms(1), where \<gamma>=\<gamma> and  a=a and p=p] assms(2) have
        "matches \<gamma> m a p \<longleftrightarrow> matches \<gamma> (alist_and (NegPos_map C as)) a p \<and> matches \<gamma> ms a p" by(cases disc_sel, blast)
      also have "\<dots> \<longleftrightarrow> match_list \<gamma> (map (Match \<circ> C) (f as)) a p \<and> matches \<gamma> ms a p" using assms(3) by simp
      also have "\<dots> \<longleftrightarrow> match_list \<gamma> (map (\<lambda>spt. MatchAnd (Match (C spt)) ms) (f as)) a p"
        by(simp add: match_list_matches bunch_of_lemmata_about_matches)
      also have "... \<longleftrightarrow> match_list \<gamma> (normalize_primitive_extract disc_sel C f m) a p"
        by(simp add: normalize_primitive_extract_def pe)
      finally show ?thesis by simp
    qed

  thm match_list_semantics[of \<gamma> "(map (Match \<circ> C) (f ml))" a p "[(alist_and (NegPos_map C ml))]"]

  corollary normalize_primitive_extract_semantics:  assumes "normalized_nnf_match m" and "wf_disc_sel disc_sel C" and
        "\<forall>ml. (match_list \<gamma> (map (Match \<circ> C) (f ml)) a p \<longleftrightarrow> matches \<gamma> (alist_and (NegPos_map C ml)) a p)"
        shows "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (normalize_primitive_extract disc_sel C f m)) s =
              approximating_bigstep_fun \<gamma> p [Rule m a] s"
  proof -
    from normalize_primitive_extract[OF assms(1) assms(2) assms(3)] have
      "match_list \<gamma> (normalize_primitive_extract disc_sel C f m) a p = matches \<gamma> m a p" .
    also have "\<dots> \<longleftrightarrow> match_list \<gamma> [m] a p" by simp
    finally show ?thesis using match_list_semantics[of \<gamma> "(normalize_primitive_extract disc_sel C f m)" a p "[m]"] by simp
  qed

  lemma normalize_primitive_extract_preserves_nnf_normalized:
  assumes "normalized_nnf_match m"
      and "wf_disc_sel (disc, sel) C"
    shows "\<forall>mn \<in> set (normalize_primitive_extract (disc, sel) C f m). normalized_nnf_match mn"
    proof
      fix mn
      assume assm2: "mn \<in> set (normalize_primitive_extract (disc, sel) C f m)"
      obtain as ms where as_ms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
      from primitive_extractor_correct(2)[OF assms(1) assms(2) as_ms] have "normalized_nnf_match ms" by simp
      from assm2 as_ms have normalize_primitive_extract_unfolded: "mn \<in> ((\<lambda>spt. MatchAnd (Match (C spt)) ms) ` set (f as))"
        unfolding normalize_primitive_extract_def by force
      with \<open>normalized_nnf_match ms\<close> show "normalized_nnf_match mn" by fastforce
    qed

  lemma normalize_rules_primitive_extract_preserves_nnf_normalized:
    "\<forall>r \<in> set rs. normalized_nnf_match (get_match r) \<Longrightarrow> wf_disc_sel disc_sel C \<Longrightarrow>
     \<forall>r \<in> set (normalize_rules (normalize_primitive_extract disc_sel C f) rs). normalized_nnf_match (get_match r)"
  apply(rule normalize_rules_preserves[where P="normalized_nnf_match" and f="(normalize_primitive_extract disc_sel C f)"])
   apply(simp; fail)
  apply(cases disc_sel)
  using normalize_primitive_extract_preserves_nnf_normalized by fast

  text\<open>If something is normalized for disc2 and disc2 @{text \<noteq>} disc1 and we do something on disc1, then disc2 remains normalized\<close>
  lemma normalize_primitive_extract_preserves_unrelated_normalized_n_primitive:
  assumes "normalized_nnf_match m"
      and "normalized_n_primitive (disc2, sel2) P m"
      and "wf_disc_sel (disc1, sel1) C"
      and "\<forall>a. \<not> disc2 (C a)" --\<open>disc1 and disc2 match for different stuff. e.g. @{text Src_Ports} and @{text Dst_Ports}\<close>
    shows "\<forall>mn \<in> set (normalize_primitive_extract (disc1, sel1) C f m). normalized_n_primitive (disc2, sel2) P mn"
    proof
      fix mn
      assume assm2: "mn \<in> set (normalize_primitive_extract (disc1, sel1) C f m)"
      obtain as ms where as_ms: "primitive_extractor (disc1, sel1) m = (as, ms)" by fastforce
      from as_ms primitive_extractor_correct[OF assms(1) assms(3)] have
                      "\<not> has_disc disc1 ms"
                  and "normalized_n_primitive (disc2, sel2) P ms"
        apply -
        apply(fast)
        using assms(2) by(fast)
      from assm2 as_ms have normalize_primitive_extract_unfolded: "mn \<in> ((\<lambda>spt. MatchAnd (Match (C spt)) ms) ` set (f as))"
        unfolding normalize_primitive_extract_def by force

      from normalize_primitive_extract_unfolded obtain Casms where Casms: "mn = (MatchAnd (Match (C Casms)) ms)" by blast

      from \<open>normalized_n_primitive (disc2, sel2) P ms\<close> assms(4) have "normalized_n_primitive (disc2, sel2) P (MatchAnd (Match (C Casms)) ms)"
        by(simp)

      with Casms show "normalized_n_primitive (disc2, sel2) P mn" by blast
    qed

  lemma normalize_primitive_extract_normalizes_n_primitive:
  fixes disc::"('a \<Rightarrow> bool)" and sel::"('a \<Rightarrow> 'b)" and f::"('b negation_type list \<Rightarrow> 'b list)"
  assumes "normalized_nnf_match m"
      and "wf_disc_sel (disc, sel) C"
      and np: "\<forall>as. (\<forall> a' \<in> set (f as). P a')" (*not quite, sel f   \<forall>as \<in> {x. disc (v x)}. *)
    shows "\<forall>m' \<in> set (normalize_primitive_extract (disc, sel) C f m). normalized_n_primitive (disc, sel) P m'"
    proof
    fix m' assume a: "m'\<in>set (normalize_primitive_extract (disc, sel) C f m)"

    have nnf: "\<forall>m' \<in> set (normalize_primitive_extract (disc, sel) C f m). normalized_nnf_match m'"
      using normalize_primitive_extract_preserves_nnf_normalized assms by blast
    with a have normalized_m': "normalized_nnf_match m'" by simp

    from a obtain as ms where as_ms: "primitive_extractor (disc, sel) m = (as, ms)"
      unfolding normalize_primitive_extract_def by fastforce
    with a have prems: "m' \<in> set (map (\<lambda>spt. MatchAnd (Match (C spt)) ms) (f as))"
      unfolding normalize_primitive_extract_def by simp

    from primitive_extractor_correct(2)[OF assms(1) assms(2) as_ms] have "normalized_nnf_match ms" .

    show "normalized_n_primitive (disc, sel) P m'"
    proof(cases "f as = []")
    case True thus "normalized_n_primitive (disc, sel) P m'" using prems by simp
    next
    case False
      with prems obtain spt where "m' = MatchAnd (Match (C spt)) ms" and "spt \<in> set (f as)" by auto

      from primitive_extractor_correct(3)[OF assms(1) assms(2) as_ms] have "\<not> has_disc disc ms" .
      with \<open>normalized_nnf_match ms\<close> have "normalized_n_primitive (disc, sel) P ms"
        by(induction "(disc, sel)" P ms rule: normalized_n_primitive.induct) simp_all

      from \<open>wf_disc_sel (disc, sel) C\<close> have "(sel (C spt)) = spt" by(simp add: wf_disc_sel.simps)
      with np \<open>spt \<in> set (f as)\<close> have "P (sel (C spt))" by simp

      show "normalized_n_primitive (disc, sel) P m'"
      apply(simp add: \<open>m' = MatchAnd (Match (C spt)) ms\<close>)
      apply(rule conjI)
       apply(simp_all add: \<open>normalized_n_primitive (disc, sel) P ms\<close>)
      apply(simp add: \<open>P (sel (C spt))\<close>)
      done
    qed
  qed

 lemma primitive_extractor_negation_type_matching1:
    assumes wf: "wf_disc_sel (disc, sel) C"
        and normalized: "normalized_nnf_match m"
        and a1: "primitive_extractor (disc, sel) m = (as, rest)"
        and a2: "matches \<gamma> m a p"
    shows "(\<forall>m\<in>set (map C (getPos as)). matches \<gamma> (Match m) a p) \<and>
           (\<forall>m\<in>set (map C (getNeg as)). matches \<gamma> (MatchNot (Match m)) a p)"
  proof -
      from primitive_extractor_correct(1)[OF normalized wf a1] a2 have
        "matches \<gamma> (alist_and (NegPos_map C as)) a p \<and> matches \<gamma> rest a p" by fast
      hence "matches \<gamma> (alist_and (NegPos_map C as)) a p" by blast
      with Negation_Type_Matching.matches_alist_and have
        "(\<forall>m\<in>set (getPos (NegPos_map C as)). matches \<gamma> (Match m) a p) \<and>
         (\<forall>m\<in>set (getNeg (NegPos_map C as)). matches \<gamma> (MatchNot (Match m)) a p)" by metis
      with getPos_NegPos_map_simp2 getNeg_NegPos_map_simp2 show ?thesis by metis
  qed

text\<open>@{const normalized_n_primitive} does NOT imply @{const normalized_nnf_match}\<close>
lemma "\<exists>m. normalized_n_primitive disc_sel f m \<longrightarrow> \<not> normalized_nnf_match m"
  by(rule_tac x="MatchNot MatchAny" in exI) (simp)

lemma remove_unknowns_generic_not_has_disc: "\<not> has_disc C m \<Longrightarrow> \<not> has_disc C (remove_unknowns_generic \<gamma> a m)"
  by(induction \<gamma> a m rule: remove_unknowns_generic.induct) (simp_all add: remove_unknowns_generic_simps2)

lemma remove_unknowns_generic_not_has_disc_negated: "\<not> has_disc_negated C neg m \<Longrightarrow> \<not> has_disc_negated C neg (remove_unknowns_generic \<gamma> a m)"
  by(induction \<gamma> a m rule: remove_unknowns_generic.induct) (simp_all add: remove_unknowns_generic_simps2)

lemma remove_unknowns_generic_normalized_n_primitive: "normalized_n_primitive disc_sel f m \<Longrightarrow>
    normalized_n_primitive disc_sel f (remove_unknowns_generic \<gamma> a m)"
  proof(induction \<gamma> a m rule: remove_unknowns_generic.induct)
    case 6 thus ?case by(case_tac disc_sel, simp add: remove_unknowns_generic_simps2)
  qed(simp_all add: remove_unknowns_generic_simps2)

lemma normalize_match_preserves_disc_negated:
    shows "(\<exists>m_DNF \<in> set (normalize_match m). has_disc_negated disc neg m_DNF) \<Longrightarrow> has_disc_negated disc neg m"
  proof(induction m rule: normalize_match.induct)
  case 3 thus ?case by (simp) blast
  next
  case 4
    from 4 show ?case by(simp) blast
  qed(simp_all)
text\<open>@{const has_disc_negated} is a structural property and @{const normalize_match} is a semantical property.
  @{const normalize_match} removes subexpressions which cannot match. Thus, we cannot show (without complicated assumptions)
  the opposite direction of @{thm normalize_match_preserves_disc_negated}, because a negated primitive
  might occur in a subexpression which will be optimized away.\<close>

corollary i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day:
  "\<not> has_disc_negated disc neg m \<Longrightarrow> \<forall> m_DNF \<in> set (normalize_match m). \<not> has_disc_negated disc neg m_DNF"
using normalize_match_preserves_disc_negated by blast

lemma not_has_disc_opt_MatchAny_match_expr:
  "\<not> has_disc disc m \<Longrightarrow> \<not> has_disc disc (opt_MatchAny_match_expr m)"
  proof -
    have "\<not> has_disc disc m \<Longrightarrow> \<not> has_disc disc (opt_MatchAny_match_expr_once m)" for m
    by(induction m rule: opt_MatchAny_match_expr_once.induct) simp_all
  thus "\<not> has_disc disc m \<Longrightarrow> \<not> has_disc disc (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(rule repeat_stabilize_induct)
     by(simp)+
  qed
lemma not_has_disc_negated_opt_MatchAny_match_expr:
  "\<not> has_disc_negated disc neg m \<Longrightarrow> \<not> has_disc_negated disc neg (opt_MatchAny_match_expr m)"
  proof -
    have "\<not> has_disc_negated disc neg m \<Longrightarrow> \<not> has_disc_negated disc neg (opt_MatchAny_match_expr_once m)"
    for m
    by(induction m arbitrary: neg rule:opt_MatchAny_match_expr_once.induct) (simp_all)
  thus "\<not> has_disc_negated disc neg m \<Longrightarrow> \<not> has_disc_negated disc neg (opt_MatchAny_match_expr m)"
    apply(simp add: opt_MatchAny_match_expr_def)
    apply(rule repeat_stabilize_induct)
     by(simp)+
  qed

lemma normalize_match_preserves_nodisc:
  "\<not> has_disc disc m \<Longrightarrow> m' \<in> set (normalize_match m) \<Longrightarrow> \<not> has_disc disc m'"
  proof -
    (*no idea why this statement is necessary*)
    have "\<not> has_disc disc m \<longrightarrow> (\<forall>m' \<in> set (normalize_match m). \<not> has_disc disc m')"
    by(induction m rule: normalize_match.induct) (safe,auto) --"need safe, otherwise simplifier loops"
  thus "\<not> has_disc disc m \<Longrightarrow> m' \<in> set (normalize_match m) \<Longrightarrow> \<not> has_disc disc m'" by blast
qed

lemma not_has_disc_normalize_match:
  "\<not> has_disc_negated disc neg  m \<Longrightarrow> m' \<in> set (normalize_match m) \<Longrightarrow> \<not> has_disc_negated disc neg m'"
  using i_m_giving_this_a_funny_name_so_i_can_thank_my_future_me_when_sledgehammer_will_find_this_one_day by blast

lemma normalize_match_preserves_normalized_n_primitive:
  "normalized_n_primitive disc_sel f rst \<Longrightarrow>
        \<forall> m \<in> set (normalize_match rst). normalized_n_primitive disc_sel f m"
apply(cases disc_sel, simp)
apply(induction rst rule: normalize_match.induct)
      apply(simp; fail)
     apply(simp; fail)
    apply(simp; fail)
   using normalized_n_primitive.simps(5) apply metis (*simp loops*)
  by simp+

subsection\<open>Optimizing a match expression\<close>

  text\<open>Optimizes a match expression with a function that takes @{typ "'b negation_type list"}
  and returns @{typ "('b list \<times> 'b list) option"}.
  The function should return @{const None} if the match expression cannot match.
  It returns @{term "Some (as_pos, as_neg)"} where @{term as_pos} and @{term as_neg} are lists of
  primitives. Positive and Negated.
  The result is one match expression.

  In contrast @{const normalize_primitive_extract} returns a list of match expression, to be read es their disjunction.\<close>

  definition compress_normalize_primitive :: "(('a \<Rightarrow> bool) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow>
                                              ('b negation_type list \<Rightarrow> ('b list \<times> 'b list) option) \<Rightarrow>
                                              'a match_expr \<Rightarrow> 'a match_expr option" where
    "compress_normalize_primitive disc_sel C f m \<equiv> (case primitive_extractor disc_sel m of (as, rst) \<Rightarrow>
      (map_option (\<lambda>(as_pos, as_neg). MatchAnd
                                       (alist_and' (NegPos_map C ((map Pos as_pos)@(map Neg as_neg))))
                                       rst
                  ) (f as)))"

  lemma compress_normalize_primitive_nnf: "wf_disc_sel disc_sel C \<Longrightarrow>
      normalized_nnf_match m \<Longrightarrow> compress_normalize_primitive disc_sel C f m = Some m' \<Longrightarrow>
    normalized_nnf_match m'"
    apply(case_tac "primitive_extractor disc_sel m")
    apply(simp add: compress_normalize_primitive_def)
    apply(clarify)
    apply (simp add: normalized_nnf_match_alist_and')
    apply(cases disc_sel, simp)
    using primitive_extractor_correct(2) by blast

  lemma compress_normalize_primitive_not_introduces_C:
    assumes notdisc: "\<not> has_disc disc m"
        and wf: "wf_disc_sel (disc,sel) C'" (*C is allowed to be different from C'*)
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
        and f_preserves: "\<And>as_pos as_neg. f [] = Some (as_pos, as_neg) \<Longrightarrow> as_pos = [] \<and> as_neg = []"
     shows "\<not> has_disc disc m'"
   proof -
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from notdisc primitive_extractor_correct(4)[OF nm wf asms] have 1: "\<not> has_disc disc ms" by simp
        from notdisc primitive_extractor_correct(7)[OF nm wf asms] have 2: "as = [] \<and> ms = m" by simp
        from 1 2 some show ?thesis by(auto dest: f_preserves simp add: compress_normalize_primitive_def asms)
   qed

  lemma compress_normalize_primitive_not_introduces_C_negated:
    assumes notdisc: "\<not> has_disc_negated disc False m"
        and wf: "wf_disc_sel (disc,sel) C"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
        and f_preserves: "\<And>as as_pos as_neg. f as = Some (as_pos, as_neg) \<Longrightarrow> getNeg as = [] \<Longrightarrow> as_neg = []"
     shows "\<not> has_disc_negated disc False m'"
   proof -
        obtain as ms where asms: "primitive_extractor (disc,sel) m = (as, ms)" by fastforce
        from notdisc primitive_extractor_correct(6)[OF nm wf asms] have 1: "\<not> has_disc_negated disc False ms" by simp
        from asms notdisc has_disc_negated_primitive_extractor[OF nm, where disc=disc and sel=sel] have
          "\<forall>a. Neg a \<notin> set as" by(simp)
        hence "getNeg as = []" by (meson NegPos_set(5) image_subset_iff last_in_set)
        with f_preserves have f_preserves': "\<And>as_pos as_neg. f as = Some (as_pos, as_neg) \<Longrightarrow> as_neg = []" by simp
        from 1 have "\<And> a b.\<not> has_disc_negated disc False (MatchAnd (alist_and' (NegPos_map C (map Pos a))) ms)"
          by(simp add: has_disc_negated_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
        with some show ?thesis by(auto dest: f_preserves' simp add: compress_normalize_primitive_def asms)
   qed

  lemma compress_normalize_primitive_Some:
  assumes normalized: "normalized_nnf_match m"
      and wf: "wf_disc_sel (disc,sel) C"
      and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
      and f_correct: "\<And>as as_pos as_neg. f as = Some (as_pos, as_neg) \<Longrightarrow>
            matches \<gamma> (alist_and (NegPos_map C ((map Pos as_pos)@(map Neg as_neg)))) a p \<longleftrightarrow>
            matches \<gamma> (alist_and (NegPos_map C as)) a p"
    shows "matches \<gamma> m' a p \<longleftrightarrow> matches \<gamma> m a p"
    using some
    apply(simp add: compress_normalize_primitive_def)
    apply(case_tac "primitive_extractor (disc,sel) m")
    apply(rename_tac as rst, simp)
    apply(drule primitive_extractor_correct(1)[OF normalized wf, where \<gamma>=\<gamma> and a=a and p=p])
    apply(elim exE conjE)
    apply(drule f_correct)
    by (meson matches_alist_and_alist_and' bunch_of_lemmata_about_matches(1))

  lemma compress_normalize_primitive_None:
  assumes normalized: "normalized_nnf_match m"
      and wf: "wf_disc_sel (disc,sel) C"
      and none: "compress_normalize_primitive (disc,sel) C f m = None"
      and f_correct: "\<And>as. f as = None \<Longrightarrow> \<not> matches \<gamma> (alist_and (NegPos_map C as)) a p"
    shows "\<not> matches \<gamma> m a p"
    using none
    apply(simp add: compress_normalize_primitive_def)
    apply(case_tac "primitive_extractor (disc, sel) m")
    apply(auto dest: primitive_extractor_correct(1)[OF assms(1) wf] f_correct)
    done

  (* only for arbitrary discs that do not match C*)
  lemma compress_normalize_primitive_hasdisc:
    assumes am: "\<not> has_disc disc2 m"
        and wf: "wf_disc_sel (disc,sel) C"
        and disc: "(\<forall>a. \<not> disc2 (C a))"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
     shows "normalized_nnf_match m' \<and> \<not> has_disc disc2 m'"
   proof -
        from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from am primitive_extractor_correct(4)[OF nm wf asms] have 1: "\<not> has_disc disc2 ms" by simp
        { fix is_pos is_neg
          from disc have x1: "\<not> has_disc disc2 (alist_and' (NegPos_map C (map Pos is_pos)))"
            by(simp add: has_disc_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
          from disc have x2: "\<not> has_disc disc2 (alist_and' (NegPos_map C (map Neg is_neg)))"
            by(simp add: has_disc_alist_and' NegPos_map_map_Neg negation_type_to_match_expr_simps)
          from x1 x2 have "\<not> has_disc disc2 (alist_and' (NegPos_map C (map Pos is_pos @ map Neg is_neg)))"
            apply(simp add: NegPos_map_append has_disc_alist_and') by blast
        }
        with some have "\<not> has_disc disc2 m'"
          apply(simp add: compress_normalize_primitive_def asms)
          apply(elim exE conjE)
          using 1 by fastforce
        with goal1 show ?thesis by simp
   qed
  lemma compress_normalize_primitive_hasdisc_negated:
    assumes am: "\<not> has_disc_negated disc2 neg m"
        and wf: "wf_disc_sel (disc,sel) C"
        and disc: "(\<forall>a. \<not> disc2 (C a))"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
     shows "normalized_nnf_match m' \<and> \<not> has_disc_negated disc2 neg m'"
   proof -
        from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from am primitive_extractor_correct(6)[OF nm wf asms] have 1: "\<not> has_disc_negated disc2 neg ms" by simp
        { fix is_pos is_neg
          from disc have x1: "\<not> has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Pos is_pos)))"
            by(simp add: has_disc_negated_alist_and' NegPos_map_map_Pos negation_type_to_match_expr_simps)
          from disc have x2: "\<not> has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Neg is_neg)))"
            by(simp add: has_disc_negated_alist_and' NegPos_map_map_Neg negation_type_to_match_expr_simps)
          from x1 x2 have "\<not> has_disc_negated disc2 neg (alist_and' (NegPos_map C (map Pos is_pos @ map Neg is_neg)))"
            apply(simp add: NegPos_map_append has_disc_negated_alist_and') by blast
        }
        with some have "\<not> has_disc_negated disc2 neg m'"
          apply(simp add: compress_normalize_primitive_def asms)
          apply(elim exE conjE)
          using 1 by fastforce

        with goal1 show ?thesis by simp
   qed

  thm normalize_primitive_extract_preserves_unrelated_normalized_n_primitive (*is similar*)
  lemma compress_normalize_primitve_preserves_normalized_n_primitive:
    assumes am: "normalized_n_primitive (disc2, sel2) P m"
        and wf: "wf_disc_sel (disc,sel) C"
        and disc: "(\<forall>a. \<not> disc2 (C a))"
        and nm: "normalized_nnf_match m"
        and some: "compress_normalize_primitive (disc,sel) C f m = Some m'"
     shows "normalized_nnf_match m' \<and> normalized_n_primitive (disc2, sel2) P m'"
   proof -
        from compress_normalize_primitive_nnf[OF wf nm some] have goal1: "normalized_nnf_match m'" .
        obtain as ms where asms: "primitive_extractor (disc, sel) m = (as, ms)" by fastforce
        from am primitive_extractor_correct[OF nm wf asms] have 1: "normalized_n_primitive (disc2, sel2) P ms" by fast
        { fix iss
          from disc have "normalized_n_primitive (disc2, sel2) P (alist_and (NegPos_map C iss))"
            apply(induction iss)
             apply(simp_all)
            apply(rename_tac i iss, case_tac i)
             apply(simp_all)
            done
        }
        with some have "normalized_n_primitive (disc2, sel2) P m'"
          apply(simp add: compress_normalize_primitive_def asms)
          apply(elim exE conjE)
          using 1 normalized_n_primitive_alist_and' normalized_n_primitive_alist_and
                 normalized_n_primitive.simps(4) by blast
        with goal1 show ?thesis by simp
   qed

subsection\<open>Processing a list of normalization functions\<close>

fun compress_normalize_primitive_monad :: "('a match_expr \<Rightarrow> 'a match_expr option) list \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr option" where
  "compress_normalize_primitive_monad [] m = Some m" |
  "compress_normalize_primitive_monad (f#fs) m = (case f m of None \<Rightarrow> None
                                                           |  Some m' \<Rightarrow> compress_normalize_primitive_monad fs m')"

lemma compress_normalize_primitive_monad:
      assumes "\<And>m m' f. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> matches \<gamma> m' a p \<longleftrightarrow> matches \<gamma> m a p"
          and "\<And>m m' f. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> normalized_nnf_match m'"
          and "normalized_nnf_match m"
          and "(compress_normalize_primitive_monad fs m) = Some m'"
      shows "matches \<gamma> m' a p \<longleftrightarrow> matches \<gamma> m a p" (is ?goal1)
        and "normalized_nnf_match m'"              (is ?goal2)
  proof -
    (*everything in one big induction*)
    have goals: "?goal1 \<and> ?goal2"
    using assms proof(induction fs arbitrary: m)
    case Nil thus ?case by simp
    next
    case (Cons f fs)
      from Cons.prems(1) have IH_prem1:
        "(\<And>f m m'. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> matches \<gamma> m' a p = matches \<gamma> m a p)" by auto
      from Cons.prems(2) have IH_prem2:
        "(\<And>f m m'. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> normalized_nnf_match m')" by auto
      from Cons.IH IH_prem1 IH_prem2 have
        IH: "\<And>m. normalized_nnf_match m \<Longrightarrow> compress_normalize_primitive_monad fs m = Some m' \<Longrightarrow>
                  (matches \<gamma> m' a p \<longleftrightarrow> matches \<gamma> m a p) \<and> ?goal2" by fast
      show ?case
        proof(cases "f m")
          case None thus ?thesis using Cons.prems by auto
        next
          case(Some m'')
            from Some Cons.prems(1)[of f] Cons.prems(3) have 1: "matches \<gamma> m'' a p = matches \<gamma> m a p" by simp
            from Some Cons.prems(2)[of f] Cons.prems(3) have 2: "normalized_nnf_match m''" by simp
            from Some have "compress_normalize_primitive_monad (f # fs) m = compress_normalize_primitive_monad fs m''" by simp
            thus ?thesis using Cons.prems(4) IH 1 2 by auto
        qed
    qed
    from goals show ?goal1 by simp
    from goals show ?goal2 by simp
  qed

(*proof is a bit sledgehammered*)
lemma compress_normalize_primitive_monad_None:
      assumes "\<And>m m' f. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> matches \<gamma> m' a p \<longleftrightarrow> matches \<gamma> m a p"
          and "\<And>m f. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = None \<Longrightarrow> \<not> matches \<gamma> m a p"
          and "\<And>m m' f. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> normalized_nnf_match m'"
          and "normalized_nnf_match m"
          and "(compress_normalize_primitive_monad fs m) = None"
      shows "\<not> matches \<gamma> m a p"
    using assms proof(induction fs arbitrary: m)
    case Nil thus ?case by simp
    next
    case (Cons f fs)
      from Cons.prems(1) have IH_prem1:
        "(\<And>f m m'. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> matches \<gamma> m' a p = matches \<gamma> m a p)" by auto
      from Cons.prems(2) have IH_prem2:
        "(\<And>f m m'. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = None \<Longrightarrow> \<not> matches \<gamma> m a p)" by auto
      from Cons.prems(3) have IH_prem3:
        "(\<And>f m m'. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> normalized_nnf_match m')" by auto
      from Cons.IH IH_prem1 IH_prem2 IH_prem3 have
        IH: "\<And>m. normalized_nnf_match m \<Longrightarrow> compress_normalize_primitive_monad fs m = None \<Longrightarrow> \<not>  matches \<gamma> m a p" by blast
      show ?case
        proof(cases "f m")
          case None thus ?thesis using Cons.prems(4) Cons.prems(2) Cons.prems(3) by auto
        next
          case(Some m'')
            from Some Cons.prems(3)[of f] Cons.prems(4) have 2: "normalized_nnf_match m''" by simp
            from Some have "compress_normalize_primitive_monad (f # fs) m = compress_normalize_primitive_monad fs m''" by simp
            hence "\<not> matches \<gamma> m'' a p" using Cons.prems(5) IH 2 by simp
            thus ?thesis using Cons.prems(1) Cons.prems(4) Some by auto
        qed
    qed

lemma compress_normalize_primitive_monad_preserves:
      assumes "\<And>m m' f. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> normalized_nnf_match m'"
          and "\<And>m m' f. f \<in> set fs \<Longrightarrow> normalized_nnf_match m \<Longrightarrow> P m \<Longrightarrow> f m = Some m' \<Longrightarrow> P m'"
          and "normalized_nnf_match m"
          and "P m"
          and "(compress_normalize_primitive_monad fs m) = Some m'"
      shows "normalized_nnf_match m' \<and> P m'"
    using assms proof(induction fs arbitrary: m)
    case Nil thus ?case by simp
    next
    case (Cons f fs) thus ?case by(simp split: option.split_asm) blast (*1s*)
    qed

(*TODO: move to generic place and use? ? ? *)
datatype 'a match_compress = CannotMatch | MatchesAll | MatchExpr 'a

end


(*  Title:      HOL/HOLCF/Library/List_Predomain.thy
    Author:     Brian Huffman
*)

section \<open>Predomain class instance for HOL list type\<close>

theory List_Predomain
imports List_Cpo Sum_Cpo
begin

subsection \<open>Strict list type\<close>

domain 'a slist = SNil | SCons "'a" "'a slist"

text \<open>Polymorphic map function for strict lists.\<close>

text \<open>FIXME: The domain package should generate this!\<close>

fixrec slist_map' :: "('a \<rightarrow> 'b) \<rightarrow> 'a slist \<rightarrow> 'b slist"
  where "slist_map'\<cdot>f\<cdot>SNil = SNil"
  | "\<lbrakk>x \<noteq> \<bottom>; xs \<noteq> \<bottom>\<rbrakk> \<Longrightarrow>
      slist_map'\<cdot>f\<cdot>(SCons\<cdot>x\<cdot>xs) = SCons\<cdot>(f\<cdot>x)\<cdot>(slist_map'\<cdot>f\<cdot>xs)"

lemma slist_map'_strict [simp]: "slist_map'\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma slist_map_conv [simp]: "slist_map = slist_map'"
apply (rule cfun_eqI, rule cfun_eqI, rename_tac f xs)
apply (induct_tac xs, simp_all)
apply (subst slist_map_unfold, simp)
apply (subst slist_map_unfold, simp add: SNil_def)
apply (subst slist_map_unfold, simp add: SCons_def)
done

lemma slist_map'_slist_map':
  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> slist_map'\<cdot>f\<cdot>(slist_map'\<cdot>g\<cdot>xs) = slist_map'\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
apply (induct xs, simp, simp)
apply (case_tac "g\<cdot>a = \<bottom>", simp, simp)
apply (case_tac "slist_map'\<cdot>g\<cdot>xs = \<bottom>", simp, simp)
done

lemma slist_map'_oo:
  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> slist_map'\<cdot>(f oo g) = slist_map'\<cdot>f oo slist_map'\<cdot>g"
by (simp add: cfcomp1 slist_map'_slist_map' eta_cfun)

lemma slist_map'_ID: "slist_map'\<cdot>ID = ID"
by (rule cfun_eqI, induct_tac x, simp_all)

lemma ep_pair_slist_map':
  "ep_pair e p \<Longrightarrow> ep_pair (slist_map'\<cdot>e) (slist_map'\<cdot>p)"
apply (rule ep_pair.intro)
apply (subst slist_map'_slist_map')
apply (erule pcpo_ep_pair.p_strict [unfolded pcpo_ep_pair_def])
apply (simp add: ep_pair.e_inverse ID_def [symmetric] slist_map'_ID)
apply (subst slist_map'_slist_map')
apply (erule pcpo_ep_pair.e_strict [unfolded pcpo_ep_pair_def])
apply (rule below_eq_trans [OF _ ID1])
apply (subst slist_map'_ID [symmetric])
apply (intro monofun_cfun below_refl)
apply (simp add: cfun_below_iff ep_pair.e_p_below)
done

text \<open>
  Types \<^typ>\<open>'a list u\<close>. and \<^typ>\<open>'a u slist\<close> are isomorphic.
\<close>

fixrec encode_list_u where
  "encode_list_u\<cdot>(up\<cdot>[]) = SNil" |
  "encode_list_u\<cdot>(up\<cdot>(x # xs)) = SCons\<cdot>(up\<cdot>x)\<cdot>(encode_list_u\<cdot>(up\<cdot>xs))"

lemma encode_list_u_strict [simp]: "encode_list_u\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma encode_list_u_bottom_iff [simp]:
  "encode_list_u\<cdot>x = \<bottom> \<longleftrightarrow> x = \<bottom>"
apply (induct x, simp_all)
apply (rename_tac xs, induct_tac xs, simp_all)
done

fixrec decode_list_u where
  "decode_list_u\<cdot>SNil = up\<cdot>[]" |
  "ys \<noteq> \<bottom> \<Longrightarrow> decode_list_u\<cdot>(SCons\<cdot>(up\<cdot>x)\<cdot>ys) =
    (case decode_list_u\<cdot>ys of up\<cdot>xs \<Rightarrow> up\<cdot>(x # xs))"

lemma decode_list_u_strict [simp]: "decode_list_u\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma decode_encode_list_u [simp]: "decode_list_u\<cdot>(encode_list_u\<cdot>x) = x"
by (induct x, simp, rename_tac xs, induct_tac xs, simp_all)

lemma encode_decode_list_u [simp]: "encode_list_u\<cdot>(decode_list_u\<cdot>y) = y"
apply (induct y, simp, simp)
apply (case_tac a, simp)
apply (case_tac "decode_list_u\<cdot>y", simp, simp)
done

subsection \<open>Lists are a predomain\<close>

definition list_liftdefl :: "udom u defl \<rightarrow> udom u defl"
  where "list_liftdefl = (\<Lambda> a. udefl\<cdot>(slist_defl\<cdot>(u_liftdefl\<cdot>a)))"

lemma cast_slist_defl: "cast\<cdot>(slist_defl\<cdot>a) = emb oo slist_map\<cdot>(cast\<cdot>a) oo prj"
using isodefl_slist [where fa="cast\<cdot>a" and da="a"]
unfolding isodefl_def by simp

instantiation list :: (predomain) predomain
begin

definition
  "liftemb = (strictify\<cdot>up oo emb oo slist_map'\<cdot>u_emb) oo slist_map'\<cdot>liftemb oo encode_list_u"

definition
  "liftprj = (decode_list_u oo slist_map'\<cdot>liftprj) oo (slist_map'\<cdot>u_prj oo prj) oo fup\<cdot>ID"

definition
  "liftdefl (t::('a list) itself) = list_liftdefl\<cdot>LIFTDEFL('a)"

instance proof
  show "ep_pair liftemb (liftprj :: udom u \<rightarrow> ('a list) u)"
    unfolding liftemb_list_def liftprj_list_def
    by (intro ep_pair_comp ep_pair_slist_map' ep_pair_strictify_up
      ep_pair_emb_prj predomain_ep ep_pair_u, simp add: ep_pair.intro)
  show "cast\<cdot>LIFTDEFL('a list) = liftemb oo (liftprj :: udom u \<rightarrow> ('a list) u)"
    unfolding liftemb_list_def liftprj_list_def liftdefl_list_def
    apply (simp add: list_liftdefl_def cast_udefl cast_slist_defl cast_u_liftdefl cast_liftdefl)
    apply (simp add: slist_map'_oo u_emb_bottom cfun_eq_iff)
    done
qed

end

subsection \<open>Configuring domain package to work with list type\<close>

lemma liftdefl_list [domain_defl_simps]:
  "LIFTDEFL('a::predomain list) = list_liftdefl\<cdot>LIFTDEFL('a)"
by (rule liftdefl_list_def)

abbreviation list_map :: "('a::cpo \<rightarrow> 'b::cpo) \<Rightarrow> 'a list \<rightarrow> 'b list"
  where "list_map f \<equiv> Abs_cfun (map (Rep_cfun f))"

lemma list_map_ID [domain_map_ID]: "list_map ID = ID"
by (simp add: ID_def)

lemma deflation_list_map [domain_deflation]:
  "deflation d \<Longrightarrow> deflation (list_map d)"
apply standard
apply (induct_tac x, simp_all add: deflation.idem)
apply (induct_tac x, simp_all add: deflation.below)
done

lemma encode_list_u_map:
  "encode_list_u\<cdot>(u_map\<cdot>(list_map f)\<cdot>(decode_list_u\<cdot>xs))
    = slist_map\<cdot>(u_map\<cdot>f)\<cdot>xs"
apply (induct xs, simp, simp)
apply (case_tac a, simp, rename_tac b)
apply (case_tac "decode_list_u\<cdot>xs")
apply (drule_tac f="encode_list_u" in cfun_arg_cong, simp, simp)
done

lemma isodefl_list_u [domain_isodefl]:
  fixes d :: "'a::predomain \<rightarrow> 'a"
  assumes "isodefl' d t"
  shows "isodefl' (list_map d) (list_liftdefl\<cdot>t)"
using assms unfolding isodefl'_def liftemb_list_def liftprj_list_def
apply (simp add: list_liftdefl_def cast_udefl cast_slist_defl cast_u_liftdefl)
apply (simp add: cfcomp1 encode_list_u_map)
apply (simp add: slist_map'_slist_map' u_emb_bottom)
done

setup \<open>
  Domain_Take_Proofs.add_rec_type (\<^type_name>\<open>list\<close>, [true])
\<close>

end


section {* WebAssembly Core AST *}

theory Wasm_Ast
  imports
    Main
    "HOL-Library.Word"
    "Word_Lib.Reversed_Bit_Lists"
begin

type_synonym \<comment> \<open>immediate\<close>
  i = nat
type_synonym \<comment> \<open>static offset\<close>
  off = nat
type_synonym \<comment> \<open>alignment exponent\<close>
  a = nat

\<comment> \<open>primitive types\<close>
typedef i32 = "UNIV :: (32 word) set" ..
typedef i64 = "UNIV :: (64 word) set" ..
typedecl f32
typedecl f64

setup_lifting type_definition_i32
declare Quotient_i32[transfer_rule]
setup_lifting type_definition_i64
declare Quotient_i64[transfer_rule]

\<comment> \<open>memory\<close>
(* type_synonym byte = "8 word" *)
typedef byte = "UNIV :: (8 word) set" ..
setup_lifting type_definition_byte
declare Quotient_byte[transfer_rule]

(* For some reason this lemma does get automatically generated *)
lemmas[code] = Abs_byte_inverse[simplified]

lift_definition msb_byte :: "byte \<Rightarrow> bool" is msb .
lift_definition zero_byte :: "byte" is 0 .
lift_definition negone_byte :: "byte" is "max_word" .

lift_definition nat_of_byte :: "byte \<Rightarrow> nat" is "unat" .
lift_definition byte_of_nat :: "nat \<Rightarrow> byte" is "of_nat" .

type_synonym bytes = "byte list"

definition bytes_takefill :: "byte \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> bytes" where
  "bytes_takefill = (\<lambda>(a::byte) n as. takefill a n as)"

definition bytes_replicate :: "nat \<Rightarrow> byte \<Rightarrow> bytes" where
  "bytes_replicate = (\<lambda>n (b::byte). replicate n b)"

definition msbyte :: "bytes \<Rightarrow> byte" where
  "msbyte bs = last (bs)"

record limit_t =
  l_min :: nat
  l_max :: "nat option"

free_constructors case_limit_t_ext for limit_t_ext
  using limit_t.cases_scheme
  by blast+

type_synonym tab_t = \<comment> \<open>table type\<close>
  "limit_t"

type_synonym mem_t = \<comment> \<open>memory type\<close>
  "limit_t"

definition Ki64 :: "nat" where
  "Ki64 = 65536"

typedef mem_rep = "UNIV :: (byte list) set" ..
setup_lifting type_definition_mem_rep
declare Quotient_mem_rep[transfer_rule]

type_synonym mem = "(mem_rep \<times> nat option)"

lift_definition mem_rep_mk :: "nat \<Rightarrow> mem_rep" is "(\<lambda>n. (bytes_replicate (n * Ki64) zero_byte))" .
definition mem_mk :: "limit_t \<Rightarrow> mem" where
  "mem_mk lim = (mem_rep_mk (l_min lim), l_max lim)"

lift_definition mem_rep_byte_at :: "mem_rep \<Rightarrow> nat \<Rightarrow> byte" is "(\<lambda>m n. m!n)::(byte list) \<Rightarrow> nat \<Rightarrow> byte" .
definition byte_at :: "mem \<Rightarrow> nat \<Rightarrow> byte" where
  "byte_at m n = mem_rep_byte_at (fst m) n"

lift_definition mem_rep_length :: "mem_rep \<Rightarrow> nat" is "(\<lambda>m. length m)" .
definition mem_length :: "mem \<Rightarrow> nat" where
  "mem_length m = mem_rep_length (fst m)"

definition mem_max :: "mem \<Rightarrow> nat option" where
  "mem_max m = snd m"

lift_definition mem_rep_read_bytes :: "mem_rep \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes" is "(\<lambda>m n l. (take l (drop n m))::(byte list))" .
definition read_bytes :: "mem \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes" where
  "read_bytes m n l = mem_rep_read_bytes (fst m) n l"

lift_definition mem_rep_write_bytes :: "mem_rep \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> mem_rep" is "(\<lambda>m n bs. ((take n m) @ bs @ (drop (n + length bs) m)) :: byte list)" .
definition write_bytes :: "mem \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> mem" where
  "write_bytes m n bs = (mem_rep_write_bytes (fst m) n bs, snd m)"

lift_definition mem_rep_append :: "mem_rep \<Rightarrow> nat \<Rightarrow> byte \<Rightarrow> mem_rep" is "(\<lambda>m n b. (append m (replicate n b))::byte list)" .
definition mem_append :: "mem \<Rightarrow> nat \<Rightarrow> byte \<Rightarrow> mem" where
  "mem_append m n b = (mem_rep_append (fst m) n b, snd m)"

lemma take_drop_map:
  assumes "ind+n \<le> length bs"
  shows "(take n (drop ind bs)) = (map ((!) bs) [ind..<ind + n])"
proof -
  have "(drop ind bs) = (map ((!) bs) [ind..<length bs])"
    using drop_map map_nth
    by (metis add.commute add.right_neutral drop_upt)
  thus ?thesis
    by (simp add: assms(1) take_map)
qed

lemma read_bytes_map:
  assumes "ind+n \<le> mem_length m"
  shows "read_bytes m ind n = (map (\<lambda>k. byte_at m k) [ind..<ind+n])"
  using assms
  unfolding read_bytes_def mem_rep_read_bytes_def mem_rep_byte_at_def
            byte_at_def mem_length_def mem_rep_length_def
  by (simp add: take_drop_map split: prod.splits)

\<comment> \<open>host\<close>
typedecl host
typedecl host_state

datatype \<comment> \<open>value types\<close>
  t = T_i32 | T_i64 | T_f32 | T_f64

datatype \<comment> \<open>packed types\<close>
  tp = Tp_i8 | Tp_i16 | Tp_i32

datatype \<comment> \<open>mutability\<close>
  mut = T_immut | T_mut

record tg = \<comment> \<open>global types\<close>
  tg_mut :: mut
  tg_t :: t

free_constructors case_tg_ext for tg_ext
  using tg.cases_scheme
  by blast+

datatype \<comment> \<open>function types\<close>
  tf = Tf "t list" "t list" ("_ '_> _" 60)

(* TYPING *)
record t_context =
  types_t :: "tf list"
  func_t :: "tf list"
  global :: "tg list"
  table :: "tab_t list"
  memory :: "mem_t list"
  local :: "t list"
  label :: "(t list) list"
  return :: "(t list) option"

datatype
  sx = S | U

datatype
  unop_i = Clz | Ctz | Popcnt

datatype
  unop_f = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt

datatype
  unop = Unop_i unop_i | Unop_f unop_f

datatype
  binop_i = Add | Sub | Mul | Div sx | Rem sx | And | Or | Xor | Shl | Shr sx | Rotl | Rotr

datatype
  binop_f = Addf | Subf | Mulf | Divf | Min | Max | Copysign

datatype
  binop = Binop_i binop_i | Binop_f binop_f

datatype
  testop = Eqz

datatype
  relop_i = Eq | Ne | Lt sx | Gt sx | Le sx | Ge sx

datatype
  relop_f = Eqf | Nef | Ltf | Gtf | Lef | Gef

datatype
  relop = Relop_i relop_i | Relop_f relop_f

datatype
  cvtop = Convert | Reinterpret

datatype \<comment> \<open>values\<close>
  v =
    ConstInt32 i32
    | ConstInt64 i64
    | ConstFloat32 f32
    | ConstFloat64 f64

datatype \<comment> \<open>basic instructions\<close>
  b_e =
    Unreachable
    | Nop
    | Drop
    | Select
    | Block tf "b_e list"
    | Loop tf "b_e list"
    | If tf "b_e list" "b_e list"
    | Br i
    | Br_if i
    | Br_table "i list" i
    | Return
    | Call i
    | Call_indirect i
    | Get_local i
    | Set_local i
    | Tee_local i
    | Get_global i
    | Set_global i
    | Load t "(tp \<times> sx) option" a off
    | Store t "tp option" a off
    | Current_memory
    | Grow_memory
    | EConst v ("C _" 60)
    | Unop t unop
    | Binop t binop
    | Testop t testop
    | Relop t relop
    | Cvtop t cvtop t "sx option"

record inst = \<comment> \<open>instances\<close>
  types :: "tf list"
  funcs :: "i list"
  tabs :: "i list"
  mems :: "i list"
  globs :: "i list"

datatype cl = \<comment> \<open>function closures\<close>
  Func_native inst tf "t list" "b_e list"
| Func_host tf host

type_synonym tabinst = "(i option) list \<times> nat option"

abbreviation "tab_size (t::tabinst) \<equiv> length (fst t)"
abbreviation "tab_max (t::tabinst) \<equiv> snd t"

record global =
  g_mut :: mut
  g_val :: v

record s = \<comment> \<open>store\<close>
  funcs :: "cl list"
  tabs :: "tabinst list"
  mems :: "mem list"
  globs :: "global list"

record f = \<comment> \<open>frame\<close>
  f_locs :: "v list"
  f_inst :: inst

datatype e = \<comment> \<open>administrative instruction\<close>
  Basic b_e ("$_" 60)
  | Trap
  | Invoke i
  | Label nat "e list" "e list"
  | Frame nat f "e list"

datatype Lholed =
    \<comment> \<open>L0 = v* [<hole>] e*\<close>
    LBase "v list" "e list"
    \<comment> \<open>L(i+1) = v* (label n {e* } Li) e*\<close>
    | LRec "v list" nat "e list" Lholed "e list"

end


(*  Title:       Kill
    Authors:     Jasmin Blanchette, Andrei Popescu, Dmitriy Traytel
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Removing Live Variables\<close>

(*<*)
theory Kill
  imports "HOL-Library.BNF_Axiomatization"
begin
(*>*)

unbundle cardinal_syntax

declare [[bnf_internals]]
bnf_axiomatization (dead 'p, Fset1: 'a1, Fset2: 'a2, Fset3: 'a3) F for map: Fmap rel: Frel

abbreviation F1map :: "('a2 \<Rightarrow> 'b2) \<Rightarrow> ('a3 \<Rightarrow> 'b3) \<Rightarrow> ('p, 'a1, 'a2, 'a3) F \<Rightarrow> ('p, 'a1, 'b2, 'b3) F" where
  "F1map \<equiv> Fmap id"
abbreviation F2map :: "('a3 \<Rightarrow> 'b3) \<Rightarrow> ('p, 'a1, 'a2, 'a3) F \<Rightarrow> ('p, 'a1, 'a2, 'b3) F" where
  "F2map \<equiv> Fmap id id"

abbreviation "F1set1 \<equiv> Fset2"
abbreviation "F1set2 \<equiv> Fset3"
abbreviation "F2set \<equiv> Fset3"

theorem F1map_id: "F1map id id = id"
  by (rule F.map_id0)

theorem F1map_comp: "F1map (f1 o g1) (f2 o g2) = F1map f1 f2 o F1map g1 g2"
  by (unfold F.map_comp0[symmetric] o_id) (rule refl)

theorem F2map_comp: "F2map (f o g) = F2map f o F2map g"
  by (unfold F.map_comp0[symmetric] o_id) (rule refl)

theorem F1map_cong: "\<lbrakk>\<And>z. z \<in> F1set1 x \<Longrightarrow> f1 z = g1 z; \<And>z. z \<in> F1set2 x \<Longrightarrow> f2 z = g2 z\<rbrakk>
  \<Longrightarrow> F1map f1 f2 x = F1map g1 g2 x"
  apply (rule F.map_cong0)
    apply (rule refl)
   apply assumption
  apply assumption
  done

theorem F2map_cong: "\<lbrakk>\<And>z. z \<in> F2set x \<Longrightarrow> f z = g z\<rbrakk> \<Longrightarrow> F2map f x = F2map g x"
  apply (rule F.map_cong0)
    apply (rule refl)
   apply (rule refl)
  apply assumption
  done

theorem F1set1_natural: "F1set1 o F1map f1 f2 = image f1 o F1set1"
  by (rule F.set_map0(2))

theorem F1set2_natural: "F1set2 o F1map f1 f2 = image f2 o F1set2"
  by (rule F.set_map0(3))

theorem F2set_natural: "F2set o F2map f = image f o F2set"
  by (rule F.set_map0(3))

abbreviation Fin :: "'a1 set \<Rightarrow> 'a2 set \<Rightarrow> 'a3 set \<Rightarrow> (('p, 'a1, 'a2, 'a3) F) set" where
  "Fin A1 A2 A3 \<equiv> {x. Fset1 x \<subseteq> A1 \<and> Fset2 x \<subseteq> A2 \<and> Fset3 x \<subseteq> A3}"

abbreviation F1in :: "'a2 set \<Rightarrow> 'a3 set \<Rightarrow> (('p, 'a1, 'a2, 'a3) F) set" where
  "F1in A1 A2 \<equiv> {x. F1set1 x \<subseteq> A1 \<and> F1set2 x \<subseteq> A2}"

lemma F1in_alt: "F1in A2 A3 = Fin UNIV A2 A3"
  by (tactic \<open>BNF_Comp_Tactics.kill_in_alt_tac @{context}\<close>)

abbreviation F2in :: "'a3 set \<Rightarrow> (('p, 'a1, 'a2, 'a3) F) set" where
  "F2in A \<equiv> {x. F2set x \<subseteq> A}"

lemma F2in_alt: "F2in A3 = Fin UNIV UNIV A3"
  by (tactic \<open>BNF_Comp_Tactics.kill_in_alt_tac @{context}\<close>)

lemma Frel_cong: "\<lbrakk>R1 = S1; R2 = S2; R3 = S3\<rbrakk> \<Longrightarrow> Frel R1 R2 R3 = Frel S1 S2 S3"
  by hypsubst (rule refl)

definition F1rel where
  "F1rel R1 R2 = (BNF_Def.Grp (F1in (Collect (case_prod R1)) (Collect (case_prod R2))) (F1map fst fst))^--1 OO
                 (BNF_Def.Grp (F1in (Collect (case_prod R1)) (Collect (case_prod R2))) (F1map snd snd))"

lemmas F1rel_unfold = trans[OF F1rel_def trans[OF OO_Grp_cong[OF F1in_alt]
      trans[OF arg_cong2[of _ _ _ _ relcompp, OF trans[OF arg_cong[of _ _ conversep, OF sym[OF F.rel_Grp]] F.rel_conversep[symmetric]] sym[OF F.rel_Grp]]
        trans[OF F.rel_compp[symmetric] Frel_cong[OF trans[OF Grp_UNIV_id[OF refl] eq_alt[symmetric]] Grp_fst_snd Grp_fst_snd]]]]]

definition F2rel where
  "F2rel R1 = (BNF_Def.Grp (F2in (Collect (case_prod R1))) (F2map fst))^--1 OO
              (BNF_Def.Grp (F2in (Collect (case_prod R1))) (F2map snd))"

lemmas F2rel_unfold = trans[OF F2rel_def trans[OF OO_Grp_cong[OF F2in_alt]
      trans[OF arg_cong2[of _ _ _ _ relcompp, OF trans[OF arg_cong[of _ _ conversep, OF sym[OF F.rel_Grp]] F.rel_conversep[symmetric]] sym[OF F.rel_Grp]]
        trans[OF F.rel_compp[symmetric] Frel_cong[OF trans[OF Grp_UNIV_id[OF refl] eq_alt[symmetric]] trans[OF Grp_UNIV_id[OF refl] eq_alt[symmetric]] Grp_fst_snd]]]]]

bnf F1: "('p, 'a1, 'a2, 'a3) F"
  map: F1map
  sets: F1set1 F1set2
  bd: "bd_F :: ('p bd_type_F) rel"
  rel: F1rel
            apply -
            apply (rule F1map_id)
           apply (rule F1map_comp)
          apply (erule F1map_cong) apply assumption
         apply (rule F1set1_natural)
        apply (rule F1set2_natural)
       apply (rule F.bd_card_order)
      apply (rule F.bd_cinfinite)
     apply (rule F.set_bd(2))
    apply (rule F.set_bd(3))
   apply (unfold F1rel_unfold F.rel_compp[symmetric] eq_OO) [1] apply (rule order_refl)
  apply (rule F1rel_def[unfolded OO_Grp_alt mem_Collect_eq])
  done

bnf F2: "('p, 'a1, 'a2, 'a3) F"
  map: F2map
  sets: F2set
  bd: "bd_F :: ('p bd_type_F) rel"
  rel: F2rel
          apply -
          apply (rule F2map_id)
         apply (rule F2map_comp)
        apply (erule F2map_cong)
       apply (rule F2set_natural)
      apply (rule F.bd_card_order)
     apply (rule F.bd_cinfinite)
    apply (rule F.set_bd(3))
   apply (unfold F2rel_unfold F.rel_compp[symmetric] eq_OO) [1] apply (rule order_refl)
  apply (rule F2rel_def[unfolded OO_Grp_alt mem_Collect_eq])
  done

(*<*)
end
(*>*)


(*<*)
theory Abstract_Monitor
  imports Formula
begin
(*>*)

section \<open>Abstract monitor specification\<close>

locale monitorable =
  fixes monitorable :: "Formula.formula \<Rightarrow> bool"

text \<open>The following locale specifies the desired behavior ouf a monitor abstractly.\<close>

locale monitor = monitorable +
  fixes
    M :: "Formula.formula \<Rightarrow> Formula.prefix \<Rightarrow> (nat \<times> event_data tuple) set"
  assumes
    mono_monitor: "monitorable \<phi> \<Longrightarrow> \<pi> \<le> \<pi>' \<Longrightarrow> M \<phi> \<pi> \<subseteq> M \<phi> \<pi>'"
    and sound_monitor: "monitorable \<phi> \<Longrightarrow> (i, v) \<in> M \<phi> \<pi> \<Longrightarrow>
      i < plen \<pi> \<and> wf_tuple (Formula.nfv \<phi>) (Formula.fv \<phi>) v \<and> (\<forall>\<sigma>. prefix_of \<pi> \<sigma> \<longrightarrow> Formula.sat \<sigma> Map.empty (map the v) i \<phi>)"
    and complete_monitor: "monitorable \<phi> \<Longrightarrow> prefix_of \<pi> \<sigma> \<Longrightarrow>
      i < plen \<pi> \<Longrightarrow> wf_tuple (Formula.nfv \<phi>) (Formula.fv \<phi>) v \<Longrightarrow>
      (\<forall>\<sigma>. prefix_of \<pi> \<sigma> \<longrightarrow> Formula.sat \<sigma> Map.empty (map the v) i \<phi>) \<Longrightarrow> \<exists>\<pi>'. prefix_of \<pi>' \<sigma> \<and> (i, v) \<in> M \<phi> \<pi>'"

locale slicable_monitor = monitor +
  assumes monitor_slice: "mem_restr S v \<Longrightarrow> (i, v) \<in> M \<phi> (Formula.pslice \<phi> S \<pi>) \<longleftrightarrow> (i, v) \<in> M \<phi> \<pi>"

locale monitor_pre_progress = monitorable +
  fixes progress :: "Formula.trace \<Rightarrow> Formula.formula \<Rightarrow> nat \<Rightarrow> nat"
  assumes
    progress_mono: "j \<le> j' \<Longrightarrow> progress \<sigma> \<phi> j \<le> progress \<sigma> \<phi> j'"
    and progress_le: "progress \<sigma> \<phi> j \<le> j"
    and progress_ge: "monitorable \<phi> \<Longrightarrow> \<exists>j. i \<le> progress \<sigma> \<phi> j"

locale monitor_progress = monitor_pre_progress +
  assumes progress_prefix_conv: "prefix_of \<pi> \<sigma> \<Longrightarrow> prefix_of \<pi> \<sigma>' \<Longrightarrow>
    progress \<sigma> \<phi> (plen \<pi>) = progress \<sigma>' \<phi> (plen \<pi>)"
begin

definition verdicts :: "Formula.formula \<Rightarrow> Formula.prefix \<Rightarrow> (nat \<times> event_data tuple) set" where
  "verdicts \<phi> \<pi> = {(i, v). wf_tuple (Formula.nfv \<phi>) (Formula.fv \<phi>) v \<and>
    (\<forall>\<sigma>. prefix_of \<pi> \<sigma> \<longrightarrow> i < progress \<sigma> \<phi> (plen \<pi>) \<and> Formula.sat \<sigma>  Map.empty (map the v) i \<phi>)}"

lemma verdicts_mono: "\<pi> \<le> \<pi>' \<Longrightarrow> verdicts \<phi> \<pi> \<subseteq> verdicts \<phi> \<pi>'"
  unfolding verdicts_def
  by (auto dest: prefix_of_antimono elim!: order.strict_trans2 intro!: progress_mono plen_mono)

end

lemma stake_eq_mono: "stake b x = stake b y \<Longrightarrow> a \<le> b \<Longrightarrow> stake a x = stake a y"
proof (induction a arbitrary: b x y)
  case 0
  then show ?case by simp
next
  case Suca: (Suc a)
  show ?case proof (cases b)
    case 0
    with Suca show ?thesis by (simp del: stake.simps)
  next
    case (Suc b')
    with Suca show ?thesis by (auto simp only: stake.simps list.inject)
  qed
qed

sublocale monitor_progress \<subseteq> monitor monitorable verdicts
proof (standard, goal_cases)
  case (1 \<phi> \<pi> \<pi>')
  from 1(2) show ?case by (rule verdicts_mono)
next
  case (2 \<phi> i v \<pi>)
  from \<open>(i, v) \<in> verdicts \<phi> \<pi>\<close> show ?case
    unfolding verdicts_def
    using ex_prefix_of[of \<pi>]
    by (auto elim!: order.strict_trans2 intro!: progress_le)
next
  case complete: (3 \<phi> \<pi> \<sigma> i v)
  from \<open>monitorable \<phi>\<close> obtain j where eval: "i < progress \<sigma> \<phi> j"
    unfolding less_eq_Suc_le
    using progress_ge by blast
  define j' where "j' = max (plen \<pi>) j"
  then have "plen \<pi> \<le> j'" by simp
  from eval have eval': "i < progress \<sigma> \<phi> j'"
    unfolding j'_def
    by (auto elim: order.strict_trans2 intro!: progress_mono)
  from complete(2) \<open>plen \<pi> \<le> j'\<close> have "\<pi> \<le> take_prefix j' \<sigma>"
  proof (transfer fixing: j', goal_cases prefix)
    case (prefix \<pi> \<sigma>)
    then have "stake j' \<sigma> = stake (length \<pi>) \<sigma> @ stake (j' - length \<pi>) (sdrop (length \<pi>) \<sigma>)"
      by (unfold stake_add) auto
    with \<open>stake (length \<pi>) \<sigma> = \<pi>\<close> show ?case
      by auto
  qed
  with complete(4) eval' show ?case using progress_prefix_conv[of "take_prefix j' \<sigma>" \<sigma> \<sigma>' \<phi> for \<sigma>']
    unfolding verdicts_def
    by (auto intro!: exI[where x="take_prefix j' \<sigma>"] complete(5)[rule_format] elim: prefix_of_antimono)
qed

locale monitor_timed_progress = monitor_pre_progress +
  assumes progress_time_conv: "\<forall>i<j. \<tau> \<sigma> i = \<tau> \<sigma>' i \<Longrightarrow> progress \<sigma> \<phi> j = progress \<sigma>' \<phi> j"
    and progress_sat_cong: "prefix_of \<pi> \<sigma> \<Longrightarrow> prefix_of \<pi> \<sigma>' \<Longrightarrow> i < progress \<sigma> \<phi> (plen \<pi>) \<Longrightarrow>
      Formula.sat \<sigma>  Map.empty v i \<phi> \<longleftrightarrow> Formula.sat \<sigma>' Map.empty v i \<phi>"
begin

lemma progress_map_conv: "progress (map_\<Gamma> f \<sigma>) \<phi> j = progress (map_\<Gamma> g \<sigma>) \<phi> j"
  by (auto intro: progress_time_conv)

lemma progress_slice_conv: "progress (Formula.slice \<phi>' R \<sigma>) \<phi> j = progress (Formula.slice \<phi>' R' \<sigma>) \<phi> j"
  unfolding Formula.slice_def using progress_map_conv .

lemma progress_slice: "progress (Formula.slice \<phi> R \<sigma>) \<phi> j = progress \<sigma> \<phi> j"
  using progress_map_conv[where g=id] by (simp add: Formula.slice_def)

end

sublocale monitor_timed_progress \<subseteq> monitor_progress
  by (unfold_locales, auto intro: progress_time_conv \<tau>_prefix_conv)

lemma (in monitor_timed_progress) verdicts_alt:
  "verdicts \<phi> \<pi> = {(i, v). wf_tuple (Formula.nfv \<phi>) (Formula.fv \<phi>) v \<and>
    (\<exists>\<sigma>. prefix_of \<pi> \<sigma> \<and> i < progress \<sigma> \<phi> (plen \<pi>) \<and> Formula.sat \<sigma> Map.empty (map the v) i \<phi>)}"
  unfolding verdicts_def
  using ex_prefix_of[of \<pi>]
  by (auto dest: progress_prefix_conv[of \<pi> _ _ \<phi>] elim!: progress_sat_cong[THEN iffD1, rotated -1])

sublocale monitor_timed_progress \<subseteq> slicable_monitor monitorable verdicts
proof
  fix S :: "event_data list set" and v i \<phi> \<pi>
  assume *: "mem_restr S v"
  show "((i, v) \<in> verdicts \<phi> (Formula.pslice \<phi> S \<pi>)) = ((i, v) \<in> verdicts \<phi> \<pi>)" (is "?L = ?R")
  proof
    assume ?L
    with * show ?R unfolding verdicts_def
      by (auto simp: progress_slice fvi_less_nfv wf_tuple_def elim!: mem_restrE
        box_equals[OF sat_slice_iff sat_fv_cong sat_fv_cong, symmetric, THEN iffD1, rotated -1]
        dest: spec[of _ "Formula.slice \<phi> S _"] prefix_of_pslice_slice)
  next
    assume ?R
    with * show ?L unfolding verdicts_alt
      by (auto simp: progress_slice fvi_less_nfv wf_tuple_def elim!: mem_restrE
        box_equals[OF sat_slice_iff sat_fv_cong sat_fv_cong, symmetric, THEN iffD2, rotated -1]
        intro: exI[of _ "Formula.slice \<phi> S _"] prefix_of_pslice_slice)
  qed
qed

text \<open>Past-only Formulas.\<close>

fun past_only :: "Formula.formula \<Rightarrow> bool" where
  "past_only (Formula.Pred _ _) = True"
| "past_only (Formula.Eq _ _) = True"
| "past_only (Formula.Less _ _) = True"
| "past_only (Formula.LessEq _ _) = True"
| "past_only (Formula.Let _ _ \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (Formula.Neg \<psi>) = past_only \<psi>"
| "past_only (Formula.Or \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (Formula.And \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (Formula.Ands l) = (\<forall>\<alpha>\<in>set l. past_only \<alpha>)"
| "past_only (Formula.Exists \<psi>) = past_only \<psi>"
| "past_only (Formula.Agg _ _ _ _ \<psi>) = past_only \<psi>"
| "past_only (Formula.Prev _ \<psi>) = past_only \<psi>"
| "past_only (Formula.Next _ _) = False"
| "past_only (Formula.Since \<alpha> _ \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (Formula.Until \<alpha> _ \<beta>) = False"
| "past_only (Formula.MatchP _ r) = Regex.pred_regex past_only r"
| "past_only (Formula.MatchF _ _) = False"

lemma past_only_sat:
  assumes "prefix_of \<pi> \<sigma>" "prefix_of \<pi> \<sigma>'"
  shows "i < plen \<pi> \<Longrightarrow> dom V = dom V' \<Longrightarrow>
     (\<And>p i. p \<in> dom V \<Longrightarrow> i < plen \<pi> \<Longrightarrow> the (V p) i = the (V' p) i) \<Longrightarrow>
     past_only \<phi> \<Longrightarrow> Formula.sat \<sigma> V v i \<phi> = Formula.sat \<sigma>' V' v i \<phi>"
proof (induction \<phi> arbitrary: V V' v i)
  case (Pred e ts)
  show ?case proof (cases "V e")
    case None
    then have "V' e = None" using \<open>dom V = dom V'\<close> by auto
    with None \<Gamma>_prefix_conv[OF assms(1,2) Pred(1)] show ?thesis by simp
  next
    case (Some a)
    moreover obtain a' where "V' e = Some a'" using Some \<open>dom V = dom V'\<close> by auto
    moreover have "the (V e) i = the (V' e) i"
      using Some Pred(1,3) by (fastforce intro: domI)
    ultimately show ?thesis by simp
  qed
next
  case (Let p b \<phi> \<psi>)
  let ?V = "\<lambda>V \<sigma>. (V(p \<mapsto>
      \<lambda>i. {v. length v = Formula.nfv \<phi> - b \<and>
              (\<exists>zs. length zs = b \<and>
                    Formula.sat \<sigma> V (zs @ v) i \<phi>)}))"
  show ?case unfolding sat.simps proof (rule Let.IH(2))
    show "i < plen \<pi>" by fact
    from Let.prems show "past_only \<psi>" by simp
    from Let.prems show "dom (?V V \<sigma>) = dom (?V V' \<sigma>')"
      by (simp del: fun_upd_apply)
  next
    fix p' i
    assume *: "p' \<in> dom (?V V \<sigma>)" "i < plen \<pi>"
    show "the (?V V \<sigma> p') i = the (?V V' \<sigma>' p') i" proof (cases "p' = p")
      case True
      with Let \<open>i < plen \<pi>\<close> show ?thesis by auto
    next
      case False
      with * show ?thesis by (auto intro!: Let.prems(3))
    qed
  qed
next
  case (Ands l)
  with \<Gamma>_prefix_conv[OF assms] show ?case by simp
next
  case (Prev I \<phi>)
  with \<tau>_prefix_conv[OF assms] show ?case by (simp split: nat.split)
next
  case (Since \<phi>1 I \<phi>2)
  with \<tau>_prefix_conv[OF assms] show ?case by auto
next
  case (MatchP I r)
  then have "Regex.match (Formula.sat \<sigma> V v) r a b = Regex.match (Formula.sat \<sigma>' V' v) r a b" if "b < plen \<pi>" for a b
    using that by (intro Regex.match_cong_strong) (auto simp: regex.pred_set)
  with \<tau>_prefix_conv[OF assms] MatchP(2) show ?case by auto
qed auto

interpretation past_only_monitor: monitor_timed_progress past_only "\<lambda>\<sigma> \<phi> j. if past_only \<phi> then j else 0"
  by unfold_locales (auto dest: past_only_sat(1) split: if_splits)

(*<*)
end
(*>*)