(*
 * Copyright 2016, Data61, CSIRO
 *
 * 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(DATA61_BSD)
 *)
section \<open>Annotations, assertions and associated operations\<close>

theory OG_Annotations
imports SmallStep
begin

type_synonym 's assn = "'s set"

datatype ('s, dead 'p, dead 'f) ann =
    AnnExpr "'s assn"
  | AnnRec "'s assn" "('s, 'p, 'f) ann"
  | AnnWhile "'s assn" "'s assn" "('s, 'p, 'f) ann"
  | AnnComp "('s, 'p, 'f) ann" "('s, 'p, 'f) ann"
  | AnnBin "'s assn" "('s, 'p, 'f) ann" "('s, 'p, 'f) ann"
  | AnnPar "(('s, 'p, 'f) ann \<times> 's assn \<times> 's assn) list"
  | AnnCall "'s assn" nat

type_synonym ('s, 'p, 'f) ann_triple = "('s, 'p, 'f) ann \<times> 's assn \<times> 's assn"

text \<open>
 The list of \<open>ann_triple\<close> is useful if the code calls the same function multiple times
 and require different annotations for the function body each time.
\<close>
type_synonym ('s,'p,'f) proc_assns = "'p \<Rightarrow> (('s, 'p, 'f) ann) list option"

abbreviation  (input) pres:: "('s, 'p, 'f) ann_triple \<Rightarrow> ('s, 'p, 'f) ann"
where "pres a \<equiv> fst a"

abbreviation (input) postcond :: "('s, 'p, 'f) ann_triple \<Rightarrow> 's assn"
where "postcond a \<equiv> fst (snd a)"

abbreviation (input) abrcond :: "('s, 'p, 'f) ann_triple \<Rightarrow> 's assn"
where "abrcond a \<equiv> snd (snd a)"

fun pre :: "('s, 'p, 'f) ann \<Rightarrow> 's assn" where
  "pre (AnnExpr r)      = r"
| "pre (AnnRec r e)     = r"
| "pre (AnnWhile r i e) = r"
| "pre (AnnComp e\<^sub>1 e\<^sub>2)   =  pre e\<^sub>1"
| "pre (AnnBin r e\<^sub>1 e\<^sub>2)  = r"
| "pre (AnnPar as)      = \<Inter> (pre ` set (map pres (as)))"
| "pre (AnnCall r n)    = r"

fun pre_par :: "('s, 'p, 'f) ann \<Rightarrow> bool" where
  "pre_par (AnnComp e\<^sub>1 e\<^sub>2) =  pre_par e\<^sub>1"
| "pre_par (AnnPar as)  = True"
| "pre_par _    = False"

fun pre_set :: "('s, 'p, 'f) ann \<Rightarrow> ('s assn) set" where
  "pre_set (AnnExpr r)      = {r}"
| "pre_set (AnnRec r e)     = {r}"
| "pre_set (AnnWhile r i e) = {r}"
| "pre_set (AnnComp e\<^sub>1 e\<^sub>2)   =  pre_set e\<^sub>1"
| "pre_set (AnnBin r e\<^sub>1 e\<^sub>2)  = {r}"
| "pre_set (AnnPar as)       = \<Union> (pre_set ` set (map pres (as)))"
(*| "pre_set (AnnPar e\<^sub>1 e\<^sub>2)    = pre_set (pres e\<^sub>1) \<union> pre_set (pres e\<^sub>2)" *)
| "pre_set (AnnCall r n)    = {r}"

lemma fst_BNFs[simp]:
  "a \<in> Basic_BNFs.fsts (a,b)"
   using fsts.intros by auto

lemma "\<not>pre_par c  \<Longrightarrow> pre c \<in> pre_set c"
  by (induct c; simp)

lemma pre_set:
  "pre c = \<Inter> (pre_set c)"
  by (induct c; fastforce)

lemma pre_imp_pre_set:
  "s \<in> pre c \<Longrightarrow> a \<in> pre_set c \<Longrightarrow> s \<in> a"
  by (simp add: pre_set)

abbreviation precond :: "('s, 'p, 'f) ann_triple \<Rightarrow> 's assn"
where "precond a \<equiv> pre (fst a)"

fun strengthen_pre :: "('s, 'p, 'f) ann \<Rightarrow> 's assn \<Rightarrow> ('s, 'p, 'f) ann" where
  "strengthen_pre (AnnExpr r)      r' = AnnExpr (r \<inter> r')"
| "strengthen_pre (AnnRec r e)     r' = AnnRec (r \<inter> r') e"
| "strengthen_pre (AnnWhile r i e) r' = AnnWhile (r \<inter> r') i e"
| "strengthen_pre (AnnComp e\<^sub>1 e\<^sub>2)   r' = AnnComp (strengthen_pre e\<^sub>1 r') e\<^sub>2"
| "strengthen_pre (AnnBin r e\<^sub>1 e\<^sub>2) r' = AnnBin (r \<inter> r') e\<^sub>1 e\<^sub>2"
| "strengthen_pre (AnnPar as)    r' = (AnnPar as)"
| "strengthen_pre (AnnCall r n)    r' = AnnCall (r \<inter> r') n"

fun weaken_pre :: "('s, 'p, 'f) ann \<Rightarrow> 's assn \<Rightarrow> ('s, 'p, 'f) ann" where
  "weaken_pre (AnnExpr r)      r' = AnnExpr (r \<union> r')"
| "weaken_pre (AnnRec r e)     r' = AnnRec (r \<union> r') e"
| "weaken_pre (AnnWhile r i e) r' = AnnWhile (r \<union> r') i e"
| "weaken_pre (AnnComp e\<^sub>1 e\<^sub>2)   r' = AnnComp (weaken_pre e\<^sub>1 r') e\<^sub>2"
| "weaken_pre (AnnBin r e\<^sub>1 e\<^sub>2) r' = AnnBin (r \<union> r') e\<^sub>1 e\<^sub>2"
| "weaken_pre (AnnPar as)   r' = AnnPar as"
| "weaken_pre (AnnCall r n)    r' = AnnCall (r \<union> r') n"

lemma weaken_pre_empty[simp]:
  "weaken_pre r {} = r"
  by (induct r) auto

text \<open>Annotations for call definition (see Language.thy)\<close>
definition
 ann_call :: "'s assn \<Rightarrow> 's assn \<Rightarrow> nat \<Rightarrow>  's assn \<Rightarrow>'s assn \<Rightarrow>  's assn \<Rightarrow> 's assn \<Rightarrow> ('s,'p,'f) ann"
where
 "ann_call init r n restoreq return restorea A \<equiv>
  AnnRec init (AnnComp (AnnComp (AnnComp (AnnExpr init) (AnnCall r n)) (AnnComp (AnnExpr restorea) (AnnExpr A)))
          (AnnRec restoreq (AnnComp (AnnExpr restoreq) (AnnExpr return))))"

inductive ann_matches :: "('s,'p,'f) body \<Rightarrow> ('s,'p,'f) proc_assns \<Rightarrow> ('s, 'p, 'f) ann \<Rightarrow> ('s, 'p, 'f) com \<Rightarrow> bool" where
  ann_skip: "ann_matches \<Gamma> \<Theta> (AnnExpr a) Skip"
| ann_basic: "ann_matches \<Gamma> \<Theta> (AnnExpr a) (Basic f)"
| ann_spec: "ann_matches \<Gamma> \<Theta> (AnnExpr a) (Spec r)"
| ann_throw: "ann_matches \<Gamma> \<Theta> (AnnExpr a) (Throw)"
| ann_await: "ann_matches \<Gamma> \<Theta> a e \<Longrightarrow>
               ann_matches \<Gamma> \<Theta> (AnnRec r a) (Await b e)"
| ann_seq: "\<lbrakk> ann_matches \<Gamma> \<Theta> a1 p1; ann_matches \<Gamma> \<Theta> a2 p2 \<rbrakk> \<Longrightarrow>
               ann_matches \<Gamma> \<Theta> (AnnComp a1 a2) (Seq p1 p2)"
| ann_cond: "\<lbrakk> ann_matches \<Gamma> \<Theta> a1 c1; ann_matches \<Gamma> \<Theta> a2 c2 \<rbrakk> \<Longrightarrow>
               ann_matches \<Gamma> \<Theta> (AnnBin a a1 a2) (Cond b c1 c2)"
| ann_catch: "\<lbrakk> ann_matches \<Gamma> \<Theta> a1 c1; ann_matches \<Gamma> \<Theta> a2 c2 \<rbrakk> \<Longrightarrow>
                ann_matches \<Gamma> \<Theta> (AnnComp a1 a2) (Catch c1 c2)"
| ann_while: "ann_matches \<Gamma> \<Theta> a' e \<Longrightarrow>
                ann_matches \<Gamma> \<Theta> (AnnWhile a i a') (While b e)"
| ann_guard: "\<lbrakk> ann_matches \<Gamma> \<Theta> a' e \<rbrakk> \<Longrightarrow>
                ann_matches \<Gamma> \<Theta> (AnnRec a a') (Guard f b e)"
| ann_call: "\<lbrakk> \<Theta> f = Some as; \<Gamma> f = Some b; n < length as;
               ann_matches \<Gamma> \<Theta> (as!n) b\<rbrakk> \<Longrightarrow>
   ann_matches \<Gamma> \<Theta> (AnnCall a n) (Call f)"
| ann_dyncom: "\<forall>s\<in>r. ann_matches \<Gamma> \<Theta> a (c s) \<Longrightarrow>
               ann_matches \<Gamma> \<Theta> (AnnRec r a) (DynCom c)"
| ann_parallel: "\<lbrakk> length as = length cs;
                   \<forall>i<length cs. ann_matches \<Gamma> \<Theta> (pres (as!i)) (cs!i) \<rbrakk> \<Longrightarrow>
   ann_matches \<Gamma> \<Theta> (AnnPar as) (Parallel cs)"

primrec ann_guards:: "'s assn \<Rightarrow> ('f \<times> 's bexp ) list \<Rightarrow>
                  ('s,'p,'f) ann \<Rightarrow> ('s,'p,'f) ann"
where
  "ann_guards _ [] c = c" |
  "ann_guards r (g#gs) c = AnnRec r (ann_guards (r \<inter> snd g) gs c)"

end


section Occurrences

text \<open>This theory contains all of the definitions and laws required for reasoning about
  identifiers that occur in the data structures of the concurrent revisions model.\<close>

theory Occurrences
  imports Data
begin

subsection Definitions

subsubsection \<open>Revision identifiers\<close>

definition RID\<^sub>S :: "('r,'l,'v) store \<Rightarrow> 'r set" where
  "RID\<^sub>S \<sigma> \<equiv> \<Union> (RID\<^sub>V ` ran \<sigma>)"

definition RID\<^sub>L :: "('r,'l,'v) local_state \<Rightarrow> 'r set" where
  "RID\<^sub>L s \<equiv> case s of (\<sigma>, \<tau>, e) \<Rightarrow> RID\<^sub>S \<sigma> \<union> RID\<^sub>S \<tau> \<union> RID\<^sub>E e"

definition RID\<^sub>G :: "('r,'l,'v) global_state \<Rightarrow> 'r set" where
  "RID\<^sub>G s \<equiv> dom s \<union> \<Union> (RID\<^sub>L ` ran s)"

subsubsection \<open>Location identifiers\<close>

definition LID\<^sub>S :: "('r,'l,'v) store \<Rightarrow> 'l set" where
  "LID\<^sub>S \<sigma> \<equiv> dom \<sigma> \<union> \<Union> (LID\<^sub>V ` ran \<sigma>)"

definition LID\<^sub>L :: "('r,'l,'v) local_state \<Rightarrow> 'l set" where
  "LID\<^sub>L s \<equiv> case s of (\<sigma>, \<tau>, e) \<Rightarrow> LID\<^sub>S \<sigma> \<union> LID\<^sub>S \<tau> \<union> LID\<^sub>E e"

definition LID\<^sub>G :: "('r,'l,'v) global_state \<Rightarrow> 'l set" where
  "LID\<^sub>G s \<equiv> \<Union> (LID\<^sub>L ` ran s)"

subsection \<open>Inference rules\<close>

subsubsection \<open>Introduction and elimination rules\<close>

lemma RID\<^sub>SI [intro]: "\<sigma> l = Some v \<Longrightarrow> r \<in> RID\<^sub>V v \<Longrightarrow> r \<in> RID\<^sub>S \<sigma>"
  by (auto simp add: RID\<^sub>S_def ran_def)

lemma RID\<^sub>SE [elim]: "r \<in> RID\<^sub>S \<sigma> \<Longrightarrow> (\<And>l v. \<sigma> l = Some v \<Longrightarrow> r \<in> RID\<^sub>V v \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp add: RID\<^sub>S_def ran_def)

lemma RID\<^sub>LI [intro, consumes 1]:
  assumes "s = (\<sigma>, \<tau>, e)"
  shows
    "r \<in> RID\<^sub>S \<sigma> \<Longrightarrow> r \<in> RID\<^sub>L s"
    "r \<in> RID\<^sub>S \<tau> \<Longrightarrow> r \<in> RID\<^sub>L s"
    "r \<in> RID\<^sub>E e \<Longrightarrow> r \<in> RID\<^sub>L s"
  by (auto simp add: RID\<^sub>L_def assms)

lemma RID\<^sub>LE [elim]:
  "\<lbrakk> r \<in> RID\<^sub>L s; (\<And>\<sigma> \<tau> e. s = (\<sigma>, \<tau>, e) \<Longrightarrow> (r \<in> RID\<^sub>S \<sigma> \<Longrightarrow> P) \<Longrightarrow> (r \<in> RID\<^sub>S \<tau> \<Longrightarrow> P) \<Longrightarrow> (r \<in> RID\<^sub>E e \<Longrightarrow> P) \<Longrightarrow> P) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (cases s) (auto simp add: RID\<^sub>L_def)

lemma RID\<^sub>GI [intro]:
  "s r = Some v \<Longrightarrow> r \<in> RID\<^sub>G s"
  "s r' = Some ls \<Longrightarrow> r \<in> RID\<^sub>L ls \<Longrightarrow> r \<in> RID\<^sub>G s"
   apply (simp add: RID\<^sub>G_def domI)
  by (metis (no_types, lifting) RID\<^sub>G_def UN_I UnI2 ranI)

lemma RID\<^sub>GE [elim]:
  assumes
    "r \<in> RID\<^sub>G s"
    "r \<in> dom s \<Longrightarrow> P"
    "\<And>r' ls. s r' = Some ls \<Longrightarrow> r \<in> RID\<^sub>L ls \<Longrightarrow> P"
  shows P
  using assms by (auto simp add: RID\<^sub>G_def ran_def)

lemma LID\<^sub>SI [intro]:
  "\<sigma> l = Some v \<Longrightarrow> l \<in> LID\<^sub>S \<sigma>"
  "\<sigma> l' = Some v \<Longrightarrow> l \<in> LID\<^sub>V v \<Longrightarrow> l \<in> LID\<^sub>S \<sigma>"
  by (auto simp add: LID\<^sub>S_def ran_def)

lemma LID\<^sub>SE [elim]:
  assumes
    "l \<in> LID\<^sub>S \<sigma>"
    "l \<in> dom \<sigma> \<Longrightarrow> P"
    "\<And>l' v. \<sigma> l' = Some v \<Longrightarrow> l \<in> LID\<^sub>V v \<Longrightarrow> P"
  shows P
  using assms by (auto simp add: LID\<^sub>S_def ran_def)

lemma LID\<^sub>LI [intro]:
  assumes "s = (\<sigma>, \<tau>, e)"
  shows
    "r \<in> LID\<^sub>S \<sigma> \<Longrightarrow> r \<in> LID\<^sub>L s"
    "r \<in> LID\<^sub>S \<tau> \<Longrightarrow> r \<in> LID\<^sub>L s"
    "r \<in> LID\<^sub>E e \<Longrightarrow> r \<in> LID\<^sub>L s"
  by (auto simp add: LID\<^sub>L_def assms)

lemma LID\<^sub>LE [elim]:
  "\<lbrakk> l \<in> LID\<^sub>L s; (\<And>\<sigma> \<tau> e. s = (\<sigma>, \<tau>, e) \<Longrightarrow> (l \<in> LID\<^sub>S \<sigma> \<Longrightarrow> P) \<Longrightarrow> (l \<in> LID\<^sub>S \<tau> \<Longrightarrow> P) \<Longrightarrow> (l \<in> LID\<^sub>E e \<Longrightarrow> P) \<Longrightarrow> P) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (cases s) (auto simp add: LID\<^sub>L_def)

lemma LID\<^sub>GI [intro]: "s r = Some ls \<Longrightarrow> l \<in> LID\<^sub>L ls \<Longrightarrow> l \<in> LID\<^sub>G s"
  by (auto simp add: LID\<^sub>G_def LID\<^sub>L_def ran_def)

lemma LID\<^sub>GE [elim]: "l \<in> LID\<^sub>G s \<Longrightarrow> (\<And>r ls. s r = Some ls \<Longrightarrow> l \<in> LID\<^sub>L ls \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp add: LID\<^sub>G_def ran_def)

subsubsection \<open>Distributive laws\<close>

lemma ID_distr_completion [simp]:
  "RID\<^sub>E (\<E>[e]) = RID\<^sub>C \<E> \<union> RID\<^sub>E e"
  "LID\<^sub>E (\<E>[e]) = LID\<^sub>C \<E> \<union> LID\<^sub>E e"
  by (induct rule: plug.induct) auto

lemma ID_restricted_store_subset_store:
  "RID\<^sub>S (\<sigma>(l := None)) \<subseteq> RID\<^sub>S \<sigma>"
  "LID\<^sub>S (\<sigma>(l := None)) \<subseteq> LID\<^sub>S \<sigma>"
proof -
  show "RID\<^sub>S (\<sigma>(l := None)) \<subseteq> RID\<^sub>S \<sigma>"
  proof (rule subsetI)
    fix r
    assume "r \<in> RID\<^sub>S (\<sigma>(l := None))"
    then obtain l' v where "(\<sigma>(l := None)) l' = Some v" and r_v: "r \<in> RID\<^sub>V v" by blast
    have "l' \<noteq> l" using \<open>(\<sigma>(l := None)) l' = Some v\<close> by auto
    hence "\<sigma> l' = Some v" using \<open>(\<sigma>(l := None)) l' = Some v\<close> by auto
    thus "r \<in> RID\<^sub>S \<sigma>" using r_v by blast
  qed
next
  show "LID\<^sub>S (\<sigma>(l := None)) \<subseteq> LID\<^sub>S \<sigma>"
  proof (rule subsetI)
    fix l'
    assume "l' \<in> LID\<^sub>S (\<sigma>(l := None))"
    hence "l' \<in> dom (\<sigma>(l := None)) \<or> (\<exists>l'' v. (\<sigma>(l := None)) l'' = Some v \<and> l' \<in> LID\<^sub>V v)" by blast
    thus "l' \<in> LID\<^sub>S \<sigma>"
    proof (rule disjE)
      assume "l' \<in> dom (\<sigma>(l := None))"
      thus "l' \<in> LID\<^sub>S \<sigma>" by auto
    next
      assume "\<exists>l'' v. (\<sigma>(l := None)) l'' = Some v \<and> l' \<in> LID\<^sub>V v"
      then obtain l'' v where "(\<sigma>(l := None)) l'' = Some v" and l'_in_v: "l' \<in> LID\<^sub>V v" by blast
      hence "\<sigma> l'' = Some v" by (cases "l = l''", auto)
      thus "l' \<in> LID\<^sub>S \<sigma>" using l'_in_v by blast
    qed
  qed
qed

lemma in_restricted_store_in_unrestricted_store [intro]:
  "r \<in> RID\<^sub>S (\<sigma>(l := None)) \<Longrightarrow> r \<in> RID\<^sub>S \<sigma>"
  "l' \<in> LID\<^sub>S (\<sigma>(l := None)) \<Longrightarrow> l' \<in> LID\<^sub>S \<sigma>"
  by (meson contra_subsetD ID_restricted_store_subset_store)+

lemma in_restricted_store_in_updated_store [intro]:
  "r \<in> RID\<^sub>S (\<sigma>(l := None)) \<Longrightarrow> r \<in> RID\<^sub>S (\<sigma>(l \<mapsto> v))"
  "l' \<in> LID\<^sub>S (\<sigma>(l := None)) \<Longrightarrow> l' \<in> LID\<^sub>S (\<sigma>(l \<mapsto> v))"
proof -
  assume "r \<in> RID\<^sub>S (\<sigma>(l := None))"
  hence "r \<in> RID\<^sub>S (\<sigma> |` (- {l}))" by (simp add: restrict_complement_singleton_eq)
  hence "r \<in> RID\<^sub>S (\<sigma>(l \<mapsto> v) |` (- {l}))" by simp
  hence "r \<in> RID\<^sub>S (\<sigma>(l := Some v, l := None))" by (simp add: restrict_complement_singleton_eq)
  thus "r \<in> RID\<^sub>S (\<sigma>(l \<mapsto> v))" by blast
next
  assume "l' \<in> LID\<^sub>S (\<sigma>(l := None))"
  hence "l' \<in> LID\<^sub>S (\<sigma> |` (- {l}))" by (simp add: restrict_complement_singleton_eq)
  hence "l' \<in> LID\<^sub>S (\<sigma>(l \<mapsto> v) |` (- {l}))" by simp
  hence "l' \<in> LID\<^sub>S (\<sigma>(l := Some v, l := None))" by (simp add: restrict_complement_singleton_eq)
  thus "l' \<in> LID\<^sub>S (\<sigma>(l \<mapsto> v))" by blast
qed

lemma ID_distr_store [simp]:
  "RID\<^sub>S (\<tau>(l \<mapsto> v)) = RID\<^sub>S (\<tau>(l := None)) \<union> RID\<^sub>V v"
  "LID\<^sub>S (\<tau>(l \<mapsto> v)) = insert l (LID\<^sub>S (\<tau>(l := None)) \<union> LID\<^sub>V v)"
proof -
  show "RID\<^sub>S (\<tau>(l \<mapsto> v)) = RID\<^sub>S (\<tau>(l := None)) \<union> RID\<^sub>V v"
  proof (rule set_eqI, rule iffI)
    fix r
    assume "r \<in> RID\<^sub>S (\<tau>(l \<mapsto> v))"
    then obtain l' v' where "(\<tau>(l \<mapsto> v)) l' = Some v'" "r \<in> RID\<^sub>V v'" by blast
    thus "r \<in> RID\<^sub>S (\<tau>(l := None)) \<union> RID\<^sub>V v" by (cases "l' = l") auto
  qed auto
next
  show "LID\<^sub>S (\<tau>(l \<mapsto> v)) = insert l (LID\<^sub>S (\<tau>(l := None)) \<union> LID\<^sub>V v)"
  proof (rule set_eqI, rule iffI)
    fix l'
    assume "l' \<in> LID\<^sub>S (\<tau>(l \<mapsto> v))"
    hence "l' \<in> dom (\<tau>(l \<mapsto> v)) \<or> (\<exists>l'' v'. (\<tau>(l \<mapsto> v)) l'' = Some v' \<and> l' \<in> LID\<^sub>V v')" by blast
    thus "l' \<in> insert l (LID\<^sub>S (\<tau>(l := None)) \<union> LID\<^sub>V v)"
    proof (rule disjE)
      assume "l' \<in> dom (\<tau>(l \<mapsto> v))"
      thus "l' \<in> insert l (LID\<^sub>S (\<tau>(l := None)) \<union> LID\<^sub>V v)" by (cases "l' = l") auto
    next
      assume "\<exists>l'' v'. (\<tau>(l \<mapsto> v)) l'' = Some v' \<and> l' \<in> LID\<^sub>V v'"
      then obtain l'' v' where "(\<tau>(l \<mapsto> v)) l'' = Some v'" "l' \<in> LID\<^sub>V v'" by blast
      thus "l' \<in> insert l (LID\<^sub>S (\<tau>(l := None)) \<union> LID\<^sub>V v)" by (cases "l = l''") auto
    qed
  qed auto
qed

lemma ID_distr_local [simp]:
  "LID\<^sub>L (\<sigma>,\<tau>,e) = LID\<^sub>S \<sigma> \<union> LID\<^sub>S \<tau> \<union> LID\<^sub>E e"
  "RID\<^sub>L (\<sigma>,\<tau>,e) = RID\<^sub>S \<sigma> \<union> RID\<^sub>S \<tau> \<union> RID\<^sub>E e"
  by (simp add: LID\<^sub>L_def RID\<^sub>L_def)+

lemma ID_restricted_global_subset_unrestricted:
  "LID\<^sub>G (s(r := None)) \<subseteq> LID\<^sub>G s"
  "RID\<^sub>G (s(r := None)) \<subseteq> RID\<^sub>G s"
proof -
  show "LID\<^sub>G (s(r := None)) \<subseteq> LID\<^sub>G s"
  proof (rule subsetI)
    fix l
    assume "l \<in> LID\<^sub>G (s(r := None))"
    then obtain r'' ls where "(s(r := None)) r'' = Some ls" and l_in_ls: "l \<in> LID\<^sub>L ls" by blast
    have "r'' \<noteq> r " using \<open>(s(r := None)) r'' = Some ls\<close> by auto
    hence "s r'' = Some ls" using \<open>(s(r := None)) r'' = Some ls\<close> by auto
    thus "l \<in> LID\<^sub>G s" using l_in_ls by blast
  qed
next
  show "RID\<^sub>G (s(r := None)) \<subseteq> RID\<^sub>G s"
  proof (rule subsetI)
    fix r'
    assume "r' \<in> RID\<^sub>G (s(r := None))"
    hence "r' \<in> dom (s(r := None)) \<or> (\<exists>r'' ls. (s(r := None)) r'' = Some ls \<and> r' \<in> RID\<^sub>L ls)" by blast
    thus "r' \<in> RID\<^sub>G s"
    proof (rule disjE)
      assume "\<exists>r'' ls. (s(r := None)) r'' = Some ls \<and> r' \<in> RID\<^sub>L ls"
      then obtain r'' ls where "(s(r := None)) r'' = Some ls" and r'_in_ls: "r' \<in> RID\<^sub>L ls" by blast
      have neq: "r'' \<noteq> r" using \<open>(s(r := None)) r'' = Some ls\<close> by auto
      hence "s r'' = Some ls" using \<open>(s(r := None)) r'' = Some ls\<close> by auto
      thus "r' \<in> RID\<^sub>G s" using r'_in_ls by blast
    qed auto
  qed
qed

lemma in_restricted_global_in_unrestricted_global [intro]:
  "r' \<in> RID\<^sub>G (s(r := None)) \<Longrightarrow> r' \<in> RID\<^sub>G s"
  "l \<in> LID\<^sub>G (s(r := None)) \<Longrightarrow> l \<in> LID\<^sub>G s"
  by (simp add: ID_restricted_global_subset_unrestricted rev_subsetD)+

lemma in_restricted_global_in_updated_global [intro]:
  "r' \<in> RID\<^sub>G (s(r := None)) \<Longrightarrow> r' \<in> RID\<^sub>G (s(r \<mapsto> ls))"
  "l \<in> LID\<^sub>G (s(r := None)) \<Longrightarrow> l \<in> LID\<^sub>G (s(r \<mapsto> ls))"
proof -
  assume "r' \<in> RID\<^sub>G (s(r := None))"
  hence "r' \<in> RID\<^sub>G (s |` (- {r}))" by (simp add: restrict_complement_singleton_eq)
  hence "r' \<in> RID\<^sub>G (s(r \<mapsto> ls) |` (- {r}))" by simp
  hence "r' \<in> RID\<^sub>G (s(r := Some ls, r := None))" by (simp add: restrict_complement_singleton_eq)
  thus "r' \<in> RID\<^sub>G (s(r \<mapsto> ls))" by blast
next
  assume "l \<in> LID\<^sub>G (s(r := None))"
  hence "l \<in> LID\<^sub>G (s |` (- {r}))" by (simp add: restrict_complement_singleton_eq)
  hence "l \<in> LID\<^sub>G (s(r \<mapsto> ls) |` (- {r}))" by simp
  hence "l \<in> LID\<^sub>G (s(r := Some ls, r := None))" by (simp add: restrict_complement_singleton_eq)
  thus "l \<in> LID\<^sub>G (s(r \<mapsto> ls))" by blast
qed

lemma ID_distr_global [simp]:
  "RID\<^sub>G (s(r \<mapsto> ls)) = insert r (RID\<^sub>G (s(r := None)) \<union> RID\<^sub>L ls)"
  "LID\<^sub>G (s(r \<mapsto> ls)) = LID\<^sub>G (s(r := None)) \<union> LID\<^sub>L ls"
proof -
  show "LID\<^sub>G (s(r \<mapsto> ls)) = LID\<^sub>G (s(r := None)) \<union> LID\<^sub>L ls"
  proof (rule set_eqI)
    fix l
    show "(l \<in> LID\<^sub>G (s(r \<mapsto> ls))) = (l \<in> LID\<^sub>G (s(r := None)) \<union> LID\<^sub>L ls)"
    proof (rule iffI)
      assume "l \<in> LID\<^sub>G (s(r \<mapsto> ls))"
      from this obtain r' ls' where "(s(r \<mapsto> ls)) r' = Some ls'" "l \<in> LID\<^sub>L ls'" by auto
      thus "l \<in> LID\<^sub>G (s(r := None)) \<union> LID\<^sub>L ls" by (cases "r = r'") auto
    qed auto
  qed
  show "RID\<^sub>G (s(r \<mapsto> ls)) = insert r (RID\<^sub>G (s(r := None)) \<union> RID\<^sub>L ls)"
  proof (rule set_eqI)
    fix r'
    show "(r' \<in> RID\<^sub>G (s(r \<mapsto> ls))) = (r' \<in> insert r (RID\<^sub>G (s(r := None)) \<union> RID\<^sub>L ls))"
    proof (rule iffI, clarsimp)
      assume r'_g: "r' \<in> RID\<^sub>G (s(r \<mapsto> ls))" and neq: "r' \<noteq> r" and r'_l: "r' \<notin> RID\<^sub>L ls"
      show "r' \<in> RID\<^sub>G (s(r := None))"
      proof (rule RID\<^sub>GE[OF r'_g])
        assume "r' \<in> dom (s(r \<mapsto> ls))"
        thus ?thesis by (simp add: RID\<^sub>G_def neq)
      next
        fix ls' r''
        assume r'_in_range:"(s(r \<mapsto> ls)) r'' = Some ls'" "r' \<in> RID\<^sub>L ls'"
        thus ?thesis by (cases "r'' = r") (use neq r'_l in auto)
      qed
    qed auto
  qed
qed

lemma restrictions_inwards [simp]:
  "x \<noteq> x' \<Longrightarrow> f(x := Some y, x' := None) = (f(x':= None, x := Some y))"
  by (rule fun_upd_twist)

subsubsection \<open>Miscellaneous laws\<close>

lemma ID_combination_subset_union [intro]:
  "RID\<^sub>S (\<sigma>;;\<tau>) \<subseteq> RID\<^sub>S \<sigma> \<union> RID\<^sub>S \<tau>"
  "LID\<^sub>S (\<sigma>;;\<tau>) \<subseteq> LID\<^sub>S \<sigma> \<union> LID\<^sub>S \<tau>"
proof -
  show "RID\<^sub>S (\<sigma>;;\<tau>) \<subseteq> RID\<^sub>S \<sigma> \<union> RID\<^sub>S \<tau>"
  proof (rule subsetI)
    fix r
    assume "r \<in> RID\<^sub>S (\<sigma>;;\<tau>)"
    from this obtain l v where "(\<sigma>;;\<tau>) l = Some v" and "r \<in> RID\<^sub>V v" by blast
    thus "r \<in> RID\<^sub>S \<sigma> \<union> RID\<^sub>S \<tau>" by (cases "l \<in> dom \<tau>") auto
  qed
  show "LID\<^sub>S (\<sigma>;;\<tau>) \<subseteq> LID\<^sub>S \<sigma> \<union> LID\<^sub>S \<tau>"
  proof (rule subsetI)
    fix l
    assume "l \<in> LID\<^sub>S (\<sigma>;;\<tau>)"
    hence "l \<in> dom (\<sigma>;;\<tau>) \<or> (\<exists>l' v. (\<sigma>;;\<tau>) l' = Some v \<and> l \<in> LID\<^sub>V v)" by blast
    thus "l \<in> LID\<^sub>S \<sigma> \<union> LID\<^sub>S \<tau>"
    proof (rule disjE)
      assume "l \<in> dom (\<sigma>;;\<tau>)"
      thus "l \<in> LID\<^sub>S \<sigma> \<union> LID\<^sub>S \<tau>" by (cases "l \<in> dom \<tau>") auto
    next
      assume "\<exists>l' v. (\<sigma>;;\<tau>) l' = Some v \<and> l \<in> LID\<^sub>V v"
      from this obtain l' v where "(\<sigma>;;\<tau>) l' = Some v" "l \<in> LID\<^sub>V v" by blast
      thus "l \<in> LID\<^sub>S \<sigma> \<union> LID\<^sub>S \<tau>" by (cases "l' \<in> dom \<tau>") auto
    qed
  qed
qed

lemma in_combination_in_component [intro]:
  "r \<in> RID\<^sub>S (\<sigma>;;\<tau>) \<Longrightarrow> r \<notin> RID\<^sub>S \<sigma> \<Longrightarrow> r \<in> RID\<^sub>S \<tau>"
  "r \<in> RID\<^sub>S (\<sigma>;;\<tau>) \<Longrightarrow> r \<notin> RID\<^sub>S \<tau> \<Longrightarrow> r \<in> RID\<^sub>S \<sigma>"
  "l \<in> LID\<^sub>S (\<sigma>;;\<tau>) \<Longrightarrow> l \<notin> LID\<^sub>S \<sigma> \<Longrightarrow> l \<in> LID\<^sub>S \<tau>"
  "l \<in> LID\<^sub>S (\<sigma>;;\<tau>) \<Longrightarrow> l \<notin> LID\<^sub>S \<tau> \<Longrightarrow> l \<in> LID\<^sub>S \<sigma>"
  by (meson Un_iff ID_combination_subset_union subsetCE)+

lemma in_mapped_in_component_of_combination [intro]:
  assumes
    maps_to_v: "(\<sigma>;;\<tau>) l = Some v" and
    l'_in_v: "l' \<in> LID\<^sub>V v"
  shows
    "l' \<notin> LID\<^sub>S \<tau> \<Longrightarrow> l' \<in> LID\<^sub>S \<sigma>"
    "l' \<notin> LID\<^sub>S \<sigma> \<Longrightarrow> l' \<in> LID\<^sub>S \<tau>"
  by (metis LID\<^sub>SI(2) combine.simps l'_in_v maps_to_v)+

lemma elim_trivial_restriction [simp]: "l \<notin> LID\<^sub>S \<tau> \<Longrightarrow> (\<tau>(l := None)) = \<tau>"
  by (simp add: LID\<^sub>S_def domIff fun_upd_idem)

lemma ID_distr_global_conditional:
  "s r = Some ls \<Longrightarrow> RID\<^sub>G s = insert r (RID\<^sub>G (s(r := None)) \<union> RID\<^sub>L ls)"
  "s r = Some ls \<Longrightarrow> LID\<^sub>G s = LID\<^sub>G (s(r := None)) \<union> LID\<^sub>L ls"
proof -
  assume "s r = Some ls"
  hence s_as_upd: "s = (s(r \<mapsto> ls))" by (simp add: fun_upd_idem)
  show "RID\<^sub>G s = insert r (RID\<^sub>G (s(r := None)) \<union> RID\<^sub>L ls)" by (subst s_as_upd, simp)
  show "LID\<^sub>G s = LID\<^sub>G (s(r := None)) \<union> LID\<^sub>L ls" by (subst s_as_upd, simp)
qed

end


(*****************************************************************************
 * Clean
 *
 * HOL-TestGen --- theorem-prover based test case generation
 *                 http://www.brucker.ch/projects/hol-testgen/
 *
 * Copyright (c) 2005-2007 ETH Zurich, Switzerland
 *               2009-2017 Univ. Paris-Sud, France
 *               2009-2012 Achim D. Brucker, Germany
 *               2015-2017 University Sheffield, UK
 *               2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

(*
 * Monads --- a base testing theory for sequential computations.
 * This file is part of HOL-TestGen.
 *)

theory MonadSE
  imports Main
begin

section\<open>Definition : Standard State Exception Monads\<close>
text\<open>State exception monads in our sense are a direct, pure formulation
of automata with a partial transition function.\<close>

subsection\<open>Definition : Core Types and Operators\<close>

type_synonym ('o, '\<sigma>) MON\<^sub>S\<^sub>E = "'\<sigma> \<rightharpoonup> ('o \<times> '\<sigma>)" (* = '\<sigma> \<Rightarrow> ('o \<times> '\<sigma>)option *)

definition bind_SE :: "('o,'\<sigma>)MON\<^sub>S\<^sub>E \<Rightarrow> ('o \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>E) \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>E"
where     "bind_SE f g = (\<lambda>\<sigma>. case f \<sigma> of None \<Rightarrow> None
                                        | Some (out, \<sigma>') \<Rightarrow> g out \<sigma>')"

notation bind_SE ("bind\<^sub>S\<^sub>E")

syntax    (xsymbols)
          "_bind_SE" :: "[pttrn,('o,'\<sigma>)MON\<^sub>S\<^sub>E,('o','\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>E"
          ("(2 _ \<leftarrow> _; _)" [5,8,8]8)
translations
          "x \<leftarrow> f; g" == "CONST bind_SE f (% x . g)"

definition unit_SE :: "'o \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>E"   ("(result _)" 8)
where     "unit_SE e = (\<lambda>\<sigma>. Some(e,\<sigma>))"
notation   unit_SE ("unit\<^sub>S\<^sub>E")

text\<open>In the following, we prove the required Monad-laws\<close>

lemma bind_right_unit[simp]: "(x \<leftarrow> m; result x) = m"
  apply (simp add:  unit_SE_def bind_SE_def)
  apply (rule ext)
  apply (case_tac "m \<sigma>", simp_all)
  done

lemma bind_left_unit [simp]: "(x \<leftarrow> result c; P x) = P c"
  by (simp add: unit_SE_def bind_SE_def)

lemma bind_assoc[simp]: "(y \<leftarrow> (x \<leftarrow> m; k x); h y) = (x \<leftarrow> m; (y \<leftarrow> k x; h y))"
  apply (simp add: unit_SE_def bind_SE_def, rule ext)
  apply (case_tac "m \<sigma>", simp_all)
  apply (case_tac "a", simp_all)
  done

subsection\<open>Definition : More Operators and their Properties\<close>

definition fail_SE :: "('o, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "fail_SE = (\<lambda>\<sigma>. None)"
notation   fail_SE ("fail\<^sub>S\<^sub>E")

definition assert_SE :: "('\<sigma> \<Rightarrow> bool) \<Rightarrow> (bool, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "assert_SE P = (\<lambda>\<sigma>. if P \<sigma> then Some(True,\<sigma>) else None)"
notation   assert_SE ("assert\<^sub>S\<^sub>E")

definition assume_SE :: "('\<sigma> \<Rightarrow> bool) \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "assume_SE P = (\<lambda>\<sigma>. if \<exists>\<sigma> . P \<sigma> then Some((), SOME \<sigma> . P \<sigma>) else None)"
notation   assume_SE ("assume\<^sub>S\<^sub>E")

lemma bind_left_fail_SE[simp] : "(x \<leftarrow> fail\<^sub>S\<^sub>E; P x) = fail\<^sub>S\<^sub>E"
  by (simp add: fail_SE_def bind_SE_def)

text\<open>We also provide a "Pipe-free" - variant of the bind operator.
Just a "standard" programming sequential operator without output frills.\<close>
(* TODO: Eliminate/Modify this. Is a consequence of the Monad-Instantiation. *)

definition bind_SE' :: "('\<alpha>, '\<sigma>)MON\<^sub>S\<^sub>E \<Rightarrow> ('\<beta>, '\<sigma>)MON\<^sub>S\<^sub>E \<Rightarrow> ('\<beta>, '\<sigma>)MON\<^sub>S\<^sub>E" (infixr ";-" 60)
where     "f ;- g = (_ \<leftarrow> f ; g)"

lemma bind_assoc'[simp]: "((m;- k);- h ) = (m;- (k;- h))"
by(simp add:bind_SE'_def)

lemma bind_left_unit' [simp]: "((result c);- P) = P"
  by (simp add:  bind_SE'_def)

lemma bind_left_fail_SE'[simp]: "(fail\<^sub>S\<^sub>E;- P) = fail\<^sub>S\<^sub>E"
  by (simp add: bind_SE'_def)

lemma bind_right_unit'[simp]: "(m;- (result ())) = m"
  by (simp add:  bind_SE'_def)

text\<open>The bind-operator in the state-exception monad yields already
       a semantics for the concept of an input sequence on the meta-level:\<close>
lemma     syntax_test: "(o1 \<leftarrow> f1 ; o2 \<leftarrow> f2; result (post o1 o2)) = X"
oops

definition yield\<^sub>C :: "('a  \<Rightarrow> 'b) \<Rightarrow>  ('b,'a ) MON\<^sub>S\<^sub>E"
    where "yield\<^sub>C f \<equiv> (\<lambda>\<sigma>. Some(f \<sigma>, \<sigma>))"

definition try_SE :: "('o,'\<sigma>) MON\<^sub>S\<^sub>E \<Rightarrow> ('o option,'\<sigma>) MON\<^sub>S\<^sub>E" ("try\<^sub>S\<^sub>E")
where     "try\<^sub>S\<^sub>E ioprog = (\<lambda>\<sigma>. case ioprog \<sigma> of
                                      None \<Rightarrow> Some(None, \<sigma>)
                                    | Some(outs, \<sigma>') \<Rightarrow> Some(Some outs, \<sigma>'))"
text\<open>In contrast, mbind as a failure safe operator can roughly be seen
       as a foldr on bind - try:
       m1 ; try m2 ; try m3; ... Note, that the rough equivalence only holds for
       certain predicates in the sequence - length equivalence modulo None,
       for example. However, if a conditional is added, the equivalence
       can be made precise:\<close>

text\<open>On this basis, a symbolic evaluation scheme can be established
  that reduces mbind-code to try\_SE\_code and ite-cascades.\<close>

definition alt_SE :: "[('o, '\<sigma>)MON\<^sub>S\<^sub>E, ('o, '\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>E"   (infixl "\<sqinter>\<^sub>S\<^sub>E" 10)
where     "(f \<sqinter>\<^sub>S\<^sub>E g) = (\<lambda> \<sigma>. case f \<sigma> of None \<Rightarrow> g \<sigma>
                                      | Some H \<Rightarrow> Some H)"

definition malt_SE :: "('o, '\<sigma>)MON\<^sub>S\<^sub>E list \<Rightarrow> ('o, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "malt_SE S = foldr alt_SE S fail\<^sub>S\<^sub>E"
notation   malt_SE ("\<Sqinter>\<^sub>S\<^sub>E")

lemma malt_SE_mt [simp]: "\<Sqinter>\<^sub>S\<^sub>E [] = fail\<^sub>S\<^sub>E"
by(simp add: malt_SE_def)

lemma malt_SE_cons [simp]: "\<Sqinter>\<^sub>S\<^sub>E (a # S) = (a \<sqinter>\<^sub>S\<^sub>E (\<Sqinter>\<^sub>S\<^sub>E S))"
by(simp add: malt_SE_def)

subsection\<open>Definition : Programming Operators and their Properties\<close>

definition  "skip\<^sub>S\<^sub>E = unit\<^sub>S\<^sub>E ()"

definition if_SE :: "['\<sigma> \<Rightarrow> bool, ('\<alpha>, '\<sigma>)MON\<^sub>S\<^sub>E, ('\<alpha>, '\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('\<alpha>, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "if_SE c E F = (\<lambda>\<sigma>. if c \<sigma> then E \<sigma> else F \<sigma>)"

syntax    (xsymbols)
          "_if_SE" :: "['\<sigma> \<Rightarrow> bool,('o,'\<sigma>)MON\<^sub>S\<^sub>E,('o','\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('o','\<sigma>)MON\<^sub>S\<^sub>E"
          ("(if\<^sub>S\<^sub>E _ then _ else _fi)" [5,8,8]8)
translations
          "(if\<^sub>S\<^sub>E cond then T1 else T2 fi)" == "CONST if_SE cond T1 T2"

subsection\<open>Theory of a Monadic While\<close>

text\<open>Prerequisites\<close>
fun replicator :: "[('a, '\<sigma>)MON\<^sub>S\<^sub>E, nat] \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>E" (infixr "^^^" 60)
where     "f ^^^ 0      = (result ())"
        | "f ^^^ (Suc n) = (f ;- f ^^^  n)"

fun replicator2 :: "[('a, '\<sigma>)MON\<^sub>S\<^sub>E, nat, ('b, '\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> ('b, '\<sigma>)MON\<^sub>S\<^sub>E" (infixr "^:^" 60)
where     "(f ^:^ 0) M      = (M )"
        | "(f ^:^ (Suc n)) M = (f ;- ((f ^:^  n) M))"

text\<open>First Step : Establishing an embedding between partial functions and relations\<close>
(* plongement *)
definition Mon2Rel :: "(unit, '\<sigma>)MON\<^sub>S\<^sub>E \<Rightarrow> ('\<sigma> \<times> '\<sigma>) set"
where "Mon2Rel f = {(x, y). (f x = Some((), y))}"
(* ressortir *)
definition Rel2Mon :: " ('\<sigma> \<times> '\<sigma>) set \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>E "
where "Rel2Mon S = (\<lambda> \<sigma>. if \<exists>\<sigma>'. (\<sigma>, \<sigma>') \<in> S then Some((), SOME \<sigma>'. (\<sigma>, \<sigma>') \<in> S) else None)"

lemma Mon2Rel_Rel2Mon_id: assumes det:"single_valued R" shows "(Mon2Rel \<circ> Rel2Mon) R = R"
apply (simp add: comp_def Mon2Rel_def Rel2Mon_def,auto)
apply (case_tac "\<exists>\<sigma>'. (a, \<sigma>') \<in> R", auto)
apply (subst (2) some_eq_ex)
using det[simplified single_valued_def] by auto

lemma Rel2Mon_Id: "(Rel2Mon \<circ> Mon2Rel) x = x"
apply (rule ext)
apply (auto simp: comp_def Mon2Rel_def Rel2Mon_def)
apply (erule contrapos_pp, drule HOL.not_sym, simp)
done

lemma single_valued_Mon2Rel: "single_valued (Mon2Rel B)"
by (auto simp: single_valued_def Mon2Rel_def)

text\<open>Second Step : Proving an induction principle allowing to establish that lfp remains
       deterministic\<close>

(* A little complete partial order theory due to Tobias Nipkow *)
definition chain :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool"
where     "chain S = (\<forall>i. S i \<subseteq> S(Suc i))"

lemma chain_total: "chain S ==> S i \<le> S j \<or> S j \<le> S i"
by (metis chain_def le_cases lift_Suc_mono_le)

definition cont :: "('a set => 'b set) => bool"
where     "cont f = (\<forall>S. chain S \<longrightarrow> f(UN n. S n) = (UN n. f(S n)))"

lemma mono_if_cont: fixes f :: "'a set \<Rightarrow> 'b set"
  assumes "cont f" shows "mono f"
proof
  fix a b :: "'a set" assume "a \<subseteq> b"
  let ?S = "\<lambda>n::nat. if n=0 then a else b"
  have "chain ?S" using \<open>a \<subseteq> b\<close> by(auto simp: chain_def)
  hence "f(UN n. ?S n) = (UN n. f(?S n))"
    using assms by (metis cont_def)
  moreover have "(UN n. ?S n) = b" using \<open>a \<subseteq> b\<close> by (auto split: if_splits)
  moreover have "(UN n. f(?S n)) = f a \<union> f b" by (auto split: if_splits)
  ultimately show "f a \<subseteq> f b" by (metis Un_upper1)
qed

lemma chain_iterates: fixes f :: "'a set \<Rightarrow> 'a set"
  assumes "mono f" shows "chain(\<lambda>n. (f^^n) {})"
proof-
  { fix n have "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" using assms
    by(induction n) (auto simp: mono_def) }
  thus ?thesis by(auto simp: chain_def)
qed

theorem lfp_if_cont:
  assumes "cont f" shows "lfp f =  (\<Union>n. (f ^^ n) {})" (is "_ = ?U")
proof
  show "lfp f \<subseteq> ?U"
  proof (rule lfp_lowerbound)
    have "f ?U = (UN n. (f^^Suc n){})"
      using chain_iterates[OF mono_if_cont[OF assms]] assms
      by(simp add: cont_def)
    also have "\<dots> = (f^^0){} \<union> \<dots>" by simp
    also have "\<dots> = ?U"
      apply(auto simp del: funpow.simps)
      by (metis empty_iff funpow_0 old.nat.exhaust)
    finally show "f ?U \<subseteq> ?U" by simp
  qed
next
  { fix n p assume "f p \<subseteq> p"
    have "(f^^n){} \<subseteq> p"
    proof(induction n)
      case 0 show ?case by simp
    next
      case Suc
      from monoD[OF mono_if_cont[OF assms] Suc] \<open>f p \<subseteq> p\<close>
      show ?case by simp
    qed
  }
  thus "?U \<subseteq> lfp f" by(auto simp: lfp_def)
qed

lemma single_valued_UN_chain:
  assumes "chain S" "(!!n. single_valued (S n))"
  shows "single_valued(UN n. S n)"
proof(auto simp: single_valued_def)
  fix m n x y z assume "(x, y) \<in> S m" "(x, z) \<in> S n"
  with chain_total[OF assms(1), of m n] assms(2)
  show "y = z" by (auto simp: single_valued_def)
qed

lemma single_valued_lfp:
fixes f :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
assumes "cont f" "\<And>r. single_valued r \<Longrightarrow> single_valued (f r)"
shows "single_valued(lfp f)"
unfolding lfp_if_cont[OF assms(1)]
proof(rule single_valued_UN_chain[OF chain_iterates[OF mono_if_cont[OF assms(1)]]])
  fix n show "single_valued ((f ^^ n) {})"
  by(induction n)(auto simp: assms(2))
qed

text\<open>Third Step: Definition of the Monadic While \<open> \<close>\<close>
definition \<Gamma> :: "['\<sigma> \<Rightarrow> bool,('\<sigma> \<times> '\<sigma>) set] \<Rightarrow> (('\<sigma> \<times> '\<sigma>) set \<Rightarrow> ('\<sigma> \<times> '\<sigma>) set)"
where     "\<Gamma> b cd = (\<lambda>cw. {(s,t). if b s then (s, t) \<in> cd O cw else s = t})"

definition while_SE :: "['\<sigma> \<Rightarrow> bool, (unit, '\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>E"
where     "while_SE c B \<equiv> (Rel2Mon(lfp(\<Gamma> c (Mon2Rel B))))"

syntax    (xsymbols)
          "_while_SE" :: "['\<sigma> \<Rightarrow> bool, (unit, '\<sigma>)MON\<^sub>S\<^sub>E] \<Rightarrow> (unit, '\<sigma>)MON\<^sub>S\<^sub>E"
          ("(while\<^sub>S\<^sub>E _ do _ od)" [8,8]8)
translations
          "while\<^sub>S\<^sub>E c do b od" == "CONST while_SE c b"

lemma cont_\<Gamma>: "cont (\<Gamma> c b)"
by (auto simp: cont_def \<Gamma>_def)

text\<open>The fixpoint theory now allows us to establish that the lfp constructed over
       @{term Mon2Rel} remains deterministic\<close>

theorem single_valued_lfp_Mon2Rel: "single_valued (lfp(\<Gamma> c (Mon2Rel B)))"
apply(rule single_valued_lfp, simp_all add: cont_\<Gamma>)
apply(auto simp: \<Gamma>_def single_valued_def)
apply(metis single_valued_Mon2Rel[of "B"] single_valued_def)
done

lemma Rel2Mon_if:
  "Rel2Mon {(s, t). if b s then (s, t) \<in> Mon2Rel c O lfp (\<Gamma> b (Mon2Rel c)) else s = t} \<sigma> =
  (if b \<sigma> then Rel2Mon (Mon2Rel c O lfp (\<Gamma> b (Mon2Rel c))) \<sigma> else Some ((), \<sigma>))"
by (simp add: Rel2Mon_def)

lemma Rel2Mon_homomorphism:
  assumes determ_X: "single_valued X" and determ_Y: "single_valued Y"
  shows   "Rel2Mon (X O Y) = (Rel2Mon X) ;- (Rel2Mon Y)"
proof -
    have relational_partial_next_in_O: "\<And>x E F. (\<exists>y. (x, y) \<in> (E O F)) \<Longrightarrow> (\<exists>y. (x, y) \<in> E)"
                        by (auto)
    have some_eq_intro: "\<And> X x y . single_valued X \<Longrightarrow> (x, y) \<in> X \<Longrightarrow> (SOME y. (x, y) \<in> X) = y"
                        by (auto simp: single_valued_def)

    show ?thesis
apply (simp add: Rel2Mon_def bind_SE'_def bind_SE_def)
apply (rule ext, rename_tac "\<sigma>")
apply (case_tac " \<exists> \<sigma>'. (\<sigma>, \<sigma>') \<in> X O Y")
apply (simp only: HOL.if_True)
apply (frule relational_partial_next_in_O)
apply (auto simp: single_valued_relcomp some_eq_intro determ_X determ_Y relcomp.relcompI)
by blast
qed

text\<open>Putting everything together, the theory of embedding and the invariance of
       determinism of the while-body, gives us the usual unfold-theorem:\<close>
theorem while_SE_unfold:
"(while\<^sub>S\<^sub>E b do c od) = (if\<^sub>S\<^sub>E b then (c ;- (while\<^sub>S\<^sub>E b do c od)) else result () fi)"
apply (simp add: if_SE_def bind_SE'_def while_SE_def unit_SE_def)
apply (subst lfp_unfold [OF mono_if_cont, OF cont_\<Gamma>])
apply (rule ext)
apply (subst \<Gamma>_def)
apply (auto simp: Rel2Mon_if Rel2Mon_homomorphism bind_SE'_def Rel2Mon_Id [simplified comp_def]
                  single_valued_Mon2Rel single_valued_lfp_Mon2Rel )
done

lemma bind_cong : " f \<sigma> = g \<sigma> \<Longrightarrow>  (x \<leftarrow> f ; M x)\<sigma> = (x \<leftarrow> g ; M x)\<sigma>"
  unfolding bind_SE'_def bind_SE_def  by simp

lemma bind'_cong : " f \<sigma> = g \<sigma> \<Longrightarrow>  (f ;- M )\<sigma> = (g ;- M )\<sigma>"
  unfolding bind_SE'_def bind_SE_def  by simp

lemma if\<^sub>S\<^sub>E_True [simp]: "(if\<^sub>S\<^sub>E (\<lambda> x. True) then c else d fi) = c"
  apply(rule ext) by (simp add: MonadSE.if_SE_def)

lemma if\<^sub>S\<^sub>E_False [simp]: "(if\<^sub>S\<^sub>E (\<lambda> x. False) then c else d fi) = d"
  apply(rule ext) by (simp add: MonadSE.if_SE_def)

lemma if\<^sub>S\<^sub>E_cond_cong : "f \<sigma> = g \<sigma> \<Longrightarrow>
                           (if\<^sub>S\<^sub>E f then c else d fi) \<sigma> =
                           (if\<^sub>S\<^sub>E g then c else d fi) \<sigma>"
  unfolding if_SE_def  by simp

lemma while\<^sub>S\<^sub>E_skip[simp] : "(while\<^sub>S\<^sub>E (\<lambda> x. False) do c od) = skip\<^sub>S\<^sub>E"
  apply(rule ext,subst MonadSE.while_SE_unfold)
  by (simp add: MonadSE.if_SE_def skip\<^sub>S\<^sub>E_def)

end


section \<open>The Optimized Observing Quorums Model\<close>

theory Observing_Quorums_Opt
imports Observing_Quorums
begin

subsection \<open>Model definition\<close>
(******************************************************************************)

record opt_obsv_state =
  next_round :: round
  decisions :: "(process, val)map"
  last_obs :: "(process, val)map"

context mono_quorum
begin

definition opt_obs_safe where
  "opt_obs_safe obs_f v \<equiv> \<exists>p. obs_f p \<in> {None, Some v}"

definition olv_round where
  "olv_round r S v r_decisions Ob \<equiv> {(s, s').
    \<comment> \<open>guards\<close>
    r = next_round s
    \<and> (S \<noteq> {} \<longrightarrow> opt_obs_safe (last_obs s) v)
    \<and> (S \<in> Quorum \<longrightarrow> Ob = UNIV)
    \<and> d_guard r_decisions (const_map v S)
    \<and> (Ob \<noteq> {} \<longrightarrow> S \<noteq> {})
    \<and> \<comment> \<open>actions\<close>
    s' = s\<lparr>
     next_round := Suc r
     , decisions := decisions s ++ r_decisions
     , last_obs := last_obs s ++ const_map v Ob
   \<rparr>
  }"

definition olv_init where
  "olv_init = { \<lparr> next_round = 0, decisions = Map.empty, last_obs = Map.empty \<rparr> }"

definition olv_trans :: "(opt_obsv_state \<times> opt_obsv_state) set" where
  "olv_trans = (\<Union>r S v D Ob. olv_round r S v D Ob) \<union> Id"

definition olv_TS :: "opt_obsv_state TS" where
  "olv_TS = \<lparr> init = olv_init, trans = olv_trans \<rparr>"

lemmas olv_TS_defs = olv_TS_def olv_init_def olv_trans_def

subsection \<open>Refinement\<close>
(******************************************************************************)

definition olv_ref_rel where
  "olv_ref_rel \<equiv> {(sa, sc).
    next_round sc = v_state.next_round sa
    \<and> decisions sc = v_state.decisions sa
    \<and> last_obs sc = map_option snd o process_mru (obsv_state.obs sa)
  }"

lemma OV_inv2_finite_map_graph:
   "s \<in> OV_inv2 \<Longrightarrow> finite (map_graph (case_prod (obsv_state.obs s)))"
  apply(rule finite_dom_finite_map_graph)
  apply(rule finite_subset[where B="{0..< v_state.next_round s} \<times> UNIV"])
   apply(auto simp add: OV_inv2_def dom_def not_le[symmetric])
  done

lemma OV_inv2_finite_obs_set:
   "s \<in> OV_inv2 \<Longrightarrow> finite (vote_set (obsv_state.obs s) Q)"
   apply(drule OV_inv2_finite_map_graph)
   apply(clarsimp simp add: map_graph_def fun_graph_def vote_set_def)
   apply(erule finite_surj[where f="\<lambda>((r, a), v). (r, v)"])
   by(force simp add: image_def)

lemma olv_round_refines:
  "{olv_ref_rel \<inter> (OV_inv2 \<inter> OV_inv3 \<inter> OV_inv4) \<times> UNIV} obsv_round r S v D Ob, olv_round r S v D Ob {>olv_ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs)
  fix sa :: obsv_state and sc sc'
  assume
    ainv: "sa \<in> OV_inv2" "sa \<in> OV_inv3" "sa \<in> OV_inv4"
    and step: "(sc, sc') \<in> olv_round r S v D Ob"
    and R: "(sa, sc) \<in> olv_ref_rel"

  \<comment> \<open>Abstract guard.\<close>
  have "S \<noteq> {} \<longrightarrow> obs_safe (v_state.next_round sa) sa v"
  proof(rule impI, rule ccontr)
    assume S_nonempty: "S \<noteq> {}" and no_Q: "\<not> obs_safe (v_state.next_round sa) sa v"
    from no_Q obtain r_w w where
      r_w: "r_w < v_state.next_round sa"
      and all_obs: "\<forall>p. obsv_state.obs sa r_w p = Some w"
      and diff: "w \<noteq> v" using ainv(3)[THEN OV_inv4D]
      by(simp add: obs_safe_def)  (metis)
    from diff step R obtain p where
      p_w: "S \<noteq> {} \<longrightarrow> (map_option snd \<circ> process_mru (obsv_state.obs sa)) p \<noteq> Some w"
      by (simp add: opt_obs_safe_def quorum_for_def olv_round_def  olv_ref_rel_def)
       (metis option.distinct(1) option.sel snd_conv)
    from all_obs have nempty: "vote_set (obsv_state.obs sa) {p} \<noteq> {}"
      by(auto simp add:  vote_set_def)
    then obtain r_w' w' where w': "process_mru (obsv_state.obs sa) p = Some (r_w', w')"
      by (simp add: process_mru_def mru_of_set_def)
        (metis option_Max_by_def surj_pair)
    hence max: "(r_w', w') = Max_by fst (vote_set (obsv_state.obs sa) {p})"
      by(auto simp add: process_mru_def mru_of_set_def option_Max_by_def)
    hence w'_obs: "(r_w', w') \<in> vote_set (obsv_state.obs sa) {p}"
      using Max_by_in[OF OV_inv2_finite_obs_set[OF ainv(1), of "{p}"] nempty]
      by fastforce
    have "r_w \<le> r_w'" using all_obs
      apply -
      apply(rule Max_by_ge[OF OV_inv2_finite_obs_set[OF ainv(1), of "{p}"], of "(r_w, w)" fst,
                            simplified max[symmetric], simplified])
      apply(auto simp add: quorum_for_def vote_set_def)
      done
    moreover have "w' \<noteq> w" using p_w w' S_nonempty
      by(auto)
    ultimately have "r_w < r_w'" using all_obs w'_obs
      apply(elim le_neq_implies_less)
      apply(auto simp add: quorum_for_def vote_set_def)
      done
    thus False using ainv(2)[THEN OV_inv3D] w'_obs all_obs \<open>w' \<noteq> w\<close>
      by(fastforce simp add: vote_set_def obs_safe_def)
  qed

  \<comment> \<open>Action refinement.\<close>
  moreover have
    "(map_option snd \<circ> process_mru (obsv_state.obs sa)) ++ const_map v Ob =
      map_option snd \<circ> process_mru ((obsv_state.obs sa)(v_state.next_round sa := const_map v Ob))"
  proof-
    from \<open>sa \<in> OV_inv2\<close>[THEN OV_inv2D]
    have empty: "\<forall>r'\<ge>v_state.next_round sa. obsv_state.obs sa r' = Map.empty"
      by simp
    show ?thesis
      by(auto simp add: map_add_def const_map_def restrict_map_def process_mru_new_votes[OF empty])
  qed

  ultimately show "\<exists>sa'. (sa, sa') \<in> obsv_round r S v D Ob \<and> (sa', sc') \<in> olv_ref_rel"
    using R step
    by(clarsimp simp add: obsv_round_def olv_round_def olv_ref_rel_def)

qed

lemma OLV_Refines:
  "PO_refines (olv_ref_rel \<inter> (OV_inv2 \<inter> OV_inv3 \<inter> OV_inv4) \<times> UNIV) obsv_TS olv_TS"
proof(rule refine_using_invariants)
  show "init olv_TS \<subseteq> olv_ref_rel `` init obsv_TS"
    by(auto simp add: obsv_TS_defs olv_TS_defs olv_ref_rel_def process_mru_def mru_of_set_def
      vote_set_def option_Max_by_def intro!: ext)
next
  show
    "{olv_ref_rel \<inter> (OV_inv2 \<inter> OV_inv3 \<inter> OV_inv4) \<times> UNIV} TS.trans obsv_TS, TS.trans olv_TS {> olv_ref_rel}"
    by(auto simp add: PO_refines_def obsv_TS_defs olv_TS_defs
      intro!: olv_round_refines)
qed (auto intro: OV_inv2_inductive OV_inv3_inductive OV_inv4_inductive
  OV_inv2_inductive(1)[THEN subsetD] OV_inv3_inductive(1)[THEN subsetD]
  OV_inv4_inductive(1)[THEN subsetD])

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |              Februaru 2006                |
            |                 March 2007  (modified)    |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_sf_rest
imports FNF_F_sf_def
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)
(* Isabelle 2017: split_if --> if_split *)

declare if_split  [split del]

(*****************************************************************

         1. full sequentialization for Depth-restriction (P |. n)
         2.
         3.

 *****************************************************************)

(*============================================================*
 |                                                            |
 |                       Depth_rest                           |
 |                                                            |
 *============================================================*)

(*============================================================*
 |                         Pfun P1 P2                         |
 *============================================================*)

(*** relation ***)

inductive_set
  fsfF_Depth_rest_rel ::
  "(('p,'a) proc * nat * ('p,'a) proc) set"

where
fsfF_Depth_rest_rel_zero:
  "(P1, 0, SDIV) : fsfF_Depth_rest_rel"
|
fsfF_Depth_rest_rel_etc:
  "P1 ~: fsfF_proc
   ==> (P1, Suc n, P1 |. (Suc n)) : fsfF_Depth_rest_rel"
|
fsfF_Depth_rest_rel_int:
  "[| ALL c. if (c: sumset C1)
             then (Rf1 c, Suc m, SRf c) : fsfF_Depth_rest_rel
             else SRf c = DIV ;
      sumset C1 ~= {} ; ALL c: sumset C1. Rf1 c : fsfF_proc |]
   ==>
   ((!! :C1 .. Rf1), Suc m, !! c:C1 .. SRf c)
   : fsfF_Depth_rest_rel"
|
fsfF_Depth_rest_rel_step:
  "[| ALL a. if a:A1
             then (Pf1 a, n, SPf a) : fsfF_Depth_rest_rel
             else SPf a = DIV ;
      ALL a:A1. Pf1 a : fsfF_proc ;
      Q1 = SKIP | Q1 = DIV | Q1 = STOP |]
   ==>
   ((? :A1 -> Pf1) [+] Q1, Suc n, (? :A1 -> SPf) [+] Q1) : fsfF_Depth_rest_rel"

(*** function ***)

definition
  fsfF_Depth_rest ::
  "('p,'a) proc => nat => ('p,'a) proc"   ("(1_ /|.seq _)" [84,900] 84)
  where
  fsfF_Depth_rest_def:
    "P1 |.seq n == THE SP. (P1, n, SP) : fsfF_Depth_rest_rel"

(****************************************************************
 |                      uniquness                               |
 ****************************************************************)

lemma fsfF_Depth_rest_rel_unique_in_lm:
   "(P1, n, SP1) : fsfF_Depth_rest_rel
    ==> (ALL SP2. ((P1, n, SP2) : fsfF_Depth_rest_rel
                   --> SP1 = SP2))"
apply (rule fsfF_Depth_rest_rel.induct[of P1 n SP1])
apply (simp)

(* zero *)
apply (intro allI impI)
apply (rotate_tac -1)
apply (erule fsfF_Depth_rest_rel.cases)
apply (simp_all)

(* etc *)
apply (intro allI impI)
apply (rotate_tac -1)
apply (erule fsfF_Depth_rest_rel.cases)
apply (simp_all)
apply (simp add: fsfF_proc_int)
apply (simp add: fsfF_proc_ext)

(* step_int *)
apply (intro allI impI)
apply (rotate_tac -1)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)

 apply (rotate_tac -4)
 apply (drule sym)
 apply (simp add: fsfF_proc_int)

 apply (simp add: fun_eq_iff)
 apply (intro allI)
 apply (drule_tac x="x" in spec)+
 apply (case_tac "x : sumset C1a")
 apply (simp)
 apply (simp)

(* step *)
apply (intro allI impI)
apply (rotate_tac -1)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)

 apply (rotate_tac -4)
 apply (drule sym)
 apply (simp add: fsfF_proc_ext)

  apply (simp add: fun_eq_iff)
  apply (rule allI)
  apply (drule_tac x="x" in spec)+
  apply (case_tac "x : A1a")
  apply (simp_all)
done

(*-----------------------*
 |        unique         |
 *-----------------------*)

lemma fsfF_Depth_rest_rel_unique:
   "[| (P1, n, SP1) : fsfF_Depth_rest_rel;
       (P1, n, SP2) : fsfF_Depth_rest_rel |]
    ==> SP1 = SP2"
by (simp add: fsfF_Depth_rest_rel_unique_in_lm)

lemma fsfF_Depth_rest_rel_EX1:
   "(EX SP. (P1, n, SP) : fsfF_Depth_rest_rel)
 = (EX! SP. (P1, n, SP) : fsfF_Depth_rest_rel)"
apply (rule iffI)

 apply (erule exE)
 apply (rule_tac a="SP" in ex1I)
 apply (simp)
 apply (simp add: fsfF_Depth_rest_rel_unique)

 apply (elim ex1_implies_exE)
 apply (simp)
done

(*------------------------------------------------------------*
 |                   fsfF_Depth_rest_rel (iff)                |
 *------------------------------------------------------------*)

(* zero *)

lemma fsfF_Depth_rest_rel_zero_iff:
  "(P1, 0, SP) : fsfF_Depth_rest_rel
   = (SP = SDIV)"
apply (rule)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)
apply (simp add: fsfF_Depth_rest_rel_zero)
done

(* etc *)

lemma fsfF_Depth_rest_rel_etc_iff:
  "P1 ~: fsfF_proc
   ==> (P1, Suc n, SP) : fsfF_Depth_rest_rel
       = (SP = P1 |. Suc n)"
apply (rule)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)
 apply (simp add: fsfF_proc_int)
 apply (simp add: fsfF_proc_ext)
apply (simp add: fsfF_Depth_rest_rel_etc)
done

(* int nat *)

lemma fsfF_Depth_rest_rel_int_iff:
  "[| ALL c. if (c: sumset C1)
             then (Rf1 c, Suc m, SRf c) : fsfF_Depth_rest_rel
             else SRf c = DIV ;
      sumset C1 ~= {} ; ALL c: sumset C1. Rf1 c : fsfF_proc |]
   ==>
   ((!! :C1 .. Rf1), Suc m, SP) : fsfF_Depth_rest_rel
   = (SP = !! :C1 .. SRf)"
apply (rule)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)

 apply (rotate_tac -4)
 apply (drule sym)
 apply (simp add: fsfF_proc_int)

 apply (simp add: fun_eq_iff)
 apply (rule allI)
 apply (drule_tac x="x" in spec)+
 apply (case_tac "x : sumset C1a")
 apply (simp add: fsfF_Depth_rest_rel_unique)

 apply (simp)
apply (simp add: fsfF_Depth_rest_rel_int)
done

(* step *)

lemma fsfF_Depth_rest_rel_step_iff:
  "[| ALL a. if a:A1
             then (Pf1 a, n, SPf a) : fsfF_Depth_rest_rel
             else SPf a = DIV ;
      ALL a:A1. Pf1 a : fsfF_proc ;
      Q1 = SKIP | Q1 = DIV | Q1 = STOP |]
   ==>
   ((? :A1 -> Pf1) [+] Q1, Suc n, SP) : fsfF_Depth_rest_rel
   = (SP = (? :A1 -> SPf) [+] Q1)"
apply (rule)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)

 apply (rotate_tac -4)
 apply (drule sym)
 apply (simp add: fsfF_proc_ext)

 apply (simp add: fun_eq_iff)
 apply (intro allI conjI)
 apply (elim conjE)
 apply (drule_tac x="x" in spec)+
 apply (case_tac "x : A1a")
 apply (simp add: fsfF_Depth_rest_rel_unique)
 apply (simp)
apply (simp add: fsfF_Depth_rest_rel_step)
done

(****************************************************************
 |                      existency                               |
 ****************************************************************)

(*** exists ***)

lemma fsfF_Depth_rest_rel_exists_zero:
   "(EX SP. (P1, 0, SP) : fsfF_Depth_rest_rel)"
apply (rule_tac x="SDIV" in exI)
apply (simp add: fsfF_Depth_rest_rel.intros)
done

lemma fsfF_Depth_rest_rel_exists_notin:
   "P1 ~: fsfF_proc
    ==> (EX SP. (P1, n, SP) : fsfF_Depth_rest_rel)"
apply (insert nat_zero_or_Suc)
apply (drule_tac x="n" in spec)
apply (elim disjE exE)
apply (simp add: fsfF_Depth_rest_rel_exists_zero)
apply (rule_tac x="P1 |. n" in exI)
apply (simp add: fsfF_Depth_rest_rel.intros)
done

(*** in fsfF_proc ***)

(********* P1 and P2 *********)

lemma fsfF_Depth_rest_rel_exists_in:
   "P1 : fsfF_proc
    ==> ALL n. (EX SP. (P1, n, SP) :  fsfF_Depth_rest_rel)"
apply (rule fsfF_proc.induct[of P1])
apply (simp)

(* int nat *)
apply (rule allI)
apply (insert nat_zero_or_Suc)
apply (drule_tac x="n" in spec)
apply (elim disjE exE)
apply (simp add: fsfF_Depth_rest_rel_exists_zero)

apply (erule dist_BALL_conjE)
apply (simp add: exchange_ALL_BALL)
apply (simp add: choice_BALL_EX)
apply (drule_tac x="n" in spec)
apply (elim exE)
apply (rule_tac x="!! c:C .. (if (c : sumset C) then f c else DIV)" in exI)
apply (rule fsfF_Depth_rest_rel.intros)
apply (simp split: if_split)
apply (simp_all)

(* ext *)
apply (rule allI)
apply (drule_tac x="n" in spec)
apply (rotate_tac -1)
apply (erule disjE)
apply (simp add: fsfF_Depth_rest_rel_exists_zero)

apply (elim exE)
apply (erule dist_BALL_conjE)

apply (simp add: exchange_ALL_BALL)
apply (simp add: choice_BALL_EX)
apply (drule_tac x="m" in spec)
apply (elim exE)
apply (rule_tac x="? a:A -> (if (a : A) then (f a) else DIV) [+] Q" in exI)
apply (rule fsfF_Depth_rest_rel.intros)
apply (simp split: if_split)
apply (simp_all)
done

(*-----------------------*
 |        exists         |
 *-----------------------*)

lemma fsfF_Depth_rest_rel_exists:
   "EX SP. (P1, n, SP) :  fsfF_Depth_rest_rel"
apply (case_tac "P1 ~: fsfF_proc")
apply (simp add: fsfF_Depth_rest_rel_exists_notin)
apply (simp add: fsfF_Depth_rest_rel_exists_in)
done

(*-----------------------*
 |    uniquely exists    |
 *-----------------------*)

lemma fsfF_Depth_rest_rel_unique_exists:
   "EX! SP. (P1, n, SP) :  fsfF_Depth_rest_rel"
apply (simp add: fsfF_Depth_rest_rel_EX1[THEN sym])
apply (simp add: fsfF_Depth_rest_rel_exists)
done

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Depth_rest_rel_zero_in:
  "(P1, 0, SP) : fsfF_Depth_rest_rel ==> SP : fsfF_proc"
apply (simp add: fsfF_Depth_rest_rel_zero_iff)
done

lemma fsfF_Depth_rest_rel_in_lm:
  "P1 : fsfF_proc ==>
   ALL n SP. (P1, n, SP) : fsfF_Depth_rest_rel --> SP : fsfF_proc"
apply (rule fsfF_proc.induct[of P1])
apply (simp)

(* int nat *)
apply (intro allI)
apply (insert nat_zero_or_Suc)
apply (drule_tac x="n" in spec)
apply (elim disjE exE)
apply (simp add: fsfF_Depth_rest_rel_zero_in)

apply (intro impI)
apply (simp)
apply (rotate_tac -1)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)

 apply (rotate_tac -4)
 apply (drule sym)
 apply (simp add: fsfF_proc.intros)

apply (rule fsfF_proc.intros)
apply (simp_all)
apply (rule ballI)
apply (drule_tac x="c" in spec)
apply (drule_tac x="c" in bspec, simp)
apply (force)

(* ext *)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (rotate_tac -1)
apply (erule disjE)
apply (simp add: fsfF_Depth_rest_rel_zero_in)

apply (intro impI)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)

 apply (rotate_tac -4)
 apply (drule sym)
 apply (simp add: fsfF_proc.intros)

apply (rule fsfF_proc.intros)
apply (simp_all)
apply (rule ballI)
apply (drule_tac x="a" in spec)
apply (drule_tac x="a" in bspec, simp)
apply (force)
done

(*------------------------------------*
 |                 in                 |
 *------------------------------------*)

lemma fsfF_Depth_rest_rel_in:
  "[| P1 : fsfF_proc ; (P1, n, SP) : fsfF_Depth_rest_rel |]
   ==> SP : fsfF_proc"
apply (insert fsfF_Depth_rest_rel_in_lm[of P1])
apply (blast)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

(*** relation ***)

lemma cspF_fsfF_Depth_rest_rel_eqF_zero:
   "(P1, 0, SP) : fsfF_Depth_rest_rel
     ==> P1 |. 0 =F SP"
apply (simp add: fsfF_Depth_rest_rel_zero_iff)
apply (rule cspF_rw_left)
apply (rule cspF_Depth_rest_Zero)
apply (rule cspF_SDIV_eqF)
done

lemma cspF_fsfF_Depth_rest_rel_eqF_notin:
   "[| P1 ~: fsfF_proc ; (P1, n, SP) : fsfF_Depth_rest_rel |]
    ==> P1 |. n =F SP"
apply (insert nat_zero_or_Suc)
apply (drule_tac x="n" in spec)
apply (elim disjE exE)
apply (simp add: cspF_fsfF_Depth_rest_rel_eqF_zero)
apply (simp add: fsfF_Depth_rest_rel_etc_iff)
done

lemma cspF_fsfF_Depth_rest_rel_eqF_in:
    "P1 : fsfF_proc ==>
     ALL n SP. (P1, n, SP) : fsfF_Depth_rest_rel
                --> P1 |. n =F SP"
apply (rule fsfF_proc.induct[of P1])
apply (simp)

(* int *)
apply (intro allI)
apply (insert nat_zero_or_Suc)
apply (drule_tac x="n" in spec)
apply (elim disjE exE)
apply (simp add: cspF_fsfF_Depth_rest_rel_eqF_zero)

apply (intro impI)
apply (simp)
apply (rotate_tac -1)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)
apply (elim conjE)

apply (rule cspF_rw_left)
apply (rule cspF_Dist)
apply (rule cspF_decompo)
apply (simp)
apply (drule_tac x="c" in bspec, simp)
apply (drule_tac x="c" in spec)
apply (simp)

(* ext *)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (rotate_tac -1)
apply (erule disjE)
apply (simp add: cspF_fsfF_Depth_rest_rel_eqF_zero)

apply (intro impI)
apply (erule fsfF_Depth_rest_rel.cases, simp_all)

apply (rule cspF_rw_left)
apply (rule cspF_Ext_dist)
apply (rule cspF_decompo)

 apply (rule cspF_rw_left)
 apply (rule cspF_step)
 apply (rule cspF_decompo)
 apply (simp)
 apply (simp)
 apply (case_tac "Q = STOP")
 apply (simp add: cspF_STOP_Depth_rest)
 apply (simp add: cspF_SKIP_or_DIV_Depth_rest)
done

(*------------------------------------*
 |                 eqF                |
 *------------------------------------*)

lemma cspF_fsfF_Depth_rest_rel_eqF:
   "(P1, n, SP) : fsfF_Depth_rest_rel ==> P1 |. n =F SP"
apply (case_tac "P1 ~: fsfF_proc")
apply (simp add: cspF_fsfF_Depth_rest_rel_eqF_notin)
apply (simp add: cspF_fsfF_Depth_rest_rel_eqF_in)
done

(*************************************************************
                  relation --> function
 *************************************************************)

lemma fsfF_Depth_rest_in_rel:
    "(P1, n, P1 |.seq n) : fsfF_Depth_rest_rel"
apply (simp add: fsfF_Depth_rest_def)
apply (rule theI'
  [of "(%R. (P1, n, R) : fsfF_Depth_rest_rel)"])
apply (simp add: fsfF_Depth_rest_rel_unique_exists)
done

lemma fsfF_Depth_rest_from_rel:
    "((P1, n, SP) : fsfF_Depth_rest_rel)
   = (P1 |.seq n = SP)"
apply (rule iffI)
apply (simp add: fsfF_Depth_rest_def)
apply (simp add: fsfF_Depth_rest_rel_unique_exists the1_equality)

apply (drule sym)
apply (simp add: fsfF_Depth_rest_in_rel)
done

lemma fsfF_Depth_rest_to_rel:
    "(P1 |.seq n = SP)
   = ((P1, n, SP) : fsfF_Depth_rest_rel)"
by (simp add: fsfF_Depth_rest_from_rel)

(*************************************************************
                          function
 *************************************************************)

lemma fsfF_Depth_rest_zero:
  "P1 |.seq 0 = SDIV"
apply (simp add: fsfF_Depth_rest_to_rel)
apply (simp add: fsfF_Depth_rest_rel_zero_iff)
done

lemma fsfF_Depth_rest_etc:
  "P1 ~: fsfF_proc
   ==> P1 |.seq (Suc n) = P1 |. (Suc n)"
apply (simp add: fsfF_Depth_rest_to_rel)
apply (simp add: fsfF_Depth_rest_rel_etc_iff)
done

lemma fsfF_Depth_rest_int:
  "[| sumset C1 ~= {} ; ALL c: sumset C1. Rf1 c : fsfF_proc |]
   ==>
   (!! :C1 .. Rf1) |.seq (Suc m) =
    !! c:C1 .. (if c: sumset C1 then (Rf1 c |.seq (Suc m)) else DIV)"
apply (simp add: fsfF_Depth_rest_to_rel)
apply (rule fsfF_Depth_rest_rel_int)
apply (simp_all)
apply (simp split: if_split)
apply (simp add: fsfF_Depth_rest_in_rel)
done

lemma fsfF_Depth_rest_step:
  "[| ALL a:A1. Pf1 a : fsfF_proc ; Q1 = SKIP | Q1 = DIV | Q1 = STOP |]
   ==>
    ((? :A1 -> Pf1) [+] Q1) |.seq (Suc n) =
    ((? a:A1 -> (if (a:A1) then (Pf1 a |.seq n) else DIV)) [+] Q1)"
apply (simp add: fsfF_Depth_rest_to_rel)
apply (rule fsfF_Depth_rest_rel_step)
apply (simp_all)
apply (simp split: if_split)
apply (simp add: fsfF_Depth_rest_in_rel)
done

lemmas fsfF_Depth_rest =
       fsfF_Depth_rest_etc
       fsfF_Depth_rest_int
       fsfF_Depth_rest_step

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Depth_rest_in:
  "P1 : fsfF_proc
   ==> P1 |.seq n : fsfF_proc"
apply (rule fsfF_Depth_rest_rel_in[of P1 n])
apply (simp_all add: fsfF_Depth_rest_in_rel)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Depth_rest_eqF:
   "P1 |. n =F P1 |.seq n"
apply (rule cspF_fsfF_Depth_rest_rel_eqF)
apply (simp add: fsfF_Depth_rest_in_rel)
done

(****************** to add them again ******************)

declare if_split    [split]
declare disj_not1   [simp]

end