(* @LICENSE(NICTA_CORE) *)

chapter \<open>More properties of maps plus map disjuction.\<close>

theory MapExtra
imports Main
begin

text \<open>
  BEWARE: we are not interested in using the @{term "dom x \<inter> dom y = {}"}
  rules from Map for our separation logic proofs. As such, we overwrite the
  Map rules where that form of disjointness is in the assumption conflicts
  with a name we want to use with @{text "\<bottom>"}.\<close>

text \<open>
  A note on naming:
  Anything not involving heap disjuction can potentially be incorporated
  directly into Map.thy, thus uses @{text "m"}.
  Anything involving heap disjunction is not really mergeable with Map, is
  destined for use in separation logic, and hence uses @{text "h"}
\<close>

text \<open>-------------------------------------------------------------------\<close>
text \<open>Things that should go into Option Type\<close>
text \<open>-------------------------------------------------------------------\<close>

text \<open>Misc option lemmas\<close>

lemma None_not_eq: "(None \<noteq> x) = (\<exists>y. x = Some y)" by (cases x) auto

lemma None_com: "(None = x) = (x = None)" by fast

lemma Some_com: "(Some y = x) = (x = Some y)" by fast

text \<open>-------------------------------------------------------------------\<close>
text \<open>Things that should go into Map.thy\<close>
text \<open>-------------------------------------------------------------------\<close>

text \<open>Map intersection: set of all keys for which the maps agree.\<close>

(*x\<^sub> *)

definition
  map_inter :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" (infixl "\<inter>\<^sub>m" 70) where
  "m\<^sub>1 \<inter>\<^sub>m m\<^sub>2 \<equiv> {x \<in> dom m\<^sub>1. m\<^sub>1 x = m\<^sub>2 x}"

text \<open>Map restriction via domain subtraction\<close>

definition
  sub_restrict_map :: "('a \<rightharpoonup> 'b) => 'a set => ('a \<rightharpoonup> 'b)" (infixl "`-"  110)
  where
  "m `- S \<equiv> (\<lambda>x. if x \<in> S then None else m x)"

subsection \<open>Properties of maps not related to restriction\<close>

lemma empty_forall_equiv: "(m = Map.empty) = (\<forall>x. m x = None)"
  by (fastforce intro!: ext)

lemma map_le_empty2 [simp]:
  "(m \<subseteq>\<^sub>m Map.empty) = (m = Map.empty)"
  by (auto simp: map_le_def intro: ext)

lemma dom_iff:
  "(\<exists>y. m x = Some y) = (x \<in> dom m)"
  by auto

lemma non_dom_eval:
  "x \<notin> dom m \<Longrightarrow> m x = None"
  by auto

lemma non_dom_eval_eq:
  "x \<notin> dom m = (m x = None)"
  by auto

lemma map_add_same_left_eq:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> (m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1')"
  by simp

lemma map_add_left_cancelI [intro!]:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1'"
  by simp

lemma dom_empty_is_empty:
  "(dom m = {}) = (m = Map.empty)"
proof (rule iffI)
  assume a: "dom m = {}"
  { assume "m \<noteq> Map.empty"
    hence "dom m \<noteq> {}"
      by - (subst (asm) empty_forall_equiv, simp add: dom_def)
    hence False using a by blast
  }
  thus "m = Map.empty" by blast
next
  assume a: "m = Map.empty"
  thus "dom m = {}" by simp
qed

lemma map_add_dom_eq:
  "dom m = dom m' \<Longrightarrow> m ++ m' = m'"
  by (rule ext) (auto simp: map_add_def split: option.splits)

lemma map_add_right_dom_eq:
  "\<lbrakk> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0' ++ m\<^sub>1'; dom m\<^sub>1 = dom m\<^sub>1' \<rbrakk> \<Longrightarrow> m\<^sub>1 = m\<^sub>1'"
  unfolding map_add_def
  by (rule ext, rule ccontr,
      drule_tac x=x in fun_cong, clarsimp split: option.splits,
      drule sym, drule sym, force+)

lemma map_le_same_dom_eq:
  "\<lbrakk> m\<^sub>0 \<subseteq>\<^sub>m m\<^sub>1 ; dom m\<^sub>0 = dom m\<^sub>1 \<rbrakk> \<Longrightarrow> m\<^sub>0 = m\<^sub>1"
  by (auto intro!: ext simp: map_le_def elim!: ballE)

subsection \<open>Properties of map restriction\<close>

lemma restrict_map_cancel:
  "(m |` S = m |` T) = (dom m \<inter> S = dom m \<inter> T)"
  by (fastforce intro: set_eqI ext dest: fun_cong
               simp: restrict_map_def None_not_eq
               split: if_split_asm)

lemma map_add_restricted_self [simp]:
  "m ++ m |` S = m"
  by (auto intro: ext simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_dom_right [simp]:
  "(m ++ m') |` dom m' = m'"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_UNIV [simp]:
  "m |` UNIV = m"
  by (simp add: restrict_map_def)

lemma restrict_map_dom:
  "S = dom m \<Longrightarrow> m |` S = m"
  by (auto intro!: ext simp: restrict_map_def None_not_eq)

lemma restrict_map_subdom:
  "dom m \<subseteq> S \<Longrightarrow> m |` S = m"
  by (fastforce simp: restrict_map_def None_com intro: ext)

lemma map_add_restrict:
  "(m\<^sub>0 ++ m\<^sub>1) |` S = ((m\<^sub>0 |` S) ++ (m\<^sub>1 |` S))"
  by (force simp: map_add_def restrict_map_def intro: ext)

lemma map_le_restrict:
  "m \<subseteq>\<^sub>m m' \<Longrightarrow> m = m' |` dom m"
  by (force simp: map_le_def restrict_map_def None_com intro: ext)

lemma restrict_map_le:
  "m |` S \<subseteq>\<^sub>m m"
  by (auto simp: map_le_def)

lemma restrict_map_remerge:
  "\<lbrakk> S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m |` (S \<union> T)"
  by (rule ext, clarsimp simp: restrict_map_def map_add_def
                         split: option.splits)

lemma restrict_map_empty:
  "dom m \<inter> S = {} \<Longrightarrow> m |` S = Map.empty"
  by (fastforce simp: restrict_map_def intro: ext)

lemma map_add_restrict_comp_right [simp]:
  "(m |` S ++ m |` (UNIV - S)) = m"
  by (force simp: map_add_def restrict_map_def split: option.splits intro: ext)

lemma map_add_restrict_comp_right_dom [simp]:
  "(m |` S ++ m |` (dom m - S)) = m"
  by (auto simp: map_add_def restrict_map_def split: option.splits intro!: ext)

lemma map_add_restrict_comp_left [simp]:
  "(m |` (UNIV - S) ++ m |` S) = m"
  by (subst map_add_comm, auto)

lemma restrict_self_UNIV:
  "m |` (dom m - S) = m |` (UNIV - S)"
  by (auto intro!: ext simp: restrict_map_def)

lemma map_add_restrict_nonmember_right:
  "x \<notin> dom m' \<Longrightarrow> (m ++ m') |` {x} = m |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_nonmember_left:
  "x \<notin> dom m \<Longrightarrow> (m ++ m') |` {x} = m' |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_right:
  "x \<subseteq> dom m' \<Longrightarrow> (m ++ m') |` x = m' |` x"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_compose:
  "\<lbrakk> S \<union> T = dom m ; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m"
  by (fastforce intro: ext simp: map_add_def restrict_map_def)

lemma map_le_dom_subset_restrict:
  "\<lbrakk> m' \<subseteq>\<^sub>m m; dom m' \<subseteq> S \<rbrakk> \<Longrightarrow> m' \<subseteq>\<^sub>m (m |` S)"
  by (force simp: restrict_map_def map_le_def)

lemma map_le_dom_restrict_sub_add:
  "m' \<subseteq>\<^sub>m m \<Longrightarrow> m |` (dom m - dom m') ++ m' = m"
  by (auto simp: None_com map_add_def restrict_map_def map_le_def
           split: option.splits
           intro!: ext)
     (force simp: Some_com)+

lemma subset_map_restrict_sub_add:
  "T \<subseteq> S \<Longrightarrow> m |` (S - T) ++ m |` T = m |` S"
  by (auto simp: restrict_map_def map_add_def intro!: ext split: option.splits)

lemma restrict_map_sub_union:
  "m |` (dom m - (S \<union> T)) = (m |` (dom m - T)) |` (dom m - S)"
  by (auto intro!: ext simp: restrict_map_def)

lemma prod_restrict_map_add:
  "\<lbrakk> S \<union> T = U; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` (X \<times> S) ++ m |` (X \<times> T) = m |` (X \<times> U)"
  by (auto simp: map_add_def restrict_map_def intro!: ext split: option.splits)

text \<open>-------------------------------------------------------------------\<close>
text \<open>Things that should NOT go into Map.thy\<close>
text \<open>-------------------------------------------------------------------\<close>

section \<open>Definitions\<close>

text \<open>Map disjuction\<close>

definition
  map_disj :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<bottom>" 51) where
  "h\<^sub>0 \<bottom> h\<^sub>1 \<equiv> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"

declare None_not_eq [simp]

section \<open>Properties of @{term "sub_restrict_map"}\<close>

lemma restrict_map_sub_add: "h |` S ++ h `- S = h"
  by (fastforce simp: sub_restrict_map_def restrict_map_def map_add_def
               split: option.splits if_split
               intro: ext)

section \<open>Properties of map disjunction\<close>

lemma map_disj_empty_right [simp]:
  "h \<bottom> Map.empty"
  by (simp add: map_disj_def)

lemma map_disj_empty_left [simp]:
  "Map.empty \<bottom> h"
  by (simp add: map_disj_def)

lemma map_disj_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_def, fast)

lemma map_disjD:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"
  by (simp add: map_disj_def)

lemma map_disjI:
  "dom h\<^sub>0 \<inter> dom h\<^sub>1 = {} \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1"
  by (simp add: map_disj_def)

subsection \<open>Map associativity-commutativity based on map disjuction\<close>

lemma map_add_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>1 ++ h\<^sub>0"
  by (drule map_disjD, rule map_add_comm, force)

lemma map_add_left_commute:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ (h\<^sub>1 ++ h\<^sub>2) = h\<^sub>1 ++ (h\<^sub>0 ++ h\<^sub>2)"
  by (simp add: map_add_com map_disj_com map_add_assoc)

lemma map_add_disj:
  "h\<^sub>0 \<bottom> (h\<^sub>1 ++ h\<^sub>2) = (h\<^sub>0 \<bottom> h\<^sub>1 \<and> h\<^sub>0 \<bottom> h\<^sub>2)"
  by (simp add: map_disj_def, fast)

lemma map_add_disj':
  "(h\<^sub>1 ++ h\<^sub>2) \<bottom> h\<^sub>0 = (h\<^sub>1 \<bottom> h\<^sub>0 \<and> h\<^sub>2 \<bottom> h\<^sub>0)"
  by (simp add: map_disj_def, fast)

text \<open>
  We redefine @{term "map_add"} associativity to bind to the right, which
  seems to be the more common case.
  Note that when a theory includes Map again, @{text "map_add_assoc"} will
  return to the simpset and will cause infinite loops if its symmetric
  counterpart is added (e.g. via @{text "map_add_ac"})
\<close>

declare map_add_assoc [simp del]

text \<open>
  Since the associativity-commutativity of @{term "map_add"} relies on
  map disjunction, we include some basic rules into the ac set.
\<close>

lemmas map_add_ac =
  map_add_assoc[symmetric] map_add_com map_disj_com
  map_add_left_commute map_add_disj map_add_disj'

subsection \<open>Basic properties\<close>

lemma map_disj_None_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left':
  "\<lbrakk> h\<^sub>0 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_None_right':
  "\<lbrakk> h\<^sub>1 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_common:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0 p = Some v ; h\<^sub>1 p = Some v' \<rbrakk> \<Longrightarrow> False"
  by (frule (1) map_disj_None_left', simp)

lemma map_disj_eq_dom_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; dom h\<^sub>0' = dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (auto simp: map_disj_def)

subsection \<open>Map disjunction and addition\<close>

lemma map_add_eval_left:
  "\<lbrakk> x \<in> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h x"
  by (auto dest!: map_disj_None_right simp: map_add_def cong: option.case_cong)

lemma map_add_eval_right:
  "\<lbrakk> x \<in> dom h' ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (auto elim!: map_disjD simp: map_add_comm map_add_eval_left map_disj_com)

lemma map_add_eval_right':
  "\<lbrakk> x \<notin> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (clarsimp simp: map_disj_def map_add_def split: option.splits)

lemma map_add_left_dom_eq:
  assumes eq: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'"
  assumes etc: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'" "dom h\<^sub>0 = dom h\<^sub>0'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  from eq have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using etc by (simp add: map_add_ac)
  thus ?thesis using etc
    by (fastforce elim!: map_add_right_dom_eq simp: map_add_ac)
qed

lemma map_add_left_eq:
  assumes eq: "h\<^sub>0 ++ h = h\<^sub>1 ++ h"
  assumes disj: "h\<^sub>0 \<bottom> h" "h\<^sub>1 \<bottom> h"
  shows "h\<^sub>0 = h\<^sub>1"
proof (rule ext)
  fix x
  from eq have eq': "(h\<^sub>0 ++ h) x = (h\<^sub>1 ++ h) x" by (auto intro!: ext)
  { assume "x \<in> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj by (simp add: map_disj_None_left)
  } moreover {
    assume "x \<notin> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj eq' by (simp add: map_add_eval_left')
  }
  ultimately show "h\<^sub>0 x = h\<^sub>1 x" by cases
qed

lemma map_add_right_eq:
  "\<lbrakk>h ++ h\<^sub>0 = h ++ h\<^sub>1; h\<^sub>0 \<bottom> h; h\<^sub>1 \<bottom> h\<rbrakk> \<Longrightarrow> h\<^sub>0 = h\<^sub>1"
  by (rule_tac h=h in map_add_left_eq, auto simp: map_add_ac)

lemma map_disj_add_eq_dom_right_eq:
  assumes merge: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and d: "dom h\<^sub>0 = dom h\<^sub>0'" and
      ab_disj: "h\<^sub>0 \<bottom> h\<^sub>1" and cd_disj: "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>1 = h\<^sub>1'"
proof (rule ext)
  fix x
  from merge have merge_x: "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0' ++ h\<^sub>1') x" by simp
  with d ab_disj cd_disj show  "h\<^sub>1 x = h\<^sub>1' x"
    by - (case_tac "h\<^sub>1 x", case_tac "h\<^sub>1' x", simp, fastforce simp: map_disj_def,
          case_tac "h\<^sub>1' x", clarsimp, simp add: Some_com,
          force simp: map_disj_def, simp)
qed

lemma map_disj_add_eq_dom_left_eq:
  assumes add: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and
          dom: "dom h\<^sub>1 = dom h\<^sub>1'" and
          disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using add disj by (simp add: map_add_ac)
  thus ?thesis using dom disj
    by - (rule map_disj_add_eq_dom_right_eq, auto simp: map_disj_com)
qed

lemma map_add_left_cancel:
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0 \<bottom> h\<^sub>1'"
  shows "(h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0 ++ h\<^sub>1') = (h\<^sub>1 = h\<^sub>1')"
proof (rule iffI, rule ext)
  fix x
  assume "(h\<^sub>0 ++ h\<^sub>1) = (h\<^sub>0 ++ h\<^sub>1')"
  hence "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0 ++ h\<^sub>1') x" by (auto intro!: ext)
  hence "h\<^sub>1 x = h\<^sub>1' x" using disj
    by - (cases "x \<in> dom h\<^sub>0",
          simp_all add: map_disj_None_right map_add_eval_right')
  thus "h\<^sub>1 x = h\<^sub>1' x" by (auto intro!: ext)
qed auto

lemma map_add_lr_disj:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'; h\<^sub>1 \<bottom> h\<^sub>1'  \<rbrakk> \<Longrightarrow> dom h\<^sub>1 \<subseteq> dom h\<^sub>0'"
  by (clarsimp simp: map_disj_def map_add_def, drule_tac x=x in fun_cong)
     (auto split: option.splits)

subsection \<open>Map disjunction and updates\<close>

lemma map_disj_update_left [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1(p \<mapsto> v) = h\<^sub>0 \<bottom> h\<^sub>1"
  by (clarsimp simp add: map_disj_def, blast)

lemma map_disj_update_right [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>1(p \<mapsto> v) \<bottom> h\<^sub>0 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_com)

lemma map_add_update_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0(p \<mapsto> v) ++ h\<^sub>1)"
  by (drule (1) map_disj_None_right)
     (auto intro: ext simp: map_add_def cong: option.case_cong)

lemma map_add_update_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>1  \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0 ++ h\<^sub>1 (p \<mapsto> v))"
  by (drule (1) map_disj_None_left)
     (auto intro: ext simp: map_add_def cong: option.case_cong)

subsection \<open>Map disjunction and @{term "map_le"}\<close>

lemma map_le_override [simp]:
  "\<lbrakk> h \<bottom> h' \<rbrakk> \<Longrightarrow> h \<subseteq>\<^sub>m h ++ h'"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_leI_left:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h" by auto

lemma map_leI_right:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>1 \<subseteq>\<^sub>m h" by auto

lemma map_disj_map_le:
  "\<lbrakk> h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (force simp: map_disj_def map_le_def)

lemma map_le_on_disj_left:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>0 ++ h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  unfolding map_le_def
  by (rule ballI, erule_tac x=a in ballE, auto simp: map_add_eval_left)+

lemma map_le_on_disj_right:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>1 ++ h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  by (auto simp: map_le_on_disj_left map_add_ac)

lemma map_le_add_cancel:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_le_override_bothD:
  assumes subm: "h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  assumes disj': "h\<^sub>0' \<bottom> h\<^sub>1"
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1"
  shows "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0"
unfolding map_le_def
proof (rule ballI)
  fix a
  assume a: "a \<in> dom h\<^sub>0'"
  hence sumeq: "(h\<^sub>0' ++ h\<^sub>1) a = (h\<^sub>0 ++ h\<^sub>1) a"
    using subm unfolding map_le_def by auto
  from a have "a \<notin> dom h\<^sub>1" using disj' by (auto dest!: map_disj_None_right)
  thus "h\<^sub>0' a = h\<^sub>0 a" using a sumeq disj disj'
    by (simp add: map_add_eval_left map_add_eval_left')
qed

lemma map_le_conv:
  "(h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<and> h\<^sub>0' \<noteq> h\<^sub>0) = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1 \<and> h\<^sub>0' \<noteq> h\<^sub>0)"
  unfolding map_le_def map_disj_def map_add_def
  by (rule iffI,
      clarsimp intro!: exI[where x="\<lambda>x. if x \<notin> dom h\<^sub>0' then h\<^sub>0 x else None"])
     (fastforce intro: ext intro: set_eqI split: option.splits if_split_asm)+

lemma map_le_conv2:
  "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1)"
  by (case_tac "h\<^sub>0'=h\<^sub>0", insert map_le_conv, auto intro: exI[where x=Map.empty])

subsection \<open>Map disjunction and restriction\<close>

lemma map_disj_comp [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (UNIV - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj:
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_disj_restrict_dom [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (dom h\<^sub>1 - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj_dom_empty:
  "h \<bottom> h' \<Longrightarrow> h |` dom h' = Map.empty"
  by (fastforce simp: map_disj_def restrict_map_def intro: ext)

lemma restrict_map_univ_disj_eq:
  "h \<bottom> h' \<Longrightarrow> h |` (UNIV - dom h') = h"
  by (rule ext, auto simp: map_disj_def restrict_map_def)

lemma restrict_map_disj_dom:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h |` dom h\<^sub>0 \<bottom> h |` dom h\<^sub>1"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_dom_left:
  "h \<bottom> h' \<Longrightarrow> (h ++ h') |` dom h = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma map_add_restrict_dom_left':
  "h \<bottom> h' \<Longrightarrow> S = dom h \<Longrightarrow> (h ++ h') |` S = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma restrict_map_disj_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def)

lemmas restrict_map_disj_both = restrict_map_disj_right restrict_map_disj_left

lemma map_dom_disj_restrict_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>0') |` dom h\<^sub>1 = h\<^sub>0' |` dom h\<^sub>1"
  by (simp add: map_add_restrict restrict_map_empty map_disj_def)

lemma restrict_map_on_disj:
  "h\<^sub>0' \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 |` dom h\<^sub>0' \<bottom> h\<^sub>1"
  unfolding map_disj_def by auto

lemma restrict_map_on_disj':
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def map_add_def)

lemma map_le_sub_dom:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h |` (dom h - dom h\<^sub>1)"
  by (rule map_le_override_bothD, subst map_le_dom_restrict_sub_add)
     (auto elim: map_add_le_mapE simp: map_add_ac)

lemma map_submap_break:
  "\<lbrakk> h \<subseteq>\<^sub>m h' \<rbrakk> \<Longrightarrow> h' = (h' |` (UNIV - dom h)) ++ h"
  by (fastforce intro!: ext split: option.splits
               simp: map_le_restrict restrict_map_def map_le_def map_add_def
                     dom_def)

lemma map_add_disj_restrict_both:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1; S \<inter> S' = {}; T \<inter> T' = {} \<rbrakk>
   \<Longrightarrow> (h\<^sub>0 |` S) ++ (h\<^sub>1 |` T) \<bottom> (h\<^sub>0 |` S') ++ (h\<^sub>1 |` T')"
  by (auto simp: map_add_ac intro!: restrict_map_disj_both restrict_map_disj)

end


theory Proof_3_2
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_3_2:
"VC2 inv3 s0 hands_value"
  apply(simp only: VC2_def inv3_def  R3_def
  dryer_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply(simp)
proof -
  define s:: state where
"s = (toEnv
                  (setPstate
                    (setVarBool
                      (setVarAny s0 hands_value)
                      (Suc (Suc 0)) ON)
                    Ctrl drying))"
  assume VC: " ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands =
    ON"
  show " \<forall>s1 s2.
       substate s1 s2 \<and>
       substate s2
        (toEnv
          (setPstate
            (setVarBool (setVarAny s0 hands_value)
              (Suc (Suc 0)) ON)
            Ctrl drying)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       10 \<le> toEnvNum s2
              (toEnv
                (setPstate
                  (setVarBool
                    (setVarAny s0 hands_value)
                    (Suc (Suc 0)) ON)
                  Ctrl drying)) \<and>
       getVarBool s1 hands = ON \<and>
       getVarBool s1 (Suc (Suc 0)) = ON \<and>
       getVarBool s2 hands = OFF \<longrightarrow>
       (\<exists>s4. toEnvP s4 \<and>
             substate s2 s4 \<and>
             substate s4
              (toEnv
                (setPstate
                  (setVarBool
                    (setVarAny s0 hands_value)
                    (Suc (Suc 0)) ON)
                  Ctrl drying)) \<and>
             toEnvNum s2 s4 \<le> 10 \<and>
             (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
              getVarBool s4 hands = ON) \<and>
             (\<forall>s3. toEnvP s3 \<and>
                   substate s2 s3 \<and>
                   substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                   getVarBool s3 (Suc (Suc 0)) =
                   ON \<and>
                   getVarBool s3 hands = OFF))"
    apply(simp only: s_def[symmetric])
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    assume req_prems: "substate s1 s2 \<and>
       substate s2 s \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       10 \<le> toEnvNum s2 s \<and>
       getVarBool s1 hands = ON \<and>
       getVarBool s1 (Suc (Suc 0)) = ON \<and>
       getVarBool s2 hands = OFF"
    then obtain "10 \<le> toEnvNum s2 s" by auto
    from le_imp_less_or_eq[OF this]
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4 s \<and>
            toEnvNum s2 s4 \<le> 10 \<and>
            (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
             getVarBool s4 hands = ON) \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 (Suc (Suc 0)) = ON \<and>
                  getVarBool s3 hands = OFF)"
    proof
      assume 1: "10 < toEnvNum s2 s"
      with req_prems substate_eq_or_predEnv
 toEnvNum_id s_def  have 2: "substate s2 s0"
        by (simp add: s_def split: if_splits)
      from VC obtain "\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF))"
        by auto
      with req_prems 1 2 have "\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)"
        by (auto simp add: s_def split: if_splits)
      then obtain s4 where 3: " toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)" ..
      have  "(toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)) \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF)"
      proof
        from 3 show "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)"
          by (simp add: s_def)
      next
        from 3 show "\<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
          by simp
      qed
      thus ?thesis by auto
    next
      assume 4: "10 = toEnvNum s2 s"
      from substate_asym have 5:
"\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF"
        by auto
      show ?thesis
      proof -
        define s5:: state where "s5=s2"
        have "toEnvP s5 \<and> substate s2 s5 \<and>
substate s5 s \<longrightarrow>pred3 s2 s s5"
        proof(induction rule: state_down_ind)
          case 1
          then show ?case
            using req_prems s_def by auto
        next
          case 2
          then show ?case
            apply(simp only: pred3_def)
          proof
            assume 6: " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
            have " (toEnvP s \<and>
         substate s s \<and>
         substate s s \<and>
         toEnvNum s2 s \<le> 10) \<and>
         (getVarBool s (Suc (Suc 0)) = OFF \<or>
          getVarBool s hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s s3 \<and>
               substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
            proof
              from 4 substate_refl s_def  req_prems
              show "(toEnvP s \<and>
         substate s s \<and>
         substate s s \<and>
         toEnvNum s2 s \<le> 10 )"
                by auto
            next
              from VC have " (getVarBool s (Suc (Suc 0)) = OFF \<or>
     getVarBool s hands = ON)"
                by (simp add: s_def)
              moreover from substate_asym have
             "\<forall>s3. toEnvP s3 \<and>
          substate s s3 \<and>
          substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF" by auto
              ultimately show
"(getVarBool s (Suc (Suc 0)) = OFF \<or>
     getVarBool s hands = ON) \<and>
    (\<forall>s3. toEnvP s3 \<and>
          substate s s3 \<and>
          substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF)" ..
            qed
            thus "\<exists>s4. toEnvP s4 \<and>
         substate s s4 \<and>
         substate s4 s \<and>
         toEnvNum s2 s4 \<le> 10 \<and>
         (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
          getVarBool s4 hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s s3 \<and>
               substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
              by auto
          qed
        next
          case (3 s5)
          then show ?case
            apply(simp only: pred3_def)
          proof
            from 3(3) have  6: " (\<forall>s3. toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s5 \<and> s3 \<noteq> s5 \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF) \<Longrightarrow>
    (\<exists>s4. toEnvP s4 \<and>
          substate s5 s4 \<and>
          substate s4 s \<and>
          toEnvNum s2 s4 \<le> 10 \<and>
          (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
           getVarBool s4 hands = ON) \<and>
          (\<forall>s3. toEnvP s3 \<and>
                substate s5 s3 \<and>
                substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                getVarBool s3 (Suc (Suc 0)) = ON \<and>
                getVarBool s3 hands = OFF)) "
              by (auto simp add: pred3_def)
            assume 7: " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 (predEnv s5) \<and>
         s3 \<noteq> predEnv s5 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
            show "\<exists>s4. toEnvP s4 \<and>
         substate (predEnv s5) s4 \<and>
         substate s4 s \<and>
         toEnvNum s2 s4 \<le> 10 \<and>
         (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
          getVarBool s4 hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate (predEnv s5) s3 \<and>
               substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
            proof cases
              assume 10: "(getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
          getVarBool (predEnv s5) hands = ON)"
              from predEnv_substate 3
substate_trans have 8:  "substate (predEnv s5) s"
                by blast
              from 3(2) substate_eq_or_predEnv req_prems
              have 9: "substate s2 (predEnv s5)"
                by auto
              have "toEnvP (predEnv s5) \<and>
         substate (predEnv s5) (predEnv s5) \<and>
         substate (predEnv s5) s \<and>
         toEnvNum s2 (predEnv s5) \<le> 10 \<and>
         (getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
          getVarBool (predEnv s5) hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate (predEnv s5) s3 \<and>
               substate s3 (predEnv s5) \<and>
 s3 \<noteq> (predEnv s5) \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
              proof -
                from predEnvP_or_emptyState[of s5]
                have "toEnvP (predEnv s5)"
                proof
                  assume "toEnvP (predEnv s5)"
                  thus ?thesis by assumption
                next
                  assume   "predEnv s5 = emptyState"
                  with 9 req_prems show ?thesis
                    by (cases s2; auto)
                qed
                moreover from substate_refl have
" substate (predEnv s5) (predEnv s5)" by auto
                moreover from 8
                have "substate (predEnv s5) s"
                  by assumption
                moreover from 4 8 9 toEnvNum3
                have "toEnvNum s2 (predEnv s5) \<le> 10"
                  by auto
                moreover from 10
                have "(getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
     getVarBool (predEnv s5) hands = ON)"
                  by assumption
                moreover from substate_asym
                have "\<forall>s3. toEnvP s3 \<and>
          substate (predEnv s5) s3 \<and>
          substate s3 (predEnv s5) \<and>
          s3 \<noteq> predEnv s5 \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF" by auto
                ultimately show ?thesis by auto
              qed
              thus ?thesis by auto
            next
              assume 10: "\<not> (getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
        getVarBool (predEnv s5) hands = ON)"
              with substate_eq_or_predEnv 7
              have " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3  s5 \<and>
         s3 \<noteq> s5 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
                by auto
              from 6[OF this] obtain s4 where 11:
"toEnvP s4 \<and>
       substate s5 s4 \<and>
       substate s4 s \<and>
       toEnvNum s2 s4 \<le> 10 \<and>
       (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
        getVarBool s4 hands = ON) \<and>
       (\<forall>s3. toEnvP s3 \<and>
             substate s5 s3 \<and>
             substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
             getVarBool s3 (Suc (Suc 0)) = ON \<and>
             getVarBool s3 hands = OFF)" ..
              have "(toEnvP s4 \<and>
      substate (predEnv s5) s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)) \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF)"
              proof
                from 11 predEnv_substate substate_trans
                show "toEnvP s4 \<and>
      substate (predEnv s5) s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)" by blast
              next
                show "\<forall>s3. toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF"
                proof(rule allI; rule impI)
                  fix s3
                  assume 12: "toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4"
                  with  11 3(1) predEnv_substate_imp_eq_or_substate
                  have "s3 = predEnv s5 \<or> substate s5 s3"
                    by auto
                  with 10 11 12 show "getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF"
                    by auto

                qed
              qed
              thus ?thesis by auto
            qed
          qed
        qed
        with s5_def req_prems substate_refl
 pred3_def 5 show ?thesis by auto
      qed
    qed
  qed
next
  assume "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands =
    ON "
  with extra2 show "extraInv
     (toEnv
       (setPstate
         (setVarBool (setVarAny s0 hands_value)
           (Suc (Suc 0)) ON)
         Ctrl drying))"
    by (auto simp add: VC2_def dryer_def)
qed

end


theory AbstractMultiPaxos
imports  IOA BallotArrays Paxos_Sig
begin

section {* Definition of the Abstract MultiPaxos I/O-automaton *}

subsection {* State and actions *}

record ('v,'a) amp_state =
  propCmd :: "'v set"
  ballot :: "'a \<Rightarrow> nat"
  vote :: "inst \<Rightarrow> 'a \<Rightarrow> bal \<Rightarrow> 'v option"
  -- {* TODO: according to Isabelle's canonical argument order,
  it shoudl be @{typ "'a \<Rightarrow> bal \<Rightarrow> inst \<Rightarrow> 'v option"} *}

locale amp_ioa =
  fixes quorums::"'a set set"
begin

definition amp_start where
  -- {* The initial state *}
  "amp_start \<equiv> {\<lparr>propCmd = {}, ballot = (\<lambda> a . 0), vote = (\<lambda> i a b . None) \<rparr>}"

subsection {* The transitions *}

definition propose where
  "propose c r r' \<equiv> (r' = r\<lparr>propCmd := (propCmd r) \<union> {c}\<rparr>)"

definition join_ballot where
  "join_ballot a b s s' \<equiv>
    b > (ballot s a) \<and> s' = s\<lparr>ballot := (ballot s)(a := b)\<rparr>"

abbreviation proved_safe_at where
  -- {* v is proved safe in instance i at ballot b by quorum q *}
  "proved_safe_at s i q b v \<equiv> ballot_array.proved_safe_at_abs quorums (ballot s) (vote s i) q b v"

abbreviation conservative_at where
  "conservative_at s i \<equiv> ballot_array.conservative_array (vote s i)"

definition do_vote where
  "do_vote a i q v s s' \<equiv> let b = ballot s a in
          v \<in> propCmd s
        \<and> vote s i a b = None
        \<and> proved_safe_at s i q b v
        \<and> q \<in> quorums
        \<and> conservative_at s' i
        \<and> s' = s\<lparr>vote := (vote s)(i := (vote s i)(a := (vote s i a)(b := Some v)))\<rparr>"

abbreviation chosen where
  "chosen s i v \<equiv> ballot_array.chosen quorums (vote s i) v"

definition learn where
  "learn i v s s' \<equiv> chosen s i v \<and> s = s'"

fun amp_trans_rel where
  "amp_trans_rel r (Propose c) r' = propose c r r'"
| "amp_trans_rel r Internal r' = (
    (\<exists> a b . join_ballot a b r r')
    \<or> (\<exists> a q i v . do_vote a i q v r r'))"
| "amp_trans_rel r (Learn i v) r' = learn i v r r'"

lemma trans_cases: assumes "amp_trans_rel r a r'"
  obtains
  (propose) c where "propose c r r'"
| (learn) i v where "learn i v r r'"
| (join_ballot) a b where "join_ballot a b r r'"
| (do_vote) a i q v where "do_vote a i q v r r'"
  using assms apply induct apply auto
  by (meson amp_trans_rel.elims(2))

definition amp_trans where
  "amp_trans \<equiv> { (r,a,r') . amp_trans_rel r a r'}"

subsection {* The I/O-automaton *}

definition amp_ioa where
  "amp_ioa \<equiv> \<lparr>ioa.asig = paxos_asig, start = amp_start, trans = amp_trans\<rparr>"

lemmas simps = amp_ioa_def paxos_asig_def amp_start_def amp_trans_def propose_def join_ballot_def
  do_vote_def learn_def

end

end


theory Incredible_Signatures
imports
  Main
  "HOL-Library.FSet"
  "HOL-Library.Stream"
  Abstract_Formula
begin

text \<open>This theory contains the definition for proof graph signatures, in the variants
\<^item> Plain port graph
\<^item> Port graph with local hypotheses
\<^item> Labeled port graph
\<^item> Port graph with local constants
\<close>

locale Port_Graph_Signature =
  fixes nodes :: "'node stream"
  fixes inPorts :: "'node \<Rightarrow> 'inPort fset"
  fixes outPorts :: "'node \<Rightarrow> 'outPort fset"

locale Port_Graph_Signature_Scoped =
  Port_Graph_Signature +
  fixes hyps :: "'node \<Rightarrow> 'outPort \<rightharpoonup> 'inPort"
  assumes hyps_correct: "hyps n p1 = Some p2 \<Longrightarrow> p1 |\<in>| outPorts n \<and> p2 |\<in>| inPorts n"
begin
  inductive_set hyps_for' :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'outPort set" for n p
    where "hyps n h = Some p \<Longrightarrow> h \<in> hyps_for' n p"

  lemma hyps_for'_subset: "hyps_for' n p \<subseteq> fset (outPorts n)"
    using hyps_correct by (meson hyps_for'.cases notin_fset subsetI)

  context includes fset.lifting
  begin
  lift_definition hyps_for  :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'outPort fset" is hyps_for'
    by (meson finite_fset hyps_for'_subset rev_finite_subset)
  lemma hyps_for_simp[simp]: "h |\<in>| hyps_for n p \<longleftrightarrow> hyps n h = Some p"
    by transfer (simp add: hyps_for'.simps)
  lemma hyps_for_simp'[simp]: "h \<in> fset (hyps_for n p) \<longleftrightarrow> hyps n h = Some p"
    by transfer (simp add: hyps_for'.simps)
  lemma hyps_for_collect: "fset (hyps_for n p) = {h . hyps n h = Some p}"
    by auto
  end
  lemma hyps_for_subset: "hyps_for n p |\<subseteq>| outPorts n"
    using hyps_for'_subset
    by (fastforce simp add: fmember.rep_eq hyps_for.rep_eq simp del: hyps_for_simp hyps_for_simp')
end

locale Labeled_Signature =
  Port_Graph_Signature_Scoped +
  fixes labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form"
  fixes labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"

locale Port_Graph_Signature_Scoped_Vars =
  Port_Graph_Signature nodes inPorts outPorts +
  Abstract_Formulas freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP
  for nodes :: "'node stream" and inPorts :: "'node \<Rightarrow> 'inPort fset"  and outPorts :: "'node \<Rightarrow> 'outPort fset"
  and  freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form" +

  fixes local_vars :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'var set"

end


theory Prelude_Bool
imports "$HETS_ISABELLE_LIB/MainHC"
uses "$HETS_ISABELLE_LIB/prelude"
begin

setup "Header.initialize
       [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
        \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
        \"notNot1\", \"notNot2\"]"

typedecl Bool

consts
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
notH__X :: "bool => bool" ("(notH/ _)" [56] 56)
otherwiseH :: "bool"

axioms
NotFalse [rule_format] : "notH False"

NotTrue [rule_format] : "~ notH True"

AndFalse [rule_format] : "ALL (x :: bool). ~ False && x"

AndTrue [rule_format] : "ALL (x :: bool). True && x = x"

AndSym [rule_format] :
"ALL (x :: bool). ALL (y :: bool). x && y = y && x"

OrDef [rule_format] :
"ALL (x :: bool).
 ALL (y :: bool). x || y = notH (notH x && notH y)"

OtherwiseDef [rule_format] : "otherwiseH"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]

theorem NotFalse1 : "ALL (x :: bool). notH x = (~ x)"
by (auto)

setup "Header.record \"NotFalse1\""

theorem NotTrue1 : "ALL (x :: bool). ~ notH x = x"
by (auto)

setup "Header.record \"NotTrue1\""

theorem notNot1 : "ALL (x :: bool). (~ x) = notH x"
by (auto)

setup "Header.record \"notNot1\""

theorem notNot2 : "ALL (x :: bool). (~ ~ x) = (~ notH x)"
apply(auto)
apply(case_tac x)
apply(auto)
done

setup "Header.record \"notNot2\""

end


theory mere_addition  (* Christoph Benzmüller, Xavier Parent, 2022  *)

imports cube

begin

consts a::\<sigma> aplus::\<sigma> b::\<sigma>

(*the mere addition scenario*)

axiomatization where
(* A is striclty better than B*)
 P0: "\<lfloor>(\<^bold>\<not>\<odot><\<^bold>\<not>a|a\<^bold>\<or>b>\<^bold>\<and>\<odot><\<^bold>\<not>b|a\<^bold>\<or>b>)\<rfloor>" and
(* Aplus is at least as good as A*)
 P1: "\<lfloor>\<^bold>\<not>\<odot><\<^bold>\<not>aplus|a\<^bold>\<or>aplus>\<rfloor>" and
(* B is strictly better than Aplus*)
 P2: "\<lfloor>(\<^bold>\<not>\<odot><\<^bold>\<not>b|aplus\<^bold>\<or>b> \<^bold>\<and> \<odot><\<^bold>\<not>aplus|aplus\<^bold>\<or>b>)\<rfloor>"

theorem TransIncons:
  assumes transitivity
  shows False
  by (metis P0 P1 P2 assms)
(* Sledgehammer finds P1-P3 inconsistent given transitivity of the
 betterness relation in the models*)

lemma True nitpick [satisfy, card i=3] oops (* Nitpick shows
consistency in the absence of transitivity*)

end

the following is some trash--I could not make it work with permission and > on formulas
lemma Transit: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<psi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<phi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  sledgehammer (*proof found -- this is not correct*) oops
  nitpick [show_all] oops

abbreviation epref  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("_\<ge>_") (* weak preference over formulas*)
  where "\<phi>\<ge>\<psi> \<equiv> \
<\<phi>|\<phi>\<or>\<psi>>"

lemma
  assumes "transitivity"
  and "\<lfloor>(\<ge>\<chi>) \<and> \<not>(\<chi>\<ge>\<phi>)\<rfloor>"
  and  "\<lfloor>(\<psi>\<ge>\<phi>)\<rfloor>"
  and "\<lfloor>(\<chi>\<ge>\<psi>) \<and> \<not>(\<psi>\<ge>\<chi>)\<rfloor>"
  shows False
  sledgehammer [user_axioms] oops
  nitpick


theory Incredible_Signatures
imports
  Main
  "HOL-Library.FSet"
  "HOL-Library.Stream"
  Abstract_Formula
begin

text \<open>This theory contains the definition for proof graph signatures, in the variants
\<^item> Plain port graph
\<^item> Port graph with local hypotheses
\<^item> Labeled port graph
\<^item> Port graph with local constants
\<close>

locale Port_Graph_Signature =
  fixes nodes :: "'node stream"
  fixes inPorts :: "'node \<Rightarrow> 'inPort fset"
  fixes outPorts :: "'node \<Rightarrow> 'outPort fset"

locale Port_Graph_Signature_Scoped =
  Port_Graph_Signature +
  fixes hyps :: "'node \<Rightarrow> 'outPort \<rightharpoonup> 'inPort"
  assumes hyps_correct: "hyps n p1 = Some p2 \<Longrightarrow> p1 |\<in>| outPorts n \<and> p2 |\<in>| inPorts n"
begin
  inductive_set hyps_for' :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'outPort set" for n p
    where "hyps n h = Some p \<Longrightarrow> h \<in> hyps_for' n p"

  lemma hyps_for'_subset: "hyps_for' n p \<subseteq> fset (outPorts n)"
    using hyps_correct by (meson hyps_for'.cases notin_fset subsetI)

  context includes fset.lifting
  begin
  lift_definition hyps_for  :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'outPort fset" is hyps_for'
    by (meson finite_fset hyps_for'_subset rev_finite_subset)
  lemma hyps_for_simp[simp]: "h |\<in>| hyps_for n p \<longleftrightarrow> hyps n h = Some p"
    by transfer (simp add: hyps_for'.simps)
  lemma hyps_for_simp'[simp]: "h \<in> fset (hyps_for n p) \<longleftrightarrow> hyps n h = Some p"
    by transfer (simp add: hyps_for'.simps)
  lemma hyps_for_collect: "fset (hyps_for n p) = {h . hyps n h = Some p}"
    by auto
  end
  lemma hyps_for_subset: "hyps_for n p |\<subseteq>| outPorts n"
    using hyps_for'_subset
    by (fastforce simp add: fmember_iff_member_fset hyps_for.rep_eq simp del: hyps_for_simp hyps_for_simp')
end

locale Labeled_Signature =
  Port_Graph_Signature_Scoped +
  fixes labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form"
  fixes labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"

locale Port_Graph_Signature_Scoped_Vars =
  Port_Graph_Signature nodes inPorts outPorts +
  Abstract_Formulas freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP
  for nodes :: "'node stream" and inPorts :: "'node \<Rightarrow> 'inPort fset"  and outPorts :: "'node \<Rightarrow> 'outPort fset"
  and  freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form" +

  fixes local_vars :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'var set"

end


theory Lprefix_antisym
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

coinductive lprefix :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> bool"
where
  LNil_lprefix: "lprefix LNil xs"
| Le_LCons: "lprefix xs ys \<Longrightarrow> lprefix (LCons x xs) (LCons x ys)"

(*hipster lprefix
Fails with
No code equations for lprefix *)

theorem lprefix_antisym:  "\<lbrakk> lprefix xs ys; lprefix ys xs \<rbrakk> \<Longrightarrow> xs = ys"
 by hipster_coinduct_sledgehammer

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_18
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
"rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

theorem property0 :
  "((rev (x (rev y) z)) = (x (rev z) y))"
  oops

end


theory Weak_Validity
imports
  Weak_Formula
  Validity
begin

section \<open>Weak Validity\<close>

text \<open>Weak formulas are a subset of (strong) formulas, and the definition of validity is simply
taken from the latter.  Here we prove some useful lemmas about the validity of weak modalities.
These are similar to corresponding lemmas about the validity of the (strong) action modality.\<close>

context indexed_weak_nominal_ts
begin

  lemma valid_weak_tau_modality_iff_tau_steps:
    "P \<Turnstile> weak_tau_modality x \<longleftrightarrow> (\<exists>n. P \<Turnstile> tau_steps x n)"
  unfolding weak_tau_modality_def by (auto simp add: map_bset.rep_eq)

  lemma tau_steps_iff_tau_transition:
    "(\<exists>n. P \<Turnstile> tau_steps x n) \<longleftrightarrow> (\<exists>P'. P \<Rightarrow> P' \<and> P' \<Turnstile> x)"
  proof
    assume "\<exists>n. P \<Turnstile> tau_steps x n"
    then obtain n where "P \<Turnstile> tau_steps x n"
      by meson
    then show "\<exists>P'. P \<Rightarrow> P' \<and> P' \<Turnstile> x"
      proof (induct n arbitrary: P)
        case 0
        then show ?case
          by simp (metis tau_refl)
      next
        case (Suc n)
        then obtain P' where "P \<rightarrow> \<langle>\<tau>, P'\<rangle>" and "P' \<Turnstile> tau_steps x n"
          by (auto simp add: valid_Act_fresh[OF bn_tau_fresh])
        with Suc.hyps show ?case
          using tau_step by blast
      qed
  next
    assume "\<exists>P'. P \<Rightarrow> P' \<and> P' \<Turnstile> x"
    then obtain P' where "P \<Rightarrow> P'" and "P' \<Turnstile> x"
      by meson
    then show "\<exists>n. P \<Turnstile> tau_steps x n"
      proof (induct)
        case (tau_refl P) then have "P \<Turnstile> tau_steps x 0"
          by simp
        then show ?case
          by meson
      next
        case (tau_step P P' P'')
        then obtain n where "P' \<Turnstile> tau_steps x n"
          by meson
        with \<open>P \<rightarrow> \<langle>\<tau>,P'\<rangle>\<close> have "P \<Turnstile> tau_steps x (Suc n)"
          by (auto simp add: valid_Act_fresh[OF bn_tau_fresh])
        then show ?case
          by meson
      qed
  qed

  lemma valid_weak_tau_modality:
    "P \<Turnstile> weak_tau_modality x \<longleftrightarrow> (\<exists>P'. P \<Rightarrow> P' \<and> P' \<Turnstile> x)"
  by (metis valid_weak_tau_modality_iff_tau_steps tau_steps_iff_tau_transition)

  lemma valid_weak_action_modality:
    "P \<Turnstile> (\<langle>\<langle>\<alpha>\<rangle>\<rangle>x) \<longleftrightarrow> (\<exists>\<alpha>' x' P'. Act \<alpha> x = Act \<alpha>' x' \<and> P \<Rightarrow>\<langle>\<alpha>'\<rangle> P' \<and> P' \<Turnstile> x')"
    (is "?l \<longleftrightarrow> ?r")
  proof (cases "\<alpha> = \<tau>")
    case True show ?thesis
    proof
      assume "?l"
      with \<open>\<alpha> = \<tau>\<close> obtain P' where trans: "P \<Rightarrow> P'" and valid: "P' \<Turnstile> x"
        by (metis valid_weak_tau_modality weak_action_modality_tau)
      from trans have "P \<Rightarrow>\<langle>\<tau>\<rangle> P'"
        by simp
      with \<open>\<alpha> = \<tau>\<close> and valid show "?r"
        by blast
    next
      assume "?r"
      then obtain \<alpha>' x' P' where eq: "Act \<alpha> x = Act \<alpha>' x'" and trans: "P \<Rightarrow>\<langle>\<alpha>'\<rangle> P'" and valid: "P' \<Turnstile> x'"
        by blast
      from eq have "\<alpha>' = \<tau> \<and> x' = x"
        using \<open>\<alpha> = \<tau>\<close> by simp
      with trans and valid have "P \<Rightarrow> P'" and "P' \<Turnstile> x"
        by simp+
      with \<open>\<alpha> = \<tau>\<close> show "?l"
        by (metis valid_weak_tau_modality weak_action_modality_tau)
    qed
  next
    case False show ?thesis
    proof
      assume "?l"
      with \<open>\<alpha> \<noteq> \<tau>\<close> obtain Q where trans: "P \<Rightarrow> Q" and valid: "Q \<Turnstile> Act \<alpha> (weak_tau_modality x)"
        by (metis valid_weak_tau_modality weak_action_modality_not_tau)
      from valid obtain \<alpha>' x' Q' where eq: "Act \<alpha> (weak_tau_modality x) = Act \<alpha>' x'" and trans': "Q \<rightarrow> \<langle>\<alpha>',Q'\<rangle>" and valid': "Q' \<Turnstile> x'"
        by (metis valid_Act)

      from eq obtain p where p_\<alpha>: "\<alpha>' = p \<bullet> \<alpha>" and p_x: "x' = p \<bullet> weak_tau_modality x"
        by (metis Act_eq_iff_perm)
      with eq have "Act \<alpha> x = Act \<alpha>' (p \<bullet> x)"
        using Act_weak_tau_modality_eq_iff by simp

      moreover from valid' and p_x have "Q' \<Turnstile> weak_tau_modality (p \<bullet> x)"
        by simp
      then obtain P' where trans'': "Q' \<Rightarrow> P'" and valid'': "P' \<Turnstile> p \<bullet> x"
        by (metis valid_weak_tau_modality)
      from trans and trans' and trans'' have "P \<Rightarrow>\<langle>\<alpha>'\<rangle> P'"
        by (metis observable_transitionI weak_transition_stepI)
      ultimately show "?r"
        using valid'' by blast
    next
      assume "?r"
      then obtain \<alpha>' x' P' where eq: "Act \<alpha> x = Act \<alpha>' x'" and trans: "P \<Rightarrow>\<langle>\<alpha>'\<rangle> P'" and valid: "P' \<Turnstile> x'"
        by blast
      with \<open>\<alpha> \<noteq> \<tau>\<close> have \<alpha>': "\<alpha>' \<noteq> \<tau>"
        using eq by (metis Act_tau_eq_iff)
      with trans obtain Q Q' where trans': "P \<Rightarrow> Q" and trans'': "Q \<rightarrow> \<langle>\<alpha>',Q'\<rangle>" and trans''': "Q' \<Rightarrow> P'"
        by (meson observable_transition_def weak_transition_def)
      from trans''' and valid have "Q' \<Turnstile> weak_tau_modality x'"
        by (metis valid_weak_tau_modality)
      with trans'' have "Q \<Turnstile> Act \<alpha>' (weak_tau_modality x')"
        by (metis valid_Act)
      with trans' and \<alpha>' have "P \<Turnstile> \<langle>\<langle>\<alpha>'\<rangle>\<rangle>x'"
        by (metis valid_weak_tau_modality weak_action_modality_not_tau)
      moreover from eq have "(\<langle>\<langle>\<alpha>\<rangle>\<rangle>x) = (\<langle>\<langle>\<alpha>'\<rangle>\<rangle>x')"
        by (metis weak_action_modality_eq)
      ultimately show "?l"
        by simp
    qed
  qed

  text \<open>The binding names in the alpha-variant that witnesses validity may be chosen fresh for any
  finitely supported context.\<close>

  lemma valid_weak_action_modality_strong:
    assumes "finite (supp X)"
    shows "P \<Turnstile> (\<langle>\<langle>\<alpha>\<rangle>\<rangle>x) \<longleftrightarrow> (\<exists>\<alpha>' x' P'. Act \<alpha> x = Act \<alpha>' x' \<and> P \<Rightarrow>\<langle>\<alpha>'\<rangle> P' \<and> P' \<Turnstile> x' \<and> bn \<alpha>' \<sharp>* X)"
  proof
    assume "P \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"
    then obtain \<alpha>' x' P' where eq: "Act \<alpha> x = Act \<alpha>' x'" and trans: "P \<Rightarrow>\<langle>\<alpha>'\<rangle> P'" and valid: "P' \<Turnstile> x'"
      by (metis valid_weak_action_modality)
    show "\<exists>\<alpha>' x' P'. Act \<alpha> x = Act \<alpha>' x' \<and> P \<Rightarrow>\<langle>\<alpha>'\<rangle> P' \<and> P' \<Turnstile> x' \<and> bn \<alpha>' \<sharp>* X"
      proof (cases "\<alpha>' = \<tau>")
        case True
        then show ?thesis
          using eq and trans and valid and bn_tau_fresh by blast
      next
        case False
        with trans obtain Q Q' where trans': "P \<Rightarrow> Q" and trans'': "Q \<rightarrow> \<langle>\<alpha>', Q'\<rangle>" and trans''': "Q' \<Rightarrow> P'"
          by (metis weak_transition_def observable_transition_def)
        have "finite (bn \<alpha>')"
          by (fact bn_finite)
        moreover note \<open>finite (supp X)\<close>
        moreover have "finite (supp (Act \<alpha>' x', \<langle>\<alpha>',Q'\<rangle>))"
          by (metis finite_Diff finite_UnI finite_supp supp_Pair supp_abs_residual_pair)
        moreover have "bn \<alpha>' \<sharp>* (Act \<alpha>' x', \<langle>\<alpha>',Q'\<rangle>)"
          by (auto simp add: fresh_star_def fresh_def supp_Pair supp_abs_residual_pair)
        ultimately obtain p where fresh_X: "(p \<bullet> bn \<alpha>') \<sharp>* X" and "supp (Act \<alpha>' x', \<langle>\<alpha>',Q'\<rangle>) \<sharp>* p"
          by (metis at_set_avoiding2)
        then have "supp (Act \<alpha>' x') \<sharp>* p" and "supp \<langle>\<alpha>',Q'\<rangle> \<sharp>* p"
          by (metis fresh_star_Un supp_Pair)+
        then have 1: "Act (p \<bullet> \<alpha>') (p \<bullet> x') = Act \<alpha>' x'" and 2: "\<langle>p \<bullet> \<alpha>', p \<bullet> Q'\<rangle> = \<langle>\<alpha>',Q'\<rangle>"
          by (metis Act_eqvt supp_perm_eq, metis abs_residual_pair_eqvt supp_perm_eq)
        from trans' and trans'' and trans''' have "P \<Rightarrow>\<langle>p \<bullet> \<alpha>'\<rangle> (p \<bullet> P')"
          using 2 by (metis observable_transitionI tau_transition_eqvt weak_transition_stepI)
        then show ?thesis
          using eq and 1 and valid and fresh_X by (metis bn_eqvt valid_eqvt)
      qed
  next
    assume "\<exists>\<alpha>' x' P'. Act \<alpha> x = Act \<alpha>' x' \<and> P \<Rightarrow>\<langle>\<alpha>'\<rangle> P' \<and> P' \<Turnstile> x' \<and> bn \<alpha>' \<sharp>* X"
    then show "P \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"
      by (metis valid_weak_action_modality)
  qed

  lemma valid_weak_action_modality_fresh:
    assumes "bn \<alpha> \<sharp>* P"
    shows "P \<Turnstile> (\<langle>\<langle>\<alpha>\<rangle>\<rangle>x) \<longleftrightarrow> (\<exists>P'. P \<Rightarrow>\<langle>\<alpha>\<rangle> P' \<and> P' \<Turnstile> x)"
  proof
    assume "P \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"

    moreover have "finite (supp P)"
      by (fact finite_supp)
    ultimately obtain \<alpha>' x' P' where
      eq: "Act \<alpha> x = Act \<alpha>' x'" and trans: "P \<Rightarrow>\<langle>\<alpha>'\<rangle> P'" and valid: "P' \<Turnstile> x'" and fresh: "bn \<alpha>' \<sharp>* P"
      by (metis valid_weak_action_modality_strong)

    from eq obtain p where p_\<alpha>: "\<alpha>' = p \<bullet> \<alpha>" and p_x: "x' = p \<bullet> x" and supp_p: "supp p \<subseteq> bn \<alpha> \<union> p \<bullet> bn \<alpha>"
      by (metis Act_eq_iff_perm_renaming)

    from assms and fresh have "(bn \<alpha> \<union> p \<bullet> bn \<alpha>) \<sharp>* P"
      using p_\<alpha> by (metis bn_eqvt fresh_star_Un)
    then have "supp p \<sharp>* P"
      using supp_p by (metis fresh_star_def subset_eq)
    then have p_P: "-p \<bullet> P = P"
      by (metis perm_supp_eq supp_minus_perm)

    from trans have "P \<Rightarrow>\<langle>\<alpha>\<rangle> (-p \<bullet> P')"
      using p_P p_\<alpha> by (metis permute_minus_cancel(1) weak_transition_eqvt)
    moreover from valid have "-p \<bullet> P' \<Turnstile> x"
      using p_x by (metis permute_minus_cancel(1) valid_eqvt)
    ultimately show "\<exists>P'. P \<Rightarrow>\<langle>\<alpha>\<rangle> P' \<and> P' \<Turnstile> x"
      by meson
  next
    assume "\<exists>P'. P \<Rightarrow>\<langle>\<alpha>\<rangle> P' \<and> P' \<Turnstile> x" then show "P \<Turnstile> \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"
      by (metis valid_weak_action_modality)
  qed

end

end