section \<open>Nested List Assertion\<close>
theory LLVM_DS_List_Assn
imports "../vcg/LLVM_VCG_Main"
begin
  (* TODO: Improve handling of pure assertions.
    Dirty hacks like for pure list-assn shouldn't be necessary!
  *)

  (* TODO: Move *)
  lemma gen_drule:
    assumes "P\<turnstile>Q"
    assumes "FRAME A P F"
    assumes "Q**F\<turnstile>B"
    shows "A\<turnstile>B"
    using assms unfolding FRAME_def
    using sep_rule(1) sep_rule(2) by blast

  (* TODO: Move *)
  lemma pure_part_set_imgD[vcg_prep_ext_rules]:
    shows "pure_part (sep_set_img S P) \<longrightarrow> (\<forall>x\<in>S. pure_part (P x))"
  proof (cases "finite S")
    case True thus ?thesis
      by (induction S) (auto dest: pure_part_split_conj)
  next
    case False then show ?thesis by simp
  qed

  subsection \<open>Tags\<close>
  text \<open>Ghost instructions to guide the VCG and Frame Inference\<close>
  lemma entails_is_noop_htriple: "(A \<turnstile> B) \<Longrightarrow> llvm_htriple A (return x) (\<lambda>_. B)"
    apply (auto simp: htriple_def wp_return)
    by (metis entails_def sep_conj_impl1)

  lemma tag_op_ruleI:
    assumes "tag_op = return x"
    assumes "A\<turnstile>B"
    shows "llvm_htriple A tag_op (\<lambda>_. B)"
    using entails_is_noop_htriple assms by metis

  text \<open>Assertion to be matched with anything.
    To obtain abstract from concrete variable.\<close>
  definition "tag_assn \<equiv> mk_pure_assn (\<lambda>_ _. True)"
  lemma tag_assn_pure[is_pure_rule]: "is_pure (tag_assn)" unfolding tag_assn_def by auto

  lemma tag_assnI[fri_rules]: "PRECOND (SOLVE_ASM (\<flat>\<^sub>pA a c)) \<Longrightarrow> \<box> \<turnstile> \<upharpoonleft>\<^sub>ptag_assn a c"
    by (auto simp: tag_assn_def sep_algebra_simps)

  (* TODO: Move *)
  lemma split_pure_assn: "is_pure A \<Longrightarrow> \<upharpoonleft>A a c \<turnstile> \<upharpoonleft>A a c ** \<upharpoonleft>A a c"
    by (smt entails_eq_iff entails_pureI extract_pure_assn pure_part_pureD pure_true_conv sep.add.right_neutral)

  definition tag_split_pure :: "'b::llvm_rep \<Rightarrow> unit llM"
    where "tag_split_pure x = return ()"

  lemma tag_split_pure_rl[vcg_rules]:
    shows "llvm_htriple
      (\<up>(is_pure A) ** \<upharpoonleft>A a c)
      (tag_split_pure c)
      (\<lambda>_. \<upharpoonleft>A a c ** \<upharpoonleft>A a c)"
    supply [vcg_rules] = tag_op_ruleI[OF tag_split_pure_def[where x=c] split_pure_assn[of A a c]]
    by vcg

  lemma bury_pure_assn: "is_pure A \<Longrightarrow> \<upharpoonleft>A a c \<turnstile> \<box>"
    by (smt entails_eq_iff entails_pureI extract_pure_assn pure_part_pureD pure_true_conv)

  lemma bury_pure_assn': "\<upharpoonleft>\<^sub>pA a c \<turnstile> \<box>"
    by (simp add: dr_assn_pure_prefix_def entails_lift_extract_simps(1))

  definition tag_bury_pure :: "'b::llvm_rep \<Rightarrow> unit llM"
    where "tag_bury_pure x = return ()"

  lemma tag_bury_pure_rl[vcg_rules]:
    shows "llvm_htriple
      (\<up>(is_pure A) ** \<upharpoonleft>A a c)
      (tag_bury_pure c)
      (\<lambda>_. \<box>)"
    supply [vcg_rules] = tag_op_ruleI[OF tag_bury_pure_def[where x=c] bury_pure_assn[of A a c]]
    by vcg

  subsection \<open>Map of Valid Indexes in List\<close>
  (* TODO: DUP in Array_of_Array_List. *)
  definition "idxe_map l i \<equiv> if i<length l then Some (l!i) else None"

  lemma idxe_map_empty[simp]: "idxe_map [] = Map.empty" unfolding idxe_map_def by auto

  lemma idxe_map_dom[simp]: "dom (idxe_map l) = {0..<length l}" unfolding idxe_map_def by (auto split: if_splits)

  lemma le_idxe_map_updI: "i<length l \<Longrightarrow> m \<subseteq>\<^sub>m idxe_map l \<Longrightarrow> m(i\<mapsto>l!i) \<subseteq>\<^sub>m idxe_map l"
    unfolding idxe_map_def map_le_def by (auto split: if_splits)

  lemma le_idxe_map_delD: "m \<subseteq>\<^sub>m idxe_map l \<Longrightarrow> m(i:=None) \<subseteq>\<^sub>m idxe_map (l[i:=x])"
    unfolding idxe_map_def map_le_def by (auto split: if_splits)

  lemma le_idxe_map_delD': "m \<subseteq>\<^sub>m idxe_map l \<Longrightarrow> m(i:=None) \<subseteq>\<^sub>m idxe_map l"
    unfolding idxe_map_def map_le_def by (auto split: if_splits)

  lemma le_idxe_mapD: "m \<subseteq>\<^sub>m idxe_map l \<Longrightarrow> m i = Some xi \<Longrightarrow> l!i = xi"
    unfolding idxe_map_def map_le_def
    apply (clarsimp split: if_splits)
    by (metis domI domIff option.inject)

  lemma le_idxe_map_lenD: "m \<subseteq>\<^sub>m idxe_map l \<Longrightarrow> m i = Some xi \<Longrightarrow> i < length l"
    unfolding idxe_map_def map_le_def
    apply (clarsimp split: if_splits)
    by (metis domI domIff)

  lemma le_idxe_map_append1I: "A\<subseteq>\<^sub>midxe_map (xs@[y]) \<Longrightarrow> A(length xs := None)\<subseteq>\<^sub>midxe_map (xs)"
    by (auto simp: map_le_def idxe_map_def split: if_splits)

  lemma le_idxe_map_append2I: "A\<subseteq>\<^sub>midxe_map xs \<Longrightarrow> A\<subseteq>\<^sub>midxe_map (xs@ys)"
    by (auto simp: map_le_def idxe_map_def split: if_splits)

  subsection \<open>Nested List Assertion\<close>

  definition "list_assn A R \<equiv> mk_assn (\<lambda>xs ys.
     \<up>(length xs=length ys)
  ** \<up>(R \<subseteq>\<^sub>m idxe_map ys)
  ** (\<Union>*i\<in>{0..<length ys} - dom R. \<upharpoonleft>A (xs!i) (ys!i)))"

  lemma list_assn_pure_partD[vcg_prep_ext_rules]:
    "pure_part (\<upharpoonleft>(list_assn A R) xs ys)
      \<Longrightarrow> length xs = length ys \<and> R \<subseteq>\<^sub>m idxe_map ys \<and> (\<forall>x\<in>{0..<length ys} - dom R. pure_part (\<upharpoonleft>A (xs ! x) (ys ! x)))"
    unfolding list_assn_def
    apply vcg_prepare_external by blast

  subsection \<open>Transformations\<close>

  subsubsection \<open>Initialization and Destruction\<close>
    text \<open>Initialization if there is a pure initial element\<close>
  lemma list_assn_init_pure:
    assumes "\<box> \<turnstile> \<upharpoonleft>A x xi"
    shows "\<box> \<turnstile> \<upharpoonleft>(list_assn A Map.empty) (replicate n x) (replicate n xi)"
  proof -
    have "\<box> \<turnstile> (\<Union>*xa\<in>{0..<n}. \<upharpoonleft>A x xi)"
      apply (induction n)
      subgoal by simp
      subgoal for n
        apply (simp add: atLeast0_lessThan_Suc)
        using conj_entails_mono[OF assms] by simp
      done

    thus ?thesis
      unfolding list_assn_def
      by (simp add: sep_algebra_simps)
  qed

  text \<open>Arbitrary initialization, no elements owned. Can be used to justify init-algorithm\<close>
  lemma list_assn_init_none:
    assumes "length xs = length ys"
    shows "\<box> \<turnstile> \<upharpoonleft>(list_assn A (idxe_map ys)) xs ys"
    using assms unfolding list_assn_def
    by (simp add: sep_algebra_simps)

  lemma list_assn_empty: "\<box> \<turnstile> \<upharpoonleft>(list_assn A Map.empty) [] []"
    unfolding list_assn_def
    by (auto simp: sep_algebra_simps)

  text \<open>Destruction if all elements have been extracted\<close>
  lemma list_assn_free_none:
    assumes "dom R \<supseteq> {0..<length ys}"
    shows "\<upharpoonleft>(list_assn A R) xs ys \<turnstile> \<box>"
    using assms unfolding list_assn_def
    by (auto simp: sep_algebra_simps entails_lift_extract_simps dest: map_le_implies_dom_le)

  subsubsection \<open>Extracting and Joining Elements\<close>

  lemma list_assn_extract_aux:
    assumes "i<length xs" "i\<notin>R"
    shows "sep_set_img ({0..<length xs} - R) P
        = (P i ** sep_set_img ({0..<length xs} - insert i R) P)"
  proof -
    from assms have 1: "{0..<length xs} - R = insert i ({0..<length xs} - insert i R)" by auto
    show ?thesis
      by (subst 1) auto
  qed

  lemma list_assn_extract:
    assumes "i<length xs" "R i = None"
    shows "\<upharpoonleft>(list_assn A R) xs ys \<turnstile> \<upharpoonleft>(list_assn A (R(i\<mapsto>ys!i))) xs ys ** \<upharpoonleft>A (xs!i) (ys!i)"
    using assms unfolding list_assn_def
    supply [simp] = le_idxe_map_updI list_assn_extract_aux ndomIff
    supply fri_red_img[fri_red_rules]
    apply (clarsimp simp: sep_algebra_simps entails_lift_extract_simps)
    apply (rule ENTAILSD)
    apply vcg
    done

  lemma list_assn_upd_aux:
    fixes I xs xsi
    defines "I \<equiv> {0..<length xsi}"
    assumes "i\<in>I" "i\<in>R" and [simp]: "length xsi = length xs"
    shows "(\<Union>*j\<in>I - (R - {i}). \<upharpoonleft>A (xs[i := x] ! j) (xsi[i := xi] ! j)) = (\<upharpoonleft>A x xi ** (\<Union>*j\<in>I - R. \<upharpoonleft>A (xs ! j) (xsi ! j)))"
  proof -
    from assms have 1: "I - (R - {i}) = insert i (I-R)" by auto
    from assms have [simplified,simp]: "i\<notin>I-R" by auto
    have [simp]: "i<length xs" using \<open>i\<in>I\<close> unfolding I_def by auto
    have [simp]: "j\<in>I-R \<Longrightarrow> i\<noteq>j" for j using \<open>i\<in>R\<close> by auto
    show ?thesis apply (subst 1) by simp
  qed

  lemma list_assn_update:
    assumes "R i \<noteq> None"
    shows "\<upharpoonleft>(list_assn A R) xs ys ** \<upharpoonleft>A x y \<turnstile> \<upharpoonleft>(list_assn A (R(i:=None))) (xs[i:=x]) (ys[i:=y])"
    using assms unfolding list_assn_def
    apply -
    apply (rule entails_pureI)

    supply [simp] = le_idxe_map_updI le_idxe_map_delD
    supply fri_red_img[fri_red_rules]
    apply (clarsimp simp: sep_algebra_simps entails_lift_extract_simps)
    apply (subst list_assn_upd_aux)
    subgoal by (metis domI idxe_map_dom map_leD)
    apply auto [2]
    apply (rule ENTAILSD)
    apply vcg
    done

  lemma list_assn_join:
    assumes "R i = Some y"
    assumes "x = xs!i"
    shows "\<upharpoonleft>(list_assn A R) xs ys ** \<upharpoonleft>A x y \<turnstile> \<upharpoonleft>(list_assn A (R(i:=None))) xs ys"
    apply (rule entails_pureI)
    apply (subst (asm) list_assn_def)
    apply (clarsimp simp: sep_algebra_simps dest!: pure_part_split_conj)
    apply (rule entails_trans[OF list_assn_update[where i=i]])
    using assms by (auto dest: le_idxe_mapD)

  lemma list_assn_join':
    assumes "R i = None"
    assumes "x = xs!i" "y=ys!i"
    shows "\<upharpoonleft>(list_assn A (R(i\<mapsto>ys!i))) xs ys ** \<upharpoonleft>A x y \<turnstile> \<upharpoonleft>(list_assn A R) xs ys"
    apply (sep_drule_simple list_assn_join[where i=i])
    using assms by (auto simp: fun_upd_idem)

  subsubsection \<open>Push and Pop\<close>
  lemma list_assn_push_back:
    shows "(\<upharpoonleft>(list_assn A R) xs ys ** \<upharpoonleft>A x y) \<turnstile> (\<upharpoonleft>(list_assn A R) (xs@[x]) (ys@[y]))"
    unfolding list_assn_def
    apply (clarsimp simp: sep_algebra_simps atLeast0_lessThan_Suc entails_lift_extract_simps
      insert_Diff_if le_idxe_map_append2I; safe)
    apply (auto dest: le_idxe_map_lenD; fail)
    apply (rule ENTAILSD)
    supply [simp] = nth_append
    by vcg

  lemma list_assn_pop_back1:
    assumes "R (length xs - 1) \<noteq> None"
    shows "\<upharpoonleft>(list_assn A R) xs ys \<turnstile> \<upharpoonleft>(list_assn A (R(length xs-1 := None))) (butlast xs) (butlast ys)"
    using assms unfolding list_assn_def
    apply (rule_tac entails_pureI)
    apply (cases xs rule: rev_cases; cases ys rule: rev_cases)
    apply (clarsimp_all
      dest!: pure_part_split_conj
      simp: sep_algebra_simps atLeast0_lessThan_Suc domI set_minus_minus_disj_conv)
    apply (rule ENTAILSD)
    supply [simp] = le_idxe_map_append1I
    by vcg

  lemma list_assn_pop_back2:
    assumes "xs\<noteq>[]" "R (length xs - 1) = None"
    shows "(\<upharpoonleft>(list_assn A R) xs ys) \<turnstile> (\<upharpoonleft>(list_assn A R) (butlast xs) (butlast ys) ** \<upharpoonleft>A (last xs) (last ys))"
    apply (rule entails_pureI) using assms
    apply vcg_prepare_external
    apply (sep_drule_simple list_assn_extract[where i="length xs - 1"])
    subgoal by (cases ys; simp)
    subgoal by simp
    apply (sep_drule_simple list_assn_pop_back1)
    subgoal by auto
    by (cases ys rule: rev_cases; simp add: last_conv_nth fun_upd_idem)

  subsection \<open>Fri-Reduce Rules for List-Assertion\<close>
  lemma la_red_extract:
    "PRECOND (SOLVE_AUTO (R i = None \<and> i<length xs))
      \<Longrightarrow> is_sep_red (\<upharpoonleft>(list_assn A (R(i\<mapsto>ys!i))) xs ys) \<box> (\<upharpoonleft>(list_assn A R) xs ys) (\<upharpoonleft>A (xs!i) (ys!i))"
    apply (clarsimp simp: vcg_tag_defs)
    apply (rule is_sep_redI)
    apply (sep_drule_simple list_assn_extract, assumption+)
    apply (erule gen_drule, fri)
    apply (rule ENTAILSD, fri)
    done

  lemma la_red_join:
    "PRECOND (SOLVE_AUTO (R i = None \<and> i<length xs \<and> x=xs!i \<and> y=ys!i))
      \<Longrightarrow> is_sep_red \<box> (\<upharpoonleft>(list_assn A (R(i\<mapsto>ys!i))) xs ys) (\<upharpoonleft>A x y) (\<upharpoonleft>(list_assn A R) xs ys)"
    apply (clarsimp simp: vcg_tag_defs)
    apply (rule is_sep_redI)
    apply (sep_rule list_assn_join')
    apply assumption+
    apply (erule gen_drule, fri)
    apply (rule ENTAILSD, fri)
    done

  subsection \<open>Tags for List-Assertion\<close>

  definition tag_la_upd :: "'b::llvm_rep \<Rightarrow> 'a word \<Rightarrow> 'd::llvm_rep \<Rightarrow> unit llM"
    where "tag_la_upd p i y = return ()"

  lemma tag_la_upd_rl[vcg_rules]:
    shows "llvm_htriple
      (\<upharpoonleft>tag_assn i ii ** \<upharpoonleft>AA ys p ** \<upharpoonleft>(list_assn A R) xs ys ** \<upharpoonleft>A x y ** \<up>(R i \<noteq> None))
      (tag_la_upd p ii y)
      (\<lambda>_. \<upharpoonleft>(list_assn A (R(i:=None))) (xs[i:=x]) (ys[i:=y]) ** \<upharpoonleft>AA ys p)"
    supply [vcg_rules] = tag_op_ruleI[OF tag_la_upd_def[where i=ii] list_assn_update[where i=i]]
    by vcg

  definition tag_la_join :: "'b::llvm_rep \<Rightarrow> 'a word \<Rightarrow> 'd::llvm_rep \<Rightarrow> unit llM"
    where "tag_la_join p i y = return ()"

  lemma tag_la_join_rl[vcg_rules]:
    shows "llvm_htriple
      (\<upharpoonleft>tag_assn i ii ** \<upharpoonleft>AA ys p ** \<upharpoonleft>(list_assn A R) xs ys ** \<upharpoonleft>A x y ** \<up>(R i = Some y \<and> x=xs!i))
      (tag_la_join p ii y)
      (\<lambda>_. \<upharpoonleft>(list_assn A (R(i:=None))) xs ys ** \<upharpoonleft>AA ys p)"
    supply [vcg_rules] = tag_op_ruleI[OF tag_la_join_def[where i=ii] list_assn_join[where i=i]]
    by vcg

  definition "tag_la_extract p i = return ()"

  (*
    TODO: We have to use tag-assn for pure (i), and variables (AA) for impure assertions:
      Otherwise, current frame-inference's pure extraction will not unify
      variable assertion with pure assertion! FIX THAT!
  *)

  lemma tag_la_extract_rl[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>tag_assn i ii ** \<upharpoonleft>AA ys p ** \<upharpoonleft>(list_assn A R) xs ys ** \<up>(R i = None \<and> i<length xs))
      (tag_la_extract p ii)
      (\<lambda>_. \<upharpoonleft>(list_assn A (R(i\<mapsto>ys!i))) xs ys ** \<upharpoonleft>A (xs!i) (ys!i) ** \<upharpoonleft>AA ys p ** \<up>(length xs = length ys))"
    supply [vcg_rules] = tag_op_ruleI[OF tag_la_extract_def[where i=ii] list_assn_extract[where i=i]]
    apply vcg
    done

  definition "tag_la_push_back p x = return ()"

  lemma tag_la_push_back_rl[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>AA ys p ** \<upharpoonleft>(list_assn A R) xs ys ** \<upharpoonleft>A x y)
      (tag_la_push_back p y)
      (\<lambda>_. \<upharpoonleft>(list_assn A R) (xs@[x]) (ys@[y]) ** \<upharpoonleft>AA ys p)"
    supply [vcg_rules] = tag_op_ruleI[OF tag_la_push_back_def[where p=p] list_assn_push_back]
    by vcg

  definition "tag_la_pop_back p = return ()"
  lemma tag_la_pop_back_rl[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>AA ys p ** \<upharpoonleft>(list_assn A R) xs ys ** \<up>(xs\<noteq>[] \<and> R (length xs-1) = None))
      (tag_la_pop_back p)
      (\<lambda>_. \<upharpoonleft>AA ys p ** \<upharpoonleft>(list_assn A R) (butlast xs) (butlast ys) ** \<upharpoonleft>A (last xs) (last ys) ** \<up>(xs\<noteq>[] \<and> ys\<noteq>[]))"
    supply [vcg_rules] = tag_op_ruleI[OF tag_la_pop_back_def[where p=p] list_assn_pop_back2]
    apply (rule htriple_pure_preI)
    by vcg

  subsection \<open>Pure List Assertion\<close>
  (* TODO: is_pure list_assn rule *)

  definition "tag_la_exfree_pure p i = return ()"

  lemma bury_pure_red: "PRECOND (SOLVE_ASM (is_pure A)) \<Longrightarrow> is_sep_red \<box> \<box> (\<upharpoonleft>A a c) \<box>"
    unfolding vcg_tag_defs
    apply (rule is_sep_redI)
    apply (sep_drule bury_pure_assn)
    by simp

  lemma tag_la_exfree_pure_rl[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>tag_assn i ii ** \<upharpoonleft>AA ys p ** \<upharpoonleft>(list_assn A R) xs ys ** \<up>(is_pure A \<and> R i = None \<and> i<length xs))
      (tag_la_exfree_pure p ii)
      (\<lambda>_. \<upharpoonleft>(list_assn A (R(i\<mapsto>ys!i))) xs ys ** \<upharpoonleft>AA ys p ** \<up>(length xs = length ys))"
    supply R[vcg_rules] =
      tag_op_ruleI[OF tag_la_exfree_pure_def[where i=ii] list_assn_extract[where i=i], of xs R A ys]
    thm R
    apply vcg
    apply vcg_try_solve
    subgoal (* TODO: Dirty hack! *)
      unfolding FRAME_INFER_def FRI_END_def
      apply (sep_drule_simple bury_pure_assn')
      by simp
    done

end


theory WellTypedAlt
  imports WTLemma
begin

datatype wta_tag =
  ConstRule
  | OpRule
  | VarRule
  | PairRule wta_tag wta_tag
  | IfRule wta_tag wta_tag wta_tag
  | LamRule wta_tag
  | AppRule wta_tag wta_tag
  | WeakPostRule wta_tag
  | StrReqRule wta_tag
  | WeakReqRule wta_tag

fun well_typed_alt :: "wta_tag \<Rightarrow> pt_env \<Rightarrow> owner_env \<Rightarrow> perm_use_env \<Rightarrow> p_exp \<Rightarrow> p_type \<Rightarrow> perm_use_env \<Rightarrow> perm_use_env \<Rightarrow> bool" where
  "well_typed_alt ConstRule env delta r_s1 e tau r_s2 rx = (\<exists> c. e = ConstExp c \<and> tau \<in> const_type c \<and> r_s2 = r_s1 \<and> rx = empty_use_env)"
| "well_typed_alt OpRule env delta r_s1 e tau r_s2 rx = (\<exists> xop. e = OpExp xop \<and> tau = op_type xop \<and> r_s2 = r_s1 \<and> rx = empty_use_env)"
| "well_typed_alt VarRule env delta r_s1 e tau r_s2 rx = (\<exists> v tau_x. e = VarExp v \<and> env (res_name v) = Some tau \<and>
    env (owner_name delta v) = Some tau_x \<and> leq_use_env (ereq_use_env (owner_name delta v) tau_x) r_s1 \<and> r_s2 = diff_use_env r_s1 (ereq_use_env (owner_name delta v) tau_x) \<and>
    rx = diff_use_env (ereq_use_env (owner_name delta v) tau_x) (ereq_use_env (owner_name delta v) tau_x))"
| "well_typed_alt (PairRule w1 w2) env delta r_s1 e tau r_s3 rf = (\<exists> e1 e2 t1 t2 r r_s2 rx1 rx2. e = PairExp e1 e2 \<and>
    tau = PairTy t1 t2 r \<and> well_typed_alt w1 env delta r_s1 e1 t1 r_s2 rx1 \<and> well_typed_alt w2 env delta r_s2 e2 t2 r_s3 rx2 \<and>
    leq_use_env (lift_use_env rx1 r) r_s3 \<and> leq_use_env (lift_use_env rx2 r) r_s3 \<and> aff_leq (max_aff (req_type t1) (req_type t2)) r \<and>
    disj_use_env (lift_use_env rx1 r) (lift_use_env rx2 r) \<and>
    rf = pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) empty_use_env tau
  )"
| "well_typed_alt (IfRule w1 w2 w3) env delta r_s1 e tau r_s3 rx = (\<exists> e1 e2 e3 rx' r_s2 rx1 rx2. e = IfExp e1 e2 e3 \<and>
    well_typed_alt w1 env delta r_s1 e1 BoolTy r_s2 rx' \<and> well_typed_alt w2 env delta r_s2 e2 tau r_s3 rx1 \<and> well_typed_alt w3 env delta r_s2 e3 tau r_s3 rx2 \<and>
    rx = comp_use_env rx1 rx2)"
| "well_typed_alt (LamRule w) env delta r_s1 ex tau r_s2 rx = (\<exists> x e t1 t2 r a r_end r_s'. ex = LamExp x e \<and>
    tau = FunTy t1 t2 r a \<and>
    well_typed_alt w (add_env env (Var x) t1) delta (add_use_env rx (Var x) r) e t2 r_s' r_end \<and> aff_use_env rx a \<and>
    leq_use_env rx r_s1 \<and> r_s2 = r_s1)"
| "well_typed_alt (AppRule w1 w2) env delta r_s1 e tau r_sf rx = (\<exists> e1 e2 t1 r a r_s2 rx1 rx2 r_s3. e = AppExp e1 e2 \<and>
    well_typed_alt w1 env delta r_s1 e1 (FunTy t1 tau r a) r_s2 rx1 \<and> well_typed_alt w2 env delta r_s2 e2 t1 r_s3 rx2 \<and>
    r_sf = diff_use_env r_s3 (comp_use_env rx1 (lift_use_env rx2 r)) \<and> (*r \<noteq> NoPerm \<and>*) (*safe_use_lift rx2 r \<and>
    safe_type t1 r \<and>*) leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s3 \<and>
    disj_use_env rx1 (lift_use_env rx2 r) \<and> leq_use_env rx r_sf \<and>
    rx = app_req rx1 rx2 r tau empty_use_env
  )"
| "well_typed_alt (WeakPostRule tag) env delta r_s1 e tau r_s2 rx = (\<exists> r_c. well_typed_alt tag env delta r_s1 e tau r_c rx \<and>
    leq_use_env rx r_s2 \<and> leq_use_env r_s2 r_c)"
| "well_typed_alt (StrReqRule tag) env delta r_s1 e tau r_s2 rx = (\<exists> rx'. well_typed_alt tag env delta r_s1 e tau r_s2 rx' \<and>
    leq_use_env rx' rx \<and> leq_use_env rx r_s2)"
| "well_typed_alt (WeakReqRule tag) env delta r_s1 e tau r_s2 rx = (\<exists> r_se r_xe r_ex. well_typed_alt tag env delta r_s1 e tau r_se r_xe \<and>
    r_s2 = diff_use_env r_se r_ex \<and> rx = diff_use_env r_xe r_ex \<and> leq_use_env r_ex r_s1)"

lemma well_typed_equiv1: "\<lbrakk> well_typed env delta r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> (\<exists> tag. well_typed_alt tag env delta r_s1 e tau r_s2 rx)"
  apply (induct e arbitrary: env r_s1 r_s2 tau rx)
        apply (auto)
    (* const case *)
        apply (rule_tac x="StrReqRule (WeakPostRule ConstRule)" in exI)
        apply (auto)
         apply (rule_tac leq_empty_use_env)
        apply (rule_tac leq_empty_use_env)
    (* op case *)
       apply (rule_tac x="StrReqRule (WeakPostRule OpRule)" in exI)
       apply (auto)
        apply (rule_tac leq_empty_use_env)
       apply (rule_tac leq_empty_use_env)
    (* var case *)
      apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule VarRule))" in exI)
      apply (auto)
      apply (rule_tac x="diff_use_env (diff_use_env r_s1 (ereq_use_env (owner_name delta x) tau_x)) r_ex" in exI)
      apply (auto)
       apply (rule_tac x="diff_use_env (diff_use_env (ereq_use_env (owner_name delta x) tau_x) (ereq_use_env (owner_name delta x) tau_x)) r_ex" in exI)
       apply (auto)
        apply (rule_tac lhs_fold_dcl_use_env)
        apply (simp)
       apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
        apply (rule_tac rhs_fold_dcl_use_env)
        apply (simp_all)
      apply (rule_tac rhs_fold_dcl_use_env)
      apply (simp)
    (* pair case *)
     apply (case_tac "\<exists>tag. well_typed_alt tag env delta r_s1 e1 t1 r_s2a rx1")
      apply (erule_tac exE)
      apply (auto)
     apply (case_tac "\<exists>tag. well_typed_alt tag env delta r_s2a e2 t2 r_s3 rx2")
      apply (erule_tac exE)
      apply (auto)
     apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule (PairRule tag taga)))" in exI)
     apply (auto)
     apply (rule_tac x="diff_use_env r_s3 r_ex" in exI)
     apply (auto)
     apply (rule_tac x="pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) r_ex (PairTy t1 t2 r)" in exI)
     apply (auto)
      apply (rule_tac x="r_s3" in exI)
      apply (rule_tac x="pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) empty_use_env (PairTy t1 t2 r)" in exI)
      apply (auto)
      apply (rule_tac x="r_ex" in exI)
      apply (auto)
      apply (simp add: pair_req_def)
      apply (auto)
       apply (simp add: diff_empty_use_env1)
      apply (simp add: diff_empty_use_env2)
     apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
      apply (auto)
    (* if case *)
     apply (case_tac "\<exists>tag. well_typed_alt tag env delta r_s1 e1 BoolTy r_s2a rx'")
      apply (erule_tac exE)
      apply (auto)
     apply (case_tac "\<exists>tag. well_typed_alt tag env delta r_s2a e2 tau r_s2 rx1")
      apply (erule_tac exE)
      apply (auto)
     apply (case_tac "\<exists>tag. well_typed_alt tag env delta r_s2a e3 tau r_s2 rx2")
      apply (erule_tac exE)
      apply (auto)
    apply (rule_tac x="IfRule tag taga tagb" in exI)
    apply (auto)
    (* lam case *)
   apply (case_tac "\<exists>tag. well_typed_alt tag (add_env env (Var x1a) t1) delta (add_use_env rxa (Var x1a) r) e t2 r_s' r_end")
    apply (erule_tac exE)
    apply (auto)
   apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule (LamRule tag)))" in exI)
   apply (auto)
   apply (rule_tac x="diff_use_env r_s1 r_ex" in exI)
   apply (auto)
   apply (rule_tac x="diff_use_env rxa r_ex" in exI)
   apply (auto)
   apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
    apply (auto)
    (* app case *)
  apply (case_tac "\<exists>tag. well_typed_alt tag env delta r_s1 e1 (FunTy t1 tau r a) r_s2a rx1")
   apply (erule_tac exE)
   apply (auto)
  apply (case_tac "\<exists>tag. well_typed_alt tag env delta r_s2a e2 t1 r_s3 rx2")
   apply (erule_tac exE)
   apply (auto)
  apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule (AppRule tag taga)))" in exI)
  apply (auto)
  apply (rule_tac x="diff_use_env (diff_use_env r_s3 (comp_use_env rx1 (lift_use_env rx2 r))) r_ex" in exI)
  apply (auto)
   apply (rule_tac x="app_req rx1 rx2 r tau r_ex" in exI)
   apply (auto)
    apply (rule_tac x="diff_use_env r_s3 (comp_use_env rx1 (lift_use_env rx2 r))" in exI)
    apply (rule_tac x="app_req rx1 rx2 r tau empty_use_env" in exI)
    apply (auto)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="r" in exI)
     apply (rule_tac x="a" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
     apply (simp add: app_req_def)
     apply (auto)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac dist_diff_leq_use_env_gen)
      apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
       apply (simp)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac self_comp_leq_use_env1)
      apply (rule_tac comp_leq_use_env2)
      apply (rule_tac self_lift_leq_use_env)
     apply (rule_tac self_comp_leq_use_env1)
    apply (rule_tac x="r_ex" in exI)
    apply (auto)
    apply (simp add: app_req_def)
    apply (auto)
     apply (simp add: diff_empty_use_env1)
    apply (simp add: comp_empty_use_env2)
    apply (simp add: diff_comp_use_env)
   apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
    apply (rule_tac rhs_fold_dcl_use_env)
    apply (simp_all)
  apply (rule_tac rhs_fold_dcl_use_env)
  apply (simp)
  done

lemma well_typed_equiv2: "\<lbrakk> well_typed_alt tag env delta r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> well_typed env delta r_s1 e tau r_s2 rx"
  apply (induct tag arbitrary: env r_s1 e tau r_s2 rx)
           apply (auto)
    (* const + op case *)
             apply (rule_tac id_leq_use_env)
            apply (rule_tac leq_empty_use_env)
           apply (rule_tac id_leq_use_env)
          apply (rule_tac leq_empty_use_env)
    (* var case *)
         apply (rule_tac x="empty_use_env" in exI)
         apply (auto)
           apply (rule_tac dist_diff_leq_use_env_gen)
            apply (rule_tac id_leq_use_env)
           apply (rule_tac dist_comp_leq_use_env)
            apply (rule_tac id_leq_use_env)
           apply (rule_tac leq_empty_use_env)
          apply (rule_tac dist_diff_leq_use_env_gen)
           apply (simp)
          apply (rule_tac id_leq_use_env)
         apply (rule_tac leq_empty_use_env)
        apply (rule_tac dist_diff_leq_use_env_gen)
         apply (rule_tac id_leq_use_env)
        apply (rule_tac self_comp_leq_use_env1)
    (* pair case *)
       apply (rule_tac x="r_s2a" in exI)
       apply (rule_tac x="r_s2" in exI)
       apply (rule_tac x="rx1" in exI)
       apply (auto)
       apply (rule_tac x="rx2" in exI)
       apply (auto)
       apply (rule_tac x="empty_use_env" in exI)
       apply (auto)
          apply (simp add: diff_empty_use_env2)
          apply (rule_tac id_leq_use_env)
         apply (simp add: pair_req_def)
         apply (auto)
          apply (rule_tac leq_empty_use_env)
         apply (rule_tac diff_leq_use_env)
         apply (rule_tac dist_comp_leq_use_env)
          apply (simp_all)
        apply (rule_tac leq_empty_use_env)
       apply (simp add: pair_req_def)
       apply (auto)
        apply (rule_tac leq_empty_use_env)
        apply (rule_tac id_leq_use_env)
    (* if case *)
      apply (rule_tac x="rx'" in exI)
      apply (rule_tac x="r_s2a" in exI)
       apply (auto)
       apply (rule_tac x="rx1" in exI)
       apply (auto)
       apply (rule_tac x="rx2" in exI)
       apply (auto)
    (* lam case *)
      apply (rule_tac x="rx" in exI)
      apply (auto)
       apply (rule_tac x="r_end" in exI)
       apply (rule_tac x="r_s'" in exI)
       apply (auto)
      apply (rule_tac x="empty_use_env" in exI)
      apply (auto)
         apply (simp add: diff_empty_use_env2)
         apply (rule_tac id_leq_use_env)
       apply (rule_tac leq_empty_use_env)
      apply (rule_tac self_diff_leq_use_env)
    (* app case *)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="r" in exI)
     apply (rule_tac x="a" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
     apply (rule_tac x="empty_use_env" in exI)
     apply (auto)
       apply (rule_tac dist_diff_leq_use_env_gen)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac dist_comp_leq_use_env)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac leq_empty_use_env)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac id_leq_use_env)
    (* post weakening case *)
    apply (rule_tac r_c="r_c" in well_typed_decr_end_perm)
      apply (auto)
    (* req strengthening case *)
   apply (rule_tac rx="rx'" in well_typed_incr_req)
     apply (auto)
    (* req weakening case *)
  apply (rule_tac well_typed_diff_end_perm)
   apply (auto)
  done

end


theory ArityTransformSafe
imports ArityTransform ArityConsistent ArityAnalysisSpec ArityEtaExpansionSafe AbstractTransform ConstOn
begin

locale CardinalityArityTransformation = ArityAnalysisLetSafeNoCard
begin
  sublocale AbstractTransformBoundSubst
    "\<lambda> a . inc\<cdot>a"
    "\<lambda> a . pred\<cdot>a"
    "\<lambda> \<Delta> e a . (a, Aheap \<Delta> e\<cdot>a)"
    "fst"
    "snd"
    "\<lambda> _. 0"
    "Aeta_expand"
    "snd"
  apply standard
  apply (simp add: Aheap_subst)
  apply (rule subst_Aeta_expand)
  done

  abbreviation ccTransform where "ccTransform \<equiv> transform"

  lemma supp_transform: "supp (transform a e) \<subseteq> supp e"
    by (induction rule: transform.induct)
       (auto simp add: exp_assn.supp Let_supp dest!: subsetD[OF supp_map_transform] subsetD[OF supp_map_transform_step] )
  interpretation supp_bounded_transform transform
    by standard (auto simp add: fresh_def supp_transform)

  fun transform_alts :: "Arity list \<Rightarrow> stack \<Rightarrow> stack"
    where
      "transform_alts _ [] = []"
    | "transform_alts (a#as) (Alts e1 e2 # S) = (Alts (ccTransform a e1) (ccTransform a e2)) # transform_alts as S"
    | "transform_alts as (x # S) = x # transform_alts as S"

  lemma transform_alts_Nil[simp]: "transform_alts [] S = S"
    by (induction  S) auto

  lemma Astack_transform_alts[simp]:
    "Astack (transform_alts as S) = Astack S"
   by (induction rule: transform_alts.induct) auto

  lemma fresh_star_transform_alts[intro]: "a \<sharp>* S \<Longrightarrow> a \<sharp>* transform_alts as S"
   by (induction as S  rule: transform_alts.induct) (auto simp add: fresh_star_Cons)

  fun a_transform :: "astate \<Rightarrow> conf \<Rightarrow> conf"
  where "a_transform (ae, a, as) (\<Gamma>, e, S) =
    (map_transform Aeta_expand ae (map_transform ccTransform ae \<Gamma>),
     ccTransform a e,
     transform_alts as  S)"

  fun restr_conf :: "var set \<Rightarrow> conf \<Rightarrow> conf"
    where "restr_conf V (\<Gamma>, e, S) = (restrictA V \<Gamma>, e, restr_stack V S)"

  inductive consistent :: "astate \<Rightarrow> conf \<Rightarrow> bool" where
    consistentI[intro!]:
    "a_consistent (ae, a, as) (\<Gamma>, e, S)
    \<Longrightarrow> (\<And> x. x \<in> thunks \<Gamma> \<Longrightarrow>  ae x = up\<cdot>0)
    \<Longrightarrow> consistent (ae, a, as) (\<Gamma>, e, S)"
  inductive_cases consistentE[elim!]: "consistent (ae, a, as) (\<Gamma>, e, S)"

  lemma closed_consistent:
    assumes "fv e = ({}::var set)"
    shows "consistent (\<bottom>, 0, []) ([], e, [])"
  by (auto simp add: edom_empty_iff_bot closed_a_consistent[OF assms])

  lemma arity_tranform_safe:
    fixes c c'
    assumes "c \<Rightarrow>\<^sup>* c'" and "\<not> boring_step c'" and "heap_upds_ok_conf c" and "consistent (ae,a,as) c"
    shows "\<exists>ae' a' as'. consistent (ae',a',as') c' \<and> a_transform (ae,a,as) c \<Rightarrow>\<^sup>* a_transform (ae',a',as') c'"
  using assms(1,2) heap_upds_ok_invariant assms(3-)
  proof(induction c c' arbitrary: ae a as rule:step_invariant_induction)
  case (app\<^sub>1 \<Gamma> e x S)
    from app\<^sub>1 have "consistent (ae, inc\<cdot>a, as) (\<Gamma>, e, Arg x # S)"
      by (auto intro: a_consistent_app\<^sub>1)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, App e x, S) \<Rightarrow> a_transform (ae, inc\<cdot>a, as) (\<Gamma>, e, Arg x # S)"
      by simp rule
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
  case (app\<^sub>2 \<Gamma> y e x S)
    have "consistent (ae, pred\<cdot>a, as) (\<Gamma>, e[y::=x], S)" using app\<^sub>2
      by (auto 4 3 intro: a_consistent_app\<^sub>2)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, Lam [y]. e, Arg x # S) \<Rightarrow> a_transform (ae, pred \<cdot> a, as) (\<Gamma>, e[y::=x], S)" by (simp add: subst_transform[symmetric]) rule
    ultimately
    show ?case by (blast  del: consistentI consistentE)
  next
  case (thunk \<Gamma> x e S)
    hence "x \<in> thunks \<Gamma>" by auto
    hence [simp]: "x \<in> domA \<Gamma>" by (rule subsetD[OF thunks_domA])

    from \<open>heap_upds_ok_conf (\<Gamma>, Var x, S)\<close>
    have "x \<notin> upds S"  by (auto dest!: heap_upds_okE)

    have "x \<in> edom ae" using thunk by auto
    have "ae x = up\<cdot>0" using thunk \<open>x \<in> thunks \<Gamma>\<close> by (auto)

    have "a_consistent (ae, 0, as) (delete x \<Gamma>, e, Upd x # S)" using thunk \<open>ae x = up\<cdot>0\<close>
      by (auto intro!: a_consistent_thunk_0 simp del: restr_delete)
    hence "consistent (ae, 0, as) (delete x \<Gamma>, e, Upd x # S)" using thunk \<open>ae x = up\<cdot>0\<close>
      by (auto simp add:  restr_delete_twist)
    moreover

    from  \<open>map_of \<Gamma> x = Some e\<close> \<open>ae x = up\<cdot>0\<close>
    have "map_of (map_transform Aeta_expand ae (map_transform ccTransform ae \<Gamma>)) x = Some (transform 0 e)"
      by (simp add: map_of_map_transform)
    with \<open>\<not> isVal e\<close>
    have "a_transform (ae, a, as) (\<Gamma>, Var x, S) \<Rightarrow> a_transform (ae, 0, as) (delete x \<Gamma>, e, Upd x # S)"
      by (auto simp add: map_transform_delete restr_delete_twist intro!: step.intros  simp del: restr_delete)
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
  case (lamvar \<Gamma> x e S)
    from lamvar(1) have [simp]: "x \<in> domA \<Gamma>" by (metis domI dom_map_of_conv_domA)

    have "up\<cdot>a \<sqsubseteq> (Aexp (Var x)\<cdot>a f|` (domA \<Gamma> \<union> upds S)) x"
      by (simp) (rule Aexp_Var)
    also from lamvar have "Aexp (Var x)\<cdot>a f|` (domA \<Gamma> \<union> upds S) \<sqsubseteq> ae" by (auto simp add: join_below_iff env_restr_join a_consistent.simps)
    finally
    obtain u where "ae x = up\<cdot>u" by (cases "ae x") (auto simp add: edom_def)
    hence "x \<in> edom ae" by (auto simp add: edomIff)

    have "a_consistent (ae, u, as) ((x,e) # delete x \<Gamma>, e, S)" using lamvar \<open>ae x = up\<cdot>u\<close>
      by (auto intro!: a_consistent_lamvar simp del: restr_delete)
    hence "consistent (ae, u, as) ((x, e) # delete x \<Gamma>, e, S)"
      using lamvar by (auto simp add:  thunks_Cons restr_delete_twist elim: below_trans)
    moreover

    from \<open>a_consistent _ _\<close>
    have "Astack (transform_alts as S) \<sqsubseteq> u" by (auto elim: a_consistent_stackD)

    {
    from \<open>isVal e\<close>
    have "isVal (transform u e)" by simp
    hence "isVal (Aeta_expand u (transform u e))" by (rule isVal_Aeta_expand)
    moreover
    from  \<open>map_of \<Gamma> x = Some e\<close>  \<open>ae x = up \<cdot> u\<close>  \<open>isVal (transform u e)\<close>
    have "map_of (map_transform Aeta_expand ae (map_transform transform ae \<Gamma>)) x = Some (Aeta_expand u (transform u e))"
      by (simp add: map_of_map_transform)
    ultimately
    have "a_transform (ae, a, as) (\<Gamma>, Var x, S) \<Rightarrow>\<^sup>*
          ((x, Aeta_expand u (transform u e)) # delete x (map_transform Aeta_expand ae (map_transform transform ae \<Gamma>)), Aeta_expand u (transform u e), transform_alts as S)"
       by (auto intro: lambda_var simp del: restr_delete)
    also have "\<dots> = ((map_transform Aeta_expand ae (map_transform transform ae ((x,e) # delete x \<Gamma>))), Aeta_expand u (transform u e), transform_alts as S)"
      using \<open>ae x = up \<cdot> u\<close> \<open>isVal (transform u e)\<close>
      by (simp add: map_transform_Cons map_transform_delete  del: restr_delete)
    also(subst[rotated]) have "\<dots> \<Rightarrow>\<^sup>* a_transform (ae, u, as) ((x, e) # delete x \<Gamma>, e, S)"
      by (simp add: restr_delete_twist) (rule Aeta_expand_safe[OF \<open>Astack _ \<sqsubseteq> u\<close>])
    finally(rtranclp_trans)
    have "a_transform (ae, a, as) (\<Gamma>, Var x, S) \<Rightarrow>\<^sup>* a_transform (ae, u, as) ((x, e) # delete x \<Gamma>, e, S)".
    }
    ultimately show ?case by (blast del: consistentI consistentE)
  next
  case (var\<^sub>2 \<Gamma> x e S)
    from var\<^sub>2
    have "a_consistent (ae, a, as) (\<Gamma>, e, Upd x # S)" by auto
    from a_consistent_UpdD[OF this]
    have "ae x = up\<cdot>0" and "a = 0".

    have "a_consistent (ae, a, as) ((x, e) # \<Gamma>, e, S)"
      using var\<^sub>2 by (auto intro!: a_consistent_var\<^sub>2)
    hence "consistent (ae, 0, as) ((x, e) # \<Gamma>, e, S)"
      using var\<^sub>2 \<open>a = 0\<close>
      by (auto simp add: thunks_Cons elim: below_trans)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, e, Upd x # S) \<Rightarrow> a_transform (ae, 0, as) ((x, e) # \<Gamma>, e, S)"
      using \<open>ae x = up\<cdot>0\<close> \<open>a = 0\<close> var\<^sub>2
      by (auto intro!: step.intros simp add: map_transform_Cons)
    ultimately show ?case by (blast del: consistentI consistentE)
  next
    case (let\<^sub>1 \<Delta> \<Gamma> e S)
    let ?ae = "Aheap \<Delta> e\<cdot>a"

    have "domA \<Delta> \<inter> upds S = {}" using fresh_distinct_fv[OF let\<^sub>1(2)] by (auto dest: subsetD[OF ups_fv_subset])
    hence *: "\<And> x. x \<in> upds S \<Longrightarrow> x \<notin> edom ?ae" by (auto simp add:  dest!: subsetD[OF edom_Aheap])
    have restr_stack_simp2: "restr_stack (edom (?ae \<squnion> ae)) S = restr_stack (edom ae) S"
      by (auto intro: restr_stack_cong dest!: *)

    have "edom ae \<subseteq> domA \<Gamma> \<union> upds S" using let\<^sub>1 by (auto dest!: a_consistent_edom_subsetD)
    from subsetD[OF this] fresh_distinct[OF let\<^sub>1(1)] fresh_distinct_fv[OF let\<^sub>1(2)]
    have "edom ae \<inter> domA \<Delta> = {}" by (auto dest: subsetD[OF ups_fv_subset])

    {
    { fix x e'
      assume "x \<in> thunks \<Gamma>"
      with let\<^sub>1
      have "(?ae \<squnion> ae) x = up\<cdot>0" by auto
    }
    moreover
    { fix x e'
      assume "x \<in> thunks \<Delta>"
      hence "(?ae \<squnion> ae) x = up\<cdot>0" by (auto simp add: Aheap_heap3)
    }
    moreover

    have "a_consistent (ae, a, as) (\<Gamma>, Let \<Delta> e, S)"
      using let\<^sub>1 by auto
    hence "a_consistent (?ae \<squnion> ae, a, as) (\<Delta> @ \<Gamma>, e, S)"
      using let\<^sub>1(1,2) \<open>edom ae \<inter> domA \<Delta> = {}\<close>
      by (auto intro!:  a_consistent_let simp del: join_comm)
    ultimately
    have "consistent (?ae \<squnion> ae, a, as) (\<Delta> @ \<Gamma>, e, S)"
      by auto
    }
    moreover
    {
      have "\<And> x. x \<in> domA \<Gamma> \<Longrightarrow> x \<notin> edom ?ae"
        using fresh_distinct[OF let\<^sub>1(1)]
        by (auto dest!: subsetD[OF edom_Aheap])
      hence "map_transform Aeta_expand (?ae \<squnion> ae) (map_transform transform (?ae \<squnion> ae) \<Gamma>)
         = map_transform Aeta_expand ae (map_transform transform ae \<Gamma>)"
         by (auto intro!: map_transform_cong restrictA_cong simp add: edomIff)
      moreover

      from \<open>edom ae \<subseteq> domA \<Gamma> \<union> upds S\<close>
      have  "\<And> x. x \<in> domA \<Delta> \<Longrightarrow> x \<notin> edom ae"
         using fresh_distinct[OF let\<^sub>1(1)] fresh_distinct_fv[OF let\<^sub>1(2)]
         by (auto dest!:  subsetD[OF ups_fv_subset])
      hence "map_transform Aeta_expand (?ae \<squnion> ae) (map_transform transform (?ae \<squnion> ae) \<Delta>)
         = map_transform Aeta_expand ?ae (map_transform transform ?ae \<Delta>)"
         by (auto intro!: map_transform_cong restrictA_cong simp add: edomIff)
      ultimately

      have "a_transform (ae, a, as) (\<Gamma>, Let \<Delta> e, S) \<Rightarrow> a_transform (?ae \<squnion> ae,  a, as) (\<Delta> @ \<Gamma>, e, S)"
        using restr_stack_simp2 let\<^sub>1(1,2)
        apply (auto simp add: map_transform_append restrictA_append  restr_stack_simp2[simplified] map_transform_restrA)
        apply (rule step.let\<^sub>1)
        apply (auto dest: subsetD[OF edom_Aheap])
        done
    }
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case (if\<^sub>1 \<Gamma> scrut e1 e2 S)
    have "consistent (ae, 0, a#as) (\<Gamma>, scrut, Alts e1 e2 # S)"
      using if\<^sub>1  by (auto dest: a_consistent_if\<^sub>1)
    moreover
    have "a_transform (ae,  a, as) (\<Gamma>, scrut ? e1 : e2, S) \<Rightarrow> a_transform (ae, 0, a#as) (\<Gamma>, scrut, Alts e1 e2 # S)"
      by (auto intro: step.intros)
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case (if\<^sub>2 \<Gamma> b e1 e2 S)
    hence "a_consistent (ae, a, as) (\<Gamma>, Bool b, Alts e1 e2 # S)" by auto
    then  obtain a' as' where [simp]: "as = a' # as'" "a = 0"
      by (rule a_consistent_alts_on_stack)

    have "consistent (ae, a', as') (\<Gamma>, if b then e1 else e2, S)"
      using if\<^sub>2 by (auto dest!: a_consistent_if\<^sub>2)
    moreover
    have "a_transform (ae, a, as) (\<Gamma>, Bool b, Alts e1 e2 # S) \<Rightarrow> a_transform (ae,  a', as') (\<Gamma>, if b then e1 else e2, S)"
      by (auto intro: step.if\<^sub>2[where b = True, simplified] step.if\<^sub>2[where b = False, simplified])
    ultimately
    show ?case by (blast del: consistentI consistentE)
  next
    case refl thus ?case by auto
  next
    case (trans c c' c'')
      from trans(3)[OF trans(5)]
      obtain ae' a' as' where "consistent (ae', a', as') c'" and *: "a_transform (ae, a, as) c \<Rightarrow>\<^sup>* a_transform (ae', a', as') c'" by blast
      from trans(4)[OF this(1)]
      obtain ae'' a'' as'' where "consistent (ae'', a'', as'') c''" and **: "a_transform (ae', a', as') c' \<Rightarrow>\<^sup>* a_transform (ae'', a'', as'') c''" by blast
      from this(1) rtranclp_trans[OF * **]
      show ?case by blast
  qed
end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory PolicySystemSAC
imports
  Noninterference
  "Access.ExampleSystem"
begin

text \<open>
  Reads/Affects sets:
  - NicA, NicB, NicD: reads all except T
       affects {RM, R, NicA, NicB, NicD}
  - NicC: reads all except T, affects self only
  - R:  reads all except T
        affects {NicA, NicB, NicD, R, RM, NTFN3}
  - RM: reads all except T
        affects {SC, EP, RM, R, NicA, NicB, NicD, NTFN2}
  - SC: reads all except T
        affects {EP, SC, NicC, RM, R, NicA, NicB, NicD, NTFN1}
  - EP: reads all except T
        affects {EP, SC, NicC, RM, R, NicA, NicB, NicD}
  - NTFN1: reads all except T, affects {NTFN1, SC, NicC}
  - NTFN2: ''                , affects {NTFN2, RM, R, NicA, NicB, NicD}
  - NTFN3: ''                , affects {NTFN3, R, NicB, NicD}
  - T: reads T, affects all except EP
\<close>

subsection \<open>Definitions\<close>

datatype SACLabels =
    NicA | NicB | NicC | NicD
  | R | RM |  SC | EP
  | T | NTFN1 | NTFN2 | NTFN3

definition complete_AgentAuthGraph where
  "complete_AgentAuthGraph g \<equiv>
     g \<union> {(y,a,y) | a y. True}
       \<union> {(x,a,y) | x a y. (x,Control,y) \<in> g }
       \<union> {(x,a,y)|x a y. \<exists> z. (x,Control,z) \<in> g \<and> (z, Control,y) \<in> g} "
declare complete_AgentAuthGraph_def [simp]

abbreviation partition_label where
  "partition_label l \<equiv> OrdinaryLabel l"

definition SACGraph where
  "SACGraph \<equiv>
  { (partition_label R, Read,  partition_label NicB), (partition_label R, Write, partition_label NicB),
    (partition_label R, Read,  partition_label NicD), (partition_label R, Write, partition_label NicD),
    (partition_label SC, Read,  partition_label NicC), (partition_label SC, Write, partition_label NicC),
    (partition_label SC, SyncSend, partition_label EP),
    (partition_label RM, Receive, partition_label EP),
    (partition_label RM, Control, partition_label R),
    (partition_label RM, Control, partition_label NicA),
    (partition_label RM, Control, partition_label NicB),
    (partition_label RM, Control, partition_label NicD),
    (partition_label T, Notify, partition_label NTFN1),
    (partition_label T, Notify, partition_label NTFN2),
    (partition_label T, Notify, partition_label NTFN3),
    (partition_label SC, Receive, partition_label NTFN1),
    (partition_label RM, Receive, partition_label NTFN2),
    (partition_label R, Receive, partition_label NTFN3)
  }"
declare SACGraph_def [simp]

definition SACAuthGraph  where
  "SACAuthGraph = complete_AgentAuthGraph SACGraph"
declare SACAuthGraph_def [simp]

definition SACAllLabels where
  "SACAllLabels \<equiv> {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC}"

definition RMControls where
  "RMControls = {partition_label RM, partition_label R, partition_label NicA, partition_label NicB, partition_label NicD}"
declare RMControls_def [simp]

lemma reads_all_rm_controlled_subjects : "\<lbrakk>partition_label RM \<in> subjectReads SACAuthGraph (partition_label x); l \<in> RMControls\<rbrakk> \<Longrightarrow> l \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (simp only:RMControls_def)
  apply (erule insertE, rule_tac t="partition_label RM" in reads_read_thread_read_pages, simp, simp)+
  apply simp
done

lemma reads_ntfn3_via_r : "partition_label R \<in> subjectReads SACAuthGraph (partition_label x) \<Longrightarrow> partition_label NTFN3 \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac ep="partition_label NTFN3" and t="partition_label R" and auth="Receive" and auth'="Notify" and a="partition_label T" in reads_read_queued_thread_read_ep)
  apply simp_all
done

lemma reads_ntfn2_via_rm : "partition_label RM \<in> subjectReads SACAuthGraph (partition_label x) \<Longrightarrow> partition_label NTFN2 \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac ep="partition_label NTFN2" and t="partition_label RM" and auth="Receive" and auth'="Notify" and a="partition_label T" in reads_read_queued_thread_read_ep)
  apply simp_all
done

lemma reads_ntfn1_via_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label x) \<Longrightarrow> partition_label NTFN1 \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac ep="partition_label NTFN1" and t="partition_label SC" and auth="Receive" and auth'="Notify" and a="partition_label T" in reads_read_queued_thread_read_ep)
  apply simp_all
done

subsection \<open>NicA, NicB, NicD reads/affects\<close>

lemma reads_Control_rev':
  "(x,Control,y) \<in> aag \<Longrightarrow>
    x \<in> subjectReads (complete_AgentAuthGraph aag) y"
  apply(rule reads_read_page_read_thread)
   apply(rule reads_lrefl)
  apply simp
  done

lemma reads_Control_rev:
  "(x,Control,y) \<in> SACGraph \<Longrightarrow>
   x \<in> subjectReads SACAuthGraph y"
  apply(subst SACAuthGraph_def)
  apply(erule reads_Control_rev')
  done

lemma abdrm_reads_ep : "x \<in> {NicA, NicB, NicD, RM} \<Longrightarrow> partition_label EP \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac t = "partition_label RM" and a = "partition_label SC" and auth' = "SyncSend" and auth = "Receive" in reads_read_queued_thread_read_ep)
      apply (simp+)[4]
  apply safe
     apply(fastforce intro: reads_Control_rev simp del: complete_AgentAuthGraph_def)
    apply(fastforce intro: reads_Control_rev simp del: complete_AgentAuthGraph_def)
   apply(fastforce intro: reads_Control_rev simp del: complete_AgentAuthGraph_def)
  done

lemma abdrm_reads_sc : "x \<in> {NicA, NicB, NicD, RM} \<Longrightarrow> partition_label SC \<in> subjectReads SACAuthGraph (partition_label x)"
    apply (rule_tac auth = "Receive" and b = "partition_label SC" and a = "partition_label RM" and ep = "partition_label EP" in read_sync_ep_read_senders)
      apply (simp, simp, simp del: SACAuthGraph_def add: abdrm_reads_ep, simp)
done

lemma abd_reads_rm : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> partition_label RM \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule reads_Control_rev)
  apply auto
done

lemma abd_reads_c : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> partition_label NicC \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac t = "partition_label SC" in reads_read_thread_read_pages)
  apply (rule abdrm_reads_sc, simp, blast, simp)
done

lemma abd_reads_r : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> partition_label R \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac p="partition_label R" and t="partition_label RM" in reads_read_thread_read_pages)
  apply (rule abd_reads_rm, simp, simp)
done

lemma abd_reads_ntfn3 : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> partition_label NTFN3 \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac ep="partition_label NTFN3" and t="partition_label R" and auth="Receive" and auth'="Notify" and a="partition_label T" in reads_read_queued_thread_read_ep)
  apply (simp_all add: abd_reads_r del:SACAuthGraph_def, simp_all)
done

lemma abd_reads_all_bw : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3} \<subseteq> subjectReads SACAuthGraph (partition_label x)"
  apply (rule subsetI)
  (* refl cases *)
  apply (case_tac "partition_label x = xa")
  apply simp
  (* non refl cases *)
  apply (case_tac "xa \<in> RMControls")
    apply (rule reads_all_rm_controlled_subjects, rule abd_reads_rm, simp, simp)
  apply (erule_tac a = xa in insertE, simp)
  apply (erule_tac a = xa in insertE, simp only:, rule abd_reads_rm, simp)
  apply (erule_tac a = xa in insertE, simp)
  apply (erule_tac a = xa in insertE, simp)
  apply (erule_tac a = xa in insertE, simp)
  apply (erule_tac a = xa in insertE, simp only:, rule abdrm_reads_ep, simp, blast)
  apply (erule_tac a = xa in insertE, simp only:, rule abdrm_reads_sc, simp, blast)
  apply (erule_tac a = xa in insertE, simp only:, rule abd_reads_c, simp)
  apply (erule_tac a = xa in insertE, simp only:, rule reads_ntfn1_via_sc, rule abdrm_reads_sc, simp, blast)
  apply (erule_tac a = xa in insertE, simp only:, rule reads_ntfn2_via_rm, rule abd_reads_rm, simp)
  apply (erule_tac a = xa in insertE, simp only:, rule reads_ntfn3_via_r, rule abd_reads_r, simp)
  apply simp
done

lemma abd_reads : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> subjectReads SACAuthGraph (partition_label x) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3}"
   apply (rule subset_antisym)
   defer
   apply (rule abd_reads_all_bw)
   apply (simp)
   apply (rule subsetI)
     apply (erule subjectReads.induct)
     (* warning: slow *)
     by (simp, blast?)+

definition abd_affects_set where
 "abd_affects_set \<equiv> {NicB, RM, R, NicA, NicD,
                     EP, NTFN2}" (* these two added for NTFN binding *)
declare abd_affects_set_def[simp]

lemma abd_affects_bw : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> partition_label ` abd_affects_set \<subseteq> subjectAffects SACAuthGraph (partition_label x)"
  apply (simp only:abd_affects_set_def)
  apply (rule subsetI)
  (* refl cases *)
  apply (case_tac "partition_label x = xa")
    apply (simp add: affects_lrefl)
  (* non-refl cases *)
  apply (simp only: image_insert)
  apply (erule_tac a = xa in insertE)
    apply (rule_tac auth = SyncSend and ep = "partition_label x" and l' = "partition_label RM" in affects_send)
    apply (simp, simp, simp, simp)
  apply (erule_tac a = xa in insertE)
    apply (simp only:)
    apply (rule_tac ep = "partition_label x" and l' = "partition_label RM" in affects_recv)
      apply (simp)
      apply (auto)[1]
  apply (erule_tac a = xa in insertE)
    apply (simp only:)
    apply (rule_tac auth = SyncSend and ep = "partition_label x" and l' = "partition_label RM" in affects_send)
    apply (simp, simp, simp, simp)
  apply (erule_tac a = xa in insertE)
    apply (simp only:)
    apply (clarify)
    apply (erule notE)
    apply (rule_tac auth = SyncSend and ep = "partition_label x" and l' = "partition_label RM" in affects_send)
    apply (simp, simp, simp, simp)
  apply (erule_tac a = xa in insertE)
    apply (rule_tac auth = SyncSend and ep = "partition_label x" and l' = "partition_label RM" in affects_send)
    apply (simp, simp, simp, simp)
  apply (erule_tac a = xa in insertE)
    apply (rule_tac ep = "xa" and l = "partition_label x" in affects_ep_bound_trans)
    apply (rule_tac x = "partition_label RM" in exI)
    apply (rule_tac x = "partition_label x" in exI)
    apply (intro conjI)
    apply (simp,simp,simp)
  apply (erule_tac a = xa in insertE)
    apply (rule_tac ep = "xa" and l = "partition_label x" in affects_ep_bound_trans)
    apply (rule_tac x = "partition_label RM" in exI)
    apply (rule_tac x = "partition_label x" in exI)
    apply (intro conjI)
    apply (simp,simp,simp,simp)
  done

lemma abd_affects : "x \<in> {NicA, NicB, NicD} \<Longrightarrow> subjectAffects SACAuthGraph (partition_label x) = partition_label ` abd_affects_set"
   apply (rule subset_antisym)
   defer
   apply (rule abd_affects_bw)
   apply (simp)
   apply (rule subsetI)
     apply (erule subjectAffects.induct)
     by auto

subsection \<open>NicC reads/affects\<close>

lemma c_reads_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label NicC)"
  apply (rule_tac b = "partition_label NicC" in reads_read_page_read_thread)
  apply (rule reads_lrefl)
  apply (simp)
done

lemma c_reads_ep : "partition_label EP \<in> subjectReads SACAuthGraph (partition_label NicC)"
  apply (rule_tac a = "partition_label EP" and ep = "partition_label EP" and t = "partition_label SC" and auth = "SyncSend" and auth' = "Reset" in reads_read_queued_thread_read_ep)
  apply (simp,simp,simp,simp)
  apply (rule c_reads_sc)
done

lemma c_reads_rm : "partition_label RM \<in> subjectReads SACAuthGraph (partition_label NicC)"
  apply (rule_tac auth = SyncSend and a = "partition_label SC" and ep = "partition_label EP" in read_sync_ep_read_receivers)
   apply (simp, simp)
   apply (rule c_reads_ep)
   apply (simp)
done

lemma c_reads_any_controlled_by_rm : "x \<in> {partition_label R, partition_label NicA, partition_label NicB, partition_label NicD} \<Longrightarrow> x \<in> subjectReads SACAuthGraph (partition_label NicC)"
  apply (rule_tac t = "partition_label RM" in reads_read_thread_read_pages)
    apply (rule c_reads_rm)
    apply auto
done

lemma c_reads : "subjectReads SACAuthGraph (partition_label NicC) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3}"
  apply (rule subset_antisym)
    defer
    (* backward *)
    apply (rule subsetI)
      apply (case_tac "x \<in> {partition_label R, partition_label NicA, partition_label NicB, partition_label NicD}")
        apply (rule c_reads_any_controlled_by_rm, assumption)
        apply (erule insertE, simp)
        apply (erule insertE, simp only:, rule c_reads_rm)
        apply (erule insertE, simp, erule insertE, simp, erule insertE, simp)
        apply (erule insertE, simp only:, rule c_reads_ep)
        apply (erule insertE, simp only:, rule c_reads_sc)
        apply (erule insertE, simp only:, rule reads_lrefl)
        apply (erule insertE, simp only:, rule reads_ntfn1_via_sc, rule c_reads_sc)
        apply (erule insertE, simp only:, rule reads_ntfn2_via_rm, rule c_reads_rm)
        apply (erule insertE, simp only:, rule reads_ntfn3_via_r, rule c_reads_any_controlled_by_rm, simp)
        apply simp
    (* forward *)
    apply (rule subsetI)
    apply (erule subjectReads.induct)
    by (simp, blast?)+

lemma c_affects_self_only : "x \<in> {partition_label NicC} \<Longrightarrow> x \<in> subjectAffects SACAuthGraph (partition_label NicC)"
  apply (erule insertE)
    apply (simp only:, rule affects_lrefl)
    apply simp
done

lemma c_affects : "subjectAffects SACAuthGraph (partition_label NicC) = {partition_label NicC}"
  apply (rule subset_antisym)
  defer
    (* backward *)
    apply (rule subsetI)
    apply (rule c_affects_self_only, assumption)
    (* forward *)
    apply (rule subsetI)
    apply (erule subjectAffects.induct)
    by (simp, blast?)+

subsection \<open>R reads/affects\<close>

lemma r_reads_bd : "x \<in> {partition_label NicB, partition_label NicD} \<Longrightarrow> x \<in> subjectReads SACAuthGraph (partition_label R)"
  apply (rule reads_read)
  apply auto
done

lemma r_reads_ep : "partition_label EP \<in> subjectReads SACAuthGraph (partition_label R)"
    apply (rule_tac a="partition_label SC" and auth'="SyncSend" and ep="partition_label EP" and t="partition_label RM" and auth="Receive" in reads_read_queued_thread_read_ep)
    apply (simp, simp, simp, simp, rule reads_Control_rev, simp)
done

lemma r_reads_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label R)"
    apply (rule_tac a="partition_label RM" and auth="Receive" and ep="partition_label EP" and b="partition_label SC" in read_sync_ep_read_senders)
    apply (simp, simp, rule r_reads_ep, simp)
done

lemma r_reads_a : "partition_label NicA \<in> subjectReads SACAuthGraph (partition_label R)"
  apply (rule_tac a="partition_label NicA" and auth'="Reset" and ep="partition_label NicA" and t="partition_label RM" and auth="Receive" in reads_read_queued_thread_read_ep)
  apply (simp_all add:reads_Control_rev[simplified])
done

lemma r_reads_c : "partition_label NicC \<in> subjectReads SACAuthGraph (partition_label R)"
  apply (rule_tac t="partition_label SC" in reads_read_thread_read_pages)
  apply (rule r_reads_sc, simp)
done

lemma r_reads : "subjectReads SACAuthGraph (partition_label R) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3}"
  apply (rule subset_antisym)
    defer
    (* backward *)
    apply (rule subsetI)
    apply (erule insertE, rule r_reads_bd, simp)
    apply (erule insertE, rule reads_Control_rev, simp)
    apply (erule insertE, simp only:, rule reads_lrefl)
    apply (erule insertE, simp only:, rule r_reads_a)
    apply (erule insertE, rule r_reads_bd, simp)
    apply (erule insertE, simp only:, rule r_reads_ep)
    apply (erule insertE, simp only:, rule r_reads_sc)
    apply (erule insertE, simp only:, rule r_reads_c)
    apply (erule insertE, simp only:, rule reads_ntfn1_via_sc, rule r_reads_sc)
    apply (erule insertE, simp only:, rule reads_ntfn2_via_rm, rule reads_Control_rev, simp)
    apply (erule insertE, simp only:, rule reads_ntfn3_via_r, rule reads_lrefl)
    apply simp
    (* forward *)
    apply (rule subsetI)
    apply (erule subjectReads.induct)
    by (simp, blast?)+

lemma r_affects_bd : "x \<in> {partition_label NicB, partition_label NicD} \<Longrightarrow> x \<in> subjectAffects SACAuthGraph (partition_label R)"
  apply (rule_tac auth="Write" in affects_write)
  apply auto
done

lemma r_affects_rm : "partition_label RM \<in> subjectAffects SACAuthGraph (partition_label R)"
  apply (rule_tac l="partition_label R" and ep="partition_label R" in affects_recv)
  apply simp_all
done

lemma r_affects_a : "partition_label NicA \<in> subjectAffects SACAuthGraph (partition_label R)"
  apply (rule_tac l="partition_label R" and ep="partition_label R" and l'="partition_label RM" and auth="Receive" in affects_reset)
  apply auto
done

lemma r_affects_ntfn3 : "partition_label NTFN3 \<in> subjectAffects SACAuthGraph (partition_label R)"
  apply (rule_tac l="partition_label R" and auth="Receive" in affects_ep)
  apply simp_all
done

lemma r_affects_ntfn2 : "partition_label NTFN2 \<in> subjectAffects SACAuthGraph (partition_label R)"
  apply (rule_tac l="partition_label R" in affects_ep_bound_trans)
  by auto

lemma r_affects_ep : "partition_label EP \<in> subjectAffects SACAuthGraph (partition_label R)"
  apply (rule_tac l="partition_label R" in affects_ep_bound_trans)
  by auto

lemma r_affects : "subjectAffects SACAuthGraph (partition_label R) =
                   {partition_label NicB, partition_label NicD, partition_label R,
                    partition_label RM, partition_label NicA, partition_label NTFN3,
                    partition_label EP, partition_label NTFN2 \<comment> \<open>these 2 added for NTFN binding\<close> }"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule insertE, rule r_affects_bd, simp)
  apply (erule insertE, rule r_affects_bd, simp)
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule r_affects_rm)
  apply (erule insertE, simp only:, rule r_affects_a)
  apply (erule insertE, simp only:, rule r_affects_ntfn3)
  apply (erule insertE, simp only:, rule r_affects_ep)
  apply (erule insertE, simp only:, rule r_affects_ntfn2)
  apply simp
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectAffects.induct)
  by (simp, blast?)+

subsection \<open>RM reads/affects\<close>

lemma rm_reads_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label RM)"
  apply (rule_tac a="partition_label RM" and auth="Receive" and ep="partition_label EP" in read_sync_ep_read_senders)
  apply (simp_all add:reads_ep)
done

lemma rm_reads_c : "partition_label NicC \<in> subjectReads SACAuthGraph (partition_label RM)"
  apply (rule_tac t="partition_label SC" in reads_read_thread_read_pages)
  apply (rule rm_reads_sc, simp)
done

lemma rm_reads : "subjectReads SACAuthGraph (partition_label RM) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule insertE, simp only:, rule reads_read, simp)
  apply (erule insertE, simp only:, rule reads_lrefl)
  apply (erule insertE, simp only:, rule reads_read, simp)
  apply (erule insertE, simp only:, rule reads_read, simp)
  apply (erule insertE, simp only:, rule reads_read, simp)
  apply (erule insertE, simp only:, rule reads_ep, simp, simp)
  apply (erule insertE, simp only:, rule rm_reads_sc)
  apply (erule insertE, simp only:, rule rm_reads_c)
  apply (erule insertE, simp only:, rule reads_ntfn1_via_sc, rule rm_reads_sc)
  apply (erule insertE, simp only:, rule reads_ntfn2_via_rm, rule reads_lrefl)
  apply (erule insertE, simp only:, rule reads_ntfn3_via_r, rule reads_read, simp)
  apply simp
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectReads.induct)
  by (simp, blast?)+

lemma rm_affects_via_control : "x \<in> {partition_label R, partition_label NicA, partition_label NicB, partition_label NicD} \<Longrightarrow> x \<in> subjectAffects SACAuthGraph (partition_label RM)"
  apply (rule_tac l="partition_label RM" and auth="Control" in affects_write)
  apply (simp, simp)
done

lemma rm_affects_ep : "partition_label EP \<in> subjectAffects SACAuthGraph (partition_label RM)"
  apply (rule_tac auth="Receive" in affects_ep)
  apply simp_all
done

lemma rm_affects_sc : "partition_label SC \<in> subjectAffects SACAuthGraph (partition_label RM)"
  apply (rule_tac l="partition_label RM" and ep="partition_label EP" in affects_recv)
  apply simp_all
done

lemma rm_affects_ntfn2 : "partition_label NTFN2 \<in> subjectAffects SACAuthGraph (partition_label RM)"
  apply (rule_tac l="partition_label RM" and auth="Receive" in affects_ep)
  apply simp_all
done

lemma rm_affects_ntfn3 : "partition_label NTFN3 \<in> subjectAffects SACAuthGraph (partition_label RM)"
  apply (rule_tac l="partition_label RM" in affects_ep_bound_trans)
  apply clarsimp
  by auto

lemma rm_affects : "subjectAffects SACAuthGraph (partition_label RM) =
                    {partition_label NicA, partition_label NicB, partition_label NicD,
                     partition_label R, partition_label SC, partition_label EP,
                     partition_label RM, partition_label NTFN2,
                     partition_label NTFN3 \<comment> \<open>added for NTFN binding\<close>}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule insertE, simp only:, rule rm_affects_via_control, simp)
  apply (erule insertE, simp only:, rule rm_affects_via_control, simp)
  apply (erule insertE, simp only:, rule rm_affects_via_control, simp)
  apply (erule insertE, simp only:, rule rm_affects_via_control, simp)
  apply (erule insertE, simp only:, rule rm_affects_sc)
  apply (erule insertE, simp only:, rule rm_affects_ep)
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule rm_affects_ntfn2)
  apply (erule insertE, simp only:, rule rm_affects_ntfn3)
  apply simp
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectAffects.induct)
  by (simp, blast?)+

subsection \<open>SC\<close>

lemma sc_reads_rm : "partition_label RM \<in> subjectReads SACAuthGraph (partition_label SC)"
  apply (rule_tac a="partition_label SC" and ep="partition_label EP" and auth="SyncSend" and b="partition_label RM" in read_sync_ep_read_receivers)
  apply (simp_all add:reads_ep)
done

lemma sc_reads : "subjectReads SACAuthGraph (partition_label SC) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule insertE, rule reads_all_rm_controlled_subjects, rule sc_reads_rm, simp)
apply (erule insertE, rule reads_all_rm_controlled_subjects, rule sc_reads_rm, simp)
apply (erule insertE, rule reads_all_rm_controlled_subjects, rule sc_reads_rm, simp)
apply (erule insertE, rule reads_all_rm_controlled_subjects, rule sc_reads_rm, simp)
apply (erule insertE, rule reads_all_rm_controlled_subjects, rule sc_reads_rm, simp)
  apply (erule insertE, simp only:, rule_tac auth="SyncSend" in reads_ep, simp, simp)
  apply (erule insertE, simp only:, rule reads_lrefl)
  apply (erule insertE, simp only:, rule reads_read, simp)
  apply (erule insertE, simp only:, rule reads_ntfn1_via_sc, rule reads_lrefl)
  apply (erule insertE, simp only:, rule reads_ntfn2_via_rm, rule sc_reads_rm)
  apply (erule insertE, simp only:, rule reads_ntfn3_via_r, rule reads_all_rm_controlled_subjects, rule sc_reads_rm, simp)
  apply simp
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectReads.induct)
  apply (simp, blast?)+
done

lemma sc_affects_all_rm_controls : "l \<in> RMControls \<Longrightarrow> l \<in> subjectAffects SACAuthGraph (partition_label SC)"
  apply (simp only:RMControls_def)
  apply (erule insertE, rule_tac l="partition_label SC" and auth="SyncSend" and ep="partition_label EP" and l'="partition_label RM" in affects_send, simp, simp, simp, simp)+
  apply simp
done

lemma sc_affects : "subjectAffects SACAuthGraph (partition_label SC) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule insertE, rule sc_affects_all_rm_controls, simp)
  apply (erule insertE, rule sc_affects_all_rm_controls, simp)
  apply (erule insertE, rule sc_affects_all_rm_controls, simp)
  apply (erule insertE, rule sc_affects_all_rm_controls, simp)
  apply (erule insertE, rule sc_affects_all_rm_controls, simp)
  apply (erule insertE, simp only:, rule_tac l="partition_label SC" and auth="SyncSend" in affects_ep, simp, simp)
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule_tac l="partition_label SC" and auth="Write" in affects_write, simp, simp)
  apply (erule insertE, simp only:, rule_tac l="partition_label SC" and auth="Receive" in affects_ep, simp, simp)
  apply simp
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectAffects.induct)
  apply (simp, blast?)+
done

subsection \<open>EP\<close>

lemma ep_reads_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label EP)"
  apply (rule_tac a="partition_label EP" and ep="partition_label EP" and auth="Receive" in read_sync_ep_read_senders)
  apply (simp, simp, rule reads_lrefl, simp_all)
done

lemma ep_reads_rm : "partition_label RM \<in> subjectReads SACAuthGraph (partition_label EP)"
  apply (rule_tac a="partition_label SC" and ep="partition_label EP" and b="partition_label RM" and auth="SyncSend" in read_sync_ep_read_receivers)
  apply (simp, simp, rule reads_lrefl, simp)
done

lemma ep_reads_c : "partition_label NicC \<in> subjectReads SACAuthGraph (partition_label EP)"
  apply (rule_tac t="partition_label SC" and p="partition_label NicC" in reads_read_thread_read_pages)
  apply (rule ep_reads_sc, simp)
done

lemma ep_reads : "subjectReads SACAuthGraph (partition_label EP) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule insertE, rule reads_all_rm_controlled_subjects, rule ep_reads_rm, simp)
  apply (erule insertE, simp only:, rule ep_reads_rm)
  apply (erule insertE, rule reads_all_rm_controlled_subjects, rule ep_reads_rm, simp)
  apply (erule insertE, rule reads_all_rm_controlled_subjects, rule ep_reads_rm, simp)
  apply (erule insertE, rule reads_all_rm_controlled_subjects, rule ep_reads_rm, simp)
  apply (erule insertE, simp only:, rule reads_lrefl)
  apply (erule insertE, simp only:, rule ep_reads_sc)
  apply (erule insertE, simp only:, rule ep_reads_c)
  apply (erule insertE, simp only:, rule reads_ntfn1_via_sc, rule ep_reads_sc)
  apply (erule insertE, simp only:, rule reads_ntfn2_via_rm, rule ep_reads_rm)
  apply (erule insertE, simp only:, rule reads_ntfn3_via_r, rule reads_all_rm_controlled_subjects, rule ep_reads_rm, simp)
  apply simp
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectReads.induct)
  apply (simp, blast?)+
done

lemma ep_affects_sc : "partition_label SC \<in> subjectAffects SACAuthGraph (partition_label EP)"
  apply (rule_tac l="partition_label EP" and ep="partition_label EP" in affects_recv)
  apply simp_all
done

lemma ep_affects_c : "partition_label NicC \<in> subjectAffects SACAuthGraph (partition_label EP)"
  apply (rule_tac l="partition_label EP" and l'="partition_label SC" and auth="SyncSend" and ep="partition_label EP" in affects_reset)
  apply simp_all
done

lemma ep_affects_ntfn2 : "partition_label NTFN2 \<in> subjectAffects SACAuthGraph (partition_label EP)"
  apply (rule_tac ep="partition_label NTFN2" in affects_ep_bound_trans)
  by auto

lemma ep_affects_rm_controls : "x \<in> RMControls \<Longrightarrow> x \<in> subjectAffects SACAuthGraph (partition_label EP)"
  apply (rule_tac l="partition_label EP" and ep="partition_label EP" and auth="SyncSend" and l'="partition_label RM" in affects_send)
  apply (simp_all)
done

lemma ep_affects: "subjectAffects SACAuthGraph (partition_label EP) = {partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN2} \<union> RMControls"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule UnE)
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule ep_affects_sc)
  apply (erule insertE, simp only:, rule ep_affects_c)
  apply (erule insertE, simp only:, rule ep_affects_ntfn2)
  apply simp
  apply (rule ep_affects_rm_controls, simp)
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectAffects.induct)
  by (simp, blast?)+

subsection \<open>NTFN1,2,3\<close>

subsubsection \<open>NTFN1 reads SC, EP, RM, R\<close>

lemma ntfn1_reads_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label NTFN1)"
  apply (rule_tac ep="partition_label NTFN1" and auth="SyncSend" and a="partition_label NTFN1" in read_sync_ep_read_receivers)
  apply (simp, simp, rule reads_lrefl, simp)
done

lemma ntfn1_reads_ep : "partition_label EP \<in> subjectReads SACAuthGraph (partition_label NTFN1)"
  apply (rule_tac ep="partition_label EP" and auth="SyncSend" and t="partition_label SC" and auth'="Reset" and a="partition_label EP" in reads_read_queued_thread_read_ep)
  apply (simp, simp, simp, simp, rule ntfn1_reads_sc)
done

lemma ntfn1_reads_rm : "partition_label RM \<in> subjectReads SACAuthGraph (partition_label NTFN1)"
  apply (rule_tac b="partition_label RM" and ep="partition_label EP" and auth="SyncSend" and a="partition_label SC" in read_sync_ep_read_receivers)
  apply (simp, simp, rule ntfn1_reads_ep, simp)
done

subsubsection \<open>NTFN2 reads SC, EP, RM, R\<close>

lemma ntfn2_reads_rm : "partition_label RM \<in> subjectReads SACAuthGraph (partition_label NTFN2)"
  apply (rule_tac ep="partition_label NTFN2" and auth="SyncSend" and a="partition_label NTFN2" in read_sync_ep_read_receivers)
  apply (simp, simp, rule reads_lrefl, simp)
done

lemma ntfn2_reads_ep : "partition_label EP \<in> subjectReads SACAuthGraph (partition_label NTFN2)"
  apply (rule_tac ep="partition_label EP" and auth="Receive" and t="partition_label RM" and auth'="Reset" and a="partition_label EP" in reads_read_queued_thread_read_ep)
  apply (simp, simp, simp, simp, rule ntfn2_reads_rm)
done

lemma ntfn2_reads_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label NTFN2)"
  apply (rule_tac b="partition_label SC" and ep="partition_label EP" and auth="Reset" and a="partition_label EP" in read_sync_ep_read_senders)
  apply (simp, simp, rule ntfn2_reads_ep, simp)
done

subsubsection \<open>NTFN3 reads SC, EP, RM, R\<close>

lemma ntfn3_reads_r : "partition_label R \<in> subjectReads SACAuthGraph (partition_label NTFN3)"
  apply (rule_tac ep="partition_label NTFN3" and auth="SyncSend" and a="partition_label NTFN3" in read_sync_ep_read_receivers)
  apply (simp, simp, rule reads_lrefl, simp)
done

lemma ntfn3_reads_rm : "partition_label RM \<in> subjectReads SACAuthGraph (partition_label NTFN3)"
  apply (rule_tac b="partition_label R" in reads_read_page_read_thread)
  apply (rule ntfn3_reads_r, simp)
done

lemma ntfn3_reads_ep : "partition_label EP \<in> subjectReads SACAuthGraph (partition_label NTFN3)"
  apply (rule_tac t="partition_label RM" and auth="Receive" and auth'="SyncSend" and a="partition_label SC" in reads_read_queued_thread_read_ep)
  apply (simp, simp, simp, simp, rule ntfn3_reads_rm)
done

lemma ntfn3_reads_sc : "partition_label SC \<in> subjectReads SACAuthGraph (partition_label NTFN3)"
  apply (rule_tac ep="partition_label EP" and auth="Receive" and a="partition_label RM" in read_sync_ep_read_senders)
  apply (simp, simp, rule ntfn3_reads_ep, simp)
done

subsubsection \<open>NTFN1,2,3 reads C\<close>

lemma ntfn123_reads_c : "x \<in> {NTFN1, NTFN2, NTFN3} \<Longrightarrow> partition_label NicC \<in> subjectReads SACAuthGraph (partition_label x)"
  apply (rule_tac t="partition_label SC" in reads_read_thread_read_pages)
  apply (erule insertE, simp only:, rule ntfn1_reads_sc, erule insertE, simp only:, rule ntfn2_reads_sc, erule insertE, simp only:, rule ntfn3_reads_sc, simp)
  apply simp
done

subsubsection \<open>NTFN1,2,3 reads each other\<close>

lemma ntfn13_reads_ntfn2 : "l \<in> {NTFN1, NTFN3} \<Longrightarrow> partition_label NTFN2 \<in> subjectReads SACAuthGraph (partition_label l)"
  apply (rule_tac t="partition_label RM" and auth="Receive" and auth'="Reset" and a="partition_label NTFN2" in reads_read_queued_thread_read_ep)
  apply (simp, simp, simp, simp)
  apply (erule insertE, simp only:, rule ntfn1_reads_rm, erule insertE, simp only:, rule ntfn3_reads_rm, simp)
done

lemma ntfn12_reads_ntfn3 : "l \<in> {NTFN1, NTFN2} \<Longrightarrow> partition_label NTFN3 \<in> subjectReads SACAuthGraph (partition_label l)"
  apply (rule_tac t="partition_label R" and auth="Receive" and auth'="Reset" and a="partition_label NTFN3" in reads_read_queued_thread_read_ep)
  apply (simp, simp, simp, simp)
  apply (erule insertE, simp only:, rule reads_all_rm_controlled_subjects, rule ntfn1_reads_rm, simp, erule insertE, simp only:, rule reads_all_rm_controlled_subjects, rule ntfn2_reads_rm, simp_all)
done

lemma ntfn23_reads_ntfn1 : "l \<in> {NTFN2, NTFN3} \<Longrightarrow> partition_label NTFN1 \<in> subjectReads SACAuthGraph (partition_label l)"
  apply (rule_tac t="partition_label SC" and auth="Receive" and auth'="Reset" and a="partition_label NTFN1" in reads_read_queued_thread_read_ep)
  apply (simp, simp, simp, simp)
  apply (erule insertE, simp only:, rule ntfn2_reads_sc, erule insertE, simp only:, rule ntfn3_reads_sc, simp)
done

subsubsection \<open>NTFN1,2,3 reads\<close>
declare SACAuthGraph_def[simp del]

lemma ntfn123_reads_rm : "l \<in> {NTFN1, NTFN2, NTFN3} \<Longrightarrow> partition_label RM \<in> subjectReads SACAuthGraph (partition_label l)"
by (auto simp:ntfn1_reads_rm ntfn2_reads_rm ntfn3_reads_rm)

lemma ntfn123_reads_sc : "l \<in> {NTFN1, NTFN2, NTFN3} \<Longrightarrow> partition_label SC \<in> subjectReads SACAuthGraph (partition_label l)"
by (auto simp:ntfn1_reads_sc ntfn2_reads_sc ntfn3_reads_sc)

lemma ntfn123_reads_ep : "l \<in> {NTFN1, NTFN2, NTFN3} \<Longrightarrow> partition_label EP \<in> subjectReads SACAuthGraph (partition_label l)"
by (auto simp:ntfn1_reads_ep ntfn2_reads_ep ntfn3_reads_ep)

lemma ntfn123_reads_ntfn123 : "\<lbrakk>l \<in> {NTFN1, NTFN2, NTFN3}; x \<in> {NTFN1, NTFN2, NTFN3}\<rbrakk> \<Longrightarrow> partition_label l \<in> subjectReads SACAuthGraph (partition_label x)"
by (auto simp:ntfn12_reads_ntfn3 ntfn13_reads_ntfn2 ntfn23_reads_ntfn1)

lemma ntfn123_reads : "l \<in> {NTFN1, NTFN2, NTFN3} \<Longrightarrow> subjectReads SACAuthGraph (partition_label l) = {partition_label NicB, partition_label RM, partition_label R, partition_label NicA, partition_label NicD, partition_label EP, partition_label SC, partition_label NicC, partition_label NTFN1, partition_label NTFN2, partition_label NTFN3}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule_tac a=x in insertE, rule reads_all_rm_controlled_subjects, rule ntfn123_reads_rm, simp, simp)
  apply (erule_tac a=x in insertE, simp only:, rule ntfn123_reads_rm, simp)
  apply (erule_tac a=x in insertE, rule reads_all_rm_controlled_subjects, rule ntfn123_reads_rm, simp, simp)
  apply (erule_tac a=x in insertE, rule reads_all_rm_controlled_subjects, rule ntfn123_reads_rm, simp, simp)
  apply (erule_tac a=x in insertE, rule reads_all_rm_controlled_subjects, rule ntfn123_reads_rm, simp, simp)
  apply (erule_tac a=x in insertE, simp only:, rule ntfn123_reads_ep, simp)
  apply (erule_tac a=x in insertE, simp only:, rule ntfn123_reads_sc, simp)
  apply (erule_tac a=x in insertE, simp only:, rule ntfn123_reads_c, simp)
  apply (auto simp:ntfn123_reads_ntfn123)[1]
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectReads.induct)
  by (simp add:SACAuthGraph_def, blast?)+

subsubsection \<open>NTFN1,2,3 affects\<close>

lemma ntfn1_affects_sc : "partition_label SC \<in> subjectAffects SACAuthGraph (partition_label NTFN1)"
  apply (rule_tac l''="partition_label SC" and l'="partition_label SC" and ep="partition_label NTFN1" and auth="Notify" and l="partition_label NTFN1" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma ntfn1_affects_c : "partition_label NicC \<in> subjectAffects SACAuthGraph (partition_label NTFN1)"
  apply (rule_tac l'="partition_label SC" and ep="partition_label NTFN1" and l="partition_label NTFN1" and auth="Notify" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma ntfn1_affects : "subjectAffects SACAuthGraph (partition_label NTFN1) = {partition_label NTFN1, partition_label SC, partition_label NicC}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule ntfn1_affects_sc)
  apply (erule insertE, simp only:, rule ntfn1_affects_c)
  apply simp
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectAffects.induct)
  apply (simp add:SACAuthGraph_def, blast?)+
done

lemma ntfn2_affects_rm : "partition_label RM \<in> subjectAffects SACAuthGraph (partition_label NTFN2)"
  apply (rule_tac l'="partition_label RM" and ep="partition_label NTFN2" and auth="Notify" and l="partition_label NTFN2" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma ntfn2_affects_ep : "partition_label EP \<in> subjectAffects SACAuthGraph (partition_label NTFN2)"
  apply (rule affects_ep_bound_trans)
  by (auto simp: SACAuthGraph_def)

lemma ntfn2_affects_rm_controls : "x \<in> RMControls \<Longrightarrow> x \<in> subjectAffects SACAuthGraph (partition_label NTFN2)"
  apply (rule_tac l="partition_label NTFN2" and ep="partition_label NTFN2" and auth="SyncSend" and l'="partition_label RM" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma ntfn2_affects : "subjectAffects SACAuthGraph (partition_label NTFN2) = {partition_label NTFN2, partition_label RM, partition_label EP} \<union> RMControls"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI)
  apply (erule UnE)
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule ntfn2_affects_rm)
  apply (erule insertE, simp only:, rule ntfn2_affects_ep)
  apply simp
  apply (rule ntfn2_affects_rm_controls, simp)
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectAffects.induct)
  by (simp add:SACAuthGraph_def, blast?)+

lemma ntfn3_affects_r : "partition_label R \<in> subjectAffects SACAuthGraph (partition_label NTFN3)"
  apply (rule_tac l'="partition_label R" and ep="partition_label NTFN3" and auth="Notify" and l="partition_label NTFN3" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma ntfn3_affects_bd : "l \<in> {NicB, NicD} \<Longrightarrow> partition_label l \<in> subjectAffects SACAuthGraph (partition_label NTFN3)"
  apply (rule_tac l'="partition_label R" and ep="partition_label NTFN3" and l="partition_label NTFN3" and auth="Notify" in affects_send)
  apply (simp add:SACAuthGraph_def, blast?)+
done

lemma ntfn3_affects : "subjectAffects SACAuthGraph (partition_label NTFN3) = {partition_label NTFN3, partition_label R} \<union> {partition_label NicB, partition_label NicD}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI, erule UnE)
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule ntfn3_affects_r, simp)
  apply (auto simp:ntfn3_affects_bd)[1]
  (* forward *)
  apply (rule subsetI)
  apply (erule subjectAffects.induct)
  apply (simp add:SACAuthGraph_def, blast?)+
done

subsection \<open>T\<close>

lemma t_reads : "subjectReads SACAuthGraph (partition_label T) = {partition_label T}"
  apply (rule subset_antisym)
  defer
  apply (rule subsetI, erule insertE, simp only:, rule reads_lrefl, simp)
  apply (rule subsetI, erule subjectReads.induct)
  apply (simp add:SACAuthGraph_def, blast?)+
done

lemma t_affects_ntfn123 : "l \<in> {NTFN1, NTFN2, NTFN3} \<Longrightarrow>  partition_label l \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule_tac auth="Notify" in affects_ep)
  apply (simp_all add:SACAuthGraph_def, blast)
done

lemma t_affects_sc : "partition_label SC \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule_tac l''="partition_label SC" and l'="partition_label SC" and ep="partition_label NTFN1" and auth="Notify" and l="partition_label T" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma t_affects_rm : "partition_label RM \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule_tac l''="partition_label RM" and l'="partition_label RM" and ep="partition_label NTFN2" and auth="Notify" and l="partition_label T" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma t_affects_r : "partition_label R \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule_tac l''="partition_label R" and l'="partition_label R" and ep="partition_label NTFN3" and auth="Notify" and l="partition_label T" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma t_affects_ep : "partition_label EP \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule affects_ep_bound_trans)
  by (auto simp: SACAuthGraph_def)

lemma t_affects_c : "partition_label NicC \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule_tac l''="partition_label NicC" and l'="partition_label SC" and ep="partition_label NTFN1" and auth="Notify" and l="partition_label T" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma t_affects_a : "partition_label NicA \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule_tac l''="partition_label NicA" and l'="partition_label RM" and ep="partition_label NTFN2" and auth="Notify" and l="partition_label T" in affects_send)
  apply (simp_all add:SACAuthGraph_def)
done

lemma t_affects_bd : "l \<in> {NicB, NicD} \<Longrightarrow> partition_label l \<in> subjectAffects SACAuthGraph (partition_label T)"
  apply (rule_tac l'="partition_label R" and ep="partition_label NTFN3" and auth="Notify" and l="partition_label T" in affects_send)
  apply (simp_all add:SACAuthGraph_def, blast)
done

lemma t_affects : "subjectAffects SACAuthGraph (partition_label T) = {partition_label NTFN1, partition_label NTFN2, partition_label NTFN3} \<union> {partition_label T, partition_label SC, partition_label RM, partition_label R, partition_label NicA, partition_label NicB, partition_label NicD, partition_label NicC, partition_label EP}"
  apply (rule subset_antisym)
  defer
  (* backward *)
  apply (rule subsetI, erule UnE)
  apply (auto simp:t_affects_ntfn123)[1]
  apply (erule insertE, simp only:, rule affects_lrefl)
  apply (erule insertE, simp only:, rule t_affects_sc)
  apply (erule insertE, simp only:, rule t_affects_rm)
  apply (erule insertE, simp only:, rule t_affects_r)
  apply (erule insertE, simp only:, rule t_affects_a)
  apply (erule insertE, simp only:, rule t_affects_bd, simp)
  apply (erule insertE, simp only:, rule t_affects_bd, simp)
  apply (erule insertE, simp only:, rule t_affects_c)
  apply (erule insertE, simp only:, rule t_affects_ep)
  apply simp
  (* forward *)
  apply (rule subsetI, erule subjectAffects.induct)
  by (simp add:SACAuthGraph_def, blast?)+

subsection \<open>Policy\<close>

lemmas SAC_reads = sc_reads ep_reads c_reads rm_reads r_reads abd_reads ntfn123_reads t_reads

lemmas SAC_affects = sc_affects ep_affects c_affects rm_affects r_affects abd_affects ntfn1_affects ntfn2_affects ntfn3_affects t_affects

definition SACFlowDoms where
  "SACFlowDoms \<equiv> {Partition EP, Partition SC, Partition NicC, Partition RM, Partition R, Partition NicA, Partition NicB, Partition NicD, Partition NTFN1, Partition NTFN2, Partition NTFN3}"
declare SACFlowDoms_def [simp]

definition SACPolicyFlows :: "(SACLabels partition \<times> SACLabels partition) set" where
  "SACPolicyFlows \<equiv>
     {(PSched,d)| d. True}
   \<union> {(Partition l, Partition k)| l k. (k = T \<longrightarrow> l = T)}"

lemma SAC_partsSubjectAffects_exceptT : "x \<noteq> T \<Longrightarrow> partsSubjectAffects SACAuthGraph x = SACFlowDoms"
  apply (rule equalityI)
  defer
  apply (rule subsetI)
    apply (simp add:partsSubjectAffects_def image_def label_can_affect_partition_def)
    apply (case_tac x)
     apply ((erule disjE, clarify, simp add:SAC_affects SAC_reads, blast?)+, simp add:SAC_affects SAC_reads, blast?)+
  apply (rule subsetI)
    apply (simp add:partsSubjectAffects_def image_def label_can_affect_partition_def)
    apply (clarify)
    apply (case_tac x)
      apply (case_tac[!] xaa)
        apply (auto simp: SAC_affects SAC_reads)
done

lemma SAC_partsSubjectAffects_T : "(partsSubjectAffects SACAuthGraph T) = {Partition NTFN1, Partition NTFN2, Partition NTFN3} \<union> {Partition T, Partition SC, Partition RM, Partition R, Partition NicA, Partition NicB, Partition NicD, Partition NicC, Partition EP}"
    apply (rule equalityI)
    apply (rule subsetI)
    apply (simp add: partsSubjectAffects_def image_def label_can_affect_partition_def SAC_affects SAC_reads)
    apply (clarify)
    apply (case_tac xa, simp_all)[1]
    apply (rule subsetI)
    apply (simp add: partsSubjectAffects_def image_def label_can_affect_partition_def SAC_affects SAC_reads)
    apply (erule disjE, simp add: SAC_reads) (* Do not collapse this in with a blast? because attempting blast takes too long *)
    apply ((erule disjE)?, simp add: SAC_reads, blast)+
done

lemma SAC_policyFlows : "policyFlows SACAuthGraph = SACPolicyFlows"
  apply (rule subset_antisym)
  (* forward *)
  apply (rule subsetI)
  apply clarify
  apply (erule policyFlows.cases)
    (* subject case *)
    apply (clarsimp simp:SACPolicyFlows_def)
    apply (case_tac "d = Partition T")
      apply (case_tac l, auto simp:SAC_partsSubjectAffects_T SAC_partsSubjectAffects_exceptT)[1]
      apply (case_tac l, auto simp:SAC_partsSubjectAffects_T SAC_partsSubjectAffects_exceptT)[1]
    (* scheduler case *)
    apply (simp add:SACPolicyFlows_def)
  (* backward *)
  apply (rule subsetI)
  apply (clarsimp simp:SACPolicyFlows_def)
  apply (erule disjE)
    (* scheduler flows to all *)
    apply (simp add:PSched_flows_to_all)
    (* all subjects flow to all subjects *)
    apply (clarify, simp)
    apply (rule policy_affects)
    apply (case_tac l, case_tac[1-12] k, auto simp:SAC_partsSubjectAffects_T SAC_partsSubjectAffects_exceptT)
done

end


theory NoCardinalityAnalysis
imports CardinalityAnalysisSpec ArityAnalysisStack
begin

locale NoCardinalityAnalysis = ArityAnalysisLetSafe +
  assumes Aheap_thunk: "x \<in> thunks \<Gamma> \<Longrightarrow> (Aheap \<Gamma> e\<cdot>a) x = up\<cdot>0"
begin

definition a2c :: "Arity\<^sub>\<bottom> \<rightarrow> two" where "a2c = (\<Lambda> a. if a \<sqsubseteq> \<bottom> then \<bottom> else many)"
lemma a2c_simp: "a2c\<cdot>a = (if a \<sqsubseteq> \<bottom> then \<bottom> else many)"
  unfolding a2c_def by (rule beta_cfun[OF cont_if_else_above]) auto

lemma a2c_eqvt[eqvt]: "\<pi> \<bullet> a2c = a2c"
  unfolding a2c_def
  apply perm_simp
  apply (rule Abs_cfun_eqvt)
  apply (rule cont_if_else_above)
  apply auto
  done

definition ae2ce :: "AEnv \<Rightarrow> (var \<Rightarrow> two)" where "ae2ce ae x = a2c\<cdot>(ae x)"

lemma ae2ce_cont: "cont ae2ce"
  by (auto simp add: ae2ce_def)
lemmas cont_compose[OF ae2ce_cont, cont2cont, simp]

lemma ae2ce_eqvt[eqvt]: "\<pi> \<bullet> ae2ce ae x = ae2ce (\<pi> \<bullet> ae) (\<pi> \<bullet> x)"
  unfolding ae2ce_def by perm_simp rule

lemma ae2ce_to_env_restr: "ae2ce ae = (\<lambda>_ . many) f|` edom ae"
  by (auto simp add: ae2ce_def lookup_env_restr_eq edom_def a2c_simp)

lemma edom_ae2ce[simp]: "edom (ae2ce ae) = edom ae"
  unfolding edom_def
  by (auto simp add: ae2ce_def  a2c_simp)

definition cHeap :: "heap \<Rightarrow> exp \<Rightarrow> Arity \<rightarrow> (var \<Rightarrow> two)"
  where "cHeap \<Gamma> e = (\<Lambda> a. ae2ce (Aheap \<Gamma> e\<cdot>a))"
lemma cHeap_simp[simp]: "cHeap \<Gamma> e\<cdot>a = ae2ce (Aheap \<Gamma> e\<cdot>a)"
  unfolding cHeap_def by simp

sublocale CardinalityHeap cHeap.

sublocale CardinalityHeapSafe cHeap Aheap
  apply standard
  apply (erule Aheap_thunk)
  apply simp
  done

fun prognosis where
  "prognosis ae as a (\<Gamma>, e, S) = ((\<lambda>_. many) f|` (edom (ABinds \<Gamma>\<cdot>ae) \<union> edom (Aexp e\<cdot>a) \<union> edom (AEstack as S)))"

lemma record_all_noop[simp]:
  "record_call x\<cdot>((\<lambda>_. many) f|` S) = (\<lambda>_. many) f|` S"
  by (auto simp add: record_call_def lookup_env_restr_eq)

lemma const_on_restr_constI[intro]:
  "S' \<subseteq> S \<Longrightarrow> const_on ((\<lambda> _. x) f|` S) S' x"
  by fastforce

lemma ap_subset_edom_AEstack: "ap S \<subseteq> edom (AEstack as S)"
  by (induction as S rule:AEstack.induct) (auto simp del: fun_meet_simp)

sublocale CardinalityPrognosis prognosis.

sublocale CardinalityPrognosisShape prognosis
proof (standard, goal_cases)
  case 1
  thus ?case by (simp cong: Abinds_env_restr_cong)
next
  case 2
  thus ?case by (simp cong: Abinds_reorder)
next
  case 3
  thus ?case by (auto dest: subsetD[OF ap_subset_edom_AEstack])
next
  case 4
  thus ?case by (auto intro: env_restr_mono2 )
next
  case (5 ae x as a \<Gamma> e S)
  from \<open>ae x = \<bottom>\<close>
  have "ABinds (delete x \<Gamma>)\<cdot>ae = ABinds \<Gamma>\<cdot>ae" by (rule ABinds_delete_bot)
  thus ?case by simp
next
  case (6 ae as a \<Gamma> x S)
  from Aexp_Var[where n = a and x = x]
  have "(Aexp (Var x)\<cdot>a) x \<noteq> \<bottom>" by auto
  hence "x \<in> edom (Aexp (Var x)\<cdot>a)" by (simp add: edomIff)
  thus ?case by simp
qed

sublocale CardinalityPrognosisApp prognosis
proof (standard, goal_cases)
  case 1
  thus ?case
    using edom_mono[OF Aexp_App] by (auto intro!: env_restr_mono2)
qed

sublocale CardinalityPrognosisLam prognosis
proof (standard, goal_cases)
  case (1 ae as a \<Gamma> e y x S)
  have "edom (Aexp e[y::=x]\<cdot>(pred\<cdot>a)) \<subseteq> insert x (edom (env_delete y (Aexp e\<cdot>(pred\<cdot>a))))"
    by (auto dest: subsetD[OF edom_mono[OF Aexp_subst]] )
  also have "\<dots> \<subseteq> insert x (edom (Aexp (Lam [y]. e)\<cdot>a))"
    using edom_mono[OF Aexp_Lam] by auto
  finally show ?case by (auto intro!: env_restr_mono2)
qed

sublocale CardinalityPrognosisVar prognosis
proof (standard, goal_cases)
  case prems: 1
  thus ?case by (auto intro!: env_restr_mono2 simp add: Abinds_reorder1[OF prems(1)])
next
  case prems: 2
  thus ?case
    by (auto intro!: env_restr_mono2 simp add: Abinds_reorder1[OF prems(1)])
       (metis Aexp_Var edomIff not_up_less_UU)
next
  case (3 e x \<Gamma> ae as S)
  have "fup\<cdot>(Aexp e)\<cdot>(ae x) \<sqsubseteq> Aexp e\<cdot>0" by (cases "ae x") (auto intro: monofun_cfun_arg)
  from edom_mono[OF this]
  show ?case by (auto intro!: env_restr_mono2 dest: subsetD[OF edom_mono[OF ABinds_delete_below]])
qed

sublocale CardinalityPrognosisIfThenElse prognosis
proof (standard, goal_cases)
  case (1 ae a as \<Gamma> scrut e1 e2 S)
  have "edom (Aexp scrut\<cdot>0 \<squnion> Aexp e1\<cdot>a \<squnion> Aexp e2\<cdot>a) \<subseteq> edom (Aexp (scrut ? e1 : e2)\<cdot>a)"
    by (rule edom_mono[OF Aexp_IfThenElse])
  thus ?case
    by (auto intro!: env_restr_mono2)
next
  case (2 ae as a \<Gamma> b e1 e2 S)
  show ?case by (auto intro!: env_restr_mono2)
qed

sublocale CardinalityPrognosisLet prognosis  cHeap Aheap
proof (standard, goal_cases)
  case prems: (1 \<Delta> \<Gamma> S ae e a as)

  from subsetD[OF prems(3)] fresh_distinct[OF prems(1)] fresh_distinct_fv[OF prems(2)]
  have  "ae f|` domA \<Delta> = \<bottom>"
    by (auto dest: subsetD[OF ups_fv_subset])
  hence [simp]: "ABinds \<Delta>\<cdot>(ae \<squnion> Aheap \<Delta> e\<cdot>a) = ABinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)" by (simp cong: Abinds_env_restr_cong add: env_restr_join)

  from  fresh_distinct[OF prems(1)]
  have "Aheap \<Delta> e\<cdot>a f|` domA \<Gamma> = \<bottom>" by (auto dest!: subsetD[OF edom_Aheap])
  hence [simp]: "ABinds \<Gamma>\<cdot>(ae \<squnion> Aheap \<Delta> e\<cdot>a) = ABinds \<Gamma>\<cdot>ae" by (simp cong: Abinds_env_restr_cong add: env_restr_join)

  have "edom (ABinds (\<Delta> @ \<Gamma>)\<cdot>(Aheap \<Delta> e\<cdot>a \<squnion> ae)) \<union> edom (Aexp e\<cdot>a)  = edom (ABinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) \<union> edom (ABinds \<Gamma>\<cdot>ae) \<union>  edom (Aexp e\<cdot>a) "
    by (simp add: Abinds_append_disjoint[OF fresh_distinct[OF prems(1)]] Un_commute)
  also have "\<dots> = edom (ABinds \<Gamma>\<cdot>ae) \<union> edom (ABinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a) \<squnion> Aexp e\<cdot>a)"
    by force
  also have "\<dots> \<subseteq> edom (ABinds \<Gamma>\<cdot>ae) \<union> edom (Aheap \<Delta> e\<cdot>a \<squnion> Aexp (Let \<Delta> e)\<cdot>a)"
    using  edom_mono[OF Aexp_Let] by force
  also have "\<dots> = edom (Aheap \<Delta> e\<cdot>a) \<union> edom (ABinds \<Gamma>\<cdot>ae) \<union> edom (Aexp (Let \<Delta> e)\<cdot>a)"
    by auto
  finally
  have "edom (ABinds (\<Delta> @ \<Gamma>)\<cdot>(Aheap \<Delta> e\<cdot>a \<squnion> ae)) \<union> edom (Aexp e\<cdot>a) \<subseteq> edom (Aheap \<Delta> e\<cdot>a) \<union> edom (ABinds \<Gamma>\<cdot>ae) \<union> edom (Aexp (Let \<Delta> e)\<cdot>a)".
  hence "edom (ABinds (\<Delta> @ \<Gamma>)\<cdot>(Aheap \<Delta> e\<cdot>a \<squnion> ae)) \<union> edom (Aexp e\<cdot>a) \<union> edom (AEstack as S) \<subseteq> edom (Aheap \<Delta> e\<cdot>a) \<union> edom (ABinds \<Gamma>\<cdot>ae) \<union> edom (Aexp (Let \<Delta> e)\<cdot>a) \<union> edom (AEstack as S)" by auto
  thus ?case by (simp add: ae2ce_to_env_restr env_restr_join2 Un_assoc[symmetric] env_restr_mono2)
qed

sublocale CardinalityPrognosisEdom prognosis
  by standard (auto dest: subsetD[OF Aexp_edom] subsetD[OF ap_fv_subset] subsetD[OF edom_AnalBinds]  subsetD[OF edom_AEstack])

sublocale CardinalityPrognosisSafe prognosis cHeap Aheap Aexp..
end

end