theory Typing_Lemmas
  imports Typing Lemmas
begin

no_notation Set.member  ("(_/ : _)" [51, 51] 50)

lemma fun_ty_val: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e : \<tau>1 \<rightarrow> \<tau>2 ; is_value e \<rbrakk> \<Longrightarrow> (\<exists>x e'. e = (\<lambda>x:\<tau>1. e')) \<or> head_ctor e"
  by (induction \<Gamma> \<Delta> e "\<tau>1 \<rightarrow> \<tau>2" rule: Tm.induct) auto
lemma forall_ty_val: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e : \<forall>a:k. \<sigma> ; is_value e \<rbrakk> \<Longrightarrow> (\<exists>x e'. e = (\<Lambda> x:k. e')) \<or> head_ctor e"
  by (induction \<Gamma> \<Delta> e "\<forall>a:k. \<sigma>" rule: Tm.induct) auto

lemma context_cons_valid[elim]: "(\<Delta>::\<Delta>) \<turnstile> bndr # \<Gamma> \<Longrightarrow> (\<Delta> \<turnstile> \<Gamma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases rule: Ctx.cases) (auto simp: context_valid(1))

(* inversion rules for abstractions *)
lemma T_Abs_Inv:
  assumes a: "\<Gamma> , \<Delta> \<turnstile> (\<lambda>x : \<tau>1 . e) : \<tau>" and b: "atom x \<sharp> \<Gamma>"
  obtains \<tau>2 where "BVar x \<tau>1 # \<Gamma> , \<Delta> \<turnstile> e : \<tau>2" "\<tau> = arrow_app \<tau>1 \<tau>2"
proof (cases rule: Tm.cases[OF a])
  case (2 x' \<tau>1' \<Gamma>' \<Delta>' e' \<tau>2)
  then have swap: "(x' \<leftrightarrow> x) \<bullet> e' = e" using Abs_rename_body[of x' e' x e] by auto
  have valid: "\<turnstile> \<Delta>" using axioms_valid(3)[OF 2(5)] 2(2) by simp
  show ?thesis
  proof (cases "atom x' = atom x")
    case True
    then show ?thesis using 2 swap that by auto
  next
    case False
    then have 1: "atom x \<sharp> BVar x' \<tau>1' # \<Gamma>'" using b by (simp add: 2 fresh_Cons)
    have 3: "((x' \<leftrightarrow> x) \<bullet> (BVar x' \<tau>1 # \<Gamma>)) , \<Delta> \<turnstile> (x' \<leftrightarrow> x) \<bullet> e' : \<tau>2" using 2 Tm.eqvt[OF 2(5), of "(x' \<leftrightarrow> x)"] by fastforce
    have "((x' \<leftrightarrow> x) \<bullet> (BVar x' \<tau>1) # ((x' \<leftrightarrow> x) \<bullet> \<Gamma>)) = BVar x \<tau>1 # \<Gamma>"
      by (metis "1" "2"(1) "2"(5) CtxE(2) binder.perm_simps(1) context_valid_tm flip_at_simps(1) flip_fresh_fresh fresh_Cons perm_\<tau>_vars)
    then show ?thesis using 1 2 3 swap that by auto
  qed
qed simp_all

lemma T_Abs_Inv_2:
  fixes \<tau>::\<tau>
  assumes a: "\<Gamma> , \<Delta> \<turnstile> (\<lambda>x:\<tau>1. e) : \<tau>"
  obtains x' e' \<tau>2 where "BVar x' \<tau>1  # \<Gamma> , \<Delta> \<turnstile> e' : \<tau>2" "(\<lambda>x:\<tau>1. e) = (\<lambda>x':\<tau>1. e')" "atom x' \<sharp> (x, e)" "\<tau> = (\<tau>1 \<rightarrow> \<tau>2)"
proof (cases rule: Tm.cases[OF a])
  case (2 x' _ _ _ e' \<tau>2)
  then obtain c::var where "atom c \<sharp> (x, e, x', e', \<Gamma>)" using obtain_fresh by blast
  then have c: "atom c \<sharp> x" "atom c \<sharp> e" "atom c \<sharp> x'" "atom c \<sharp> e'" "atom c \<sharp> \<Gamma>" by auto
  obtain e2 where P: "(x' \<leftrightarrow> c) \<bullet> (\<lambda> x' : \<tau>1 . e') = (\<lambda> c : \<tau>1 . e2)" using flip_fresh_fresh by force
  then have 1: "(x' \<leftrightarrow> c) \<bullet> e' = e2" by (simp add: Abs1_eq_iff(3))
  have 3: "(x' \<leftrightarrow> c) \<bullet> \<Gamma> = \<Gamma>" by (metis 2(1,5) CtxE(2) c(5) context_valid_tm flip_def swap_fresh_fresh)
  have 4: "((x' \<leftrightarrow> c) \<bullet> BVar x' \<tau>1) = BVar c \<tau>1" using P by auto
  have valid: "\<turnstile> \<Delta>" using axioms_valid(3)[OF 2(5)] 2(2) by simp
  have "(x' \<leftrightarrow> c) \<bullet> (BVar x' \<tau>1 # \<Gamma> , \<Delta> \<turnstile> e' : \<tau>2)" using 2 by auto
  then have "((x' \<leftrightarrow> c) \<bullet> (BVar x' \<tau>1 # \<Gamma>)) , \<Delta> \<turnstile> (x' \<leftrightarrow> c) \<bullet>  e' : \<tau>2" using valid by auto
  then have "(((x' \<leftrightarrow> c) \<bullet> BVar x' \<tau>1) # ((x' \<leftrightarrow> c) \<bullet> \<Gamma>)) , \<Delta> \<turnstile> e2 : \<tau>2" using 1 by auto
  then have x: "BVar c \<tau>1 # \<Gamma> , \<Delta> \<turnstile> e2 : \<tau>2" using 3 4 by argo
  have y: "(\<lambda> x : \<tau>1 . e) = (\<lambda> c : \<tau>1 . e2)" by (metis 1 2(3) Abs1_eq_iff(3) c(3,4) flip_commute fresh_at_base(2) term.eq_iff(5))
  show ?thesis using that[OF x y] 2(3,4) c(1,2) by simp
qed auto

lemma T_Let_Inv:
  assumes a: "\<Gamma> , \<Delta> \<turnstile> Let x \<tau>1 e1 e2 : \<tau>" and b: "atom x \<sharp> \<Gamma>"
  shows "\<Gamma> , \<Delta> \<turnstile> e1 : \<tau>1 \<and> BVar x \<tau>1 # \<Gamma> , \<Delta> \<turnstile> e2 : \<tau>"
proof (cases rule: Tm.cases[OF a])
  case (7 \<Gamma>' \<Delta>' e1' \<tau>1' x' e2' \<tau>2')
  have swap: "(x' \<leftrightarrow> x) \<bullet> e2' = e2" using Abs_rename_body[of x' e2' x e2] 7(3) by simp
  show ?thesis
  proof (cases "atom x' = atom x")
    case True
    then show ?thesis using 7 swap by auto
  next
    case False
    then have 1: "atom x \<sharp> BVar x' \<tau>1 # \<Gamma>'" using b by (simp add: 7 fresh_Cons)
    have 2: "((x' \<leftrightarrow> x) \<bullet> (BVar x' \<tau>1#\<Gamma>)) , \<Delta> \<turnstile> (x' \<leftrightarrow> x) \<bullet> e2' : \<tau>" using Tm.eqvt[OF 7(6), of "(x' \<leftrightarrow> x)"] 7 by auto
    have 3: "((x' \<leftrightarrow> x) \<bullet> (BVar x' \<tau>1) # ((x' \<leftrightarrow> x) \<bullet> \<Gamma>)) = BVar x \<tau>1#\<Gamma>"
      by (metis "1" 7(1,6) CtxE(2) binder.perm_simps(1) context_valid_tm flip_at_simps(1) flip_def fresh_Cons perm_\<tau>_vars swap_fresh_fresh)
    from 2 3 7 swap show ?thesis by auto
  qed
qed simp_all

lemma T_AbsT_Inv:
  assumes a: "\<Gamma> , \<Delta> \<turnstile> (\<Lambda> a : k . e) : \<tau>" and b: "atom a \<sharp> \<Gamma>" "atom a \<sharp> \<tau>"
  obtains \<sigma> where "BTyVar a k # \<Gamma> , \<Delta> \<turnstile> e : \<sigma>" "\<tau> = (\<forall> a:k. \<sigma>)"
proof (cases rule: Tm.cases[OF a])
  case (4 a' k' \<Gamma>' \<Delta>' e' \<sigma>')
  then have fresh: "atom a' \<sharp> \<Gamma>" by (cases rule: Ctx.cases[OF context_valid(2)[OF 4(5)]]) auto
  have swap: "(a' \<leftrightarrow> a) \<bullet> e' = e" using Abs_rename_body[of a' e' a e] 4(3) by simp
  have valid: "\<turnstile> \<Delta>" using axioms_valid(3)[OF 4(5)] 4(2) by simp
  show ?thesis
  proof (cases "atom a = atom a'")
    case True
    then show ?thesis by (metis 4 Abs1_eq_iff(3) atom_eq_iff term.eq_iff(6) that)
  next
    case False
    then have 1: "atom a \<sharp> BTyVar a' k # \<Gamma>" using b by (simp add: 4 fresh_Cons)
    have 2: "((a' \<leftrightarrow> a) \<bullet> (BTyVar a' k # \<Gamma>)), \<Delta> \<turnstile> (a' \<leftrightarrow> a) \<bullet> e' : (a' \<leftrightarrow> a) \<bullet> \<sigma>'" using Tm.eqvt[OF 4(5), of "(a' \<leftrightarrow> a)"] valid 4 by auto
    have "((a' \<leftrightarrow> a) \<bullet> (BTyVar a' k # \<Gamma>)) = ((a' \<leftrightarrow> a) \<bullet> BTyVar a' k) # \<Gamma>" using 1 fresh flip_fresh_fresh b(1) by simp
    then have "((a' \<leftrightarrow> a) \<bullet> (BTyVar a' k # \<Gamma>)) = BTyVar a k # \<Gamma>" by (simp add: flip_fresh_fresh)
    then have "BTyVar a k # \<Gamma> , \<Delta> \<turnstile> e : (a' \<leftrightarrow> a) \<bullet> \<sigma>'" using 2 swap by argo
    then show ?thesis by (metis "4"(3,4) Abs1_eq_iff(3) False \<tau>.eq_iff(5) \<tau>.fresh(5) b(2) empty_iff flip_commute insert_iff list.set(1,2) term.eq_iff(6) that)
  qed
qed simp_all

lemma Ty_Forall_Inv:
  assumes a: "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y (\<forall>a:k. \<sigma>) : \<tau>" and b: "atom a \<sharp> \<Gamma>"
  shows "BTyVar a k # \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma> : \<star> \<and> \<tau> = \<star>"
proof (cases rule: Ty.cases[OF a])
  case (5 a' k' \<Gamma>' \<Delta>' \<sigma>')
  then have 1: "(BTyVar a' k # \<Gamma>) , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma>' : \<star>" by simp
  have valid: "\<turnstile> \<Delta>" by (rule axioms_valid(2)[OF 1])
  have "(a' \<leftrightarrow> a) \<bullet> \<sigma>' = \<sigma>" using Abs_rename_body[of a' \<sigma>' a \<sigma>] 5(3) by auto
  then have 2: "((a' \<leftrightarrow> a) \<bullet> (BTyVar a' k # \<Gamma>)) , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma> : \<star>" using Ty.eqvt[OF 1, of "(a' \<leftrightarrow> a)"] valid by auto
  have 3: "((a' \<leftrightarrow> a) \<bullet> (BTyVar a' k # \<Gamma>)) = BTyVar a k # ((a' \<leftrightarrow> a) \<bullet> \<Gamma>)" using Cons_eqvt flip_fresh_fresh by force
  have 4: "(a' \<leftrightarrow> a) \<bullet> \<Gamma> = \<Gamma>" by (metis 5(1,5) CtxE(1) b context_valid_ty flip_def swap_fresh_fresh)
  show ?thesis using 2 3 4 5(4) by argo
qed simp_all

lemma Ty_Forall_Inv_2:
  assumes a: "\<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<forall> a : k . \<sigma> : k2"
  obtains a' \<sigma>' where "(\<forall> a:k. \<sigma>) = (\<forall> a':k. \<sigma>')" "BTyVar a' k # \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma>' : \<star>" "atom a' \<sharp> (a, \<sigma>)" "k2 = \<star>"
proof (cases rule: Ty.cases[OF a])
  case (5 a2 _ _ _ \<sigma>2)
  then obtain c::tyvar where "atom c \<sharp> (a, \<sigma>, a2, \<sigma>2, \<Gamma>)" using obtain_fresh by blast
  then have c: "atom c \<sharp> a" "atom c \<sharp> \<sigma>" "atom c \<sharp> a2" "atom c \<sharp> \<sigma>2" "atom c \<sharp> \<Gamma>" by auto
  obtain \<sigma>' where P: "(a2 \<leftrightarrow> c) \<bullet> (\<forall> a2:k. \<sigma>2) = (\<forall> c:k. \<sigma>')" using flip_fresh_fresh by force
  then have 1: "(a2 \<leftrightarrow> c) \<bullet> \<sigma>2 = \<sigma>'" by (simp add: Abs1_eq_iff(3))
  have 2: "(a2 \<leftrightarrow> c) \<bullet> \<Gamma> = \<Gamma>" by (metis 5(1,5) CtxE(1) c(5) context_valid_ty flip_def swap_fresh_fresh)
  have 3: "((a2 \<leftrightarrow> c) \<bullet> BTyVar a2 k) = BTyVar c k" using P by auto
  have valid: "\<turnstile> \<Delta>" using axioms_valid(2)[OF 5(5)] 5(2) by simp
  have "(a2 \<leftrightarrow> c) \<bullet> (BTyVar a2 k # \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma>2 : \<star>)" using 5 by auto
  then have "((a2 \<leftrightarrow> c) \<bullet> (BTyVar a2 k # \<Gamma>)) , \<Delta> \<turnstile>\<^sub>t\<^sub>y (a2 \<leftrightarrow> c) \<bullet> \<sigma>2 : \<star>" using valid by auto
  then have "(((a2 \<leftrightarrow> c) \<bullet> BTyVar a2 k) # ((a2 \<leftrightarrow> c) \<bullet> \<Gamma>)) , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma>' : \<star>" using 1 by auto
  then have x: "BTyVar c k # \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<sigma>' : \<star>" using 2 3 by argo
  have y: "(a2 \<leftrightarrow> c) \<bullet> (\<forall> a2:k. \<sigma>2) = (\<forall> a2:k. \<sigma>2)" by (metis \<tau>.fresh(5) c(4) flip_def insert_iff list.set(2) no_tyvars_in_kinds swap_fresh_fresh)
  show ?thesis using that[OF _ x _ 5(4)] c(1,2) by (metis 5(3) P \<tau>.eq_iff(5) fresh_Pair y)
qed simp_all

lemma axiom_isin_same_kind: "\<lbrakk> AxData T k1 \<in> set (\<Delta>' @ AxData T k2 # \<Delta>) ; \<turnstile> (\<Delta>' @ AxData T k2 # \<Delta>) \<rbrakk> \<Longrightarrow> k1 = k2"
proof (induction \<Delta>')
  case Nil
  then have "\<nexists>k. AxData T k \<in> set \<Delta>" by auto
  then show ?case using Nil.prems(1) by auto
next
  case (Cons a \<Delta>')
  then show ?case using axioms_valid(2)
  proof (cases a rule: axiom.exhaust)
    case (AxData T' k3)
    then have "\<nexists>k. AxData T' k \<in> set (\<Delta>' @ AxData T k2 # \<Delta>)" using Cons(3) by fastforce
    then have "T' \<noteq> T" by auto
    then show ?thesis using Cons AxData by auto
  qed fastforce
qed

lemma axiom_isin_same_type: "\<lbrakk> AxCtor D \<tau>1 \<in> set (\<Delta>' @ AxCtor D \<tau>2 # \<Delta>) ; \<turnstile> (\<Delta>' @ AxCtor D \<tau>2 # \<Delta>) \<rbrakk> \<Longrightarrow> \<tau>1 = \<tau>2"
proof (induction \<Delta>')
  case Nil
  then have "\<nexists>t. AxCtor D t \<in> set \<Delta>" by auto
  then show ?case using Nil(1) by auto
next
  case (Cons a \<Delta>')
  then show ?case
  proof (cases a rule: axiom.exhaust)
    case (AxCtor D' \<tau>')
    then have "\<nexists>t. AxCtor D' t \<in> set (\<Delta>' @ AxCtor D \<tau>2 # \<Delta>)" using Cons(3) by fastforce
    then have "D' \<noteq> D" by auto
    then show ?thesis using AxCtor Cons axioms_valid_aux(2) set_ConsD by auto
  qed auto
qed
lemmas axiom_isin_same = axiom_isin_same_kind axiom_isin_same_type

lemma axiom_isin_split: "\<lbrakk> b \<in> set \<Delta> ; \<turnstile> \<Delta> \<rbrakk> \<Longrightarrow> \<exists>\<Delta>1 \<Delta>2. \<Delta> = \<Delta>1 @ b # \<Delta>2"
proof (induction \<Delta>)
  case (Cons a \<Delta>)
  then show ?case
  proof (cases "a = b")
    case True
    then show ?thesis by blast
  next
    case False
    then show ?thesis by (meson Cons.prems(1) split_list)
  qed
qed simp

lemma axioms_split_valid: "\<turnstile> \<Delta>' @ \<Delta> \<Longrightarrow> \<turnstile> \<Delta>"
proof (induction \<Delta>')
  case (Cons a \<Delta>')
  then show ?case using axioms_valid(2) by (cases a rule: axiom.exhaust) auto
qed simp

lemma isin_subset:
  fixes \<Gamma>::"\<Gamma>"
  assumes "\<Delta> \<turnstile> \<Gamma>' @ \<Gamma>"
  shows "bndr \<in> \<Gamma> \<longrightarrow> bndr \<in> (\<Gamma>' @ \<Gamma>)"
proof
  assume "bndr \<in> \<Gamma>"
  then show "bndr \<in> (\<Gamma>' @ \<Gamma>)"
  using assms proof (induction \<Gamma>' arbitrary: \<Gamma>)
    case (Cons b \<Gamma>2)
    have 1: "\<Delta> \<turnstile> \<Gamma>2 @ \<Gamma>" using Cons(3) by auto
    have 2: "bndr \<in> (\<Gamma>2 @ \<Gamma>)" by (rule Cons(1)[OF Cons(2) 1])
    show ?case
    proof (cases b rule: binder.exhaust)
      case (BVar x \<tau>)
      then have "atom x \<sharp> (\<Gamma>2 @ \<Gamma>)" using Cons by auto
      then show ?thesis using 2 BVar fresh_not_isin_var by (cases bndr rule: binder.exhaust) auto
    next
      case (BTyVar a k)
      then have "atom a \<sharp> (\<Gamma>2 @ \<Gamma>)" using Cons by auto
      then show ?thesis using 2 BTyVar fresh_not_isin_tyvar by (cases bndr rule: binder.exhaust) auto
    qed
  qed auto
qed

lemma isin_superset_tyvar: "\<lbrakk> BTyVar a k \<in> (\<Gamma>' @ BVar x \<tau> # \<Gamma>) ; \<Delta> \<turnstile> \<Gamma>' @ BVar x \<tau> # \<Gamma> \<rbrakk> \<Longrightarrow> BTyVar a k \<in> (\<Gamma>' @ \<Gamma>)"
proof (induction \<Gamma>')
  case (Cons bndr \<Gamma>')
  then show ?case by (cases bndr rule: binder.exhaust) auto
qed auto

lemma isin_superset_var: "\<lbrakk> BVar x \<tau> \<in> (\<Gamma>' @ BVar y \<tau>2 # \<Gamma>) ; \<Delta> \<turnstile> \<Gamma>' @ BVar y \<tau>2 # \<Gamma> ; x \<noteq> y \<rbrakk> \<Longrightarrow> BVar x \<tau> \<in> (\<Gamma>' @ \<Gamma>)"
proof (induction \<Gamma>')
  case (Cons bndr \<Gamma>')
  then show ?case by (cases bndr rule: binder.exhaust) auto
qed auto
lemmas isin_superset = isin_superset_tyvar isin_superset_var

lemma isin_same_kind: "\<lbrakk> BTyVar a k1 \<in> (\<Gamma>' @ BTyVar a k2 # \<Gamma>) ; \<Delta> \<turnstile> \<Gamma>' @ BTyVar a k2 # \<Gamma> \<rbrakk> \<Longrightarrow> k1 = k2"
proof (induction \<Gamma>')
  case (Cons bndr \<Gamma>')
  then show ?case by (cases rule: Ctx.cases[OF Cons(3)]) (auto split: if_splits simp: fresh_Cons fresh_append fresh_at_base(2))
qed auto

lemma isin_same_type: "\<lbrakk> BVar x \<tau> \<in> (\<Gamma>' @ BVar x \<tau>2 # \<Gamma>) ; \<Delta> \<turnstile> \<Gamma>' @ BVar x \<tau>2 # \<Gamma> \<rbrakk> \<Longrightarrow> \<tau> = \<tau>2"
proof (induction \<Gamma>')
  case (Cons a \<Gamma>')
  then show ?case by (cases rule: Ctx.cases[OF Cons(3)]) (auto split: if_splits simp: fresh_Cons fresh_append fresh_at_base)
qed auto
lemmas isin_same = isin_same_kind isin_same_type

lemma isin_subst_tyvar: "\<lbrakk> BTyVar a k \<in> (\<Gamma>' @ BTyVar b k2 # \<Gamma>) ; \<Delta> \<turnstile> \<Gamma>' @ BTyVar b k2 # \<Gamma> ; a \<noteq> b \<rbrakk> \<Longrightarrow> BTyVar a k \<in> (\<Gamma>'[\<sigma>/b] @ \<Gamma>)"
proof (induction \<Gamma>')
  case (Cons bndr \<Gamma>')
  then show ?case
  proof (cases rule: Ctx.cases[OF Cons(3)])
    case (2 \<Gamma>2 c k3)
    then have "BTyVar a k = bndr \<or> BTyVar a k \<in> (\<Gamma>' @ BTyVar b k2 # \<Gamma>)" by (metis Cons.prems(1) Cons_eq_append_conv isin.simps(5) list.inject)
    then show ?thesis
    proof
      assume a: "BTyVar a k = bndr"
      then show ?thesis using 2 Cons by auto
    next
      assume "BTyVar a k \<in> (\<Gamma>' @ BTyVar b k2 # \<Gamma>)"
      then show ?thesis using 2 Cons fresh_not_isin_tyvar by auto
    qed
  next
    case (3 \<Gamma> \<tau> x)
    then show ?thesis using Cons by auto
  qed simp
qed simp

lemma context_split_valid: "(\<Delta>::\<Delta>) \<turnstile> (\<Gamma>' @ \<Gamma>) \<Longrightarrow> \<Delta> \<turnstile> \<Gamma>"
  by (induction \<Gamma>') (auto simp: Ctx_Empty)

lemma isin_split: "\<lbrakk> b \<in> \<Gamma> ; \<Delta> \<turnstile> \<Gamma> \<rbrakk> \<Longrightarrow> \<exists>\<Gamma>1 \<Gamma>2. \<Gamma> = \<Gamma>1 @ b # \<Gamma>2"
proof (induction \<Gamma>)
  case (Cons bndr \<Gamma>)
  then show ?case
  proof (cases "bndr = b")
    case False
    then have "b \<in> \<Gamma>"
    proof (cases bndr rule: binder.exhaust)
      case (BVar x \<tau>)
      then show ?thesis using False Cons by (cases b rule: binder.exhaust) auto
    next
      case (BTyVar a k)
      then show ?thesis using False Cons by (cases b rule: binder.exhaust) auto
    qed
    then show ?thesis by (metis Cons.IH Cons.prems(2) Cons_eq_appendI context_cons_valid)
  qed blast
qed auto

lemma axioms_regularity: "\<turnstile> \<Delta>' @ AxCtor D \<tau> # \<Delta> \<Longrightarrow> [] , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : \<star>"
  using Ax_Ctor axioms_split_valid by (induction \<Delta>) blast+

lemma context_regularity: "\<Delta> \<turnstile> \<Gamma>' @ BVar x \<tau> # \<Gamma> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : \<star>"
  using Ctx_Var context_split_valid by (induction \<Gamma>) blast+

lemma Tm_eqvt_tyvar:
  assumes "BTyVar a k # \<Gamma> , \<Delta> \<turnstile> e : \<tau>" "atom c \<sharp> \<Gamma>"
  shows "BTyVar c k # \<Gamma> , \<Delta> \<turnstile> (a \<leftrightarrow> c) \<bullet> e : (a \<leftrightarrow> c) \<bullet> \<tau>"
proof -
  have "\<turnstile> \<Delta>" by (rule axioms_valid(3)[OF assms(1)])
  then have 1: "(a \<leftrightarrow> c) \<bullet> \<Delta> = \<Delta>" by auto
  have "\<Delta> \<turnstile> BTyVar a k # \<Gamma>" by (rule context_valid(2)[OF assms(1)])
  then have 2: "(a \<leftrightarrow> c) \<bullet> \<Gamma> = \<Gamma>" using assms(2) flip_fresh_fresh by blast
  have 3: "(a \<leftrightarrow> c) \<bullet> BTyVar a k = BTyVar c k" using flip_fresh_fresh by force

  have "(a \<leftrightarrow> c) \<bullet> (BTyVar a k # \<Gamma>) , (a \<leftrightarrow> c) \<bullet> \<Delta> \<turnstile> (a \<leftrightarrow> c) \<bullet> e : (a \<leftrightarrow> c) \<bullet> \<tau>" by (rule Tm.eqvt[OF assms(1), of "(a \<leftrightarrow> c)"])
  then show ?thesis using 1 2 3 by auto
qed

end


theory CFGExit_wf imports CFGExit CFG_wf begin

subsection \<open>New well-formedness lemmas using \<open>(_Exit_)\<close>\<close>

locale CFGExit_wf = CFGExit sourcenode targetnode kind valid_edge Entry
    get_proc get_return_edges procs Main Exit +
  CFG_wf sourcenode targetnode kind valid_edge Entry
    get_proc get_return_edges procs Main Def Use ParamDefs ParamUses
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> ('var,'val,'ret,'pname) edge_kind"
  and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')")  and get_proc :: "'node \<Rightarrow> 'pname"
  and get_return_edges :: "'edge \<Rightarrow> 'edge set"
  and procs :: "('pname \<times> 'var list \<times> 'var list) list" and Main :: "'pname"
  and Exit::"'node"  ("'('_Exit'_')")
  and Def :: "'node \<Rightarrow> 'var set" and Use :: "'node \<Rightarrow> 'var set"
  and ParamDefs :: "'node \<Rightarrow> 'var list"
  and ParamUses :: "'node \<Rightarrow> 'var set list" +
  assumes Exit_empty:"Def (_Exit_) = {} \<and> Use (_Exit_) = {}"

begin

lemma Exit_Use_empty [dest!]: "V \<in> Use (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

lemma Exit_Def_empty [dest!]: "V \<in> Def (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

end

end


(*
 * Copyright 2017, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory ArchArraysMemInstance
imports "../ArraysMemInstance"
begin

(* Showing arrays are in mem_type requires maximum sizes for objects,
   and maximum counts for elements *)
class array_outer_max_size = mem_type +
  assumes array_outer_max_size_ax: "size_of TYPE('a::c_type) < 2 ^ 19"

class array_max_count = finite +
  assumes array_max_count_ax: "CARD ('a) <= 2 ^ 13"

instance array :: (array_outer_max_size, array_max_count) mem_type
apply intro_classes
apply simp
apply (subgoal_tac "addr_card = 2 ^ (addr_bitsize - 19) * 2 ^ 19")
  apply (erule ssubst)
  apply (rule less_le_trans[where y = "card (UNIV::'b set) * 2 ^ 19"])
    apply (rule mult_less_mono2)
      apply (rule array_outer_max_size_ax)
    apply simp
  apply (rule mult_le_mono1)
    apply (rule le_trans[where j = "2 ^ 13"])
      apply (rule array_max_count_ax)
    apply simp
  apply simp
apply (simp add: addr_card)
done

class array_inner_max_size = array_outer_max_size +
  assumes array_inner_max_size_ax: "size_of TYPE('a::c_type) < 2 ^ 6"

instance array :: (array_inner_max_size, array_max_count) array_outer_max_size
apply intro_classes
apply simp
  apply (rule order_less_le_trans)
   apply (rule mult_le_less_imp_less)
    apply (rule array_max_count_ax)
   apply (rule array_inner_max_size_ax)
  apply simp
   apply simp
  apply simp
  done

instance word :: (len8) array_outer_max_size
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done

instance word :: (len8) array_inner_max_size
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done

instance ptr :: (c_type) array_outer_max_size
apply intro_classes
apply (simp add: size_of_def)
done

instance ptr :: (c_type) array_inner_max_size
apply intro_classes
apply (simp add: size_of_def)
done

class lt12 = finite +
  assumes lt12_ax: "CARD ('a) < 2 ^ 12"
class lt11 = lt12 +
  assumes lt11_ax: "CARD ('a) < 2 ^ 11"
class lt10 = lt11 +
  assumes lt10_ax: "CARD ('a) < 2 ^ 10"
class lt9 = lt10 +
  assumes lt9_ax: "CARD ('a) < 2 ^ 9"
class lt8 = lt9 +
  assumes lt8_ax: "CARD ('a) < 2 ^ 8"
class lt7 = lt8 +
  assumes lt7_ax: "CARD ('a) < 2 ^ 7"
class lt6 = lt7 +
  assumes lt6_ax: "CARD ('a) < 2 ^ 6"
class lt5 = lt6 +
  assumes lt5_ax: "CARD ('a) < 2 ^ 5"
class lt4 = lt5 +
  assumes lt4_ax: "CARD ('a) < 2 ^ 4"
class lt3 = lt4 +
  assumes lt3_ax: "CARD ('a) < 2 ^ 3"
class lt2 = lt3 +
  assumes lt2_ax: "CARD ('a) < 2 ^ 2"
class lt1 = lt2 +
  assumes lt1_ax: "CARD ('a) < 2 ^ 1"

instance bit0 :: (lt12) array_max_count
  using lt12_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt12) array_max_count
  using lt12_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt11) lt12
  using lt11_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt11) lt12
  using lt11_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt10) lt11
  using lt10_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt10) lt11
  using lt10_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt9) lt10
  using lt9_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt9) lt10
  using lt9_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt8) lt9
  using lt8_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt8) lt9
  using lt8_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt7) lt8
  using lt7_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt7) lt8
  using lt7_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt6) lt7
  using lt6_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt6) lt7
  using lt6_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt5) lt6
  using lt5_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt5) lt6
  using lt5_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt4) lt5
  using lt4_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt4) lt5
  using lt4_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt3) lt4
  using lt3_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt3) lt4
  using lt3_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt2) lt3
  using lt2_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt2) lt3
  using lt2_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt1) lt2
  using lt1_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt1) lt2
  using lt1_ax[where 'a='a] by intro_classes simp

instance num1 :: lt1
  by (intro_classes, simp_all)

(* don't understand why this also seems to be necessary *)
instance num1 :: array_max_count
  by (intro_classes, simp)

(* introduce hackish handling of 8192 type by making a copy of the type
   under a constructor, and then manually showing that it is an instance of
   array_max_count *)
datatype array_max_count_ty = array_max_count_ty "8192"

(* ML c-parser code also needs to know at which array size to use this type *)
ML \<open>
  structure ArchArrayMaxCount = struct
    val array_max_count = 8192
  end
\<close>

lemma univ_array_max_count_ty:
  "(UNIV::array_max_count_ty set) = image array_max_count_ty (UNIV::8192 set)"
  apply (simp add: set_eq_iff image_iff)
  apply (rule_tac allI)
  apply (rule_tac array_max_count_ty.induct)
  apply simp
  done

instance "array_max_count_ty" :: finite
  apply intro_classes
  apply (simp add: univ_array_max_count_ty)
  done

lemma card_array_max_count_ty[simp]: "CARD(array_max_count_ty) = CARD(8192)"
  apply (simp add: univ_array_max_count_ty card_image inj_on_def)
  done

instance "array_max_count_ty" :: array_max_count
  by intro_classes simp

end


(*<*)

(* Author: Kyndylan Nienhuis *)

theory CheriInstantiation

imports
  "ExecutionStep"
  "ValidState"
  "AddressTranslation"
  "Execute"
  "LoadData"
  "StoreData"
  "RestrictCap"
  "LoadCap"
  "StoreCap"
  "SealCap"
  "UnsealCap"
  "Exception"
  "InvokeCap"
  "MemoryInvariant"
  "CapabilityInvariant"
  "SystemRegisterAccess"
begin

(*>*)

theorem CheriInstantiation:
  shows "CanBeSimulated SemanticsCheriMips"
unfolding CanBeSimulated_def
proof clarify
  fix s lbl s'
  assume as: "(lbl, s') \<in> SemanticsCheriMips s"
  show "(lbl, s') \<in> AbstractSemantics s"
    unfolding AbstractSemantics_def
    using AddressTranslationInstantiation[OF as]
    using ExceptionInstantiation[OF as]
    using ExecuteInstantiation[OF as]
    using CapabilityInvariantInstantiation[OF as]
    using InvokeCapInstantiation[OF as]
    using LoadCapInstantiation[OF as]
    using LoadDataInstantiation[OF as]
    using MemoryInvariantInstantiation[OF as]
    using RestrictCapInstantiation[OF as]
    using SealCapInstantiation[OF as]
    using StoreCapInstantiation[OF as]
    using StoreLocalCapInstantiation[OF as]
    using StoreDataInstantiation[OF as]
    using UnsealCapInstantiation[OF as]
    using SystemRegisterInstantiation[OF as]
    using ValidStateInstantiation[OF as]
    by auto
qed

(*<*)
end
(*>*)


(*  Title:      HOL/Metis.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    Author:     Jasmin Blanchette, TU Muenchen
*)

section \<open>Metis Proof Method\<close>

theory Metis
imports ATP
begin

ML_file "~~/src/Tools/Metis/metis.ML"

subsection \<open>Literal selection and lambda-lifting helpers\<close>

definition select :: "'a \<Rightarrow> 'a" where
"select = (\<lambda>x. x)"

lemma not_atomize: "(\<not> A \<Longrightarrow> False) \<equiv> Trueprop A"
by (cut_tac atomize_not [of "\<not> A"]) simp

lemma atomize_not_select: "(A \<Longrightarrow> select False) \<equiv> Trueprop (\<not> A)"
unfolding select_def by (rule atomize_not)

lemma not_atomize_select: "(\<not> A \<Longrightarrow> select False) \<equiv> Trueprop A"
unfolding select_def by (rule not_atomize)

lemma select_FalseI: "False \<Longrightarrow> select False" by simp

definition lambda :: "'a \<Rightarrow> 'a" where
"lambda = (\<lambda>x. x)"

lemma eq_lambdaI: "x \<equiv> y \<Longrightarrow> x \<equiv> lambda y"
unfolding lambda_def by assumption

subsection \<open>Metis package\<close>

ML_file "Tools/Metis/metis_generate.ML"
ML_file "Tools/Metis/metis_reconstruct.ML"
ML_file "Tools/Metis/metis_tactic.ML"

hide_const (open) select fFalse fTrue fNot fComp fconj fdisj fimplies fAll fEx fequal lambda
hide_fact (open) select_def not_atomize atomize_not_select not_atomize_select select_FalseI
  fFalse_def fTrue_def fNot_def fconj_def fdisj_def fimplies_def fAll_def fEx_def fequal_def
  fTrue_ne_fFalse fNot_table fconj_table fdisj_table fimplies_table fAll_table fEx_table
  fequal_table fAll_table fEx_table fNot_law fComp_law fconj_laws fdisj_laws fimplies_laws
  fequal_laws fAll_law fEx_law lambda_def eq_lambdaI

end


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

(*
 * A theoretical framework for reasoning about non-interference
 * of monadic programs.
 *)

theory EquivValid
imports Corres_UL
begin

section\<open>State equivalence validity\<close>

text\<open>

A generalised information flow property.

Often, we read in the entire state, but then only examine part of it.
The following property may be used to split up binds whose first part
does this.

@{term "I"} is the state relation that holds invariantly.

@{term "A"} (also) holds between initial states.

@{term "B"} (also) holds between final states.

@{term "P"} holds in the initial state for @{term "f"}.

@{term "P'"} holds in the initial state for @{term "f'"}.

\<close>

definition
  equiv_valid_2 :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s,'b) nondet_monad \<Rightarrow> ('s,'c) nondet_monad \<Rightarrow> bool"
where
  "equiv_valid_2 I A B R P P' f f' \<equiv> \<forall>s t.
       P s \<and> P' t \<and> I s t \<and> A s t
     \<longrightarrow> (\<forall>(rva, s') \<in> fst (f s). \<forall>(rvb, t') \<in> fst (f' t).
          R rva rvb \<and> I s' t' \<and> B s' t')"

lemma equiv_valid_2_bind_general:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D B C R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes r1: "equiv_valid_2 D A B R' P P' f f'"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare': "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  shows "equiv_valid_2 D A C R (\<lambda> s. P s \<and> S s) (\<lambda> s. P' s \<and> S' s) (f >>= g) (f' >>= g')"
  using assms
  unfolding bind_def equiv_valid_2_def valid_def
  apply fastforce
  done

(* almost all of the time, the second relation doesn't change *)
lemma equiv_valid_2_bind:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D A A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes r1: "equiv_valid_2 D A A R' P P' f f'"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare': "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  shows "equiv_valid_2 D A A R (\<lambda> s. P s \<and> S s) (\<lambda> s. P' s \<and> S' s) (f >>= g) (f' >>= g')"
  using assms by (blast intro: equiv_valid_2_bind_general)

lemma equiv_valid_2_guard_imp:
  assumes reads_res: "equiv_valid_2 D A B R Q Q' f f'"
  assumes guard_imp: "\<And> s. P s \<Longrightarrow> Q s"
  assumes guard_imp': "\<And> s. P' s \<Longrightarrow> Q' s"
  shows "equiv_valid_2 D A B R P P' f f'"
  using assms
  by (fastforce simp: equiv_valid_2_def)

lemma equiv_valid_2_bind_pre:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D A A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes r1: "equiv_valid_2 D A A R' P P' f f'"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare': "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  assumes guard_imp: "\<And> s. T s \<Longrightarrow> P s \<and> S s"
  assumes guard_imp': "\<And> s. T' s \<Longrightarrow> P' s \<and> S' s"
  shows "equiv_valid_2 D A A R T T' (f >>= g) (f' >>= g')"
  using assms by (blast intro: equiv_valid_2_bind[THEN equiv_valid_2_guard_imp])

lemma return_ev2:
  assumes rel: "\<And> s t. \<lbrakk>P s; P' t; I s t; A s t\<rbrakk> \<Longrightarrow> R a b"
  shows "equiv_valid_2 I A A R P P' (return a) (return b)"
  by(auto simp: equiv_valid_2_def return_def rel)

lemma equiv_valid_2_liftE:
  "equiv_valid_2 D A B R P P' f f' \<Longrightarrow>
   equiv_valid_2 D A B (E \<oplus> R) P P' (liftE f) (liftE f')"
  apply(unfold liftE_def)
  apply(rule equiv_valid_2_guard_imp)
  apply(rule_tac Q="\<top>\<top>" and Q'="\<top>\<top>" and R'=R in equiv_valid_2_bind_general)
       apply(fastforce intro: return_ev2)
      apply assumption
     apply(rule wp_post_taut)+
   by(simp_all)

lemma equiv_valid_2_liftE_bindE_general:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D B C R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare':  "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  assumes r1: "equiv_valid_2 D A B R' P P' f f'"
  shows "equiv_valid_2 D A C R (P and S) (P' and S') (liftE f >>=E g) (liftE f' >>=E g')"
  apply(unfold bindE_def)
  apply(rule equiv_valid_2_guard_imp)
  apply(rule_tac Q="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q v s)" and Q'="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q' v s)" in equiv_valid_2_bind_general)
       prefer 2
       apply(rule_tac E="dc" in equiv_valid_2_liftE)
       apply(rule r1)
      apply(clarsimp simp: lift_def split: sum.split)
      apply(insert r2, fastforce simp: equiv_valid_2_def)[1]
     apply(simp add: liftE_def, wp, fastforce intro!: hoare_strengthen_post[OF hoare])
    apply(simp add: liftE_def, wp, fastforce intro!: hoare_strengthen_post[OF hoare'])
   by(auto)

lemma equiv_valid_2_liftE_bindE:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D A A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare':  "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  assumes r1: "equiv_valid_2 D A A R' P P' f f'"
  shows "equiv_valid_2 D A A R (P and S) (P' and S') (liftE f >>=E g) (liftE f' >>=E g')"
  using assms by(blast intro: equiv_valid_2_liftE_bindE_general)

lemma equiv_valid_2_rvrel_imp:
  "\<lbrakk>equiv_valid_2 I A A R P P' f f'; \<And> s t. R s t \<Longrightarrow> R' s t\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A A R' P P' f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

subsection\<open>Specialised fixed-state state equivalence validity\<close>

text\<open>

For resolve_address_bits and rec_del: talk about a fixed initial
state. Note we only do this for one of the computations; the other
state can be constrained by how it is related to this one by @{term
"I"} and so forth.

Also captures the typical case where the relation between the return
values is equality and the required preconditions are identical.

wp can cope with this.

\<close>

definition
  spec_equiv_valid :: "'s \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s,'b) nondet_monad \<Rightarrow> bool"
where
  "spec_equiv_valid st I A B P f \<equiv> equiv_valid_2 I A B (=) (P and ((=) st)) P f f"

abbreviation spec_equiv_valid_inv where
  "spec_equiv_valid_inv st I A P f \<equiv> spec_equiv_valid st I A A P f"

subsection\<open>Specialised state equivalence validity\<close>

text\<open>

Most of the time we deal with the streamlined version.

wp can cope with this too.

\<close>

definition
  equiv_valid :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s,'b) nondet_monad \<Rightarrow> bool"
where
  "equiv_valid I A B P f \<equiv> \<forall>st. spec_equiv_valid st I A B P f"

lemma equiv_valid_def2:
  "equiv_valid I A B P f = equiv_valid_2 I A B (=) P P f f"
  by (simp add: equiv_valid_def spec_equiv_valid_def equiv_valid_2_def)

abbreviation equiv_valid_rv where
  "equiv_valid_rv I A B R P f \<equiv> equiv_valid_2 I A B R P P f f"

(* this is probably way more general than we need for all but a few special cases *)
lemma bind_ev_general:
  assumes reads_res_2: "\<And>rv. equiv_valid I B C (Q rv) (g rv)"
  assumes reads_res_1: "equiv_valid I A B P' f"
  assumes hoare: "\<lbrace> P'' \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid I A C (\<lambda>s. P' s \<and> P'' s) (f >>= g)"
  unfolding equiv_valid_def2
  apply (rule equiv_valid_2_bind_general[where R'="(=)"])
     apply (auto intro: reads_res_1[unfolded equiv_valid_def2] reads_res_2[unfolded equiv_valid_def2])[2]
   apply (rule hoare)
  apply (rule hoare)
  done

lemma bind_ev:
  assumes reads_res_2: "\<And>rv. equiv_valid I A A (Q rv) (g rv)"
  assumes reads_res_1: "equiv_valid I A A P' f"
  assumes hoare: "\<lbrace> P'' \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid I A A (\<lambda>s. P' s \<and> P'' s) (f >>= g)"
  using assms by (blast intro: bind_ev_general)

lemma equiv_valid_weaken_pre:
  "\<lbrakk> equiv_valid I A' B P f; \<forall>st t. I st t \<and> A st t \<longrightarrow> A' st t \<rbrakk>
     \<Longrightarrow> equiv_valid I A B P f"
  by (fastforce simp: equiv_valid_def spec_equiv_valid_def equiv_valid_2_def)

lemma equiv_valid_guard_imp:
  assumes reads_res: "equiv_valid I A B Q f"
  assumes guard_imp: "\<And> s. P s \<Longrightarrow> Q s"
  shows "equiv_valid I A B P f"
  using assms by (fastforce simp: equiv_valid_def2 equiv_valid_2_def)

lemmas bind_ev_pre = bind_ev[THEN equiv_valid_guard_imp]

lemma gen_asm_ev':
  assumes "Q \<Longrightarrow> equiv_valid D A B P f"
  shows "equiv_valid D A B (P and K Q) f"
  using assms by (fastforce simp: equiv_valid_def2 equiv_valid_2_def)

declare K_def [simp del]

lemmas gen_asm_ev =
  gen_asm_ev'[where P="\<top>", simplified]
  gen_asm_ev'
  gen_asm_ev'[simplified K_def, where P="\<top>", simplified]
  gen_asm_ev'[simplified K_def]

declare K_def [simp]

text \<open>
  This is a further streamlined version that we expect to get the most from
  automating, and for the most part, we shouldn't need to deal with the
  extra generality of the properties above.
\<close>
abbreviation equiv_valid_inv where
  "equiv_valid_inv I A P f \<equiv> equiv_valid I A A P f"

abbreviation equiv_valid_rv_inv where
  "equiv_valid_rv_inv I A R P f \<equiv> equiv_valid_rv I A A R P f"

lemma get_evrv:
  "equiv_valid_rv_inv I A (I and A) \<top> get"
  by(auto simp: equiv_valid_2_def get_def)

lemma equiv_valid_rv_bind_general:
  assumes ev1:
  "equiv_valid_rv I A B W P f"
  assumes ev2:
  "\<And> rv rv'. W rv rv' \<Longrightarrow> equiv_valid_2 I B C R (Q rv) (Q rv') (g rv) (g rv')"
  assumes hoare:
  "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_rv I A C R P (f >>= g)"
  apply(rule equiv_valid_2_guard_imp)
  apply(rule equiv_valid_2_bind_general[OF ev2])
       apply(assumption)
      apply(rule ev1)
     apply(rule hoare)
    apply(rule hoare)
   apply(simp_all)
  done

lemma equiv_valid_rv_bind:
  assumes ev1:
  "equiv_valid_rv_inv I A W P f"
  assumes ev2:
  "\<And> rv rv'. W rv rv' \<Longrightarrow> equiv_valid_2 I A A R (Q rv) (Q rv') (g rv) (g rv')"
  assumes hoare:
  "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_rv_inv I A R P (f >>= g)"
  using assms by(blast intro: equiv_valid_rv_bind_general)

lemma modify_ev2:
  assumes "\<And> s t. \<lbrakk>I s t; A s t; P s; P' t\<rbrakk> \<Longrightarrow> R () () \<and> I (f s) (f' t) \<and> B (f s) (f' t)"
  shows
  "equiv_valid_2 I A B R P P' (modify f) (modify f')"
  apply(clarsimp simp: equiv_valid_2_def in_monad)
  using assms by auto

lemma modify_ev:
  "equiv_valid I A B
     (\<lambda> s. \<forall> s t. I s t \<and> A s t \<longrightarrow> I (f s) (f t) \<and> B (f s) (f t))
     (modify f)"
  apply(clarsimp simp:equiv_valid_def2)
  apply(rule modify_ev2)
  by auto

lemma modify_ev':
  "equiv_valid I A B
     (\<lambda> s. \<forall> t. I s t \<and> A s t \<longrightarrow> I (f s) (f t) \<and> B (f s) (f t))
     (modify f)"
  apply(clarsimp simp:equiv_valid_def2)
  apply(rule modify_ev2)
  by auto

lemma modify_ev'':
  assumes "\<And> s t. \<lbrakk>I s t; A s t; P s; P t\<rbrakk> \<Longrightarrow> I (f s) (f t) \<and> B (f s) (f t)"
  shows "equiv_valid I A B P (modify f)"
  apply(clarsimp simp:equiv_valid_def2)
  apply(rule modify_ev2)
  using assms by auto

lemma put_ev2:
  assumes "\<And> s t. \<lbrakk>I s t; A s t; P s; P' t\<rbrakk> \<Longrightarrow> R () () \<and> I x x' \<and> B x x'"
  shows
  "equiv_valid_2 I A B R P P' (put x) (put x')"
  apply(clarsimp simp: equiv_valid_2_def in_monad)
  using assms by auto

lemma get_bind_ev2:
  assumes "\<And> rv rv'. \<lbrakk>I rv rv'; A rv rv'\<rbrakk> \<Longrightarrow> equiv_valid_2 I A B R (P and ((=) rv)) (P' and ((=) rv')) (f rv) (f' rv')"
  shows "equiv_valid_2 I A B R P P' (get >>= f) (get >>= f')"
  apply(rule equiv_valid_2_guard_imp)
  apply(rule_tac R'="I and A" in equiv_valid_2_bind_general)
       apply(rule assms, simp+)
      apply(rule get_evrv)
     apply(wp get_sp)+
   by(auto)

lemma return_ev_pre:
  "equiv_valid_inv I A P (return x)"
  apply (simp add: equiv_valid_def2 return_ev2)
  done

lemmas return_ev = return_ev_pre[where P=\<top>]

lemma fail_ev2_l:
  "equiv_valid_2 I A B R P P' fail f'"
  by(simp add: equiv_valid_2_def fail_def)

lemma fail_ev2_r:
  "equiv_valid_2 I A B R P P' f fail"
  by(simp add: equiv_valid_2_def fail_def)

lemma fail_ev_pre:
  "equiv_valid I A B P fail"
  apply (simp add: equiv_valid_def2 fail_ev2_l)
  done

lemmas fail_ev = fail_ev_pre[where P=\<top>]

lemma assert_ev2:
  "R () () \<Longrightarrow> equiv_valid_2 I A A R P P' (assert a) (assert b)"
  apply(simp add: assert_def fail_ev2_l fail_ev2_r)
  apply(blast intro: return_ev2)
  done

lemma liftE_ev:
  "equiv_valid I A B P f \<Longrightarrow> equiv_valid I A B P (liftE f)"
  unfolding liftE_def
  apply (rule bind_ev_general[THEN equiv_valid_guard_imp, OF return_ev _ wp_post_taut])
  apply fastforce+ (* schematic instantiation *)
  done

lemma if_ev:
  assumes "b \<Longrightarrow> equiv_valid I A B P f"
  assumes "\<not> b \<Longrightarrow> equiv_valid I A B Q g"
  shows "equiv_valid I A B (\<lambda>s. (b \<longrightarrow> P s) \<and> (\<not>b \<longrightarrow> Q s)) (if b then f else g)"
  apply (clarsimp split: if_split)
  using assms by blast

lemmas if_ev_pre = equiv_valid_guard_imp[OF if_ev]

lemma assert_ev_pre:
  "equiv_valid_inv I A P (assert b)"
  apply(simp add: equiv_valid_def2 assert_ev2)
  done

lemmas assert_ev = assert_ev_pre[where P=\<top>]

lemma assert_opt_ev:
  "equiv_valid_inv I A \<top> (assert_opt v)"
  apply (simp add: assert_opt_def return_ev fail_ev
            split: option.split)
  done

lemma assert_opt_ev2:
  assumes "\<And> a a'. \<lbrakk>v = Some a; v' = Some a'\<rbrakk> \<Longrightarrow> R a a'"
  shows "equiv_valid_2 I A A R \<top> \<top> (assert_opt v) (assert_opt v')"
  apply (simp add: assert_opt_def return_ev fail_ev2_l fail_ev2_r
            split: option.split)
  apply(intro allI impI)
  apply(rule return_ev2)
  apply(rule assms, assumption+)
  done

lemma select_f_ev:
  "equiv_valid_inv I A (K (det f)) (select_f (f x))"
  apply (rule gen_asm_ev)
  apply (simp add: select_f_def equiv_valid_def2 equiv_valid_2_def det_set_iff)
  done

lemma gets_evrv:
  "equiv_valid_rv_inv I A R (K (\<forall>s t. I s t \<and> A s t \<longrightarrow> R (f s) (f t))) (gets f)"
  apply (auto simp: equiv_valid_2_def in_monad)
  done

lemma gets_evrv':
  "equiv_valid_rv_inv I A R (\<lambda>s. (\<forall>t. I s t \<and> A s t \<longrightarrow> R (f s) (f t))) (gets f)"
  apply (auto simp: equiv_valid_2_def in_monad)
  done

lemma gets_evrv'':
  "\<forall>s t. I s t \<and> A s t \<and> P s \<and> P t \<longrightarrow> R (f s) (f t) \<Longrightarrow> equiv_valid_rv_inv I A R P (gets f)"
  apply (auto simp: equiv_valid_2_def in_monad)
  done

lemma equiv_valid_rv_guard_imp:
  "\<lbrakk>equiv_valid_rv I A B R P f; \<And> s. Q s \<Longrightarrow> P s\<rbrakk> \<Longrightarrow>
   equiv_valid_rv I A B R Q f"
  apply(simp add: equiv_valid_2_def)
  apply fast
  done

lemma gets_ev:
  shows "equiv_valid_inv I A (\<lambda> s. \<forall> s t. I s t \<and> A s t \<longrightarrow> f s = f t) (gets f)"
  apply (simp add: equiv_valid_def2)
  apply (auto intro: equiv_valid_rv_guard_imp[OF gets_evrv])
  done

lemma gets_ev':
  shows "equiv_valid_inv I A (\<lambda> s. \<forall> t. I s t \<and> A s t \<longrightarrow> f s = f t) (gets f)"
  apply (simp add: equiv_valid_def2)
  apply (auto intro: equiv_valid_rv_guard_imp[OF gets_evrv'])
  done

lemma gets_ev'':
  "\<forall>s t. I s t \<and> A s t \<and> P s \<and> P t \<longrightarrow> f s = f t \<Longrightarrow> equiv_valid_inv I A P (gets f)"
  apply (simp add: equiv_valid_def2)
  apply (auto intro: equiv_valid_rv_guard_imp[OF gets_evrv''])
  done

lemma gets_the_evrv:
  "equiv_valid_rv_inv I A R (K (\<forall>s t. I s t \<and> A s t \<longrightarrow> R (the (f s)) (the (f t)))) (gets_the f)"
  unfolding gets_the_def
  apply (rule equiv_valid_rv_bind)
    apply(rule equiv_valid_rv_guard_imp[OF gets_evrv])
    apply simp
   apply(rule assert_opt_ev2)
   apply simp
  apply wp
  done

lemma gets_the_ev:
  "equiv_valid_inv I A (K (\<forall>s t. I s t \<and> A s t \<longrightarrow> f s = f t)) (gets_the f)"
  unfolding equiv_valid_def2
  apply(rule equiv_valid_rv_guard_imp[OF gets_the_evrv])
  by simp

lemma throwError_ev_pre:
  "equiv_valid_inv I A P (throwError e)"
  by (auto simp: throwError_def return_ev_pre)

lemmas throwError_ev = throwError_ev_pre[where P=\<top>]

lemma returnOk_ev_pre:
  "equiv_valid_inv I A P (returnOk v)"
  by (auto simp: returnOk_def return_ev_pre)

lemmas returnOk_ev = returnOk_ev_pre[where P=\<top>]

(* this seems restrictive, to have the same beginning and ending state relation,
   however, one suspects that bindE is used usually only in code that doesn't
   modify the state, so is probably OK.. We'll see *)
lemma bindE_ev:
  assumes reads_res_2: "\<And> rv. equiv_valid_inv I A (Q rv) (g rv)"
  assumes reads_res_1: "equiv_valid_inv I A P' f"
  assumes hoare: "\<lbrace> P'' \<rbrace> f \<lbrace> Q \<rbrace>,-"
  shows "equiv_valid_inv I A (\<lambda>s. P' s \<and> P'' s) (f >>=E g)"
  unfolding bindE_def
  apply (rule bind_ev)
    prefer 3
    apply(rule hoare[unfolded validE_R_def validE_def])
   apply(simp split: sum.split add: lift_def throwError_ev)
   apply(blast intro!: reads_res_2)
  apply(rule reads_res_1)
  done

lemmas bindE_ev_pre = bindE_ev[THEN equiv_valid_guard_imp]

(* Of course, when we know that progress is always made, we can do better *)
lemma liftE_bindE_ev_general:
  assumes r2: "\<And> val. equiv_valid I B C (Q val) (g val)"
  assumes r1: "equiv_valid I A B P f"
  assumes hoare: "\<lbrace> R \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid I A C (\<lambda> s. P s \<and> R s) (liftE f >>=E g)"
  apply(simp add: bindE_def)
  apply(rule_tac Q="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q v s)" in bind_ev_general)
    prefer 2
    apply(rule liftE_ev)
    apply(rule r1)
   apply(insert r2, fastforce simp: lift_def split: sum.split simp: equiv_valid_def2 equiv_valid_2_def)[1]
  apply(insert hoare, fastforce simp: valid_def liftE_def return_def bind_def)
  done

lemma liftE_bindE_ev:
  assumes r2: "\<And> val. equiv_valid_inv I A (Q val) (g val)"
  assumes r1: "equiv_valid_inv I A P f"
  assumes hoare: "\<lbrace> R \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_inv I A (\<lambda> s. P s \<and> R s) (liftE f >>=E g)"
  using assms by (blast intro: liftE_bindE_ev_general)

lemmas liftE_bindE_ev_pre = liftE_bindE_ev[THEN equiv_valid_guard_imp]

lemma liftM_ev:
  assumes reads_res: "equiv_valid I A B P g"
  shows "equiv_valid I A B P (liftM f g)"
  apply (simp add: liftM_def)
  apply (rule bind_ev_general[THEN equiv_valid_guard_imp, OF return_ev reads_res wp_post_taut])
  apply simp
  done

lemma liftME_ev:
  assumes reads_res: "equiv_valid_inv I A P g"
  shows "equiv_valid_inv I A P (liftME f g)"
  apply(simp add: liftME_def)
  apply (rule bindE_ev_pre[OF returnOk_ev reads_res])
  apply (rule hoare_True_E_R)
  apply fast
  done

lemma whenE_ev:
  assumes a: "b \<Longrightarrow> equiv_valid_inv I A P m"
  shows "equiv_valid_inv I A (\<lambda>s. b \<longrightarrow> P s) (whenE b m)"
  unfolding whenE_def by (auto intro: a returnOk_ev_pre)

lemma whenE_throwError_bindE_ev:
  assumes "\<And> rv. \<not> b \<Longrightarrow> equiv_valid_inv I A P (g rv)"
  shows "equiv_valid_inv I A P (whenE b (throwError e) >>=E g)"
  apply (rule_tac Q="\<lambda> rv. P and (\<lambda> s. \<not> b)" in bindE_ev_pre)
     apply (rule gen_asm_ev)
     apply (blast intro: assms)
    apply (rule whenE_ev)
    apply (rule throwError_ev)
   apply (wp whenE_throwError_wp)
  apply simp
  done

(* FIXME: trivially generalised *)
lemma K_bind_ev:
  "equiv_valid I A B P f \<Longrightarrow> equiv_valid I A B P (K_bind f x)"
  by simp

subsection\<open>wp setup\<close>

lemmas splits_ev[wp_split] =
  bind_ev_pre bindE_ev_pre
  bind_ev bindE_ev
  if_ev_pre
  if_ev

lemmas wp_ev[wp] =
  return_ev_pre
  return_ev
  liftE_ev
  fail_ev_pre
  fail_ev
  assert_opt_ev
  assert_ev
  gets_ev
  gets_the_ev
  returnOk_ev_pre
  returnOk_ev
  throwError_ev_pre
  throwError_ev
  liftM_ev
  liftME_ev
  whenE_ev
  K_bind_ev

subsection\<open>crunch setup\<close>

lemmas pre_ev =
  hoare_pre
  equiv_valid_guard_imp

subsection\<open>Tom instantiates wpc\<close>

lemma wpc_helper_equiv_valid:
  "equiv_valid D A B Q f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (equiv_valid D A B P f)"
  using equiv_valid_guard_imp
  apply (simp add: wpc_helper_def)
  apply (blast)
  done

wpc_setup "\<lambda>m. equiv_valid D A B Q m" wpc_helper_equiv_valid

subsection\<open>More hoare-like rules\<close>

lemma mapM_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapM m lst)"
  using assms
  apply(atomize)
  apply(rule_tac Q=I in equiv_valid_guard_imp)
  apply(induct lst)
    apply(simp add: mapM_Nil return_ev_pre)
   apply(subst mapM_Cons)
   apply(rule bind_ev_pre[where P''="I"])
    apply(rule bind_ev[OF return_ev])
    apply fastforce
    apply (rule wp_post_taut)
    apply fastforce+
  done

lemma mapM_x_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapM_x m lst)"
  apply(subst mapM_x_mapM)
  apply(rule bind_ev_pre[OF return_ev mapM_ev_pre])
  apply (blast intro: reads_res invariant inv_established wp_post_taut)+
  done

lemma mapM_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  shows "equiv_valid_inv D A I (mapM m lst)"
  using assms by (auto intro: mapM_ev_pre)

lemma mapM_x_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  shows "equiv_valid_inv D A I (mapM_x m lst)"
  using assms by (auto intro: mapM_x_ev_pre)

(* MOVE -- proof clagged from mapM_x_mapM *)
lemma mapME_x_mapME:
  "mapME_x f l = mapME f l >>=E (\<lambda> y. returnOk ())"
  apply (simp add: mapME_x_def sequenceE_x_def mapME_def sequenceE_def)
  apply (induct l, simp_all add: Let_def bindE_assoc)
  done

lemma mapME_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>,-"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapME m lst)"
  using assms
  apply(atomize)
  apply(rule_tac Q=I in equiv_valid_guard_imp)
  apply(induct lst)
    apply(simp add: mapME_Nil returnOk_ev_pre)
   apply(subst mapME_Cons)
   apply wp
   apply fastforce
   apply (rule hoare_True_E_R[where P="\<top>"])
   apply fastforce+
  done

lemma mapME_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv I A P (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> P \<rbrace> m x \<lbrace> \<lambda>_. P \<rbrace>, -"
  shows "equiv_valid_inv I A P (mapME m lst)"
  using assms by (auto intro: mapME_ev_pre)

lemma mapME_x_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>,-"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapME_x m lst)"
  unfolding mapME_x_mapME
  apply (wp assms mapME_ev_pre | simp)+
  done

lemma mapME_x_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>, -"
  shows "equiv_valid_inv D A I (mapME_x m lst)"
  using assms by (auto intro: mapME_x_ev_pre)

lemma mapM_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapM m lst)"
  apply(rule mapM_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

lemma mapM_x_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapM_x m lst)"
  apply(rule mapM_x_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

lemma mapME_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapME m lst)"
  apply(rule mapME_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

lemma mapME_x_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapME_x m lst)"
  apply(rule mapME_x_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

subsection\<open>Rules for the specialised validity\<close>

lemma use_spec_ev:
  "(\<And>st. spec_equiv_valid st I A B P f) \<Longrightarrow> equiv_valid I A B P f"
  by (simp add: equiv_valid_def)

lemma drop_spec_ev:
  "equiv_valid I A B P f \<Longrightarrow> spec_equiv_valid st I A B P f"
  by (simp add: equiv_valid_def)

lemma spec_equiv_valid_guard_imp:
  assumes reads_res: "spec_equiv_valid_inv s' I A P' f"
  assumes guard_imp: "\<And> s. P s \<Longrightarrow> P' s"
  shows "spec_equiv_valid_inv s' I A P f"
  using assms
  by (fastforce simp: spec_equiv_valid_def equiv_valid_2_def)

lemma bind_spec_ev:
  assumes reads_res_2: "\<And> rv s''. (rv, s'') \<in> fst (f s') \<Longrightarrow> spec_equiv_valid_inv s'' I A (Q rv) (g rv)"
  assumes reads_res_1: "spec_equiv_valid_inv s' I A P' f"
  assumes hoare: "\<lbrace>P''\<rbrace> f \<lbrace>Q\<rbrace>"
  shows "spec_equiv_valid_inv s' I A (\<lambda>s. P' s \<and> P'' s) (f >>= g)"
  using reads_res_1
  apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def valid_def bind_def split_def)
  apply (rename_tac t a b aa ba ab bb ac bc)
  apply (erule_tac x=t in allE)
  apply clarsimp
  apply (erule_tac x="(a, b)" in ballE)
   apply (erule_tac x="(ab, bb)" in ballE)
    apply clarsimp
    apply (cut_tac reads_res_2)
     prefer 2
     apply assumption
    apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def)
    apply(erule_tac x=bb in allE)
    using hoare
    apply (fastforce simp: valid_def)+
  done

lemma bindE_spec_ev:
  assumes reads_res_2: "\<And> rv s''. (Inr rv, s'') \<in> fst (f s') \<Longrightarrow> spec_equiv_valid_inv s'' I A (Q rv) (g rv)"
  assumes reads_res_1: "spec_equiv_valid_inv s' I A P' f"
  assumes hoare: "\<lbrace>P''\<rbrace> f \<lbrace>Q\<rbrace>,-"
  shows "spec_equiv_valid_inv s' I A (\<lambda>s. P' s \<and> P'' s) (f >>=E g)"
  unfolding bindE_def
  apply (rule bind_spec_ev)
    prefer 3
    apply(rule hoare[simplified validE_R_def validE_def])
   apply(simp split: sum.split add: lift_def)
   apply(rule conjI)
    apply(fastforce simp: spec_equiv_valid_def throwError_def return_ev2)
   apply(fastforce simp: reads_res_2)
  apply(rule reads_res_1)
  done

lemma if_spec_ev:
  "\<lbrakk> G \<Longrightarrow> spec_equiv_valid_inv s' I A P f;
     \<not> G \<Longrightarrow> spec_equiv_valid_inv s' I A P' f'
   \<rbrakk>  \<Longrightarrow> spec_equiv_valid_inv s' I A (\<lambda>s. (G \<longrightarrow> P s) \<and> (\<not> G \<longrightarrow> P' s)) (if G then f else f')"
  by (cases G, simp+)

lemmas splits_spec_ev[wp_split] =
  drop_spec_ev
  spec_equiv_valid_guard_imp[OF bind_spec_ev] spec_equiv_valid_guard_imp[OF bindE_spec_ev]
  bind_spec_ev bindE_spec_ev
  spec_equiv_valid_guard_imp[OF if_spec_ev] if_spec_ev

(* Miscellaneous rules. *)

lemma assertE_ev[wp]:
  "equiv_valid_inv I A \<top> (assertE b)"
  unfolding assertE_def
  apply wp
  by simp

lemma equiv_valid_2_bindE:
  assumes g: "\<And>rv rv'. R' rv rv' \<Longrightarrow>
      equiv_valid_2 D A A (E \<oplus> R) (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes h1: "\<lbrace>S\<rbrace> f \<lbrace>Q\<rbrace>,-"
  assumes h2: "\<lbrace>S'\<rbrace> f' \<lbrace>Q'\<rbrace>,-"
  assumes f: "equiv_valid_2 D A A (E \<oplus> R') P P' f f'"
  shows "equiv_valid_2 D A A (E \<oplus> R) (P and S) (P' and S') (f >>=E g) (f' >>=E g')"
  apply(unfold bindE_def)
  apply(rule equiv_valid_2_guard_imp)
    apply(rule_tac R'="E \<oplus> R'" and Q="case_sum \<top>\<top> Q" and Q'="case_sum \<top>\<top> Q'" and S=S and S'=S' in equiv_valid_2_bind)
       apply(clarsimp simp: lift_def split: sum.splits)
       apply(intro impI conjI allI)
          apply(simp add: throwError_def)
          apply(rule return_ev2)
          apply simp
         apply(simp)
        apply(simp)
       apply(fastforce intro: g)
      apply(rule f)
     apply(insert h1, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
    apply(insert h2, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
   by auto

lemma rel_sum_comb_equals:
  "((=) \<oplus> (=)) = (=)"
  apply(rule ext)
  apply(rule ext)
  apply(rename_tac a b)
  apply(case_tac a, auto)
  done

definition spec_equiv_valid_2_inv where
  "spec_equiv_valid_2_inv s I A R P P' f f' \<equiv>
      equiv_valid_2 I A A R (P and ((=) s)) P' f f'"

lemma spec_equiv_valid_def2:
  "spec_equiv_valid s I A A P f =
   spec_equiv_valid_2_inv s I A (=) P P f f"
  apply(simp add: spec_equiv_valid_def spec_equiv_valid_2_inv_def)
  done

lemma drop_spec_ev2_inv:
  "equiv_valid_2 I A A R P P' f f' \<Longrightarrow>
   spec_equiv_valid_2_inv s I A R P P' f f'"
  apply(simp add: spec_equiv_valid_2_inv_def)
  apply(erule equiv_valid_2_guard_imp, auto)
  done

lemma spec_equiv_valid_2_inv_guard_imp:
  "\<lbrakk>spec_equiv_valid_2_inv s I A R Q Q' f f'; \<And> s. P s \<Longrightarrow> Q s; \<And> s. P' s \<Longrightarrow> Q' s\<rbrakk> \<Longrightarrow>
    spec_equiv_valid_2_inv s I A R P P' f f'"
  by(auto simp: spec_equiv_valid_2_inv_def equiv_valid_2_def)

lemma bind_spec_ev2:
  assumes reads_res_2: "\<And> rv s' rv'. \<lbrakk>(rv, s') \<in> fst (f s); R' rv rv'\<rbrakk> \<Longrightarrow> spec_equiv_valid_2_inv s' I A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes reads_res_1: "spec_equiv_valid_2_inv s I A R' P P' f f'"
  assumes hoare: "\<lbrace>S\<rbrace> f \<lbrace>Q\<rbrace>"
  assumes hoare': "\<lbrace>S'\<rbrace> f' \<lbrace>Q'\<rbrace>"
  shows "spec_equiv_valid_2_inv s I A R (P and S) (P' and S') (f >>= g) (f' >>= g')"
  using reads_res_1
  apply (clarsimp simp: spec_equiv_valid_2_inv_def equiv_valid_2_def bind_def split_def)
  apply (erule_tac x=t in allE)
  apply clarsimp
  apply (drule_tac x="(a, b)" in bspec, assumption)
  apply (drule_tac x="(ab, bb)" in bspec, assumption)
  apply clarsimp
  apply (cut_tac rv="a" and s'="b" in reads_res_2)
    apply assumption
   apply assumption
  apply (clarsimp simp: spec_equiv_valid_2_inv_def equiv_valid_2_def)
  apply(drule_tac x=bb in spec)
  apply clarsimp
  using hoare hoare'
  apply (fastforce simp: valid_def)+
  done

lemma spec_equiv_valid_2_inv_bindE:
  assumes g: "\<And>rv s' rv'. \<lbrakk>(Inr rv, s') \<in> fst (f s); R' rv rv'\<rbrakk> \<Longrightarrow>
      spec_equiv_valid_2_inv s' I A (E \<oplus> R) (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes h1: "\<lbrace>S\<rbrace> f \<lbrace>Q\<rbrace>,-"
  assumes h2: "\<lbrace>S'\<rbrace> f' \<lbrace>Q'\<rbrace>,-"
  assumes f: "spec_equiv_valid_2_inv s I A (E \<oplus> R') P P' f f'"
  shows "spec_equiv_valid_2_inv s I A (E \<oplus> R) (P and S) (P' and S') (f >>=E g) (f' >>=E g')"
  apply(unfold bindE_def)
  apply(rule spec_equiv_valid_2_inv_guard_imp)
    apply(rule_tac R'="E \<oplus> R'" and Q="case_sum \<top>\<top> Q" and Q'="case_sum \<top>\<top> Q'" and S=S and S'=S' in bind_spec_ev2)
       apply(clarsimp simp: lift_def split: sum.splits)
       apply(intro impI conjI allI)
          apply(simp add: throwError_def)
          apply(rule drop_spec_ev2_inv[OF return_ev2])
          apply simp
         apply(simp)
        apply(simp)
       apply(fastforce intro: g)
      apply(rule f)
     apply(insert h1, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
    apply(insert h2, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
   by auto

lemma trancl_subset_equivalence:
  "\<lbrakk>(a, b) \<in> r'\<^sup>+; \<forall>x. (a, x)\<in>r'\<^sup>+ \<longrightarrow> Q x; \<forall>x y. Q x \<longrightarrow> ((y, x) \<in> r) = ((y, x) \<in> r')\<rbrakk> \<Longrightarrow> (a, b) \<in> r\<^sup>+"
  apply(induct a b rule: trancl.induct)
   apply(blast)
  apply(simp)
  apply(rule_tac b=b in trancl_into_trancl)
   apply(simp)
  apply(erule_tac x=c in allE)
  apply(subgoal_tac "(a, c) \<in> r'\<^sup>+")
   apply(auto)
   done

lemma equiv_valid_rv_gets_compD:
  "equiv_valid_rv_inv I A R P (gets (f \<circ> g)) \<Longrightarrow>
   equiv_valid_rv_inv I A (\<lambda> rv rv'. R (f rv) (f rv')) P (gets g)"
  apply(clarsimp simp: equiv_valid_2_def gets_def bind_def return_def get_def)
  done

lemma liftE_ev2:
  "equiv_valid_2 I A B R P P' f f' \<Longrightarrow>
   equiv_valid_2 I A B (E \<oplus> R) P P' (liftE f) (liftE f')"
  apply(clarsimp simp: liftE_def equiv_valid_2_def bind_def return_def)
  apply fastforce
  done

lemma whenE_spec_ev2_inv:
  assumes a: "b \<Longrightarrow> spec_equiv_valid_2_inv s I A R P P' m m'"
  assumes r: "\<And> x. R x x"
  shows "spec_equiv_valid_2_inv s I A R P P' (whenE b m) (whenE b m')"
  unfolding whenE_def
  apply (auto intro: a simp: returnOk_def intro!: drop_spec_ev2_inv[OF return_ev2] intro: r)
  done

lemma whenE_spec_ev:
  assumes a: "b \<Longrightarrow> spec_equiv_valid_inv s I A P m"
  shows "spec_equiv_valid_inv s I A P  (whenE b m) "
  unfolding whenE_def
  apply (auto intro: a simp: returnOk_def intro!: drop_spec_ev[OF return_ev_pre])
  done

lemma spec_equiv_valid_2_inv_by_spec_equiv_valid:
  "\<lbrakk>spec_equiv_valid s I A A P f; P' = P; f' = f;
    (\<And> a. R a a)\<rbrakk> \<Longrightarrow>
       spec_equiv_valid_2_inv s I A R P P' f f'"
  apply(clarsimp simp: spec_equiv_valid_def spec_equiv_valid_2_inv_def)
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma mapM_ev'':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (P x) (m x)"
  assumes inv: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> \<lambda>s. \<forall>x\<in>set lst. P x s \<rbrace> m x \<lbrace> \<lambda>_ s. \<forall>x\<in>set lst. P x s \<rbrace>"
  shows "equiv_valid_inv D A (\<lambda> s. \<forall>x\<in>set lst. P x s) (mapM m lst)"
  apply(rule mapM_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res]; simp)
  apply(wpsimp wp: inv)
  done

lemma mapM_x_ev'':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (P x) (m x)"
  assumes inv: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> \<lambda>s. \<forall>x\<in>set lst. P x s \<rbrace> m x \<lbrace> \<lambda>_ s. \<forall>x\<in>set lst. P x s \<rbrace>"
  shows "equiv_valid_inv D A (\<lambda> s. \<forall>x\<in>set lst. P x s) (mapM_x m lst)"
  apply(rule mapM_x_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res]; simp)
  apply(wpsimp wp: inv)
  done

lemma catch_ev[wp]:
  assumes ok:
    "equiv_valid I A A P f"
  assumes err:
    "\<And> e. equiv_valid I A A (E e) (handler e)"
  assumes hoare:
    "\<lbrace> Q \<rbrace> f -, \<lbrace> E \<rbrace>"
  shows
    "equiv_valid I A A (P and Q) (f <catch> handler)"
  apply (simp add: catch_def)
  apply (wp err ok | wpc | simp)+
   apply (insert hoare[simplified validE_E_def validE_def])[1]
   apply (simp split: sum.splits)
  by simp

lemma equiv_valid_rv_trivial:
  assumes inv: "\<And> P. \<lbrace> P \<rbrace> f \<lbrace> \<lambda>_. P \<rbrace>"
  shows "equiv_valid_rv_inv I A \<top>\<top> \<top> f"
  by(auto simp: equiv_valid_2_def dest: state_unchanged[OF inv])

lemma equiv_valid_2_trivial:
  assumes inv: "\<And> P. \<lbrace> P \<rbrace> f \<lbrace> \<lambda>_. P \<rbrace>"
  assumes inv': "\<And> P. \<lbrace> P \<rbrace> f' \<lbrace> \<lambda>_. P \<rbrace>"
  shows "equiv_valid_2 I A A \<top>\<top> \<top> \<top> f f'"
  by(auto simp: equiv_valid_2_def dest: state_unchanged[OF inv] state_unchanged[OF inv'])

lemma gen_asm_ev2_r:
  "\<lbrakk>P' \<Longrightarrow> equiv_valid_2 I A B R P Q f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R P  (Q and (K P')) f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma gen_asm_ev2_l:
  "\<lbrakk>P \<Longrightarrow> equiv_valid_2 I A B R Q P' f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R (Q and (K P)) P' f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma gen_asm_ev2_r':
  "\<lbrakk>P' \<Longrightarrow> equiv_valid_2 I A B R P \<top> f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R P (\<lambda>s. P') f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma gen_asm_ev2_l':
  "\<lbrakk>P \<Longrightarrow> equiv_valid_2 I A B R \<top> P' f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R (\<lambda>s. P) P' f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma equiv_valid_rv_liftE_bindE:
  assumes ev1:
  "equiv_valid_rv_inv I A W P f"
  assumes ev2:
  "\<And> rv rv'. W rv rv' \<Longrightarrow> equiv_valid_2 I A A R (Q rv) (Q rv') (g rv) (g rv')"
  assumes hoare:
  "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_rv_inv I A R P ((liftE f) >>=E g)"
  apply(unfold bindE_def)
  apply(rule_tac Q="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q v s)" in equiv_valid_rv_bind)
    apply(rule_tac E="dc" in equiv_valid_2_liftE)
    apply(rule ev1)
   apply(clarsimp simp: lift_def split: sum.split)
   apply(insert ev2, fastforce simp: equiv_valid_2_def)[1]
  apply(insert hoare, clarsimp simp: valid_def liftE_def bind_def return_def split_def)
  done

lemma if_evrv:
  assumes "b \<Longrightarrow> equiv_valid_rv_inv I A R P f"
  assumes "\<not> b \<Longrightarrow> equiv_valid_rv_inv I A R Q g"
  shows "equiv_valid_rv_inv I A R (\<lambda>s. (b \<longrightarrow> P s) \<and> (\<not>b \<longrightarrow> Q s)) (if b then f else g)"
  apply (clarsimp split: if_split)
  using assms by blast

end


theory SINVAR_TaintingTrusted_impl
imports SINVAR_TaintingTrusted "../TopoS_Interface_impl"
begin

subsubsection \<open>SecurityInvariant Tainting with Trust List Implementation\<close>

code_identifier code_module SINVAR_Tainting_impl => (Scala) SINVAR_Tainting

(*could we use those to make code more efficient?*)
lemma "A - B \<subseteq> C \<longleftrightarrow> (\<forall>a\<in>A. a \<in> C \<or> a \<in> B)" by blast
lemma "\<not>(A - B \<subseteq> C) \<longleftrightarrow> (\<exists>a \<in> A. a \<notin> C \<and> a \<notin> B)" by blast

fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> SINVAR_TaintingTrusted.taints) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (v1,v2) \<in> set (edgesL G). taints (nP v1) - untaints (nP v1) \<subseteq> taints (nP v2))"

(*Test that we have executable code, despite the abstractions*)
export_code sinvar checking SML
value[code] "sinvar \<lparr> nodesL = [], edgesL =[] \<rparr> (\<lambda>_. SINVAR_TaintingTrusted.default_node_properties)"
lemma "sinvar \<lparr> nodesL = [], edgesL =[] \<rparr> (\<lambda>_. SINVAR_TaintingTrusted.default_node_properties)" by eval

definition TaintingTrusted_offending_list
  :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> SINVAR_TaintingTrusted.taints) \<Rightarrow> ('v \<times> 'v) list list" where
  "TaintingTrusted_offending_list G nP = (if sinvar G nP then
    []
   else
    [ [e \<leftarrow> edgesL G. case e of (v1,v2) \<Rightarrow> \<not>(taints (nP v1) - untaints (nP v1) \<subseteq> taints (nP v2))] ])"

(*TODO: is this code somewhat efficient?*)
export_code TaintingTrusted_offending_list checking SML

definition "NetModel_node_props P =
  (\<lambda> i. (case (node_properties P) i of
                  Some property \<Rightarrow> property
                | None \<Rightarrow> SINVAR_TaintingTrusted.default_node_properties))"

definition "TaintingTrusted_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_TaintingTrusted.default_node_properties P))"

interpretation TaintingTrusted_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_TaintingTrusted.default_node_properties
  and sinvar_spec=SINVAR_TaintingTrusted.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_TaintingTrusted.receiver_violation
  and offending_flows_impl=TaintingTrusted_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=TaintingTrusted_eval
  apply(unfold TopoS_List_Impl_def)
  apply(rule conjI)
   apply(simp add: TopoS_TaintingTrusted)
   apply(simp add: list_graph_to_graph_def SINVAR_TaintingTrusted.sinvar_def; fail)
  apply(rule conjI)
   apply(simp add: list_graph_to_graph_def)
   apply(simp add: list_graph_to_graph_def SINVAR_TaintingTrusted.sinvar_def Taints_offending_set
                    SINVAR_TaintingTrusted.Taints_offending_set_def TaintingTrusted_offending_list_def; fail)
  apply(rule conjI)
   apply(simp only: NetModel_node_props_def)
   (*interpretation is in local context*)
   apply (metis SecurityInvariant.node_props.simps SecurityInvariant.node_props_eq_node_props_formaldef TopoS_TaintingTrusted)
  apply(simp only: TaintingTrusted_eval_def)
  apply(simp add: TopoS_eval_impl_proofrule[OF TopoS_TaintingTrusted])
  apply(simp add: list_graph_to_graph_def SINVAR_TaintingTrusted.sinvar_def; fail)
 done

subsubsection \<open>TaintingTrusted packing\<close>
  definition SINVAR_LIB_TaintingTrusted :: "('v::vertex, SINVAR_TaintingTrusted.taints) TopoS_packed" where
    "SINVAR_LIB_TaintingTrusted \<equiv>
    \<lparr> nm_name = ''TaintingTrusted'',
      nm_receiver_violation = SINVAR_TaintingTrusted.receiver_violation,
      nm_default = SINVAR_TaintingTrusted.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = TaintingTrusted_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = TaintingTrusted_eval
      \<rparr>"
  interpretation SINVAR_LIB_BLPbasic_interpretation: TopoS_modelLibrary SINVAR_LIB_TaintingTrusted
      SINVAR_TaintingTrusted.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_TaintingTrusted_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

subsubsection\<open>Example\<close>
context
begin
  private definition tainting_example :: "string list_graph" where
  "tainting_example \<equiv> \<lparr> nodesL = [''produce 1'',
                                  ''produce 2'',
                                  ''produce 3'',
                                  ''read 1 2'',
                                  ''read 3'',
                                  ''consume 1 2 3'',
                                  ''consume 3''],
              edgesL =[(''produce 1'', ''read 1 2''),
                       (''produce 2'', ''read 1 2''),
                       (''produce 3'', ''read 3''),
                       (''read 3'', ''read 1 2''),
                       (''read 1 2'', ''consume 1 2 3''),
                       (''read 3'', ''consume 3'')] \<rparr>"
  lemma "wf_list_graph tainting_example" by eval

  private definition tainting_example_props :: "string \<Rightarrow> SINVAR_TaintingTrusted.taints" where
    "tainting_example_props \<equiv> (\<lambda> n. SINVAR_TaintingTrusted.default_node_properties)
                          (''produce 1'' := TaintsUntaints {''1''} {},
                           ''produce 2'' := TaintsUntaints {''2''} {},
                           ''produce 3'' := TaintsUntaints {''3''} {},
                           ''read 1 2'' := TaintsUntaints {''3'',''foo''} {''1'',''2''},
                           ''read 3'' := TaintsUntaints {''3''} {},
                           ''consume 1 2 3'' := TaintsUntaints {''foo'',''3''} {},
                           ''consume 3'' := TaintsUntaints {''3''} {})"

  value "tainting_example_props (''consume 1 2 3'')"
  value[code] "TaintingTrusted_offending_list tainting_example tainting_example_props"
  private lemma "sinvar tainting_example tainting_example_props" by eval
end

(*TODO: fails. why?*)
export_code SINVAR_LIB_TaintingTrusted checking Scala
export_code SINVAR_LIB_TaintingTrusted checking SML

hide_const (open) NetModel_node_props TaintingTrusted_offending_list TaintingTrusted_eval

hide_const (open) sinvar

end


theory Simpl_Anno imports Simpl.Vcg begin

definition "named_loop name = UNIV"

lemma annotate_named_loop_inv:
  "whileAnno b (named_loop name) V c = whileAnno b I V c"
  by (simp add: whileAnno_def)

lemma annotate_named_loop_inv_fix:
  "whileAnno b (named_loop name) V c = whileAnnoFix b I (\<lambda>_. V) (\<lambda>_. c)"
  by (simp add: whileAnno_def whileAnnoFix_def)

lemma annotate_named_loop_var:
  "whileAnno b (named_loop name) V' c = whileAnno b I V c"
  by (simp add: whileAnno_def)

lemma annotate_named_loop_var_fix:
  "whileAnno b (named_loop name) V' c = whileAnnoFix b I (\<lambda>_. V) (\<lambda>_. c)"
  by (simp add: whileAnno_def whileAnnoFix_def)

end