theory RB_Relaxed_mike_v2 imports RCU_Lems
begin

datatype F = B | W | Q | R
datatype Pointer = Head | Tail

consts n :: nat   (*size of buffer, input*)
consts N :: nat   (*number of Arr\<^sub>W entries*)

(*(Wr T u t b \<sigma>)*)
(*
lemma pval_val:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
  and "ts = getTS \<sigma> w"
shows "\<not> [x \<approx>\<^sub>t u] (write_trans t b w v \<sigma> ts) "
  sorry
*)

lemma pval_val_same:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v t b \<sigma>)"
  using assms
  apply (simp add: p_obs_def visible_writes_def value_def write_trans_def)
  apply(simp add: rev_app_def update_modView_def update_mods_def update_thrView_def update_wa_def)
  apply safe
  using w_in_writes_on_var apply blast
  defer
  apply (simp add: getVWNC_var)
   apply (simp add: getVWNC_var)
  apply(case_tac "(a, ba)
       \<in> writes_on \<sigma> x")
  apply (smt dual_order.strict_trans getTS_w_greater_tst_w getVWNC_in_visible_writes le_neq_trans less_le_not_le mem_Collect_eq visible_writes_def)
proof -
fix a :: nat and ba :: rat
  assume a1: "(a, ba) \<in> writes_on (\<sigma> \<lparr>thrView := (thrView \<sigma>) (t := (thrView \<sigma> t) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> t (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) := (thrView \<sigma> t) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> t (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> t (var w))) := True)\<rparr>) (var w)"
  assume a2: "x = var w"
  assume a3: "(a, ba) \<notin> writes_on \<sigma> x"
  assume a4: "ba \<noteq> getTS \<sigma> (getVWNC \<sigma> t (var w))"
  have f5: "\<forall>s n p. var p = n \<and> p \<in> surrey_state.writes (s::surrey_state) \<or> p \<notin> writes_on s n"
    using writes_on_def by force
  have "\<forall>s n p. writes_on (write_available_update p (s::surrey_state)) n = writes_on s n"
    by (metis (no_types) surrey_state.select_convs(1) surrey_state.surjective surrey_state.update_convs(5) writes_on_def)
  then have f6: "(a, ba) \<in> writes_on (\<sigma> \<lparr>thrView := (thrView \<sigma>) (t := (thrView \<sigma> t) (x := (x, getTS \<sigma> (getVWNC \<sigma> t x)))), modView := (modView \<sigma>) ((x, getTS \<sigma> (getVWNC \<sigma> t x)) := (thrView \<sigma> t) (x := (x, getTS \<sigma> (getVWNC \<sigma> t x)))), mods := (mods \<sigma>) ((x, getTS \<sigma> (getVWNC \<sigma> t x)) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (x, getTS \<sigma> (getVWNC \<sigma> t x)) (surrey_state.writes \<sigma>)\<rparr>) x"
    using a2 a1 by blast
  have f7: "\<forall>s f. surrey_state.writes (writes_update f (s::surrey_state)) = f (surrey_state.writes s)"
    by auto
  have f8: "var (a, ba) = x"
    using f6 f5 by meson
  have "(a, ba) \<in> surrey_state.writes \<sigma>"
    using f7 f6 f5 a4 a2 by (metis insert_iff snd_conv)
  then show False
    using f8 a3 writes_on_def by force
qed

lemma pval_val_other:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
  and "t\<noteq>s"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v s b \<sigma>)"
  using assms apply simp
  apply (simp add: p_obs_def visible_writes_def value_def write_trans_def)
    apply(simp add: rev_app_def update_modView_def update_mods_def update_thrView_def update_wa_def)
  apply safe
  using w_in_writes_on_var
  apply (simp add: w_in_writes_on_var getVWNC_var)
  apply (simp add: getVWNC_var)

  apply(case_tac "(a, ba)
       \<in> writes_on \<sigma> x")
  apply (smt dual_order.strict_trans getTS_w_greater_tst_w getVWNC_in_visible_writes le_neq_trans less_le_not_le mem_Collect_eq visible_writes_def)
proof -
  fix a :: nat and ba :: rat
  assume a1: "ba \<noteq> getTS \<sigma> (getVWNC \<sigma> s (var w))"
  assume a2: "(a, ba) \<in> writes_on (\<sigma> \<lparr>thrView := (thrView \<sigma>) (s := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := True)\<rparr>) (var w)"
  assume a3: "(a, ba) \<notin> writes_on \<sigma> x"
  assume a4: "x = var w"
  have "(a, ba) \<in> \<lbrace>\<acute>var = var w \<and> \<acute>(\<in>) (surrey_state.writes (\<sigma> \<lparr>thrView := (thrView \<sigma>) (s := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := True)\<rparr>))\<rbrace>"
    using a2 writes_on_def by blast
  then have f5: "var (a, ba) = var w \<and> (a, ba) \<in> surrey_state.writes (\<sigma> \<lparr>thrView := (thrView \<sigma>) (s := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), modView := (modView \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := (thrView \<sigma> s) (var w := (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))))), mods := (mods \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := \<lparr>val = v, is_releasing = b\<rparr>), writes := insert (var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) (surrey_state.writes \<sigma>), write_available := (write_available \<sigma>) ((var w, getTS \<sigma> (getVWNC \<sigma> s (var w))) := True)\<rparr>)"
    by blast
  then have "(a, ba) \<notin> surrey_state.writes \<sigma>"
    using a4 a3 writes_on_def by fastforce
  then show False
    using f5 a1 by simp
qed

lemma pval_val:
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v t' b \<sigma>)"
  using assms apply (cases "t=t'")
  using pval_val_same apply blast
  using pval_val_other by blast

lemma pval_val_outside:
  assumes "wfs \<sigma>"
  and "N\<in> \<nat>"
  and "\<forall>j.[x \<approx>\<^sub>t j] \<sigma> \<longrightarrow> j<N"
  and "\<forall>k. k<N \<longrightarrow> [x \<approx>\<^sub>t k] \<sigma>"
  and "u\<in>\<nat> \<and> u<N"
shows "\<forall>z.(z>N\<longrightarrow>\<not>[x \<approx>\<^sub>t z] (Wr x u t' b \<sigma>))"
  using assms apply (cases "t=t'")
  apply (metis fst_conv not_less_iff_gr_or_eq pval_val)
  by (metis fst_conv not_less_iff_gr_or_eq pval_val)

lemma pval_val_outside_2:
  assumes "wfs \<sigma>"
  and "N \<in> \<nat>"
  and "[x =\<^sub>t 0] \<sigma>"
  and "u \<noteq> 0"
shows "\<exists>i.(([x =\<^sub>t i] (Wr x u t b \<sigma>))\<or>([x =\<^sub>t i] (Wr x 0 t' b \<sigma>)))"
  using assms apply (cases "t=t'")
  using OpSem_ProofRules.ext_d_obs_d_obs apply blast
  using OpSem_ProofRules.ext_d_obs_d_obs by blast

lemma pval_val_outside_3:
  assumes "wfs \<sigma>"
  and "N \<in> \<nat>"
  and "[x =\<^sub>t 0] \<sigma>"
  and "u \<noteq> 0"
 shows  "\<exists>i.(([x =\<^sub>t i] (Wr x u t b \<sigma>)\<and> i\<noteq>0)\<or>(([x =\<^sub>t i] (Wr x 0 t b \<sigma>))))"
  using OpSem_ProofRules.ext_d_obs_d_obs assms(1) assms(3) by blast

lemma pval_val_outside_4:
  assumes "wfs \<sigma>"
  and "N \<in> \<nat>"
  and "[x =\<^sub>t 0] \<sigma>"
 shows  "\<exists>i.(([x =\<^sub>t i] (Wr x 3 t b \<sigma>)\<and> i\<noteq>0)\<or>(([x =\<^sub>t i] (Wr x 0 t b \<sigma>))))\<longrightarrow>(i+1=1 \<or> i+1=4)"
  using add_cancel_left_left by blast

(*
  assumes "wfs \<sigma>"
  and "\<not> [x \<approx>\<^sub>t u] \<sigma>"
  and "u \<noteq> v"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t u] (Wr x v t b \<sigma>)"

lemma pval_val_all:
  assumes "wfs \<sigma>"
  and "\<forall>i. i > k \<longrightarrow> \<not> [x \<approx>\<^sub>t i] \<sigma>"
  and "k < j"
  and "u \<le> k"
  and "var w = x"
shows "\<not> [x \<approx>\<^sub>t j] (Wr x v t b \<sigma>) "
  using assms

  using pval_val sledgehammer
*)

consts
  H :: L
  T :: L

record LB =
  hW ::  V               (*local copy of W*)
  tW ::  V               (*local copy of W*)
  q :: "(nat \<times> nat) list" (*for now assume well synchronised, need to think about weak memory *)
  tempR :: "(nat \<times> nat)"          (*local copy of word by R*)

  tloc :: V
  Data:: "nat  \<Rightarrow> nat"     (*returns a word Data_i*)
  countW :: nat  (* the index of the next element of Data to be written  *)
  countR :: nat  (* how many words from Data the read has read or reading (i.e., retrieved)  *)

  ownD :: "nat \<Rightarrow> F" (* ownership of data indices *)
  ownB :: "nat \<Rightarrow> F" (* ownership of bytes in buffer *)
  (* tries :: nat *)
  oom :: bool       (*signals W that it was OOM*)
  \<sigma> :: surrey_state

definition "global s \<equiv> wfs s \<and> H \<noteq> T"

lemmas opsemsyntax [simp] =  global_def
lemmas defs_del [simp del] =  Rd_def Let_def Wr_def Upd_def st_rd_def val_rd_def

(* thread 2 is the writer *)
(* thread 3 is the reader *)

(* Omit tries *)
(* Finish queueu + reader *)

(* We need this one to hold at minimum *)
definition "arrayInv s \<equiv> \<forall>i. (i<countR s \<longrightarrow> ownD s i = R)\<and> (countR s \<le> i \<and> i < countW s \<longrightarrow> ownD s i = B) \<and> (countW s \<le> i \<and> i < n \<longrightarrow> ownD s i = W) "

definition "q_entries_bounded s \<equiv> (\<forall>i. i < length(q s) \<longrightarrow> (fst(q s!i)+snd(q s!i)\<le>N)\<and>snd(q s!i)>0)"
definition "tempR_bounded s \<equiv> fst (tempR s) + snd (tempR s) \<le> N"
definition "counter_q_rel s \<equiv> (countW s-countR s=length(q s))"
definition "con_assms s  \<equiv>   0 < N \<and> 0<n \<and> (countR s\<le>countW s) \<and> (countW s\<le>n)
                             \<and> (\<forall>i.(i<n)\<longrightarrow>Data s i\<le>N \<and> Data s i>0)"
(*new
(typically)
\forall x . P(x) \<longrightarrow> Q(x)
\exists x . P(x) \<and> Q(x)

[H =\<^sub>2 i] means thread 2 sees the last write to H and this has value i.
[H \<approx>\<^sub>2 i] means that thread 2 can see the value i.
*)
definition "bounded_pointers s \<equiv> ((\<forall>i. i > N \<longrightarrow> \<not>[H \<approx>\<^sub>2 i] (\<sigma> s)))\<and>
                                 ((\<forall>j. j > N \<longrightarrow> \<not>[T \<approx>\<^sub>2 j] (\<sigma> s)))"

definition "basic_pointer_movement s \<equiv> 0\<le>hW s\<and> hW s\<le>N \<and> 0\<le>tW s\<and> tW s\<le>N"

definition "collection s \<equiv> arrayInv s \<and> q_entries_bounded s
                          \<and>tempR_bounded s \<and>counter_q_rel s \<and> con_assms s
                          \<and> bounded_pointers s \<and> basic_pointer_movement s"

definition "init s \<equiv>
                     [T =\<^sub>2 0] (\<sigma> s) \<and> [H =\<^sub>2 0] (\<sigma> s) \<and> [T =\<^sub>3 0] (\<sigma> s) \<and> (q s = []) \<and> (hW s = 0) \<and> (tW s = 0)
                        \<and> (\<forall>l. (l<n) \<longrightarrow>  ((Data s l > 0)\<and>(Data s l \<le> N)))
                        \<and> (\<forall>i. (i<n) \<longrightarrow>  ownD s i = W)
                        \<and> (\<forall>i. (i\<le>N) \<longrightarrow>  ownB s i = B)
                        \<and> (countW s = 0) \<and> (countR s = 0)
                        \<and> (tempR s = (0,0)) \<and> \<not> oom s "

definition "grd1 s \<equiv> (tW s = hW s) \<and> (Data s (countW s) \<le> N) "
definition "grd2 s \<equiv> (tW s > hW s) \<and> (Data s (countW s) < (tW s - hW s)) "
definition "grd3 s \<equiv> tW s < hW s "
definition "grd4 s \<equiv> Data s (countW s) \<le> N - hW s "
definition "grd5 s \<equiv> Data s (countW s) < tW s "
definition "no_space_for_word s \<equiv> (grd1 s \<longrightarrow> \<not>(Data s (countW s) \<le> N))\<and>
                                  (grd2 s \<longrightarrow> \<not>(Data s (countW s) < (tW s - hW s)))\<and>
                                  (grd3 s \<longrightarrow> \<not>(Data s (countW s) \<le> N - hW s \<or> Data s (countW s) < tW s))"

lemmas main_invariant_lemmas = collection_def arrayInv_def q_entries_bounded_def
                                      counter_q_rel_def tempR_bounded_def con_assms_def
                                      init_def bounded_pointers_def basic_pointer_movement_def
                                      pval_val_same pval_val_other pval_val
lemmas guards = grd1_def grd2_def grd3_def grd4_def grd5_def no_space_for_word_def

lemma LoadBuffering:
 "\<parallel>-   \<lbrace> global \<acute>\<sigma>  \<and> \<acute>collection  \<and> \<acute>init \<rbrace>
COBEGIN
\<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> \<not> \<acute>oom \<and> \<acute>init\<rbrace>
  WHILE \<acute>countW < n
   INV \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> (\<exists> i. [H =\<^sub>2 i]\<acute>\<sigma>)\<rbrace>
   DO
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> (\<exists> i. [H =\<^sub>2 i]\<acute>\<sigma>) \<and> \<acute>countW < n\<rbrace> \<comment> \<open>A1\<close>
      <\<acute>hW \<leftarrow>\<^sub>2 H\<acute>\<sigma>> ;;
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n\<rbrace>
      <\<acute>tW \<leftarrow>\<^sub>2 T\<acute>\<sigma>> ;;
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n\<rbrace>
      IF \<acute>grd1 \<comment> \<open>A2\<close>
      THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd1 \<rbrace> \<comment> \<open>A3\<close>
            \<langle><T :=\<^sub>2 0 \<acute>\<sigma>>,, <T :=\<^sub>3 0 \<acute>\<sigma>>\<rangle> ;; \<comment> \<open>This might not need to be releasing\<close>
            \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd1 \<rbrace>
            \<langle><H :=\<^sub>2 (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>hW := 0 ,, \<acute>oom := False ,,
              (\<acute>ownB := ( \<lambda> x. if 0\<le> x \<and> x < (\<acute>Data \<acute>countW) then W else \<acute>ownB x ))\<rangle>
      ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<not>\<acute>grd1 \<rbrace>
            IF \<acute>grd2
            THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd2\<rbrace> \<comment> \<open>A4\<close>
                \<langle><H :=\<^sub>2 \<acute>hW + (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>oom := False ,,
                  (\<acute>ownB := ( \<lambda> x. if \<acute>hW \<le> x \<and> x < (\<acute>hW + (\<acute>Data \<acute>countW)) then W else \<acute>ownB x ))\<rangle>
            ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<not>\<acute>grd1 \<and> \<not>\<acute>grd2\<rbrace>
                 IF \<acute>grd3
                 THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<rbrace> \<comment> \<open>A5\<close>
                      IF \<acute>grd4
                      THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<and> \<acute>grd4 \<rbrace> \<comment> \<open>A6\<close>
                      \<langle><H :=\<^sub>2 \<acute>hW + (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>oom := False ,,
                         (\<acute>ownB := ( \<lambda> x. if \<acute>hW \<le> x \<and> x < (\<acute>hW + (\<acute>Data \<acute>countW)) then W else \<acute>ownB x ))\<rangle>
                      ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<and> \<not>\<acute>grd4 \<rbrace>
                            IF \<acute>grd5
                            THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>grd3 \<and> \<acute>grd5 \<rbrace> \<comment> \<open>A7\<close>
                              \<langle><H :=\<^sub>2 (\<acute>Data \<acute>countW) \<acute>\<sigma>> ,, \<acute>hW := 0 ,, \<acute>oom := False ,,
                                (\<acute>ownB := ( \<lambda> x. if ((0 \<le> x \<and> x < (\<acute>Data \<acute>countW))\<or> x\<ge>T)\<and>x\<noteq>N then W else \<acute>ownB x ))\<rangle>
                            ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>no_space_for_word\<rbrace> \<comment> \<open>A8\<close>
                                \<langle>\<acute>oom := True\<rangle>
                                  \<comment> \<open>OOM\<close>
                            FI
                      FI
                 ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>countW < n \<and> \<acute>no_space_for_word\<rbrace>
                      \<langle>\<acute>oom := True\<rangle>
                      \<comment> \<open>OOM\<close>
                 FI
           FI
     FI;;
     \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection
        \<and> ((\<acute>oom=False \<and> [H =\<^sub>2 (\<acute>hW+(\<acute>Data \<acute>countW))]\<acute>\<sigma> ) \<comment> \<open>\<and> \<acute>hW  + \<acute>Data (\<acute>countW) \<le> N\<close>
             \<or> (\<acute>oom=True \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>no_space_for_word)) \<and> \<acute>countW < n\<rbrace>
     IF \<acute>oom=True
     THEN \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> [H =\<^sub>2 \<acute>hW]\<acute>\<sigma> \<and> \<acute>no_space_for_word \<and> \<acute>countW < n\<rbrace> \<comment> \<open>OK\<close>
          SKIP
     ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection  \<and> \<acute>countW < n \<and> [H =\<^sub>2 (\<acute>hW+(\<acute>Data \<acute>countW))]\<acute>\<sigma>\<rbrace>
          \<langle>\<acute>q := \<acute>q @ [(\<acute>hW, (\<acute>Data \<acute>countW))],,
           \<acute>ownD := (\<lambda> x. if x = \<acute>countW then B else \<acute>ownD x),,
           \<acute>ownB := (\<lambda> x. if (\<acute>ownB x = W) then Q else \<acute>ownB x),,
           \<acute>countW := (\<acute>countW+1)\<rangle>
     FI
   OD
    \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countW = n\<rbrace>

\<parallel>
 \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>tempR = (0, 0) \<rbrace>
  WHILE \<acute>countR < n
  INV \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>tempR=(0,0) \<rbrace>
  DO  \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countR < n \<and> \<acute>tempR=(0,0) \<rbrace>
      IF \<acute>countR < \<acute>countW THEN
                \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countR < \<acute>countW \<and> \<acute>tempR=(0,0) \<rbrace> \<comment> \<open>retrieve from Q, dequeue\<close>
                \<langle> \<acute>tempR  := (fst(hd \<acute>q),(snd(hd \<acute>q))) ,,
                    \<acute>ownD := (\<lambda> x. if x = \<acute>countR then R else \<acute>ownD x),,
                    \<acute>countR := \<acute>countR+1,,
                    ( IF \<exists>i.(i<(fst(hd \<acute>q)+snd(hd \<acute>q)) \<and> [T =\<^sub>3 i] \<acute>\<sigma>) THEN (\<acute>ownB := ( \<lambda> x. if i \<le> x \<and> x < (fst(hd \<acute>q)+(snd(hd \<acute>q))) then R else \<acute>ownB x ))
                      ELSE (\<acute>ownB := ( \<lambda> x. if i > x \<and> x \<le> (fst(hd \<acute>q)+(snd(hd \<acute>q)))\<or>(x=N) then \<acute>ownB x else R ))FI),,
                     \<acute>q := (tl \<acute>q) \<rangle>;;
                    \<lbrace> global \<acute>\<sigma> \<and>\<acute>collection \<and> \<acute>countR \<le> \<acute>countW  \<and> \<acute>tempR\<noteq>(0,0)\<rbrace> \<comment> \<open>Push T\<close>
                    \<langle><T :=\<^sub>3 (fst \<acute>tempR + snd \<acute>tempR) \<acute>\<sigma> >
                    ,, \<acute> tempR := (0,0),,
                   \<acute>ownB := (\<lambda> x. if \<acute>ownB x = R then B else \<acute>ownD x) \<rangle>
      ELSE
      \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>tempR=(0,0) \<and> \<acute>countR < n\<rbrace>
      SKIP
      FI
  OD
\<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countR = n\<rbrace>

COEND
  \<lbrace> global \<acute>\<sigma> \<and> \<acute>collection \<and> \<acute>countW = n \<and> \<acute>countR = n\<rbrace>

"
  apply (oghoare)
  apply ((simp add: main_invariant_lemmas Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff; force)+)[4]
  apply ((simp add: guards main_invariant_lemmas Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)[1]
  apply (metis OpSem_ProofRules.d_obs_read_value OpSem_ProofRules.ext_d_obs_rd_pres d_obs_implies_p_obs le_less_linear)
  apply auto[1]
  apply ((simp add: guards main_invariant_lemmas Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)[1]
  apply clarsimp
  apply (meson not_less not_pobs_contradiction)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  using pval_val apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[3]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply auto[3]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis)
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply auto[1]
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply (metis (no_types, lifting) Suc_diff_le d_obs_implies_p_obs fst_eqD le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply auto[1]
  apply ((simp add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)+)
  apply clarsimp
  apply (simp_all add: main_invariant_lemmas guards Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff)
          (*129*)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred hd_conv_nth length_0_conv length_tl less_numeral_extra(3) nat.inject nth_tl snd_conv zero_less_diff)
  apply clarify
  using pval_val apply auto[1]
  using OpSem_ProofRules.p_obs_contradiction apply blast
  apply clarify
  apply linarith
  apply (metis (no_types, lifting) less_numeral_extra(3) )
  using pval_val apply auto[1]
  apply clarify
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (intro conjI impI)
  apply (metis getVWNC_var leD pval_val)
  apply (metis OpSem_ProofRules.ext_write_other_pres_d_obs)
  apply clarify
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (intro conjI impI)
  apply (metis getVWNC_var leD pval_val)
  apply (metis OpSem_ProofRules.ext_write_other_pres_d_obs)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply linarith
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply linarith
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply linarith
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply clarify
  apply blast
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (intro conjI impI)
  apply (metis getVWNC_var leD pval_val)
  apply (metis OpSem_ProofRules.ext_write_other_pres_d_obs)
  apply clarify
  apply blast
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply (metis getVWNC_var leD pval_val)
  apply (smt One_nat_def Suc_diff_Suc Suc_mono Suc_pred diff_is_0_eq hd_conv_nth leD length_0_conv length_tl nat_less_le nat.inject nth_tl zero_less_diff)
  apply clarify
  apply (meson not_less not_pobs_contradiction)
  apply (meson not_less not_pobs_contradiction)
  apply (metis OpSem_ProofRules.write_pres_wfs dual_order.strict_trans fst_eqD leD pval_val_other pval_val_same)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis OpSem_ProofRules.write_pres_wfs dual_order.strict_trans fst_eqD leD pval_val_other pval_val_same)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis OpSem_ProofRules.write_pres_wfs dual_order.strict_trans fst_eqD leD pval_val_other pval_val_same)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis OpSem_ProofRules.write_pres_wfs dual_order.strict_trans fst_eqD leD pval_val_other pval_val_same)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis OpSem_ProofRules.write_pres_wfs dual_order.strict_trans fst_eqD leD pval_val_other pval_val_same)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (meson le_less_linear not_pobs_contradiction)
  apply (metis OpSem_ProofRules.write_pres_wfs dual_order.strict_trans fst_eqD leD pval_val_other pval_val_same)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply clarify
  apply (smt OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD le_less_trans less_diff_conv less_imp_le_nat)
  apply (metis Nat.le_diff_conv2 OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs add.commute leD)
  apply (metis OpSem_ProofRules.d_obs_not_p_obs OpSem_ProofRules.ext_d_obs_d_obs OpSem_ProofRules.write_pres_wfs leD)
  apply (metis Suc_diff_le d_obs_implies_p_obs fst_conv le_less_linear less_antisym nth_append nth_append_length snd_conv)
  apply (meson le_less_linear not_pobs_contradiction)
  by simp

(*(simp add: Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff )?)*)


theory TTreeImplCardinalitySafe
imports TTreeImplCardinality TTreeAnalysisSpec CardinalityAnalysisSpec
begin

lemma pathsCard_paths_nxt:  "pathsCard (paths (nxt f x)) \<sqsubseteq> record_call x\<cdot>(pathsCard (paths f))"
  apply transfer
  apply (rule pathsCard_below)
  apply auto
  apply (erule below_trans[OF _ monofun_cfun_arg[OF paths_Card_above], rotated]) back
  apply (auto intro: fun_belowI simp add: record_call_simp two_pred_two_add_once)
  done

lemma pathsCards_none: "pathsCard (paths t) x = none \<Longrightarrow> x \<notin> carrier t"
  by transfer (auto dest: pathCards_noneD)

lemma const_on_edom_disj: "const_on f S empty \<longleftrightarrow> edom f \<inter> S = {}"
  by (auto simp add: empty_is_bottom edom_def)

context TTreeAnalysisCarrier
begin
  lemma carrier_Fstack: "carrier (Fstack as S) \<subseteq> fv S"
    by (induction S rule: Fstack.induct)
       (auto simp add: empty_is_bottom[symmetric] carrier_Fexp dest!: subsetD[OF Aexp_edom])

  lemma carrier_FBinds: "carrier ((FBinds \<Gamma>\<cdot>ae) x) \<subseteq> fv \<Gamma>"
  apply (simp add: Texp.AnalBinds_lookup)
  apply (auto split: option.split simp add: empty_is_bottom[symmetric] )
  apply (case_tac "ae x")
  apply (auto simp add: empty_is_bottom[symmetric] carrier_Fexp dest!: subsetD[OF Aexp_edom])
  by (metis (poly_guards_query) contra_subsetD domA_from_set map_of_fv_subset map_of_SomeD option.sel)
end

context TTreeAnalysisSafe
begin

  sublocale CardinalityPrognosisShape prognosis
  proof
    fix \<Gamma> :: heap and ae ae' :: AEnv and u e S as
    assume "ae f|` domA \<Gamma> = ae' f|` domA \<Gamma>"
    from Texp.AnalBinds_cong[OF this]
    show "prognosis ae as u (\<Gamma>, e, S) = prognosis ae' as u (\<Gamma>, e, S)" by simp
  next
    fix ae as a \<Gamma> e S
    show "const_on (prognosis ae as a (\<Gamma>, e, S)) (ap S) many"
    proof
      fix x
      assume "x \<in> ap S"
      hence "[x,x] \<in> paths (Fstack as S)"
        by (induction S rule: Fstack.induct)
           (auto 4 4 intro: subsetD[OF both_contains_arg1] subsetD[OF both_contains_arg2] paths_Cons_nxt)
      hence "[x,x] \<in> paths (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)"
        by (rule subsetD[OF both_contains_arg2])
      hence "[x,x] \<in> paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))"
        by (rule subsetD[OF substitute_contains_arg])
      hence "pathCard [x,x] x \<sqsubseteq> pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))) x"
        by (metis fun_belowD paths_Card_above)
      also have "pathCard [x,x] x = many"  by (auto simp add: pathCard_def)
      finally
      show "prognosis ae as a (\<Gamma>, e, S) x = many"
        by (auto intro: below_antisym)
    qed
  next
    fix \<Gamma> \<Delta> :: heap and e :: exp and ae :: AEnv and as u S
    assume "map_of \<Gamma> = map_of \<Delta>"
    hence "FBinds \<Gamma> = FBinds \<Delta>" and "thunks \<Gamma> = thunks \<Delta>" by (auto intro!: cfun_eqI  thunks_cong simp add: Texp.AnalBinds_lookup)
    thus "prognosis ae as u (\<Gamma>, e, S) = prognosis ae as u (\<Delta>, e, S)"  by simp
  next
    fix \<Gamma> :: heap and e :: exp and ae :: AEnv and as u S x
    show "prognosis ae as u (\<Gamma>, e, S) \<sqsubseteq> prognosis ae as u (\<Gamma>, e, Upd x # S)" by simp
  next
  fix \<Gamma> :: heap and e :: exp and ae :: AEnv and as a S x
  assume "ae x = \<bottom>"

  hence "FBinds (delete x \<Gamma>)\<cdot>ae = FBinds \<Gamma>\<cdot>ae" by (rule Texp.AnalBinds_delete_bot)
  moreover
  hence "((FBinds \<Gamma>\<cdot>ae) x) = \<bottom>" by (metis Texp.AnalBinds_delete_lookup)
  ultimately
  show "prognosis ae as a (\<Gamma>, e, S) \<sqsubseteq> prognosis ae as a (delete x \<Gamma>, e, S)"
    by (simp add: substitute_T_delete empty_is_bottom)
  next
    fix ae as a \<Gamma> x S
    have "once \<sqsubseteq> (pathCard [x]) x" by (simp add: two_add_simp)
    also have "pathCard [x] \<sqsubseteq> pathsCard ({[],[x]})"
      by (rule paths_Card_above) simp
    also have "\<dots> = pathsCard (paths (single x))" by simp
    also have "single x \<sqsubseteq> (Texp (Var x)\<cdot>a)" by (rule Texp_Var)
    also have "\<dots> \<sqsubseteq> Texp (Var x)\<cdot>a \<otimes>\<otimes> Fstack as S" by (rule both_above_arg1)
    also have "\<dots> \<sqsubseteq> substitute  (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (Var x)\<cdot>a \<otimes>\<otimes> Fstack as S)" by (rule substitute_above_arg)
    also have "pathsCard (paths \<dots>) x = prognosis ae as a (\<Gamma>, Var x, S) x" by simp
    finally
    show "once \<sqsubseteq> prognosis ae as a (\<Gamma>, Var x, S) x"
      by this (rule cont2cont_fun, intro cont2cont)+
  qed

  sublocale CardinalityPrognosisApp prognosis
  proof
    fix ae as a \<Gamma> e x S
    have "Texp e\<cdot>(inc\<cdot>a)  \<otimes>\<otimes> many_calls x \<otimes>\<otimes> Fstack as S = many_calls x  \<otimes>\<otimes> (Texp e)\<cdot>(inc\<cdot>a) \<otimes>\<otimes> Fstack as S"
      by (metis both_assoc both_comm)
    thus "prognosis ae as (inc\<cdot>a) (\<Gamma>, e, Arg x # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, App e x, S)"
      by simp (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_App)
  qed

  sublocale CardinalityPrognosisLam prognosis
  proof
    fix ae as a \<Gamma> e y x S
    have "Texp e[y::=x]\<cdot>(pred\<cdot>a) \<sqsubseteq> many_calls x  \<otimes>\<otimes> Texp (Lam [y]. e)\<cdot>a"
      by (rule below_trans[OF Texp_subst both_mono2'[OF Texp_Lam]])
    moreover have "Texp (Lam [y]. e)\<cdot>a \<otimes>\<otimes> many_calls x \<otimes>\<otimes> Fstack as S = many_calls x  \<otimes>\<otimes> Texp (Lam [y]. e)\<cdot>a \<otimes>\<otimes> Fstack as S"
      by (metis both_assoc both_comm)
    ultimately
    show "prognosis ae as (pred\<cdot>a) (\<Gamma>, e[y::=x], S) \<sqsubseteq> prognosis ae as a (\<Gamma>, Lam [y]. e, Arg x # S)"
      by simp (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1')
  qed

  sublocale CardinalityPrognosisVar prognosis
  proof
    fix \<Gamma> :: heap and e :: exp and x :: var and ae :: AEnv and as u a S
    assume "map_of \<Gamma> x = Some e"
    assume "ae x = up\<cdot>u"

    assume "isVal e"
    hence "x \<notin> thunks \<Gamma>" using \<open>map_of \<Gamma> x = Some e\<close> by (metis thunksE)
    hence [simp]: "f_nxt (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) x = FBinds \<Gamma>\<cdot>ae" by (auto simp add: f_nxt_def)

    have "prognosis ae as u (\<Gamma>, e, S) = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (nxt (single x) x \<otimes>\<otimes> Texp e\<cdot>u  \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((nxt (single x) x \<otimes>\<otimes> Fstack as S) \<otimes>\<otimes> Texp e\<cdot>u )))"
      by (metis both_assoc both_comm)
    also have "\<dots> \<sqsubseteq> pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (nxt (single x \<otimes>\<otimes> Fstack as S) x \<otimes>\<otimes> Texp e\<cdot>u)))"
      by (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1'  nxt_both_left) simp
    also have "\<dots> = pathsCard (paths (nxt (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S)) x))"
      using \<open>map_of \<Gamma> x = Some e\<close> \<open>ae x = up\<cdot>u\<close> by (simp add: Texp.AnalBinds_lookup)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S))))"
      by (rule pathsCard_paths_nxt)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((Texp (Var x)\<cdot>a) \<otimes>\<otimes> Fstack as S))))"
      by (intro monofun_cfun_arg pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_Var)
    also have "\<dots> = record_call x \<cdot>(prognosis ae as a (\<Gamma>, Var x, S))"
      by simp
    finally
    show "prognosis ae as u (\<Gamma>, e, S) \<sqsubseteq> record_call x\<cdot>(prognosis ae as a (\<Gamma>, Var x, S))" by this simp_all
  next
    fix \<Gamma> :: heap and e :: exp and x :: var and ae :: AEnv and as u a S
    assume "map_of \<Gamma> x = Some e"
    assume "ae x = up\<cdot>u"
    assume "\<not> isVal e"
    hence "x \<in> thunks \<Gamma>" using \<open>map_of \<Gamma> x = Some e\<close> by (metis thunksI)
    hence [simp]: "f_nxt (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) x = FBinds (delete x \<Gamma>)\<cdot>ae"
      by (auto simp add: f_nxt_def Texp.AnalBinds_delete_to_fun_upd empty_is_bottom)

    have "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks (delete x \<Gamma>)) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
       by (rule arg_cong[OF substitute_cong_T]) (auto simp add: empty_is_bottom)
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (nxt (single x) x \<otimes>\<otimes> Texp e\<cdot>u  \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) ((nxt (single x) x \<otimes>\<otimes> Fstack as S) \<otimes>\<otimes> Texp e\<cdot>u )))"
      by (metis both_assoc both_comm)
    also have "\<dots> \<sqsubseteq> pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (nxt (single x \<otimes>\<otimes> Fstack as S) x  \<otimes>\<otimes> Texp e\<cdot>u)))"
      by (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1'  nxt_both_left) simp
    also have "\<dots> = pathsCard (paths (nxt (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S)) x))"
      using \<open>map_of \<Gamma> x = Some e\<close> \<open>ae x = up\<cdot>u\<close> by (simp add: Texp.AnalBinds_lookup)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S))))"
      by (rule pathsCard_paths_nxt)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((Texp (Var x)\<cdot>a) \<otimes>\<otimes> Fstack as S))))"
      by (intro monofun_cfun_arg pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_Var)
    also have "\<dots> = record_call x \<cdot>(prognosis ae as a (\<Gamma>, Var x, S))"
      by simp
    finally
    show "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> record_call x\<cdot>(prognosis ae as a (\<Gamma>, Var x, S))" by this simp_all
  next
    fix \<Gamma> :: heap and e :: exp and ae :: AEnv and  x :: var and as S
    assume "isVal e"
    hence "repeatable (Texp e\<cdot>0)" by (rule Fun_repeatable)

    assume [simp]: "x \<notin> domA \<Gamma>"

    have [simp]: "thunks ((x, e) # \<Gamma>) = thunks \<Gamma>"
      using \<open>isVal e\<close>
      by (auto simp add: thunks_Cons dest: subsetD[OF thunks_domA])

    have "fup\<cdot>(Texp e)\<cdot>(ae x) \<sqsubseteq> Texp e\<cdot>0" by (metis fup2 monofun_cfun_arg up_zero_top)
    hence "substitute ((FBinds \<Gamma>\<cdot>ae)(x := fup\<cdot>(Texp e)\<cdot>(ae x))) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute ((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0)) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S)"
      by (intro substitute_mono1' fun_upd_mono below_refl monofun_cfun_arg)
    also have "\<dots> = substitute (((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0))(x := empty)) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S)"
      using \<open>repeatable (Texp e\<cdot>0)\<close> by (rule substitute_remove_anyways, simp)
    also have "((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0))(x := empty) = FBinds \<Gamma>\<cdot>ae"
      by (simp add: fun_upd_idem Texp.AnalBinds_not_there empty_is_bottom)
    finally
    show "prognosis ae as 0 ((x, e) # \<Gamma>, e, S) \<sqsubseteq> prognosis ae as 0 (\<Gamma>, e, Upd x # S)"
      by (simp, intro pathsCard_mono' paths_mono)
  qed

  sublocale CardinalityPrognosisIfThenElse prognosis
  proof
    fix ae as \<Gamma> scrut e1 e2 S a
    have "Texp scrut\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<sqsubseteq> Texp (scrut ? e1 : e2)\<cdot>a"
      by (rule Texp_IfThenElse)
    hence "substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp scrut\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (scrut ? e1 : e2)\<cdot>a \<otimes>\<otimes> Fstack as S)"
      by (rule substitute_mono2'[OF both_mono1'])
    thus "prognosis ae (a#as) 0 (\<Gamma>, scrut, Alts e1 e2 # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, scrut ? e1 : e2, S)"
      by (simp, intro pathsCard_mono' paths_mono)
  next
    fix ae as a \<Gamma> b e1 e2 S
    have "Texp (if b then e1 else e2)\<cdot>a \<sqsubseteq> Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a"
      by (auto simp add: either_above_arg1 either_above_arg2)
    hence "substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (if b then e1 else e2)\<cdot>a \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (Bool b)\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S)"
      by (rule substitute_mono2'[OF both_mono1'[OF below_trans[OF _ both_above_arg2]]])
    thus "prognosis ae as a (\<Gamma>, if b then e1 else e2, S) \<sqsubseteq> prognosis ae (a#as) 0 (\<Gamma>, Bool b, Alts e1 e2 # S)"
      by (auto intro!: pathsCard_mono' paths_mono)
  qed

end

context TTreeAnalysisCardinalityHeap
begin

  definition cHeap where
    "cHeap \<Gamma> e = (\<Lambda> a. pathsCard (paths (Theap \<Gamma> e\<cdot>a)))"

  lemma cHeap_simp: "(cHeap \<Gamma> e)\<cdot>a = pathsCard (paths (Theap \<Gamma> e\<cdot>a))"
    unfolding cHeap_def  by (rule beta_cfun) (intro cont2cont)

  sublocale CardinalityHeap cHeap.

  sublocale CardinalityHeapSafe cHeap Aheap
  proof
    fix x \<Gamma> e a
    assume "x \<in> thunks \<Gamma>"
    moreover
    assume "many \<sqsubseteq> (cHeap \<Gamma> e\<cdot>a) x"
    hence "many \<sqsubseteq> pathsCard (paths (Theap \<Gamma> e \<cdot>a)) x" unfolding cHeap_def by simp
    hence "\<exists>p\<in> (paths (Theap \<Gamma> e\<cdot>a)). \<not> (one_call_in_path x p)" unfolding pathsCard_def
      by (auto split: if_splits)
    ultimately
    show "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>0"
      by (metis Theap_thunk)
  next
    fix \<Gamma> e a
    show "edom (cHeap \<Gamma> e\<cdot>a) = edom (Aheap \<Gamma> e\<cdot>a)"
    by (simp add: cHeap_def Union_paths_carrier carrier_Fheap)
  qed

  sublocale CardinalityPrognosisEdom prognosis
  proof
    fix ae as a \<Gamma> e S
    show "edom (prognosis ae as a (\<Gamma>, e, S)) \<subseteq> fv \<Gamma> \<union> fv e \<union> fv S"
      apply (simp add: Union_paths_carrier)
      apply (rule carrier_substitute_below)
      apply (auto simp add: carrier_Fexp dest: subsetD[OF Aexp_edom] subsetD[OF carrier_Fstack] subsetD[OF ap_fv_subset] subsetD[OF carrier_FBinds])
      done
  qed

  sublocale CardinalityPrognosisLet prognosis cHeap
  proof
    fix \<Delta> \<Gamma> :: heap and e :: exp and S :: stack and  ae :: AEnv and a :: Arity and as
    assume "atom ` domA \<Delta> \<sharp>* \<Gamma>"
    assume "atom ` domA \<Delta> \<sharp>* S"
    assume "edom ae \<subseteq> domA \<Gamma> \<union> upds S"

    have "domA \<Delta> \<inter> edom ae = {}"
      using fresh_distinct[OF \<open>atom ` domA \<Delta> \<sharp>* \<Gamma>\<close>] fresh_distinct_fv[OF \<open>atom ` domA \<Delta> \<sharp>* S\<close>]
            \<open>edom ae \<subseteq> domA \<Gamma> \<union> upds S\<close> ups_fv_subset[of S]
      by auto

    have const_on1:  "\<And> x. const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (carrier ((FBinds \<Gamma>\<cdot>ae) x)) empty"
      unfolding const_on_edom_disj using fresh_distinct_fv[OF \<open>atom ` domA \<Delta> \<sharp>* \<Gamma>\<close>]
      by (auto dest!: subsetD[OF carrier_FBinds] subsetD[OF Texp.edom_AnalBinds])
    have const_on2:  "const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (carrier (Fstack as S)) empty"
      unfolding const_on_edom_disj using fresh_distinct_fv[OF \<open>atom ` domA \<Delta> \<sharp>* S\<close>]
      by (auto dest!: subsetD[OF carrier_FBinds] subsetD[OF carrier_Fstack] subsetD[OF Texp.edom_AnalBinds] subsetD[OF ap_fv_subset ])
    have  const_on3: "const_on (FBinds \<Gamma>\<cdot>ae) (- (- domA \<Delta>)) TTree.empty"
      and const_on4: "const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (domA \<Gamma>) TTree.empty"
      unfolding const_on_edom_disj using fresh_distinct[OF \<open>atom ` domA \<Delta> \<sharp>* \<Gamma>\<close>]
      by (auto dest!:  subsetD[OF Texp.edom_AnalBinds])

    have disj1: "\<And> x. carrier ((FBinds \<Gamma>\<cdot>ae) x) \<inter> domA \<Delta> = {}"
      using fresh_distinct_fv[OF \<open>atom ` domA \<Delta> \<sharp>* \<Gamma>\<close>]
      by (auto dest: subsetD[OF carrier_FBinds])
    hence disj1': "\<And> x. carrier ((FBinds \<Gamma>\<cdot>ae) x) \<subseteq> - domA \<Delta>" by auto
    have disj2: "\<And> x. carrier (Fstack as S) \<inter> domA \<Delta> = {}"
      using fresh_distinct_fv[OF \<open>atom ` domA \<Delta> \<sharp>* S\<close>] by (auto dest!: subsetD[OF carrier_Fstack])
    hence disj2': "carrier (Fstack as S) \<subseteq> - domA \<Delta>" by auto

    {
    fix x
    have "(FBinds (\<Delta> @ \<Gamma>)\<cdot>(ae \<squnion> Aheap \<Delta> e\<cdot>a)) x = (FBinds \<Gamma>\<cdot>ae) x \<otimes>\<otimes> (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x"
    proof (cases "x \<in> domA \<Delta>")
      case True
      have "map_of \<Gamma> x = None" using True fresh_distinct[OF \<open>atom ` domA \<Delta> \<sharp>* \<Gamma>\<close>] by (metis disjoint_iff_not_equal domA_def map_of_eq_None_iff)
      moreover
      have "ae x = \<bottom>" using True \<open>domA \<Delta> \<inter> edom ae = {}\<close> by auto
      ultimately
      show ?thesis using True
          by (auto simp add: Texp.AnalBinds_lookup empty_is_bottom[symmetric] cong: option.case_cong)
    next
      case False
      have "map_of \<Delta> x = None" using False by (metis domA_def map_of_eq_None_iff)
      moreover
      have "(Aheap \<Delta> e\<cdot>a) x = \<bottom>" using False using edom_Aheap by (metis contra_subsetD edomIff)
      ultimately
      show ?thesis using False
         by (auto simp add: Texp.AnalBinds_lookup empty_is_bottom[symmetric] cong: option.case_cong)
    qed
    }
    note FBinds = ext[OF this]

    {
    have "pathsCard (paths (substitute (FBinds (\<Delta> @ \<Gamma>)\<cdot>(Aheap \<Delta> e\<cdot>a \<squnion> ae)) (thunks (\<Delta> @ \<Gamma>)) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)))
      = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks (\<Delta> @ \<Gamma>)) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a))  (thunks (\<Delta> @ \<Gamma>))  (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))))"
       by (simp add: substitute_substitute[OF const_on1] FBinds)
    also have "substitute (FBinds \<Gamma>\<cdot>ae) (thunks (\<Delta> @ \<Gamma>)) = substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>)"
      apply (rule substitute_cong_T)
      using const_on3
      by (auto dest: subsetD[OF thunks_domA])
    also have "substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks (\<Delta> @ \<Gamma>)) = substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>)"
      apply (rule substitute_cong_T)
      using const_on4
      by (auto dest: subsetD[OF thunks_domA])
    also have "substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S) = substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S"
      by (rule substitute_only_empty_both[OF const_on2])
    also note calculation
    }
    note eq_imp_below[OF this]
    also
    note env_restr_split[where S = "domA \<Delta>"]
    also
    have "pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S))) f|` domA \<Delta>
        = pathsCard (paths (ttree_restr (domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a))))"
          by (simp add: filter_paths_conv_free_restr ttree_restr_both ttree_rest_substitute[OF disj1]  ttree_restr_is_empty[OF disj2])
    also
    have "ttree_restr (domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<sqsubseteq> Theap \<Delta> e\<cdot>a"  by (rule Theap_substitute)
    also
    have "pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S))) f|` (- domA \<Delta>) =
          pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (ttree_restr (- domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<otimes>\<otimes> Fstack as S)))"
          by (simp add: filter_paths_conv_free_restr2 ttree_rest_substitute2[OF disj1' const_on3] ttree_restr_both  ttree_restr_noop[OF disj2'])
    also have "ttree_restr (- domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a))  (thunks \<Delta>)  (Texp e\<cdot>a)) \<sqsubseteq> Texp (Terms.Let \<Delta> e)\<cdot>a" by (rule Texp_Let)
    finally
    show "prognosis (Aheap \<Delta> e\<cdot>a \<squnion> ae) as a (\<Delta> @ \<Gamma>, e, S) \<sqsubseteq> cHeap \<Delta> e\<cdot>a \<squnion> prognosis ae as a (\<Gamma>, Terms.Let \<Delta> e, S)"
      by (simp add: cHeap_def del: fun_meet_simp)
  qed

  sublocale CardinalityPrognosisSafe prognosis cHeap Aheap Aexp ..
end

end