\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Counter-Example for Theorem 3\<close>
theory Effectively_Acyclic_Maintain_Counter_Example
  imports Effectively_Acyclic "HOL-Library.Multiset"
begin

paragraph \<open>Summary\<close>
text \<open>This theory provides a counter-example for theorem 3 in @{cite krishna20}\<close>

text \<open>We use flow graphs h = h1 + h2 and h' = h1' + h2.\<close>

text \<open>We introduce the following hack to obtain a pos_cancel_comm_monoid_add multiset.
  Regarding @{term "x \<subseteq># y"} it is, however it is not regarding @{term "x \<le> y"} of multisets.
  I have no clue how to use the first variant with my existing formalization. I think I have
  to include the endomorphism stuff in context pos_cancel_comm_monoid_add. Unfortunately,
  it uses extensively Function Algebras that seem to not be applicable in this context as
  it constrains the type class of its type parameter and our context does not provide this
  information for its type parameter.\<close>

instance multiset :: (preorder) pos_cancel_comm_monoid_add
  sorry

lemma aux':
  fixes m :: "nat multiset"
  shows "m \<le> {#2#} \<Longrightarrow> m = {#} \<or> m = {#2#}"
  sorry (* related to our type-class issue, next lemma shows that this works for
            the intended less-relation... *)

lemma aux'':
  fixes m :: "nat multiset"
  shows "m \<subseteq># {#2#} \<Longrightarrow> m = {#} \<or> m = {#2#}"
  using multi_nonempty_split by auto

text \<open>Edge function\<close>

fun f' :: "nat set \<Rightarrow> nat multiset \<Rightarrow> nat multiset" where
"f' R X = {# x + 1 | x \<in># X . x \<notin> R #}"

text \<open>Inflows {inf of h, inf1 of h1, inf2 of h2\<close>

fun inf :: "nat \<Rightarrow> nat multiset" where
"inf 0 = {# 0 #}" |
"inf _ = {#}"

fun inf1 :: "nat \<Rightarrow> nat multiset" where
"inf1 0 = {# 0 #}" |
"inf1 k = (if k = 2 then {#2#} else {#})"

fun inf2 :: "nat \<Rightarrow> nat multiset" where
"inf2 k = (if k = 1 then {#1#} else {#})"

text \<open>Flows flow of h, flow' of h'\<close>

fun flow :: "nat \<Rightarrow> nat multiset" where
"flow k = {# k #}"

fun flow' :: "nat \<Rightarrow> nat multiset" where
"flow' x = (if x = 0 then {# 0, 3 #} else {# x #})"

text \<open>Edges edges of h, edges' of h'\<close>

fun edges :: "nat \<Rightarrow> nat \<Rightarrow> nat multiset \<Rightarrow> nat multiset" where
"edges x y = (
    if x = 0 \<and> y = 1 then f' {3} else
    if x = 1 \<and> y = 2 then f' {2} else
    if x = 2 \<and> y = 0 then f' {2} else
    (\<lambda>_. 0)
  )"

fun edges' :: "nat \<Rightarrow> nat \<Rightarrow> nat multiset \<Rightarrow> nat multiset" where
"edges' x y = (
    if x = 0 \<and> y = 1 then f' {3} else
    if x = 1 \<and> y = 2 then f' {2} else
    if x = 2 \<and> y = 0 then f' {} else
    (\<lambda>_. 0)
  )"

text \<open>Define flow graphs using the above raw definitions\<close>

abbreviation "h \<equiv> fg {0,1,2} edges flow"
abbreviation "h' \<equiv> fg {0,1,2} edges' flow'"
abbreviation "h1 \<equiv> fg {0,2} edges flow"
abbreviation "h1' \<equiv> fg {0,2} edges' flow'"
abbreviation "h2 \<equiv> fg {1} edges flow :: (nat, nat multiset) fg"

text \<open>Prove for each of the defined flow graphs that the supposed inflow and flow actually solve
the flow equation.\<close>

lemma flow_exists: "flow_eq (fg {0,1,2} edges flow) inf"
  by (rule flow_eqI, auto simp: numeral_2_eq_2)

lemma flow_exists': "flow_eq (fg {0,1,2} edges' flow') inf"
  by (rule flow_eqI, auto simp: numeral_2_eq_2)

lemma flow_exists1: "flow_eq (fg {0,2} edges flow) inf1"
  by (rule flow_eqI, auto simp: numeral_2_eq_2)

lemma flow_exists1': "flow_eq (fg {0,2} edges' flow') inf1"
  by (rule flow_eqI, auto simp: numeral_2_eq_2)

lemma flow_exists2: "flow_eq (fg {1} edges flow) inf2"
  by (rule flow_eqI, auto simp: numeral_2_eq_2)

text \<open>Prove that each of the defined flow graphs is a valid flow graph (kind of redundant
considering the proofs for the flow equations...)\<close>

lemma fg_exists: "h \<noteq> bot"
  using fgI2[OF flow_exists] by auto

lemma fg_exists': "h' \<noteq> bot"
  using fgI2[OF flow_exists'] by auto

lemma fg_exists1: "h1 \<noteq> bot"
  using fgI2[OF flow_exists1] by auto

lemma fg_exists1': "h1' \<noteq> bot"
  using fgI2[OF flow_exists1'] by auto

lemma fg_exists2: "h2 \<noteq> bot"
  using fgI2[OF flow_exists2] by auto

text \<open>Prove that the indeed h = h1 + h2 and h' = h1' + h2 (as supposed to)\<close>

lemma fg_sum_eq: "h1 + h2 = h"
  by (rule plus_fg_fg'[OF fg_exists1 fg_exists2], auto)

lemma fg_sum_eq': "h1' + h2 = h'"
  by (rule plus_fg_fg'[OF fg_exists1' fg_exists2], auto)

text \<open>Prove that h1' extends h1 subflow-preservingly\<close>

lemma aux:
  "m \<le> {# 2 #} \<Longrightarrow> {#x \<in># fold_mset (add_mset \<circ> Suc) {#} {#x \<in># m. x \<noteq> 2#}. x \<noteq> 3#} = {#x \<in># fold_mset (add_mset \<circ> Suc) {#} m. x \<noteq> 3#}"
  apply (rule multiset_eqI)
  using aux'[of m] apply auto
  by (metis (mono_tags, lifting) comp_def comp_fun_commute.fold_mset_single comp_fun_commute_mset_image count_single eval_nat_numeral(3))

lemma ctx: "h1 \<lesssim>\<^sub>S h1'"
  using fg_exists1 fg_exists1' inf_fg_int_fg[of h1] inf_fg_int_fg[of h1']
        inf_fg_fg''[OF flow_exists1] inf_fg_fg''[OF flow_exists1'] outf_fg_unfold'[OF fg_exists1]
        outf_fg_unfold'[OF fg_exists1'] aux
  unfolding subflow_preserving_extension_def contextual_extension_def
  apply clarsimp
  unfolding image_mset_def
  by (smt aux' filter_empty_mset filter_mset_add_mset fold_mset_empty inf1.simps(2) numeral_2_eq_2)

text \<open>Define the set E of allowed edge functions by introducing the
closure over all f' and id and 0\<close>

inductive_set E :: "(nat multiset \<Rightarrow> nat multiset) set" where
id[intro]: "id \<in> E" |
zero[intro]: "(\<lambda>_. {#}) \<in> E" |
base[intro]: "finite R \<Longrightarrow> f' R \<in> E" |
plus[intro]: "f1 \<in> E \<Longrightarrow> f2 \<in> E \<Longrightarrow> f1 + f2 \<in> E" |
comp[intro]: "f1 \<in> E \<Longrightarrow> f2 \<in> E \<Longrightarrow> f1 o f2 \<in> E"

text \<open>We have to prove that E is a closed set of endomorphisms:\<close>

lemma endo_E': "e \<in> E \<Longrightarrow> e \<in> End"
  by (induction rule: E.induct, auto simp: endo_def)

lemma endo_E: "E \<subseteq> End"
  using endo_E' by auto

lemma End_closed_E: "End_closed E"
  unfolding End_closed_def
  using endo_E' by auto

text \<open>We have to prove that E is a reduced set of functions.\<close>

text \<open>For some reason we introduce an abbreviation for reduced functions.\<close>
abbreviation "reduced' e \<equiv> (\<exists>x. e x \<noteq> 0) \<longrightarrow> (\<exists>x. e (e x) \<noteq> 0)"

text \<open>All f' are reduced\<close>
lemma reduced_f':
  shows "finite R \<Longrightarrow> reduced' ((f' :: nat set \<Rightarrow> nat multiset \<Rightarrow> nat multiset) R)"
proof
  assume A: "finite R" "\<exists>x. f' R x \<noteq> {#}"
  show "\<exists>x. f' R (f' R x) \<noteq> {#}"
  proof (cases "R = {}")
    case True
    then have "f' R (f' R {#(0 :: nat)#}) = {#2#}"
      by simp
    then show ?thesis
      by (metis add_mset_not_empty)
  next
    case False
    then have "Max R \<in> R"
      using A by simp
    then have *: "(Max R) + 1 \<notin> R"
      by (metis A(1) Max_ge add.right_neutral add_le_cancel_left not_one_le_zero)
    then have **: "(Max R) + 2 \<notin> R"
      by (metis A(1) Max_ge add.comm_neutral add_le_cancel_left eq_numeral_Suc linorder_not_le zero_less_Suc)

    have "f' R (f' R {#(Max R) + 1#}) = {#(Max R) + 3#}"
      using * ** by simp
    then show ?thesis
      by (metis empty_not_add_mset)
  qed
qed

text \<open>Sums of functions from E are reduced.\<close>
lemma reduced_E_plus:
  assumes "f1 \<in> E" "f2 \<in> E" "reduced' f1" "reduced' f2" "\<forall>x. (f1 + f2) ((f1 + f2) x) = {#}"
  shows "\<forall>x. (f1 + f2) x = {#}"
proof -
  have "\<forall>x. f1 (f1 x) = {#} \<and> f2 (f2 x) = {#}"
  proof
    fix x
    have "{#} = (f1 + f2) ((f1 + f2) x)"
      using assms by simp
    also have "... = f1 ((f1 + f2) x) + f2 ((f1 + f2) x)"
      by simp
    also have "... = f1 (f1 x) + f1 (f2 x) + f2 (f1 x) + f2 (f2 x)"
      using assms endo_E' unfolding endo_def by simp
    finally show "f1 (f1 x) = {#} \<and> f2 (f2 x) = {#}"
      by auto
  qed
  then have "\<forall>x. f1 x = {#}" "\<forall>x. f2 x = {#}"
    using assms by auto
  then  show "\<forall>x. (f1 + f2) x = {#}"
    by auto
qed

text \<open>Some auxiliary development\<close>
lemma E_mono:
  assumes "e \<in> E" "x \<subseteq># x'"
  shows "e x \<subseteq># e x'"
  using assms
  by (induction arbitrary: x x', auto simp: image_mset_subseteq_mono multiset_filter_mono mset_subset_eq_mono_add)

text \<open>Some auxiliary development\<close>
lemma E_not_zero: "e \<in> E \<Longrightarrow> e \<noteq> 0 \<Longrightarrow> \<exists>x. x \<noteq> 0 \<and> (\<forall>x' \<ge> x. \<exists>y \<ge> x'. y \<in># e {#x'#})"
proof (induction rule: E.induct)
case id
  then show ?case by auto
next
  case zero
  then show ?case by simp
next
  case (base R)
  then show ?case
  proof (cases "R = {}")
    case True
    show ?thesis
      by (rule exI[where x="1"], auto simp: True)
  next
    case False
    then have "Max R \<in> R"
      using base by simp
    then have *: "\<forall>x' > Max R. x' \<notin> R"
      using base False Max_less_iff by auto
    show ?thesis
      apply (rule exI[where x="Max R + 1"], simp)
      using "*" Suc_le_lessD by blast
  qed
next
  case (plus f1 f2)
  then have "f1 \<noteq> 0 \<or> f2 \<noteq> 0"
    by auto
  then consider (a) "f1 \<noteq> 0" | (b) "f2 \<noteq> 0" by blast
  then show ?case
  proof cases
    case a
    then obtain x where "x \<noteq> 0" "\<forall>x'\<ge>x. \<exists>y\<ge>x'. y \<in># f1 {#x'#}" using plus by blast
    then show ?thesis
      apply (cases "f2 = 0", auto)
      by (rule exI[where x="x"], auto)
  next
    case b
    then obtain x where "x \<noteq> 0" "\<forall>x'\<ge>x. \<exists>y\<ge>x'. y \<in># f2 {#x'#}" using plus by blast
    then show ?thesis
      apply (cases "f1 = 0", auto)
      by (rule exI[where x="x"], auto)
  qed
next
  case (comp f1 f2)
  then have "f1 \<noteq> 0" by auto
  moreover have "f2 \<noteq> 0"
    using comp
    by (meson End_closed_End endo_E' endo_f_0_0_closed_comp)
  ultimately obtain x1 x2 where *: "x1 \<noteq> 0" "\<forall>x'\<ge>x1. \<exists>y\<ge>x'. y \<in># f1 {#x'#}"
    "x2 \<noteq> 0" "\<forall>x'\<ge>x2. \<exists>y\<ge>x'. y \<in># f2 {#x'#}" using comp by blast

  let ?x = "max x1 x2"

  have bla: "\<forall>x'\<ge>max x1 x2. \<exists>y\<ge>x'. y \<in># (f1 \<circ> f2) {#x'#}"
  proof safe
    fix x'
    assume A: "max x1 x2 \<le> x'"
    then have "x' \<ge> x2" by simp
    then obtain y where Y: "y \<ge> x'" "y \<in># f2 {#x'#}" using * by blast
    then have X: "{#y#} \<subseteq># f2 {#x'#}" by simp
    have X2: "f1 {#y#} \<subseteq># f1 (f2 {#x'#})" by (fact E_mono[OF comp(1) X])

    have AA: "y \<ge> x1" using A Y by simp
    then obtain y2 where ZZ: "y2 \<ge> y" "y2 \<in># f1 {#y#}" using * by blast
    then have Z: "y2 \<in># f1 (f2 {#x'#})" using X2 mset_subset_eqD by metis
    show "\<exists>y\<ge>x'. y \<in># (f1 \<circ> f2) {#x'#}"
      apply (rule exI[where x="y2"])
      using Z ZZ Y by auto
  qed

  show ?case
    apply (rule exI[where x="?x"])
    using * bla by auto
qed

text \<open>Compositions of functions in E are reduced\<close>
lemma reduced_E_comp:
  assumes "f1 \<in> E" "f2 \<in> E" "reduced' f1" "reduced' f2" "\<exists>x. (f1 o f2) x \<noteq> 0"
  shows "\<exists>x. (f1 o f2) ((f1 o f2) x) \<noteq> {#}"
proof -
  obtain x where *: "f1 (f2 x) \<noteq> 0"
    using assms by auto
  then have A1: "f1 \<noteq> 0" by auto
  have A2: "f2 \<noteq> 0" using End_closed_E assms by auto

  obtain x1 x2 where *: "x2 \<noteq> 0" "x2 \<noteq> 0" "\<forall>x' \<ge> x1. \<exists>y \<ge> x'. y \<in># f1 {#x'#}" "\<forall>x' \<ge> x2. \<exists>y \<ge> x'. y \<in># f2 {#x'#}"
    using E_not_zero[OF assms(1) A1] E_not_zero[OF assms(2) A2] by auto

  let ?x = "max x1 x2"

  have *: "?x \<noteq> 0" "\<forall>x' \<ge> ?x. \<exists>y \<ge> x'. y \<in># f1 {#x'#}" "\<forall>x' \<ge> ?x. \<exists>y \<ge> x'. y \<in># f2 {#x'#}"
    using * by auto

  have "?x \<ge> ?x" by simp
  then obtain y1 where B1: "y1 \<ge> ?x" "y1 \<in># f2 {#?x#}" using * by blast
  then have B2: "{#y1#} \<subseteq># f2 {#?x#}" by simp
  then have B22: "f1 {#y1#} \<subseteq># f1 (f2 {#?x#})" using E_mono[OF assms(1) B2] by simp
  then have "y1 \<ge> ?x" using B1 by simp
  then obtain y2 where B2: "y2 \<ge> y1" "y2 \<in># f1 {#y1#}" using * by blast
  then have B22': "{#y2#} \<subseteq># f1 {#y1#}" by simp
  have B3: "{#y2#} \<subseteq># f1 (f2 {#?x#})" using subset_mset.order.trans[OF B22' B22] by simp
  then have B3': "f2 {#y2#} \<subseteq># f2 (f1 (f2 {#?x#}))" using E_mono[OF assms(2) B3]
    unfolding comp_def by simp
  then have "y2 \<ge> ?x" using B1 B2 order_trans by blast
  then obtain y3 where B3: "y3 \<ge> y2" "y3 \<in># f2 {#y2#}" using * by blast
  then have B7: "{#y3#} \<subseteq># f2 {#y2#}" by simp
  then have B33: "{#y3#} \<subseteq># f2 (f1 (f2 {#?x#}))" using subset_mset.order.trans[OF B7 B3'] by simp
  then have B5: "f1 {#y3#} \<subseteq># f1 (f2 (f1 (f2 {#?x#})))" using E_mono[OF assms(1) B33]
    unfolding comp_def by simp
  have "y3 \<ge> ?x" using B3(1) \<open>max x1 x2 \<le> y2\<close> order.trans by blast
  then obtain y4 where B4: "y4 \<ge> y3" "y4 \<in># f1 {#y3#}" using * by blast
  then have B6: "y4 \<in># f1 (f2 (f1 (f2 {#?x#})))" using B5 by (simp add: mset_subset_eqD)
  show ?thesis unfolding comp_def
    apply (rule exI[where x="{#?x#}"])
    using B6 by auto
qed

text \<open>All functions in E are reduced\<close>
lemma reduced_E': "e \<in> E \<Longrightarrow> \<forall>x. e (e x) = 0 \<Longrightarrow> \<forall>x. e x = 0"
  apply (induction rule: E.induct, simp, simp)
  using reduced_f' apply blast
  using reduced_E_plus apply blast
  using reduced_E_comp by blast

text \<open>Obtain the actual reduced predicate.\<close>
lemma reduced_E: "reduced E"
  using reduced_E'
  unfolding reduced_def comp_def zero_fun_def
  by metis

text \<open>Prove that all edge functions that occur in our flow graphs are allowed by E.\<close>
lemma edge_in: "\<forall>x y. edge_fg h x y \<in> E" using fg_exists by auto
lemma edge_in2: "\<forall>x y. edge_fg h2 x y \<in> E" using fg_exists2 by auto
lemma edge_in1: "\<forall>x y. edge_fg h1 x y \<in> E" using fg_exists1 by auto
lemma edge_in1': "\<forall>x y. edge_fg h1' x y \<in> E" using fg_exists1' by auto
lemma edge_in': "\<forall>x y. edge_fg h' x y \<in> E" using fg_exists' by auto

lemma k_lists_h_3_unfold':
  "k_lists {0,1,2} 3 = {
    [0,0,0], [0,0,1], [0,0,2],
    [0,1,0], [0,1,1], [0,1,2],
    [0,2,0], [0,2,1], [0,2,2],
    [1,0,0], [1,0,1], [1,0,2],
    [1,1,0], [1,1,1], [1,1,2],
    [1,2,0], [1,2,1], [1,2,2],
    [2,0,0], [2,0,1], [2,0,2],
    [2,1,0], [2,1,1], [2,1,2],
    [2,2,0], [2,2,1], [2,2,2]
}"
  unfolding k_lists_def
  apply auto
  by (smt insert_iff insert_subset length_0_conv length_Suc_conv list.set(2) numeral_3_eq_3 singletonD)

lemma k_lists_h_3_unfold:
  "k_lists {0,Suc 0, Suc (Suc 0)} 3 = {
    [0,0,0], [0,0,1], [0,0,2],
    [0,1,0], [0,1,1], [0,1,2],
    [0,2,0], [0,2,1], [0,2,2],
    [1,0,0], [1,0,1], [1,0,2],
    [1,1,0], [1,1,1], [1,1,2],
    [1,2,0], [1,2,1], [1,2,2],
    [2,0,0], [2,0,1], [2,0,2],
    [2,1,0], [2,1,1], [2,1,2],
    [2,2,0], [2,2,1], [2,2,2]
}"
  using k_lists_h_3_unfold'
  apply (subst (asm) numeral_2_eq_2)
  by simp

lemma k_lists_h1'_1_unfold: "k_lists (dom_fg h1') 1 = {[0], [2]}"
  unfolding k_lists_def
  using fg_exists1'
  apply auto
  by (metis empty_iff length_0_conv length_Suc_conv set_ConsD set_empty subset_empty subset_insert)

lemma k_lists_h_1_unfold: "k_lists (dom_fg h) 1 = {[1],[2],[0]}"
  unfolding k_lists_def
  using fg_exists
  apply auto
  by (metis empty_iff length_0_conv length_Suc_conv set_ConsD set_empty subset_empty subset_insert)

lemma k_lists_h_2_unfold: "k_lists (dom_fg h) 2 = {[0,0], [0,1], [0,2], [1,0], [1,1], [1,2], [2,0], [2,1], [2,2]}"
  unfolding k_lists_def
  using fg_exists
  apply auto
  by (smt insertE insert_subset length_0_conv length_Suc_conv list.set(2) numeral_2_eq_2 singletonD)

lemma k_lists_h1'_2_unfold: "k_lists (dom_fg h1') 2 = {[0,0], [0,2], [2,0], [2,2]}"
  unfolding k_lists_def
  using fg_exists1'
  apply auto
  by (smt insertE insert_subset length_0_conv length_Suc_conv list.set(2) numeral_2_eq_2 singletonD)

text \<open>Prove effective acyclicity of all flow graphs\<close>

lemma pigeonhole_split_list_length_le:
  assumes "length as \<ge> card N + 1" "set as \<subseteq> N" "finite N"
  shows "\<exists>x xs ys zs. as = xs @ x # ys @ x # zs \<and> length ys < card N"
  using assms
proof (induction "length as" arbitrary: as rule: nat_less_induct)
  case 1
  obtain x xs ys zs where *: "as = xs @ x # ys @ x # zs"
    using pigeonhole_split_list[of N as] 1 by auto
  then show ?case
  proof (cases "length ys < card N")
    case True
    then show ?thesis using * by blast
  next
    case False
    then have X: "\<And>m x. m < length as \<Longrightarrow> m = length x \<Longrightarrow> card N + 1 \<le> length x \<Longrightarrow> set x \<subseteq> N \<Longrightarrow>
      finite N \<Longrightarrow> (\<exists>xa xs ys zs. x = xs @ xa # ys @ xa # zs \<and> length ys < card N)"
      using 1 by blast
    from False have A: "length (x # ys) < length as" using * by simp
    moreover have B: "length (x # ys) \<ge> card N + 1" using * False 1 by simp
    moreover have C: "set (x # ys) \<subseteq> N" using 1 * by simp
    ultimately show ?thesis using * 1 X[OF A _ B C]
      by (metis append.assoc append_Cons)
  qed
qed

text \<open>Obviously I have not the slightest clue how to efficiently \<close>

lemma ea_aux:
  assumes "k \<ge> 1" "k \<le> 3" "xs \<in> k_lists (dom_fg h) k"
  shows "chain (edge_fg h) xs (hd xs) (flow_fg h (hd xs)) = {#}"
  using assms
      apply (cases "k = 0")
       apply simp
      apply (cases "k = 1")
      using k_lists_h_1_unfold fg_exists apply simp
       apply (intro conjI)
         apply (clarsimp, cases xs, simp, simp)+
      apply (cases "k = 2")
       defer
      using k_lists_h_2_unfold fg_exists apply simp
       apply (clarsimp split: if_splits simp: numeral_2_eq_2)
       apply (intro conjI)
        apply safe
          apply (cases "k = 3")
      using k_lists_h_3_unfold fg_exists apply simp
           apply (clarsimp split: if_splits nat.splits simp: numeral_2_eq_2)
           apply (cases xs)
            apply simp
           apply safe
      apply simp_all
          apply (cases "k = 3")
      using k_lists_h_3_unfold fg_exists apply simp
           apply (clarsimp split: if_splits nat.splits simp: numeral_2_eq_2)
           apply (cases xs)
            apply simp
           apply safe
      apply simp_all
          apply (cases "k = 3")
      using k_lists_h_3_unfold fg_exists apply simp
           apply (clarsimp split: if_splits nat.splits simp: numeral_2_eq_2)
           apply (cases xs)
            apply simp
           apply safe
      apply simp_all
          apply (cases "k = 3")
      using k_lists_h_3_unfold fg_exists apply simp
           apply (clarsimp split: if_splits nat.splits simp: numeral_2_eq_2)
           apply (cases xs)
            apply simp
           apply safe
      apply simp_all
      using k_lists_h_2_unfold fg_exists apply simp
       apply (clarsimp split: if_splits simp: numeral_2_eq_2)
       apply (intro conjI)
        apply safe
      by simp_all

lemma ea_aux1':
  assumes "k \<ge> 1" "k \<le> 2" "xs \<in> k_lists (dom_fg h1') k"
  shows "chain (edge_fg h1') xs (hd xs) (flow_fg h1' (hd xs)) = {#}"
  using assms
      apply (cases "k = 0")
       apply simp
      apply (cases "k = 1")
      using k_lists_h1'_1_unfold fg_exists1' apply simp
       apply (intro conjI)
         apply (clarsimp, cases xs, simp, simp)+
      apply (cases "k = 2")
       defer
      apply linarith
      using k_lists_h1'_2_unfold fg_exists1' apply simp
       apply (clarsimp split: if_splits simp: numeral_2_eq_2)
       apply (intro conjI)
        apply safe
      by simp_all

lemma chainE:
  assumes "chain f xs y z = a" "f = g on set xs"
  shows "chain g xs y z = a"
  using assms
  apply (induction xs rule: induct_list012, auto)
  by (smt chain_cong set_ConsD)

lemma ea1': "eff_acyclic' h1'"
  unfolding eff_acyclic'_def eff_acyclic_def
proof (safe, goal_cases)
  case (1 k ns)
  then show ?case
  proof (cases "k \<ge> 3")
    case True
    then obtain n ns1 ns2 ns3 where ns: "ns = ns1 @ n # ns2 @ n # ns3" "length ns2 < card (dom_fg h1')"
      using pigeonhole_split_list_length_le[of "dom_fg h1'" ns] 1 fg_exists1' unfolding k_lists_def by auto
    then have "chain edges' (n # ns2) n (flow_fg h1' n) = 0"
      using ea_aux1'[of "length (n # ns2)" "n # ns2"] fg_exists1' True 1
        fg_exists' fg_sum_eq' chain_cong'[OF edge_fg_plus_fg_on1[of h1' h2], symmetric]
      apply (auto split: if_splits simp: numeral_2_eq_2 k_lists_def)
      by (erule chainE, auto)+
    then have "chain edges' (n # ns3) (hd ns) (chain edges' (n # ns2) n (flow_fg h1' n)) = {#}"
      apply simp
      apply (rule endo_f_0_0_closed[of "chain _ _ _", where E=E])
       apply (rule endo_chain_closed)
         apply auto
      using End_closed_E by blast+
    then have "chain edges' (n # ns2 @ n # ns3) (hd ns) (flow_fg h1' n) = {#}"
      using chain_append'[where xs="n#ns2"]
      by (smt append_Cons list.discI list.sel(1))
    then have **: "chain (edge_fg h1') (n # ns2 @ n # ns3) (hd ns) (flow_fg h1' n) = {#}"
      apply (subst (asm) chain_cong'[where g="edge_fg h1'" and N="{0,2}"], simp add: fg_exists1')
       apply (metis "1"(2) dom_fg_fg fg_exists1' k_lists_dom le_sup_iff ns(1) set_append)
      by simp
    have *: "hd (ns1 @ [n]) = hd ns" using ns by (simp add: hd_append)
    have "chain (edge_fg h1') (ns1 @ n # ns2 @ n # ns3) (hd ns) (flow_fg h1' (hd ns)) \<le>
      chain (edge_fg h1') (n # ns2 @ n # ns3) (hd ns) (flow_fg h1' n)"
      apply (subst chain_append_nonempty[where xs="ns1"], simp)
      apply (rule order_trans)
       apply (rule pos_endo_mono'_closed[where f="chain _ _ _" and E=E])
      apply (subst *[symmetric])
      apply (rule chain_flow_fg_le_flow_fg[of h1' E n ns1])
               apply (simp add: fg_exists1')
              apply (simp add: End_closed_E)
      using edge_in1' apply blast
      using 1 ns unfolding k_lists_def apply (simp add: fg_exists1 fg_exists1' list.sel(1))
      using 1 ns unfolding k_lists_def apply (simp add: fg_exists1 fg_exists1' list.sel(1))
          apply (simp add: E.id)
         apply (simp add: E.zero)
        apply (simp add: E.id End_closed_E edge_in1' endo_chain_closed)
              apply (simp add: End_closed_E)
      apply simp
      done
    then show ?thesis
      using ns ** by simp
  next
    case False
    then have "k \<le> 2" by simp
    with 1 show ?thesis
      using ea_aux1' by blast
  qed
qed

lemma ea: "eff_acyclic' h"
  unfolding eff_acyclic'_def eff_acyclic_def
proof (safe, goal_cases)
  case (1 k ns)
  then show ?case
  proof (cases "k \<ge> 4")
    case True
    then obtain n ns1 ns2 ns3 where ns: "ns = ns1 @ n # ns2 @ n # ns3" "length ns2 < card (dom_fg h)"
      using pigeonhole_split_list_length_le[of "dom_fg h" ns] 1 fg_exists unfolding k_lists_def by auto
    then have "chain edges (n # ns2) n (flow_fg h n) = 0"
      using ea_aux[of "length (n # ns2)" "n # ns2"] fg_exists True 1
        fg_exists' fg_sum_eq'
      unfolding k_lists_def
      apply simp
      apply (erule chainE)
      by auto
    then have "chain edges (n # ns3) (hd ns) (chain edges (n # ns2) n (flow_fg h n)) = {#}"
      apply simp
      apply (rule endo_f_0_0_closed[of "chain _ _ _", where E=E])
       apply (rule endo_chain_closed)
         apply auto
      using End_closed_E by blast+
    then have "chain edges (n # ns2 @ n # ns3) (hd ns) (flow_fg h n) = {#}"
      using chain_append'[where xs="n#ns2"]
      by (smt append_Cons list.discI list.sel(1))
    then have **: "chain (edge_fg h) (n # ns2 @ n # ns3) (hd ns) (flow_fg h n) = {#}"
      apply (subst (asm) chain_cong'[where g="edge_fg h" and N="{0,1,2}"], simp add: fg_exists)
        apply (metis One_nat_def edge_fg_fg fg_exists insertCI)
      using ns 1 fg_exists unfolding k_lists_def by auto
    have *: "hd (ns1 @ [n]) = hd ns" using ns by (simp add: hd_append)
    have bruteforce: "fg {0, Suc 0, 2} edges flow = h"
      by simp
    have "chain (edge_fg h) (ns1 @ n # ns2 @ n # ns3) (hd ns) (flow_fg h (hd ns)) \<le>
      chain (edge_fg h) (n # ns2 @ n # ns3) (hd ns) (flow_fg h n)"
      apply (subst chain_append_nonempty[where xs="ns1"], simp)
      apply (rule order_trans)
       apply (rule pos_endo_mono'_closed[where f="chain _ _ _" and E=E])
         apply (subst *[symmetric])
      apply (subst bruteforce)+
         apply (rule chain_flow_fg_le_flow_fg[of h E n ns1])
      using fg_exists apply blast
              apply (simp add: End_closed_E)
      using edge_in apply blast
            apply (metis "1"(2) Diff_insert_absorb UnCI insertI1 k_lists_dom list.simps(15) ns(1) set_append subset_Diff_insert)
      apply (metis "1"(2) k_lists_dom le_sup_iff ns(1) set_append)
          apply (simp add: E.id)
         apply (simp add: E.zero)
      apply (metis E.id End_closed_E bruteforce edge_in endo_chain_closed)
              apply (simp add: End_closed_E)
      by simp
    then show ?thesis
      using ns ** by simp
  next
    case False
    then have "k \<le> 3" by simp
    with 1 show ?thesis
      using ea_aux by blast
  qed
qed

lemma eff_acyclic'_plus_fg1:
  fixes h h1 h2
  assumes "eff_acyclic' h" "h = h1 + h2" "h \<noteq> bot"
  shows "eff_acyclic' h1"
  using assms edge_fg_plus_fg_on1[of h1 h2] flow_fg_plus_fg_on1[of h1 h2]
  unfolding eff_acyclic'_def eff_acyclic_def k_lists_def
  apply auto
  apply (subst chain_cong'[where g="edge_fg (h1 + h2)" and N="dom_fg h1"])
    apply simp
   apply simp
  by (metis dom_fg_plus_fg_subs1 hd_in_set le_simps(3) length_greater_0_conv plus_fg_dom_un subset_eq)

lemma eff_acyclic'_plus_fg2:
  fixes h h1 h2
  assumes "eff_acyclic' h" "h = h1 + h2" "h \<noteq> bot"
  shows "eff_acyclic' h2"
  using assms eff_acyclic'_plus_fg1
  using add.commute by blast

lemma ea1: "eff_acyclic' h1" and ea2: "eff_acyclic' h2"
  using ea eff_acyclic'_plus_fg2 eff_acyclic'_plus_fg1
  by (metis fg_exists fg_sum_eq)+

text \<open>Prove that h' is not an effectively acyclic flow graph.\<close>
lemma ea': "\<not> (eff_acyclic' h')"
proof
  let ?ns = "[0,1,2]"
  let ?N = "dom_fg h'" let ?e = "edge_fg h'" let ?f = "flow_fg h'"
  have k: "?ns \<in> k_lists ?N 3"
    using fg_exists' unfolding k_lists_def by simp

  assume A: "eff_acyclic' h'"
  have *: "chain ?e ?ns (hd ?ns) (?f (hd ?ns)) = {#}"
    apply (rule eff_acyclic'_chain_eq_0_plus_fg[of h' h' 0])
    using fg_exists' End_closed_E edge_in' A by auto

  have "chain edges' ?ns (hd ?ns) (flow' (hd ?ns)) = {# 3 #}" by simp
  with * fg_exists' show False by simp
qed

text \<open>Assuming theorem 3 from @{cite krishna20} we derive False from our example flow graphs:
on the one hand the theorem claims that flow graph h1'+h2 us effectively acyclic,
while on the other hand we showed that it is not effectively acyclic.\<close>

lemma maintain_eff_acyclic_dom:
  assumes T: "\<And>h h1 h1' h2 :: (nat, nat multiset) fg. \<And>E.
           h = h1 + h2 \<Longrightarrow> h \<noteq> bot \<Longrightarrow> h1' \<noteq> bot \<Longrightarrow> dom_fg h1' \<inter> dom_fg h2 = {} \<Longrightarrow>
           \<forall>n \<in> dom_fg h1' - dom_fg h1. outf_fg h2 n = 0 \<Longrightarrow> \<forall>x y. edge_fg h x y \<in> E \<Longrightarrow>
           End_closed E \<Longrightarrow> id \<in> E \<Longrightarrow> \<forall>x y. edge_fg h2 x y \<in> E \<Longrightarrow>
           \<forall>x y. edge_fg h1 x y \<in> E \<Longrightarrow> \<forall>x y. edge_fg h1' x y \<in> E \<Longrightarrow>
           (\<lambda>_. 0) \<in> E \<Longrightarrow> reduced E \<Longrightarrow> eff_acyclic' h \<Longrightarrow> eff_acyclic' h1 \<Longrightarrow> eff_acyclic' h1' \<Longrightarrow>
           eff_acyclic' h2 \<Longrightarrow> h1 \<lesssim>\<^sub>S h1' \<Longrightarrow>
           \<exists>h'. h' = h1' + h2 \<and> h' \<noteq> bot \<and> eff_acyclic' h' \<and> h \<lesssim>\<^sub>S h'"
  shows False
proof -
  have "\<exists>h'. h' = h1' + h2 \<and> h' \<noteq> bot \<and> eff_acyclic' h' \<and> h \<lesssim>\<^sub>S h'"
    apply (rule T[OF fg_sum_eq[symmetric] fg_exists fg_exists1' _ _ edge_in End_closed_E
        _ edge_in2 edge_in1 edge_in1' _ reduced_E ea ea1 ea1' ea2 ctx])
    using fg_exists1 fg_exists1' fg_exists2 assms id_def by auto
  then obtain h'' where "h'' = h1' + h2" "h'' \<noteq> bot" "eff_acyclic' h''" "h \<lesssim>\<^sub>S h''"
    by blast
  with ea' fg_sum_eq' show False by simp
qed

end


(*
  File: SepAuto.thy
  Author: Bohua Zhan
*)

section \<open>Separation logic\<close>

theory SepAuto
  imports SepLogic_Base "HOL-Imperative_HOL.Imperative_HOL"
begin

text \<open>
  Separation logic for Imperative\_HOL, and setup of auto2. The development of
  separation logic here follows \cite{Separation_Logic_Imperative_HOL-AFP} by Lammich and Meis.
\<close>

subsection \<open>Partial Heaps\<close>

datatype pheap = pHeap (heapOf: heap) (addrOf: "addr set")
setup \<open>add_simple_datatype "pheap"\<close>

fun in_range :: "(heap \<times> addr set) \<Rightarrow> bool" where
  "in_range (h,as) \<longleftrightarrow> (\<forall>a\<in>as. a < lim h)"
setup \<open>add_rewrite_rule @{thm in_range.simps}\<close>

text \<open>Two heaps agree on a set of addresses.\<close>
definition relH :: "addr set \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> bool" where [rewrite]:
  "relH as h h' = (in_range (h, as) \<and> in_range (h', as) \<and>
     (\<forall>t. \<forall>a\<in>as. refs h t a = refs h' t a \<and> arrays h t a = arrays h' t a))"

lemma relH_D [forward]:
  "relH as h h' \<Longrightarrow> in_range (h, as) \<and> in_range (h', as)" by auto2

lemma relH_D2 [rewrite]:
  "relH as h h' \<Longrightarrow> a \<in> as \<Longrightarrow> refs h t a = refs h' t a"
  "relH as h h' \<Longrightarrow> a \<in> as \<Longrightarrow> arrays h t a = arrays h' t a" by auto2+
setup \<open>del_prfstep_thm_eqforward @{thm relH_def}\<close>

lemma relH_dist_union [forward]:
  "relH (as \<union> as') h h' \<Longrightarrow> relH as h h' \<and> relH as' h h'" by auto2

lemma relH_ref [rewrite]:
  "relH as h h' \<Longrightarrow> addr_of_ref r \<in> as \<Longrightarrow> Ref.get h r = Ref.get h' r"
  by (simp add: Ref.get_def relH_def)

lemma relH_array [rewrite]:
  "relH as h h' \<Longrightarrow> addr_of_array r \<in> as \<Longrightarrow> Array.get h r = Array.get h' r"
  by (simp add: Array.get_def relH_def)

lemma relH_set_ref [resolve]:
  "relH {a. a < lim h \<and> a \<notin> {addr_of_ref r}} h (Ref.set r x h)"
  by (simp add: Ref.set_def relH_def)

lemma relH_set_array [resolve]:
  "relH {a. a < lim h \<and> a \<notin> {addr_of_array r}} h (Array.set r x h)"
  by (simp add: Array.set_def relH_def)

subsection \<open>Assertions\<close>

datatype assn_raw = Assn (assn_fn: "pheap \<Rightarrow> bool")

fun aseval :: "assn_raw \<Rightarrow> pheap \<Rightarrow> bool" where
  "aseval (Assn f) h = f h"
setup \<open>add_rewrite_rule @{thm aseval.simps}\<close>

definition proper :: "assn_raw \<Rightarrow> bool" where [rewrite]:
  "proper P = (
    (\<forall>h as. aseval P (pHeap h as) \<longrightarrow> in_range (h,as)) \<and>
    (\<forall>h h' as. aseval P (pHeap h as) \<longrightarrow> relH as h h' \<longrightarrow> in_range (h',as) \<longrightarrow> aseval P (pHeap h' as)))"

fun in_range_assn :: "pheap \<Rightarrow> bool" where
  "in_range_assn (pHeap h as) \<longleftrightarrow> (\<forall>a\<in>as. a < lim h)"
setup \<open>add_rewrite_rule @{thm in_range_assn.simps}\<close>

typedef assn = "Collect proper"
@proof @have "Assn in_range_assn \<in> Collect proper" @qed

setup \<open>add_rewrite_rule @{thm Rep_assn_inject}\<close>
setup \<open>register_wellform_data ("Abs_assn P", ["proper P"])\<close>
setup \<open>add_prfstep_check_req ("Abs_assn P", "proper P")\<close>

lemma Abs_assn_inverse' [rewrite]: "proper y \<Longrightarrow> Rep_assn (Abs_assn y) = y"
  by (simp add: Abs_assn_inverse)

lemma proper_Rep_assn [forward]: "proper (Rep_assn P)" using Rep_assn by auto

definition models :: "pheap \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Turnstile>" 50) where [rewrite_bidir]:
  "h \<Turnstile> P \<longleftrightarrow> aseval (Rep_assn P) h"

lemma models_in_range [resolve]: "pHeap h as \<Turnstile> P \<Longrightarrow> in_range (h,as)" by auto2

lemma mod_relH [forward]: "relH as h h' \<Longrightarrow> pHeap h as \<Turnstile> P \<Longrightarrow> pHeap h' as \<Turnstile> P" by auto2

instantiation assn :: one begin
definition one_assn :: assn where [rewrite]:
  "1 \<equiv> Abs_assn (Assn (\<lambda>h. addrOf h = {}))"
instance .. end

abbreviation one_assn :: assn ("emp") where "one_assn \<equiv> 1"

lemma one_assn_rule [rewrite]: "h \<Turnstile> emp \<longleftrightarrow> addrOf h = {}" by auto2
setup \<open>del_prfstep_thm @{thm one_assn_def}\<close>

instantiation assn :: times begin
definition times_assn where [rewrite]:
  "P * Q = Abs_assn (Assn (
    \<lambda>h. (\<exists>as1 as2. addrOf h = as1 \<union> as2 \<and> as1 \<inter> as2 = {} \<and>
                   aseval (Rep_assn P) (pHeap (heapOf h) as1) \<and> aseval (Rep_assn Q) (pHeap (heapOf h) as2))))"
instance .. end

lemma mod_star_conv [rewrite]:
  "pHeap h as \<Turnstile> A * B \<longleftrightarrow> (\<exists>as1 as2. as = as1 \<union> as2 \<and> as1 \<inter> as2 = {} \<and> pHeap h as1 \<Turnstile> A \<and> pHeap h as2 \<Turnstile> B)" by auto2
setup \<open>del_prfstep_thm @{thm times_assn_def}\<close>

lemma aseval_ext [backward]: "\<forall>h. aseval P h = aseval P' h \<Longrightarrow> P = P'"
  apply (cases P) apply (cases P') by auto

lemma assn_ext: "\<forall>h as. pHeap h as \<Turnstile> P \<longleftrightarrow> pHeap h as \<Turnstile> Q \<Longrightarrow> P = Q"
@proof @have "Rep_assn P = Rep_assn Q" @qed
setup \<open>add_backward_prfstep_cond @{thm assn_ext} [with_filt (order_filter "P" "Q")]\<close>

setup \<open>del_prfstep_thm @{thm aseval_ext}\<close>

lemma assn_one_left: "1 * P = (P::assn)"
@proof
  @have "\<forall>h as. pHeap h as \<Turnstile> P \<longleftrightarrow> pHeap h as \<Turnstile> 1 * P" @with
    @have "as = {} \<union> as"
  @end
@qed

lemma assn_times_comm: "P * Q = Q * (P::assn)"
@proof
  @have "\<forall>h as. pHeap h as \<Turnstile> P * Q \<longleftrightarrow> pHeap h as \<Turnstile> Q * P" @with
    @case "pHeap h as \<Turnstile> P * Q" @with
      @obtain as1 as2 where "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "pHeap h as1 \<Turnstile> P" "pHeap h as2 \<Turnstile> Q"
      @have "as = as2 \<union> as1"
    @end
    @case "pHeap h as \<Turnstile> Q * P" @with
      @obtain as1 as2 where "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "pHeap h as1 \<Turnstile> Q" "pHeap h as2 \<Turnstile> P"
      @have "as = as2 \<union> as1"
    @end
  @end
@qed

lemma assn_times_assoc: "(P * Q) * R = P * (Q * (R::assn))"
@proof
  @have "\<forall>h as. pHeap h as \<Turnstile> (P * Q) * R \<longleftrightarrow> pHeap h as \<Turnstile> P * (Q * R)" @with
    @case "pHeap h as \<Turnstile> (P * Q) * R" @with
      @obtain as1 as2 where "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "pHeap h as1 \<Turnstile> P * Q" "pHeap h as2 \<Turnstile> R"
      @obtain as11 as12 where "as1 = as11 \<union> as12" "as11 \<inter> as12 = {}" "pHeap h as11 \<Turnstile> P" "pHeap h as12 \<Turnstile> Q"
      @have "as = as11 \<union> (as12 \<union> as2)"
    @end
    @case "pHeap h as \<Turnstile> P * (Q * R)" @with
      @obtain as1 as2 where "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "pHeap h as1 \<Turnstile> P" "pHeap h as2 \<Turnstile> Q * R"
      @obtain as21 as22 where "as2 = as21 \<union> as22" "as21 \<inter> as22 = {}" "pHeap h as21 \<Turnstile> Q" "pHeap h as22 \<Turnstile> R"
      @have "as = (as1 \<union> as21) \<union> as22"
    @end
  @end
@qed

instantiation assn :: comm_monoid_mult begin
  instance apply standard
  apply (rule assn_times_assoc) apply (rule assn_times_comm) by (rule assn_one_left)
end

subsubsection \<open>Existential Quantification\<close>

definition ex_assn :: "('a \<Rightarrow> assn) \<Rightarrow> assn" (binder "\<exists>\<^sub>A" 11) where [rewrite]:
  "(\<exists>\<^sub>Ax. P x) = Abs_assn (Assn (\<lambda>h. \<exists>x. h \<Turnstile> P x))"

lemma mod_ex_dist [rewrite]: "(h \<Turnstile> (\<exists>\<^sub>Ax. P x)) \<longleftrightarrow> (\<exists>x. h \<Turnstile> P x)" by auto2
setup \<open>del_prfstep_thm @{thm ex_assn_def}\<close>

lemma ex_distrib_star: "(\<exists>\<^sub>Ax. P x * Q) = (\<exists>\<^sub>Ax. P x) * Q"
@proof
  @have "\<forall>h as. pHeap h as \<Turnstile> (\<exists>\<^sub>Ax. P x) * Q \<longleftrightarrow> pHeap h as \<Turnstile> (\<exists>\<^sub>Ax. P x * Q)" @with
    @case "pHeap h as \<Turnstile> (\<exists>\<^sub>Ax. P x) * Q" @with
      @obtain as1 as2 where "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "pHeap h as1 \<Turnstile> (\<exists>\<^sub>Ax. P x)" "pHeap h as2 \<Turnstile> Q"
      @obtain x where "pHeap h as1 \<Turnstile> P x"
      @have "pHeap h as \<Turnstile> P x * Q"
    @end
  @end
@qed

subsubsection \<open>Pointers\<close>

definition sngr_assn :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> assn" (infix "\<mapsto>\<^sub>r" 82) where [rewrite]:
  "r \<mapsto>\<^sub>r x = Abs_assn (Assn (
    \<lambda>h. Ref.get (heapOf h) r = x \<and> addrOf h = {addr_of_ref r} \<and> addr_of_ref r < lim (heapOf h)))"

lemma sngr_assn_rule [rewrite]:
  "pHeap h as \<Turnstile> r \<mapsto>\<^sub>r x \<longleftrightarrow> (Ref.get h r = x \<and> as = {addr_of_ref r} \<and> addr_of_ref r < lim h)" by auto2
setup \<open>del_prfstep_thm @{thm sngr_assn_def}\<close>

definition snga_assn :: "'a::heap array \<Rightarrow> 'a list \<Rightarrow> assn" (infix "\<mapsto>\<^sub>a" 82) where [rewrite]:
  "r \<mapsto>\<^sub>a x = Abs_assn (Assn (
    \<lambda>h. Array.get (heapOf h) r = x \<and> addrOf h = {addr_of_array r} \<and> addr_of_array r < lim (heapOf h)))"

lemma snga_assn_rule [rewrite]:
  "pHeap h as \<Turnstile> r \<mapsto>\<^sub>a x \<longleftrightarrow> (Array.get h r = x \<and> as = {addr_of_array r} \<and> addr_of_array r < lim h)" by auto2
setup \<open>del_prfstep_thm @{thm snga_assn_def}\<close>

subsubsection \<open>Pure Assertions\<close>

definition pure_assn :: "bool \<Rightarrow> assn" ("\<up>") where [rewrite]:
  "\<up>b = Abs_assn (Assn (\<lambda>h. addrOf h = {} \<and> b))"

lemma pure_assn_rule [rewrite]: "h \<Turnstile> \<up>b \<longleftrightarrow> (addrOf h = {} \<and> b)" by auto2
setup \<open>del_prfstep_thm @{thm pure_assn_def}\<close>

definition top_assn :: assn ("true") where [rewrite]:
  "top_assn = Abs_assn (Assn in_range_assn)"

lemma top_assn_rule [rewrite]: "pHeap h as \<Turnstile> true \<longleftrightarrow> in_range (h, as)" by auto2
setup \<open>del_prfstep_thm @{thm top_assn_def}\<close>

setup \<open>del_prfstep_thm @{thm models_def}\<close>

subsubsection \<open>Properties of assertions\<close>

abbreviation bot_assn :: assn ("false") where "bot_assn \<equiv> \<up>False"

lemma top_assn_reduce: "true * true = true"
@proof
  @have "\<forall>h. h \<Turnstile> true \<longleftrightarrow> h \<Turnstile> true * true" @with
    @have "addrOf h = addrOf h \<union> {}"
  @end
@qed

lemma mod_pure_star_dist [rewrite]:
  "h \<Turnstile> P * \<up>b \<longleftrightarrow> (h \<Turnstile> P \<and> b)"
@proof
  @case "h \<Turnstile> P \<and> b" @with
    @have "addrOf h = addrOf h \<union> {}"
  @end
@qed

lemma pure_conj: "\<up>(P \<and> Q) = \<up>P * \<up>Q" by auto2

subsubsection \<open>Entailment and its properties\<close>

definition entails :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Longrightarrow>\<^sub>A" 10) where [rewrite]:
  "(P \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<forall>h. h \<Turnstile> P \<longrightarrow> h \<Turnstile> Q)"

lemma entails_triv: "A \<Longrightarrow>\<^sub>A A" by auto2
lemma entails_true: "A \<Longrightarrow>\<^sub>A true" by auto2
lemma entails_frame [backward]: "P \<Longrightarrow>\<^sub>A Q \<Longrightarrow> P * R \<Longrightarrow>\<^sub>A Q * R" by auto2
lemma entails_frame': "\<not> (A * F \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<not> (B * F \<Longrightarrow>\<^sub>A Q)" by auto2
lemma entails_frame'': "\<not> (P \<Longrightarrow>\<^sub>A B * F) \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<not> (P \<Longrightarrow>\<^sub>A A * F)" by auto2
lemma entails_equiv_forward: "P = Q \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q" by auto2
lemma entails_equiv_backward: "P = Q \<Longrightarrow> Q \<Longrightarrow>\<^sub>A P" by auto2
lemma entailsD [forward]: "P \<Longrightarrow>\<^sub>A Q \<Longrightarrow> h \<Turnstile> P \<Longrightarrow> h \<Turnstile> Q" by auto2
lemma entails_trans2: "A \<Longrightarrow>\<^sub>A D * B \<Longrightarrow> B \<Longrightarrow>\<^sub>A C \<Longrightarrow> A \<Longrightarrow>\<^sub>A D * C" by auto2

lemma entails_pure': "\<not>(\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<not>(emp \<Longrightarrow>\<^sub>A Q) \<and> b)" by auto2
lemma entails_pure: "\<not>(P * \<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<not>(P \<Longrightarrow>\<^sub>A Q) \<and> b)" by auto2
lemma entails_ex: "\<not>((\<exists>\<^sub>Ax. P x) \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<exists>x. \<not>(P x \<Longrightarrow>\<^sub>A Q))" by auto2
lemma entails_ex_post: "\<not>(P \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. Q x)) \<Longrightarrow> \<forall>x. \<not>(P \<Longrightarrow>\<^sub>A Q x)" by auto2
lemma entails_pure_post: "\<not>(P \<Longrightarrow>\<^sub>A Q * \<up>b) \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q \<Longrightarrow> \<not>b" by auto2

setup \<open>del_prfstep_thm @{thm entails_def}\<close>

subsection \<open>Definition of the run predicate\<close>

inductive run :: "'a Heap \<Rightarrow> heap option \<Rightarrow> heap option \<Rightarrow> 'a \<Rightarrow> bool" where
  "run c None None r"
| "execute c h = None \<Longrightarrow> run c (Some h) None r"
| "execute c h = Some (r, h') \<Longrightarrow> run c (Some h) (Some h') r"
setup \<open>add_case_induct_rule @{thm run.cases}\<close>
setup \<open>fold add_resolve_prfstep @{thms run.intros(1,2)}\<close>
setup \<open>add_forward_prfstep @{thm run.intros(3)}\<close>

lemma run_complete [resolve]:
  "\<exists>\<sigma>' r. run c \<sigma> \<sigma>' (r::'a)"
@proof
  @obtain "r::'a" where "r = r"
  @case "\<sigma> = None" @with @have "run c None None r" @end
  @case "execute c (the \<sigma>) = None" @with @have "run c \<sigma> None r" @end
@qed

lemma run_to_execute [forward]:
  "run c (Some h) \<sigma>' r \<Longrightarrow> if \<sigma>' = None then execute c h = None else execute c h = Some (r, the \<sigma>')"
@proof @case_induct "run c (Some h) \<sigma>' r" @qed

setup \<open>add_rewrite_rule @{thm execute_bind(1)}\<close>
lemma runE [forward]:
  "run f (Some h) (Some h') r' \<Longrightarrow> run (f \<bind> g) (Some h) \<sigma> r \<Longrightarrow> run (g r') (Some h') \<sigma> r" by auto2

setup \<open>add_rewrite_rule @{thm Array.get_alloc}\<close>
setup \<open>add_rewrite_rule @{thm Ref.get_alloc}\<close>
setup \<open>add_rewrite_rule_bidir @{thm Array.length_def}\<close>

subsection \<open>Definition of hoare triple, and the frame rule.\<close>

definition new_addrs :: "heap \<Rightarrow> addr set \<Rightarrow> heap \<Rightarrow> addr set" where [rewrite]:
  "new_addrs h as h' = as \<union> {a. lim h \<le> a \<and> a < lim h'}"

definition hoare_triple :: "assn \<Rightarrow> 'a Heap \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bool" ("<_>/ _/ <_>") where [rewrite]:
  "<P> c <Q> \<longleftrightarrow> (\<forall>h as \<sigma> r. pHeap h as \<Turnstile> P \<longrightarrow> run c (Some h) \<sigma> r \<longrightarrow>
    (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) \<Turnstile> Q r \<and> relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and>
     lim h \<le> lim (the \<sigma>)))"

lemma hoare_tripleD [forward]:
  "<P> c <Q> \<Longrightarrow> run c (Some h) \<sigma> r \<Longrightarrow> \<forall>as. pHeap h as \<Turnstile> P \<longrightarrow>
     (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) \<Turnstile> Q r \<and> relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and>
     lim h \<le> lim (the \<sigma>))"
  by auto2
setup \<open>del_prfstep_thm_eqforward @{thm hoare_triple_def}\<close>

abbreviation hoare_triple' :: "assn \<Rightarrow> 'r Heap \<Rightarrow> ('r \<Rightarrow> assn) \<Rightarrow> bool" ("<_> _ <_>\<^sub>t") where
  "<P> c <Q>\<^sub>t \<equiv> <P> c <\<lambda>r. Q r * true>"

theorem frame_rule [backward]:
  "<P> c <Q> \<Longrightarrow> <P * R> c <\<lambda>x. Q x * R>"
@proof
  @have "\<forall>h as \<sigma> r. pHeap h as \<Turnstile> P * R \<longrightarrow> run c (Some h) \<sigma> r \<longrightarrow>
                    (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) \<Turnstile> Q r * R \<and>
                     relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and> lim h \<le> lim (the \<sigma>))" @with
    @obtain as1 as2 where "as = as1 \<union> as2" "as1 \<inter> as2 = {}" "pHeap h as1 \<Turnstile> P \<and> pHeap h as2 \<Turnstile> R"
    @have "relH as2 h (the \<sigma>)"
    @have "new_addrs h as (the \<sigma>) = new_addrs h as1 (the \<sigma>) \<union> as2"
  @end
@qed

text \<open>This is the last use of the definition of separating conjunction.\<close>
setup \<open>del_prfstep_thm @{thm mod_star_conv}\<close>

theorem bind_rule:
  "<P> f <Q> \<Longrightarrow> \<forall>x. <Q x> g x <R> \<Longrightarrow> <P> f \<bind> g <R>"
@proof
  @have "\<forall>h as \<sigma> r. pHeap h as \<Turnstile> P \<longrightarrow> run (f \<bind> g) (Some h) \<sigma> r \<longrightarrow>
                    (\<sigma> \<noteq> None \<and> pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) \<Turnstile> R r \<and>
                     relH {a . a < lim h \<and> a \<notin> as} h (the \<sigma>) \<and> lim h \<le> lim (the \<sigma>))" @with
    \<comment> \<open>First step from h to h'\<close>
    @obtain \<sigma>' r' where "run f (Some h) \<sigma>' r'"
    @obtain h' where "\<sigma>' = Some h'"
    @let "as' = new_addrs h as h'"
    @have "pHeap h' as' \<Turnstile> Q r'"

    \<comment> \<open>Second step from h' to h''\<close>
    @have "run (g r') (Some h') \<sigma> r"
    @obtain h'' where "\<sigma> = Some h''"
    @let "as'' = new_addrs h' as' h''"
    @have "pHeap h'' as'' \<Turnstile> R r"
    @have "as'' = new_addrs h as h''"
  @end
@qed

text \<open>Actual statement used:\<close>
lemma bind_rule':
  "<P> f <Q> \<Longrightarrow> \<not> <P> f \<bind> g <R> \<Longrightarrow> \<exists>x. \<not> <Q x> g x <R>" using bind_rule by blast

lemma pre_rule':
  "\<not> <P * R> f <Q> \<Longrightarrow> P \<Longrightarrow>\<^sub>A P' \<Longrightarrow> \<not> <P' * R> f <Q>"
@proof @have "P * R \<Longrightarrow>\<^sub>A P' * R" @qed

lemma pre_rule'':
  "<P> f <Q> \<Longrightarrow> P' \<Longrightarrow>\<^sub>A P * R \<Longrightarrow> <P'> f <\<lambda>x. Q x * R>"
@proof @have "<P * R> f <\<lambda>x. Q x * R>" @qed

lemma pre_ex_rule:
  "\<not> <\<exists>\<^sub>Ax. P x> f <Q> \<longleftrightarrow> (\<exists>x. \<not> <P x> f <Q>)" by auto2

lemma pre_pure_rule:
  "\<not> <P * \<up>b> f <Q> \<longleftrightarrow> \<not> <P> f <Q> \<and> b" by auto2

lemma pre_pure_rule':
  "\<not> <\<up>b> f <Q> \<longleftrightarrow> \<not> <emp> f <Q> \<and> b" by auto2

lemma post_rule:
  "<P> f <Q> \<Longrightarrow> \<forall>x. Q x \<Longrightarrow>\<^sub>A R x \<Longrightarrow> <P> f <R>" by auto2

setup \<open>fold del_prfstep_thm [@{thm entailsD}, @{thm entails_frame}, @{thm frame_rule}]\<close>

text \<open>Actual statement used:\<close>
lemma post_rule':
  "<P> f <Q> \<Longrightarrow> \<not> <P> f <R> \<Longrightarrow> \<exists>x. \<not> (Q x \<Longrightarrow>\<^sub>A R x)" using post_rule by blast

lemma norm_pre_pure_iff: "<P * \<up>b> c <Q> \<longleftrightarrow> (b \<longrightarrow> <P> c <Q>)" by auto2
lemma norm_pre_pure_iff2: "<\<up>b> c <Q> \<longleftrightarrow> (b \<longrightarrow> <emp> c <Q>)" by auto2

subsection \<open>Hoare triples for atomic commands\<close>

text \<open>First, those that do not modify the heap.\<close>
setup \<open>add_rewrite_rule @{thm execute_assert(1)}\<close>
lemma assert_rule:
  "<\<up>(R x)> assert R x <\<lambda>r. \<up>(r = x)>" by auto2

lemma execute_return' [rewrite]: "execute (return x) h = Some (x, h)" by (metis comp_eq_dest_lhs execute_return)
lemma return_rule:
  "<emp> return x <\<lambda>r. \<up>(r = x)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_nth(1)}\<close>
lemma nth_rule:
  "<a \<mapsto>\<^sub>a xs * \<up>(i < length xs)> Array.nth a i <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs ! i)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_len}\<close>
lemma length_rule:
  "<a \<mapsto>\<^sub>a xs> Array.len a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = length xs)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_lookup}\<close>
lemma lookup_rule:
  "<p \<mapsto>\<^sub>r x> !p <\<lambda>r. p \<mapsto>\<^sub>r x * \<up>(r = x)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_freeze}\<close>
lemma freeze_rule:
  "<a \<mapsto>\<^sub>a xs> Array.freeze a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs)>" by auto2

text \<open>Next, the update rules.\<close>
setup \<open>add_rewrite_rule @{thm Ref.lim_set}\<close>
lemma Array_lim_set [rewrite]: "lim (Array.set p xs h) = lim h" by (simp add: Array.set_def)

setup \<open>fold add_rewrite_rule [@{thm Ref.get_set_eq}, @{thm Array.get_set_eq}]\<close>
setup \<open>add_rewrite_rule @{thm Array.update_def}\<close>

setup \<open>add_rewrite_rule @{thm execute_upd(1)}\<close>
lemma upd_rule:
  "<a \<mapsto>\<^sub>a xs * \<up>(i < length xs)> Array.upd i x a <\<lambda>r. a \<mapsto>\<^sub>a list_update xs i x * \<up>(r = a)>" by auto2

setup \<open>add_rewrite_rule @{thm execute_update}\<close>
lemma update_rule:
  "<p \<mapsto>\<^sub>r y> p := x <\<lambda>r. p \<mapsto>\<^sub>r x>" by auto2

text \<open>Finally, the allocation rules.\<close>
lemma lim_set_gen [rewrite]: "lim (h\<lparr>lim := l\<rparr>) = l" by simp

lemma Array_alloc_def' [rewrite]:
  "Array.alloc xs h = (let l = lim h; r = Array l in (r, (Array.set r xs (h\<lparr>lim := l + 1\<rparr>))))"
  by (simp add: Array.alloc_def)

setup \<open>fold add_rewrite_rule [
  @{thm addr_of_array.simps}, @{thm addr_of_ref.simps}, @{thm Ref.alloc_def}]\<close>

lemma refs_on_Array_set [rewrite]: "refs (Array.set p xs h) t i = refs h t i"
  by (simp add: Array.set_def)

lemma arrays_on_Ref_set [rewrite]: "arrays (Ref.set p x h) t i = arrays h t i"
  by (simp add: Ref.set_def)

lemma refs_on_Array_alloc [rewrite]: "refs (snd (Array.alloc xs h)) t i = refs h t i"
  by (metis (no_types, lifting) Array.alloc_def refs_on_Array_set select_convs(2) snd_conv surjective update_convs(3))

lemma arrays_on_Ref_alloc [rewrite]: "arrays (snd (Ref.alloc x h)) t i = arrays h t i"
  by (metis (no_types, lifting) Ref.alloc_def arrays_on_Ref_set select_convs(1) sndI surjective update_convs(3))

lemma arrays_on_Array_alloc [rewrite]: "i < lim h \<Longrightarrow> arrays (snd (Array.alloc xs h)) t i = arrays h t i"
  by (smt Array.alloc_def Array.set_def addr_of_array.simps fun_upd_apply less_or_eq_imp_le
          linorder_not_less simps(1) snd_conv surjective update_convs(1) update_convs(3))

lemma refs_on_Ref_alloc [rewrite]: "i < lim h \<Longrightarrow> refs (snd (Ref.alloc x h)) t i = refs h t i"
  by (smt Ref.alloc_def Ref.set_def addr_of_ref.simps fun_upd_apply less_or_eq_imp_le
          linorder_not_less select_convs(2) simps(6) snd_conv surjective update_convs(3))

setup \<open>add_rewrite_rule @{thm execute_new}\<close>
lemma new_rule:
  "<emp> Array.new n x <\<lambda>r. r \<mapsto>\<^sub>a replicate n x>" by auto2

setup \<open>add_rewrite_rule @{thm execute_of_list}\<close>
lemma of_list_rule:
  "<emp> Array.of_list xs <\<lambda>r. r \<mapsto>\<^sub>a xs>" by auto2

setup \<open>add_rewrite_rule @{thm execute_ref}\<close>
lemma ref_rule:
  "<emp> ref x <\<lambda>r. r \<mapsto>\<^sub>r x>" by auto2

setup \<open>fold del_prfstep_thm [
  @{thm sngr_assn_rule}, @{thm snga_assn_rule}, @{thm pure_assn_rule}, @{thm top_assn_rule},
  @{thm mod_pure_star_dist}, @{thm one_assn_rule}, @{thm hoare_triple_def}, @{thm mod_ex_dist}]\<close>
setup \<open>del_simple_datatype "pheap"\<close>

subsection \<open>Definition of procedures\<close>

text \<open>ASCII abbreviations for ML files.\<close>
abbreviation (input) ex_assn_ascii :: "('a \<Rightarrow> assn) \<Rightarrow> assn" (binder "EXA" 11)
  where "ex_assn_ascii \<equiv> ex_assn"

abbreviation (input) models_ascii :: "pheap \<Rightarrow> assn \<Rightarrow> bool" (infix "|=" 50)
  where "h |= P \<equiv> h \<Turnstile> P"

ML_file "sep_util.ML"

ML \<open>
structure AssnMatcher = AssnMatcher(SepUtil)
structure SepLogic = SepLogic(SepUtil)
val add_assn_matcher = AssnMatcher.add_assn_matcher
val add_entail_matcher = AssnMatcher.add_entail_matcher
val add_forward_ent_prfstep = SepLogic.add_forward_ent_prfstep
val add_rewrite_ent_rule = SepLogic.add_rewrite_ent_rule
val add_hoare_triple_prfstep = SepLogic.add_hoare_triple_prfstep
\<close>
setup \<open>AssnMatcher.add_assn_matcher_proofsteps\<close>
setup \<open>SepLogic.add_sep_logic_proofsteps\<close>

ML_file "sep_steps_test.ML"

attribute_setup forward_ent = \<open>setup_attrib add_forward_ent_prfstep\<close>
attribute_setup rewrite_ent = \<open>setup_attrib add_rewrite_ent_rule\<close>
attribute_setup hoare_triple = \<open>setup_attrib add_hoare_triple_prfstep\<close>

setup \<open>fold add_hoare_triple_prfstep [
  @{thm assert_rule}, @{thm update_rule}, @{thm nth_rule}, @{thm upd_rule},
  @{thm return_rule}, @{thm ref_rule}, @{thm lookup_rule}, @{thm new_rule},
  @{thm of_list_rule}, @{thm length_rule}, @{thm freeze_rule}]\<close>

text \<open>Some simple tests\<close>

theorem "<emp> ref x <\<lambda>r. r \<mapsto>\<^sub>r x>" by auto2
theorem "<a \<mapsto>\<^sub>r x> ref x <\<lambda>r. a \<mapsto>\<^sub>r x * r \<mapsto>\<^sub>r x>" by auto2
theorem "<a \<mapsto>\<^sub>r x> (!a) <\<lambda>r. a \<mapsto>\<^sub>r x * \<up>(r = x)>" by auto2
theorem "<a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y> (!a) <\<lambda>r. a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y * \<up>(r = x)>" by auto2
theorem "<a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y> (!b) <\<lambda>r. a \<mapsto>\<^sub>r x * b \<mapsto>\<^sub>r y * \<up>(r = y)>" by auto2
theorem "<a \<mapsto>\<^sub>r x> do { a := y; !a } <\<lambda>r. a \<mapsto>\<^sub>r y * \<up>(r = y)>" by auto2
theorem "<a \<mapsto>\<^sub>r x> do { a := y; a := z; !a } <\<lambda>r. a \<mapsto>\<^sub>r z * \<up>(r = z)>" by auto2
theorem "<a \<mapsto>\<^sub>r x> do { y \<leftarrow> !a; ref y} <\<lambda>r. a \<mapsto>\<^sub>r x * r \<mapsto>\<^sub>r x>" by auto2
theorem "<emp> return x <\<lambda>r. \<up>(r = x)>" by auto2

end


(*  Title:      HOL/Auth/Guard/Extensions.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section {*Extensions to Standard Theories*}

theory Extensions
imports "../Event"
begin

subsection{*Extensions to Theory @{text Set}*}

lemma eq: "[| !!x. x:A ==> x:B; !!x. x:B ==> x:A |] ==> A=B"
by auto

lemma insert_Un: "P ({x} Un A) ==> P (insert x A)"
by simp

lemma in_sub: "x:A ==> {x}<=A"
by auto

subsection{*Extensions to Theory @{text List}*}

subsubsection{*"remove l x" erase the first element of "l" equal to "x"*}

primrec remove :: "'a list => 'a => 'a list" where
"remove [] y = []" |
"remove (x#xs) y = (if x=y then xs else x # remove xs y)"

lemma set_remove: "set (remove l x) <= set l"
by (induct l, auto)

subsection{*Extensions to Theory @{text Message}*}

subsubsection{*declarations for tactics*}

declare analz_subset_parts [THEN subsetD, dest]
declare parts_insert2 [simp]
declare analz_cut [dest]
declare split_if_asm [split]
declare analz_insertI [intro]
declare Un_Diff [simp]

subsubsection{*extract the agent number of an Agent message*}

primrec agt_nb :: "msg => agent" where
"agt_nb (Agent A) = A"

subsubsection{*messages that are pairs*}

definition is_MPair :: "msg => bool" where
"is_MPair X == EX Y Z. X = {|Y,Z|}"

declare is_MPair_def [simp]

lemma MPair_is_MPair [iff]: "is_MPair {|X,Y|}"
by simp

lemma Agent_isnt_MPair [iff]: "~ is_MPair (Agent A)"
by simp

lemma Number_isnt_MPair [iff]: "~ is_MPair (Number n)"
by simp

lemma Key_isnt_MPair [iff]: "~ is_MPair (Key K)"
by simp

lemma Nonce_isnt_MPair [iff]: "~ is_MPair (Nonce n)"
by simp

lemma Hash_isnt_MPair [iff]: "~ is_MPair (Hash X)"
by simp

lemma Crypt_isnt_MPair [iff]: "~ is_MPair (Crypt K X)"
by simp

abbreviation
  not_MPair :: "msg => bool" where
  "not_MPair X == ~ is_MPair X"

lemma is_MPairE: "[| is_MPair X ==> P; not_MPair X ==> P |] ==> P"
by auto

declare is_MPair_def [simp del]

definition has_no_pair :: "msg set => bool" where
"has_no_pair H == ALL X Y. {|X,Y|} ~:H"

declare has_no_pair_def [simp]

subsubsection{*well-foundedness of messages*}

lemma wf_Crypt1 [iff]: "Crypt K X ~= X"
by (induct X, auto)

lemma wf_Crypt2 [iff]: "X ~= Crypt K X"
by (induct X, auto)

lemma parts_size: "X:parts {Y} ==> X=Y | size X < size Y"
by (erule parts.induct, auto)

lemma wf_Crypt_parts [iff]: "Crypt K X ~:parts {X}"
by (auto dest: parts_size)

subsubsection{*lemmas on keysFor*}

definition usekeys :: "msg set => key set" where
"usekeys G == {K. EX Y. Crypt K Y:G}"

lemma finite_keysFor [intro]: "finite G ==> finite (keysFor G)"
apply (simp add: keysFor_def)
apply (rule finite_imageI)
apply (induct G rule: finite_induct)
apply auto
apply (case_tac "EX K X. x = Crypt K X", clarsimp)
apply (subgoal_tac "{Ka. EX Xa. (Ka=K & Xa=X) | Crypt Ka Xa:F}
= insert K (usekeys F)", auto simp: usekeys_def)
by (subgoal_tac "{K. EX X. Crypt K X = x | Crypt K X:F} = usekeys F",
auto simp: usekeys_def)

subsubsection{*lemmas on parts*}

lemma parts_sub: "[| X:parts G; G<=H |] ==> X:parts H"
by (auto dest: parts_mono)

lemma parts_Diff [dest]: "X:parts (G - H) ==> X:parts G"
by (erule parts_sub, auto)

lemma parts_Diff_notin: "[| Y ~:H; Nonce n ~:parts (H - {Y}) |]
==> Nonce n ~:parts H"
by simp

lemmas parts_insert_substI = parts_insert [THEN ssubst]
lemmas parts_insert_substD = parts_insert [THEN sym, THEN ssubst]

lemma finite_parts_msg [iff]: "finite (parts {X})"
by (induct X, auto)

lemma finite_parts [intro]: "finite H ==> finite (parts H)"
apply (erule finite_induct, simp)
by (rule parts_insert_substI, simp)

lemma parts_parts: "[| X:parts {Y}; Y:parts G |] ==> X:parts G"
by (frule parts_cut, auto)

lemma parts_parts_parts: "[| X:parts {Y}; Y:parts {Z}; Z:parts G |] ==> X:parts G"
by (auto dest: parts_parts)

lemma parts_parts_Crypt: "[| Crypt K X:parts G; Nonce n:parts {X} |]
==> Nonce n:parts G"
by (blast intro: parts.Body dest: parts_parts)

subsubsection{*lemmas on synth*}

lemma synth_sub: "[| X:synth G; G<=H |] ==> X:synth H"
by (auto dest: synth_mono)

lemma Crypt_synth [rule_format]: "[| X:synth G; Key K ~:G |] ==>
Crypt K Y:parts {X} --> Crypt K Y:parts G"
by (erule synth.induct, auto dest: parts_sub)

subsubsection{*lemmas on analz*}

lemma analz_UnI1 [intro]: "X:analz G ==> X:analz (G Un H)"
  by (subgoal_tac "G <= G Un H") (blast dest: analz_mono)+

lemma analz_sub: "[| X:analz G; G <= H |] ==> X:analz H"
by (auto dest: analz_mono)

lemma analz_Diff [dest]: "X:analz (G - H) ==> X:analz G"
by (erule analz.induct, auto)

lemmas in_analz_subset_cong = analz_subset_cong [THEN subsetD]

lemma analz_eq: "A=A' ==> analz A = analz A'"
by auto

lemmas insert_commute_substI = insert_commute [THEN ssubst]

lemma analz_insertD:
     "[| Crypt K Y:H; Key (invKey K):H |] ==> analz (insert Y H) = analz H"
by (blast intro: analz.Decrypt analz_insert_eq)

lemma must_decrypt [rule_format,dest]: "[| X:analz H; has_no_pair H |] ==>
X ~:H --> (EX K Y. Crypt K Y:H & Key (invKey K):H)"
by (erule analz.induct, auto)

lemma analz_needs_only_finite: "X:analz H ==> EX G. G <= H & finite G"
by (erule analz.induct, auto)

lemma notin_analz_insert: "X ~:analz (insert Y G) ==> X ~:analz G"
by auto

subsubsection{*lemmas on parts, synth and analz*}

lemma parts_invKey [rule_format,dest]:"X:parts {Y} ==>
X:analz (insert (Crypt K Y) H) --> X ~:analz H --> Key (invKey K):analz H"
by (erule parts.induct, auto dest: parts.Fst parts.Snd parts.Body)

lemma in_analz: "Y:analz H ==> EX X. X:H & Y:parts {X}"
by (erule analz.induct, auto intro: parts.Fst parts.Snd parts.Body)

lemmas in_analz_subset_parts = analz_subset_parts [THEN subsetD]

lemma Crypt_synth_insert: "[| Crypt K X:parts (insert Y H);
Y:synth (analz H); Key K ~:analz H |] ==> Crypt K X:parts H"
apply (drule parts_insert_substD, clarify)
apply (frule in_sub)
apply (frule parts_mono)
apply auto
done

subsubsection{*greatest nonce used in a message*}

fun greatest_msg :: "msg => nat"
where
  "greatest_msg (Nonce n) = n"
| "greatest_msg {|X,Y|} = max (greatest_msg X) (greatest_msg Y)"
| "greatest_msg (Crypt K X) = greatest_msg X"
| "greatest_msg other = 0"

lemma greatest_msg_is_greatest: "Nonce n:parts {X} ==> n <= greatest_msg X"
by (induct X, auto)

subsubsection{*sets of keys*}

definition keyset :: "msg set => bool" where
"keyset G == ALL X. X:G --> (EX K. X = Key K)"

lemma keyset_in [dest]: "[| keyset G; X:G |] ==> EX K. X = Key K"
by (auto simp: keyset_def)

lemma MPair_notin_keyset [simp]: "keyset G ==> {|X,Y|} ~:G"
by auto

lemma Crypt_notin_keyset [simp]: "keyset G ==> Crypt K X ~:G"
by auto

lemma Nonce_notin_keyset [simp]: "keyset G ==> Nonce n ~:G"
by auto

lemma parts_keyset [simp]: "keyset G ==> parts G = G"
by (auto, erule parts.induct, auto)

subsubsection{*keys a priori necessary for decrypting the messages of G*}

definition keysfor :: "msg set => msg set" where
"keysfor G == Key ` keysFor (parts G)"

lemma keyset_keysfor [iff]: "keyset (keysfor G)"
by (simp add: keyset_def keysfor_def, blast)

lemma keyset_Diff_keysfor [simp]: "keyset H ==> keyset (H - keysfor G)"
by (auto simp: keyset_def)

lemma keysfor_Crypt: "Crypt K X:parts G ==> Key (invKey K):keysfor G"
by (auto simp: keysfor_def Crypt_imp_invKey_keysFor)

lemma no_key_no_Crypt: "Key K ~:keysfor G ==> Crypt (invKey K) X ~:parts G"
by (auto dest: keysfor_Crypt)

lemma finite_keysfor [intro]: "finite G ==> finite (keysfor G)"
by (auto simp: keysfor_def intro: finite_UN_I)

subsubsection{*only the keys necessary for G are useful in analz*}

lemma analz_keyset: "keyset H ==>
analz (G Un H) = H - keysfor G Un (analz (G Un (H Int keysfor G)))"
apply (rule eq)
apply (erule analz.induct, blast)
apply (simp, blast)
apply (simp, blast)
apply (case_tac "Key (invKey K):H - keysfor G", clarsimp)
apply (drule_tac X=X in no_key_no_Crypt)
by (auto intro: analz_sub)

lemmas analz_keyset_substD = analz_keyset [THEN sym, THEN ssubst]

subsection{*Extensions to Theory @{text Event}*}

subsubsection{*general protocol properties*}

definition is_Says :: "event => bool" where
"is_Says ev == (EX A B X. ev = Says A B X)"

lemma is_Says_Says [iff]: "is_Says (Says A B X)"
by (simp add: is_Says_def)

(* one could also require that Gets occurs after Says
but this is sufficient for our purpose *)
definition Gets_correct :: "event list set => bool" where
"Gets_correct p == ALL evs B X. evs:p --> Gets B X:set evs
--> (EX A. Says A B X:set evs)"

lemma Gets_correct_Says: "[| Gets_correct p; Gets B X # evs:p |]
==> EX A. Says A B X:set evs"
apply (simp add: Gets_correct_def)
by (drule_tac x="Gets B X # evs" in spec, auto)

definition one_step :: "event list set => bool" where
"one_step p == ALL evs ev. ev#evs:p --> evs:p"

lemma one_step_Cons [dest]: "[| one_step p; ev#evs:p |] ==> evs:p"
by (unfold one_step_def, blast)

lemma one_step_app: "[| evs@evs':p; one_step p; []:p |] ==> evs':p"
by (induct evs, auto)

lemma trunc: "[| evs @ evs':p; one_step p |] ==> evs':p"
by (induct evs, auto)

definition has_only_Says :: "event list set => bool" where
"has_only_Says p == ALL evs ev. evs:p --> ev:set evs
--> (EX A B X. ev = Says A B X)"

lemma has_only_SaysD: "[| ev:set evs; evs:p; has_only_Says p |]
==> EX A B X. ev = Says A B X"
by (unfold has_only_Says_def, blast)

lemma in_has_only_Says [dest]: "[| has_only_Says p; evs:p; ev:set evs |]
==> EX A B X. ev = Says A B X"
by (auto simp: has_only_Says_def)

lemma has_only_Says_imp_Gets_correct [simp]: "has_only_Says p
==> Gets_correct p"
by (auto simp: has_only_Says_def Gets_correct_def)

subsubsection{*lemma on knows*}

lemma Says_imp_spies2: "Says A B {|X,Y|}:set evs ==> Y:parts (spies evs)"
by (drule Says_imp_spies, drule parts.Inj, drule parts.Snd, simp)

lemma Says_not_parts: "[| Says A B X:set evs; Y ~:parts (spies evs) |]
==> Y ~:parts {X}"
by (auto dest: Says_imp_spies parts_parts)

subsubsection{*knows without initState*}

primrec knows' :: "agent => event list => msg set" where
  knows'_Nil: "knows' A [] = {}" |
  knows'_Cons0:
 "knows' A (ev # evs) = (
   if A = Spy then (
     case ev of
       Says A' B X => insert X (knows' A evs)
     | Gets A' X => knows' A evs
     | Notes A' X => if A':bad then insert X (knows' A evs) else knows' A evs
   ) else (
     case ev of
       Says A' B X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Gets A' X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Notes A' X => if A=A' then insert X (knows' A evs) else knows' A evs
   ))"

abbreviation
  spies' :: "event list => msg set" where
  "spies' == knows' Spy"

subsubsection{*decomposition of knows into knows' and initState*}

lemma knows_decomp: "knows A evs = knows' A evs Un (initState A)"
by (induct evs, auto split: event.split simp: knows.simps)

lemmas knows_decomp_substI = knows_decomp [THEN ssubst]
lemmas knows_decomp_substD = knows_decomp [THEN sym, THEN ssubst]

lemma knows'_sub_knows: "knows' A evs <= knows A evs"
by (auto simp: knows_decomp)

lemma knows'_Cons: "knows' A (ev#evs) = knows' A [ev] Un knows' A evs"
by (induct ev, auto)

lemmas knows'_Cons_substI = knows'_Cons [THEN ssubst]
lemmas knows'_Cons_substD = knows'_Cons [THEN sym, THEN ssubst]

lemma knows_Cons: "knows A (ev#evs) = initState A Un knows' A [ev]
Un knows A evs"
apply (simp only: knows_decomp)
apply (rule_tac s="(knows' A [ev] Un knows' A evs) Un initState A" in trans)
apply (simp only: knows'_Cons [of A ev evs] Un_ac)
apply blast
done

lemmas knows_Cons_substI = knows_Cons [THEN ssubst]
lemmas knows_Cons_substD = knows_Cons [THEN sym, THEN ssubst]

lemma knows'_sub_spies': "[| evs:p; has_only_Says p; one_step p |]
==> knows' A evs <= spies' evs"
by (induct evs, auto split: event.splits)

subsubsection{*knows' is finite*}

lemma finite_knows' [iff]: "finite (knows' A evs)"
by (induct evs, auto split: event.split simp: knows.simps)

subsubsection{*monotonicity of knows*}

lemma knows_sub_Cons: "knows A evs <= knows A (ev#evs)"
by(cases A, induct evs, auto simp: knows.simps split:event.split)

lemma knows_ConsI: "X:knows A evs ==> X:knows A (ev#evs)"
by (auto dest: knows_sub_Cons [THEN subsetD])

lemma knows_sub_app: "knows A evs <= knows A (evs @ evs')"
apply (induct evs, auto)
apply (simp add: knows_decomp)
apply (rename_tac a b c)
by (case_tac a, auto simp: knows.simps)

subsubsection{*maximum knowledge an agent can have
includes messages sent to the agent*}

primrec knows_max' :: "agent => event list => msg set" where
knows_max'_def_Nil: "knows_max' A [] = {}" |
knows_max'_def_Cons: "knows_max' A (ev # evs) = (
  if A=Spy then (
    case ev of
      Says A' B X => insert X (knows_max' A evs)
    | Gets A' X => knows_max' A evs
    | Notes A' X =>
      if A':bad then insert X (knows_max' A evs) else knows_max' A evs
  ) else (
    case ev of
      Says A' B X =>
      if A=A' | A=B then insert X (knows_max' A evs) else knows_max' A evs
    | Gets A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
    | Notes A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
  ))"

definition knows_max :: "agent => event list => msg set" where
"knows_max A evs == knows_max' A evs Un initState A"

abbreviation
  spies_max :: "event list => msg set" where
  "spies_max evs == knows_max Spy evs"

subsubsection{*basic facts about @{term knows_max}*}

lemma spies_max_spies [iff]: "spies_max evs = spies evs"
by (induct evs, auto simp: knows_max_def split: event.splits)

lemma knows_max'_Cons: "knows_max' A (ev#evs)
= knows_max' A [ev] Un knows_max' A evs"
by (auto split: event.splits)

lemmas knows_max'_Cons_substI = knows_max'_Cons [THEN ssubst]
lemmas knows_max'_Cons_substD = knows_max'_Cons [THEN sym, THEN ssubst]

lemma knows_max_Cons: "knows_max A (ev#evs)
= knows_max' A [ev] Un knows_max A evs"
apply (simp add: knows_max_def del: knows_max'_def_Cons)
apply (rule_tac evs=evs in knows_max'_Cons_substI)
by blast

lemmas knows_max_Cons_substI = knows_max_Cons [THEN ssubst]
lemmas knows_max_Cons_substD = knows_max_Cons [THEN sym, THEN ssubst]

lemma finite_knows_max' [iff]: "finite (knows_max' A evs)"
by (induct evs, auto split: event.split)

lemma knows_max'_sub_spies': "[| evs:p; has_only_Says p; one_step p |]
==> knows_max' A evs <= spies' evs"
by (induct evs, auto split: event.splits)

lemma knows_max'_in_spies' [dest]: "[| evs:p; X:knows_max' A evs;
has_only_Says p; one_step p |] ==> X:spies' evs"
by (rule knows_max'_sub_spies' [THEN subsetD], auto)

lemma knows_max'_app: "knows_max' A (evs @ evs')
= knows_max' A evs Un knows_max' A evs'"
by (induct evs, auto split: event.splits)

lemma Says_to_knows_max': "Says A B X:set evs ==> X:knows_max' B evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

lemma Says_from_knows_max': "Says A B X:set evs ==> X:knows_max' A evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

subsubsection{*used without initState*}

primrec used' :: "event list => msg set" where
"used' [] = {}" |
"used' (ev # evs) = (
  case ev of
    Says A B X => parts {X} Un used' evs
    | Gets A X => used' evs
    | Notes A X => parts {X} Un used' evs
  )"

definition init :: "msg set" where
"init == used []"

lemma used_decomp: "used evs = init Un used' evs"
by (induct evs, auto simp: init_def split: event.split)

lemma used'_sub_app: "used' evs <= used' (evs@evs')"
by (induct evs, auto split: event.split)

lemma used'_parts [rule_format]: "X:used' evs ==> Y:parts {X} --> Y:used' evs"
apply (induct evs, simp)
apply (rename_tac a b)
apply (case_tac a, simp_all)
apply (blast dest: parts_trans)+
done

subsubsection{*monotonicity of used*}

lemma used_sub_Cons: "used evs <= used (ev#evs)"
by (induct evs, (induct ev, auto)+)

lemma used_ConsI: "X:used evs ==> X:used (ev#evs)"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma notin_used_ConsD: "X ~:used (ev#evs) ==> X ~:used evs"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma used_appD [dest]: "X:used (evs @ evs') ==> X:used evs | X:used evs'"
by (induct evs, auto, rename_tac a b, case_tac a, auto)

lemma used_ConsD: "X:used (ev#evs) ==> X:used [ev] | X:used evs"
by (case_tac ev, auto)

lemma used_sub_app: "used evs <= used (evs@evs')"
by (auto simp: used_decomp dest: used'_sub_app [THEN subsetD])

lemma used_appIL: "X:used evs ==> X:used (evs' @ evs)"
by (induct evs', auto intro: used_ConsI)

lemma used_appIR: "X:used evs ==> X:used (evs @ evs')"
by (erule used_sub_app [THEN subsetD])

lemma used_parts: "[| X:parts {Y}; Y:used evs |] ==> X:used evs"
apply (auto simp: used_decomp dest: used'_parts)
by (auto simp: init_def used_Nil dest: parts_trans)

lemma parts_Says_used: "[| Says A B X:set evs; Y:parts {X} |] ==> Y:used evs"
by (induct evs, simp_all, safe, auto intro: used_ConsI)

lemma parts_used_app: "X:parts {Y} ==> X:used (evs @ Says A B Y # evs')"
apply (drule_tac evs="[Says A B Y]" in used_parts, simp, blast)
apply (drule_tac evs'=evs' in used_appIR)
apply (drule_tac evs'=evs in used_appIL)
by simp

subsubsection{*lemmas on used and knows*}

lemma initState_used: "X:parts (initState A) ==> X:used evs"
by (induct evs, auto simp: used.simps split: event.split)

lemma Says_imp_used: "Says A B X:set evs ==> parts {X} <= used evs"
by (induct evs, auto intro: used_ConsI)

lemma not_used_not_spied: "X ~:used evs ==> X ~:parts (spies evs)"
by (induct evs, auto simp: used_Nil)

lemma not_used_not_parts: "[| Y ~:used evs; Says A B X:set evs |]
==> Y ~:parts {X}"
by (induct evs, auto intro: used_ConsI)

lemma not_used_parts_false: "[| X ~:used evs; Y:parts (spies evs) |]
==> X ~:parts {Y}"
by (auto dest: parts_parts)

lemma known_used [rule_format]: "[| evs:p; Gets_correct p; one_step p |]
==> X:parts (knows A evs) --> X:used evs"
apply (case_tac "A=Spy", blast)
apply (induct evs)
apply (simp add: used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="%G. X:parts G" in knows_Cons_substD, safe)
apply (erule initState_used)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto dest: Says_imp_used intro: used_ConsI)

lemma known_max_used [rule_format]: "[| evs:p; Gets_correct p; one_step p |]
==> X:parts (knows_max A evs) --> X:used evs"
apply (case_tac "A=Spy")
apply force
apply (induct evs)
apply (simp add: knows_max_def used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="%G. X:parts G" in knows_max_Cons_substD, safe)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto simp: knows_max'_Cons dest: Says_imp_used intro: used_ConsI)

lemma not_used_not_known: "[| evs:p; X ~:used evs;
Gets_correct p; one_step p |] ==> X ~:parts (knows A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_used)

lemma not_used_not_known_max: "[| evs:p; X ~:used evs;
Gets_correct p; one_step p |] ==> X ~:parts (knows_max A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_max_used)

subsubsection{*a nonce or key in a message cannot equal a fresh nonce or key*}

lemma Nonce_neq [dest]: "[| Nonce n' ~:used evs;
Says A B X:set evs; Nonce n:parts {X} |] ==> n ~= n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

lemma Key_neq [dest]: "[| Key n' ~:used evs;
Says A B X:set evs; Key n:parts {X} |] ==> n ~= n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

subsubsection{*message of an event*}

primrec msg :: "event => msg"
where
  "msg (Says A B X) = X"
| "msg (Gets A X) = X"
| "msg (Notes A X) = X"

lemma used_sub_parts_used: "X:used (ev # evs) ==> X:parts {msg ev} Un used evs"
by (induct ev, auto)

end


theory WellTypedAlt
  imports WTLemma
begin

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

fun well_typed_alt :: "wta_tag \<Rightarrow> pt_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 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 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 r_s1 e tau r_s2 rx = (\<exists> x v tau_x. e = VarExp x v \<and> env (deref_name x v) = Some tau \<and>
    env x = Some tau_x \<and> var_val_type v tau tau_x \<and> leq_use_env (ereq_use_env x tau_x) r_s1 \<and> r_s2 = diff_use_env r_s1 (ereq_use_env x tau_x) \<and>
    rx = diff_use_env (ereq_use_env x tau_x) (ereq_use_env x tau_x))"
| "well_typed_alt PairRule env 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 env r_s1 e1 t1 r_s2 rx1 \<and> well_typed env 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 env r_s1 e tau r_s3 rx = (\<exists> e1 e2 e3 rx' r_s2 rx1 rx2. e = IfExp e1 e2 e3 \<and>
    well_typed env r_s1 e1 BoolTy r_s2 rx' \<and> well_typed env r_s2 e2 tau r_s3 rx1 \<and> well_typed env r_s2 e3 tau r_s3 rx2 \<and>
    rx = comp_use_env rx1 rx2)"
| "well_typed_alt LamRule env 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> x \<notin> ref_vars e \<and>
    well_typed (add_env env x t1) (add_use_env rx 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 env 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 env r_s1 e1 (FunTy t1 tau r a) r_s2 rx1 \<and> well_typed env 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 r_s1 e tau r_s2 rx = (\<exists> r_c. well_typed_alt tag env 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 r_s1 e tau r_s2 rx = (\<exists> rx'. well_typed_alt tag env 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 r_s1 e tau r_s2 rx = (\<exists> r_se r_xe r_ex. well_typed_alt tag env 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 r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> (\<exists> tag. well_typed_alt tag env 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 x1a tau_x)) r_ex" in exI)
      apply (auto)
       apply (rule_tac x="diff_use_env (diff_use_env (ereq_use_env x1a tau_x) (ereq_use_env x1a 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 (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule PairRule))" 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 (rule_tac x="IfRule" in exI)
    apply (auto)
    (* lam case *)
   apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule LamRule))" 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 (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule AppRule))" 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 r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> well_typed env 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)
    (* lam case *)
      apply (rule_tac x="rx" 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


(* Title:   Convert_Monoid_SST.thy
   Author:  Akama Hitoshi
*)

section \<open>Proof of convertion from a Monoid SST to a ordinary SST\<close>

theory Convert_Monoid_SST
  imports Main HOL.Sum_Type "../Core/Update" "../Core/SST" "../Core/Monoid_SST" "../Decomposition/Decompose_Update"
                         "../Type/Monoid_SST_Type" "Convert_Monoid_SST_Def" "Convert_Monoid_SST_Type_Misc"
begin

subsection \<open>Properties\<close>

lemma \<Delta>'_id: "\<Delta>' B (\<alpha>, idU) = \<alpha>"
  by (rule ext, simp add: \<Delta>'_def idU_def resolve_shuffle_def \<iota>_def synthesize_inverse_shuffle Rep_bc_shuffle_inverse)

lemma \<Delta>'_assoc:
  fixes B :: "'k::enum boundedness"
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  assumes assm_k_bounded: "boundedness B k"
  assumes assm_bounded_type: "bctype k msst \<gamma>"
  assumes assm_reachable: "reachable (convert_MSST B msst) (q, \<beta>)"
  shows  "\<Delta>' B (\<beta>, SST.eta_hat msst (q, w) \<bullet> \<psi>) = \<Delta>' B (\<Delta>' B (\<beta>, SST.eta_hat msst (q, w)), \<psi>)"
proof -
  let ?alpha = "Rep_alpha B \<beta>"
  let ?theta = "SST.eta_hat msst (q, w)"
  let ?inner = "(\<lambda>x. \<pi>\<^sub>1 (hat_homU (\<iota> B ?alpha) (?theta x)))"
  have \<Delta>'_assoc_string: "\<pi>\<^sub>1 (hat_homU (\<iota> B ?alpha) (hat_hom ?theta u))
       = \<pi>\<^sub>1 (hat_homU (\<iota> B (\<lambda>y. \<pi>\<^sub>1 (hat_homU (\<iota> B ?alpha) (?theta y)))) u)" for u
  proof (induct u rule: xa_induct)
    case Nil
    then show ?case by (simp add: resolve_shuffle_def idU_def)
  next
    case (Var x xs)
    then show ?case
      by (simp add: resolve_shuffle_distrib hat_homU_append \<iota>_def synthesize_inverse_shuffle)
  next
    case (Alpha a xs)
    then show ?case by (simp add: resolve_shuffle_distrib)
  qed
  have *: "\<forall>x. bounded_shuffle k (?inner x)"
    apply (rule allI)
    apply (rule resolve_bounded)
    apply (rule hat_homU_iota_bounded_copy[OF assms])
    done
  then show ?thesis
    by (intro ext, simp add: \<Delta>'_def compU_apply \<Delta>'_assoc_string Abs_alpha_inverse[OF assms(1) *])
qed

lemma convert_\<delta>_hat:
  fixes B :: "'k::enum boundedness"
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  assumes assm_k_bounded: "boundedness B k"
  assumes assm_bounded_type: "bctype k msst \<gamma>"
  assumes assm_reachable: "reachable (convert_MSST B msst) (q, \<beta>)"
  shows "hat1 (convert_\<delta> B msst) ((q, \<beta>), w)
       = (delta_hat msst (q, w), \<Delta>' B (\<beta>, eta_hat msst (q, w)))"
using assm_reachable proof (induct w arbitrary: q rule: rev_induct)
  case Nil
  then show ?case by (simp add: convert_\<delta>_simp \<Delta>'_id)
next
  case (snoc a w)
  then show ?case
    by (simp add: eta_append convert_\<delta>_simp \<Delta>'_assoc[OF assm_k_bounded assm_bounded_type snoc.prems])
qed

lemma compU_valuate:
  fixes t :: "('y, 'z, 'b) update'"
  fixes \<theta> :: "('w, 'x, 'y + 'b) update'"
  shows "t \<bullet> (valuate o \<theta>) = valuate o (update2hom t \<star> \<theta>)"
proof (rule ext, simp add: compU_apply map_alpha_apply)
  show "hat_hom t (valuate u) = valuate (hat_alpha (update2hom t) u)" for u :: "('x + 'y + 'b) list"
    by (induct u rule: xa_induct, simp_all add: hat_hom_def)
qed

lemma update2hom_map_alpha:
  fixes t :: "('y, 'z, 'b) update'"
  fixes \<theta> :: "('w, 'x, 'b) update'"
  shows "update2hom t \<star> inr_list \<star> \<theta> = inr_list \<star> \<theta>"
proof (rule ext, simp add: map_alpha_def)
  show "hat_alpha (update2hom t) (hat_alpha inr_list w) = hat_alpha inr_list w" for w :: "('x + 'b) list"
    by (induct w rule: xa_induct, simp_all)
qed

lemma hat_homU_map_alpha:
  "update2hom t \<star> hat_homU \<phi> m = hat_homU (map_alpha (update2hom t) o \<phi>) m"
proof (induct m)
  case Nil
  then show ?case by (simp add: map_alpha_def idU_def)
next
  case (Cons a m)
  then show ?case proof (cases a)
    case (Inl z)
    then show ?thesis by (simp add: map_alpha_distrib Cons)
  next
    case (Inr b)
    then show ?thesis by (simp add: map_alpha_distrib Cons update2hom_map_alpha)
  qed
qed

lemma hat_homU_lem: "hat_homU (hat_homU \<phi> o \<theta>) m = hat_homU \<phi> (hat_hom \<theta> m)"
  by (induct m rule: xa_induct, simp_all add: hat_homU_append)

lemma valuate_update_map_alpha:
  fixes \<theta> :: "('y, 'b + 'c) update"
  shows "valuate (valuate (\<theta> x)) = valuate ((retain_right \<star> \<theta>) x)"
proof (simp add: map_alpha_apply)
  show "valuate (valuate u) = valuate (hat_alpha retain_right u)" for u :: "('y + 'b + 'c) list"
  proof (induct u rule: xa_induct)
    case (Alpha a xs)
    then show ?case by (cases a, simp_all)
  qed (simp_all)
qed

lemma retain_right_inr_list_eq_idS: "(retain_right \<odot> inr_list) = idS"
  by (rule ext, simp add: compS_apply idS_def)

lemma retain_right_embed: "retain_right \<odot> Convert_Monoid_SST_Def.embed x = empty_store"
  by (rule ext_prod, simp add: compS_apply)

lemma retain_right_hat_homU_iota_alpha0:
  "retain_right \<star> hat_homU (\<iota> B \<alpha>0) m = concatU (valuate m)"
proof (induct m rule: xa_induct)
  case Nil
  then show ?case by simp
next
  case (Var x xs)
  then show ?case
    by (simp add: map_alpha_distrib \<iota>_def \<alpha>0_def map_alpha_synthesize retain_right_embed synthesize_idU)
next
  case (Alpha a xs)
  then show ?case
    by (simp add: map_alpha_distrib map_alpha_assoc retain_right_inr_list_eq_idS)
qed

lemma iota_alpha0_remove_aux:
  "valuate (valuate (hat_homU (\<iota> B \<alpha>0) m x'))
 = valuate (concatU (valuate m) x')"
  by (simp add: valuate_update_map_alpha retain_right_hat_homU_iota_alpha0)

lemma iota_alpha0_remove:
  "valuate (valuate (hat_hom (hat_homU (\<iota> B \<alpha>0) m) (hat_alpha inr_list u)))
 = valuate (hat_hom (concatU (valuate m)) u)"
  by (induct u rule: xa_induct, simp_all add: iota_alpha0_remove_aux)

lemma H'_embed: "H' B (\<beta>, \<theta>) \<bullet> Convert_Monoid_SST_Def.embed x = \<pi>\<^sub>2 B (hat_homU (\<iota> B (Rep_alpha B \<beta>)) (\<theta> x))"
  by (auto simp add: compU_apply H'_def)

(* SST.eta_hat msst (q, w) *)
lemma map_alpha_H'_iota_\<Delta>:
  fixes x :: "'x"
  fixes \<alpha> :: "'x \<Rightarrow> 'y::enum shuffle"
  fixes \<theta> :: "('x, ('y, 'b) update) update"
  assumes "boundedness B k"
  assumes "bctype k msst \<gamma>"
  assumes "reachable (convert_MSST B msst) (q, \<beta>)"
  shows "map_alpha (update2hom (H' B (\<beta>, SST.eta_hat msst (q, w)))) o \<iota> B (Rep_alpha B (\<Delta>' B (\<beta>, SST.eta_hat msst (q, w))))
       = hat_homU (\<iota> B (Rep_alpha B \<beta>)) o SST.eta_hat msst (q, w)"
  apply (rule ext)
  apply (simp add: \<iota>_def map_alpha_synthesize compU_apply hat_hom_def[symmetric] H'_embed \<Delta>'_def update2hom_compS_compU)
  apply (simp only: resolve_shuffle_hat_homU_inverse[OF assms])
  apply (rule resolve_inverse)
  apply (rule assms(1))
  apply (rule hat_homU_iota_bounded_copy)
  apply (rule assms)+
  done

lemma hat_homU_iota:
  assumes "boundedness B k"
  assumes "bctype k msst \<gamma>"
  assumes "reachable (convert_MSST B msst) (q, \<beta>)"
  shows "hat_homU (\<iota> B (Rep_alpha B \<beta>)) (hat_hom (SST.eta_hat msst (q, w)) u)
       = update2hom (H' B (\<beta>, SST.eta_hat msst (q, w))) \<star> hat_homU (\<iota> B (Rep_alpha B (\<Delta>' B (\<beta>, SST.eta_hat msst (q, w))))) u"
  by (simp add: hat_homU_map_alpha hat_homU_lem map_alpha_H'_iota_\<Delta>[OF assms])

lemma H'_assoc:
  fixes \<beta> :: "'x \<Rightarrow> ('k::enum, 'y::enum) bc_shuffle"
  assumes "boundedness B k"
  assumes "bctype k msst \<gamma>"
  assumes "reachable (convert_MSST B msst) (q, \<beta>)"
  shows "H' B (\<beta>, SST.eta_hat msst (q, w) \<bullet> \<psi>)
       = H' B (\<beta>, SST.eta_hat msst (q, w)) \<bullet> H' B (\<Delta>' B (\<beta>, SST.eta_hat msst (q, w)), \<psi>)"
proof -
  have "\<pi>\<^sub>2 B (hat_homU (\<iota> B (Rep_alpha B \<beta>)) (hat_hom (SST.eta_hat msst (q, w)) u)) (y, e)
       = (H' B (\<beta>, SST.eta_hat msst (q, w))
         \<bullet> \<pi>\<^sub>2 B (hat_homU (\<iota> B (Rep_alpha B (\<Delta>' B (\<beta>, SST.eta_hat msst (q, w))))) u)) (y, e)" for u y e
    by (simp add: hat_homU_iota[OF assms] map_alpha_resolve_store)
  then have "H' B (\<beta>, SST.eta_hat msst (q, w) \<bullet> \<psi>) (x, y, e)
           = (H' B (\<beta>, SST.eta_hat msst (q, w)) \<bullet> H' B (\<Delta>' B (\<beta>, SST.eta_hat msst (q, w)), \<psi>)) (x, y, e)" for x y e
    by (simp add: compU_apply H'_simp2)
  then show ?thesis by auto
qed

lemma convert_\<eta>_hat_gt_0:
  fixes msst :: "('q, 'x, 'y::enum, 'a, 'b) MSST"
  fixes \<beta> :: "'x \<Rightarrow> ('k::enum, 'y::enum) bc_shuffle"
  assumes "boundedness B k"
  assumes "bctype k msst \<gamma>"
  assumes reach: "reachable (convert_MSST B msst) (q, \<beta>)"
  assumes len: "0 < length w"
  shows   "SST.hat2 (convert_\<delta> B msst) (convert_\<eta> B msst) ((q, \<beta>), w)
         = H' B (\<beta>, eta_hat msst (q, w))"
using reach len proof (induct w arbitrary: q \<beta>)
  case Nil
  then show ?case by simp
next
  case (Cons a w)
  then show ?case proof (cases "length w")
    case 0 then show ?thesis by (simp add: eta_convert_MSST_simp convert_\<eta>_simp)
  next
    case (Suc nat) then show ?thesis proof -
      let ?qb' = "convert_\<delta> B msst ((q, \<beta>), a)"
      have l: "0 < length w" by (simp add: Suc)
      have r: "reachable (convert_MSST B msst) (fst ?qb', snd ?qb')"
        by (simp add: reachable_delta[OF Cons.prems(1)] delta_convert_MSST_simp[symmetric])
      have hat: "SST.eta msst (q, a) = SST.eta_hat msst (q, [a])" by (simp add:)
      show ?thesis
        apply (simp add: Cons.hyps[OF r l, simplified])
        apply (simp add: delta_convert_MSST_simp eta_convert_MSST_simp convert_\<eta>_simp convert_\<delta>_simp)
        apply (simp only: hat)
        apply (rule H'_assoc[symmetric, OF assms(1-2) Cons.prems(1)])
        done
    qed
  qed
qed

lemma list_all_isl_valuate:
  assumes "list_all isl bs"
  shows "valuate bs = []"
  using assms by (induct bs rule: xa_induct, simp_all)

lemma valuate_H'_Nil_var: "valuate (H' B (\<alpha>, idU) (x, y, k)) = []"
proof (simp add: H'_def idU_def \<iota>_def)
  let ?beta = "Rep_bc_shuffle (\<alpha> x)"
  let ?m = "\<pi>\<inverse> B (Rep_bc_shuffle (\<alpha> x), embed x)"
  have "\<forall>y k. list_all isl (embed x (y, k))"
    by simp
  then have "\<forall>y. list_all isl (valuate (?m y))"
    by (rule synthesize_preserve_prop_on_string)
  then have "list_all isl (\<pi>\<^sub>2 B ?m (y, k))"
    using resolve_store_preserve_prop_on_string by blast
  then show "valuate (\<pi>\<^sub>2 B ?m (y, k)) = []"
    by (rule list_all_isl_valuate)
qed

lemma valuate_H'_Nil: "valuate (hat_hom (H' B (\<alpha>, idU)) u) = valuate u"
proof (induct u rule: xa_induct)
  case Nil
  then show ?case by simp
next
  case (Var x xs)
  then show ?case by (cases x, simp add: valuate_H'_Nil_var)
next
  case (Alpha a xs)
  then show ?case by simp
qed

lemma convert_\<eta>_hat_valuate:
  assumes "boundedness B k"
  assumes "bctype k msst \<gamma>"
  assumes "reachable (convert_MSST B msst) (q, \<alpha>)"
  shows   "valuate o (SST.hat2 (convert_\<delta> B msst) (convert_\<eta> B msst) ((q, \<alpha>), w) \<bullet> \<phi>)
         = valuate o (H' B (\<alpha>, eta_hat msst (q, w)) \<bullet> \<phi>)"
proof (cases "w")
  case Nil
  show ?thesis by (rule ext, simp add: Nil valuate_H'_Nil compU_apply)
next
  case (Cons _ _)
  then have l: "0 < length w" by simp
  then show ?thesis by (simp add: convert_\<eta>_hat_gt_0[OF assms])
qed

lemma reach0: "reachable (convert_MSST B msst) (initial msst, Abs_alpha B \<alpha>0)"
  by (simp add: reachable_initial initial_convert_MSST_simp[symmetric])

theorem MSST_can_convert:
  assumes assm_k_bounded: "boundedness B k"
  assumes assm_bounded_type: "bctype k msst \<gamma>"
  shows "SST.run (convert_MSST B msst) w = Monoid_SST.run msst w"
proof (cases "final msst (hat1 (delta msst) (initial msst, w))")
  case None
  show ?thesis
    by (simp add: convert_MSST_def SST.run_def Monoid_SST.run_def convert_final_def convert_\<delta>_hat[OF assms reach0] None)
next
  case Some1: (Some m)
  show ?thesis proof (cases "final_string msst (hat1 (delta msst) (initial msst, w))")
    case None
    then show ?thesis
      by (simp add: convert_MSST_def SST.run_def Monoid_SST.run_def convert_final_def convert_\<delta>_hat[OF assms reach0] Some1)
  next
    case Some2: (Some u)
    show ?thesis
      apply (simp add: SST.run_def Monoid_SST.run_def initial_convert_MSST_simp final_convert_MSST_simp)
      apply (simp add: convert_final_def convert_\<delta>_hat[OF assms reach0] Some1 Some2
                 initial_convert_MSST_simp delta_convert_MSST_simp eta_convert_MSST_simp convert_\<eta>_hat_valuate[OF assms reach0] del: comp_apply)
      apply (simp add: compU_valuate del: comp_apply)
      apply (simp add: map_alpha_distrib del: comp_apply)
      apply (simp add: hat_homU_map_alpha del: comp_apply)
      apply (simp add: update2hom_map_alpha del: comp_apply)
      apply (simp add: map_alpha_H'_iota_\<Delta>[OF assms reach0] del: comp_apply)
      apply (simp add: hat_homU_lem)
      apply (simp add: iota_alpha0_remove compU_apply map_alpha_apply)
      done
  qed
qed

hide_fact reach0

end