section \<open> Substitutions \<close>

theory Substitutions
  imports Unrestriction
begin

type_synonym ('s\<^sub>1, 's\<^sub>2) psubst = "'s\<^sub>1 \<Rightarrow> 's\<^sub>2"
type_synonym 's subst = "'s \<Rightarrow> 's"

definition subst_nil :: "('s\<^sub>1, 's\<^sub>2) psubst" ("\<lparr>\<leadsto>\<rparr>")
  where [expr_defs, code_unfold]: "\<lparr>\<leadsto>\<rparr> = (\<lambda> s. undefined)"

definition subst_id :: "'s subst" ("[\<leadsto>]")
  where [expr_defs, code_unfold]: "subst_id = (\<lambda>s. s)"

definition subst_default :: "('s\<^sub>1, 's\<^sub>2::default) psubst" ("\<lblot>\<leadsto>\<rblot>")
  where [expr_defs, code_unfold]: "\<lblot>\<leadsto>\<rblot> = (\<lambda> s. default)"

definition subst_ext :: "('s\<^sub>1 \<Longrightarrow> 's\<^sub>2) \<Rightarrow> ('s\<^sub>2, 's\<^sub>1) psubst" ("_\<^sup>\<up>" [999] 999) where
[expr_defs, code_unfold]: "subst_ext a = get\<^bsub>a\<^esub>"

definition subst_res :: "('s\<^sub>1 \<Longrightarrow> 's\<^sub>2) \<Rightarrow> ('s\<^sub>1, 's\<^sub>2) psubst" ("_\<^sub>\<down>" [999] 999) where
[expr_defs, code_unfold]: "subst_res a = create\<^bsub>a\<^esub>"

definition subst_app :: "('s\<^sub>1, 's\<^sub>2) psubst \<Rightarrow> ('a, 's\<^sub>2) expr \<Rightarrow> ('a, 's\<^sub>1) expr"
  where [expr_defs]: "subst_app \<sigma> e = (\<lambda> s. e (\<sigma> s))"

syntax "_subst_app" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<dagger>" 65)

translations
  "_subst_app \<sigma> e" == "CONST subst_app \<sigma> e"
  "_subst_app \<sigma> e" <= "_subst_app \<sigma> (e)\<^sub>e"

abbreviation "aext P a \<equiv> subst_app (a\<^sup>\<up>) P"
abbreviation "ares P a \<equiv> subst_app (a\<^sub>\<down>) P"

definition subst_comp :: "('s\<^sub>1, 's\<^sub>2) psubst \<Rightarrow> ('s\<^sub>3, 's\<^sub>1) psubst \<Rightarrow> ('s\<^sub>3, 's\<^sub>2) psubst" (infixl "\<circ>\<^sub>s" 55)
    where [expr_defs, code_unfold]: "subst_comp = comp"

text \<open> Create a substitution that copies the region from the given scene from a given state.
  This is used primarily in calculating unrestriction conditions. \<close>

definition sset :: "'s scene \<Rightarrow> 's \<Rightarrow> 's subst"
  where [expr_defs, code_unfold]: "sset a s' = (\<lambda> s. s \<oplus>\<^sub>S s' on a)"

syntax "_sset" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("sset[_, _]")
translations "_sset a P" == "CONST sset a P"

definition subst_upd :: "('s\<^sub>1, 's\<^sub>2) psubst \<Rightarrow> ('a \<Longrightarrow> 's\<^sub>2) \<Rightarrow> ('a, 's\<^sub>1) expr \<Rightarrow> ('s\<^sub>1, 's\<^sub>2) psubst"
  where [expr_defs, code_unfold]: "subst_upd \<sigma> x e = (\<lambda> s. put\<^bsub>x\<^esub> (\<sigma> s) (e s))"

definition subst_lookup :: "('s\<^sub>1, 's\<^sub>2) psubst \<Rightarrow> ('a \<Longrightarrow> 's\<^sub>2) \<Rightarrow> ('a, 's\<^sub>1) expr" ("\<langle>_\<rangle>\<^sub>s")
  where [expr_defs, code_unfold]: "\<langle>\<sigma>\<rangle>\<^sub>s x = (\<lambda> s. get\<^bsub>x\<^esub> (\<sigma> s))"

expr_constructor subst_lookup

definition unrest_usubst :: "'s scene \<Rightarrow> 's subst \<Rightarrow> bool"
  where [expr_defs]: "unrest_usubst a \<sigma> = (\<forall> s s'. \<sigma> (s \<oplus>\<^sub>S s' on a) = (\<sigma> s) \<oplus>\<^sub>S s' on a)"

syntax
  "_unrest_usubst" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<sharp>\<^sub>s" 20)

translations
  "_unrest_usubst x p" == "CONST unrest_usubst x p"
  "_unrest_usubst (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_unrest_usubst (x +\<^sub>L y) P"

definition par_subst :: "'s subst \<Rightarrow> 's scene \<Rightarrow> 's scene \<Rightarrow> 's subst \<Rightarrow> 's subst"
  where [expr_defs]: "par_subst \<sigma>\<^sub>1 A B \<sigma>\<^sub>2 = (\<lambda> s. (s \<oplus>\<^sub>S (\<sigma>\<^sub>1 s) on A) \<oplus>\<^sub>S (\<sigma>\<^sub>2 s) on B)"

nonterminal uexprs and smaplet and smaplets

syntax
  "_smaplet"        :: "[svid, logic] => smaplet" ("_ \<leadsto>/ _")
  ""                :: "smaplet => smaplets" ("_")
  "_SMaplets"       :: "[smaplet, smaplets] => smaplets" ("_,/ _")
  \<comment> \<open> A little syntax utility to extract a list of variable identifiers from a substitution \<close>
  "_smaplets_svids" :: "smaplets \<Rightarrow> logic"
  "_SubstUpd"       :: "[logic, smaplets] => logic" ("_/'(_')" [900,0] 900)
  "_Subst"          :: "smaplets => logic" ("(1[_])")
  "_PSubst"         :: "smaplets => logic" ("(1\<lparr>_\<rparr>)")
  "_DSubst"         :: "smaplets \<Rightarrow> logic" ("(1\<lblot>_\<rblot>)")
  "_psubst"         :: "[logic, svids, uexprs] \<Rightarrow> logic"
  "_subst"          :: "logic \<Rightarrow> uexprs \<Rightarrow> svids \<Rightarrow> logic" ("(_\<lbrakk>_'/_\<rbrakk>)" [990,0,0] 991)
  "_uexprs"         :: "[logic, uexprs] => uexprs" ("_,/ _")
  ""                :: "logic => uexprs" ("_")
  "_par_subst"      :: "logic \<Rightarrow> salpha \<Rightarrow> salpha \<Rightarrow> logic \<Rightarrow> logic" ("_ [_|_]\<^sub>s _" [100,0,0,101] 101)

translations
  "_SubstUpd m (_SMaplets xy ms)"     == "_SubstUpd (_SubstUpd m xy) ms"
  "_SubstUpd m (_smaplet x y)"        == "CONST subst_upd m x (y)\<^sub>e"
  "_smaplet (_svid_tuple (_of_svid_list (x +\<^sub>L y))) e" <= "_smaplet (x +\<^sub>L y) e"
  "_Subst ms"                         == "_SubstUpd [\<leadsto>] ms"
  "_Subst (_SMaplets ms1 ms2)"        <= "_SubstUpd (_Subst ms1) ms2"
  "_PSubst ms"                        == "_SubstUpd \<lparr>\<leadsto>\<rparr> ms"
  "_PSubst (_SMaplets ms1 ms2)"       <= "_SubstUpd (_PSubst ms1) ms2"
  "_DSubst ms"                        == "_SubstUpd \<lblot>\<leadsto>\<rblot> ms"
  "_DSubst (_SMaplets ms1 ms2)"       <= "_SubstUpd (_DSubst ms1) ms2"
  "_SMaplets ms1 (_SMaplets ms2 ms3)" <= "_SMaplets (_SMaplets ms1 ms2) ms3"
  "_smaplets_svids (_SMaplets (_smaplet x e) ms)" => "x +\<^sub>L (_smaplets_svids ms)"
  "_smaplets_svids (_smaplet x e)" => "x"
  "_subst P es vs" => "CONST subst_app (_psubst [\<leadsto>] vs es) P"
  "_psubst m (_svid_list x xs) (_uexprs v vs)" => "_psubst (_psubst m x v) xs vs"
  "_psubst m x v"  => "CONST subst_upd m x (v)\<^sub>e"
  "_subst P v x" <= "CONST subst_app (CONST subst_upd [\<leadsto>] x (v)\<^sub>e) P"
  "_subst P v x" <= "_subst (_sexp_quote P)  v x"
  "_subst P v (_svid_tuple (_of_svid_list (x +\<^sub>L y)))" <= "_subst P v (x +\<^sub>L y)"
  "_par_subst \<sigma>\<^sub>1 A B \<sigma>\<^sub>2" == "CONST par_subst \<sigma>\<^sub>1 A B \<sigma>\<^sub>2"

expr_constructor subst_app (1)
expr_constructor subst_id
expr_constructor subst_nil
expr_constructor subst_default
expr_constructor subst_upd

ML_file \<open>Expr_Util.ML\<close>

subsection \<open> Substitution Laws \<close>

named_theorems usubst and usubst_eval

lemma subst_id_apply [usubst]: "[\<leadsto>] \<dagger> P = P"
  by (expr_auto)

lemma subst_unrest [usubst]:
  "\<lbrakk> vwb_lens x; $x \<sharp> v \<rbrakk> \<Longrightarrow> \<sigma>(x \<leadsto> e) \<dagger> v = \<sigma> \<dagger> v"
  by expr_auto

lemma subst_lookup_id [usubst]: "\<langle>[\<leadsto>]\<rangle>\<^sub>s x = var x"
  by expr_simp

lemma subst_lookup_aext [usubst]: "\<langle>a\<^sup>\<up>\<rangle>\<^sub>s x = get\<^bsub>ns_alpha a x\<^esub>"
  by expr_auto

lemma subst_id_var: "[\<leadsto>] = ($\<^bold>v)\<^sub>e"
  by expr_simp

lemma subst_upd_id_lam [usubst]: "subst_upd ($\<^bold>v)\<^sub>e x v = subst_upd [\<leadsto>] x v"
  by expr_simp

lemma subst_id [simp]: "[\<leadsto>] \<circ>\<^sub>s \<sigma> = \<sigma>" "\<sigma> \<circ>\<^sub>s [\<leadsto>] = \<sigma>"
  by expr_auto+

lemma subst_default_id [simp]: "\<lblot>\<leadsto>\<rblot> \<circ>\<^sub>s \<sigma> = \<lblot>\<leadsto>\<rblot>"
  by (simp add: expr_defs comp_def)

lemma subst_lookup_one_lens [usubst]: "\<langle>\<sigma>\<rangle>\<^sub>s 1\<^sub>L = \<sigma>"
  by expr_simp

lemma usubst_apply_twice [usubst]:
  "\<rho> \<dagger> (\<sigma> \<dagger> e) = (\<sigma> \<circ>\<^sub>s \<rho>) \<dagger> e"
  by expr_simp

lemma usubst_apply_twice_SEXP [usubst]:
  "\<rho> \<dagger> [\<sigma> \<dagger> e]\<^sub>e = (\<sigma> \<circ>\<^sub>s \<rho>) \<dagger> [e]\<^sub>e"
  by expr_simp

(* FIXME: Figure out how to make laws like this parse and simplify *)

term "(f (\<sigma> \<dagger> e))\<^sub>e"

term "(\<forall> x. x + $y > $z)\<^sub>e"

term "(\<forall> k. P\<lbrakk>\<guillemotleft>k\<guillemotright>/x\<rbrakk>)\<^sub>e"

lemma subst_var [usubst]: "\<sigma> \<dagger> ($x)\<^sub>e = \<langle>\<sigma>\<rangle>\<^sub>s x"
  by (simp add: expr_defs)

text \<open> We can't use this as simplification unfortunately as the expression structure is too
  ambiguous to support automatic rewriting. \<close>

lemma subst_uop: "\<sigma> \<dagger> (\<guillemotleft>f\<guillemotright> e)\<^sub>e = (\<guillemotleft>f\<guillemotright> (\<sigma> \<dagger> e))\<^sub>e"
  by (simp add: expr_defs)

lemma subst_bop: "\<sigma> \<dagger> (\<guillemotleft>f\<guillemotright> e\<^sub>1 e\<^sub>2)\<^sub>e = (\<guillemotleft>f\<guillemotright> (\<sigma> \<dagger> e\<^sub>1) (\<sigma> \<dagger> e\<^sub>2))\<^sub>e"
  by (simp add: expr_defs)

lemma subst_lit [usubst]: "\<sigma> \<dagger> (\<guillemotleft>v\<guillemotright>)\<^sub>e = (\<guillemotleft>v\<guillemotright>)\<^sub>e"
  by (expr_simp)

lemmas subst_basic_ops [usubst] =
  subst_bop[where f=conj]
  subst_bop[where f=disj]
  subst_bop[where f=implies]
  subst_uop[where f=Not]
  subst_bop[where f=HOL.eq]
  subst_bop[where f=less]
  subst_bop[where f=less_eq]
  subst_bop[where f=Set.member]
  subst_bop[where f=inf]
  subst_bop[where f=sup]
  subst_bop[where f=Pair]

text \<open> A substitution update naturally yields the given expression. \<close>

lemma subst_lookup_upd [usubst]:
  assumes "weak_lens x"
  shows "\<langle>\<sigma>(x \<leadsto> v)\<rangle>\<^sub>s x = (v)\<^sub>e"
  using assms by (simp add: expr_defs)

lemma subst_lookup_upd_diff [usubst]:
  assumes "x \<bowtie> y"
  shows "\<langle>\<sigma>(y \<leadsto> v)\<rangle>\<^sub>s x = \<langle>\<sigma>\<rangle>\<^sub>s x"
  using assms by (simp add: expr_defs)

lemma subst_lookup_pair [usubst]:
  "\<langle>\<sigma>\<rangle>\<^sub>s (x +\<^sub>L y) = ((\<langle>\<sigma>\<rangle>\<^sub>s x, \<langle>\<sigma>\<rangle>\<^sub>s y))\<^sub>e"
  by (expr_simp)

text \<open> Substitution update is idempotent. \<close>

lemma usubst_upd_idem [usubst]:
  assumes "mwb_lens x"
  shows "\<sigma>(x \<leadsto> u, x \<leadsto> v) = \<sigma>(x \<leadsto> v)"
  using assms by (simp add: expr_defs)

lemma usubst_upd_idem_sub [usubst]:
  assumes "x \<subseteq>\<^sub>L y" "mwb_lens y"
  shows "\<sigma>(x \<leadsto> u, y \<leadsto> v) = \<sigma>(y \<leadsto> v)"
  using assms by (simp add: expr_defs assms fun_eq_iff sublens_put_put)

text \<open> Substitution updates commute when the lenses are independent. \<close>

lemma usubst_upd_comm:
  assumes "x \<bowtie> y"
  shows "\<sigma>(x \<leadsto> u, y \<leadsto> v) = \<sigma>(y \<leadsto> v, x \<leadsto> u)"
  using assms unfolding subst_upd_def
  by (auto simp add: subst_upd_def assms comp_def lens_indep_comm)

lemma usubst_upd_comm2:
  assumes "z \<bowtie> y"
  shows "\<sigma>(x \<leadsto> u, y \<leadsto> v, z \<leadsto> s) = \<sigma>(x \<leadsto> u, z \<leadsto> s, y \<leadsto> v)"
  using assms unfolding subst_upd_def
  by (auto simp add: subst_upd_def assms comp_def lens_indep_comm)

lemma usubst_upd_var_id [usubst]:
  "vwb_lens x \<Longrightarrow> [x \<leadsto> $x] = [\<leadsto>]"
  by (simp add: subst_upd_def subst_id_def id_lens_def SEXP_def)

lemma usubst_upd_pair [usubst]:
  "\<sigma>((x, y) \<leadsto> (e, f)) = \<sigma>(y \<leadsto> f, x \<leadsto> e)"
  by (simp add: subst_upd_def lens_defs SEXP_def fun_eq_iff)

lemma subst_upd_comp [usubst]:
  "\<rho>(x \<leadsto> v) \<circ>\<^sub>s \<sigma> = (\<rho> \<circ>\<^sub>s \<sigma>)(x \<leadsto> \<sigma> \<dagger> v)"
  by (simp add: expr_defs fun_eq_iff)

subsection \<open> Proof rules \<close>

text \<open> In proof, a lens can always be substituted for an arbitrary but fixed value. \<close>

lemma taut_substI:
  assumes "vwb_lens x" "\<And> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`"
  shows "`P`"
  using assms by (expr_simp, metis vwb_lens.put_eq)

lemma eq_substI:
  assumes "vwb_lens x" "\<And> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>"
  shows "P = Q"
  using assms by (expr_simp, metis vwb_lens.put_eq)

lemma less_eq_substI:
  assumes "vwb_lens x" "\<And> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> \<le> Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>"
  shows "P \<le> Q"
  using assms by (expr_simp, metis le_funE le_funI vwb_lens_def wb_lens.source_stability)

subsection \<open> Ordering substitutions \<close>

text \<open> A simplification procedure to reorder substitutions maplets lexicographically by variable syntax \<close>

simproc_setup subst_order ("subst_upd (subst_upd \<sigma> x u) y v") =
  \<open> (fn _ => fn ctx => fn ct =>
        case (Thm.term_of ct) of
          Const (@{const_name subst_upd}, _) $ (Const (@{const_name subst_upd}, _) $ s $ x $ u) $ y $ v
            => if (YXML.content_of (Syntax.string_of_term ctx x) > YXML.content_of(Syntax.string_of_term ctx y))
               then SOME (mk_meta_eq @{thm usubst_upd_comm})
               else NONE  |
          _ => NONE)
  \<close>

subsection \<open> Substitution Unrestriction Laws \<close>

lemma unrest_subst_lens [expr_simps]: "mwb_lens x \<Longrightarrow> ($x \<sharp>\<^sub>s \<sigma>) = (\<forall>s v. \<sigma> (put\<^bsub>x\<^esub> s v) = put\<^bsub>x\<^esub> (\<sigma> s) v)"
  by (simp add: unrest_usubst_def, metis lens_override_def mwb_lens_weak weak_lens.create_get)

lemma unrest_subst_empty [unrest]: "x \<sharp>\<^sub>s [\<leadsto>]"
  by (expr_simp)

lemma unrest_subst_upd [unrest]: "\<lbrakk> vwb_lens x; x \<bowtie> y; $x \<sharp> (e)\<^sub>e; $x \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> $x \<sharp>\<^sub>s \<sigma>(y \<leadsto> e)"
  by (expr_auto add: lens_indep_comm)

lemma unrest_subst_apply [unrest]:
  "\<lbrakk> $x \<sharp> P; $x \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> $x \<sharp> (\<sigma> \<dagger> P)"
  by (expr_auto)

subsection \<open> Conditional Substitution Laws \<close>

lemma usubst_cond_upd_1 [usubst]:
  "\<sigma>(x \<leadsto> u) \<triangleleft> b \<triangleright> \<rho>(x \<leadsto> v) = (\<sigma> \<triangleleft> b \<triangleright> \<rho>)(x \<leadsto> (u \<triangleleft> b \<triangleright> v))"
  by expr_auto

lemma usubst_cond_upd_2 [usubst]:
  "\<lbrakk> vwb_lens x; $x \<sharp>\<^sub>s \<rho> \<rbrakk> \<Longrightarrow> \<sigma>(x \<leadsto> u) \<triangleleft> b \<triangleright> \<rho> = (\<sigma> \<triangleleft> b \<triangleright> \<rho>)(x \<leadsto> (u \<triangleleft> b \<triangleright> ($x)\<^sub>e))"
  by (expr_auto, metis lens_override_def lens_override_idem)

lemma usubst_cond_upd_3 [usubst]:
  "\<lbrakk> vwb_lens x; $x \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<sigma> \<triangleleft> b \<triangleright> \<rho>(x \<leadsto> v) = (\<sigma> \<triangleleft> b \<triangleright> \<rho>)(x \<leadsto> (($x)\<^sub>e \<triangleleft> b \<triangleright> v))"
  by (expr_auto, metis lens_override_def lens_override_idem)

subsection \<open> Evaluation \<close>

lemma subst_SEXP [usubst_eval]: "\<sigma> \<dagger> [\<lambda> s. e s]\<^sub>e = [\<lambda> s. e (\<sigma> s)]\<^sub>e"
  by (simp add: SEXP_def subst_app_def fun_eq_iff)

lemma get_subst_id [usubst_eval]: "get\<^bsub>x\<^esub> ([\<leadsto>] s) = get\<^bsub>x\<^esub> s"
  by (simp add: subst_id_def)

lemma get_subst_upd_same [usubst_eval]: "weak_lens x \<Longrightarrow> get\<^bsub>x\<^esub> ((\<sigma>(x \<leadsto> e)) s) = e s"
  by (simp add: subst_upd_def SEXP_def)

lemma get_subst_upd_indep [usubst_eval]:
  "x \<bowtie> y \<Longrightarrow> get\<^bsub>x\<^esub> ((\<sigma>(y \<leadsto> e)) s) = get\<^bsub>x\<^esub> (\<sigma> s)"
  by (simp add: subst_upd_def)

lemma unrest_ssubst: "(a \<sharp> P) \<longleftrightarrow> (\<forall> s'. sset a s' \<dagger> P = (P)\<^sub>e)"
  by (auto simp add: expr_defs fun_eq_iff)

lemma get_subst_sset_out [usubst_eval]: "\<lbrakk> vwb_lens x; var_alpha x \<bowtie>\<^sub>S a \<rbrakk> \<Longrightarrow> get\<^bsub>x\<^esub> (sset a s' s) = get\<^bsub>x\<^esub> s"
  by (simp add: expr_defs var_alpha_def get_scene_override_indep)

lemma get_subst_sset_in [usubst_eval]: "\<lbrakk> vwb_lens x; var_alpha x \<le> a \<rbrakk> \<Longrightarrow> get\<^bsub>x\<^esub> (sset a s' s) = get\<^bsub>x\<^esub> s'"
  by (simp add: get_scene_override_le sset_def var_alpha_def)

lemma get_subst_ext [usubst_eval]: "get\<^bsub>x\<^esub> (subst_ext a s) = get\<^bsub>ns_alpha a x\<^esub> s"
  by (expr_simp)

lemma unrest_sset_lens [unrest]: "\<lbrakk> mwb_lens x; mwb_lens y; x \<bowtie> y \<rbrakk> \<Longrightarrow> $x \<sharp>\<^sub>s sset[$y, s]"
  by (simp add: sset_def unrest_subst_lens lens_indep_comm lens_override_def)

text \<open> If a variable is unrestricted in a substitution then it's application has no effect. \<close>

lemma usubst_apply_unrest:
  "\<lbrakk> vwb_lens x; $x \<sharp>\<^sub>s \<sigma> \<rbrakk> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s x = var x"
proof -
  assume 1: "vwb_lens x" and "$x \<sharp>\<^sub>s \<sigma>"
  hence "\<forall>s s'. \<sigma> (s \<oplus>\<^sub>L s' on x) = \<sigma> s \<oplus>\<^sub>L s' on x"
    by (simp add: unrest_usubst_def)
  thus "\<langle>\<sigma>\<rangle>\<^sub>s x = var x"
    by (metis 1 lens_override_def lens_override_idem mwb_lens_weak subst_lookup_def vwb_lens_mwb weak_lens.put_get)
qed

text \<open> A tactic for proving unrestrictions by evaluating a special kind of substitution. \<close>

method unrest = (simp add: unrest_ssubst var_alpha_combine usubst_eval)

text \<open> A tactic for evaluating substitutions. \<close>

method subst_eval = (simp add: usubst_eval usubst unrest)

end


theory Max_AJG
imports "../l4v/tools/autocorres/AutoCorres"
begin

text{*

Author: Andrew Gacek
Description: Correctness proof for a function that finds the max value in an array. The correctness
in this case is based on comparing the C code with that of a functional specification of a max
function over a list in Isabelle/HOL.

*}

install_C_file max_AJG.c
autocorres[ts_rules = nondet, unsigned_word_abs = max, heap_abs_syntax] max_AJG.c

context max_AJG begin

lemma ptr_add_assoc [simp]:
  "p +\<^sub>p (i + j) = p +\<^sub>p i +\<^sub>p j"
by (simp add: CTypesDefs.ptr_add_def distrib_right)

(*
 * Array validity definitions
 *)

definition array_loc_valid :: "32 word ptr \<Rightarrow> nat \<Rightarrow> bool" where
  "array_loc_valid a n \<equiv> (unat (ptr_val a) + size_of TYPE(32 word) * n \<le> UINT_MAX)"

fun array_elems_valid :: "lifted_globals \<Rightarrow> 32 word ptr \<Rightarrow> nat \<Rightarrow> bool" where
  "array_elems_valid s a 0 = True" |
  "array_elems_valid s a (Suc n) = (is_valid_w32 s a \<and> array_elems_valid s (a +\<^sub>p 1) n)"

definition is_array :: "lifted_globals \<Rightarrow> 32 word ptr \<Rightarrow> nat \<Rightarrow> bool" where
  "is_array s a n \<equiv> (array_loc_valid a n \<and> array_elems_valid s a n)"

lemma array_elems_valid_Suc [simp]:
  "array_elems_valid s a (Suc n) = (array_elems_valid s a n \<and> is_valid_w32 s (a +\<^sub>p int n))"
by (induction n arbitrary: a, auto)

declare array_elems_valid.simps(2)[simp del]

lemma array_all_elems_valid [intro]:
  "\<lbrakk> array_elems_valid s a n; m < n \<rbrakk> \<Longrightarrow> is_valid_w32 s (a +\<^sub>p int m)"
by (induction n arbitrary: a, auto elim: less_SucE)

lemma array_all_loc_valid [intro]:
  "\<lbrakk> array_loc_valid p n; m < n \<rbrakk> \<Longrightarrow> Suc m \<le> UINT_MAX"
by (simp add: array_loc_valid_def)

(*
 * Array contents
 *)

fun the_array :: "lifted_globals \<Rightarrow> 32 word ptr \<Rightarrow> nat \<Rightarrow> nat list" where
  "the_array s a 0 = []" |
  "the_array s a (Suc n) = unat s[a] # the_array s (a +\<^sub>p 1) n"

lemma the_array_Suc[simp]:
  "the_array s a (Suc n) = the_array s a n @ [unat s[a +\<^sub>p int n]]"
by (induction n arbitrary: a, auto)

declare the_array.simps(2)[simp del]

fun maxL :: "nat list \<Rightarrow> nat" where
  "maxL [] = 0" |
  "maxL (x#xs) = max x (maxL xs)"

lemma maxL_append [simp]:
  "maxL (xs @ ys) = max (maxL xs) (maxL ys)"
by (induction xs, auto)

lemma "\<lbrace> \<lambda>s. is_array s a n \<and> P s \<rbrace>
       max' a n
       \<lbrace> \<lambda>r s. r = maxL (the_array s a n) \<and> P s \<rbrace>!"
apply (unfold max'_def)
apply (subst whileLoop_add_inv[where
       I = "\<lambda>(i, result) s. result = maxL (the_array s a i) \<and>
                            i \<le> n \<and>
                            is_array s a n \<and>
                            P s" and
       M = "\<lambda>((i, result), s). n - i"])
apply wp
apply (auto simp add: is_array_def)
done

end
end


theory "HOLCF-Join-Classes"
imports "HOLCF-Join"
begin

class Finite_Join_cpo = cpo +
  assumes all_compatible: "compatible x y"

lemmas join_mono = join_mono[OF all_compatible all_compatible ]
lemmas join_above1[simp] = all_compatible[THEN join_above1]
lemmas join_above2[simp] = all_compatible[THEN join_above2]
lemmas join_below[simp] = all_compatible[THEN join_below]
lemmas join_below_iff = all_compatible[THEN join_below_iff]
lemmas join_assoc[simp] = join_assoc[OF all_compatible all_compatible all_compatible]
lemmas join_comm[simp] = all_compatible[THEN join_commute]

lemma join_lc[simp]: "x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> (z::'a::Finite_Join_cpo))"
  by (metis join_assoc join_comm)

lemma join_cont': "chain Y \<Longrightarrow> (\<Squnion> i. Y i) \<squnion> y = (\<Squnion> i. Y i \<squnion> (y::'a::Finite_Join_cpo))"
by (metis all_compatible join_cont1)

lemma join_cont1:
  fixes y :: "'a :: Finite_Join_cpo"
  shows "cont (\<lambda>x. (x \<squnion> y))"
  apply (rule contI2)
  apply (rule monofunI)
  apply (metis below_refl join_mono)
  apply (rule eq_imp_below)
  apply (rule join_cont')
  apply assumption
  done

lemma join_cont2:
  fixes x :: "'a :: Finite_Join_cpo"
  shows "cont (\<lambda>y. (x \<squnion> y))"
  by (simp only: join_comm) (rule join_cont1)

lemma join_cont[cont2cont,simp]:"cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. (f x \<squnion> (g x::'a::Finite_Join_cpo)))"
  apply (rule cont2cont_case_prod[where g = "\<lambda> x. (f x, g x)" and f = "\<lambda> p x y . x \<squnion> y", simplified])
  apply (rule join_cont2)
  apply (metis cont2cont_Pair)
  done

instantiation "fun" :: (type, Finite_Join_cpo) Finite_Join_cpo
begin
  definition fun_join :: "('a \<Rightarrow> 'b) \<rightarrow> ('a \<Rightarrow> 'b) \<rightarrow> ('a \<Rightarrow> 'b)"
    where "fun_join = (\<Lambda> f g . (\<lambda> x. (f x) \<squnion> (g x)))"

instantiation "cfun" :: (cpo, Finite_Join_cpo) Finite_Join_cpo
begin
  definition cfun_join :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b)"
    where "cfun_join = (\<Lambda> f g  x. (f \<cdot> x) \<squnion> (g \<cdot> x))"
  lemma [simp]: "cfun_join\<cdot>f\<cdot>g\<cdot>x = (f \<cdot> x) \<squnion> (g \<cdot> x)"
    unfolding cfun_join_def
      apply (subst beta_cfun, intro cont2cont cont2cont_lambda cont2cont_fun)+
      ..
  instance
  apply standard
  proof(intro compatibleI exI conjI strip)
    fix x y
    show "x \<sqsubseteq> cfun_join\<cdot>x\<cdot>y"  by (auto simp add: cfun_below_iff)
    show "y \<sqsubseteq> cfun_join\<cdot>x\<cdot>y"  by (auto simp add: cfun_below_iff)
    fix z
    assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    thus "cfun_join\<cdot>x\<cdot>y \<sqsubseteq> z" by (auto simp add: cfun_below_iff)
  qed
end

lemma bot_lub[simp]: "S <<| \<bottom> \<longleftrightarrow>  S \<subseteq> {\<bottom>}"
  by (auto dest!: is_lubD1 is_ubD intro: is_lubI is_ubI)

lemma compatible_up[simp]: "compatible (up\<cdot>x) (up\<cdot>y) \<longleftrightarrow> compatible x y"
proof
  assume "compatible (up\<cdot>x) (up\<cdot>y)"
  then obtain z' where z': "{up\<cdot>x,up\<cdot>y} <<| z'" unfolding compatible_def by auto
  then obtain z where  "{up\<cdot>x,up\<cdot>y} <<| up\<cdot>z" by (cases z') auto
  hence "{x,y} <<| z"
    unfolding is_lub_def
    apply auto
    by (metis up_below)
  thus "compatible x y"  unfolding compatible_def..
next
  assume "compatible x y"
  then obtain z where z: "{x,y} <<| z" unfolding compatible_def by auto
  hence  "{up\<cdot>x,up\<cdot>y} <<| up\<cdot>z"  unfolding is_lub_def
    apply auto
    by (metis not_up_less_UU upE up_below)
  thus "compatible (up\<cdot>x) (up\<cdot>y)"  unfolding compatible_def..
qed

instance u :: (Finite_Join_cpo) Finite_Join_cpo
proof
  fix x y :: "'a\<^sub>\<bottom>"
  show "compatible x y"
  apply (cases x, simp)
  apply (cases y, simp)
  apply (simp add: all_compatible)
  done
qed

class is_unit = fixes unit assumes is_unit: "\<And> x. x = unit"

instantiation unit :: is_unit
begin

definition "unit \<equiv> ()"

instance
  by standard auto

end

instance lift :: (is_unit) Finite_Join_cpo
proof
  fix x y :: "'a lift"
  show "compatible x y"
  apply (cases x, simp)
  apply (cases y, simp)
  apply (simp add: all_compatible)
  apply (subst is_unit)
  apply (subst is_unit) back
  apply simp
  done
qed

instance prod :: (Finite_Join_cpo, Finite_Join_cpo) Finite_Join_cpo
proof
  fix x y :: "('a \<times> 'b)"
  let ?z = "(fst x \<squnion> fst y, snd x \<squnion> snd y)"
  show "compatible x y"
  proof(rule compatibleI)
    show "x \<sqsubseteq> ?z" by (cases x, auto)
    show "y \<sqsubseteq> ?z" by (cases y, auto)
    fix z'
    assume "x \<sqsubseteq> z'" and "y \<sqsubseteq> z'" thus "?z \<sqsubseteq> z'"
      by (cases z', cases x, cases y, auto)
  qed
qed

lemma prod_join:
    fixes x y :: "'a::Finite_Join_cpo \<times> 'b::Finite_Join_cpo"
    shows "x \<squnion> y = (fst x \<squnion> fst y, snd x \<squnion> snd y)"
  apply (rule is_joinI)
  apply (cases x, auto)[1]
  apply (cases y, auto)[1]
  apply (cases x, cases y, case_tac a, auto)[1]
  done

lemma
  fixes x y :: "'a::Finite_Join_cpo \<times> 'b::Finite_Join_cpo"
  shows fst_join[simp]: "fst (x \<squnion> y) = fst x \<squnion> fst y"
  and snd_join[simp]: "snd (x \<squnion> y) = snd x \<squnion> snd y"
  unfolding prod_join by simp_all

lemma fun_meet_simp[simp]: "(f \<squnion> g) x = f x \<squnion> (g x::'a::Finite_Join_cpo)"
proof-
  have "f \<squnion> g = (\<lambda> x. f x \<squnion> g x)"
  by (rule is_joinI)(auto simp add: fun_below_iff)
  thus ?thesis by simp
qed

lemma fun_upd_meet_simp[simp]: "(f \<squnion> g) (x := y) = f (x := y)  \<squnion> g (x := y::'a::Finite_Join_cpo)"
  by auto

lemma cfun_meet_simp[simp]: "(f \<squnion> g) \<cdot> x = f \<cdot> x \<squnion> (g \<cdot> x::'a::Finite_Join_cpo)"
proof-
  have "f \<squnion> g = (\<Lambda> x. f \<cdot> x \<squnion> g \<cdot> x)"
  by (rule is_joinI)(auto simp add: cfun_below_iff)
  thus ?thesis by simp
qed

lemma cfun_join_below:
  fixes f :: "('a::Finite_Join_cpo) \<rightarrow> ('b::Finite_Join_cpo)"
  shows "f\<cdot>x \<squnion> f\<cdot>y \<sqsubseteq> f\<cdot>(x \<squnion> y)"
  by (intro join_below monofun_cfun_arg join_above1 join_above2)

lemma join_self_below[iff]:
  "x = x \<squnion> y \<longleftrightarrow> y \<sqsubseteq> (x::'a::Finite_Join_cpo)"
  "x = y \<squnion> x \<longleftrightarrow> y \<sqsubseteq> (x::'a::Finite_Join_cpo)"
  "x \<squnion> y = x \<longleftrightarrow> y \<sqsubseteq> (x::'a::Finite_Join_cpo)"
  "y \<squnion> x = x \<longleftrightarrow> y \<sqsubseteq> (x::'a::Finite_Join_cpo)"
  "x \<squnion> y \<sqsubseteq> x \<longleftrightarrow> y \<sqsubseteq> (x::'a::Finite_Join_cpo)"
  "y \<squnion> x \<sqsubseteq> x \<longleftrightarrow> y \<sqsubseteq> (x::'a::Finite_Join_cpo)"
  apply (metis join_above2 larger_is_join1)
  apply (metis join_above1 larger_is_join2)
  apply (metis join_above2 larger_is_join1)
  apply (metis join_above1 larger_is_join2)
  apply (metis join_above1 join_above2 below_antisym larger_is_join1)
  apply (metis join_above2 join_above1 below_antisym larger_is_join2)
  done

lemma join_bottom_iff[iff]:
  "x \<squnion> y = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> (y::'a::{Finite_Join_cpo,pcpo}) = \<bottom>"
  by (metis all_compatible join_bottom(2) join_comm join_idem)

class Join_cpo = cpo +
  assumes exists_lub: "\<exists>u. S <<| u"

context Join_cpo
begin
  subclass Finite_Join_cpo
    apply standard
    unfolding compatible_def
    apply (rule exists_lub)
  done
end

lemma below_lubI[intro, simp]:
  fixes x :: "'a :: Join_cpo"
  shows  "x \<in> S \<Longrightarrow> x \<sqsubseteq> lub S"
by (metis exists_lub is_ub_thelub_ex)

lemma lub_belowI[intro, simp]:
  fixes x :: "'a :: Join_cpo"
  shows  "(\<And> y. y \<in> S \<Longrightarrow> y \<sqsubseteq> x) \<Longrightarrow> lub S \<sqsubseteq> x"
by (metis exists_lub is_lub_thelub_ex is_ub_def)

(* subclass (in Join_cpo)  pcpo *)
instance Join_cpo \<subseteq> pcpo
  apply standard
  apply (rule exI[where x = "lub {}"])
  apply auto
  done

lemma lub_empty_set[simp]:
  "lub {} = (\<bottom>::'a::Join_cpo)"
  by (rule lub_eqI) simp

lemma lub_insert[simp]:
  fixes x :: "'a :: Join_cpo"
  shows "lub (insert x S) = x \<squnion> lub S"
by (rule lub_eqI) (auto intro: below_trans[OF _ join_above2] simp add: join_below_iff is_ub_def is_lub_def)

end


text\<open>This is an excerpt of the Optics library
     \<^url>\<open>https://www.isa-afp.org/entries/Optics.html\<close> by Frank Zeyda and
     Simon Foster. It provides a rich infrastructure for \<^emph>\<open>algebraic lenses\<close>,
     an abstract theory allowing to describe parts of memory and their
     independence. We use it to abstractly model typed program variables and
     framing conditions.

     Optics provides a rich framework for lense compositions and sub-lenses
     which we will not use in the context of Clean; even the offered concept
     of a list-lense, a possible means to model the stack-infrastructure
     required for local variables, is actually richer than needed.

     Since Clean strives for minimality, we restrict ourselves to this "proxy"
     theory for Optics.
\<close>

theory Optics
  imports Lens_Laws
begin

fun      upd_hd :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "upd_hd f [] = []"
      | "upd_hd f (a#S) = f a # S"

lemma [simp] :"tl (upd_hd f S) = tl S"
  by (metis list.sel(3) upd_hd.elims)

definition upd2put :: "(('d \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c"
  where   "upd2put f = (\<lambda>\<sigma>. \<lambda> b. f (\<lambda>_. b) \<sigma>)"

definition create\<^sub>L
  where "create\<^sub>L getv updv = \<lparr>lens_get = getv,lens_put = upd2put updv\<rparr>"

definition "hd\<^sub>L = create\<^sub>L hd upd_hd"   (* works since no partial lenses needed in Clean*)

definition "map_nth i = (\<lambda>f l. list_update l i (f (l ! i)))"

lemma indep_list_lift :
     "X \<bowtie> create\<^sub>L getv updv
      \<Longrightarrow> (\<lambda>f \<sigma>. updv (\<lambda>_. f (getv \<sigma>)) \<sigma>) = updv
      \<Longrightarrow> X \<bowtie> create\<^sub>L (hd \<circ> getv ) (updv \<circ> upd_hd)"
  unfolding create\<^sub>L_def o_def Lens_Laws.lens_indep_def upd2put_def
  by (auto,metis (no_types)) (metis (no_types))

end


theory ConstructPointsFromIntervals = AllenHayesLadkin:

(*
  author: Stefan Woelfl
  date:   05-11-2004

  Summary:
     This thy file contains the basics of Ladkin's method of how
     to construct instants from intervals.

*)

consts
"Equiv" :: "Interval => Interval => Interval => Interval => bool"   ( "Equiv" )
"PointLess" :: "Interval => Interval => Interval => Interval => bool"   ( "PointLess" )

axioms
Equiv_def: "!! x :: Interval . !! y :: Interval . !! z :: Interval . !! u :: Interval .
  Equiv x y z u = (M x y & M z u & M x u)"
PointLess_def: "!! x :: Interval . !! y :: Interval . !! z :: Interval . !! u :: Interval .
  PointLess x y z u = (? r :: Interval . ? s :: Interval . ? t :: Interval . Equiv x y r s & Equiv z u s t)"

declare Equiv_def[iff]
declare PointLess_def[iff]

theorem Equiv_refl[elim]: "!! x :: Interval . !! y :: Interval . M x y ==> Equiv x y x y"
proof -
  fix x y
  assume "M x y"
  thus "Equiv x y x y" by blast
qed

theorem Equiv_sym[sym]: "!! x :: Interval . !! y :: Interval . !! z :: Interval . !! u :: Interval .
  Equiv x y z u ==> Equiv z u x y"
proof -
  fix x y z u
  assume  "Equiv x y z u"
  with M1 M2a M2b M2c M2d M3 M4
    show "Equiv z u x y"
    by blast
qed

theorem Equiv_trans[trans]: "!! x y z u v w :: Interval .
  (* (M x y & M z u & M v w) --> *)
  Equiv x y z u & Equiv z u v w ==> Equiv x y v w"
proof -
  fix  x y z u v w
  assume "Equiv x y z u & Equiv z u v w"
  with M1 M2a M2b M2c M2d M3 M4
  show "Equiv x y v w"
    by blast
qed

theorem PointLess_irrefl: "!! x :: Interval . !! y :: Interval .
  M x y ==> Not (PointLess x y x y)"
proof -
  fix x y
  assume "M x y"
  with M1 M2a M2b M2c M2d M3 M4
  show "Not (PointLess x y x y)"
    by blast
qed

(* ML "set Blast.trace"; *)

theorem PointLess_trans[trans]: "!! x y z u v w :: Interval .
  PointLess x y z u & PointLess z u v w ==> PointLess x y v w"
proof -
  fix x y z u v w
  assume A: "PointLess x y z u & PointLess z u v w"
  from A obtain r1 s1 t1 where B: "Equiv x y r1 s1 & Equiv z u s1 t1" by blast
  from A obtain r2 s2 t2 where C: "Equiv z u r2 s2 & Equiv v w s2 t2" by blast
  from B C  M1 have "M s1 s2" by blast
  from M5var this obtain s1s2 where "! u . (M u s1 = M u s1s2) & (M s2 u = M s1s2 u)" by blast
  from B C M1 this have "M r1 s1s2 & M s1s2 t2" by blast
  from this B C M1 have "Equiv x y r1 s1s2 & Equiv v w s1s2 t2" by blast
 from this show "PointLess x y v w" by blast
qed

theorem PointLess_linear[intro]: "!! x y z u :: Interval .
  M x y & M z u ==> PointLess x y z u | Equiv x y z u | PointLess z u x y"
proof -
  fix x y z u
  assume A: "M x y & M z u"
  from this M2a have "M x u | (EX v. M x v & M v u) | (EX v. M z v & M v y)" by blast
  moreover
  { assume "M x u"
    from this A M1 M3 M4 have "Equiv x y z u" by blast
  }
  moreover
  { assume "EX v. M x v & M v u"
    from this A M1 M3 M4 have "PointLess x y z u" by blast
  }
  moreover
  { assume "EX v. M z v & M v y"
    from this A M1 M3 M4 have "PointLess z u x y" by blast
  }
    (* by (tactic{*Blast.depth_tac (claset ()) 25 1*}) *)
  ultimately show "PointLess x y z u | Equiv x y z u | PointLess z u x y" by blast
qed

end


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

(* License: BSD, terms see file ./LICENSE *)

theory Separation
imports TypHeap
begin

(* The store is not captured explicitly, variable values may appear in
   predicates and do not require special treatment *)
type_synonym ('a,'b) map_assert = "('a \<rightharpoonup> 'b) \<Rightarrow> bool"
type_synonym heap_assert = "(addr \<times> s_heap_index,s_heap_value) map_assert"

definition sep_emp :: "('a,'b) map_assert" ("\<box>") where
  "sep_emp \<equiv> (=) Map.empty"

definition sep_true :: "('a,'b) map_assert" where
  "sep_true \<equiv> \<lambda>s. True"

definition sep_false :: "('a,'b) map_assert" where
  "sep_false \<equiv> \<lambda>s. False"

definition
  sep_conj :: "('a,'b) map_assert \<Rightarrow> ('a,'b) map_assert \<Rightarrow> ('a,'b) map_assert" (infixr "\<and>\<^sup>*" 35)
where
  "P \<and>\<^sup>* Q \<equiv> \<lambda>s. \<exists>s\<^sub>0 s\<^sub>1. s\<^sub>0 \<bottom> s\<^sub>1 \<and> s = s\<^sub>1 ++ s\<^sub>0 \<and> P s\<^sub>0 \<and> Q s\<^sub>1"

definition
  sep_impl :: "('a,'b) map_assert \<Rightarrow> ('a,'b) map_assert \<Rightarrow> ('a,'b) map_assert" (infixr "\<longrightarrow>\<^sup>*" 25)
where
  "x \<longrightarrow>\<^sup>* y \<equiv> \<lambda>s. \<forall>s'. s \<bottom> s' \<and> x s' \<longrightarrow> y (s ++ s')"

definition
  singleton :: "'a::c_type ptr \<Rightarrow> 'a \<Rightarrow> heap_mem \<Rightarrow> heap_typ_desc \<Rightarrow> heap_state"
where
  "singleton p v h d \<equiv> lift_state (heap_update p v h,d) |` s_footprint p"

text \<open>
  Like in Separation.thy, these arrows are defined using bsub and esub but
  have an \emph{input} syntax abbreviation with just sub.
  Why? Because if sub is the only way, people write things like
  @{text "p \<mapsto>\<^sup>i\<^sub>(f x y) v"} instead of @{text "p \<mapsto>\<^sup>i\<^bsub>(f x y)\<^esub> v"}. We preserve
  the sub syntax though, because esub and bsub are a pain to type.
\<close>

definition
  sep_map :: "'a::c_type ptr \<Rightarrow> 'a ptr_guard \<Rightarrow> 'a \<Rightarrow> heap_assert" ("_ \<mapsto>\<^bsub>_\<^esub> _" [56,0,51] 56)
where
  "p \<mapsto>\<^bsub>g\<^esub> v \<equiv> \<lambda>s. lift_typ_heap g s p = Some v \<and> dom s = s_footprint p \<and> wf_heap_val s"

notation (input)
  sep_map ("_ \<mapsto>\<^sub>_ _" [56,1000,51] 56)

definition
  sep_map_any :: "'a ::c_type ptr \<Rightarrow> 'a ptr_guard \<Rightarrow> heap_assert" ("_ \<mapsto>\<^bsub>_\<^esub> -" [56,0] 56)
where
  "p \<mapsto>\<^bsub>g\<^esub> - \<equiv> \<lambda>s. \<exists>v. (p \<mapsto>\<^sub>g v) s"

notation (input)
  sep_map_any ("_ \<mapsto>\<^sub>_ -" [56,0] 56)

definition
  sep_map' :: "'a::c_type ptr \<Rightarrow> 'a ptr_guard \<Rightarrow> 'a \<Rightarrow> heap_assert" ("_ \<hookrightarrow>\<^bsub>_\<^esub> _" [56,0,51] 56)
where
  "p \<hookrightarrow>\<^bsub>g\<^esub> v \<equiv> (p \<mapsto>\<^bsub>g\<^esub> v) \<and>\<^sup>* sep_true"

notation (input)
  sep_map' ("_ \<hookrightarrow>\<^sub>_ _" [56,1000,51] 56)

definition
  sep_map'_any :: "'a ::c_type ptr \<Rightarrow> 'a ptr_guard  \<Rightarrow> heap_assert" ("_ \<hookrightarrow>\<^bsub>_\<^esub> -" [56,0] 56)
where
  "p \<hookrightarrow>\<^bsub>g\<^esub> - \<equiv> \<lambda>s. \<exists>x. (p \<hookrightarrow>\<^sub>g x) s"

notation (input)
  sep_map'_any ("_ \<hookrightarrow>\<^sub>_ -" [56,0] 56)

syntax
  "_sep_assert" :: "bool \<Rightarrow> heap_state \<Rightarrow> bool" ("'(_')\<^bsup>sep\<^esup>" [0] 100)

text \<open>----\<close>

lemma sep_empD:
  "\<box> s \<Longrightarrow> s = Map.empty"
  by (simp add: sep_emp_def)

lemma sep_emp_empty [simp]:
  "\<box> Map.empty"
  by (simp add: sep_emp_def)

lemma sep_true [simp]:
  "sep_true s"
  by (simp add: sep_true_def)

lemma sep_false [simp]:
  "\<not> sep_false s"
  by (simp add: sep_false_def)

declare sep_false_def [symmetric, simp add]

lemma singleton_dom':
  "dom (singleton p (v::'a::mem_type) h d) = dom (lift_state (h,d)) \<inter> s_footprint p"
  by (auto simp: singleton_def lift_state_def
           split: if_split_asm s_heap_index.splits)

lemma lift_state_dom:
  "d,g \<Turnstile>\<^sub>t p \<Longrightarrow> s_footprint (p::'a::mem_type ptr) \<subseteq> dom (lift_state (h,d))"
  apply(clarsimp simp: h_t_valid_def valid_footprint_def Let_def)
  apply(clarsimp simp: lift_state_def split: s_heap_index.splits option.splits)
  apply(rule conjI; clarsimp)
   apply(fastforce dest: s_footprintD intvlD simp: size_of_def)
  apply(frule s_footprintD2)
  apply(drule s_footprintD)
  apply(drule intvlD, clarsimp)
  apply(rename_tac k)
  apply(drule_tac x=k in spec)
  apply(erule impE)
   apply(simp add: size_of_def)
  apply(subst (asm) word_unat.eq_norm)
  apply(subst (asm) mod_less)
   apply(subst len_of_addr_card)
   apply(erule less_trans)
   apply(rule max_size)
  apply(force simp: map_le_def)
  done

lemma singleton_dom:
  "d,g \<Turnstile>\<^sub>t p \<Longrightarrow> dom (singleton p (v::'a::mem_type) h d) = s_footprint p"
  apply(subst singleton_dom')
  apply(fastforce dest: lift_state_dom)
  done

lemma wf_heap_val_restrict [simp]:
  "wf_heap_val s \<Longrightarrow> wf_heap_val (s |` X)"
  unfolding wf_heap_val_def by (auto simp: restrict_map_def)

lemma singleton_wf_heap_val [simp]:
  "wf_heap_val (singleton p v h d)"
  unfolding singleton_def by simp

lemma h_t_valid_restrict_proj_d:
  "\<lbrakk> proj_d s,g \<Turnstile>\<^sub>t p; \<forall>x. x \<in> s_footprint p \<longrightarrow> s x = s' x \<rbrakk> \<Longrightarrow>
      proj_d s',g \<Turnstile>\<^sub>t p"
  apply(clarsimp simp: h_t_valid_def valid_footprint_def Let_def)
  apply(rule conjI)
   apply(drule_tac x=y in spec)
   apply simp
   apply(clarsimp simp: proj_d_def map_le_def)
   apply(drule_tac x="ptr_val p + of_nat y" in spec)
   apply(drule_tac x="SIndexTyp a" in spec)
   apply(erule impE)
    apply(erule s_footprintI)
    apply(simp add: size_of_def)
   apply simp
  apply(clarsimp simp: proj_d_def)
  apply(drule_tac x=y in spec)
  apply clarsimp
  apply(drule_tac x="ptr_val p + of_nat y" in spec)
  apply(drule_tac x="SIndexVal" in spec)
  apply(erule impE)
   apply(rule s_footprintI2)
   apply(simp add: size_of_def)
  apply force
  done

lemma s_valid_restrict [simp]:
  "s |` s_footprint p,g \<Turnstile>\<^sub>s p = s,g \<Turnstile>\<^sub>s p"
  by (fastforce simp: s_valid_def elim: h_t_valid_restrict_proj_d)

lemma proj_h_restrict:
  "(x,SIndexVal) \<in> X \<Longrightarrow> proj_h (s |` X) x = proj_h s x"
  by (auto simp: proj_h_def)

lemma heap_list_s_restrict [rule_format]:
  "(\<lambda>x. (x,SIndexVal)) ` {p..+n} \<subseteq> X \<Longrightarrow> heap_list_s (s |` X) n p = heap_list_s s n p"
  apply(induct n arbitrary: p)
   apply(simp add: heap_list_s_def)
  apply(clarsimp simp: heap_list_s_def)
  apply(rule conjI)
   apply(fastforce intro: proj_h_restrict intvl_self)
  apply(fastforce intro: intvl_plus_sub_Suc)
  done

lemma lift_typ_heap_restrict [simp]:
  "lift_typ_heap g (s |` s_footprint p) p = lift_typ_heap g s p"
  apply(clarsimp simp: lift_typ_heap_if)
  apply(subst heap_list_s_restrict)
   apply clarsimp
   apply(drule intvlD, clarsimp)
   apply(erule s_footprintI2)
  apply simp
  done

lemma singleton_s_valid:
  "d,g \<Turnstile>\<^sub>t p \<Longrightarrow> singleton p (v::'a::mem_type) h d,g \<Turnstile>\<^sub>s p"
  by (simp add: singleton_def h_t_s_valid)

lemma singleton_lift_typ_heap_Some:
  "d,g \<Turnstile>\<^sub>t p \<Longrightarrow> lift_typ_heap g (singleton p v h d) p = Some (v::'a::mem_type)"
  by (simp add: singleton_def lift_t lift_t_heap_update h_t_valid_restrict)

lemma sep_map_g:
  "(p \<mapsto>\<^sub>g v) s \<Longrightarrow> g p"
  by (force simp: sep_map_def dest: lift_typ_heap_g)

lemma sep_map_g_sep_false:
  "\<not> g p \<Longrightarrow> (p \<mapsto>\<^sub>g v) = sep_false"
  by (simp add: sep_map_def lift_typ_heap_if s_valid_def h_t_valid_def)

lemma sep_map_singleton:
  "d,g \<Turnstile>\<^sub>t p \<Longrightarrow> ((p::'a::mem_type ptr) \<mapsto>\<^sub>g v) (singleton p v h d)"
  by (simp add: sep_map_def singleton_lift_typ_heap_Some singleton_dom)

lemma sep_mapD:
  "(p \<mapsto>\<^sub>g v) s \<Longrightarrow> lift_typ_heap g s p = Some v \<and>
      dom s = s_footprint p \<and> wf_heap_val s"
  by (simp add: sep_map_def)

lemma sep_map_lift_typ_heapD:
  "(p \<mapsto>\<^sub>g v) s \<Longrightarrow> lift_typ_heap g s p = Some (v::'a::c_type)"
  by (simp add: sep_map_def)

lemma sep_map_dom_exc:
  "(p \<mapsto>\<^sub>g (v::'a::c_type)) s \<Longrightarrow> dom s = s_footprint p"
  by (simp add: sep_map_def)

lemma sep_map_inj:
  "\<lbrakk> (p \<mapsto>\<^sub>g (v::'a::c_type)) s; (p \<mapsto>\<^sub>h v') s \<rbrakk> \<Longrightarrow> v = v'"
  by (clarsimp simp: sep_map_def lift_typ_heap_if split: if_split_asm)

lemma sep_map_anyI_exc [simp]:
  "(p \<mapsto>\<^sub>g v) s \<Longrightarrow> (p \<mapsto>\<^sub>g -) s"
  by (force simp: sep_map_any_def)

lemma sep_map_anyD_exc:
  "(p \<mapsto>\<^sub>g -) s \<Longrightarrow> \<exists>v. (p \<mapsto>\<^sub>g v) s"
  by (force simp: sep_map_any_def)

lemma sep_map_any_singleton:
  "d,g \<Turnstile>\<^sub>t i \<Longrightarrow> (i \<mapsto>\<^sub>g -) (singleton i (v::'a::mem_type) h d)"
  by (unfold sep_map_any_def, rule_tac x=v in exI, erule sep_map_singleton)

lemma proj_h_heap_merge:
  "proj_h (s ++ t) = (\<lambda>x. if (x,SIndexVal) \<in>  dom t then proj_h t x else proj_h s x)"
  by (force simp: proj_h_def split: option.splits)

lemma s_valid_heap_merge_right:
  "s\<^sub>1,g \<Turnstile>\<^sub>s p \<Longrightarrow> s\<^sub>0 ++ s\<^sub>1,g \<Turnstile>\<^sub>s p"
  apply (clarsimp simp: s_valid_def h_t_valid_def valid_footprint_def Let_def)
  apply (rule conjI)
   apply(drule_tac x=y in spec, simp)
   apply clarsimp
   apply(erule map_le_trans)
   apply(clarsimp simp: proj_d_def map_le_def split: option.splits)
  apply(drule_tac x=y in spec, simp)
  apply(clarsimp simp: proj_d_def map_le_def split: option.splits)
  done

lemma proj_d_map_add_fst:
  "fst (proj_d (s ++ t) x) = (if (x,SIndexVal) \<in> dom t then fst (proj_d t x) else
      fst (proj_d s x))"
  by (auto simp: proj_d_def split: option.splits)

lemma proj_d_map_add_snd:
  "snd (proj_d (s ++ t) x) n = (if (x,SIndexTyp n) \<in> dom t then snd (proj_d t x) n else
      snd (proj_d s x) n)"
  by (auto simp: proj_d_def split: option.splits)

lemma proj_d_restrict_map_fst:
  "(x,SIndexVal) \<in> X \<Longrightarrow> fst (proj_d (s |` X) x) = fst (proj_d s x)"
  by (auto simp: proj_d_def)

lemma proj_d_restrict_map_snd:
  "(x,SIndexTyp n) \<in> X \<Longrightarrow> snd (proj_d (s |` X) x) n = snd (proj_d s x) n"
  by (auto simp: proj_d_def)

lemma s_valid_heap_merge_right2:
  "\<lbrakk> s\<^sub>0 ++ s\<^sub>1,g \<Turnstile>\<^sub>s p; s_footprint p \<subseteq> dom s\<^sub>1 \<rbrakk> \<Longrightarrow> s\<^sub>1,g \<Turnstile>\<^sub>s p"
  apply(clarsimp simp: s_valid_def h_t_valid_def valid_footprint_def Let_def)
  apply(rule conjI)
   apply(clarsimp simp: map_le_def)
   apply(subst proj_d_map_add_snd)
   apply(clarsimp split: if_split_asm)
   apply(subgoal_tac "(ptr_val p + of_nat y,SIndexTyp a) \<in> s_footprint p")
    apply fast
   apply(erule s_footprintI)
   apply(simp add: size_of_def)
  apply(subgoal_tac "(ptr_val p + of_nat y,SIndexVal) \<in> s_footprint p")
   apply(drule (1) subsetD)
   apply clarsimp
   apply(subst (asm) proj_d_map_add_fst)
   apply(drule_tac x=y in spec)
   apply(clarsimp split: if_split_asm)
  apply(rule s_footprintI2)
  apply(simp add: size_of_def)
  done

lemma heap_list_s_heap_merge_right':
  "\<lbrakk> s\<^sub>1,g \<Turnstile>\<^sub>s (p::'a::c_type ptr); n \<le> size_of TYPE('a) \<rbrakk> \<Longrightarrow>
      heap_list_s (s\<^sub>0 ++ s\<^sub>1) n (ptr_val p + of_nat (size_of TYPE('a) - n))
          = heap_list_s s\<^sub>1 n (ptr_val p + of_nat (size_of TYPE('a) - n))"
proof (induct n)
  case 0 thus ?case by (simp add: heap_list_s_def)
next
  case (Suc n)
  hence "(ptr_val p + (of_nat (size_of TYPE('a) - Suc n)),SIndexVal) \<in> dom s\<^sub>1"
    by - (drule_tac x="size_of TYPE('a) - Suc n" in s_valid_Some, auto)
  with Suc show ?case
    by (simp add: heap_list_s_def proj_h_heap_merge algebra_simps)
qed

lemma heap_list_s_heap_merge_right:
  "s\<^sub>1,g \<Turnstile>\<^sub>s ((Ptr p)::'a::c_type ptr) \<Longrightarrow>
   heap_list_s (s\<^sub>0 ++ s\<^sub>1) (size_of TYPE('a)) p = heap_list_s s\<^sub>1 (size_of TYPE('a)) p"
  by (force dest: heap_list_s_heap_merge_right')

lemma lift_typ_heap_heap_merge_right:
  "lift_typ_heap g s\<^sub>1 p = Some v \<Longrightarrow> lift_typ_heap g (s\<^sub>0 ++ s\<^sub>1) (p::'a::c_type ptr) = Some v"
  by (force simp: lift_typ_heap_if s_valid_heap_merge_right heap_list_s_heap_merge_right
            split: if_split_asm)

lemma lift_typ_heap_heap_merge_sep_map:
  "(p \<mapsto>\<^sub>g v) s\<^sub>1 \<Longrightarrow> lift_typ_heap g (s\<^sub>0 ++ s\<^sub>1) p = Some (v::'a::c_type)"
  by (drule sep_map_lift_typ_heapD, erule lift_typ_heap_heap_merge_right)

lemma sep_conjI:
  "\<lbrakk> P s\<^sub>0; Q s\<^sub>1; s\<^sub>0 \<bottom> s\<^sub>1; s = s\<^sub>1 ++ s\<^sub>0 \<rbrakk> \<Longrightarrow> (P \<and>\<^sup>* Q) s"
  by (force simp: sep_conj_def)

lemma sep_conjD:
  "(P \<and>\<^sup>* Q) s \<Longrightarrow> \<exists>s\<^sub>0 s\<^sub>1. s\<^sub>0 \<bottom> s\<^sub>1 \<and> s = s\<^sub>1 ++ s\<^sub>0 \<and> P s\<^sub>0 \<and> Q s\<^sub>1"
  by (force simp: sep_conj_def)

lemma sep_map'I:
  "((p \<mapsto>\<^sub>g v) \<and>\<^sup>* sep_true) s \<Longrightarrow> (p \<hookrightarrow>\<^sub>g v) s"
  by (simp add: sep_map'_def)

lemma sep_map'D:
  "(p \<hookrightarrow>\<^sub>g v) s \<Longrightarrow> ((p \<mapsto>\<^sub>g v) \<and>\<^sup>* sep_true) s"
  by (simp add: sep_map'_def)

lemma sep_map'_g_exc:
  "(p \<hookrightarrow>\<^sub>g v) s \<Longrightarrow> g p"
  by (force simp add: sep_map'_def dest: sep_conjD sep_map_g)

lemma sep_conj_sep_true:
  "P s \<Longrightarrow> (P \<and>\<^sup>* sep_true) s"
  by (erule_tac s\<^sub>1=Map.empty in sep_conjI, simp+)

lemma sep_map_sep_map'_exc [simp]:
  "(p \<mapsto>\<^sub>g v) s \<Longrightarrow> (p \<hookrightarrow>\<^sub>g v) s"
  by (unfold sep_map'_def, erule sep_conj_sep_true)

lemma sep_conj_true [simp]:
  "(sep_true \<and>\<^sup>* sep_true) = sep_true"
  by (rule ext, simp, rule_tac s\<^sub>0=x and s\<^sub>1=Map.empty in sep_conjI, auto)

lemma sep_conj_assocD:
  assumes l: "((P \<and>\<^sup>* Q) \<and>\<^sup>* R) s"
  shows "(P \<and>\<^sup>* (Q \<and>\<^sup>* R)) s"
proof -
  from l obtain s' s\<^sub>2 where disj_o: "s' \<bottom> s\<^sub>2" and merge_o: "s = s\<^sub>2 ++ s'" and
    l_o: "(P \<and>\<^sup>* Q) s'" and r_o: "R s\<^sub>2" by (force dest: sep_conjD)
  then obtain s\<^sub>0 s\<^sub>1 where disj_i: "s\<^sub>0 \<bottom> s\<^sub>1" and merge_i: "s' = s\<^sub>1 ++ s\<^sub>0" and
    l_i: "P s\<^sub>0" and r_i: "Q s\<^sub>1" by (force dest: sep_conjD)
  from disj_o disj_i merge_i have disj_i': "s\<^sub>1 \<bottom> s\<^sub>2"
    by (force simp: map_ac_simps)
  with r_i and r_o have r_o': "(Q \<and>\<^sup>* R) (s\<^sub>2 ++ s\<^sub>1)" by (fast intro: sep_conjI)
  from disj_o merge_i disj_i disj_i' have "s\<^sub>0 \<bottom> s\<^sub>2 ++ s\<^sub>1"
    by (force simp: map_ac_simps)
  with r_o' l_i have "(P \<and>\<^sup>* (Q \<and>\<^sup>* R)) ((s\<^sub>2 ++ s\<^sub>1) ++ s\<^sub>0)"
    by (force intro: sep_conjI)
  moreover from merge_o merge_i disj_i disj_i' have "s = ((s\<^sub>2 ++ s\<^sub>1) ++ s\<^sub>0)"
    by (simp add: map_add_assoc [symmetric])
  ultimately show ?thesis by simp
qed

(* Reynolds' properties from "Separation Logic: A Logic for Shared
   Mutable Data Structures", page 5-6.  *)

lemma sep_conj_com:
  "(P \<and>\<^sup>* Q) = (Q \<and>\<^sup>* P)"
  by (rule ext) (auto simp: map_ac_simps sep_conjI dest!: sep_conjD)

lemma sep_conj_false_right [simp]:
  "(P \<and>\<^sup>* sep_false) = sep_false"
  by (force dest: sep_conjD)

lemma sep_conj_false_left [simp]:
  "(sep_false \<and>\<^sup>* P) = sep_false"
  by (simp add: sep_conj_com)

lemma sep_conj_comD:
  "(P \<and>\<^sup>* Q) s \<Longrightarrow> (Q \<and>\<^sup>* P) s"
  by (simp add: sep_conj_com)

(* FIXME: the need for this kind of special case should disappear with
   generalised separation conjunction *)
lemma exists_left:
  "(Q \<and>\<^sup>* (\<lambda>s. \<exists>x. P x s)) = ((\<lambda>s. \<exists>x. P x s) \<and>\<^sup>* Q)" by (simp add: sep_conj_com)

lemma sep_conj_assoc:
  "((P \<and>\<^sup>* Q) \<and>\<^sup>* R) = (P \<and>\<^sup>* (Q \<and>\<^sup>* R))" (is "?x = ?y")
proof (rule ext, rule)
  fix s
  assume "?x s"
  thus "?y s" by - (erule sep_conj_assocD)
next
  fix s
  assume "?y s"
  hence "((R \<and>\<^sup>* Q) \<and>\<^sup>* P) s" by (simp add: sep_conj_com)
  hence "(R \<and>\<^sup>* (Q \<and>\<^sup>* P)) s" by - (erule sep_conj_assocD)
  thus "?x s" by (simp add: sep_conj_com)
qed

(* For permutative rewriting *)
lemma sep_conj_left_com:
  "(P \<and>\<^sup>* (Q \<and>\<^sup>* R)) = (Q \<and>\<^sup>* (P \<and>\<^sup>* R))" (is "?x = ?y")
proof -
  have "?x = ((Q \<and>\<^sup>* R) \<and>\<^sup>* P)" by (simp add: sep_conj_com)
  also have "\<dots> = (Q \<and>\<^sup>* (R \<and>\<^sup>* P))" by (subst sep_conj_assoc, simp)
  finally show ?thesis by (simp add: sep_conj_com)
qed

lemmas sep_conj_ac = sep_conj_com sep_conj_assoc sep_conj_left_com

lemma sep_conj_empty:
  "(P \<and>\<^sup>* \<box>) = P"
proof (rule ext, rule)
  fix x
  assume "(P \<and>\<^sup>* \<box>) x"
  thus "P x" by (force simp: sep_emp_def dest: sep_conjD)
next
  fix x
  assume "P x"
  moreover have "\<box> Map.empty" by simp
  ultimately show "(P \<and>\<^sup>* \<box>) x" by - (erule (1) sep_conjI, auto)
qed

lemma sep_conj_empty' [simp]:
  "(\<box> \<and>\<^sup>* P) = P"
 by (simp add: sep_conj_empty sep_conj_ac)

lemma sep_conj_true_P [simp]:
  "(sep_true \<and>\<^sup>* (sep_true \<and>\<^sup>* P)) = (sep_true \<and>\<^sup>* P)"
  by (simp add: sep_conj_ac)

lemma sep_map'_unfold_exc:
  "(p \<hookrightarrow>\<^sub>g v) = ((p \<hookrightarrow>\<^sub>g v) \<and>\<^sup>* sep_true)"
  by (simp add: sep_map'_def sep_conj_ac)

lemma sep_conj_disj:
  "((\<lambda>s. P s \<or> Q s) \<and>\<^sup>* R) s = ((P \<and>\<^sup>* R) s \<or> (Q \<and>\<^sup>* R) s)" (is "?x = (?y \<or> ?z)")
proof rule
  assume ?x
  then obtain s\<^sub>0 s\<^sub>1 where "s\<^sub>0 \<bottom> s\<^sub>1" and "s = s\<^sub>1 ++ s\<^sub>0" and "P s\<^sub>0 \<or> Q s\<^sub>0" and
      "R s\<^sub>1"
    by - (drule sep_conjD, auto)
  moreover from this have "\<not> ?z \<Longrightarrow> \<not> Q s\<^sub>0"
    by - (clarsimp, erule notE, erule (2) sep_conjI, simp)
  ultimately show "?y \<or> ?z" by (force intro: sep_conjI)
next
  have "?y \<Longrightarrow> ?x"
    by (force simp: map_ac_simps intro: sep_conjI dest: sep_conjD)
  moreover have "?z \<Longrightarrow> ?x"
    by (force simp: map_ac_simps intro: sep_conjI dest: sep_conjD)
  moreover assume "?y \<or> ?z"
  ultimately show ?x by fast
qed

lemma sep_conj_conj:
  "((\<lambda>s. P s \<and> Q s) \<and>\<^sup>* R) s \<Longrightarrow> (P \<and>\<^sup>* R) s \<and> (Q \<and>\<^sup>* R) s"
  by (force intro: sep_conjI dest!: sep_conjD)

lemma sep_conj_exists1:
  "((\<lambda>s. \<exists>x. P x s) \<and>\<^sup>* Q) = (\<lambda>s. (\<exists>x. (P x \<and>\<^sup>* Q) s))"
  by (force intro: sep_conjI dest: sep_conjD)

lemma sep_conj_exists2:
  "(P \<and>\<^sup>* (\<lambda>s. \<exists>x. Q x s)) = (\<lambda>s. (\<exists>x. (P \<and>\<^sup>* Q x) s))"
  by (force intro: sep_conjI dest: sep_conjD)

lemmas sep_conj_exists = sep_conj_exists1 sep_conj_exists2

lemma sep_conj_forall:
  "((\<lambda>s. \<forall>x. P x s) \<and>\<^sup>* Q) s \<Longrightarrow> (P x \<and>\<^sup>* Q) s"
  by (force intro: sep_conjI dest: sep_conjD)

lemma sep_conj_impl:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; \<And>s. P s \<Longrightarrow> P' s; \<And>s. Q s \<Longrightarrow> Q' s \<rbrakk> \<Longrightarrow> (P' \<and>\<^sup>* Q') s"
  by (force intro: sep_conjI dest: sep_conjD)

lemma sep_conj_sep_true_left:
  "(P \<and>\<^sup>* Q) s \<Longrightarrow> (sep_true \<and>\<^sup>* Q) s"
  by (erule sep_conj_impl, simp+)

lemma sep_conj_sep_true_right:
  "(P \<and>\<^sup>* Q) s \<Longrightarrow> (P \<and>\<^sup>* sep_true) s"
  by (subst (asm) sep_conj_com, drule sep_conj_sep_true_left,
      simp add: sep_conj_ac)

lemma sep_globalise:
  "\<lbrakk> (P \<and>\<^sup>* R) s; (\<And>s. P s \<Longrightarrow> Q s) \<rbrakk> \<Longrightarrow> (Q \<and>\<^sup>* R) s"
  by (fast elim: sep_conj_impl)

lemma sep_implI:
  "\<forall>s'. s \<bottom> s' \<and> x s' \<longrightarrow> y (s ++ s') \<Longrightarrow> (x \<longrightarrow>\<^sup>* y) s"
  by (force simp: sep_impl_def)

lemma sep_implI':
  assumes x: "\<And>h'. \<lbrakk> h \<bottom> h'; x h' \<rbrakk> \<Longrightarrow> y (h ++ h')"
  shows "(x \<longrightarrow>\<^sup>* y) h"
  apply (simp add: sep_impl_def)
  apply (intro allI impI)
  apply (erule conjE)
  apply (erule (1) x)
  done

lemma sep_implD:
  "(x \<longrightarrow>\<^sup>* y) s \<Longrightarrow> \<forall>s'. s \<bottom> s' \<and> x s' \<longrightarrow> y (s ++ s')"
  by (force simp: sep_impl_def)

lemma sep_emp_sep_impl [simp]:
  "(\<box> \<longrightarrow>\<^sup>* P) = P"
  apply(rule ext)
  apply(clarsimp simp: sep_impl_def)
  apply(rule iffI; clarsimp?)
   apply(drule_tac x=Map.empty in spec)
   apply fastforce
  apply(fastforce dest: sep_empD)
  done

lemma sep_impl_sep_true [simp]:
  "(P \<longrightarrow>\<^sup>* sep_true) = sep_true"
  by (force intro: sep_implI)

lemma sep_impl_sep_false [simp]:
  "(sep_false \<longrightarrow>\<^sup>* P) = sep_true"
  by (force intro: sep_implI)

lemma sep_impl_sep_true_P:
  "(sep_true \<longrightarrow>\<^sup>* P) s \<Longrightarrow> P s"
  by (auto dest!: sep_implD, drule_tac x=Map.empty in spec, simp)

lemma sep_impl_sep_true_false [simp]:
  "(sep_true \<longrightarrow>\<^sup>* sep_false) = sep_false"
  by (force dest: sep_impl_sep_true_P)

lemma sep_impl_impl:
  "(P \<longrightarrow>\<^sup>* Q \<longrightarrow>\<^sup>* R) = (P \<and>\<^sup>* Q \<longrightarrow>\<^sup>* R)"
  apply(rule ext)
  apply(rule iffI)
   apply(rule sep_implI)
   apply clarsimp
   apply(drule sep_conjD, clarsimp)
   apply(drule sep_implD)
   apply(drule_tac x=s\<^sub>0 in spec)
   apply(erule impE)
    apply(clarsimp simp: map_disj_def, fast)
   apply(drule sep_implD)
   apply(drule_tac x=s\<^sub>1 in spec)
   apply(erule impE)
    apply(clarsimp simp: map_disj_def, fast)
   apply(subst map_add_com [where h\<^sub>0=s\<^sub>1])
    apply(clarsimp simp: map_disj_def, fast)
   apply(subst map_add_assoc)
   apply simp
  apply(rule sep_implI, clarsimp)
  apply(rule sep_implI, clarsimp)
  apply(drule sep_implD)
  apply(drule_tac x="s' ++ s'a" in spec)
  apply(erule impE)
   apply(rule conjI)
    apply(clarsimp simp: map_disj_def, fast)
   apply(erule (1) sep_conjI)
    apply(clarsimp simp: map_disj_def, fast)
   apply(subst map_add_com)
    apply(clarsimp simp: map_disj_def, fast)
   apply simp
  apply(simp add: map_add_assoc)
  done

lemma sep_conj_sep_impl:
  "\<lbrakk> P s; \<And>s. (P \<and>\<^sup>* Q) s \<Longrightarrow> R s \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s"
proof (rule sep_implI, clarsimp)
  fix s'
  assume "P s" and "s \<bottom> s'" and "Q s'"
  hence "(P \<and>\<^sup>* Q) (s ++ s')" by (force simp: map_ac_simps intro: sep_conjI)
  moreover assume "\<And>s. (P \<and>\<^sup>* Q) s \<Longrightarrow> R s"
  ultimately show "R (s ++ s')" by simp
qed

lemma sep_conj_sep_impl2:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; \<And>s. P s \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s \<rbrakk> \<Longrightarrow> R s"
  by (force simp: map_ac_simps dest: sep_implD sep_conjD)

lemma sep_map'_anyI_exc [simp]:
  "(p \<hookrightarrow>\<^sub>g v) s \<Longrightarrow> (p \<hookrightarrow>\<^sub>g -) s"
  by (force simp: sep_map'_any_def)

lemma sep_map'_anyD_exc:
  "(p \<hookrightarrow>\<^sub>g -) s \<Longrightarrow> \<exists>v. (p \<hookrightarrow>\<^sub>g v) s"
  by (force simp: sep_map'_any_def)

lemma sep_map'_any_unfold_exc:
  "(i \<hookrightarrow>\<^sub>g -) = ((i \<hookrightarrow>\<^sub>g -) \<and>\<^sup>* sep_true)"
  by (rule ext, simp add: sep_map'_any_def)
     (subst sep_map'_unfold_exc, subst sep_conj_com, subst sep_conj_exists,
      simp add: sep_conj_ac)

lemma sep_map'_inj_exc:
  assumes pv: "(p \<hookrightarrow>\<^sub>g (v::'a::c_type)) s" and pv': "(p \<hookrightarrow>\<^sub>h v') s"
  shows "v = v'"
proof -
  from pv pv' obtain s\<^sub>0 s\<^sub>1 s\<^sub>0' s\<^sub>1' where pv_m: "(p \<mapsto>\<^sub>g v) s\<^sub>1" and
      pv'_m: "(p \<mapsto>\<^sub>h v') s\<^sub>1'" and "s\<^sub>0 ++ s\<^sub>1 = s\<^sub>0' ++ s\<^sub>1'"
    by (force simp: sep_map'_def map_ac_simps dest!: sep_conjD)
  hence "s\<^sub>1 = s\<^sub>1'" by (force dest!: map_add_right_dom_eq sep_map_dom_exc)
  with pv_m pv'_m show ?thesis by (force dest: sep_map_inj)
qed

lemma sep_map'_any_dom_exc:
  "((p::'a::mem_type ptr) \<hookrightarrow>\<^sub>g -) s \<Longrightarrow> (ptr_val p,SIndexVal) \<in> dom s"
  by (clarsimp simp: sep_map'_def sep_map'_any_def sep_conj_ac
               dest!: sep_conjD)
     (subgoal_tac "s\<^sub>1 (ptr_val p,SIndexVal) \<noteq> None", force simp: map_ac_simps,
      force dest: sep_map_dom_exc)

lemma sep_map'_dom_exc:
  "(p \<hookrightarrow>\<^sub>g (v::'a::mem_type)) s \<Longrightarrow> (ptr_val p,SIndexVal) \<in> dom s"
  apply(clarsimp simp: sep_map'_def sep_conj_ac dest!: sep_conjD)
  apply(subgoal_tac "s\<^sub>1 (ptr_val p, SIndexVal) \<noteq> None")
   apply(force simp: map_ac_simps)
  apply(drule sep_map_dom_exc)
  apply(subgoal_tac "(ptr_val p, SIndexVal) \<in> s_footprint p")
   apply fast
  apply(rule s_footprintI2 [where x=0, simplified])
  apply simp
  done

lemma sep_map'_lift_typ_heapD:
  "(p \<hookrightarrow>\<^sub>g v) s \<Longrightarrow>
      lift_typ_heap g s p = Some (v::'a::c_type)"
  by (force simp: sep_map'_def map_ac_simps dest: sep_conjD
                  lift_typ_heap_heap_merge_sep_map)

lemma sep_map'_merge:
  assumes map'_v: "(p \<hookrightarrow>\<^sub>g v) s\<^sub>0 \<or> (p \<hookrightarrow>\<^sub>g v) s\<^sub>1" and disj: "s\<^sub>0 \<bottom> s\<^sub>1"
  shows "(p \<hookrightarrow>\<^sub>g v) (s\<^sub>0 ++ s\<^sub>1)" (is "?x")
proof cases
  assume "(p \<hookrightarrow>\<^sub>g v) s\<^sub>0"
  with disj show ?x
    by (clarsimp simp: sep_map'_def sep_conj_ac dest!: sep_conjD)
       (rename_tac s\<^sub>0' s\<^sub>1', rule_tac s\<^sub>1="s\<^sub>1'" and s\<^sub>0="s\<^sub>0' ++ s\<^sub>1" in sep_conjI,
         auto simp: map_ac_simps)
next
  assume "\<not> (p \<hookrightarrow>\<^sub>g v) s\<^sub>0"
  with map'_v have "(p \<hookrightarrow>\<^sub>g v) s\<^sub>1" by simp
  with disj show ?x
    by (clarsimp simp: sep_map'_def sep_conj_ac dest!: sep_conjD)
       (rename_tac s\<^sub>0' s\<^sub>1', rule_tac s\<^sub>1="s\<^sub>1'" and s\<^sub>0="s\<^sub>0 ++ s\<^sub>0'" in sep_conjI,
        auto simp: map_ac_simps)
qed

lemma sep_conj_overlapD:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; \<And>s. P s \<Longrightarrow> ((p::'a::mem_type ptr) \<hookrightarrow>\<^sub>g -) s;
      \<And>s. Q s \<Longrightarrow> (p \<hookrightarrow>\<^sub>h -) s \<rbrakk> \<Longrightarrow> False"
  apply(drule sep_conjD, clarsimp simp: map_disj_def)
  apply(subgoal_tac "(ptr_val p,SIndexVal) \<in> dom s\<^sub>0 \<and> (ptr_val p,SIndexVal) \<in> dom s\<^sub>1")
   apply fast
  apply(fast intro!: sep_map'_any_dom_exc)
  done

lemma sep_no_skew:
  "(\<lambda>s. (p \<hookrightarrow>\<^sub>g v) s \<and> (q \<hookrightarrow>\<^sub>h w) s) s \<Longrightarrow>
      p=q \<or> {ptr_val (p::'a::c_type ptr)..+size_of TYPE('a)} \<inter>
          {ptr_val q..+size_of TYPE('a)} = {}"
  apply clarsimp
  apply(drule sep_map'_lift_typ_heapD)+
  apply(clarsimp simp: lift_typ_heap_if s_valid_def split: if_split_asm)
  apply(rule ccontr)
  apply(drule (1) h_t_valid_neq_disjoint; simp?)
  apply(rule peer_typ_not_field_of; simp)
  done

lemma sep_no_skew2:
  "\<lbrakk> (\<lambda>s. (p \<hookrightarrow>\<^sub>g v) s \<and> (q \<hookrightarrow>\<^sub>h w) s) s; typ_uinfo_t TYPE('a) \<bottom>\<^sub>t typ_uinfo_t TYPE('b) \<rbrakk>
      \<Longrightarrow> {ptr_val (p::'a::c_type ptr)..+size_of TYPE('a)} \<inter>
          {ptr_val (q::'b::c_type ptr)..+size_of TYPE('b)} = {}"
  apply clarsimp
  apply(drule sep_map'_lift_typ_heapD)+
  apply(clarsimp simp: lift_typ_heap_if s_valid_def split: if_split_asm)
  apply(frule (1) h_t_valid_neq_disjoint[where q=q])
    apply(clarsimp simp: tag_disj_def sub_typ_proper_def)
    apply(simp add: typ_tag_lt_def)
   apply(clarsimp simp: tag_disj_def typ_tag_le_def field_of_t_def field_of_def)
  apply assumption
  done

lemma sep_conj_impl_same:
  "(P \<and>\<^sup>* (P \<longrightarrow>\<^sup>* Q)) s \<Longrightarrow> Q s"
  apply(drule sep_conjD, clarsimp)
  apply(drule sep_implD)
  apply(drule_tac x="s\<^sub>0" in spec)
  apply(clarsimp simp: map_disj_com)
  done

(* Pure *)

definition pure :: "('a,'b) map_assert \<Rightarrow> bool" where
  "pure P \<equiv> \<forall>s s'. P s = P s'"

lemma pure_sep_true:
  "pure sep_true"
  by (simp add: pure_def)

lemma pure_sep_fasle:
  "pure sep_true"
  by (simp add: pure_def)

lemma pure_split:
  "pure P = (P = sep_true \<or> P = sep_false)"
  by (force simp: pure_def)

lemma pure_sep_conj:
  "\<lbrakk> pure P; pure Q \<rbrakk> \<Longrightarrow> pure (P \<and>\<^sup>* Q)"
  by (force simp: pure_split)

lemma pure_sep_impl:
  "\<lbrakk> pure P; pure Q \<rbrakk> \<Longrightarrow> pure (P \<longrightarrow>\<^sup>* Q)"
  by (force simp: pure_split)

lemma pure_conj_sep_conj:
  "\<lbrakk> (\<lambda>s. P s \<and> Q s) s; pure P \<or> pure Q \<rbrakk> \<Longrightarrow> (P \<and>\<^sup>* Q) s"
  by (force simp: pure_split sep_conj_ac intro: sep_conj_sep_true)

lemma pure_sep_conj_conj:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; pure P; pure Q \<rbrakk> \<Longrightarrow> (\<lambda>s. P s \<and> Q s) s"
  by (force simp: pure_split)

lemma pure_conj_sep_conj_assoc:
  "pure P \<Longrightarrow> ((\<lambda>s. P s \<and> Q s) \<and>\<^sup>* R) = (\<lambda>s. P s \<and> (Q \<and>\<^sup>* R) s)"
  by (force simp: pure_split)

lemma pure_sep_impl_impl:
  "\<lbrakk> (P \<longrightarrow>\<^sup>* Q) s; pure P \<rbrakk> \<Longrightarrow> P s \<longrightarrow> Q s"
  by (force simp: pure_split dest: sep_impl_sep_true_P)

lemma pure_impl_sep_impl:
  "\<lbrakk> P s \<longrightarrow> Q s; pure P; pure Q \<rbrakk> \<Longrightarrow> (P \<longrightarrow>\<^sup>* Q) s"
  by (force simp: pure_split)

(* Intuitionistic *)

definition
  intuitionistic :: "('a,'b) map_assert \<Rightarrow> bool"
where
  "intuitionistic P \<equiv> \<forall>s s'. P s \<and> s \<subseteq>\<^sub>m s' \<longrightarrow> P s'"

lemma intuitionisticI:
  "(\<And>s s'. \<lbrakk> P s; s \<subseteq>\<^sub>m s' \<rbrakk> \<Longrightarrow> P s') \<Longrightarrow> intuitionistic P"
  by (unfold intuitionistic_def, fast)

lemma intuitionisticD:
  "\<lbrakk> intuitionistic P; P s; s \<subseteq>\<^sub>m s' \<rbrakk> \<Longrightarrow> P s'"
  by (unfold intuitionistic_def, fast)

lemma pure_intuitionistic:
  "pure P \<Longrightarrow> intuitionistic P"
  by (clarsimp simp: intuitionistic_def pure_def, fast)

lemma intuitionistic_sep_map':
  "intuitionistic (p \<hookrightarrow>\<^sub>g v)"
proof (rule intuitionisticI)
  fix s s'
  assume "(p \<hookrightarrow>\<^sub>g v) s"
  then obtain s\<^sub>0 s\<^sub>1 where "(p \<mapsto>\<^sub>g v) s\<^sub>0" and s: "s = s\<^sub>1 ++ s\<^sub>0"
    by (force dest!: sep_conjD sep_map'D)
  moreover assume "s \<subseteq>\<^sub>m s'"
  with s have "s' = s' |` (UNIV - dom s\<^sub>0) ++ s\<^sub>0"
    by - (simp, drule map_add_le_mapE, subst map_le_restrict, fast, force)
  ultimately show "(p \<hookrightarrow>\<^sub>g v) s'" by (force intro: sep_map'I sep_conjI)
qed

lemma intuitionistic_sep_conj_sep_true:
  "intuitionistic (P \<and>\<^sup>* sep_true)"
  by (rule intuitionisticI, drule sep_conjD, clarsimp)
     (erule_tac s\<^sub>1="s'|`(dom s' - dom s\<^sub>0)" in sep_conjI, simp,
      force simp: map_disj_def,
      force intro: map_le_dom_restrict_sub_add map_add_le_mapE  sym)

lemma intuitionistic_sep_impl_sep_true:
  "intuitionistic (sep_true \<longrightarrow>\<^sup>* P)"
proof (rule intuitionisticI, rule sep_implI, clarsimp)
  fix s s' s'a
  assume "(sep_true \<longrightarrow>\<^sup>* P) s" and le: "s \<subseteq>\<^sub>m s'" and "s' \<bottom> s'a"
  moreover from this have "P (s ++ (s' |` (dom s' - dom s) ++ s'a))"
    by - (drule sep_implD,
          drule_tac x="s'|`(dom s' - dom s) ++ s'a" in spec,
          force simp: map_disj_def dest: map_disj_map_le)
  moreover have "dom s \<inter> dom (s' |` (dom s' - dom s)) = {}" by force
  ultimately show "P (s' ++ s'a)"
    by (force simp: map_le_dom_restrict_sub_add map_add_assoc dest!: map_add_comm)
qed

lemma intuitionistic_conj:
  "\<lbrakk> intuitionistic P; intuitionistic Q \<rbrakk> \<Longrightarrow> intuitionistic (\<lambda>s. P s \<and> Q s)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_disj:
  "\<lbrakk> intuitionistic P; intuitionistic Q \<rbrakk> \<Longrightarrow> intuitionistic (\<lambda>s. P s \<or> Q s)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_forall:
  "(\<And>x. intuitionistic (P x)) \<Longrightarrow> intuitionistic (\<lambda>s. \<forall>x. P x s)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_exists:
  "(\<And>x. intuitionistic (P x)) \<Longrightarrow> intuitionistic (\<lambda>s. \<exists>x. P x s)"
  by (force intro: intuitionisticI dest: intuitionisticD)

lemma intuitionistic_sep_conj:
  "intuitionistic (P::('a,'b) map_assert) \<Longrightarrow> intuitionistic (P \<and>\<^sup>* Q)"
proof (rule intuitionisticI, drule sep_conjD, clarsimp)
  fix s' s\<^sub>0 s\<^sub>1
  assume le: "s\<^sub>1 ++ s\<^sub>0 \<subseteq>\<^sub>m s'" and disj: "s\<^sub>0 \<bottom> (s\<^sub>1::'a \<rightharpoonup> 'b)"
  hence le_restrict: "s\<^sub>0 \<subseteq>\<^sub>m s' |` (dom s' - dom s\<^sub>1)"
    by - (rule map_le_dom_subset_restrict, erule map_add_le_mapE,
          force simp: map_disj_def  dest: map_le_implies_dom_le
          map_add_le_mapE)
  moreover assume "intuitionistic P" and "P s\<^sub>0"
  ultimately have "P (s' |` (dom s' - dom s\<^sub>1))"
    by - (erule (2) intuitionisticD)
  moreover from le_restrict have "s' |` (dom s' - dom s\<^sub>1) \<bottom> s\<^sub>1"
    by (force simp: map_disj_def dest: map_le_implies_dom_le)
  moreover from le disj have "s\<^sub>1 \<subseteq>\<^sub>m s'"
    by (subst (asm) map_add_comm, force  simp: map_disj_def)
       (erule map_add_le_mapE)
  hence "s' = s\<^sub>1 ++ s' |` (dom s' - dom s\<^sub>1)"
    by (subst map_add_comm, force simp: map_disj_def,
        force simp: map_le_dom_restrict_sub_add map_add_comm map_disj_def)
  moreover assume "Q s\<^sub>1"
  ultimately show "(P \<and>\<^sup>* Q) s'"
    by - (erule (3) sep_conjI)
qed

lemma intuitionistic_sep_impl:
  "intuitionistic (Q::('a,'b) map_assert) \<Longrightarrow> intuitionistic (P \<longrightarrow>\<^sup>* Q)"
proof (rule intuitionisticI, rule sep_implI, clarsimp)
  fix s s' s'a
  assume le: "s \<subseteq>\<^sub>m s'" and disj: "s' \<bottom> (s'a::'a \<rightharpoonup> 'b)"
  moreover from this have "s ++ s'a \<subseteq>\<^sub>m s' ++ s'a"
  proof -
    from le disj have "s \<subseteq>\<^sub>m s ++ s'a"
      by (subst map_add_com)
         (force simp: map_disj_def dest: map_le_implies_dom_le, simp)
    with le disj show ?thesis
      by - (rule map_add_le_mapI, subst map_add_com,
            auto elim: map_le_trans)
  qed
  moreover assume "(P \<longrightarrow>\<^sup>* Q) s" and "intuitionistic Q" and "P s'a"
  ultimately show "Q (s' ++ s'a)"
    by (fast elim: map_disj_map_le intuitionisticD dest: sep_implD)
qed

lemma strongest_intuitionistic:
  "\<not> (\<exists>Q. (\<forall>s. (Q s \<longrightarrow> (P \<and>\<^sup>* sep_true) s)) \<and> intuitionistic Q \<and>
      Q \<noteq> (P \<and>\<^sup>* sep_true) \<and> (\<forall>s. P s \<longrightarrow> Q s))"
  by (clarsimp, rule ext) (force dest!: sep_conjD intuitionisticD)

lemma weakest_intuitionistic:
  "\<not> (\<exists>Q. (\<forall>s. ((sep_true \<longrightarrow>\<^sup>* P) s \<longrightarrow> Q s)) \<and> intuitionistic Q \<and>
      Q \<noteq> (sep_true \<longrightarrow>\<^sup>* P) \<and> (\<forall>s. Q s \<longrightarrow> P s))"
  apply (clarsimp, rule ext)
  apply (rename_tac Q x)
  apply (rule iffI; clarsimp?)
  apply (rule sep_implI')
  apply (rename_tac h')
  apply (drule_tac s=x and s'="x ++ h'" in intuitionisticD; clarsimp simp: map_ac_simps)
  done

lemma intuitionistic_sep_conj_sep_true_P:
  "\<lbrakk> (P \<and>\<^sup>* sep_true) s; intuitionistic P \<rbrakk> \<Longrightarrow> P s"
  by (force dest: intuitionisticD sep_conjD)

lemma intuitionistic_sep_conj_sep_true_simp:
  "intuitionistic P \<Longrightarrow> (P \<and>\<^sup>* sep_true) = P"
  by (fast intro: sep_conj_sep_true elim: intuitionistic_sep_conj_sep_true_P)

lemma intuitionistic_sep_impl_sep_true_P:
  "\<lbrakk> P s; intuitionistic P \<rbrakk> \<Longrightarrow> (sep_true \<longrightarrow>\<^sup>* P) s"
  by (force simp: map_add_com intro: sep_implI dest: intuitionisticD)

lemma intuitionistic_sep_impl_sep_true_simp:
  "intuitionistic P \<Longrightarrow> (sep_true \<longrightarrow>\<^sup>* P) = P"
  by (fast elim: sep_impl_sep_true_P intuitionistic_sep_impl_sep_true_P)

(* Domain exact *)

definition
  dom_exact :: "('a,'b) map_assert \<Rightarrow> bool"
where
  "dom_exact P \<equiv> \<forall>s s'. P s \<and> P s' \<longrightarrow> dom s = dom s'"

lemma dom_exactI:
  "(\<And>s s'. \<lbrakk> P s; P s' \<rbrakk> \<Longrightarrow> dom s = dom s') \<Longrightarrow> dom_exact P"
  by (unfold dom_exact_def, fast)

lemma dom_exactD:
  "\<lbrakk> dom_exact P; P s\<^sub>0; P s\<^sub>1 \<rbrakk> \<Longrightarrow> dom s\<^sub>0 = dom s\<^sub>1"
  by (unfold dom_exact_def, fast)

lemma dom_exact_sep_conj:
  "\<lbrakk> dom_exact P; dom_exact Q \<rbrakk> \<Longrightarrow> dom_exact (P \<and>\<^sup>* Q)"
  by (rule dom_exactI, (drule sep_conjD)+, clarsimp)
     (drule (2) dom_exactD, drule (2) dom_exactD, simp)

lemma dom_exact_sep_conj_conj:
  "\<lbrakk> (P \<and>\<^sup>* R) s; (Q \<and>\<^sup>* R) s; dom_exact R \<rbrakk> \<Longrightarrow> ((\<lambda>s. P s \<and> Q s) \<and>\<^sup>* R) s"
  by ((drule sep_conjD)+, clarsimp simp: sep_conj_ac,
      rule sep_conjI, fast, rule conjI)
     (fast, drule (2) dom_exactD, drule (1) map_disj_add_eq_dom_right_eq,
      auto simp: map_ac_simps)

lemma sep_conj_conj_simp:
  "dom_exact R \<Longrightarrow> ((\<lambda>s. P s \<and> Q s) \<and>\<^sup>* R) = (\<lambda>s. (P \<and>\<^sup>* R) s \<and> (Q \<and>\<^sup>* R) s)"
  by (fast intro!: sep_conj_conj dom_exact_sep_conj_conj)

definition dom_eps :: "('a,'b) map_assert \<Rightarrow> 'a set" where
  "dom_eps P \<equiv> THE x. \<forall>s. P s \<longrightarrow> x = dom s"

lemma dom_epsI:
  "\<lbrakk> dom_exact P; P s; x \<in> dom s \<rbrakk> \<Longrightarrow> x \<in> dom_eps P"
  by (unfold dom_eps_def, rule_tac a="dom s" in theI2)
     (fastforce simp: dom_exact_def, clarsimp+)

lemma dom_epsD [rule_format]:
  "\<lbrakk> dom_exact P; P s \<rbrakk> \<Longrightarrow> x \<in> dom_eps P \<longrightarrow> x \<in> dom s"
  by (unfold dom_eps_def, rule_tac a="dom s" in theI2)
     (fastforce simp: dom_exact_def, clarsimp+)

lemma dom_eps:
  "\<lbrakk> dom_exact P; P s \<rbrakk> \<Longrightarrow> dom s = dom_eps P"
  by (force intro: dom_epsI dest: dom_epsD)

lemma map_restrict_dom_exact:
  "\<lbrakk> dom_exact P; P s \<rbrakk> \<Longrightarrow> s |` dom_eps P = s"
  by (force simp: restrict_map_def None_com intro: dom_epsI)

lemma map_restrict_dom_exact2:
  "\<lbrakk> dom_exact P; P s\<^sub>0; s\<^sub>0 \<bottom> s\<^sub>1 \<rbrakk> \<Longrightarrow> (s\<^sub>1 |` dom_eps P) = Map.empty"
  by (force simp: restrict_map_def map_disj_def dest: dom_epsD)

lemma map_restrict_dom_exact3:
  "\<lbrakk> dom_exact P; P s \<rbrakk> \<Longrightarrow> s |` (UNIV - dom_eps P) = Map.empty"
  by (force simp: restrict_map_def dest: dom_epsI)

lemma map_add_restrict_dom_exact:
  "\<lbrakk> dom_exact P; s\<^sub>0 \<bottom> s\<^sub>1; P s\<^sub>1 \<rbrakk> \<Longrightarrow> (s\<^sub>1 ++ s\<^sub>0) |` (dom_eps P) = s\<^sub>1"
  by (simp add: map_add_restrict map_restrict_dom_exact)
     (subst map_restrict_dom_exact2, auto simp: map_disj_def)

lemma map_add_restrict_dom_exact2:
  "\<lbrakk> dom_exact P; s\<^sub>0 \<bottom> s\<^sub>1; P s\<^sub>0 \<rbrakk> \<Longrightarrow> (s\<^sub>1 ++ s\<^sub>0) |` (UNIV - dom_eps P) = s\<^sub>1"
  by (force simp: map_add_restrict map_disj_def dom_eps
            intro: restrict_map_subdom dest: map_restrict_dom_exact3 )

lemma dom_exact_sep_conj_forall:
  assumes sc: "\<forall>x. (P x \<and>\<^sup>* Q) s" and de: "dom_exact Q"
  shows "((\<lambda>s. \<forall>x. P x s) \<and>\<^sup>* Q) s"
proof (rule_tac s\<^sub>0="s |` (UNIV - dom_eps Q)" and  s\<^sub>1="s |` dom_eps Q" in sep_conjI)
  from sc de show "\<forall>x. P x (s |` (UNIV - dom_eps Q))"
    by (force simp: map_add_restrict_dom_exact2 sep_conj_ac dest: sep_conjD)
next
  from sc de show "Q (s |` dom_eps Q)"
    by (force simp: map_add_restrict_dom_exact dest!: sep_conjD spec)
next
  from sc de show "s |` (UNIV - dom_eps Q) \<bottom> s |` dom_eps Q"
    by (force simp: map_add_restrict_dom_exact2 map_ac_simps
              dest: map_add_restrict_dom_exact dest!: sep_conjD spec)
next
  show "s = s |` dom_eps Q ++ s |` (UNIV - dom_eps Q)" by simp
qed

lemma sep_conj_forall_simp:
  "dom_exact Q \<Longrightarrow> ((\<lambda>s. \<forall>x. P x s) \<and>\<^sup>* Q) = (\<lambda>s. \<forall>x. (P x \<and>\<^sup>* Q) s)"
  by (fast dest: sep_conj_forall dom_exact_sep_conj_forall)

lemma dom_exact_sep_map:
  "dom_exact (i \<mapsto>\<^sub>g x)"
  by (clarsimp simp: dom_exact_def sep_map_def)

lemma dom_exact_P_emp:
  "\<lbrakk> dom_exact P; P Map.empty; P s \<rbrakk> \<Longrightarrow> s = Map.empty"
  by (auto simp: dom_exact_def)

(* Strictly exact *)

definition
  strictly_exact :: "('a,'b) map_assert \<Rightarrow> bool"
where
  "strictly_exact P \<equiv> \<forall>s s'. P s \<and> P s' \<longrightarrow> s = s'"

lemma strictly_exactD:
  "\<lbrakk> strictly_exact P; P s\<^sub>0; P s\<^sub>1 \<rbrakk> \<Longrightarrow> s\<^sub>0 = s\<^sub>1"
  by (unfold strictly_exact_def, fast)

lemma strictly_exactI:
  "(\<And>s s'. \<lbrakk> P s; P s' \<rbrakk> \<Longrightarrow> s = s') \<Longrightarrow> strictly_exact P"
  by (unfold strictly_exact_def, fast)

lemma strictly_exact_dom_exact:
  "strictly_exact P \<Longrightarrow> dom_exact P"
  by (force simp: strictly_exact_def dom_exact_def)

lemma strictly_exact_sep_emp:
  "strictly_exact \<box>"
  by (force simp: strictly_exact_def dest: sep_empD)

lemma strictly_exact_sep_conj:
  "\<lbrakk> strictly_exact P; strictly_exact Q \<rbrakk> \<Longrightarrow> strictly_exact (P \<and>\<^sup>* Q)"
  by (force intro!: strictly_exactI dest: sep_conjD strictly_exactD)

lemma strictly_exact_conj_impl:
  "\<lbrakk> (Q \<and>\<^sup>* sep_true) s; P s; strictly_exact Q \<rbrakk> \<Longrightarrow> (Q \<and>\<^sup>* (Q \<longrightarrow>\<^sup>* P)) s"
  by (force intro: sep_conjI sep_implI dest: strictly_exactD dest!: sep_conjD)

lemma dom_eps_sep_emp [simp]:
  "dom_eps \<box> = {}"
  apply(subst dom_eps [symmetric])
    apply(rule strictly_exact_dom_exact)
    apply(rule strictly_exact_sep_emp)
   apply(rule sep_emp_empty)
  apply simp
  done

lemma dom_eps_sep_map:
  "g p \<Longrightarrow> dom_eps (p \<mapsto>\<^sub>g (v::'a::mem_type)) = s_footprint p"
  apply(subst dom_eps [symmetric])
    apply(rule dom_exact_sep_map)
   apply(rule sep_map_singleton)
   apply(erule ptr_retyp_h_t_valid)
  apply(subst singleton_dom)
   apply(erule ptr_retyp_h_t_valid)
  apply simp
  done

(* Non-empty *)

definition non_empty :: "('a,'b) map_assert \<Rightarrow> bool" where
  "non_empty P \<equiv> \<exists>s. P s"

lemma non_emptyI:
  "P s \<Longrightarrow> non_empty P"
  by (force simp: non_empty_def)

lemma non_emptyD:
  "non_empty P \<Longrightarrow> \<exists>s. P s"
  by (force simp: non_empty_def)

lemma non_empty_sep_true:
  "non_empty sep_true"
  by (simp add: non_empty_def)

lemma non_empty_sep_false:
  "\<not> non_empty sep_false"
  by (simp add: non_empty_def)

lemma non_empty_sep_emp:
  "non_empty \<box>"
  unfolding non_empty_def by (rule exI, rule sep_emp_empty)

lemma non_empty_sep_map:
  "g p \<Longrightarrow> non_empty (p \<mapsto>\<^sub>g (v::'a::mem_type))"
  apply(unfold non_empty_def)
  apply(rule exI, rule sep_map_singleton)
  apply(erule ptr_retyp_h_t_valid)
  done

lemma non_empty_sep_conj:
  "\<lbrakk> non_empty P; non_empty Q; dom_exact P; dom_exact Q;
      dom_eps P \<inter> dom_eps Q = {} \<rbrakk> \<Longrightarrow> non_empty (P \<and>\<^sup>* Q)"
  apply(clarsimp simp: non_empty_def)
  apply(rename_tac s s')
  apply(rule_tac x="s++s'" in exI)
  apply(rule sep_conjI, assumption+)
   apply(clarsimp simp: map_disj_def dom_eps)
  apply(subst map_add_com)
   apply(clarsimp simp: map_disj_def dom_eps)
  apply simp
  done

lemma non_empty_sep_map':
  "g p \<Longrightarrow> non_empty (p \<hookrightarrow>\<^sub>g (v::'a::mem_type))"
  apply(unfold sep_map'_def)
  apply(clarsimp simp: non_empty_def sep_conj_ac)
  apply(rule_tac x="singleton p v h (ptr_retyp p d)" in exI)
  apply(rule_tac s\<^sub>0=Map.empty in sep_conjI)
     apply simp
    apply(rule sep_map_singleton)
    apply(erule ptr_retyp_h_t_valid)
   apply(simp add: map_disj_def)
  apply simp
  done

lemma non_empty_sep_impl:
  "\<not> P Map.empty \<Longrightarrow> non_empty (P \<longrightarrow>\<^sup>* Q)"
  apply(clarsimp simp: non_empty_def)
  apply(rule_tac x="\<lambda>s. Some undefined" in exI)
  apply(rule sep_implI)
  apply(clarsimp simp: map_disj_def)
  done

(* Some useful lemmas *)

lemma pure_conj_right: "(Q \<and>\<^sup>* (\<lambda>s. P' \<and> Q' s)) = (\<lambda>s. P' \<and> (Q \<and>\<^sup>* Q') s)"
  by (rule ext, rule, rule, clarsimp dest!: sep_conjD)
     (erule sep_conj_impl, auto)

lemma pure_conj_right': "(Q \<and>\<^sup>* (\<lambda>s. P' s \<and> Q')) = (\<lambda>s. Q' \<and> (Q \<and>\<^sup>* P') s)"
  by (simp add: conj_comms pure_conj_right)

lemma pure_conj_left: "((\<lambda>s. P' \<and> Q' s) \<and>\<^sup>* Q) = (\<lambda>s. P' \<and> (Q' \<and>\<^sup>* Q) s)"
  by (simp add: pure_conj_right sep_conj_ac)

lemma pure_conj_left': "((\<lambda>s. P' s \<and> Q') \<and>\<^sup>* Q) = (\<lambda>s. Q' \<and> (P' \<and>\<^sup>* Q) s)"
  by (subst conj_comms, subst pure_conj_left, simp)

lemmas pure_conj = pure_conj_right pure_conj_right' pure_conj_left pure_conj_left'

declare pure_conj [simp add]

lemma sep_conj_sep_conj_sep_impl_sep_conj:
  "(P \<and>\<^sup>* R) s \<Longrightarrow> (P \<and>\<^sup>* (Q \<longrightarrow>\<^sup>* (Q \<and>\<^sup>* R))) s"
  by (erule (1) sep_conj_impl, erule sep_conj_sep_impl, simp add: sep_conj_ac)

lemma sep_map'_conjE1_exc:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; \<And>s. P s \<Longrightarrow> (i \<hookrightarrow>\<^sub>g v) s \<rbrakk> \<Longrightarrow> (i \<hookrightarrow>\<^sub>g v) s"
  by (subst sep_map'_unfold_exc, erule sep_conj_impl, simp+)

lemma sep_map'_conjE2_exc:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; \<And>s. Q s \<Longrightarrow> (i \<hookrightarrow>\<^sub>g v) s \<rbrakk> \<Longrightarrow> (i \<hookrightarrow>\<^sub>g v) s"
  by (subst (asm) sep_conj_com, erule sep_map'_conjE1_exc, simp)

lemma sep_map'_any_conjE1_exc:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; \<And>s. P s \<Longrightarrow> (i \<hookrightarrow>\<^sub>g -) s \<rbrakk> \<Longrightarrow> (i \<hookrightarrow>\<^sub>g -) s"
  by (subst sep_map'_any_unfold_exc, erule sep_conj_impl, simp+)

lemma sep_map'_any_conjE2_exc:
  "\<lbrakk> (P \<and>\<^sup>* Q) s; \<And>s. Q s \<Longrightarrow> (i \<hookrightarrow>\<^sub>g -) s \<rbrakk> \<Longrightarrow> (i \<hookrightarrow>\<^sub>g -) s"
  by (subst (asm) sep_conj_com, erule sep_map'_any_conjE1_exc, simp)

lemma sep_conj_mapD_exc:
  "((i \<mapsto>\<^sub>g v) \<and>\<^sup>* P) s \<Longrightarrow> (i \<hookrightarrow>\<^sub>g v) s \<and> ((i \<mapsto>\<^sub>g -) \<and>\<^sup>* P) s"
  by (force simp: sep_conj_ac intro: sep_conj_impl sep_map'_conjE2_exc)

lemma sep_impl_conj_sameD:
  "\<lbrakk> (P \<longrightarrow>\<^sup>* P \<and>\<^sup>* Q) s; dom_exact P; non_empty P; dom s \<subseteq> UNIV - dom_eps P \<rbrakk>
      \<Longrightarrow> Q s"
  apply(drule sep_implD)
  apply(clarsimp simp: non_empty_def)
  apply(rename_tac s')
  apply(drule_tac x=s' in spec)
  apply(erule impE)
   apply(fastforce simp: map_disj_def dom_eps)
  apply(drule sep_conjD, clarsimp)
  apply(clarsimp simp: map_disj_def)
  apply(subst (asm) map_add_comm)
   apply(clarsimp simp: dom_eps)
   apply fast
  apply(subst (asm) map_add_comm, fast)
  apply(drule map_disj_add_eq_dom_right_eq)
     apply(simp add: dom_eps)
    apply(clarsimp simp: dom_eps map_disj_def)
    apply fast
   apply(simp add: map_disj_def)
  apply clarsimp
  done

lemma sep_impl_conj_sameI:
  "Q s \<Longrightarrow>  (P \<longrightarrow>\<^sup>* P \<and>\<^sup>* Q) s"
  by (fastforce intro: sep_implI sep_conjI simp: map_disj_com)

end


theory FBound
  imports "BlexerSimp" "ClosedFormsBounds"
begin

fun distinctBy :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a list"
  where
  "distinctBy [] f acc = []"
| "distinctBy (x#xs) f acc =
     (if (f x) \<in> acc then distinctBy xs f acc
      else x # (distinctBy xs f ({f x} \<union> acc)))"

fun rerase :: "arexp \<Rightarrow> rrexp"
where
  "rerase AZERO = RZERO"
| "rerase (AONE _) = RONE"
| "rerase (ACHAR _ c) = RCHAR c"
| "rerase (AALTs bs rs) = RALTS (map rerase rs)"
| "rerase (ASEQ _ r1 r2) = RSEQ (rerase r1) (rerase r2)"
| "rerase (ASTAR _ r) = RSTAR (rerase r)"
| "rerase (ANTIMES _ r n) = RNTIMES (rerase r) n"

lemma eq1_rerase:
  shows "x ~1 y \<longleftrightarrow> (rerase x) = (rerase y)"
  apply(induct x y rule: eq1.induct)
  apply(auto)
  done

lemma distinctBy_distinctWith:
  shows "distinctBy xs f (f ` acc) = distinctWith xs (\<lambda>x y. f x = f y) acc"
  apply(induct xs arbitrary: acc)
  apply(auto)
  by (metis image_insert)

lemma distinctBy_distinctWith2:
  shows "distinctBy xs rerase {} = distinctWith xs eq1 {}"
  apply(subst distinctBy_distinctWith[of _ _ "{}", simplified])
  using eq1_rerase by presburger

lemma asize_rsize:
  shows "rsize (rerase r) = asize r"
  apply(induct r rule: rerase.induct)
  apply(auto)
  apply (metis (mono_tags, lifting) comp_apply map_eq_conv)
  done

lemma rerase_fuse:
  shows "rerase (fuse bs r) = rerase r"
  apply(induct r)
       apply simp+
  done

lemma rerase_bsimp_ASEQ:
  shows "rerase (bsimp_ASEQ x1 a1 a2) = rsimp_SEQ (rerase a1) (rerase a2)"
  apply(induct x1 a1 a2 rule: bsimp_ASEQ.induct)
  apply(auto)
  done

lemma rerase_bsimp_AALTs:
  shows "rerase (bsimp_AALTs bs rs) = rsimp_ALTs (map rerase rs)"
  apply(induct bs rs rule: bsimp_AALTs.induct)
  apply(auto simp add: rerase_fuse)
  done

fun anonalt :: "arexp \<Rightarrow> bool"
  where
  "anonalt (AALTs bs2 rs) = False"
| "anonalt r = True"

fun agood :: "arexp \<Rightarrow> bool" where
  "agood AZERO = False"
| "agood (AONE cs) = True"
| "agood (ACHAR cs c) = True"
| "agood (AALTs cs []) = False"
| "agood (AALTs cs [r]) = False"
| "agood (AALTs cs (r1#r2#rs)) = (distinct (map rerase (r1 # r2 # rs)) \<and>(\<forall>r' \<in> set (r1#r2#rs). agood r' \<and> anonalt r'))"
| "agood (ASEQ _ AZERO _) = False"
| "agood (ASEQ _ (AONE _) _) = False"
| "agood (ASEQ _ _ AZERO) = False"
| "agood (ASEQ cs r1 r2) = (agood r1 \<and> agood r2)"
| "agood (ASTAR cs r) = True"

fun anonnested :: "arexp \<Rightarrow> bool"
  where
  "anonnested (AALTs bs2 []) = True"
| "anonnested (AALTs bs2 ((AALTs bs1 rs1) # rs2)) = False"
| "anonnested (AALTs bs2 (r # rs2)) = anonnested (AALTs bs2 rs2)"
| "anonnested r = True"

lemma asize0:
  shows "0 < asize r"
  apply(induct  r)
  apply(auto)
  done

lemma rnullable:
  shows "rnullable (rerase r) = bnullable r"
  apply(induct r rule: rerase.induct)
  apply(auto)
  done

lemma rder_bder_rerase:
  shows "rder c (rerase r ) = rerase (bder c r)"
  apply (induct r)
  apply (auto)
  using rerase_fuse apply presburger
  using rnullable apply blast
  using rnullable by blast

lemma rerase_map_bsimp:
  assumes "\<And> r. r \<in> set rs \<Longrightarrow> rerase (bsimp r) = (rsimp \<circ> rerase) r"
  shows "map rerase (map bsimp rs) =  map (rsimp \<circ> rerase) rs"
  using assms
  apply(induct rs)
  by simp_all

lemma rerase_flts:
  shows "map rerase (flts rs) = rflts (map rerase rs)"
  apply(induct rs rule: flts.induct)
  apply(auto simp add: rerase_fuse)
  done

lemma rerase_dB:
  shows "map rerase (distinctBy rs rerase acc) = rdistinct (map rerase rs) acc"
  apply(induct rs arbitrary: acc)
  apply simp+
  done

lemma rerase_earlier_later_same:
  assumes " \<And>r. r \<in> set rs \<Longrightarrow> rerase (bsimp r) = rsimp (rerase r)"
  shows " (map rerase (distinctBy (flts (map bsimp rs)) rerase {})) =
          (rdistinct (rflts (map (rsimp \<circ> rerase) rs)) {})"
  apply(subst rerase_dB)
  apply(subst rerase_flts)
  apply(subst rerase_map_bsimp)
  apply auto
  using assms
  apply simp
  done

lemma bsimp_rerase:
  shows "rerase (bsimp a) = rsimp (rerase a)"
  apply(induct a rule: bsimp.induct)
  apply(auto)
  using rerase_bsimp_ASEQ apply presburger
  using distinctBy_distinctWith2 rerase_bsimp_AALTs rerase_earlier_later_same by fastforce

lemma rders_simp_size:
  shows "rders_simp (rerase r) s  = rerase (bders_simp r s)"
  apply(induct s rule: rev_induct)
  apply simp
  by (simp add: bders_simp_append rder_bder_rerase rders_simp_append bsimp_rerase)

corollary aders_simp_finiteness:
  assumes "\<exists>N. \<forall>s. rsize (rders_simp (rerase r) s) \<le> N"
  shows " \<exists>N. \<forall>s. asize (bders_simp r s) \<le> N"
proof -
  from assms obtain N where "\<forall>s. rsize (rders_simp (rerase r) s) \<le> N"
    by blast
  then have "\<forall>s. rsize (rerase (bders_simp r s)) \<le> N"
    by (simp add: rders_simp_size)
  then have "\<forall>s. asize (bders_simp r s) \<le> N"
    by (simp add: asize_rsize)
  then show "\<exists>N. \<forall>s. asize (bders_simp r s) \<le> N" by blast
qed

theorem annotated_size_bound:
  shows "\<exists>N. \<forall>s. asize (bders_simp r s) \<le> N"
  apply(insert aders_simp_finiteness)
  by (simp add: rders_simp_bounded)

unused_thms

end