theory HSem
  imports "HeapToEnv" "AList-Utils-Nominal" "HOLCF-Fix-Join-Nominal" "FMap-Nominal-HOLCF" "HasESem" "FMap-Join"
begin

lemma fdom_fix_join_compat:
  assumes "fix_on_cond S (bottom_of S) (\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>')"
  assumes "\<rho>' \<in> fix_join_compat \<rho> F"
  shows "fdom \<rho>' = fdom \<rho>"
  by (metis assms(2) bottom_of_fjc fmap_below_dom subpcpo.bottom_of_minimal subpcpo_fjc to_bot_minimal)

subsubsection {* A locale for heap semantics, abstract in the expression semantics *}

text {*
The following theory about the semantics of a heap is abstract in the type and
semantics of expressions. Also, care is taken that lemmas required to prove
continuity of the heap semantics are provideded before requiring full
continuity of the expression semantics, to allow for a mutually recursive
proof.
*}

context has_ESem
begin

text {*
This definition captures the notion of compatible heaps and environments, i.e.\ those heaps where,
in the course of calculating the semantics, all joins exist.
*}

abbreviation HSem_cond' :: "('var \<times> 'exp) list \<Rightarrow> 'var f\<rightharpoonup> 'value \<Rightarrow> bool"
  where "HSem_cond' h \<rho> \<equiv>
      fix_join_cond (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
                        (\<lambda> \<rho>' . heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"

text {*
The following definition is in fact just
\[
@{text "\<lbrace>h\<rbrace>\<rho> = \<rho>'. \<rho> \<squnion> heapToEnv h (\<lbrakk>-\<rbrakk>\<^bsub>\<rho>'\<^esub>)"}
\]
with additional book-keeping for domain of the map and the condition that all joins exist.
*}

definition HSem :: "('var \<times> 'exp) list \<Rightarrow> 'var f\<rightharpoonup> 'value \<Rightarrow> 'var f\<rightharpoonup> 'value"
  where
  "HSem h \<rho> =
    (if HSem_cond' h \<rho>
    then fix_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>' . heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))
      (\<lambda> \<rho>'. \<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
    else (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))"

abbreviation HSem_syn ("\<lbrace>_\<rbrace>_"  [60,60] 60) where "\<lbrace>\<Gamma>\<rbrace>\<rho> \<equiv> HSem \<Gamma> \<rho>"

abbreviation HSem_fempty  ("\<lbrace>_\<rbrace>"  [60] 60) where "\<lbrace>\<Gamma>\<rbrace> \<equiv> \<lbrace>\<Gamma>\<rbrace>fempty"

text {*
Given the predcondition hold, we can unfold the definition directly.
*}

lemma HSem_def': "HSem_cond' \<Gamma> \<rho> \<Longrightarrow>
  HSem \<Gamma> \<rho> = fix_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>) (\<lambda>\<rho>'. heapToEnv \<Gamma> (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>))
           (\<lambda>\<rho>'. \<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub> \<squnion> heapToEnv \<Gamma> (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)
 "
  unfolding  HSem_def
  by (subst if_P, auto)

subsubsection {* Continutiy of the heap semantics *}

lemma HSem_mono:
  assumes cond1: "HSem_cond' h \<rho>"
  assumes cond2: "HSem_cond' h \<rho>'"
  assumes "\<rho> \<sqsubseteq> \<rho>'"
  shows "HSem h \<rho> \<sqsubseteq> HSem h \<rho>'"
    unfolding HSem_def
    unfolding if_P[OF cond1] if_P[OF cond2]
    apply (rule fix_on_mono2[OF fix_on_cond_fjc[OF cond1] fix_on_cond_fjc[OF cond2]])
    apply (simp add: bottom_of_fjc to_bot_fmap_def fmap_below_dom[OF `\<rho> \<sqsubseteq> \<rho>'`])
    apply (erule (1) join_mono[OF rho_F_compat_fjc[OF cond1] rho_F_compat_fjc[OF cond2]])
    apply (subst fmap_below_dom[OF `\<rho> \<sqsubseteq> \<rho>'`], rule cont2monofunE[OF cont2cont_fmap_expand[OF cont_id] assms(3)])
    apply (subst fmap_below_dom[OF `\<rho> \<sqsubseteq> \<rho>'`], rule cont2monofunE[OF cont2cont_fmap_expand[OF cont_id]])
    apply (erule cont2monofunE[rotated])
    apply (intro cont2cont cont2cont_fmap_expand cont2cont_heapToEnv)
    done

lemma HSem_cont'':
  assumes cond1: "HSem_cond' h (\<Squnion> i. Y i)"
  assumes cond2: "\<And>i. HSem_cond' h (Y i)"
  assumes "chain Y"
  shows "HSem h (\<Squnion> i. Y  i) = (\<Squnion> i. HSem h (Y i))"
proof-
  have fdoms[simp]:"\<And> i. fdom (Y i) = fdom (\<Squnion> i. Y i)" (is "\<And> _ .(_ = ?d)") by (metis chain_fdom `chain Y`)

  have "fix_on       (fix_join_compat (\<Squnion> i. Y i\<^bsub>[?d \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>))
             (\<lambda>\<rho>'.                     (\<Squnion> i. Y i\<^bsub>[?d \<union> heapVars h]\<^esub>) \<squnion>
                      heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>) =
       (\<Squnion> i. fix_on  (fix_join_compat      (Y i\<^bsub>[?d \<union> heapVars h]\<^esub>)  (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot>  \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>))
                                        (\<lambda>\<rho>'. Y i\<^bsub>[?d \<union> heapVars h]\<^esub> \<squnion>
                      heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[?d \<union> heapVars h]\<^esub>)) "
    by (rule fix_on_join_cont[OF
          ch2ch_cont[OF fmap_expand_cont `chain Y`]
          cond2[unfolded fdoms]
          cond1[unfolded cont2contlubE[OF fmap_expand_cont `chain Y`]]
          ])
  thus ?thesis
    unfolding HSem_def
    unfolding if_P[OF cond1] if_P[OF cond2]
    by (simp add: cont2contlubE[OF fmap_expand_cont `chain Y`])
qed

subsubsection {* Disjoint heaps and environments are compatible *}

lemma disjoint_is_HSem_cond:
  "fdom \<rho> \<inter> heapVars h = {} \<Longrightarrow> HSem_cond' h \<rho>"
  apply (rule fix_join_condI)
  apply (intro cont2cont cont2cont_fmap_expand[OF cont2cont_heapToEnv])
  apply (rule compatible_fmapI)
  apply (case_tac "x \<in> fdom \<rho>")
  apply simp
  apply (subst lookup_fmap_expand2)
  apply auto
  done

subsubsection {* Inductions over the heap semantics *}

lemma HSem_ind':
  assumes "HSem_cond' h \<rho>"
  assumes "adm_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)) P"
  assumes "P (to_bot (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))"
  assumes "\<And> y. y \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) \<Longrightarrow>
        P y \<Longrightarrow>
        P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e \<cdot> y)\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  shows "P (HSem h \<rho>)"
  unfolding HSem_def
  apply (subst if_P[OF assms(1)])
  apply (rule fix_on_fjc_ind[OF assms(1)])
  apply fact
  apply (simp add:bottom_of_fjc)
  apply fact
  apply fact
  done

lemma HSem_ind:
  assumes "HSem_cond' h \<rho> \<Longrightarrow> adm_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)) P"
  assumes "HSem_cond' h \<rho> \<Longrightarrow> P (to_bot (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))"
  assumes "\<And> y. HSem_cond' h \<rho> \<Longrightarrow>
        y \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) \<Longrightarrow>
        P y \<Longrightarrow>
        P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e \<cdot> y)\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  assumes "P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  shows "P (HSem h \<rho>)"
  apply (cases "HSem_cond' h \<rho>")
  apply (rule HSem_ind'[OF _ assms(1,2,3)], assumption+)
  unfolding HSem_def
  apply (subst if_not_P, assumption)
  apply (rule assms(4))
  done

lemma parallel_HSem_ind:
  assumes cond1: "HSem_cond' h \<rho>"
  assumes cond2: "HSem_cond' h2 \<rho>2"
  assumes "adm_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda>\<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
                  \<times> fix_join_compat (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) (\<lambda>\<rho>'. heapToEnv h2 (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>))
                 (\<lambda>\<rho>'. P (fst \<rho>') (snd \<rho>'))"
  assumes "P (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (f\<emptyset>\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)"
  assumes "\<And>y z. y \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
               (\<lambda>\<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) \<Longrightarrow>
          z \<in> fix_join_compat (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)
               (\<lambda>\<rho>'. heapToEnv h2 (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) \<Longrightarrow>
          P y z \<Longrightarrow>
          P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e \<cdot> y)\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
           (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub> \<squnion> heapToEnv h2 (\<lambda>e. ESem e \<cdot> z)\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) "
  shows "P (HSem h \<rho>) (HSem h2 \<rho>2)"
  unfolding HSem_def if_P[OF cond1] if_P[OF cond2]
  apply (rule parallel_fix_on_ind[OF fix_on_cond_fjc[OF cond1] fix_on_cond_fjc[OF cond2]])
  apply (rule assms(3))
  using assms(4) apply (simp add: bottom_of_fjc to_bot_fmap_def)
  by (rule assms(5))

lemma HSem_eq:
  assumes "HSem_cond' h \<rho>"
  shows "HSem h \<rho> = \<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem e \<cdot> (HSem h \<rho>))\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>"
  unfolding HSem_def
  using assms
  apply (simp)
  apply (erule fix_on_fjc_eq)
  done

lemma HSem_there:
  assumes "HSem_cond' h \<rho>"
  shows "HSem h \<rho> \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
  unfolding HSem_def
  apply (subst if_P[OF assms])
  apply (rule fix_on_there[OF fix_on_cond_fjc[OF assms]])
  done

lemma the_lookup_HSem_other:
  assumes "y \<notin> heapVars h"
  shows "(HSem h \<rho>) f! y = \<rho> f! y"
proof(cases "HSem_cond' h \<rho>")
  case True show ?thesis
    apply (subst HSem_eq[OF True])
    apply (subst the_lookup_join[OF rho_F_compat_fjc[OF True HSem_there[OF True]]])
    apply (cases "y \<in> fdom \<rho>")
    apply (auto simp add: assms lookup_not_fdom)
    done
next
  case False show ?thesis
    unfolding HSem_def if_not_P[OF False]
    apply (cases "y \<in> fdom \<rho>")
    apply (auto simp add: assms  False lookup_not_fdom)
    done
qed

lemma fmap_lookup_bot_HSem_other:
  assumes "y \<notin> heapVars h"
  shows "(HSem h \<rho>) f!\<^sub>\<bottom> y = \<rho> f!\<^sub>\<bottom> y"
proof(cases "HSem_cond' h \<rho>")
  case True show ?thesis
    apply (subst HSem_eq[OF True])
    apply (subst fmap_lookup_bot_join[OF rho_F_compat_fjc[OF True HSem_there[OF True]]])
    apply (cases "y \<in> fdom \<rho>")
    apply (auto simp add: assms lookup_not_fdom)
    done
next
  case False show ?thesis
    unfolding HSem_def if_not_P[OF False]
    apply (cases "y \<in> fdom \<rho>")
    apply (auto simp add: assms  False lookup_not_fdom)
    done
qed

lemma the_lookup_HSem_both:
  assumes "HSem_cond' h \<rho>"
  assumes "y \<in> heapVars h"
  shows "HSem h \<rho> f! y =
    (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> f! y) \<squnion> ESem (the (map_of h y)) \<cdot> (HSem h \<rho>)"
  apply (subst HSem_eq[OF assms(1)])
  apply (subst the_lookup_join[OF rho_F_compat_fjc[OF assms(1) HSem_there[OF assms(1)]]])
  apply (subst (2) lookup_fmap_expand1)
    using assms(2) apply auto[3]
  apply (subst lookupHeapToEnv[OF assms(2)])
  by (rule refl)

lemma the_lookup_HSem_both_compatible:
  assumes "HSem_cond' h \<rho>"
  assumes "y \<in> heapVars h"
  shows "compatible (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> f! y) (ESem (the (map_of h y)) \<cdot> (HSem h \<rho>))"
  using the_lookup_compatible[OF rho_F_compat_fjc[OF assms(1) HSem_there[OF assms(1)]], of y]
  apply (subst (asm) (2) lookup_fmap_expand1)
    using assms(2) apply auto[3]
  apply (subst (asm) lookupHeapToEnv[OF assms(2)])
  .

lemma the_lookup_HSem_heap:
  assumes "HSem_cond' h \<rho>"
  assumes "y \<in> heapVars h"
  assumes "y \<notin> fdom \<rho>"
  shows "(HSem h \<rho>) f! y = ESem (the (map_of h y)) \<cdot> (HSem h \<rho>)"
  apply (subst HSem_eq[OF assms(1)])
  apply (subst the_lookup_join[OF rho_F_compat_fjc[OF assms(1) HSem_there[OF assms(1)]]])
  apply (subst lookup_fmap_expand2)
    using assms(2,3) apply auto[3]
  apply (subst lookup_fmap_expand1)
    using assms(2) apply auto[3]
  apply (subst lookupHeapToEnv[OF assms(2)])
  by (simp)

lemma HSem_refines:
  assumes "HSem_cond' h \<rho>"
  shows "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<sqsubseteq> HSem h \<rho>"
  apply (subst HSem_eq[OF assms(1)])
  apply (rule join_above1[OF rho_F_compat_fjc[OF assms HSem_there[OF assms]]])
done

lemma HSem_compatible[simp]:
  "compatible (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>) (HSem \<Gamma> \<rho>)"
  apply (cases "HSem_cond' \<Gamma> \<rho>")
  apply (drule HSem_refines)
  apply (metis below.r_refl ub_implies_compatible)
  unfolding HSem_def
  apply simp
  done

lemma fdom_HSem[simp]:
  "fdom (HSem h \<rho>) = fdom \<rho> \<union> heapVars h"
  apply (rule HSem_ind)
  apply (rule adm_is_adm_on)
  apply simp
  apply simp
  apply (subst fdom_join)

  apply (rule compat_fjc)
  apply (erule rho_fjc)
  apply (erule (1) F_pres_compat'')
  apply simp+
  done

lemma HSem_cond'_cong[fundef_cong]:
  "\<lbrakk> env1 = env2 ; heap1 = heap2 ; (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> ESem e = ESem e) \<rbrakk>
      \<Longrightarrow>  HSem_cond' heap1 env1 \<longleftrightarrow> HSem_cond'  heap2 env2"
  by (auto cong:heapToEnv_cong)

lemma HSem_cong[fundef_cong]:
  "\<lbrakk> env1 = env2 ; heap1 = heap2 ; (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> ESem e = ESem e) \<rbrakk>
      \<Longrightarrow> HSem heap1 env1 = HSem heap2 env2"
  unfolding HSem_def
  by (auto cong:heapToEnv_cong)

lemma fjc'_of_member:
  assumes "fix_join_cond \<rho> F"
  assumes "\<rho>' \<in> fix_join_compat \<rho> F" (is "_ \<in> ?S")
  assumes "to_bot \<rho> = to_bot \<rho>'"
  shows "fix_join_cond \<rho>' F"
proof (rule fix_join_condI)
case goal1
  have "cont F" by (rule cont_F_fjc[OF assms(1)])
  thus ?case by simp
case (goal2 i)
  show ?case
  apply (rule compat_fjc[OF assms(2) F_pres_compat''[OF assms(1)]])

  apply (induct_tac i)
  apply (simp only: funpow.simps id_apply fjc_iff)
  apply (rule to_bot_belowI)
  apply (simp add: assms(3))

  apply (simp only: funpow.simps o_apply id_apply)
  apply (erule join_fjc[OF assms(2) F_pres_compat''[OF assms(1)]])
  done
qed

lemma fjc'_of_fun_below:
  fixes \<rho> :: "'a\<Colon>{Bounded_Nonempty_Meet_cpo,subpcpo_partition}"
  assumes "fix_join_cond \<rho> F"
  assumes "G \<sqsubseteq> F"
  assumes "cont G"
  shows "fix_join_cond \<rho> G"
  apply (rule fix_join_condI[OF assms(3)])
  apply (rule compat_fjc[OF rho_fjc[OF assms(1)]])
  apply (rule down_closed_fjc[OF _ fun_belowD[OF assms(2)]])
  apply (rule F_pres_compat''[OF assms(1)])

  apply (induct_tac i)
  apply (simp only: funpow.simps id_apply fjc_iff)
  apply (rule to_bot_belowI)
  apply (simp add: assms(3))

  apply (simp only: funpow.simps o_apply id_apply)
  apply (rule join_fjc[OF rho_fjc[OF assms(1)]])
  apply (rule down_closed_fjc[OF _ fun_belowD[OF assms(2)]])
  apply (erule F_pres_compat''[OF assms(1)])
  done

lemma HSem_cond'_of_member:
  assumes "HSem_cond' \<Gamma> \<rho>"
  assumes "\<rho>' \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)
                (\<lambda> \<rho>'.  heapToEnv \<Gamma> (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)" (is "_ \<in> ?S")
  shows "HSem_cond' \<Gamma>  \<rho>'"
proof-
  let "fix_join_compat (\<rho>\<^bsub>[?d]\<^esub>) ?F" = "?S"
  have "fdom \<rho>' = ?d"
    using fdom_fix_join_compat[OF fix_on_cond_fjc[OF assms(1)] assms(2)]
    by auto
  have fdom[simp]:"fdom \<rho>' \<union> heapVars \<Gamma> = ?d"
    using fdom_fix_join_compat[OF fix_on_cond_fjc[OF assms(1)] assms(2)]
    by auto
  show ?thesis
    apply (rule fjc'_of_member)
    apply (rule assms(1)[unfolded fdom[symmetric]])
    apply (subst fmap_expand_noop)
    apply (metis `fdom \<rho>' = fdom \<rho> \<union> heapVars \<Gamma>` `fdom \<rho>' \<union> heapVars \<Gamma> =fdom \<rho> \<union> heapVars \<Gamma>`)
    apply (rule assms(2)[unfolded fdom[symmetric]])
    apply (simp add:to_bot_fmap_def)
    done
qed

subsubsection {* Reordering lemmas for HSem *}

lemma HSem_reorder:
  assumes "map_of \<Gamma> = map_of \<Delta>"
  shows "HSem \<Gamma> \<rho> = HSem \<Delta> \<rho>"
by (simp add: HSem_def heapToEnv_reorder[OF assms] assms dom_map_of_conv_heapVars[symmetric])

lemma HSem_reorder_head:
  assumes "x \<noteq> y"
  shows "HSem ((x,e1)#(y,e2)#\<Gamma>) \<rho> = HSem ((y,e2)#(x,e1)#\<Gamma>) \<rho>"
proof-
  have "set ((x,e1)#(y,e2)#\<Gamma>) = set ((y,e2)#(x,e1)#\<Gamma>)"
    by auto
  thus ?thesis
    unfolding HSem_def heapToEnv_reorder_head[OF assms]
    by (simp add: heapVars_def)
qed

lemma HSem_reorder_head_append:
  assumes "x \<notin> heapVars \<Gamma>"
  shows "HSem ((x,e)#\<Gamma>@\<Delta>) \<rho> = HSem (\<Gamma> @ ((x,e)#\<Delta>)) \<rho>"
proof-
  have "set ((x,e)#\<Gamma>@\<Delta>) = set (\<Gamma> @ ((x,e)#\<Delta>))" by auto
  thus ?thesis
    unfolding HSem_def heapToEnv_reorder_head_append[OF assms]
    by simp
qed

subsubsection {* Substitution *}

lemma HSem_subst_exp:
  assumes cond1: "HSem_cond' ((x, e) # \<Gamma>) \<rho>"
  assumes cond2: "HSem_cond' ((x, e') # \<Gamma>) \<rho>"
  assumes "\<And>\<rho>'. fdom \<rho>' = fdom \<rho> \<union> (heapVars ((x,e)#\<Gamma>)) \<Longrightarrow> ESem e \<cdot> \<rho>' = ESem e' \<cdot> \<rho>'"
  shows "HSem ((x,e)#\<Gamma>) \<rho> = HSem ((x,e')#\<Gamma>) \<rho>"
  apply (rule parallel_HSem_ind[OF cond1 cond2])
  apply (auto intro: adm_is_adm_on)[1]
  apply simp
  apply (subst heapToEnv_subst_exp)
  apply (rule assms(3))
  apply (drule fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond1]])
  apply simp
  apply simp
  done

subsubsection {* Refinement relations *}

lemma HSem_refines_lookup: "HSem_cond' \<Gamma> \<rho> \<Longrightarrow> x \<in> fdom \<rho> \<Longrightarrow> \<rho> f! x \<sqsubseteq> (HSem \<Gamma> \<rho>) f! x"
  apply (drule HSem_refines)
  apply (drule fmap_belowE[of _ _ x])
  apply simp
  done

lemma HSem_heap_below: "HSem_cond' \<Gamma> \<rho> \<Longrightarrow> x \<in> heapVars \<Gamma> \<Longrightarrow> ESem (the (map_of \<Gamma> x)) \<cdot> (HSem \<Gamma> \<rho>) \<sqsubseteq> (HSem \<Gamma> \<rho>) f! x"
  apply (subst the_lookup_HSem_both, assumption+)
  apply (rule join_above2)
  apply (rule the_lookup_HSem_both_compatible, assumption+)
  done

lemma fmap_restr_HSem_noop:
  assumes "heapVars \<Gamma> \<inter> fdom \<rho> = {}"
  shows "fmap_restr (fdom \<rho>) (HSem \<Gamma> \<rho>) = \<rho>"
  apply (rule fmap_eqI)
  using assms apply auto[1]
  using assms apply auto[1]
  apply (subst the_lookup_HSem_other)
  apply auto
  done

lemma HSem_disjoint_less:
  assumes "heapVars \<Gamma> \<inter> fdom \<rho> = {}"
  shows "\<rho> \<le> HSem \<Gamma> \<rho>"
  using assms
by (metis fmap_less_restrict fmap_restr_HSem_noop)
end

subsubsection {* Requiring continuity of the expression semantics *}

text {*
The lemmas above ought to be sufficient to prove continuity of the expression semantics. Hence, we
extend the locale by assuming this for alle expressions, and repeat some of the lemmas above, discharing
their more specific assumptions.
*}

context has_ESem
begin
  lemma HSem_below:
    assumes "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<sqsubseteq> r"
    assumes "\<And>x. x \<in> heapVars h \<Longrightarrow> ESem (the (map_of h x)) \<cdot> r \<sqsubseteq> r f! x"
    shows "HSem h \<rho> \<sqsubseteq> r"
  proof (rule HSem_ind)
    from fmap_below_dom[OF assms(1)]
    have [simp]:"fdom r = fdom \<rho> \<union> heapVars h" by simp
    {
    case goal1 show ?case by (auto intro: adm_is_adm_on)
    case goal2 show ?case by (simp add: to_bot_fmap_def)
    case (goal3 \<rho>')
      show ?case
      apply (rule join_below[OF rho_F_compat_fjc[OF goal3(1) goal3(2)] assms(1)])
      apply (rule fmap_expand_belowI)
      apply simp
      apply (simp add: lookupHeapToEnv)
      by (rule below_trans[OF
            monofun_cfun_arg[OF goal3(3)]
            assms(2)])
    next
    case goal4 show ?case by fact
    }
  qed

  lemma fempty_is_HSem_cond:
    "HSem_cond' h fempty"
      by (rule disjoint_is_HSem_cond, auto)

  lemma HSem_cond'_Nil[simp]:
    "HSem_cond' [] \<rho>"
    by (rule disjoint_is_HSem_cond, simp)

  lemma HSem_Nil[simp]: "HSem [] \<rho> = \<rho>"
    apply (subst HSem_eq[OF HSem_cond'_Nil])
    apply auto
    by (metis below.r_refl is_joinI to_bot_fmap_def to_bot_minimal)

subsubsection {* Re-calculating the semantics of the heap is idempotent *}

  lemma HSem_redo:
    assumes "HSem_cond' (\<Gamma> @ \<Delta>) \<rho>"
    assumes "HSem_cond' \<Gamma> (fmap_restr (fdom \<rho> \<union> heapVars \<Delta>) (HSem (\<Gamma> @ \<Delta>) \<rho>))"
    shows "HSem \<Gamma> (fmap_restr (fdom \<rho> \<union> heapVars \<Delta>) (HSem (\<Gamma>@\<Delta>) \<rho>)) = HSem (\<Gamma> @ \<Delta>) \<rho>" (is "?LHS = ?RHS")
  proof (rule below_antisym)
    show "?LHS \<sqsubseteq> ?RHS"
    proof(rule HSem_below)
    case goal1
      show ?case
        apply (rule fmap_expand_fmap_restr_below)
        apply auto
        done
    case (goal2 x)
      hence "x \<in> heapVars (\<Gamma>@\<Delta>)" by auto
      show ?case
        apply (subst the_lookup_HSem_both[OF assms(1) `x \<in> heapVars (\<Gamma>@\<Delta>)`])
        apply (rule below_trans[OF _ join_above2[OF the_lookup_HSem_both_compatible[OF assms(1) `x \<in> heapVars (\<Gamma>@\<Delta>)`]]])
        using goal2 by (auto simp add: map_add_dom_app_simps dom_map_of_conv_image_fst dom_map_of_conv_heapVars[symmetric])
    qed

    show "?RHS \<sqsubseteq> ?LHS"
    proof(rule HSem_below)
    case goal1
      show ?case
        apply (rule fmap_expand_belowI)
          apply auto[1]
        apply (rule below_trans[OF _ HSem_refines_lookup[OF assms(2)]])
          prefer 2 apply simp
        apply (subst lookup_fmap_restr)
          apply auto[2]
        apply (erule HSem_refines_lookup[OF assms(1)])
        done

    case (goal2 x)
      show ?case
      proof(cases "x \<in> heapVars \<Gamma>")
      case True
        show ?thesis
          apply (subst the_lookup_HSem_both[OF assms(2) True])
          apply (rule below_trans[OF _ join_above2[OF the_lookup_HSem_both_compatible[OF assms(2) True]]])
          using True by (auto simp add: map_add_dom_app_simps dom_map_of_conv_image_fst dom_map_of_conv_heapVars[symmetric])
      next
      case False
        hence delta: "x \<in> heapVars \<Delta>" using goal2 by auto
        show ?thesis
          apply (subst the_lookup_HSem_other[OF False])
          apply (subst lookup_fmap_restr)
            using delta apply auto[1]
          apply (subst the_lookup_HSem_both[OF assms(1) goal2])
          apply (rule below_trans[OF _ join_above2[OF the_lookup_HSem_both_compatible[OF assms(1) `x \<in> heapVars (\<Gamma>@\<Delta>)`]]])
          apply (rule monofun_cfun_arg[OF `?LHS \<sqsubseteq> ?RHS`])
          done
      qed
    qed
  qed

subsubsection {* The heap semantics can also be defined inductively over the heap *}

  lemma iterative_HSem:
    assumes "HSem_cond' ((x, e) # \<Gamma>) \<rho>"
    assumes "x \<notin> heapVars \<Gamma>"
    shows "HSem ((x,e) # \<Gamma>) \<rho> =
        fix_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>) (\<lambda> \<rho>'. heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>))
                (\<lambda> \<rho>'. (HSem \<Gamma> \<rho>')
                        \<squnion> ((f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)(x f\<mapsto> ESem e \<cdot> \<rho>')
                        \<squnion> (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)))" (is "_ = fix_on ?S ?R")
  apply (subst HSem_def'[OF assms(1)])
  proof(rule below_antisym)
    interpret subpcpo ?S by (rule subpcpo_fjc)

    let "?d" = "fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)"

    let "fix_on _ ?L" = "fix_on ?S
                         (\<lambda>\<rho>'. \<rho>\<^bsub>[?d]\<^esub> \<squnion>
                               heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)"
    let "(\<lambda> \<rho>'. ?L1 \<rho>' \<squnion> ?L2 \<rho>')" = ?L
    let "(\<lambda> \<rho>'. ?R1 \<rho>' \<squnion> (?R2 \<rho>' \<squnion> ?R3 \<rho>'))" = ?R

    { fix \<rho>' assume "\<rho>' \<in> ?S"
      hence fdom1: "fdom \<rho>' = ?d"
      apply (subst (asm) fjc_iff)
      apply (drule fmap_below_dom)
      apply (subst (asm) fdom_fix_on[OF fix_on_cond_fjc[OF assms(1)], unfolded bottom_of_fjc])
      apply auto
      done
    } note fdom = this

    { fix \<rho>' assume "\<rho>' \<in> ?S"
      have fdom1: "(fdom \<rho>' \<union> heapVars \<Gamma>) = ?d" using fdom[OF `\<rho>' \<in> ?S`] by auto
      have fdom2: "(fdom \<rho>' \<union> heapVars ((x,e) # \<Gamma>)) = ?d" using fdom1 by auto
      have "HSem_cond' ((x,e) # \<Gamma>) \<rho>'" by (rule HSem_cond'_of_member[OF assms(1) `\<rho>'\<in>?S`])
      from this[unfolded fdom2]
      have "HSem_cond' \<Gamma> \<rho>'"
        apply (subst (1 2) fdom1, rule fjc'_of_fun_below)
        apply (rule fun_belowI)
        apply (rule heapToEnv_mono)
        apply simp
        apply rule
        apply (simp add: assms(2))
        apply (intro cont2cont cont2cont_fmap_expand cont2cont_heapToEnv)
        done
    } note HSem_cond'_Gamma = this

    have closedL: "closed_on ?L"
      by (rule closed_on_fjc[OF assms(1)])

    have closedR1: "closed_on ?R1"
      apply (rule closed_onI)
         apply (rule HSem_ind)
        apply (rule adm_is_adm_on[OF subcpo_mem_adm[OF subcpo_fjc]])
        apply (rule down_closed_fjc, assumption)
        apply (frule fdom)
       apply (auto simp add:to_bot_fmap_def simp del:fjc_iff)[1]
        apply (rule join_fjc)
         apply (subst fmap_expand_noop)
        apply (frule fdom, auto)[1]
       apply assumption
       apply (rule down_closed_fjc[OF F_pres_compat''[OF assms(1)]], assumption) back
         apply (rule heapToEnv_mono)
        apply simp
       apply (frule fdom, auto)[1]
      apply (simp add: assms(2))
      apply (subst fmap_expand_noop)
       apply (frule fdom, auto)[1]
      apply assumption
      done

    have closedR2: "closed_on ?R2"
      apply (rule closed_onI)
      apply (rule down_closed_fjc[OF F_pres_compat''[OF assms(1)]], assumption)
      apply (rule fmap_belowI)
      apply (frule fdom, auto)[1]
      apply (case_tac "xaa = x", simp_all)
      done

    have closedR3: "closed_on ?R3"
      apply (rule closed_onI)
      by (rule rho_fjc[OF assms(1)])

    have closedR: "closed_on ?R"
      by (rule closed_on_join_fjc[OF closedR1 closed_on_join_fjc[OF closedR2 closedR3]])

    have contL: "cont_on ?L"
      by (rule cont_on_fjc[OF assms(1)])

    have contR1: "cont_on ?R1"
      apply (rule cont_onI2)
      apply (rule monofun_onI)
      apply (erule (2) HSem_mono[OF HSem_cond'_Gamma HSem_cond'_Gamma])
      apply (rule eq_imp_below[OF HSem_cont''])
      apply (erule HSem_cond'_Gamma[OF chain_on_lub_on])
      apply (erule HSem_cond'_Gamma[OF chain_on_is_on])
      apply (erule chain_on_is_chain)
      done

    have contR2: "cont_on ?R2"
      by (intro cont_is_cont_on fmap_upd_cont cont_const cont2cont)

    have contR3: "cont_on ?R3"
      by (rule cont_is_cont_on[OF cont_const])

    have contR: "cont_on ?R"
      apply (rule cont_on_join_fjc)
      apply (rule closedR1)
      apply (rule closed_on_join_fjc[OF closedR2 closedR3])
      apply (rule contR1)
      apply (rule cont_on_join_fjc)
      apply (rule closedR2)
      apply (rule closedR3)
      apply (rule contR2)
      apply (rule contR3)
      done

    note fix_on_condL = fix_on_cond_fjc[OF assms(1)]

    have fix_on_condR: "fix_on_cond ?S bottom_of ?R"
      by (rule fix_on_condI[OF subpcpo_fjc refl closedR contR])

    have R_there: "fix_on ?S ?R \<in> ?S"
      by (rule fix_on_there[OF fix_on_condR])

    have compatL: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?L1 x) (?L2 x)"
      by (rule compat_fjc[OF rho_fjc[OF assms(1)]  F_pres_compat''[OF assms(1)]])

    have compatR2R3: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R2 x) (?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR2] closed_onE[OF closedR3]])
    have compatR1R2: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x) (?R2 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR1] closed_onE[OF closedR2]])
    have compatR1R2R3: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x) (?R2 x \<squnion> ?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR1] closed_onE[OF closed_on_join_fjc[OF closedR2 closedR3]]])
    have compatR1R2R3': "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x \<squnion> ?R2 x) (?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closed_on_join_fjc[OF closedR1 closedR2]] closed_onE[OF closedR3]])

    show "fix_on ?S ?L \<sqsubseteq> fix_on ?S ?R"
    proof (rule fix_on_mono[OF fix_on_condL fix_on_condR])
      fix \<rho>'
      assume there: "\<rho>' \<in> ?S"
      hence [simp]:"fdom \<rho>' = ?d" by (rule fdom)

      have inner_cond: "HSem_cond' \<Gamma> \<rho>'"
        by (rule HSem_cond'_Gamma[OF there])
      have inner_refine: "\<rho>' \<sqsubseteq> HSem \<Gamma> \<rho>'"
        apply (insert HSem_refines[OF inner_cond])
        apply (subst (asm) fmap_expand_noop)
        apply auto
        done

      have belowL1: "?L1 \<rho>' \<sqsubseteq> ?R \<rho>'"
        by (rule below_trans[OF join_above2[OF compatR2R3[OF there]] join_above2[OF compatR1R2R3[OF there]]])

      have "?L2 \<rho>' \<sqsubseteq> ?R1 \<rho>' \<squnion> ?R2 \<rho>'"
      proof (rule fmap_belowI)
      case goal1 show ?case
        by (subst fdom_join[OF compatR1R2[OF there]], auto)
      case (goal2 x')
        hence "x' \<in> ?d" by simp
        show ?case
        proof(cases "x' = x")
        case True
          show ?thesis
            apply (subst the_lookup_join[OF compatR1R2[OF there]])
            apply (insert the_lookup_compatible[OF compatR1R2[OF there], of x'])
            apply (simp add: True)
            apply (erule join_above2)
            done
        next
        case False
          show ?thesis
          proof (cases "x' \<in> heapVars \<Gamma>")
          case True
            have "heapToEnv \<Gamma> (\<lambda>e. ESem e \<cdot> \<rho>') f! x' \<sqsubseteq> HSem \<Gamma> \<rho>' f! x'"
              apply (subst HSem_eq[OF inner_cond])
              apply (subst the_lookup_join[OF rho_F_compat_fjc[OF inner_cond  HSem_there[OF inner_cond]]])
              apply (insert the_lookup_compatible[OF rho_F_compat_fjc[OF inner_cond  HSem_there[OF inner_cond]], of x'])
              apply (subst (2) lookup_fmap_expand1)
              apply (simp_all add: True)[3]
              apply (subst (asm) (2) lookup_fmap_expand1)
              apply (simp_all add: True)[3]
              apply (erule below_trans[OF _ join_above2, rotated])
              apply (rule cont2monofunE[OF _ inner_refine])
              apply (intro cont2cont)
              done
            thus ?thesis
              apply (subst lookup_fmap_expand1)
              apply simp
              apply (simp add: True)
              apply (simp add: True)
              apply (subst the_lookup_join[OF compatR1R2[OF there]])
              apply (insert the_lookup_compatible[OF compatR1R2[OF there], of x'])
              apply (simp add: True False)
              done
          next
          case False
            show ?thesis
            apply (subst lookup_fmap_expand2)
            apply simp
            apply fact
            apply (simp add: False `x' \<noteq> x`)
            apply simp
            done
          qed
        qed
      qed
      hence belowL2: "?L2 \<rho>' \<sqsubseteq> ?R \<rho>'"
        apply (subst join_assoc[symmetric, OF compatR1R2[OF there] compatR1R2R3[OF there] compatR2R3[OF there]])
        apply (erule below_trans[OF _ join_above1[OF compatR1R2R3'[OF there]]])
        done

      show "?L \<rho>' \<sqsubseteq> ?R \<rho>'"
        apply (rule join_below[OF compatL[OF there]])
        apply (rule belowL1)
        apply (rule belowL2)
        done
    qed

    show "fix_on ?S ?R \<sqsubseteq> fix_on ?S ?L"
      unfolding bottom_of_fjc
      by (rule R_there[unfolded fjc_iff, unfolded bottom_of_fjc])
  qed

  (*
  lemma iterative_HSem':
    assumes "HSem_cond' ((x, e) # \<Gamma>) \<rho>"
    assumes "x \<notin> heapVars \<Gamma>"
    shows "HSem ((x,e) # \<Gamma>) \<rho> =
        fix_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>) (\<lambda> \<rho>'. heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>))
                (\<lambda> \<rho>'. (HSem \<Gamma> (\<rho>' f|` (-heapVars \<Gamma>)))
                        \<squnion> ((f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)(x f\<mapsto> ESem e (HSem \<Gamma> (\<rho>' f|` (-heapVars \<Gamma>))))
                        \<squnion> (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)))" (is "_ = fix_on ?S ?R")
  apply (subst HSem_def'[OF assms(1)])
  proof(rule below_antisym)
    interpret subpcpo ?S by (rule subpcpo_fjc)

    let "?d" = "fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)"

    have [simp]: "\<And> \<rho>. fdom (\<rho> f|` (- heapVars \<Gamma>)) \<union> heapVars \<Gamma> = fdom \<rho> \<union> heapVars \<Gamma>"
      by auto
    have [simp]: "insert x (fdom \<rho> \<union> heapVars \<Gamma>) \<inter> - heapVars \<Gamma> \<union> heapVars \<Gamma> =  insert x (fdom \<rho> \<union> heapVars \<Gamma>)"
      by auto

    let "fix_on _ ?L" = "fix_on ?S
                         (\<lambda>\<rho>'. \<rho>\<^bsub>[?d]\<^esub> \<squnion>
                               heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)"
    let "(\<lambda> \<rho>'. ?L1 \<rho>' \<squnion> ?L2 \<rho>')" = ?L
    let "(\<lambda> \<rho>'. ?R1 \<rho>' \<squnion> (?R2 \<rho>' \<squnion> ?R3 \<rho>'))" = ?R

    { fix \<rho>' assume "\<rho>' \<in> ?S"
      hence fdom1: "fdom \<rho>' = ?d"
      apply (subst (asm) fjc_iff)
      apply (drule fmap_below_dom)
      apply (subst (asm) fdom_fix_on[OF fix_on_cond_fjc[OF assms(1)], unfolded bottom_of_fjc])
      apply auto
      done
    } note fdom = this

    { fix \<rho>' assume "\<rho>' \<in> ?S"
      have fdom1: "(fdom \<rho>' \<union> heapVars \<Gamma>) = ?d" using fdom[OF `\<rho>' \<in> ?S`] by auto
      have fdom2: "(fdom \<rho>' \<union> heapVars ((x,e) # \<Gamma>)) = ?d" using fdom1 by auto
      have "HSem_cond' ((x,e) # \<Gamma>) \<rho>'" by (rule HSem_cond'_of_member[OF assms(1) `\<rho>'\<in>?S`])
      from this[unfolded fdom2]
      have "HSem_cond' \<Gamma> \<rho>'"
        apply (subst (1 2) fdom1, rule fjc'_of_fun_below)
        apply (rule fun_belowI)
        apply (rule heapToEnv_mono)
        apply simp
        apply rule
        apply (simp add: assms(2))
        apply (rule cont2cont_fmap_expand[OF  cont2cont_heapToEnv[OF ESem_cont]])
        done
    } note HSem_cond'_Gamma = this

    have closedL: "closed_on ?L"
      by (rule closed_on_fjc[OF assms(1)])

    have closedR1: "closed_on ?R1"
      apply (rule closed_onI)
         apply (rule HSem_ind)
        apply (rule adm_is_adm_on[OF subcpo_mem_adm[OF subcpo_fjc]])
        apply (rule down_closed_fjc, assumption)
        apply (frule fdom)
       apply (auto simp add:to_bot_fmap_def simp del:fjc_iff)[1]
        apply (rule join_fjc)
        apply (frule fdom)
        apply (erule down_closed_fjc)
       apply (auto intro: fmap_expand_fmap_restr_below)[1]
       apply (rule down_closed_fjc[OF F_pres_compat''[OF assms(1)]], assumption) back
         apply (rule heapToEnv_mono)
        apply simp
       apply (frule fdom, auto)[1]
      apply (simp add: assms(2))
      apply (frule fdom)
      apply (erule down_closed_fjc)
      apply (auto intro: fmap_expand_fmap_restr_below)[1]
      done

    have closedR2: "closed_on ?R2"
      apply (rule closed_onI)
      apply (rule down_closed_fjc[OF F_pres_compat''[OF assms(1)]], assumption)
      apply (rule fmap_belowI)
      apply (frule fdom, auto)[1]
      apply (case_tac "xaa = x", simp_all)
      done

    have closedR3: "closed_on ?R3"
      apply (rule closed_onI)
      by (rule rho_fjc[OF assms(1)])

    have closedR: "closed_on ?R"
      by (rule closed_on_join_fjc[OF closedR1 closed_on_join_fjc[OF closedR2 closedR3]])

    have contL: "cont_on ?L"
      by (rule cont_on_fjc[OF assms(1)])

    have contR1: "cont_on ?R1"
      apply (rule cont_onI2)
      apply (rule monofun_onI)
      apply (erule (2) HSem_monofun''[OF ESem_cont HSem_cond'_Gamma HSem_cond'_Gamma])
      apply (rule eq_imp_below[OF HSem_cont''[OF ESem_cont]])
      apply (erule HSem_cond'_Gamma[OF chain_on_lub_on])
      apply (erule HSem_cond'_Gamma[OF chain_on_is_on])
      apply (erule chain_on_is_chain)
      done

    have contR2: "cont_on ?R2"
      by (rule cont_is_cont_on[OF fmap_upd_cont[OF cont_const ESem_cont]])

    have contR3: "cont_on ?R3"
      by (rule cont_is_cont_on[OF cont_const])

    have contR: "cont_on ?R"
      apply (rule cont_on_join_fjc)
      apply (rule closedR1)
      apply (rule closed_on_join_fjc[OF closedR2 closedR3])
      apply (rule contR1)
      apply (rule cont_on_join_fjc)
      apply (rule closedR2)
      apply (rule closedR3)
      apply (rule contR2)
      apply (rule contR3)
      done

    note fix_on_condL = fix_on_cond_fjc[OF assms(1)]

    have fix_on_condR: "fix_on_cond ?S bottom_of ?R"
      by (rule fix_on_condI[OF subpcpo_fjc refl closedR contR])

    have R_there: "fix_on ?S ?R \<in> ?S"
      by (rule fix_on_there[OF fix_on_condR])

    have compatL: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?L1 x) (?L2 x)"
      by (rule compat_fjc[OF rho_fjc[OF assms(1)]  F_pres_compat''[OF assms(1)]])

    have compatR2R3: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R2 x) (?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR2] closed_onE[OF closedR3]])
    have compatR1R2: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x) (?R2 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR1] closed_onE[OF closedR2]])
    have compatR1R2R3: "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x) (?R2 x \<squnion> ?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closedR1] closed_onE[OF closed_on_join_fjc[OF closedR2 closedR3]]])
    have compatR1R2R3': "\<And> x. x \<in> ?S \<Longrightarrow> compatible (?R1 x \<squnion> ?R2 x) (?R3 x)"
      by (rule compat_fjc[OF closed_onE[OF closed_on_join_fjc[OF closedR1 closedR2]] closed_onE[OF closedR3]])

    show "fix_on ?S ?L \<sqsubseteq> fix_on ?S ?R"
    proof (rule fix_on_mono[OF fix_on_condL fix_on_condR])
      fix \<rho>'
      assume there: "\<rho>' \<in> ?S"
      hence [simp]:"fdom \<rho>' = ?d" by (rule fdom)

      have inner_cond: "HSem_cond' \<Gamma> \<rho>'"
        by (rule HSem_cond'_Gamma[OF there])
      have inner_refine: "\<rho>' \<sqsubseteq> HSem \<Gamma> \<rho>'"
        apply (insert HSem_refines[OF inner_cond])
        apply (subst (asm) fmap_expand_noop)
        apply auto
        done

      have belowL1: "?L1 \<rho>' \<sqsubseteq> ?R \<rho>'"
        by (rule below_trans[OF join_above2[OF compatR2R3[OF there]] join_above2[OF compatR1R2R3[OF there]]])

      have "?L2 \<rho>' \<sqsubseteq> ?R1 \<rho>' \<squnion> ?R2 \<rho>'"
      proof (rule fmap_belowI)
      case goal1 show ?case
        by (subst fdom_join[OF compatR1R2[OF there]], auto)
      case (goal2 x')
        hence "x' \<in> ?d" by simp
        show ?case
        proof(cases "x' = x")
        case True
          show ?thesis
            apply (subst the_lookup_join[OF compatR1R2[OF there]])
            apply (insert the_lookup_compatible[OF compatR1R2[OF there], of x'])
            apply (simp add: True)
            apply (erule join_above2)
            done
        next
        case False
          show ?thesis
          proof (cases "x' \<in> heapVars \<Gamma>")
          case True
            have "heapToEnv \<Gamma> (\<lambda>e. ESem e \<rho>') f! x' \<sqsubseteq> HSem \<Gamma> \<rho>' f! x'"
              apply (subst HSem_eq[OF inner_cond])
              apply (subst the_lookup_join[OF rho_F_compat_fjc[OF inner_cond  HSem_there[OF inner_cond]]])
              apply (insert the_lookup_compatible[OF rho_F_compat_fjc[OF inner_cond  HSem_there[OF inner_cond]], of x'])
              apply (subst (2) lookup_fmap_expand1)
              apply (simp_all add: True)[3]
              apply (subst (asm) (2) lookup_fmap_expand1)
              apply (simp_all add: True)[3]
              apply (erule below_trans[OF _ join_above2, rotated])
              apply (rule cont2monofunE[OF _ inner_refine])
              apply (intro cont2cont ESem_cont)
              done
            thus ?thesis
              apply (subst lookup_fmap_expand1)
              apply simp
              apply (simp add: True)
              apply (simp add: True)
              apply (subst the_lookup_join[OF compatR1R2[OF there]])
              apply (insert the_lookup_compatible[OF compatR1R2[OF there], of x'])
              apply (simp add: True False)
              done
          next
          case False
            show ?thesis
            apply (subst lookup_fmap_expand2)
            apply simp
            apply fact
            apply (simp add: False `x' \<noteq> x`)
            apply simp
            done
          qed
        qed
      qed
      hence belowL2: "?L2 \<rho>' \<sqsubseteq> ?R \<rho>'"
        apply (subst join_assoc[symmetric, OF compatR1R2[OF there] compatR1R2R3[OF there] compatR2R3[OF there]])
        apply (erule below_trans[OF _ join_above1[OF compatR1R2R3'[OF there]]])
        done

      show "?L \<rho>' \<sqsubseteq> ?R \<rho>'"
        apply (rule join_below[OF compatL[OF there]])
        apply (rule belowL1)
        apply (rule belowL2)
        done
    qed

    show "fix_on ?S ?R \<sqsubseteq> fix_on ?S ?L"
      unfolding bottom_of_fjc
      by (rule R_there[unfolded fjc_iff, unfolded bottom_of_fjc])
  qed
  *)

  subsubsection {* Substitution *}

  lemma HSem_subst_expr_below:
    assumes cond1: "HSem_cond' ((x, e1) # \<Gamma>) \<rho>"
    assumes cond2: "HSem_cond' ((x, e2) # \<Gamma>) \<rho>"
    assumes below: "ESem e1 \<cdot> (HSem ((x, e2) # \<Gamma>) \<rho>) \<sqsubseteq> ESem e2 \<cdot> (HSem ((x, e2) # \<Gamma>) \<rho>)"
    shows "HSem ((x, e1) # \<Gamma>) \<rho> \<sqsubseteq> HSem ((x, e2) # \<Gamma>) \<rho>"
  proof (rule HSem_ind'[OF cond1])
  case goal1 show ?case by (auto intro: adm_is_adm_on)
  case goal2 show ?case by (simp add: to_bot_fmap_def)
  case (goal3 \<rho>')
    show ?case
      apply (subst HSem_eq[OF cond2])
      apply (rule join_mono[OF
        rho_F_compat_fjc[OF cond1 goal3(1)]
        rho_F_compat_fjc[OF cond2 HSem_there[OF cond2]]
        ])
      apply simp
      apply (subst (1 2) heapToEnv.simps)
      apply (simp del: heapToEnv.simps)
      apply (rule cont2monofunE[OF fmap_expand_cont])
      apply (rule fmap_upd_mono)
      apply (rule cont2monofunE[OF _ goal3(2)])
        apply (intro cont2cont)
      apply (rule below_trans[OF monofun_cfun_arg[OF goal3(2)] below])
      done
  qed

  lemma HSem_subst_expr:
    assumes cond1: "HSem_cond' ((x, e1) # \<Gamma>) \<rho>"
    assumes cond2: "HSem_cond' ((x, e2) # \<Gamma>) \<rho>"
    assumes below1: "ESem e1 \<cdot> (HSem ((x, e2) # \<Gamma>) \<rho>) \<sqsubseteq> ESem e2 \<cdot> (HSem ((x, e2) # \<Gamma>) \<rho>)"
    assumes below2: "ESem e2 \<cdot> (HSem ((x, e1) # \<Gamma>) \<rho>) \<sqsubseteq> ESem e1 \<cdot> (HSem ((x, e1) # \<Gamma>) \<rho>)"
    shows "HSem ((x, e1) # \<Gamma>) \<rho> = HSem ((x, e2) # \<Gamma>) \<rho>"
    by (metis assms HSem_subst_expr_below below_antisym)

  subsubsection {* Lemmas specialized to @{text "\<rho> = f\<emptyset>"} *}

  lemma HSemb_def: "HSem h f\<emptyset> = fix_on {y. fdom y = heapVars h} (\<lambda> \<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>'))"
    by (simp add: HSem_def'[OF fempty_is_HSem_cond] bottom_of_fjc to_bot_fmap_def)

  lemma fix_on_cond_fempty:
    "fix_on_cond {y. fdom y = heapVars h}
       (subpcpo_syn.bottom_of {y. fdom y = heapVars h})
       (\<lambda>\<rho>'. heapToEnv h (\<lambda>e. ESem e \<cdot> \<rho>'))"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above[where x = "f\<emptyset>\<^bsub>[heapVars h]\<^esub>", simplified])
    apply (rule refl)
    apply auto[1]
    apply (intro cont_is_cont_on cont2cont)
    done

  lemma HSemb_ind':
    assumes "adm_on ({y . fdom y = heapVars h}) P"
    assumes "P (f\<emptyset>\<^bsub>[heapVars h]\<^esub>)"
    assumes "\<And> y. fdom y = heapVars h \<Longrightarrow> P y \<Longrightarrow> P (heapToEnv h (\<lambda>e. ESem e \<cdot> y))"
    shows "P (HSem h f\<emptyset>)"
    apply (subst HSemb_def)
    apply (rule fix_on_ind[OF fix_on_cond_fempty assms(1)])
    using assms apply auto
    done

  lemma HSemb_redo:
    assumes "HSem_cond' \<Gamma> (fmap_restr (heapVars \<Delta>) (HSem (\<Gamma> @ \<Delta>) f\<emptyset>))"
    shows "HSem \<Gamma> (fmap_restr (heapVars \<Delta>) (HSem (\<Gamma>@\<Delta>) f\<emptyset>)) = HSem (\<Gamma> @ \<Delta>) f\<emptyset>"
    apply (rule HSem_redo[OF fempty_is_HSem_cond, simplified (no_asm)])
    using assms by simp

  lemma HSemb_eq:
    shows "HSem h f\<emptyset> = heapToEnv h (\<lambda>e. ESem e \<cdot> (HSem h f\<emptyset>))"
    by (subst HSem_eq[OF fempty_is_HSem_cond], simp)

  lemma HSemb_heap_below: "x \<in> heapVars \<Gamma> \<Longrightarrow> ESem (the (map_of \<Gamma> x)) \<cdot> (HSem \<Gamma> f\<emptyset>) \<sqsubseteq> (HSem \<Gamma> f\<emptyset>) f! x"
    by (erule HSem_heap_below[OF fempty_is_HSem_cond])

  lemma HSemb_below:
    assumes "heapToEnv h (\<lambda>e. ESem e \<cdot> r) \<sqsubseteq> r"
    shows "HSem h f\<emptyset> \<sqsubseteq> r"
    apply (subst HSemb_def)
    apply (rule fix_on_least_below[OF fix_on_cond_fempty _ assms])
    using assms by (metis (full_types) fmap_below_dom heapToEnv_fdom mem_Collect_eq)

  lemmas the_lookup_HSem_fempty = the_lookup_HSem_heap[OF fempty_is_HSem_cond, simp]

end

locale has_ignore_fresh_ESem = has_ESem +
  assumes ESem_ignores_fresh: "\<rho>1 \<le> \<rho>2 \<Longrightarrow> atom ` (fdom \<rho>2 - fdom \<rho>1) \<sharp>* e \<Longrightarrow> ESem e \<cdot> \<rho>1 = ESem e \<cdot> \<rho>2"
begin

subsubsection {* Binding more variables increases knowledge *}

  lemma HSem_subset_below:
    assumes cond2: "HSem_cond' (\<Delta>@\<Gamma>) \<rho>"
    assumes fresh: "atom ` heapVars \<Gamma> \<sharp>* \<Delta>"
    assumes rho_fresh: "fdom \<rho> \<inter> heapVars (\<Gamma> @ \<Delta>) = {}"
    shows "(\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Delta>@\<Gamma>\<rbrace>\<rho>"
  proof-
    have fdoms: "fdom \<rho> \<union> (heapVars \<Delta> \<union> heapVars \<Gamma>) - (fdom \<rho> \<union> heapVars \<Delta>) = heapVars \<Gamma>"
      using fresh rho_fresh by (auto dest: fresh_distinct)

    have below: "\<lbrace>\<Delta>\<rbrace>\<rho> \<sqsubseteq> (\<lbrace>\<Delta>@\<Gamma>\<rbrace>\<rho>)\<^bsub>[fdom \<rho> \<union> heapVars \<Delta>]\<^esub>" (is "_ \<sqsubseteq> ?RHS")
    proof (rule HSem_below)
      show "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Delta>]\<^esub> \<sqsubseteq> ?RHS"
      proof (rule fmap_expand_belowI)
        fix x
        assume "x \<in> fdom \<rho>"
        with fmap_belowE[OF HSem_refines[OF cond2], where x = x]
        show "\<rho> f! x \<sqsubseteq> ?RHS f! x" by simp
      qed simp
    next
    case (goal2 x)[simp]
      have "ESem (the (map_of \<Delta> x)) \<cdot> ?RHS = ESem (the (map_of \<Delta> x)) \<cdot> (\<lbrace>\<Delta>@\<Gamma>\<rbrace>\<rho>)"
        apply (rule ESem_ignores_fresh[OF fmap_expand_less])
        apply simp
        apply auto[1]
        apply (simp add: fdoms)
        using fresh apply (metis fresh fresh_heap_expr'[OF _ the_map_of_snd[OF goal2]] fresh_star_def)
        done
      also have "\<dots> = ESem (the (map_of (\<Delta>@\<Gamma>) x)) \<cdot> (\<lbrace>\<Delta>@\<Gamma>\<rbrace>\<rho>)"
        by (simp add: map_add_dom_app_simps dom_map_of_conv_heapVars)
      also have "\<dots> \<sqsubseteq> ?RHS f! x"
        by (simp, rule HSem_heap_below[OF cond2, where x = x, simplified])
      finally
      show ?case.
    qed

    show ?thesis
    proof(rule fmap_expand_belowI)
    case (goal2 x)
      with fmap_belowE[OF below, where x = x]
      show ?case by (cases "x\<in> fdom \<rho>", auto)
    qed auto
  qed

  subsubsection {* Additional, fresh bindings in one or two steps *}

  lemma HSem_merge:
    assumes fresh: "atom ` heapVars \<Gamma> \<sharp>* \<Delta>"
    assumes rho_fresh: "fdom \<rho> \<inter> heapVars (\<Gamma> @ \<Delta>) = {}"
    shows "\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> = \<lbrace>\<Gamma>@\<Delta>\<rbrace>\<rho>"
  proof(rule below_antisym)
    from fresh rho_fresh
    have Gamma_fresh: "heapVars \<Gamma> \<inter> (fdom \<rho> \<union> heapVars \<Delta>) = {}"
      by (auto dest: fresh_distinct)
    hence fdoms: "fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma> - (fdom \<rho> \<union> heapVars \<Delta>) = heapVars \<Gamma>"
      by auto

    have map_of_eq: "map_of (\<Delta> @ \<Gamma>) = map_of (\<Gamma> @ \<Delta>)"
    proof
      fix x
      show "map_of (\<Delta> @ \<Gamma>) x = map_of (\<Gamma> @ \<Delta>) x"
      proof (cases "x \<in> heapVars \<Gamma>")
        case True
        hence "x \<notin> heapVars \<Delta>" by (metis Gamma_fresh IntI equals0D in_mono sup_ge2)
        thus "map_of (\<Delta> @ \<Gamma>) x = map_of (\<Gamma> @ \<Delta>) x"
          by (simp add: map_add_dom_app_simps dom_map_of_conv_heapVars)
      next
        case False
        thus "map_of (\<Delta> @ \<Gamma>) x = map_of (\<Gamma> @ \<Delta>) x"
          by (simp add: map_add_dom_app_simps dom_map_of_conv_heapVars)
      qed
    qed

    have cond1: "HSem_cond' \<Gamma> (\<lbrace>\<Delta>\<rbrace>\<rho>)"
      apply (rule disjoint_is_HSem_cond)
      using Gamma_fresh by auto
    have cond2: "HSem_cond' (\<Gamma>@\<Delta>) \<rho>"
      apply (rule disjoint_is_HSem_cond)
      using rho_fresh by auto
    have cond2': "HSem_cond' (\<Delta>@\<Gamma>) \<rho>"
      apply (rule disjoint_is_HSem_cond)
      using rho_fresh by auto
    have cond3: "HSem_cond' \<Delta> \<rho>"
      apply (rule disjoint_is_HSem_cond)
      using rho_fresh by auto

    show "\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> \<sqsubseteq> \<lbrace>\<Gamma>@\<Delta>\<rbrace>\<rho>"
    proof(rule HSem_below)
      have "(\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Delta> @ \<Gamma>\<rbrace>\<rho>"
        by (rule HSem_subset_below[OF cond2' fresh rho_fresh])
      also have "\<lbrace>\<Delta> @ \<Gamma>\<rbrace>\<rho> = \<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho>"
        by (rule HSem_reorder[OF map_of_eq])
      finally
      show "(\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom (\<lbrace>\<Delta>\<rbrace>\<rho>) \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho>"
        by simp

    case (goal2 x)[simp]
      have "ESem (the (map_of \<Gamma> x)) \<cdot> (\<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho>) = ESem (the (map_of (\<Gamma>@\<Delta>) x)) \<cdot> (\<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho>)"
        by (simp add: map_add_dom_app_simps dom_map_of_conv_heapVars)
      also have "\<dots> \<sqsubseteq> \<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho> f! x"
        by (rule HSem_heap_below[OF cond2], simp)
      finally
      show ?case.
    qed

    show "\<lbrace>\<Gamma>@\<Delta>\<rbrace>\<rho> \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>"
    proof(rule HSem_below)
      have "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub> = (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Delta>]\<^esub>)\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub>"
        by (rule fmap_expand_idem[symmetric], auto)
      also have "... \<sqsubseteq> (\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub>"
        by (rule cont2monofunE[OF fmap_expand_cont HSem_refines[OF cond3]])
      also have "... = (\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom (\<lbrace>\<Delta>\<rbrace>\<rho>) \<union> heapVars (\<Gamma>)]\<^esub>"
        apply (rule arg_cong) back
        by auto
      also have "... \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>"
        by (rule HSem_refines[OF cond1])
      finally
      show "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub> \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> ".

    case (goal2 x)
      {
        assume x[simp]: "x \<in> heapVars \<Gamma>"
        have "ESem (the (map_of (\<Gamma> @ \<Delta>) x)) \<cdot> (\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>) = ESem (the (map_of (\<Gamma>) x)) \<cdot> (\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>)"
          by (simp add: map_add_dom_app_simps dom_map_of_conv_heapVars)
        also have "\<dots> \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> f! x"
          by (rule HSem_heap_below[OF cond1 x])
        finally have ?case.
      }
      moreover
      {
        assume [simp]:"x \<notin> heapVars \<Gamma>" and  "x \<in> heapVars \<Delta>"
        have "ESem (the (map_of (\<Gamma> @ \<Delta>) x)) \<cdot> (\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>) = ESem (the (map_of \<Delta> x)) \<cdot> (\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>)"
          by (simp add: map_add_dom_app_simps dom_map_of_conv_heapVars)
        also have "\<dots>  = ESem (the (map_of \<Delta> x)) \<cdot> (\<lbrace>\<Delta>\<rbrace>\<rho>)"
          apply (rule ESem_ignores_fresh[symmetric])
          apply (rule HSem_disjoint_less)
            using Gamma_fresh apply auto[1]
          apply (simp add: fdoms)
            using fresh apply (metis fresh fresh_heap_expr'[OF _ the_map_of_snd[OF `x \<in> heapVars \<Delta>`]] fresh_star_def)
          done
        also have "\<dots> \<sqsubseteq> \<lbrace>\<Delta>\<rbrace>\<rho> f! x"
          by (rule HSem_heap_below[OF cond3 `x \<in> heapVars \<Delta>`])
        also have "\<dots> = \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> f! x"
          by (rule the_lookup_HSem_other[symmetric, OF `x \<notin> heapVars \<Gamma>`])
        finally have ?case.
      }
      ultimately show ?case using goal2 by fastforce
    qed
  qed

subsubsection {* Adding a fresh variable to a heap does not affect its semantics *}

  lemma HSem_add_fresh':
    assumes cond1: "HSem_cond' \<Gamma> \<rho>"
    assumes cond2: "HSem_cond' ((x,e) # \<Gamma>) \<rho>"
    assumes fresh: "atom x \<sharp> (\<rho>,\<Gamma>)"
    assumes step: "\<And>e \<rho>'. fdom \<rho>' = fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>) \<Longrightarrow> e \<in> snd ` set \<Gamma> \<Longrightarrow> ESem e \<cdot> \<rho>' = ESem e\<cdot>  (fmap_restr (fdom \<rho>' - {x}) \<rho>')"
    shows  "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (HSem ((x, e) # \<Gamma>) \<rho>) = HSem \<Gamma> \<rho>"
  proof (rule parallel_HSem_ind[OF cond1 cond2])
  case goal1 show ?case by (auto intro:adm_is_adm_on)
  case goal2 show ?case by (auto)[1]
  case goal3
    have "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>) = \<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>"
      apply (subst fmap_restr_fmap_expand2)
      by auto
    moreover

    have "x \<notin> fdom \<rho> \<union> heapVars \<Gamma>"
      using fresh
      apply (auto simp add: fresh_fmap_pure fresh_Pair)
      by (metis heapVars_not_fresh)
    hence [simp]:"fdom z - {x} = fdom \<rho> \<union> heapVars \<Gamma>"
      using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond2] goal3(2)]
      by auto

    have "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (heapToEnv ((x, e) # \<Gamma>) (\<lambda>e. ESem e \<cdot> z)\<^bsub>[fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)]\<^esub>)
      =  heapToEnv \<Gamma> (\<lambda>e. ESem e \<cdot> y)\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub> "
      apply (subst fmap_restr_fmap_expand2)
        apply simp
        apply auto[1]
      apply (subst heapToEnv_remove_Cons_fmap_expand[OF _ `x \<notin> fdom \<rho> \<union> heapVars \<Gamma>`])
        apply simp
      apply (rule arg_cong[OF heapToEnv_cong[OF refl]])
      apply (subst step)
      using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond2] goal3(2)] apply simp
      apply assumption
      using `_ = y`[symmetric]
      apply simp
      done
    ultimately
    show ?case
      apply (subst fmap_restr_join[OF _ rho_F_compat_fjc[OF cond2 `z \<in> _`]])
      by simp+
  qed

  lemma HSem_add_fresh:
    assumes cond1: "HSem_cond' \<Gamma> \<rho>"
    assumes cond2: "HSem_cond' ((x,e) # \<Gamma>) \<rho>"
    assumes fresh: "atom x \<sharp> (\<rho>, \<Gamma>)"
    shows  "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (\<lbrace>(x, e) # \<Gamma>\<rbrace>\<rho>) = \<lbrace>\<Gamma>\<rbrace>\<rho>"
  proof(rule HSem_add_fresh'[OF assms])
  case (goal1 e \<rho>')
    assume "e \<in> snd ` set \<Gamma>"
    hence "atom x \<sharp> e"
      apply auto
      by (metis fresh fresh_PairD(2) fresh_list_elem)

    assume "fdom \<rho>' = fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)"
    hence [simp]:"fdom \<rho>' - fdom \<rho>' \<inter> (fdom \<rho>' - {x}) = {x}" by auto

    show ?case
      apply (rule ESem_ignores_fresh[symmetric, OF fmap_restr_less])
      apply (simp add: fresh_star_def)
      using `atom x \<sharp> e`.
  qed

end

lemma parallel_HSem_ind_different_ESem:
  assumes cond1: "has_ESem.HSem_cond' ESem1 h \<rho>"
  assumes cond2: "has_ESem.HSem_cond' ESem2 h2 \<rho>2"
  assumes "adm_on (fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda>\<rho>'. heapToEnv h (\<lambda>e. ESem1 e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
                  \<times> fix_join_compat (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) (\<lambda>\<rho>'. heapToEnv h2 (\<lambda>e. ESem2 e \<cdot> \<rho>')\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>))
                 (\<lambda>\<rho>'. P (fst \<rho>') (snd \<rho>'))"
  assumes "P (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (f\<emptyset>\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)"
  assumes "\<And>y z. y \<in> fix_join_compat (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
               (\<lambda>\<rho>'. heapToEnv h (\<lambda>e. ESem1 e \<cdot> \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) \<Longrightarrow>
          z \<in> fix_join_compat (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)
               (\<lambda>\<rho>'. heapToEnv h2 (\<lambda>e. ESem2 e \<cdot> \<rho>')\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) \<Longrightarrow>
          P y z \<Longrightarrow>
          P (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<squnion> heapToEnv h (\<lambda>e. ESem1 e \<cdot> y)\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)
           (\<rho>2\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub> \<squnion> heapToEnv h2 (\<lambda>e. ESem2 e \<cdot> z)\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>) "
  shows "P (has_ESem.HSem ESem1 h \<rho>) (has_ESem.HSem ESem2 h2 \<rho>2)"
  unfolding has_ESem.HSem_def if_P[OF cond1] if_P[OF cond2]
  apply (rule parallel_fix_on_ind[OF fix_on_cond_fjc[OF cond1] fix_on_cond_fjc[OF cond2]])
  apply (rule assms(3))
  using assms(4) apply (simp add: bottom_of_fjc to_bot_fmap_def)
  by (rule assms(5))

lemma parallel_HSem_ind_different_ESem_disjoint:
  assumes disj1: "fdom \<rho> \<inter> heapVars h = {}"
  assumes disj2: "fdom \<rho>2 \<inter> heapVars h2 = {}"
  assumes "adm (\<lambda>\<rho>'. P (fst \<rho>') (snd \<rho>'))"
  assumes "P (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (f\<emptyset>\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)"
  assumes "\<And>y z. P y z \<Longrightarrow> P (\<rho> f++ heapToEnv h (\<lambda>e. ESem1 e \<cdot> y)) (\<rho>2 f++ heapToEnv h2 (\<lambda>e. ESem2 e \<cdot> z))"
  shows "P (has_ESem.HSem ESem1 h \<rho>) (has_ESem.HSem ESem2 h2 \<rho>2)"
proof (rule parallel_HSem_ind_different_ESem)
  interpret HSem1: has_ESem ESem1.
  interpret HSem2: has_ESem ESem2.
  case goal1 from disj1 show ?case by (rule HSem1.disjoint_is_HSem_cond)
  case goal2 from disj2 show ?case by (rule HSem2.disjoint_is_HSem_cond)
  case goal3 from assms(3) show ?case by (rule adm_is_adm_on)
  case goal4 from assms(4) show ?case.
  case goal5
  note fmap_expand_join_disjunct[of \<rho> "heapToEnv h (\<lambda>e. ESem1 e \<cdot> y)", simplified, OF disj1]
  moreover
  note fmap_expand_join_disjunct[of \<rho>2 "heapToEnv h2 (\<lambda>e. ESem2 e \<cdot> z)", simplified, OF disj2]
  moreover
  note assms(5)[OF goal5(3)]
  ultimately
  show ?case by simp
qed

subsubsection {* Equivariance of @{term HSem} *}

lemma HSem_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> ESem1 e = ESem2 e); env1 = env2 ; heap1 = heap2  \<rbrakk>
      \<Longrightarrow> has_ESem.HSem ESem1 heap1 env1 = has_ESem.HSem  ESem2 heap2 env2"
  unfolding has_ESem.HSem_def
  by (auto cong:heapToEnv_cong)

lemma HSem_eqvt[eqvt]:
  "\<pi> \<bullet> has_ESem.HSem ESem h \<rho> = has_ESem.HSem (\<pi> \<bullet> ESem) (\<pi> \<bullet> h) (\<pi> \<bullet> \<rho>)"
proof (cases "has_ESem.HSem_cond' ESem h \<rho>")
  case True
  hence True_permuted: "has_ESem.HSem_cond' (\<pi> \<bullet> ESem) (\<pi> \<bullet> h)  (\<pi> \<bullet> \<rho>)"
    by -(drule fix_join_cond_eqvt[where \<pi> = \<pi>], perm_simp, assumption)

  show ?thesis
   unfolding has_ESem.HSem_def
   apply (simp only: if_P[OF True] if_P[OF True_permuted])
   apply (subst fix_on_eqvt[OF fix_on_cond_fjc[OF True]])
   apply (subst bottom_of_eqvt[OF subpcpo_fjc])
   apply (subst fix_join_compat_eqvt[OF True])
   apply perm_simp
   apply rule
   done
next
case False
  hence False_permuted: "\<not> has_ESem.HSem_cond' (\<pi> \<bullet> ESem) (\<pi> \<bullet> h) (\<pi> \<bullet> \<rho>)"
    apply -
    apply rule
    apply (erule notE)
    apply (drule fix_join_cond_eqvt[where \<pi> = "- \<pi>"])
    apply perm_simp
    by (metis (no_types) eqvt_bound pemute_minus_self unpermute_def)
  show ?thesis
   unfolding has_ESem.HSem_def
   apply (simp only: if_not_P[OF False] if_not_P[OF False_permuted])
   apply perm_simp
   apply rule
   done
qed

end


theory CrashHoare
imports "Monads/NonDetMonadVCG"
begin

lemma hoare_pre_conj_const:
  "(P \<Longrightarrow> \<lbrace> Q \<rbrace> f \<lbrace> R \<rbrace>) \<Longrightarrow> \<lbrace> \<lambda>s. P \<and> Q s \<rbrace> f \<lbrace> R \<rbrace>"
  by(cases P, auto)

lemma alternativeE_valid:
  "\<lbrace> A \<rbrace> f \<lbrace> B \<rbrace>, \<lbrace> C \<rbrace> \<Longrightarrow> \<lbrace> A \<rbrace> g \<lbrace> B \<rbrace>, \<lbrace> C \<rbrace> \<Longrightarrow> \<lbrace> A \<rbrace> f OR g \<lbrace> B \<rbrace>, \<lbrace> C \<rbrace>"
  unfolding validE_def by(auto intro:alternative_valid)

section "The Crash Monad"
type_synonym ('s,'a) crash_monad = "('s, unit + 'a) nondet_monad"

text {* A process in the crash monad can terminate abruptly at any point.  We model this with
  a unit exception. *}
definition
  crash_atom :: "('s,'a) nondet_monad \<Rightarrow> ('s,'a) crash_monad"
where
  "crash_atom m = (liftE m OR throwError ())"

text {* The process must establish its crash invariant at the boundaries of atomic operations. *}
lemma valid_crash_atom:
  assumes valid_suc: "\<lbrace> A \<rbrace> f \<lbrace> B \<rbrace>"
      and crash:     "\<And>s. A s \<Longrightarrow> Cr () s"
  shows "\<lbrace> A \<rbrace> crash_atom f \<lbrace> B \<rbrace>, \<lbrace> Cr \<rbrace>"
  unfolding crash_atom_def
  by(wp add:alternativeE_valid valid_suc crash, auto)

section "A Crash-Safe Algorithm"

text {* We have a heap built from two-element cells.  These elements can only be updated
  one at a time, but we will insist that all indexed cells have their left and right elements
  equal. *}
record cell =
  left :: nat
  right :: nat

record heap =
  cells :: "nat \<Rightarrow> cell"
  index :: "nat \<Rightarrow> nat"
  index_length :: nat

definition
  occupied :: "heap \<Rightarrow> nat set"
where
  "occupied h = {n. \<exists>m < index_length h. index h m = n}"

text {* All cells reachable from the index. *}
definition
  lift_cells :: "heap \<Rightarrow> cell set"
where
  "lift_cells h = (\<lambda>n. cells h (index h n)) ` {n. n < index_length h}"

text {* This is the heap invariant, that must hold even on a crash. *}
definition
  valid_cells :: "cell set \<Rightarrow> bool"
where
  "valid_cells C \<longleftrightarrow> (\<forall>c\<in>C. left c = right c)"

definition
  valid_heap :: "heap \<Rightarrow> bool"
where
  "valid_heap h \<longleftrightarrow> valid_cells (lift_cells h)"

section "Crash-Atomic Updates"

text {* The elements of a cell can be updated atomically, but not whole cells.  Also, the
  index cannot be updated atomically with its length indicator. *}

definition write_left :: "nat \<Rightarrow> nat \<Rightarrow> (heap, unit) crash_monad"
where
  "write_left n l =
    crash_atom (modify (\<lambda>h. h\<lparr> cells := (cells h)(n := (cells h n)\<lparr> left := l \<rparr>) \<rparr>))"

definition write_right :: "nat \<Rightarrow> nat \<Rightarrow> (heap, unit) crash_monad"
where
  "write_right n l =
    crash_atom (modify (\<lambda>h. h\<lparr> cells := (cells h)(n := (cells h n)\<lparr> right := l \<rparr>) \<rparr>))"

definition write_index :: "nat \<Rightarrow> nat \<Rightarrow> (heap, unit) crash_monad"
where
  "write_index m n =
    crash_atom (modify (\<lambda>h. h\<lparr> index := (index h)(m := n) \<rparr>))"

definition inc_length :: "(heap, unit) crash_monad"
where
  "inc_length = crash_atom (modify (index_length_update Suc))"

section "Non-Atomic Updates"

text {* Add an entry to the end of the index. *}
definition extend_index :: "nat \<Rightarrow> (heap, unit) crash_monad"
where "extend_index n = doE
        i <- liftE (gets index_length);
        write_index i n;
        inc_length
       odE"

text {* Add a cell, with left and right elements equal.  On termination, this satisfies
  the invariant trivially, but we'll have to prove that it preserves it at every step. *}
definition new_cell :: "nat \<Rightarrow> nat \<Rightarrow> (heap, unit) crash_monad"
where
  "new_cell n x =
    doE
      write_left n x;
      write_right n x;
      extend_index n
    odE"

section "The Correctness Proof"

text {* @{term inc_length} makes the cell pointed to by the next index entry reachable --- this
  cell must therefore be valid. *}
lemma valid_inc:
  "\<lbrace> \<lambda>h. valid_cells (insert (cells h (index h (index_length h))) (lift_cells h)) \<rbrace>
    inc_length
   \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>, \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>"
proof -
  txt {* Adding an index entry commutes with lifting the cells. *}
  {
    fix h::heap
    have "{n. n < Suc (index_length h)} = insert (index_length h) {n. n < index_length h}"
      by(auto)
    moreover assume "valid_cells (insert (cells h (index h (index_length h))) (lift_cells h))"
    ultimately have  "valid_cells (lift_cells (index_length_update Suc h))"
      by(simp add:lift_cells_def)
  }
  txt {* If a set of cells is valid, so is a subset. *}
  moreover {
    fix h::heap
    assume "valid_cells (insert (cells h (index h (index_length h))) (lift_cells h))"
    hence "valid_cells (lift_cells h)"
      unfolding valid_cells_def lift_cells_def
      by(auto)
  }
  ultimately show ?thesis
    unfolding inc_length_def
    by(wp add:valid_crash_atom, auto)
qed

text {* Now we generalise to adding an arbitrary location. *}
lemma valid_extend:
  "\<lbrace> \<lambda>h. valid_cells (insert (cells h n) (lift_cells h)) \<rbrace>
    extend_index n
   \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>, \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>"
proof -
  txt {* Unpack the validity predicate on the new cell. *}
  have wi_valid: "\<And>i.
        \<lbrace> \<lambda>h. i = index_length h \<and>
              left (cells h n) = right (cells h n) \<and>
              valid_cells (lift_cells h) \<rbrace>
          write_index i n
        \<lbrace> \<lambda>_ h. valid_cells (insert (cells h (index h (index_length h))) (lift_cells h)) \<rbrace>,
        \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>"
    unfolding write_index_def
    by(wp add:valid_crash_atom,
       simp_all add:valid_cells_def lift_cells_def)

  show ?thesis
    unfolding extend_index_def
    apply(wp add:valid_inc)
    apply(simp)
    apply(wp add:wi_valid)
    apply(simp add:valid_cells_def)
    done
qed

text {* As long as we're not overwriting a cell, the @{term new_cell} preserves the invariant
  both under normal execution, or under a crash at any point. *}
theorem valid_new_cell:
  "\<lbrace> \<lambda>h. n \<notin> occupied h \<and> valid_cells (lift_cells h) \<rbrace>
    new_cell n x
   \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>,
   \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>"
proof -
  txt {* @{term write_left} updates the left element, and preserves the invariant. *}
  have wl_valid:
    "\<lbrace> \<lambda>h.  valid_cells (lift_cells h) \<and> n \<notin> occupied h \<rbrace>
      write_left n x
     \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<and> n \<notin> occupied h \<and> left (cells h n) = x \<rbrace>,
     \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>"
    unfolding write_left_def
    by(wp add:valid_crash_atom,
       auto simp:occupied_def lift_cells_def valid_cells_def)

  txt {* @{term write_right} completes the validity predicate on the new cell. *}
  have wr_valid:
    "\<lbrace> \<lambda>h. n \<notin> occupied h \<and> valid_cells (lift_cells h) \<and> left (cells h n) = x\<rbrace>
      write_right n x
     \<lbrace> \<lambda>_ h. valid_cells (insert (cells h n) (lift_cells h)) \<rbrace>,
     \<lbrace> \<lambda>_ h. valid_cells (lift_cells h) \<rbrace>"
    unfolding write_right_def
    by(wp add:valid_crash_atom,
       auto simp:occupied_def lift_cells_def valid_cells_def)

  txt {* Put it all together with the VCG. *}
  show ?thesis
    unfolding new_cell_def
    apply(wp add:valid_extend)
    apply(simp)
    apply(wp add:wr_valid valid_extend)
    apply(simp)
    apply(wp add:wr_valid)
    apply(simp add:conj_comms)
    apply(wp add:wl_valid)
    done
qed

end


theory "Cardinality-Domain"
imports "../Launchbury/HOLCF-Utils"
begin

type_synonym oneShot = "one"
abbreviation notOneShot :: oneShot where "notOneShot \<equiv> ONE"
abbreviation oneShot :: oneShot where "oneShot \<equiv> \<bottom>"

type_synonym two = "oneShot\<^sub>\<bottom>"
abbreviation many :: two where "many \<equiv> up\<cdot>notOneShot"
abbreviation once :: two where "once \<equiv> up\<cdot>oneShot"
abbreviation none :: two where "none \<equiv> \<bottom>"

lemma many_max[simp]: "a \<sqsubseteq> many" by (cases a) auto

lemma two_conj: "c = many \<or> c = once \<or> c = none" by (metis Exh_Up one_neq_iffs(1))

lemma two_cases[case_names many once none]:
  obtains "c = many" | "c = once" | "c = none" using two_conj by metis

definition two_pred where "two_pred = (\<Lambda> x. if x \<sqsubseteq> once then \<bottom> else x)"

lemma two_pred_simp: "two_pred\<cdot>c = (if c \<sqsubseteq> once then \<bottom> else c)"
  unfolding two_pred_def
  apply (rule beta_cfun)
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)
  done

lemma two_pred_simps[simp]:
  "two_pred\<cdot>many = many"
  "two_pred\<cdot>once = none"
  "two_pred\<cdot>none = none"
by (simp_all add: two_pred_simp)

lemma two_pred_below_arg: "two_pred \<cdot> f \<sqsubseteq> f"
  by (auto simp add: two_pred_simp)

lemma two_pred_none: "two_pred\<cdot>c = none \<longleftrightarrow> c \<sqsubseteq> once"
  by (auto simp add: two_pred_simp)

definition record_call where "record_call x = (\<Lambda> ce. (\<lambda> y. if x = y then two_pred\<cdot>(ce y) else ce y))"

lemma record_call_simp: "(record_call x \<cdot> f) x' = (if x = x' then two_pred \<cdot> (f x') else f x')"
  unfolding record_call_def by auto

lemma record_call[simp]: "(record_call x \<cdot> f) x = two_pred \<cdot> (f x)"
  unfolding record_call_simp by auto

lemma record_call_other[simp]: "x' \<noteq> x \<Longrightarrow> (record_call x \<cdot> f) x' = f x'"
  unfolding record_call_simp by auto

lemma record_call_below_arg: "record_call x \<cdot> f \<sqsubseteq> f"
  unfolding record_call_def
  by (auto intro!: fun_belowI two_pred_below_arg)

definition two_add :: "two \<rightarrow> two \<rightarrow> two"
  where "two_add = (\<Lambda> x. (\<Lambda> y. if x \<sqsubseteq> \<bottom> then y else (if y \<sqsubseteq> \<bottom> then x else many)))"

lemma two_add_simp: "two_add\<cdot>x\<cdot>y = (if x \<sqsubseteq> \<bottom> then y else (if y \<sqsubseteq> \<bottom> then x else many))"
  unfolding two_add_def
  apply (subst beta_cfun)
  apply (rule cont2cont)
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)[1]
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)[8]
  apply (rule beta_cfun)
  apply (rule cont_if_else_above)
  apply (auto elim: below_trans)[1]
  apply (rule cont_if_else_above)
  apply auto
  done

lemma two_pred_two_add_once: "c \<sqsubseteq> two_pred\<cdot>(two_add\<cdot>once\<cdot>c)"
  by (cases c rule: two_cases) (auto simp add: two_add_simp)

end


section \<open>Records \label{sec:records}\<close>

(*<*)
theory Records imports Main begin
(*>*)

text \<open>
  \index{records|(}%
  Records are familiar from programming languages.  A record of $n$
  fields is essentially an $n$-tuple, but the record's components have
  names, which can make expressions easier to read and reduces the
  risk of confusing one field for another.

  A record of Isabelle/HOL covers a collection of fields, with select
  and update operations.  Each field has a specified type, which may
  be polymorphic.  The field names are part of the record type, and
  the order of the fields is significant --- as it is in Pascal but
  not in Standard ML.  If two different record types have field names
  in common, then the ambiguity is resolved in the usual way, by
  qualified names.

  Record types can also be defined by extending other record types.
  Extensible records make use of the reserved pseudo-field \cdx{more},
  which is present in every record type.  Generic record operations
  work on all possible extensions of a given type scheme; polymorphism
  takes care of structural sub-typing behind the scenes.  There are
  also explicit coercion functions between fixed record types.
\<close>

subsection \<open>Record Basics\<close>

text \<open>
  Record types are not primitive in Isabelle and have a delicate
  internal representation @{cite "NaraschewskiW-TPHOLs98"}, based on
  nested copies of the primitive product type.  A \commdx{record}
  declaration introduces a new record type scheme by specifying its
  fields, which are packaged internally to hold up the perception of
  the record as a distinguished entity.  Here is a simple example:
\<close>

record point =
  Xcoord :: int
  Ycoord :: int

text \<open>\noindent
  Records of type \<^typ>\<open>point\<close> have two fields named \<^const>\<open>Xcoord\<close>
  and \<^const>\<open>Ycoord\<close>, both of type~\<^typ>\<open>int\<close>.  We now define a
  constant of type \<^typ>\<open>point\<close>:
\<close>

definition pt1 :: point where
"pt1 \<equiv> (| Xcoord = 999, Ycoord = 23 |)"

text \<open>\noindent
  We see above the ASCII notation for record brackets.  You can also
  use the symbolic brackets \<open>\<lparr>\<close> and \<open>\<rparr>\<close>.  Record type
  expressions can be also written directly with individual fields.
  The type name above is merely an abbreviation.
\<close>

definition pt2 :: "\<lparr>Xcoord :: int, Ycoord :: int\<rparr>" where
"pt2 \<equiv> \<lparr>Xcoord = -45, Ycoord = 97\<rparr>"

text \<open>
  For each field, there is a \emph{selector}\index{selector!record}
  function of the same name.  For example, if \<open>p\<close> has type \<^typ>\<open>point\<close> then \<open>Xcoord p\<close> denotes the value of the \<open>Xcoord\<close> field of~\<open>p\<close>.  Expressions involving field selection
  of explicit records are simplified automatically:
\<close>

lemma "Xcoord \<lparr>Xcoord = a, Ycoord = b\<rparr> = a"
  by simp

text \<open>
  The \emph{update}\index{update!record} operation is functional.  For
  example, \<^term>\<open>p\<lparr>Xcoord := 0\<rparr>\<close> is a record whose \<^const>\<open>Xcoord\<close>
  value is zero and whose \<^const>\<open>Ycoord\<close> value is copied from~\<open>p\<close>.  Updates of explicit records are also simplified automatically:
\<close>

lemma "\<lparr>Xcoord = a, Ycoord = b\<rparr>\<lparr>Xcoord := 0\<rparr> =
         \<lparr>Xcoord = 0, Ycoord = b\<rparr>"
  by simp

text \<open>
  \begin{warn}
  Field names are declared as constants and can no longer be used as
  variables.  It would be unwise, for example, to call the fields of
  type \<^typ>\<open>point\<close> simply \<open>x\<close> and~\<open>y\<close>.
  \end{warn}
\<close>

subsection \<open>Extensible Records and Generic Operations\<close>

text \<open>
  \index{records!extensible|(}%

  Now, let us define coloured points (type \<open>cpoint\<close>) to be
  points extended with a field \<open>col\<close> of type \<open>colour\<close>:
\<close>

datatype colour = Red | Green | Blue

record cpoint = point +
  col :: colour

text \<open>\noindent
  The fields of this new type are \<^const>\<open>Xcoord\<close>, \<open>Ycoord\<close> and
  \<open>col\<close>, in that order.
\<close>

definition cpt1 :: cpoint where
"cpt1 \<equiv> \<lparr>Xcoord = 999, Ycoord = 23, col = Green\<rparr>"

text \<open>
  We can define generic operations that work on arbitrary
  instances of a record scheme, e.g.\ covering \<^typ>\<open>point\<close>, \<^typ>\<open>cpoint\<close>, and any further extensions.  Every record structure has an
  implicit pseudo-field, \cdx{more}, that keeps the extension as an
  explicit value.  Its type is declared as completely
  polymorphic:~\<^typ>\<open>'a\<close>.  When a fixed record value is expressed
  using just its standard fields, the value of \<open>more\<close> is
  implicitly set to \<open>()\<close>, the empty tuple, which has type
  \<^typ>\<open>unit\<close>.  Within the record brackets, you can refer to the
  \<open>more\<close> field by writing ``\<open>\<dots>\<close>'' (three dots):
\<close>

lemma "Xcoord \<lparr>Xcoord = a, Ycoord = b, \<dots> = p\<rparr> = a"
  by simp

text \<open>
  This lemma applies to any record whose first two fields are \<open>Xcoord\<close> and~\<^const>\<open>Ycoord\<close>.  Note that \<open>\<lparr>Xcoord = a, Ycoord
  = b, \<dots> = ()\<rparr>\<close> is exactly the same as \<open>\<lparr>Xcoord = a, Ycoord
  = b\<rparr>\<close>.  Selectors and updates are always polymorphic wrt.\ the
  \<open>more\<close> part of a record scheme, its value is just ignored (for
  select) or copied (for update).

  The \<open>more\<close> pseudo-field may be manipulated directly as well,
  but the identifier needs to be qualified:
\<close>

lemma "point.more cpt1 = \<lparr>col = Green\<rparr>"
  by (simp add: cpt1_def)

text \<open>\noindent
  We see that the colour part attached to this \<^typ>\<open>point\<close> is a
  rudimentary record in its own right, namely \<open>\<lparr>col =
  Green\<rparr>\<close>.  In order to select or update \<open>col\<close>, this fragment
  needs to be put back into the context of the parent type scheme, say
  as \<open>more\<close> part of another \<^typ>\<open>point\<close>.

  To define generic operations, we need to know a bit more about
  records.  Our definition of \<^typ>\<open>point\<close> above has generated two
  type abbreviations:

  \medskip
  \begin{tabular}{l}
  \<^typ>\<open>point\<close>~\<open>=\<close>~\<open>\<lparr>Xcoord :: int, Ycoord :: int\<rparr>\<close> \\
  \<^typ>\<open>'a point_scheme\<close>~\<open>=\<close>~\<open>\<lparr>Xcoord :: int, Ycoord :: int, \<dots> :: 'a\<rparr>\<close> \\
  \end{tabular}
  \medskip

\noindent
  Type \<^typ>\<open>point\<close> is for fixed records having exactly the two fields
  \<^const>\<open>Xcoord\<close> and~\<open>Ycoord\<close>, while the polymorphic type \<^typ>\<open>'a point_scheme\<close> comprises all possible extensions to those two
  fields.  Note that \<^typ>\<open>unit point_scheme\<close> coincides with \<^typ>\<open>point\<close>, and \<^typ>\<open>\<lparr>col :: colour\<rparr> point_scheme\<close> with \<^typ>\<open>cpoint\<close>.

  In the following example we define two operations --- methods, if we
  regard records as objects --- to get and set any point's \<open>Xcoord\<close> field.
\<close>

definition getX :: "'a point_scheme \<Rightarrow> int" where
"getX r \<equiv> Xcoord r"
definition setX :: "'a point_scheme \<Rightarrow> int \<Rightarrow> 'a point_scheme" where
"setX r a \<equiv> r\<lparr>Xcoord := a\<rparr>"

text \<open>
  Here is a generic method that modifies a point, incrementing its
  \<^const>\<open>Xcoord\<close> field.  The \<open>Ycoord\<close> and \<open>more\<close> fields
  are copied across.  It works for any record type scheme derived from
  \<^typ>\<open>point\<close> (including \<^typ>\<open>cpoint\<close> etc.):
\<close>

definition incX :: "'a point_scheme \<Rightarrow> 'a point_scheme" where
"incX r \<equiv>
  \<lparr>Xcoord = Xcoord r + 1, Ycoord = Ycoord r, \<dots> = point.more r\<rparr>"

text \<open>
  Generic theorems can be proved about generic methods.  This trivial
  lemma relates \<^const>\<open>incX\<close> to \<open>getX\<close> and \<open>setX\<close>:
\<close>

lemma "incX r = setX r (getX r + 1)"
  by (simp add: getX_def setX_def incX_def)

text \<open>
  \begin{warn}
  If you use the symbolic record brackets \<open>\<lparr>\<close> and \<open>\<rparr>\<close>,
  then you must also use the symbolic ellipsis, ``\<open>\<dots>\<close>'', rather
  than three consecutive periods, ``\<open>...\<close>''.  Mixing the ASCII
  and symbolic versions causes a syntax error.  (The two versions are
  more distinct on screen than they are on paper.)
  \end{warn}%
  \index{records!extensible|)}
\<close>

subsection \<open>Record Equality\<close>

text \<open>
  Two records are equal\index{equality!of records} if all pairs of
  corresponding fields are equal.  Concrete record equalities are
  simplified automatically:
\<close>

lemma "(\<lparr>Xcoord = a, Ycoord = b\<rparr> = \<lparr>Xcoord = a', Ycoord = b'\<rparr>) =
    (a = a' \<and> b = b')"
  by simp

text \<open>
  The following equality is similar, but generic, in that \<open>r\<close>
  can be any instance of \<^typ>\<open>'a point_scheme\<close>:
\<close>

lemma "r\<lparr>Xcoord := a, Ycoord := b\<rparr> = r\<lparr>Ycoord := b, Xcoord := a\<rparr>"
  by simp

text \<open>\noindent
  We see above the syntax for iterated updates.  We could equivalently
  have written the left-hand side as \<open>r\<lparr>Xcoord := a\<rparr>\<lparr>Ycoord :=
  b\<rparr>\<close>.

  Record equality is \emph{extensional}:
  \index{extensionality!for records} a record is determined entirely
  by the values of its fields.
\<close>

lemma "r = \<lparr>Xcoord = Xcoord r, Ycoord = Ycoord r\<rparr>"
  by simp

text \<open>\noindent
  The generic version of this equality includes the pseudo-field
  \<open>more\<close>:
\<close>

lemma "r = \<lparr>Xcoord = Xcoord r, Ycoord = Ycoord r, \<dots> = point.more r\<rparr>"
  by simp

text \<open>
  The simplifier can prove many record equalities
  automatically, but general equality reasoning can be tricky.
  Consider proving this obvious fact:
\<close>

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"
  apply simp?
  oops

text \<open>\noindent
  Here the simplifier can do nothing, since general record equality is
  not eliminated automatically.  One way to proceed is by an explicit
  forward step that applies the selector \<^const>\<open>Xcoord\<close> to both sides
  of the assumed record equality:
\<close>

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"
  apply (drule_tac f = Xcoord in arg_cong)
  txt \<open>@{subgoals [display, indent = 0, margin = 65]}
    Now, \<open>simp\<close> will reduce the assumption to the desired
    conclusion.\<close>
  apply simp
  done

text \<open>
  The \<open>cases\<close> method is preferable to such a forward proof.  We
  state the desired lemma again:
\<close>

lemma "r\<lparr>Xcoord := a\<rparr> = r\<lparr>Xcoord := a'\<rparr> \<Longrightarrow> a = a'"

  txt \<open>The \methdx{cases} method adds an equality to replace the
  named record term by an explicit record expression, listing all
  fields.  It even includes the pseudo-field \<open>more\<close>, since the
  record equality stated here is generic for all extensions.\<close>

  apply (cases r)

  txt \<open>@{subgoals [display, indent = 0, margin = 65]} Again, \<open>simp\<close> finishes the proof.  Because \<open>r\<close> is now represented as
  an explicit record construction, the updates can be applied and the
  record equality can be replaced by equality of the corresponding
  fields (due to injectivity).\<close>

  apply simp
  done

text \<open>
  The generic cases method does not admit references to locally bound
  parameters of a goal.  In longer proof scripts one might have to
  fall back on the primitive \<open>rule_tac\<close> used together with the
  internal field representation rules of records.  The above use of
  \<open>(cases r)\<close> would become \<open>(rule_tac r = r in
  point.cases_scheme)\<close>.
\<close>

subsection \<open>Extending and Truncating Records\<close>

text \<open>
  Each record declaration introduces a number of derived operations to
  refer collectively to a record's fields and to convert between fixed
  record types.  They can, for instance, convert between types \<^typ>\<open>point\<close> and \<^typ>\<open>cpoint\<close>.  We can add a colour to a point or convert
  a \<^typ>\<open>cpoint\<close> to a \<^typ>\<open>point\<close> by forgetting its colour.

  \begin{itemize}

  \item Function \cdx{make} takes as arguments all of the record's
  fields (including those inherited from ancestors).  It returns the
  corresponding record.

  \item Function \cdx{fields} takes the record's very own fields and
  returns a record fragment consisting of just those fields.  This may
  be filled into the \<open>more\<close> part of the parent record scheme.

  \item Function \cdx{extend} takes two arguments: a record to be
  extended and a record containing the new fields.

  \item Function \cdx{truncate} takes a record (possibly an extension
  of the original record type) and returns a fixed record, removing
  any additional fields.

  \end{itemize}
  These functions provide useful abbreviations for standard
  record expressions involving constructors and selectors.  The
  definitions, which are \emph{not} unfolded by default, are made
  available by the collective name of \<open>defs\<close> (\<open>point.defs\<close>, \<open>cpoint.defs\<close>, etc.).
  For example, here are the versions of those functions generated for
  record \<^typ>\<open>point\<close>.  We omit \<open>point.fields\<close>, which happens to
  be the same as \<open>point.make\<close>.

  @{thm [display, indent = 0, margin = 65] point.make_def [no_vars]
  point.extend_def [no_vars] point.truncate_def [no_vars]}
  Contrast those with the corresponding functions for record \<^typ>\<open>cpoint\<close>.  Observe \<open>cpoint.fields\<close> in particular.
  @{thm [display, indent = 0, margin = 65] cpoint.make_def [no_vars]
  cpoint.fields_def [no_vars] cpoint.extend_def [no_vars]
  cpoint.truncate_def [no_vars]}

  To demonstrate these functions, we declare a new coloured point by
  extending an ordinary point.  Function \<open>point.extend\<close> augments
  \<open>pt1\<close> with a colour value, which is converted into an
  appropriate record fragment by \<open>cpoint.fields\<close>.
\<close>

definition cpt2 :: cpoint where
"cpt2 \<equiv> point.extend pt1 (cpoint.fields Green)"

text \<open>
  The coloured points \<^const>\<open>cpt1\<close> and \<open>cpt2\<close> are equal.  The
  proof is trivial, by unfolding all the definitions.  We deliberately
  omit the definition of~\<open>pt1\<close> in order to reveal the underlying
  comparison on type \<^typ>\<open>point\<close>.
\<close>

lemma "cpt1 = cpt2"
  apply (simp add: cpt1_def cpt2_def point.defs cpoint.defs)
  txt \<open>@{subgoals [display, indent = 0, margin = 65]}\<close>
  apply (simp add: pt1_def)
  done

text \<open>
  In the example below, a coloured point is truncated to leave a
  point.  We use the \<open>truncate\<close> function of the target record.
\<close>

lemma "point.truncate cpt2 = pt1"
  by (simp add: pt1_def cpt2_def point.defs)

text \<open>
  \begin{exercise}
  Extend record \<^typ>\<open>cpoint\<close> to have a further field, \<open>intensity\<close>, of type~\<^typ>\<open>nat\<close>.  Experiment with generic operations
  (using polymorphic selectors and updates) and explicit coercions
  (using \<open>extend\<close>, \<open>truncate\<close> etc.) among the three record
  types.
  \end{exercise}

  \begin{exercise}
  (For Java programmers.)
  Model a small class hierarchy using records.
  \end{exercise}
  \index{records|)}
\<close>

(*<*)
end
(*>*)


section \<open> Designs \<close>

theory ITree_Designs
  imports ITree_WP
begin

named_theorems dpre

text \<open> The design precondition captures the initial states that do not give the possibility of divergence.
  This is different to the weakest precondition, which expresses the related property of the precondition
  under which the program terminates. \<close>

definition itree_pre :: "('e, 'r, 's) ktree \<Rightarrow> ('r \<Rightarrow> bool)" where
"itree_pre P = (\<lambda> s. \<not> (\<exists> es. P s \<midarrow>es\<leadsto> diverge))"

lemma itree_pre_div_free: "itree_pre P = (\<lambda> s. div_free (P s))"
  by (simp add: div_free_is_no_divergence itree_pre_def no_divergence_def)

expr_ctr itree_pre

definition refined_by :: "('e, 'r, 's) ktree \<Rightarrow> ('e, 'r, 's) ktree \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>\<D>" 50) where
"refined_by P Q = (`itree_pre P \<longrightarrow> itree_pre Q` \<and> {(s, s') \<in> itree_rel Q. itree_pre P s} \<subseteq> itree_rel P)"

lemma assume_pre [dpre]: "itree_pre (assume b) = b"
  by (auto simp add: itree_pre_def assume_def fun_eq_iff)

lemma assert_pre [dpre]: "itree_pre (assert b) = (True)\<^sub>e"
  by (auto simp add: itree_pre_def test_def fun_eq_iff)
     (metis deadlock_def deadlock_trace_to diverge_not_Vis)

lemma assigns_pre [dpre]: "itree_pre \<langle>\<sigma>\<rangle>\<^sub>a = (True)\<^sub>e"
  by (auto simp add: itree_pre_def assigns_def)

lemma Div_pre [dpre]: "itree_pre Div = (False)\<^sub>e"
  by (auto simp add: itree_pre_def fun_eq_iff)

lemma Div_bottom: "Div \<sqsubseteq>\<^sub>\<D> P"
  by (simp add: refined_by_def Div_rel Div_pre)

lemma Stop_pre [dpre]: "itree_pre Stop = (True)\<^sub>e"
  by (auto simp add: itree_pre_def fun_eq_iff deadlock_def)

lemma seq_pre [dpre]: "itree_pre (P ;; Q) = (itree_pre P \<and> wlp P (itree_pre Q))\<^sub>e"
  apply (expr_simp, auto elim!: trace_to_bindE simp add: seq_itree_def kleisli_comp_def itree_pre_def wlp_itree_def itree_rel_defs retvals_def)
  apply (metis bind_diverge trace_to_bind_left)
  apply (meson trace_to_bind)
  apply (metis trace_of_Sils trace_to_Nil trace_to_trans)
  done

lemma input_in_pre [dpre]:
  "wb_prism c \<Longrightarrow> itree_pre (input_in c A P) = (\<forall> v \<in> A. itree_pre (P v))\<^sub>e"
  by (expr_simp add: itree_pre_div_free input_in_where_def div_free_bind div_free_inp_in retvals_inp_in)

method refine = (auto simp add: refined_by_def dpre wp usubst_eval unrest itree_rel relcomp_unfold)
method refine_auto = (refine ; expr_auto)

end