section "Assertions"

theory Assertions
imports
  "../Imperative_HOL_Time/Imperative_HOL_Time"
  (*"Tools/Imperative_HOL_Add" *)
  "Tools/Syntax_Match"
  Automatic_Refinement.Misc
begin

subsection \<open>Partial Heaps\<close>
text \<open>
  A partial heap is modeled by a heap and a set of valid addresses, with the
  side condition that the valid addresses have to be within the limit of the
  heap. This modeling is somewhat strange for separation logic, however, it
  allows us to solve some technical problems related to definition of
  Hoare triples, that will be detailed later.
\<close>
type_synonym pheap = "heap \<times> addr set"

text \<open>Predicate that expresses that the address set of a partial heap is
  within the heap's limit.
\<close>
fun in_range :: "(heap \<times> addr set) \<Rightarrow> bool"
  where "in_range (h,as) \<longleftrightarrow> (\<forall>a\<in>as. a < lim h)"

declare in_range.simps[simp del]

lemma in_range_empty[simp, intro!]: "in_range (h,{})"
  by (auto simp: in_range.simps)

lemma in_range_dist_union[simp]:
  "in_range (h,as \<union> as') \<longleftrightarrow> in_range (h,as) \<and> in_range (h,as')"
  by (auto simp: in_range.simps)

lemma in_range_subset:
  "\<lbrakk>as \<subseteq> as'; in_range (h,as')\<rbrakk> \<Longrightarrow> in_range (h,as)"
  by (auto simp: in_range.simps)

text \<open>Relation that holds if two heaps are identical on a given
  address range\<close>
definition relH :: "addr set \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> bool"
  where "relH as h h' \<equiv>
  in_range (h,as)
  \<and> in_range (h',as)
  \<and> (\<forall>t. \<forall>a \<in> as.
        refs h t a = refs h' t a
      \<and> arrays h t a = arrays h' t a
    )"

lemma relH_in_rangeI:
  assumes "relH as h h'"
  shows "in_range (h,as)" and "in_range (h',as)"
  using assms unfolding relH_def by auto

text "Reflexivity"
lemma relH_refl: "in_range (h,as) \<Longrightarrow> relH as h h"
  unfolding relH_def by simp

text "Symmetry"
lemma relH_sym: "relH as h h' \<Longrightarrow> relH as h' h"
  unfolding relH_def
  by auto

text "Transitivity"
lemma relH_trans[trans]: "\<lbrakk>relH as h1 h2; relH as h2 h3\<rbrakk> \<Longrightarrow> relH as h1 h3"
  unfolding relH_def
  by auto

lemma relH_dist_union[simp]:
  "relH (as\<union>as') h h' \<longleftrightarrow> relH as h h' \<and> relH as' h h'"
  unfolding relH_def
  by auto

lemma relH_subset:
  assumes "relH bs h h'"
  assumes "as \<subseteq> bs"
  shows "relH as h h'"
  using assms unfolding relH_def by (auto intro: in_range_subset)

lemma relH_ref:
  assumes "relH as h h'"
  assumes "addr_of_ref r \<in> as"
  shows "Ref_Time.get h r = Ref_Time.get h' r"
  using assms unfolding relH_def Ref_Time.get_def by auto

lemma relH_array:
  assumes "relH as h h'"
  assumes "addr_of_array r \<in> as"
  shows "Array_Time.get h r = Array_Time.get h' r"
  using assms unfolding relH_def Array_Time.get_def by auto

lemma relH_set_ref: "\<lbrakk> addr_of_ref r \<notin> as; in_range (h,as)\<rbrakk>
  \<Longrightarrow> relH as h (Ref_Time.set r x h)"
  unfolding relH_def Ref_Time.set_def
  by (auto simp: in_range.simps)

lemma relH_set_array: "\<lbrakk>addr_of_array r \<notin> as; in_range (h,as)\<rbrakk>
  \<Longrightarrow> relH as h (Array_Time.set r x h)"
  unfolding relH_def Array_Time.set_def
  by (auto simp: in_range.simps)

subsection \<open>Assertions\<close>
text \<open>
  Assertions are predicates on partial heaps, that fulfill a well-formedness
  condition called properness: They only depend on the part of the heap
  by the address set, and must be false for partial heaps that are not in range.
\<close>
type_synonym assn_raw = "pheap \<Rightarrow> bool"

definition proper :: "assn_raw \<Rightarrow> bool" where
  "proper P \<equiv> \<forall>h h' as. (P (h,as) \<longrightarrow> in_range (h,as))
    \<and> (P (h,as) \<and> relH as h h' \<and> in_range (h',as) \<longrightarrow> P (h',as))"

lemma properI[intro?]:
  assumes "\<And>as h. P (h,as) \<Longrightarrow> in_range (h,as)"
  assumes "\<And>as h h'.
    \<lbrakk>P (h,as); relH as h h'; in_range (h',as)\<rbrakk> \<Longrightarrow> P (h',as)"
  shows "proper P"
  unfolding proper_def using assms by blast

lemma properD1:
  assumes "proper P"
  assumes "P (h,as)"
  shows "in_range (h,as)"
  using assms unfolding proper_def by blast

lemma properD2:
  assumes "proper P"
  assumes "P (h,as)"
  assumes "relH as h h'"
  assumes "in_range (h',as)"
  shows "P (h',as)"
  using assms unfolding proper_def by blast

lemmas properD = properD1 properD2

lemma proper_iff:
  assumes "proper P"
  assumes "relH as h h'"
  assumes "in_range (h',as)"
  shows "P (h,as) \<longleftrightarrow> P (h',as)"
  using assms
  by (metis properD2 relH_in_rangeI(1) relH_sym)

text \<open>We encapsulate assertions in their own type\<close>
typedef assn = "Collect proper"
  apply simp
  unfolding proper_def
  by fastforce

lemmas [simp] = Rep_assn_inverse Rep_assn_inject
lemmas [simp, intro!] = Rep_assn[unfolded mem_Collect_eq]

lemma Abs_assn_eqI[intro?]:
  "(\<And>h. P h = Rep_assn Pr h) \<Longrightarrow> Abs_assn P = Pr"
  "(\<And>h. P h = Rep_assn Pr h) \<Longrightarrow> Pr = Abs_assn P"
  by (metis Rep_assn_inverse predicate1I xt1(5))+

abbreviation models :: "pheap \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Turnstile>" 50)
  where "h\<Turnstile>P \<equiv> Rep_assn P h"

lemma models_in_range: "h\<Turnstile>P \<Longrightarrow> in_range h"
  apply (cases h)
  by (metis mem_Collect_eq Rep_assn properD1)

subsubsection \<open>Empty Partial Heap\<close>
text \<open>The empty partial heap satisfies some special properties.
  We set up a simplification that tries to rewrite it to the standard
  empty partial heap \<open>h\<^sub>\<bottom>\<close>\<close>
abbreviation h_bot ("h\<^sub>\<bottom>") where "h\<^sub>\<bottom> \<equiv> (undefined,{})"
lemma mod_h_bot_indep: "(h,{})\<Turnstile>P \<longleftrightarrow> (h',{})\<Turnstile>P"
  by (metis mem_Collect_eq Rep_assn emptyE in_range_empty
    proper_iff relH_def)

lemma mod_h_bot_normalize[simp]:
  "syntax_fo_nomatch undefined h \<Longrightarrow> (h,{})\<Turnstile>P \<longleftrightarrow> h\<^sub>\<bottom> \<Turnstile> P"
  using mod_h_bot_indep[where h'=undefined] by simp

text \<open>Properness, lifted to the assertion type.\<close>
lemma mod_relH: "relH as h h' \<Longrightarrow> (h,as)\<Turnstile>P \<longleftrightarrow> (h',as)\<Turnstile>P"
  by (metis mem_Collect_eq Rep_assn proper_iff relH_in_rangeI(2))

subsection \<open>Connectives\<close>
text \<open>
  We define several operations on assertions, and instantiate some type classes.
\<close>

subsubsection \<open>Empty Heap and Separation Conjunction\<close>
text \<open>The assertion that describes the empty heap, and the separation
  conjunction form a commutative monoid:\<close>
instantiation assn :: one begin
  fun one_assn_raw :: "pheap \<Rightarrow> bool"
    where "one_assn_raw (h,as) \<longleftrightarrow> as={}"

  lemma one_assn_proper[intro!,simp]: "proper one_assn_raw"
    by (auto intro!: properI)

  definition one_assn :: assn where "1 \<equiv> Abs_assn one_assn_raw"
  instance ..
end

abbreviation one_assn::assn ("emp") where "one_assn \<equiv> 1"

instantiation assn :: times begin
  fun times_assn_raw :: "assn_raw \<Rightarrow> assn_raw \<Rightarrow> assn_raw" where
    "times_assn_raw P Q (h,as)
    = (\<exists>as1 as2. as=as1\<union>as2 \<and> as1\<inter>as2={}
        \<and> P (h,as1) \<and> Q (h,as2))"

  lemma times_assn_proper[intro!,simp]:
    "proper P \<Longrightarrow> proper Q \<Longrightarrow> proper (times_assn_raw P Q)"
    apply (rule properI)
    apply (auto dest: properD1) []
    apply clarsimp
    apply (drule (3) properD2)
    apply (drule (3) properD2)
    apply blast
    done

  definition times_assn where "P*Q \<equiv>
    Abs_assn (times_assn_raw (Rep_assn P) (Rep_assn Q))"

  instance ..
end

lemma mod_starD: "h\<Turnstile>A*B \<Longrightarrow> \<exists>h1 h2. h1\<Turnstile>A \<and> h2\<Turnstile>B"
  by (auto simp: mod_star_conv)

lemma mod_starE:
  assumes "h \<Turnstile> a*b"
  obtains h\<^sub>1 h\<^sub>2 where "h\<^sub>1 \<Turnstile> a" "h\<^sub>2 \<Turnstile> b"
  using assms by (auto dest: mod_starD)

lemma star_assnI:
  assumes "(h,as)\<Turnstile>P" and "(h,as')\<Turnstile>Q" and "as\<inter>as'={}"
  shows "(h,as\<union>as')\<Turnstile>P*Q"
  using assms unfolding times_assn_def
  by (auto simp: Abs_assn_inverse)

instantiation assn :: comm_monoid_mult begin
  lemma assn_one_left: "1*P = (P::assn)"
    unfolding one_assn_def times_assn_def
    apply (rule)
    apply (auto simp: Abs_assn_inverse)
    done

  lemma assn_times_comm: "P*Q = Q*(P::assn)"
    unfolding times_assn_def
    apply rule
    apply (fastforce simp add: Abs_assn_inverse Un_ac)
    done

  lemma assn_times_assoc: "(P*Q)*R = P*(Q*(R::assn))"
    unfolding times_assn_def
    apply rule
    apply (auto simp: Abs_assn_inverse)
    apply (rule_tac x="as1\<union>as1a" in exI)
    apply (rule_tac x="as2a" in exI)
    apply (auto simp add: Un_ac) []

    apply (rule_tac x="as1a" in exI)
    apply (rule_tac x="as2a\<union>as2" in exI)
    apply (fastforce simp add: Un_ac) []
    done

  instance
    apply standard
    apply (rule assn_times_assoc)
    apply (rule assn_times_comm)
    apply (rule assn_one_left)
    done

end

subsubsection \<open>Magic Wand\<close>
fun wand_raw :: "assn_raw \<Rightarrow> assn_raw \<Rightarrow> assn_raw" where
  "wand_raw P Q (h,as) \<longleftrightarrow> in_range (h,as)
  \<and> (\<forall>h' as'. as\<inter>as'={} \<and> relH as h h' \<and> in_range (h',as)
    \<and> P (h',as')
    \<longrightarrow> Q (h',as\<union>as'))"

lemma wand_proper[simp, intro!]: "proper (wand_raw P Q)"
  apply (rule properI)
  apply simp
  apply (auto dest: relH_trans)
  done

definition
  wand_assn :: "assn \<Rightarrow> assn \<Rightarrow> assn" (infixl "-*" 56)
  where "P-*Q \<equiv> Abs_assn (wand_raw (Rep_assn P) (Rep_assn Q))"

lemma wand_assnI:
  assumes "in_range (h,as)"
  assumes "\<And>h' as'. \<lbrakk>
    as \<inter> as' = {};
    relH as h h';
    in_range (h',as);
    (h',as')\<Turnstile>Q
  \<rbrakk> \<Longrightarrow> (h',as\<union>as') \<Turnstile> R"
  shows "(h,as) \<Turnstile> Q -* R"
  using assms
  unfolding wand_assn_def
  apply (auto simp: Abs_assn_inverse)
  done

subsubsection \<open>Boolean Algebra on Assertions\<close>
instantiation assn :: boolean_algebra begin
  definition top_assn where "top \<equiv> Abs_assn in_range"
  definition bot_assn where "bot \<equiv> Abs_assn (\<lambda>_. False)"
  definition sup_assn where "sup P Q \<equiv> Abs_assn (\<lambda>h. h\<Turnstile>P \<or> h\<Turnstile>Q)"
  definition inf_assn where "inf P Q \<equiv> Abs_assn (\<lambda>h. h\<Turnstile>P \<and> h\<Turnstile>Q)"
  definition uminus_assn where
    "-P \<equiv> Abs_assn (\<lambda>h. in_range h \<and> \<not>h\<Turnstile>P)"

  lemma bool_assn_proper[simp, intro!]:
    "proper in_range"
    "proper (\<lambda>_. False)"
    "proper P \<Longrightarrow> proper Q \<Longrightarrow> proper (\<lambda>h. P h \<or> Q h)"
    "proper P \<Longrightarrow> proper Q \<Longrightarrow> proper (\<lambda>h. P h \<and> Q h)"
    "proper P \<Longrightarrow> proper (\<lambda>h. in_range h \<and> \<not>P h)"
    apply (auto
      intro!: properI
      intro: relH_in_rangeI
      dest: properD1
      simp: proper_iff)
    done

  text \<open>(And, Or, True, False, Not) are a Boolean algebra.
    Due to idiosyncrasies of the Isabelle/HOL class setup, we have to
    also define a difference and an ordering:\<close>
  definition less_eq_assn where
  [simp]: "(a::assn) \<le> b \<equiv> a = inf a b"

  definition less_assn where
  [simp]: "(a::assn) < b \<equiv> a \<le> b \<and> a\<noteq>b"

  definition minus_assn where
  [simp]: "(a::assn) - b \<equiv> inf a (-b)"

  instance
    apply standard
    unfolding
      top_assn_def bot_assn_def sup_assn_def inf_assn_def uminus_assn_def
      less_eq_assn_def less_assn_def minus_assn_def
    apply (auto
      simp: Abs_assn_inverse conj_commute conj_ac
      intro: Abs_assn_eqI models_in_range)
    apply rule
    apply (metis (mono_tags) Abs_assn_inverse[unfolded mem_Collect_eq]
      Rep_assn[unfolded mem_Collect_eq] bool_assn_proper(4))
    apply rule
    apply (metis (mono_tags)
      Abs_assn_inverse[unfolded mem_Collect_eq]
      Rep_assn[unfolded mem_Collect_eq] bool_assn_proper(4))
    apply rule
    apply (simp add: Abs_assn_inverse)
    apply (metis (mono_tags)
      Abs_assn_inverse[unfolded mem_Collect_eq]
      Rep_assn[unfolded mem_Collect_eq] bool_assn_proper(4))
    done

end

text \<open>We give the operations some more standard names\<close>
abbreviation top_assn::assn ("true") where "top_assn \<equiv> top"
abbreviation bot_assn::assn ("false") where "bot_assn \<equiv> bot"
abbreviation sup_assn::"assn\<Rightarrow>assn\<Rightarrow>assn" (infixr "\<or>\<^sub>A" 61)
  where "sup_assn \<equiv> sup"
abbreviation inf_assn::"assn\<Rightarrow>assn\<Rightarrow>assn" (infixr "\<and>\<^sub>A" 62)
  where "inf_assn \<equiv> inf"
abbreviation uminus_assn::"assn \<Rightarrow> assn" ("\<not>\<^sub>A _" [81] 80)
  where "uminus_assn \<equiv> uminus"

text \<open>Now we prove some relations between the Boolean algebra operations
  and the (empty heap,separation conjunction) monoid\<close>

lemma star_false_left[simp]: "false * P = false"
  unfolding times_assn_def bot_assn_def
  apply rule
  apply (auto simp add: Abs_assn_inverse)
  done

lemma star_false_right[simp]: "P * false = false"
  using star_false_left by (simp add: assn_times_comm)

lemmas star_false = star_false_left star_false_right

lemma assn_basic_inequalities[simp, intro!]:
  "true \<noteq> emp" "emp \<noteq> true"
  "false \<noteq> emp" "emp \<noteq> false"
  "true \<noteq> false" "false \<noteq> true"
  subgoal
    unfolding one_assn_def top_assn_def
    proof (subst Abs_assn_inject; simp?)
      have "in_range (\<lparr>arrays = (\<lambda>_ _. []), refs = (\<lambda>_ _. 0), lim = 1\<rparr>,{0})" (is "in_range ?h")
        by (auto simp: in_range.simps)
      moreover have "\<not>one_assn_raw ?h" by auto
      ultimately show "in_range \<noteq> one_assn_raw" by auto
    qed
  subgoal
    by (simp add: \<open>true \<noteq> emp\<close>)
  subgoal
  using star_false_left \<open>true \<noteq> emp\<close> by force
  subgoal
    by (simp add: \<open>false \<noteq> emp\<close>)
  subgoal
    by (metis inf_bot_right inf_top.right_neutral \<open>true \<noteq> emp\<close>)
  subgoal
    using \<open>true \<noteq> false\<close> by auto
  done

subsubsection \<open>Existential Quantification\<close>
definition ex_assn :: "('a \<Rightarrow> assn) \<Rightarrow> assn" (binder "\<exists>\<^sub>A" 11)
  where "(\<exists>\<^sub>Ax. P x) \<equiv> Abs_assn (\<lambda>h. \<exists>x. h\<Turnstile>P x)"

lemma ex_assn_proper[simp, intro!]:
  "(\<And>x. proper (P x)) \<Longrightarrow> proper (\<lambda>h. \<exists>x. P x h)"
  by (auto intro!: properI dest: properD1 simp: proper_iff)

lemma ex_assn_const[simp]: "(\<exists>\<^sub>Ax. c) = c"
  unfolding ex_assn_def by auto

lemma ex_one_point_gen:
  "\<lbrakk>\<And>h x. h\<Turnstile>P x \<Longrightarrow> x=v\<rbrakk> \<Longrightarrow> (\<exists>\<^sub>Ax. P x) = (P v)"
  unfolding ex_assn_def
  apply rule
  apply auto
  done

lemma ex_distrib_star: "(\<exists>\<^sub>Ax. P x * Q) = (\<exists>\<^sub>Ax. P x) * Q"
  unfolding ex_assn_def times_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

lemma ex_distrib_and: "(\<exists>\<^sub>Ax. P x \<and>\<^sub>A Q) = (\<exists>\<^sub>Ax. P x) \<and>\<^sub>A Q"
  unfolding ex_assn_def inf_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  done

lemma ex_distrib_or: "(\<exists>\<^sub>Ax. P x \<or>\<^sub>A Q) = (\<exists>\<^sub>Ax. P x) \<or>\<^sub>A Q"
  unfolding ex_assn_def sup_assn_def
  apply rule
  apply (auto simp add: Abs_assn_inverse)
  done

lemma ex_join_or: "(\<exists>\<^sub>Ax. P x \<or>\<^sub>A (\<exists>\<^sub>Ax. Q x)) = (\<exists>\<^sub>Ax. P x \<or>\<^sub>A Q x)"
  unfolding ex_assn_def sup_assn_def
  apply rule
  apply (auto simp add: Abs_assn_inverse)
  done

subsubsection \<open>Pure Assertions\<close>
text \<open>Pure assertions do not depend on any heap content.\<close>
fun pure_assn_raw where "pure_assn_raw b (h,as) \<longleftrightarrow> as={} \<and> b"
definition pure_assn :: "bool \<Rightarrow> assn" ("\<up>") where
  "\<up>b \<equiv> Abs_assn (pure_assn_raw b)"

lemma pure_assn_proper[simp, intro!]: "proper (pure_assn_raw b)"
  by (auto intro!: properI intro: relH_in_rangeI)

lemma pure_true[simp]: "\<up>True = emp"
  unfolding pure_assn_def one_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  apply (auto)
  done

lemma pure_false[simp]: "\<up>False = false"
  unfolding pure_assn_def bot_assn_def
  apply rule
  apply (auto simp: Abs_assn_inverse)
  done

lemma pure_assn_eq_false_iff[simp]: "\<up>P = false \<longleftrightarrow> \<not>P" by auto

lemma pure_assn_eq_emp_iff[simp]: "\<up>P = emp \<longleftrightarrow> P" by (cases P) auto

lemma merge_pure_star[simp]:
  "\<up>a * \<up>b = \<up>(a\<and>b)"
  unfolding times_assn_def
  apply rule
  unfolding pure_assn_def
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

lemma merge_true_star[simp]: "true*true = true"
  unfolding times_assn_def top_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  apply (fastforce simp: in_range.simps)
  done

lemma merge_pure_and[simp]:
  "\<up>a \<and>\<^sub>A \<up>b = \<up>(a\<and>b)"
  unfolding inf_assn_def
  apply rule
  unfolding pure_assn_def
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

lemma merge_pure_or[simp]:
  "\<up>a \<or>\<^sub>A \<up>b = \<up>(a\<or>b)"
  unfolding sup_assn_def
  apply rule
  unfolding pure_assn_def
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

lemma pure_assn_eq_conv[simp]: "\<up>P = \<up>Q \<longleftrightarrow> P=Q" by auto

definition "is_pure_assn a \<equiv> \<exists>P. a=\<up>P"
lemma is_pure_assnE: assumes "is_pure_assn a" obtains P where "a=\<up>P"
  using assms
  by (auto simp: is_pure_assn_def)

lemma is_pure_assn_pure[simp, intro!]: "is_pure_assn (\<up>P)"
  by (auto simp add: is_pure_assn_def)

lemma is_pure_assn_basic_simps[simp]:
  "is_pure_assn false"
  "is_pure_assn emp"
proof -
  have "is_pure_assn (\<up>False)" by rule thus "is_pure_assn false" by simp
  have "is_pure_assn (\<up>True)" by rule thus "is_pure_assn emp" by simp
qed

lemma is_pure_assn_starI[simp,intro!]:
  "\<lbrakk>is_pure_assn a; is_pure_assn b\<rbrakk> \<Longrightarrow> is_pure_assn (a*b)"
  by (auto elim!: is_pure_assnE)

subsubsection \<open>Pointers\<close>
text \<open>In Imperative HOL, we have to distinguish between pointers to single
  values and pointers to arrays. For both, we define assertions that
  describe the part of the heap that a pointer points to.\<close>
fun sngr_assn_raw :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> assn_raw" where
  "sngr_assn_raw r x (h,as) \<longleftrightarrow> Ref_Time.get h r = x \<and> as = {addr_of_ref r} \<and>
  addr_of_ref r < lim h"

lemma sngr_assn_proper[simp, intro!]: "proper (sngr_assn_raw r x)"
  apply (auto intro!: properI simp: relH_ref)
  apply (simp add: in_range.simps)
  apply (auto simp add: in_range.simps dest: relH_in_rangeI)
  done

definition sngr_assn :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> assn" (infix "\<mapsto>\<^sub>r" 82)
  where "r\<mapsto>\<^sub>rx \<equiv> Abs_assn (sngr_assn_raw r x)"

fun snga_assn_raw :: "'a::heap array \<Rightarrow> 'a list \<Rightarrow> assn_raw"
  where "snga_assn_raw r x (h,as)
  \<longleftrightarrow> Array_Time.get h r = x \<and> as = {addr_of_array r}
      \<and> addr_of_array r < lim h"

lemma snga_assn_proper[simp, intro!]: "proper (snga_assn_raw r x)"
  apply (auto intro!: properI simp: relH_array)
  apply (simp add: in_range.simps)
  apply (auto simp add: in_range.simps dest: relH_in_rangeI)
  done

definition
  snga_assn :: "'a::heap array \<Rightarrow> 'a list \<Rightarrow> assn" (infix "\<mapsto>\<^sub>a" 82)
  where "r\<mapsto>\<^sub>aa \<equiv> Abs_assn (snga_assn_raw r a)"

text \<open>Two disjoint parts of the heap cannot be pointed to by the
  same pointer\<close>
lemma sngr_same_false[simp]:
  "p \<mapsto>\<^sub>r x * p \<mapsto>\<^sub>r y = false"
  unfolding times_assn_def bot_assn_def sngr_assn_def
  apply rule
  apply (auto simp: Abs_assn_inverse)
  done

lemma snga_same_false[simp]:
  "p \<mapsto>\<^sub>a x * p \<mapsto>\<^sub>a y = false"
  unfolding times_assn_def bot_assn_def snga_assn_def
  apply rule
  apply (auto simp: Abs_assn_inverse)
  done

subsection \<open>Properties of the Models-Predicate\<close>
lemma mod_true[simp]: "h\<Turnstile>true \<longleftrightarrow> in_range h"
  unfolding top_assn_def by (simp add: Abs_assn_inverse)
lemma mod_false[simp]: "\<not> h\<Turnstile>false"
  unfolding bot_assn_def by (simp add: Abs_assn_inverse)

lemma mod_emp: "h\<Turnstile>emp \<longleftrightarrow> snd h = {}"
  unfolding one_assn_def by (cases h) (simp add: Abs_assn_inverse)

lemma mod_emp_simp[simp]: "(h,{})\<Turnstile>emp"
  by (simp add: mod_emp)

lemma mod_pure[simp]: "h\<Turnstile>\<up>b \<longleftrightarrow> snd h = {} \<and> b"
  unfolding pure_assn_def
  apply (cases h)
  apply (auto simp add: Abs_assn_inverse)
  done

lemma mod_ex_dist[simp]: "h\<Turnstile>(\<exists>\<^sub>Ax. P x) \<longleftrightarrow> (\<exists>x. h\<Turnstile>P x)"
  unfolding ex_assn_def by (auto simp: Abs_assn_inverse)

lemma mod_exI: "\<exists>x. h\<Turnstile>P x \<Longrightarrow> h\<Turnstile>(\<exists>\<^sub>Ax. P x)"
  by (auto simp: mod_ex_dist)
lemma mod_exE: assumes "h\<Turnstile>(\<exists>\<^sub>Ax. P x)" obtains x where "h\<Turnstile>P x"
  using assms by (auto simp: mod_ex_dist)

(* Not declared as simp, to not interfere with precision.
  TODO: Perhaps define own connector for precision claims?
*)
lemma mod_and_dist: "h\<Turnstile>P\<and>\<^sub>AQ \<longleftrightarrow> h\<Turnstile>P \<and> h\<Turnstile>Q"
  unfolding inf_assn_def by (simp add: Abs_assn_inverse)

lemma mod_or_dist[simp]: "h\<Turnstile>P\<or>\<^sub>AQ \<longleftrightarrow> h\<Turnstile>P \<or> h\<Turnstile>Q"
  unfolding sup_assn_def by (simp add: Abs_assn_inverse)

lemma mod_not_dist[simp]: "h\<Turnstile>(\<not>\<^sub>AP) \<longleftrightarrow> in_range h \<and> \<not> h\<Turnstile>P"
  unfolding uminus_assn_def by (simp add: Abs_assn_inverse)

lemma mod_pure_star_dist[simp]: "h\<Turnstile>P*\<up>b \<longleftrightarrow> h\<Turnstile>P \<and> b"
  by (metis (full_types) mod_false mult_1_right pure_false
    pure_true star_false_right)

lemmas mod_dist = mod_pure mod_pure_star_dist mod_ex_dist mod_and_dist
  mod_or_dist mod_not_dist

lemma mod_star_trueI: "h\<Turnstile>P \<Longrightarrow> h\<Turnstile>P*true"
  unfolding times_assn_def top_assn_def
  apply (simp add: Abs_assn_inverse)
  apply (cases h)
  apply auto
  done

lemma mod_star_trueE': assumes "h\<Turnstile>P*true" obtains h' where
  "fst h' = fst h" and "snd h' \<subseteq> snd h" and "h'\<Turnstile>P"
  using assms
  unfolding times_assn_def top_assn_def
  apply (cases h)
  apply (fastforce simp add: Abs_assn_inverse)
  done

lemma mod_star_trueE: assumes "h\<Turnstile>P*true" obtains h' where "h'\<Turnstile>P"
  using assms by (blast elim: mod_star_trueE')

lemma mod_h_bot_iff[simp]:
  "(h,{}) \<Turnstile> \<up>b \<longleftrightarrow> b"
  "(h,{}) \<Turnstile> true"
  "(h,{}) \<Turnstile> p\<mapsto>\<^sub>rx \<longleftrightarrow> False"
  "(h,{}) \<Turnstile> q\<mapsto>\<^sub>ay \<longleftrightarrow> False"
  "(h,{}) \<Turnstile> P*Q \<longleftrightarrow> ((h,{}) \<Turnstile> P) \<and> ((h,{}) \<Turnstile> Q)"
  "(h,{}) \<Turnstile> P\<and>\<^sub>AQ \<longleftrightarrow> ((h,{}) \<Turnstile> P) \<and> ((h,{}) \<Turnstile> Q)"
  "(h,{}) \<Turnstile> P\<or>\<^sub>AQ \<longleftrightarrow> ((h,{}) \<Turnstile> P) \<or> ((h,{}) \<Turnstile> Q)"
  "(h,{}) \<Turnstile> (\<exists>\<^sub>Ax. R x) \<longleftrightarrow> (\<exists>x. (h,{}) \<Turnstile> R x)"
  apply (simp add: pure_assn_def Abs_assn_inverse)
  apply simp
  apply (simp add: sngr_assn_def Abs_assn_inverse)
  apply (simp add: snga_assn_def Abs_assn_inverse)
  apply (simp add: times_assn_def Abs_assn_inverse)
  apply (simp add: inf_assn_def Abs_assn_inverse)
  apply (simp add: sup_assn_def Abs_assn_inverse)
  apply (simp add: ex_assn_def Abs_assn_inverse)
  done

subsection \<open>Entailment\<close>
definition entails :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Longrightarrow>\<^sub>A" 10)
  where "P \<Longrightarrow>\<^sub>A Q \<equiv> \<forall>h. h\<Turnstile>P \<longrightarrow> h\<Turnstile>Q"

lemma entailsI:
  assumes "\<And>h. h\<Turnstile>P \<Longrightarrow> h\<Turnstile>Q"
  shows "P \<Longrightarrow>\<^sub>A Q"
  using assms unfolding entails_def by auto

lemma entailsD:
  assumes "P \<Longrightarrow>\<^sub>A Q"
  assumes "h\<Turnstile>P"
  shows "h\<Turnstile>Q"
  using assms unfolding entails_def by blast

subsubsection \<open>Properties\<close>
lemma ent_fwd:
  assumes "h\<Turnstile>P"
  assumes "P \<Longrightarrow>\<^sub>A Q"
  shows "h\<Turnstile>Q" using assms(2,1) by (rule entailsD)

lemma ent_refl[simp]: "P \<Longrightarrow>\<^sub>A P"
  by (auto simp: entailsI)

lemma ent_trans[trans]: "\<lbrakk> P \<Longrightarrow>\<^sub>A Q; Q \<Longrightarrow>\<^sub>AR \<rbrakk> \<Longrightarrow> P \<Longrightarrow>\<^sub>A R"
  by (auto intro: entailsI dest: entailsD)

lemma ent_iffI:
  assumes "A\<Longrightarrow>\<^sub>AB"
  assumes "B\<Longrightarrow>\<^sub>AA"
  shows "A=B"
  apply (subst Rep_assn_inject[symmetric])
  apply (rule ext)
  using assms unfolding entails_def
  by blast

lemma ent_false[simp]: "false \<Longrightarrow>\<^sub>A P"
  by (auto intro: entailsI)
lemma ent_true[simp]: "P \<Longrightarrow>\<^sub>A true"
  by (auto intro!: entailsI simp: models_in_range)

lemma ent_false_iff[simp]: "(P \<Longrightarrow>\<^sub>A false) \<longleftrightarrow> (\<forall>h. \<not>h\<Turnstile>P)"
  unfolding entails_def
  by auto

lemma ent_pure_pre_iff[simp]: "(P*\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto simp add: mod_dist)

lemma ent_pure_pre_iff_sng[simp]:
  "(\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (emp \<Longrightarrow>\<^sub>A Q))"
  using ent_pure_pre_iff[where P=emp]
  by simp

lemma ent_pure_post_iff[simp]:
  "(P \<Longrightarrow>\<^sub>A Q*\<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto simp add: mod_dist)

lemma ent_pure_post_iff_sng[simp]:
  "(P \<Longrightarrow>\<^sub>A \<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A emp))"
  using ent_pure_post_iff[where Q=emp]
  by simp

lemma ent_ex_preI: "(\<And>x. P x \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> \<exists>\<^sub>Ax. P x \<Longrightarrow>\<^sub>A Q"
  unfolding entails_def ex_assn_def
  by (auto simp: Abs_assn_inverse)

lemma ent_ex_postI: "(P \<Longrightarrow>\<^sub>A Q x) \<Longrightarrow> P \<Longrightarrow>\<^sub>A \<exists>\<^sub>Ax. Q x"
  unfolding entails_def ex_assn_def
  by (auto simp: Abs_assn_inverse)

lemma ent_mp: "(P * (P -* Q)) \<Longrightarrow>\<^sub>A Q"
  apply (rule entailsI)
  unfolding times_assn_def wand_assn_def
  apply (clarsimp simp add: Abs_assn_inverse)
  apply (drule_tac x="a" in spec)
  apply (drule_tac x="as1" in spec)
  apply (auto simp: Un_ac relH_refl)
  done

lemma ent_star_mono: "\<lbrakk> P \<Longrightarrow>\<^sub>A P'; Q \<Longrightarrow>\<^sub>A Q'\<rbrakk> \<Longrightarrow> P*Q \<Longrightarrow>\<^sub>A P'*Q'"
  unfolding entails_def times_assn_def
  apply (simp add: Abs_assn_inverse)
  apply metis
  done

lemma ent_wandI:
  assumes IMP: "Q*P \<Longrightarrow>\<^sub>A R"
  shows "P \<Longrightarrow>\<^sub>A (Q -* R)"
  unfolding entails_def
  apply clarsimp
  apply (rule wand_assnI)
  apply (blast intro: models_in_range)
proof -
  fix h as h' as'
  assume "(h,as)\<Turnstile>P"
    and "as\<inter>as'={}"
    and "relH as h h'"
    and "in_range (h',as)"
    and "(h',as') \<Turnstile> Q"

  from \<open>(h,as)\<Turnstile>P\<close> and \<open>relH as h h'\<close> have "(h',as)\<Turnstile>P"
    by (simp add: mod_relH)
  with \<open>(h',as') \<Turnstile> Q\<close> and \<open>as\<inter>as'={}\<close> have "(h',as\<union>as')\<Turnstile>Q*P"
    by (metis star_assnI Int_commute Un_commute)
  with IMP show "(h',as\<union>as') \<Turnstile> R" by (blast dest: ent_fwd)
qed

lemma ent_disjI1:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "P \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjI2:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "Q \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjI1_direct[simp]: "A \<Longrightarrow>\<^sub>A A \<or>\<^sub>A B"
  by (simp add: entails_def)

lemma ent_disjI2_direct[simp]: "B \<Longrightarrow>\<^sub>A A \<or>\<^sub>A B"
  by (simp add: entails_def)

lemma ent_disjE: "\<lbrakk> A\<Longrightarrow>\<^sub>AC; B\<Longrightarrow>\<^sub>AC \<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>AC"
  unfolding entails_def by auto

lemma ent_conjI: "\<lbrakk> A\<Longrightarrow>\<^sub>AB; A\<Longrightarrow>\<^sub>AC \<rbrakk> \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<and>\<^sub>A C"
  unfolding entails_def by (auto simp: mod_and_dist)

lemma ent_conjE1: "\<lbrakk>A\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)
lemma ent_conjE2: "\<lbrakk>B\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)

lemma star_or_dist1:
  "(A \<or>\<^sub>A B)*C = (A*C \<or>\<^sub>A B*C)"
  apply (rule ent_iffI)
  unfolding entails_def
  by (auto simp add: mod_star_conv)

lemma star_or_dist2:
  "C*(A \<or>\<^sub>A B) = (C*A \<or>\<^sub>A C*B)"
  apply (rule ent_iffI)
  unfolding entails_def
  by (auto simp add: mod_star_conv)

lemmas star_or_dist = star_or_dist1 star_or_dist2

lemma ent_disjI1': "A\<Longrightarrow>\<^sub>AB \<Longrightarrow> A\<Longrightarrow>\<^sub>AB\<or>\<^sub>AC"
  by (auto simp: entails_def star_or_dist)

lemma ent_disjI2': "A\<Longrightarrow>\<^sub>AC \<Longrightarrow> A\<Longrightarrow>\<^sub>AB\<or>\<^sub>AC"
  by (auto simp: entails_def star_or_dist)

lemma triv_exI[simp, intro!]: "Q x \<Longrightarrow>\<^sub>A \<exists>\<^sub>Ax. Q x"
  by (meson ent_ex_postI ent_refl)

subsubsection \<open>Weak Entails\<close>
text \<open>Weakening of entails to allow arbitrary unspecified memory in conclusion\<close>
definition entailst :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Longrightarrow>\<^sub>t" 10)
  where "entailst A B \<equiv> A \<Longrightarrow>\<^sub>A B * true"

lemma enttI: "A\<Longrightarrow>\<^sub>AB*true \<Longrightarrow> A\<Longrightarrow>\<^sub>tB" unfolding entailst_def .
lemma enttD: "A\<Longrightarrow>\<^sub>tB \<Longrightarrow> A\<Longrightarrow>\<^sub>AB*true" unfolding entailst_def .

lemma entt_trans:
  "entailst A B \<Longrightarrow> entailst B C \<Longrightarrow> entailst A C"
  unfolding entailst_def
  apply (erule ent_trans)
  by (metis assn_times_assoc ent_star_mono ent_true merge_true_star)

lemma entt_refl[simp, intro!]: "entailst A A"
  unfolding entailst_def
  by (simp add: entailsI mod_star_trueI)

lemma entt_true[simp, intro!]:
  "entailst A true"
  unfolding entailst_def by simp

lemma entt_emp[simp, intro!]:
  "entailst A emp"
  unfolding entailst_def by simp

lemma entt_star_true_simp[simp]:
  "entailst A (B*true) \<longleftrightarrow> entailst A B"
  "entailst (A*true) B \<longleftrightarrow> entailst A B"
  unfolding entailst_def
  subgoal by (auto simp: assn_times_assoc)
  subgoal
    apply (intro iffI)
    subgoal using entails_def mod_star_trueI by blast
    subgoal by (metis assn_times_assoc ent_refl ent_star_mono merge_true_star)
    done
  done

lemma entt_star_mono: "\<lbrakk>entailst A B; entailst C D\<rbrakk> \<Longrightarrow> entailst (A*C) (B*D)"
  unfolding entailst_def
proof -
  assume a1: "A \<Longrightarrow>\<^sub>A B * true"
  assume "C \<Longrightarrow>\<^sub>A D * true"
  then have "A * C \<Longrightarrow>\<^sub>A true * B * (true * D)"
    using a1 assn_times_comm ent_star_mono by force
  then show "A * C \<Longrightarrow>\<^sub>A B * D * true"
    by (simp add: ab_semigroup_mult_class.mult.left_commute assn_times_comm)
qed

lemma entt_frame_fwd:
  assumes "entailst P Q"
  assumes "entailst A (P*F)"
  assumes "entailst (Q*F) B"
  shows "entailst A B"
  using assms
  by (metis entt_refl entt_star_mono entt_trans)

lemma enttI_true: "P*true \<Longrightarrow>\<^sub>A Q*true \<Longrightarrow> P\<Longrightarrow>\<^sub>tQ"
  by (drule enttI) simp

lemma entt_def_true: "(P\<Longrightarrow>\<^sub>tQ) \<equiv> (P*true \<Longrightarrow>\<^sub>A Q*true)"
  unfolding entailst_def
  apply (rule eq_reflection)
  using entailst_def entt_star_true_simp(2) by auto

lemma ent_imp_entt: "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P\<Longrightarrow>\<^sub>tQ"
  apply (rule enttI)
  apply (erule ent_trans)
  by (simp add: entailsI mod_star_trueI)

lemma entt_disjI1_direct[simp]: "A \<Longrightarrow>\<^sub>t A \<or>\<^sub>A B"
  by (rule ent_imp_entt[OF ent_disjI1_direct])

lemma entt_disjI2_direct[simp]: "B \<Longrightarrow>\<^sub>t A \<or>\<^sub>A B"
  by (rule ent_imp_entt[OF ent_disjI2_direct])

lemma entt_disjI1': "A\<Longrightarrow>\<^sub>tB \<Longrightarrow> A\<Longrightarrow>\<^sub>tB\<or>\<^sub>AC"
  by (auto simp: entailst_def entails_def star_or_dist)

lemma entt_disjI2': "A\<Longrightarrow>\<^sub>tC \<Longrightarrow> A\<Longrightarrow>\<^sub>tB\<or>\<^sub>AC"
  by (auto simp: entailst_def entails_def star_or_dist)

lemma entt_disjE: "\<lbrakk> A\<Longrightarrow>\<^sub>tM; B\<Longrightarrow>\<^sub>tM \<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>t M"
  using ent_disjE enttD enttI by blast

lemma entt_disjD1: "A\<or>\<^sub>AB\<Longrightarrow>\<^sub>tC \<Longrightarrow> A\<Longrightarrow>\<^sub>tC"
  using entt_disjI1_direct entt_trans by blast

lemma entt_disjD2: "A\<or>\<^sub>AB\<Longrightarrow>\<^sub>tC \<Longrightarrow> B\<Longrightarrow>\<^sub>tC"
  using entt_disjI2_direct entt_trans by blast

subsection \<open>Precision\<close>
text \<open>
  Precision rules describe that parts of an assertion may depend only on the
  underlying heap. For example, the data where a pointer points to is the same
  for the same heap.
\<close>
text \<open>Precision rules should have the form:
  @{text [display] "\<forall>x y. (h\<Turnstile>(P x * F1) \<and>\<^sub>A (P y * F2)) \<longrightarrow> x=y"}\<close>
definition "precise R \<equiv> \<forall>a a' h p F F'.
  h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<longrightarrow> a = a'"

lemma preciseI[intro?]:
  assumes "\<And>a a' h p F F'. h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<Longrightarrow> a = a'"
  shows "precise R"
  using assms unfolding precise_def by blast

lemma preciseD:
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F'"
  shows "a=a'"
  using assms unfolding precise_def by blast

lemma preciseD':
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F"
  assumes "h \<Turnstile> R a' p * F'"
  shows "a=a'"
  apply (rule preciseD)
  apply (rule assms)
  apply (simp only: mod_and_dist)
  apply (blast intro: assms)
  done

lemma precise_extr_pure[simp]:
  "precise (\<lambda>x y. \<up>P * R x y) \<longleftrightarrow> (P \<longrightarrow> precise R)"
  "precise (\<lambda>x y. R x y * \<up>P) \<longleftrightarrow> (P \<longrightarrow> precise R)"
  apply (cases P, (auto intro!: preciseI) [2])+
  done

lemma sngr_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>rx)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  unfolding sngr_assn_def times_assn_def
  apply (simp add: Abs_assn_inverse)
  apply auto
  done

lemma snga_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>ax)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  unfolding snga_assn_def times_assn_def
  apply (simp add: Abs_assn_inverse)
  apply auto
  done

end


theory TeslDenotationalExamples

imports TeslDenotationalRelations

begin

term \<open>\<top> \<otimes> ((fst,0) implies (snd,1))\<close>

typ \<open>'c::semiring\<close>

text\<open> An example with a non-homogeneous semantic universe
 The accessors for the clocks must be defined according to the number of clocks in the spec
   - the ith clock is accessed by fst\<circ>snd^i if it is not the last clock in the spec
   - the ith clock is accessed by snd^i if it is the last one in the spec
\<close>
abbreviation \<open>C\<^sub>1 \<equiv> (fst,0::nat)\<close>
abbreviation \<open>C\<^sub>2 \<equiv> (fst o snd,1::nat)\<close>         \<comment> \<open> second clock of more than two clocks \<close>
abbreviation \<open>C\<^sub>2\<^sub>l \<equiv> (snd,1::nat)\<close>              \<comment> \<open> second of two clocks \<close>
abbreviation \<open>C\<^sub>3 \<equiv> (fst \<circ> snd o snd,2::nat)\<close>   \<comment> \<open> Third clock of more than three clocks \<close>
abbreviation \<open>C\<^sub>3\<^sub>l \<equiv> (snd o snd,2::nat)\<close>        \<comment> \<open> Third clock of three clocks \<close>
abbreviation \<open>C\<^sub>4 \<equiv> (fst \<circ> snd \<circ> snd o snd,3::nat)\<close>
abbreviation \<open>C\<^sub>4\<^sub>l \<equiv> (snd \<circ> snd o snd,3::nat)\<close>

term \<open>C\<^sub>1 implies C\<^sub>2\<close>
term \<open>(C\<^sub>1 implies C\<^sub>2 ) \<otimes> (C\<^sub>1 sporadic (3::int)) \<otimes> (C\<^sub>2 sporadic (2::real))  \<otimes> (C\<^sub>3\<^sub>l sporadic ((2::nat,X)))\<close>

text\<open> An example with a homogeneous semantic universe and a tag-relation on real numbers ... \<close>

term \<open>\<top> \<otimes> (C\<^sub>1 implies C\<^sub>2\<^sub>l)
        \<otimes> (C\<^sub>1 sporadic (3::real))
        \<otimes> (C\<^sub>2\<^sub>l sporadic (2))
        \<otimes> (tag relation C\<^sub>1 = 2 * C\<^sub>2\<^sub>l + 0)\<close>

text \<open>
  Show that 1 1 1 1 1 1 ...
            2 2 2 2 2 2 ...
            T F F F F F ...
  is a valid run for \<^theory_text>\<open>(D\<^sub>1 implies D\<^sub>2) \<otimes> (tag relation D\<^sub>2 = (2, 0) D\<^sub>1)\<close>
\<close>
abbreviation spec1 where \<open>spec1 \<equiv> (C\<^sub>1 implies C\<^sub>2\<^sub>l) \<otimes> (tag relation C\<^sub>2\<^sub>l = (2, 0) C\<^sub>1)\<close>
abbreviation time1::\<open>nat \<Rightarrow> int \<times> int\<close> where \<open>time1 \<equiv> \<lambda>n. (1, 2)\<close>
abbreviation hamlet1::\<open>nat \<Rightarrow> bool list\<close> where \<open>hamlet1 == (\<lambda>n. [False, False])(0:=[True, True])\<close>
abbreviation run1 where \<open>run1 \<equiv> Abs_run (time1, hamlet1)\<close>

lemma run_rep1:\<open>run_rep_prop time1 hamlet1\<close>
unfolding run_rep_prop_def by (simp add: monoI rank_int_def rank_prod_def)

term \<open>fst\<^sub>r\<^sub>u\<^sub>n run1\<close>
term \<open>fst\<^sub>r\<^sub>u\<^sub>n ` spec1\<close>

lemma \<open>run1 \<in> spec1\<close>
proof -
  \<comment> \<open> Implication \<close>
  have \<open>hamlet run1 = hamlet1\<close> using run_rep1 by (simp add: Abs_run_inverse hamlet_def)
  moreover have \<open>\<forall>n. ticks C\<^sub>1 (hamlet1 n) \<longrightarrow> ticks C\<^sub>2\<^sub>l (hamlet1 n)\<close> unfolding ticks_def by simp
  ultimately have imp:\<open>run1 \<in> (C\<^sub>1 implies C\<^sub>2\<^sub>l)\<close> unfolding Implies_def by simp
  \<comment> \<open> Tag relation \<close>
  have \<open>time run1 = time1\<close> using run_rep1  by (simp add: Abs_run_inverse time_def)
  moreover have \<open>mono time1\<close> by (simp add: monoI)
  moreover have \<open>(\<forall>n. (timep C\<^sub>2\<^sub>l (time1 n), timep C\<^sub>1 (time1 n)) \<in> {(m::int, n::int). m = 2 * n + 0 \<or> n = (m - 0) div 2})\<close> by simp
  ultimately have tagrel:\<open>run1 \<in> (tag relation C\<^sub>2\<^sub>l = (2, 0) C\<^sub>1)\<close> unfolding TagRelation_def AffineTagRelation\<^sub>i\<^sub>n\<^sub>t.simps time_def by simp
  \<comment> \<open> Final result \<close>
  from imp and tagrel show ?thesis using TeslComp_def by blast
qed

\<comment> \<open> A spec with a more complex time function \<close>
abbreviation \<open>spec2 \<equiv> (C\<^sub>1 implies C\<^sub>2\<^sub>l) \<otimes> (tag relation C\<^sub>2\<^sub>l = (2, 0) C\<^sub>1)\<close>
abbreviation \<open>time2 \<equiv> \<lambda>n::nat. (int n, int 2*n)\<close>
abbreviation \<open>hamlet2 \<equiv> (\<lambda>n::nat. [False, False])(0:=[True, True])\<close>
abbreviation \<open>run2 \<equiv> Abs_run (time2, hamlet2)\<close>

lemma mono_time2:\<open>mono time2\<close>
proof -
  {
    fix m n::nat
    assume \<open>m \<le> n\<close>
    hence \<open>(int m, int 2*m) \<le> (int n, int 2*n)\<close> by (simp add: less_eq_prod_def)
    hence \<open>time2 m \<le> time2 n\<close> .
  }
  thus ?thesis by (rule monoI)
qed

lemma run_rep2:\<open>run_rep_prop time2 hamlet2\<close>
unfolding run_rep_prop_def using mono_time2 by (simp add: rank_int_def rank_prod_def)

lemma \<open>run2 \<in> spec2\<close>
proof -
  \<comment> \<open> Implication \<close>
  have \<open>hamlet run2 = hamlet2\<close> using run_rep2 by (simp add: Abs_run_inverse hamlet_def)
  moreover have \<open>\<forall>n. ticks C\<^sub>1 (hamlet2 n) \<longrightarrow> ticks C\<^sub>2\<^sub>l (hamlet2 n)\<close> unfolding ticks_def by simp
  ultimately have imp:\<open>run2 \<in> (C\<^sub>1 implies C\<^sub>2\<^sub>l)\<close> unfolding Implies_def by simp
  \<comment> \<open> Tag relation \<close>
  have \<open>time run2 = time2\<close> using run_rep2 by (simp add: Abs_run_inverse time_def)
  moreover have \<open>(\<forall>n. (timep C\<^sub>2\<^sub>l (time2 n), timep C\<^sub>1 (time2 n)) \<in> {(m::int, n::int). m = 2 * n + 0 \<or> n = (m - 0) div 2})\<close> by simp
  ultimately have tagrel:\<open>run2 \<in> (tag relation C\<^sub>2\<^sub>l = (2, 0) C\<^sub>1)\<close> unfolding TagRelation_def AffineTagRelation\<^sub>i\<^sub>n\<^sub>t.simps time_def using mono_time2 by simp
  \<comment> \<open> Final result \<close>
  from imp and tagrel show ?thesis using TeslComp_def by blast
qed

\<comment> \<open> A spec with a timed delay \<close>
abbreviation \<open>spec3 \<equiv> (C\<^sub>1 implies C\<^sub>2\<^sub>l) \<otimes> (tag relation C\<^sub>2\<^sub>l = (2, 0) C\<^sub>1) \<otimes> (C\<^sub>1 time-delayed by 2 on C\<^sub>1 implies C\<^sub>2\<^sub>l)\<close>
abbreviation \<open>hamlet3 \<equiv> (\<lambda>n::nat. [False, False])(0:=[True, True],2:=[False,True])\<close>
abbreviation \<open>run3 \<equiv> Abs_run (time2, hamlet3)\<close>

lemma run_rep3:\<open>run_rep_prop time2 hamlet3\<close>
using mono_time2 by (simp add: rank_int_def rank_prod_def run_rep_prop_def)

lemma \<open>run3 \<in> spec3\<close>
proof -
  \<comment> \<open> Implication \<close>
  have ham:\<open>hamlet run3 = hamlet3\<close> using run_rep3 by (simp add: Abs_run_inverse hamlet_def)
  moreover have \<open>\<forall>n. ticks C\<^sub>1 (hamlet3 n) \<longrightarrow> ticks C\<^sub>2\<^sub>l (hamlet3 n)\<close> unfolding ticks_def by simp
  ultimately have imp:\<open>run3 \<in> (C\<^sub>1 implies C\<^sub>2\<^sub>l)\<close> unfolding Implies_def by simp
  \<comment> \<open> Tag relation \<close>
  have tim:\<open>time run3 = time2\<close> using run_rep3 by (simp add: Abs_run_inverse time_def)
  moreover have \<open>(\<forall>n. (timep C\<^sub>2\<^sub>l (time2 n), timep C\<^sub>1 (time2 n)) \<in> {(m::int, n::int). m = 2 * n + 0 \<or> n = (m - 0) div 2})\<close> by simp
  ultimately have tagrel:\<open>run3 \<in> (tag relation C\<^sub>2\<^sub>l = (2, 0) C\<^sub>1)\<close> unfolding TagRelation_def AffineTagRelation\<^sub>i\<^sub>n\<^sub>t.simps time_def using mono_time2 by simp
  \<comment> \<open> Time delay \<close>
  have c1ticks0:\<open>\<forall>n. ticks C\<^sub>1 (hamlet3 n) \<longrightarrow> n = 0\<close> unfolding ticks_def by simp
  have \<open>\<forall>n. ticks C\<^sub>1 (hamlet3 n) \<longrightarrow> (\<exists>m. m > n \<and> ticks C\<^sub>2\<^sub>l (hamlet3 m)  \<and> timep C\<^sub>1 (time2 m) = timep C\<^sub>1 (time2 n) + 2)\<close>
  proof -
    {
      fix n
      assume h:\<open>ticks C\<^sub>1 (hamlet3 n)\<close>
      have \<open>\<exists>m. m > n \<and> ticks C\<^sub>2\<^sub>l (hamlet3 m) \<and> timep C\<^sub>1 (time2 m) = timep C\<^sub>1 (time2 n) + 2\<close>
      proof -
        from h c1ticks0 have \<open>n = 0\<close> unfolding ticks_def by simp
        moreover have \<open>timep C\<^sub>1 (time2 0) = 0\<close> by simp
        moreover have \<open>ticks C\<^sub>2\<^sub>l (hamlet3 (n+2))\<close> unfolding ticks_def using `n = 0` by simp
        moreover have \<open>timep C\<^sub>1 (time2 (n + 2)) = timep C\<^sub>1 (time2 0) + 2\<close> using `n = 0` by simp
        moreover have \<open>n < n+2\<close> by simp
        ultimately have \<open>(n+2) > n \<and> ticks C\<^sub>2\<^sub>l (hamlet3 (n + 2)) \<and> timep C\<^sub>1 (time2 (n + 2)) = timep C\<^sub>1 (time2 n) + 2\<close> by simp
        thus ?thesis by blast
      qed
    }
    thus ?thesis by blast
  qed
  with tim ham mono_time2 have tdelay:\<open>run3 \<in> (C\<^sub>1 time-delayed by 2 on C\<^sub>1 implies C\<^sub>2\<^sub>l)\<close> unfolding TimeDelayed_def time_def hamlet_def by simp
  with imp tagrel show ?thesis using TeslComp_def by blast
qed

\<comment> \<open> A spec with a delay \<close>
abbreviation \<open>spec4 \<equiv> (tag relation C\<^sub>2 = (1, 0) C\<^sub>1) \<otimes> (tag relation C\<^sub>3\<^sub>l = (1, 0) C\<^sub>1) \<otimes> (C\<^sub>1 delayed by 2 on C\<^sub>2 implies C\<^sub>3\<^sub>l)\<close>
abbreviation \<open>hamlet4 \<equiv> (\<lambda>n::nat. [False, False, False])(0:=[True, False, False],1:=[False, True, False], 2:=[False,True,True])\<close>
abbreviation \<open>time4 \<equiv> \<lambda>n::nat. (int n, int n, int n)\<close>
abbreviation \<open>run4 \<equiv> Abs_run (time4, hamlet4)\<close>

lemma mono_time4: \<open>mono time4\<close>
proof -
  {
    fix m n::nat
    assume \<open>m \<le> n\<close>
    hence \<open>(int m, int m, int m) \<le> (int n, int n, int n)\<close> by (simp add: less_eq_prod_def)
    hence \<open>time4 m \<le> time4 n\<close> .
  }
  thus ?thesis by (rule monoI)
qed

lemma run_rep4:\<open>run_rep_prop time4 hamlet4\<close>
using mono_time4 by (simp add: rank_int_def rank_prod_def run_rep_prop_def)

lemma ham4c1:
  assumes \<open>ticks C\<^sub>1 (hamlet4 n)\<close>
  shows \<open>n = 0\<close>
proof -
  from assms have *:\<open>(hamlet4 n)!0\<close> by (simp add:ticks_def)
  have \<open>(hamlet4 0)!0\<close> by simp
  moreover have \<open>\<not> ((hamlet4 1)!0)\<close> by simp
  moreover have \<open>\<not> ((hamlet4 2)!0)\<close> by simp
  moreover have \<open>n\<noteq>0 \<and> n\<noteq>1 \<and> n\<noteq>2 \<Longrightarrow> \<not> ((hamlet4 n)!0)\<close> by simp
  ultimately have \<open>(hamlet4 n)!0 \<Longrightarrow> n = 0\<close> by blast
  with * show ?thesis by simp
qed

lemma 02:\<open>(0 < (p::nat) \<and> p \<le> 2) = (p = 1 \<or> p = 2)\<close> by auto

lemma T02:\<open>((0 < p \<and> p \<le> 2) \<and> ticks C\<^sub>2 (hamlet4 p)) = ((p = 1 \<or> p = 2) \<and> (ticks C\<^sub>2 (hamlet4 p)))\<close>
proof -
  have \<open>ticks C\<^sub>2 (hamlet4 1)\<close> by (simp add:ticks_def)
  moreover have \<open>ticks C\<^sub>2 (hamlet4 2)\<close> by (simp add:ticks_def)
  ultimately show ?thesis using 02 by metis
qed

lemma \<open>run4 \<in> spec4\<close>
proof -
  \<comment> \<open> Tag relations \<close>
  have tim:\<open>time run4 = time4\<close> using run_rep4 by (simp add: Abs_run_inverse time_def)
  moreover have \<open>(\<forall>n. (timep C\<^sub>2 (time4 n), timep C\<^sub>1 (time4 n)) \<in> {(m::int, n::int). m = 1 * n + 0 \<or> n = (m - 0) div 1})\<close> by simp
  ultimately have tagrel1:\<open>run4 \<in> (tag relation C\<^sub>2 = (1, 0) C\<^sub>1)\<close> unfolding TagRelation_def AffineTagRelation\<^sub>i\<^sub>n\<^sub>t.simps time_def using mono_time4 by simp
  from tim have \<open>(\<forall>n. (timep C\<^sub>3\<^sub>l (time4 n), timep C\<^sub>1 (time4 n)) \<in> {(m::int, n::int). m = 1 * n + 0 \<or> n = (m - 0) div 1})\<close> by simp
  with tim have tagrel2:\<open>run4 \<in> (tag relation C\<^sub>3\<^sub>l = (1, 0) C\<^sub>1)\<close> unfolding TagRelation_def AffineTagRelation\<^sub>i\<^sub>n\<^sub>t.simps time_def using mono_time4 by simp
  \<comment> \<open> Delayed implication \<close>
  have ham:\<open>hamlet run4 = hamlet4\<close> using run_rep4 by (simp add: Abs_run_inverse hamlet_def)
  have \<open>\<forall>n. ticks C\<^sub>1 (hamlet4 n) \<longrightarrow> (\<exists>n\<^sub>f\<^sub>i\<^sub>r\<^sub>e > n. ticks C\<^sub>3\<^sub>l (hamlet4 n\<^sub>f\<^sub>i\<^sub>r\<^sub>e) \<and>
                                                 card {p. n < p \<and> p \<le> n\<^sub>f\<^sub>i\<^sub>r\<^sub>e \<and>
                                                 ticks C\<^sub>2 (hamlet4 p)} = 2)\<close>
  proof -
    { fix n assume \<open>ticks C\<^sub>1 (hamlet4 n)\<close>
      hence n0:\<open>n=0\<close> using ham4c1 by simp
      have t:\<open>ticks C\<^sub>3\<^sub>l (hamlet4 2)\<close> by (simp add:ticks_def)
      have \<open>ticks C\<^sub>2 (hamlet4 1)\<close> by (simp add:ticks_def)
      moreover have \<open>ticks C\<^sub>2 (hamlet4 2)\<close> by (simp add:ticks_def)
      ultimately have \<open>{p. (p=1 \<or> p = 2) \<and> ticks C\<^sub>2 (hamlet4 p)} = {1, 2}\<close> by auto
      with T02 have *:\<open>{p. 0 < p \<and> p \<le> 2 \<and> ticks C\<^sub>2 (hamlet4 p)} = {1, 2}\<close> using arg_cong by blast
      from arg_cong[OF this, of \<open>card\<close>] have \<open>card {p. 0 < p \<and> p \<le> 2 \<and> ticks C\<^sub>2 (hamlet4 p)} = card {(1::nat), 2}\<close> .
      also have \<open>... = 2\<close> by simp
      finally have \<open>card {p. 0 < p \<and> p \<le> 2 \<and> ticks C\<^sub>2 (hamlet4 p)} = 2\<close> by simp
      with t have \<open>2 > n \<and> ticks C\<^sub>3\<^sub>l (hamlet4 2) \<and> card {p. 0 < p \<and> p \<le> 2 \<and> ticks C\<^sub>2 (hamlet4 p)} = 2\<close> using n0 by simp
    }
    thus ?thesis by (metis (no_types, lifting) Collect_cong ham4c1)
  qed
  with tim ham have delay:\<open>run4 \<in> (C\<^sub>1 delayed by 2 on C\<^sub>2 implies C\<^sub>3\<^sub>l)\<close> unfolding Delayed_def using time_def by (simp add:tick_count_between_def)
  from tagrel1 tagrel2 delay show ?thesis using TeslComp_def by blast
qed

term \<open>Least (\<lambda>X. X>(3::int))\<close>
term \<open>x mod y\<close>

term Max

abbreviation \<open>C5\<^sub>1::(nat\<times>nat, nat)\<H> \<equiv> (fst, 0::nat)\<close>
abbreviation \<open>C5\<^sub>2::(nat\<times>nat, nat)\<H> \<equiv> (snd,1::nat)\<close>              \<comment> \<open> second of two clocks \<close>

abbreviation \<open>spec5::(nat\<times>nat) run set \<equiv> (C5\<^sub>1 filtered by 1, 2 (1, 1)* implies C5\<^sub>2)\<close>
abbreviation \<open>hamlet5 \<equiv> (\<lambda>n::nat. [False, False])(0:=[True, False],1:=[True, True], 2:=[True,True], 3:=[True,False], 4:=[True,True], 5:=[True,False])\<close>
abbreviation \<open>time5 \<equiv> \<lambda>n::nat. (n, n)\<close>
abbreviation \<open>run5 \<equiv> Abs_run (time5, hamlet5)\<close>

lemma run_rep5:\<open>run_rep_prop time5 hamlet5\<close>
unfolding run_rep_prop_def
proof
  show \<open>mono time5\<close> unfolding mono_def by (simp add: less_eq_prod_def)
  have \<open>\<forall>n. rank (time5 n) = 2\<close> using rank_nat_def by (simp add: rank_prod_def)
  moreover have \<open>\<forall>n. length (hamlet5 n) = 2\<close> by simp
  ultimately show \<open>\<forall>n. rank (time5 n) = length (hamlet5 n)\<close> by simp
qed

lemma c1ticks6:
  assumes \<open>n < 6\<close>
  shows   \<open>ticks C5\<^sub>1 (hamlet5 n)\<close>
proof -
  have \<open>ticks C5\<^sub>1 (hamlet5 0)\<close> unfolding ticks_def by simp
  moreover have \<open>ticks C5\<^sub>1 (hamlet5 1)\<close> unfolding ticks_def by simp
  moreover have \<open>ticks C5\<^sub>1 (hamlet5 2)\<close> unfolding ticks_def by simp
  moreover have \<open>ticks C5\<^sub>1 (hamlet5 3)\<close> unfolding ticks_def by simp
  moreover have \<open>ticks C5\<^sub>1 (hamlet5 4)\<close> unfolding ticks_def by simp
  moreover have \<open>ticks C5\<^sub>1 (hamlet5 5)\<close> unfolding ticks_def by simp
  ultimately show ?thesis using assms by auto
qed

lemma c1notick6:
  assumes \<open>n \<ge> 6\<close>
  shows   \<open>\<not>ticks C5\<^sub>1 (hamlet5 n)\<close>
unfolding ticks_def using assms by simp

lemma n_lt_6:
  assumes \<open>(n::nat) < 6\<close>
  shows   \<open>n = 0 \<or> n = 1 \<or> n = 2 \<or> n = 3 \<or> n = 4 \<or> n = 5\<close>
using assms by auto

declare [[show_sorts]]

lemma c1cnt6is:
  assumes \<open>n < 6\<close>
  shows   \<open>tick_count C5\<^sub>1 hamlet5 n = (Suc n)\<close>
proof -
  from c1ticks6 assms have \<open>\<forall>i \<le> n. ticks C5\<^sub>1 (hamlet5 i)\<close> using le_less_trans by blast
  hence \<open>{i. i \<le> n \<and> ticks C5\<^sub>1 (hamlet5 i)} = {i. i \<le> n}\<close> by blast
  moreover have \<open>card {i. i \<le> n} = Suc n\<close> by simp
  ultimately show ?thesis unfolding tick_count_def by auto
qed

lemma c1cnt6:
  assumes \<open>n < 6\<close>
  shows   \<open>tick_count_fun C5\<^sub>1 hamlet5 n = Suc n\<close>
using c1cnt6is tick_count_is_fun using assms by (simp add: tick_count_is_fun)

lemma c1filt_ok:
  assumes \<open>n < 6\<close>
  shows   \<open>filter 1 2 1 1 (tick_count C5\<^sub>1 hamlet5 n) \<longrightarrow> ticks C5\<^sub>2 (hamlet5 n)\<close> (is \<open>?P n\<close>)
proof -
  have \<open>?P 0\<close> unfolding filter_def ticks_def by eval
  moreover have \<open>?P 1\<close> unfolding filter_def ticks_def by simp
  moreover have \<open>?P 2\<close> unfolding filter_def ticks_def by simp
  moreover have \<open>?P 3\<close> unfolding filter_def ticks_def by eval
  moreover have \<open>?P 4\<close> unfolding filter_def ticks_def by eval
  moreover have \<open>?P 5\<close> unfolding filter_def ticks_def by eval
  ultimately show ?thesis using assms n_lt_6 by blast
qed

\<^cancel>\<open>
value \<open>ticks C\<^sub>1 (hamlet5 1)\<close>
value \<open>tick_count C\<^sub>1 hamlet5 1\<close>
value \<open>filter 1 2 1 1 (tick_count C\<^sub>1 hamlet5 1)\<close>
value \<open>ticks C\<^sub>2\<^sub>l (hamlet5 1)\<close>
\<close>

lemma \<open>run5 \<in> spec5\<close>
proof -
  \<comment> \<open> Filtered implication \<close>
  have ham:\<open>hamlet run5 = hamlet5\<close> using run_rep5 by (simp add: Abs_run_inverse hamlet_def)
  have \<open>\<forall>n. ticks C5\<^sub>1 (hamlet5 n) \<and> filter 1 2 1 1 (tick_count C5\<^sub>1 hamlet5 n) \<longrightarrow> ticks C5\<^sub>2 (hamlet5 n)\<close>
  proof -
    { fix n
      have \<open>ticks C5\<^sub>1 (hamlet5 n) \<and> filter 1 2 1 1 (tick_count C5\<^sub>1 hamlet5 n) \<longrightarrow> ticks C5\<^sub>2 (hamlet5 n)\<close>
      proof (cases \<open>n < 6\<close>)
        case True thus ?thesis using c1filt_ok filter_def by blast
      next
        case False thus ?thesis using c1notick6 by auto
      qed
    }
    thus ?thesis ..
  qed
  with ham show ?thesis unfolding Filtered_def by simp
qed

text \<open>
  Example specification for the await implication.
\<close>
abbreviation \<open>C6\<^sub>1::(nat\<times>nat\<times>nat, nat)\<H> \<equiv> (fst, 0::nat)\<close>
abbreviation \<open>C6\<^sub>2::(nat\<times>nat\<times>nat, nat)\<H> \<equiv> (fst \<circ> snd,1::nat)\<close>              \<comment> \<open> second of three clocks \<close>
abbreviation \<open>C6\<^sub>3::(nat\<times>nat\<times>nat, nat)\<H> \<equiv> (snd \<circ> snd,2::nat)\<close>              \<comment> \<open> third of three clocks \<close>

abbreviation \<open>spec6 \<equiv> (await C6\<^sub>1, C6\<^sub>2 implies C6\<^sub>3)\<close>
abbreviation \<open>hamlet6 \<equiv> (\<lambda>n::nat. [False, False, False])(0:=[True, False, False],1:=[False, True, True], 2:=[True,True,True], 3:=[False,True,False], 4:=[True,False,True])\<close>
abbreviation \<open>time6 \<equiv> \<lambda>n::nat. (n, n, n)\<close>
abbreviation \<open>run6 \<equiv> Abs_run (time6, hamlet6)\<close>

lemma run_rep6:\<open>run_rep_prop time6 hamlet6\<close>
unfolding run_rep_prop_def by (simp add: less_eq_prod_def monoI rank_nat_def rank_prod_def)

lemma n_lt_5:
  assumes \<open>(n::nat) < 5\<close>
  shows   \<open>n = 0 \<or> n = 1 \<or> n = 2 \<or> n = 3 \<or> n = 4\<close>
using assms by auto

text \<open>
  Show that the await implication holds for all instants n < 5
\<close>
lemma awaitc1c2_ok:
  assumes \<open>n < 5\<close>
  shows   \<open>have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 n \<longrightarrow> ticks C6\<^sub>3 (hamlet6 n)\<close> (is \<open>?P n\<close>)
proof -
  \<comment> \<open> Proof at instant 0 \<close>
  have nc2_0:\<open>\<not>ticks C6\<^sub>2 (hamlet6 0)\<close> unfolding ticks_def by simp
  hence 0:\<open>?P 0\<close> using bt0_bt0 by blast
  \<comment> \<open> Proof at instant 1 \<close>
  have \<open>ticks C6\<^sub>1 (hamlet6 0)\<close> unfolding ticks_def by simp
  moreover have \<open>(0::nat) < 1\<close> by simp
  moreover have \<open>(1::nat) \<le> 1\<close> by simp
  ultimately have 11:\<open>has_ticked_since C6\<^sub>1 hamlet6 0 1\<close> unfolding has_ticked_since_def by blast
  have \<open>ticks C6\<^sub>2 (hamlet6 1)\<close> unfolding ticks_def by simp
  with nc2_0 have \<open>first_tick_since C6\<^sub>2 hamlet6 0 1\<close> unfolding first_tick_since_def by simp
  with 11 have \<open>has_first_since C6\<^sub>1 C6\<^sub>2 hamlet6 0 1\<close> by (simp add: has_first_since_def)
  hence hbt1:\<open>have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 1\<close> using have_both_ticked.intros(1) by simp
  moreover have \<open>ticks C6\<^sub>3 (hamlet6 1)\<close> unfolding ticks_def by simp
  ultimately have 1:\<open>?P 1\<close> by blast
  \<comment> \<open> Proof at instant 2 \<close>
  have \<open>ticks C6\<^sub>1 (hamlet6 2)\<close> unfolding ticks_def by simp
  moreover have \<open>(Suc 1) \<le> 2\<close> by simp
  ultimately have hts12:\<open>has_ticked_since C6\<^sub>1 hamlet6 (Suc 1) 2\<close> unfolding has_ticked_since_def by blast
  have \<open>ticks C6\<^sub>2 (hamlet6 2)\<close> unfolding ticks_def by simp
  hence \<open>first_tick_since C6\<^sub>2 hamlet6 (Suc 1) 2\<close> unfolding first_tick_since_def by auto
  with hts12 have \<open>has_first_since C6\<^sub>1 C6\<^sub>2 hamlet6 (Suc 1) 2\<close> by (simp add: has_first_since_def)
  from have_both_ticked.intros(3)[OF hbt1 this] have hbt2:\<open>have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 2\<close> .
  moreover have \<open>ticks C6\<^sub>3 (hamlet6 2)\<close> unfolding ticks_def by simp
  ultimately have 2:\<open>?P 2\<close> by blast
  \<comment> \<open> Proof at instant 3 \<close>
  have \<open>\<not>ticks C6\<^sub>1 (hamlet6 3)\<close> unfolding ticks_def by simp
  hence nht13:\<open>\<not>has_ticked_since C6\<^sub>1 hamlet6 (Suc 2) 3\<close> unfolding has_ticked_since_def by auto
  with nhtsa[OF hbt2, of 3] have \<open>\<not>have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 3\<close> by auto
  hence 3:\<open>?P 3\<close> by blast
  \<comment> \<open> Proof at instant 4 \<close>
  have \<open>ticks C6\<^sub>2 (hamlet6 3)\<close> by (simp add: ticks_def)
  moreover have \<open>(Suc 2) \<le> 3\<close> by simp
  moreover have \<open>(3::nat) \<le> 4\<close> by simp
  ultimately have hts24:\<open>has_ticked_since C6\<^sub>2 hamlet6 (Suc 2) 4\<close> using has_ticked_since_def by blast
  have \<open>ticks C6\<^sub>1 (hamlet6 4)\<close> by (simp add:ticks_def)
  moreover have \<open>\<not>ticks C6\<^sub>1 (hamlet6 (Suc 2))\<close> by (simp add:ticks_def)
  ultimately have fts24:\<open>first_tick_since C6\<^sub>1 hamlet6 (Suc 2) 4\<close> unfolding first_tick_since_def by auto
  with hbt2 hts24 have \<open>have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 4\<close> using have_both_ticked.intros(4)
    using has_first_since_def by blast
  moreover have \<open>ticks C6\<^sub>3 (hamlet6 4)\<close> by (simp add:ticks_def)
  ultimately have 4:\<open>?P 4\<close> by blast
  \<comment> \<open> Conclusion \<close>
  from 0 1 2 3 4 show ?thesis using n_lt_5[OF assms] by blast
qed

text \<open>
  Show that C1 and C2 do not both tick after instant 5.
\<close>
lemma c1notick5:
  assumes \<open>n \<ge> 5\<close>
    shows \<open>\<not>ticks C6\<^sub>1 (hamlet6 n)\<close>
unfolding ticks_def using assms by simp

lemma c2notick5:
  assumes \<open>n \<ge> 5\<close>
    shows \<open>\<not>ticks C6\<^sub>2 (hamlet6 n)\<close>
unfolding ticks_def using assms by simp

lemma nohbt125:
  assumes \<open>n \<ge> 5\<close>
    shows \<open>\<not>have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 n\<close>
using c1notick5 c2notick5 assms hbt_t by blast

text \<open>
  Finally, show that the run satisfies the specification.
\<close>
lemma \<open>run6 \<in> spec6\<close>
proof -
  \<comment> \<open>Await implication\<close>
  have ham:\<open>hamlet run6 = hamlet6\<close> using run_rep6 by (simp add: Abs_run_inverse hamlet_def)
  have \<open>\<forall>n. have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 n \<longrightarrow> ticks C6\<^sub>3 (hamlet6 n)\<close>
  proof -
    { fix n
      have \<open>have_both_ticked C6\<^sub>1 C6\<^sub>2 hamlet6 n \<longrightarrow> ticks C6\<^sub>3 (hamlet6 n)\<close>
      proof (cases \<open>n < 5\<close>)
        case True thus ?thesis using awaitc1c2_ok by blast
      next
        case False
          hence \<open>n \<ge> 5\<close> by simp
          from nohbt125[OF this] show ?thesis by blast
      qed
    }
    thus ?thesis ..
  qed
  with ham show ?thesis unfolding Await_def by simp
qed

abbreviation \<open>spec7 \<equiv> (C\<^sub>1 sustained from C\<^sub>2 to C\<^sub>3 implies C\<^sub>4\<^sub>l)\<close>
abbreviation \<open>hamlet7 \<equiv> (\<lambda>n::nat. [False, False, False, False])
  (0:=[True, False, False, False],
   1:=[True, True,  False, False],
   2:=[True, False, False, True],
   3:=[True, False, True,  True],
   4:=[True, False, False, False])\<close>
abbreviation \<open>time7 \<equiv> \<lambda>n::nat. (n, n, n, n)\<close>
abbreviation \<open>run7 \<equiv> Abs_run (time7, hamlet7)\<close>

lemma run_rep7:\<open>run_rep_prop time7 hamlet7\<close>
unfolding run_rep_prop_def by (simp add: less_eq_prod_def monoI rank_nat_def rank_prod_def)

lemma \<open>run7 \<in> spec7\<close>
proof -
  have ham:\<open>hamlet run7 = hamlet7\<close> using run_rep7 by (simp add: Abs_run_inverse hamlet_def)
  have \<open>\<forall>n. between C\<^sub>2 C\<^sub>3 hamlet7 n \<and> ticks C\<^sub>1 (hamlet7 n) \<longrightarrow> ticks C\<^sub>4\<^sub>l (hamlet7 n)\<close>(is \<open>\<forall>n. ?P n\<close>)
  proof -
    { fix n::nat
      have \<open>?P n\<close>
      proof (cases \<open>n < 5\<close>)
        case True
          have nb0:\<open>\<not>between C\<^sub>2 C\<^sub>3 hamlet7 0\<close> using between_def by blast
          hence 0:\<open>?P 0\<close> by auto
          have \<open>\<not>ticks C\<^sub>2 (hamlet7 0)\<close> unfolding ticks_def by simp
          with nb0 have \<open>\<not>between C\<^sub>2 C\<^sub>3 hamlet7 (Suc 0)\<close> using between_def by blast
          hence nb1:\<open>\<not>between C\<^sub>2 C\<^sub>3 hamlet7 1\<close> by simp
          hence 1:\<open>?P 1\<close> by blast
          have \<open>ticks C\<^sub>2 (hamlet7 1)\<close> unfolding ticks_def by simp
          moreover have \<open>\<not>ticks C\<^sub>3 (hamlet7 1)\<close> unfolding ticks_def by simp
          ultimately have \<open>between C\<^sub>2 C\<^sub>3 hamlet7 (Suc 1)\<close> using between_is_ind between_ind.intros(2) by blast
          hence bt2:\<open>between C\<^sub>2 C\<^sub>3 hamlet7 2\<close> using Num.Suc_1 by metis \<comment> \<open> ??? \<close>
          have \<open>ticks C\<^sub>4\<^sub>l (hamlet7 2)\<close> unfolding ticks_def by simp
          hence 2:\<open>?P 2\<close> by blast
          have \<open>\<not>ticks C\<^sub>3 (hamlet7 2)\<close> unfolding ticks_def by simp
          with bt2 have \<open>between C\<^sub>2 C\<^sub>3 hamlet7 (Suc 2)\<close> using between_is_ind between_ind.intros(1) by blast
          hence bt3:\<open>between C\<^sub>2 C\<^sub>3 hamlet7 3\<close> by simp
          have \<open>ticks C\<^sub>4\<^sub>l (hamlet7 3)\<close> unfolding ticks_def by simp
          hence 3:\<open>?P 3\<close> by blast
          have \<open>ticks C\<^sub>3 (hamlet7 3)\<close> unfolding ticks_def by simp
          hence \<open>\<not>between C\<^sub>2 C\<^sub>3 hamlet7 (Suc 3)\<close> using between_is_ind between_ind.intros(2) by blast
          hence \<open>\<not>between C\<^sub>2 C\<^sub>3 hamlet7 4\<close> by simp
          hence 4:\<open>?P 4\<close> by blast
          from 0 1 2 3 4 n_lt_5[OF True] show ?thesis by blast
      next
        case False
          hence \<open>\<not>ticks C\<^sub>1 (hamlet7 n)\<close> unfolding ticks_def by simp
          thus ?thesis by auto
      qed
    }
    thus ?thesis ..
  qed
  thus ?thesis unfolding SustainFromTo_def using ham by simp
qed

end


(*  Title:       Data refinement of representation of a file
    Authors:     Karen Zee <kkz at mit.edu> and Viktor Kuncak <vkuncak at mit.edu>
    Maintainer:  Karen Zee <kkz at mit.edu>
    License:     LGPL
*)

header "Data refinement of representation of a file"
theory FileRefinement imports Main CArrays ResizableArrays begin

text {*
  We describe a file at
  two levels of abstraction: an abstract file, represented as a resizable array, and
  a concrete file, represented using data blocks.
  We consider the following operations:
\begin{verbatim}
makeAFS     :: AFile
afsRead     :: "AFile => nat ~=> byte"
afsWrite    :: "AFile => nat => byte ~=> AFile"
afsFileSize :: "AFile => nat"
\end{verbatim}
*}

typedecl
  -- "unit of file content"
  byte
consts
  -- "value used for padding"
  fillByte :: byte

axiomatization
  blockSize :: nat  -- "in bytes" and
  numBlocks :: nat  -- "total number of blocks in the file system"
where
  nonZeroBlockSize: "blockSize > 0" and
  nonZeroNumBlocks: "numBlocks > 0"

(* ------------------------------------------------------------ *)
subsection {* Abstract File *}

type_synonym AFile = "byte rArray" -- "abstract file is a resizable array of bytes"

definition makeAF :: AFile
 where  -- "initial file has size 0"
  "makeAF == (0, % index. fillByte)"

definition afSize :: "AFile => nat" where
  -- "file size is the length of the resizable array"
  "afSize afile == fst afile"

definition afRead :: "AFile => nat ~=> byte" where
  -- "reading from a file looks up the byte, reporting @{term None} if the index is out of file bounds"
  "afRead afile byteIndex ==
   if byteIndex < fst afile then Some ((snd afile) byteIndex) else None"

definition afWrite :: "AFile => nat => byte ~=> AFile" where
  -- "writing to a file updates the file content and extends the file if there is enough space"
  "afWrite afile byteIndex value ==
   if byteIndex div blockSize < numBlocks then
     Some (raWrite afile byteIndex value fillByte)
   else None"

(* ------------------------------------------------------------ *)
subsection {* Concrete File *}

type_synonym Block = "byte cArray" -- "array of @{term blockSize} bytes"

record CFile =
  fileSize      :: nat -- "in bytes"
  nextFreeBlock :: nat -- "next block available for allocation"
  data          :: "Block cArray" -- "array of up to @{term numBlocks} blocks"

definition makeCF :: CFile
 where  -- "initial file has no allocated blocks"
  "makeCF ==
   (| fileSize      = 0,
      nextFreeBlock = 0,
      data          = makeCArray numBlocks (makeCArray blockSize fillByte)
   |)"

definition cfSize :: "CFile => nat" where
  "cfSize cfile == fileSize cfile"

definition cfRead :: "CFile => nat ~=> byte" where
  -- {* Looks up correct data block and reads its content,
        if byteIndex is within bounds, else returns None. *}
  "cfRead cfile byteIndex ==
   if byteIndex < fileSize cfile then
     (let i = byteIndex div blockSize in
       (let j = byteIndex mod blockSize in
         Some (readCArray (readCArray (data cfile) i) j)))
   else None"

subsubsection {* Writing File *}

text {* We first present some auxiliary operations. *}

definition cfWriteNoExtend :: "CFile => nat => byte => CFile" where
  -- {* Writing to a file when
        @{term byteIndex} is within bounds. *}
  "cfWriteNoExtend cfile byteIndex value ==
   let i = byteIndex div blockSize in
     let j = byteIndex mod blockSize in
       let block = readCArray (data cfile) i in
         cfile(| data :=
                 writeCArray (data cfile) i (writeCArray block j value) |)"

definition cfExtendFile :: "CFile => nat => CFile" where
  -- {* Writing to a file when
        @{term byteIndex} is out of bounds.  Involves
        allocating a new block. *}
  "cfExtendFile cfile byteIndex ==
     cfile(| fileSize := Suc byteIndex,
             nextFreeBlock := Suc (byteIndex div blockSize) |)"

text {* The main file write operation. *}

definition cfWrite :: "CFile => nat => byte ~=> CFile" where
  -- {* Writes the file at byte location byteIndex, automatically extending
   the file to that byte location if byteIndex is not within bounds.  *}
  "cfWrite cfile byteIndex value ==
     if byteIndex div blockSize < numBlocks then
       if byteIndex < fileSize cfile then
         Some (cfWriteNoExtend cfile byteIndex value)
       else
         Some (cfWriteNoExtend (cfExtendFile cfile byteIndex) byteIndex value)
     else None"

(* ---------------------------------------------------------------*)
subsection {* Reachability Invariants for Concrete File *}

definition nextFreeBlockInvariant :: "CFile => bool" where
  "nextFreeBlockInvariant state ==
   (fileSize state + blockSize - 1) div blockSize = nextFreeBlock state"

definition unallocatedBlocksInvariant :: "CFile => bool" where
  -- {* This invariant of the implementation is needed to prove
   writeExtendCorrect. It says that any unallocated block contains
   fillByte's. *}
  "unallocatedBlocksInvariant state ==
   ALL blockNum i .
     ~ blockNum < nextFreeBlock state & blockNum < numBlocks & i < blockSize
     --> data state blockNum i = fillByte"

definition lastBlockInvariant :: "CFile => bool" where
  "lastBlockInvariant state ==
   ALL index .
     ~ index < fileSize state & nextFreeBlock state = index div blockSize + 1
     --> data state (index div blockSize) (index mod blockSize) = fillByte"

definition reachabilityInvariant :: "CFile => bool" where
  "reachabilityInvariant cfile ==
      nextFreeBlockInvariant cfile &
      unallocatedBlocksInvariant cfile &
      lastBlockInvariant cfile"

(* ---------------------------------------------------------------*)
subsection {* Initial File Satisfies Invariants *}

text {* We prove each invariant individually and then summarize. *}

lemma nextFreeBlockInvariant1:
  "nextFreeBlockInvariant makeCF"
apply (simp add: nextFreeBlockInvariant_def makeCF_def)
apply (simp add: nonZeroBlockSize)
done

lemma unallocatedBlocksInvariant1:
  "unallocatedBlocksInvariant makeCF"
apply (simp add: unallocatedBlocksInvariant_def makeCF_def)
apply (simp add: makeCArray_def)
done

lemma lastBlockInvariant1:
  "lastBlockInvariant makeCF"
by (simp add: lastBlockInvariant_def makeCF_def)

lemma makeCFpreserves: "reachabilityInvariant makeCF"
by (simp add: reachabilityInvariant_def
              nextFreeBlockInvariant1
              unallocatedBlocksInvariant1
              lastBlockInvariant1)

(* ---------------------------------------------------------------*)
subsection {* Properties of Concrete File Operations *}

lemma cfWriteNoExtendPreservesFileSize:
  "[| index < fileSize cfile1;
      cfWrite cfile1 index value = Some cfile2
   |] ==>
   fileSize cfile2 = fileSize cfile1"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (simp add: cfWriteNoExtend_def Let_def)
apply force
done

lemma cfWriteExtendFileSize:
  "[| ~ index < fileSize cfile1;
      cfWrite cfile1 index value = Some cfile2
   |] ==> fileSize cfile2 = Suc index"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (simp add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply force
done

lemma fileSizeIncreases:
  "cfWrite cfile1 index value = Some cfile2
   ==> fileSize cfile1 <= fileSize cfile2"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (case_tac "index < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply force
apply force
done

lemma nextFreeBlockIncreases:
  "[| nextFreeBlockInvariant cfile1;
      cfWrite cfile1 index value = Some cfile2
   |] ==> nextFreeBlock cfile1 <= nextFreeBlock cfile2"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (case_tac "index < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply force
apply (simp add: nextFreeBlockInvariant_def)
apply auto
apply hypsubst_thin
apply (subgoal_tac "nextFreeBlock cfile1 =
  (fileSize cfile1 + blockSize - Suc 0) div blockSize", simp_all)
apply (subgoal_tac "Suc (index div blockSize) =
  (index + blockSize) div blockSize", simp)
apply (subgoal_tac "(fileSize cfile1 + blockSize - Suc 0) <=
  (index + blockSize)", simp add: div_le_mono)
apply (subgoal_tac "(fileSize cfile1 + blockSize - Suc 0) <
  (fileSize cfile1 + blockSize)", simp)
apply (simp_all add: nonZeroBlockSize)
done

(* ---------------------------------------------------------------*)
subsection {* Concrete File Operations Preserve Invariants *}

text {* There is only one top-level concrete operation: write, and we
show that it preserves all reachability invariants. *}

lemma cfWritePreservesNextFreeBlockInvariant:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2
    |] ==> nextFreeBlockInvariant cfile2"
apply (simp add: reachabilityInvariant_def
                 cfWrite_def
                 nextFreeBlockInvariant_def)
apply (case_tac "byteIndex div blockSize < numBlocks", simp_all)
apply (case_tac "byteIndex < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply auto
apply (simp add: nonZeroBlockSize)
done

lemma modInequalityLemma:
  "(a::nat) ~= b & a mod c = b mod c ==> a div c ~= b div c"
apply auto
apply (insert mod_div_equality [of "a" "c"])
apply (insert mod_div_equality [of "b" "c"])
apply simp
done

lemma mod_round_lt:
  "[| 0 < (c::nat);
      a < b
   |] ==> a div c < (b + c - 1) div c"
apply (subgoal_tac "a <= b - 1")
apply (subgoal_tac "a div c <= (b - 1) div c")
apply (insert div_add_self2 [of c "b - 1"])
apply (simp)
apply (simp add: div_le_mono)
apply (insert less_Suc_eq_le [of a "b - 1"])
apply simp
done

lemma blockNumNELemma:
  "!!blockNum i.
       [| nextFreeBlockInvariant cfile1;
          cfile1
          (| data :=
               writeCArray (data cfile1) (byteIndex div blockSize)
                (writeCArray
                  (readCArray (data cfile1) (byteIndex div blockSize))
                  (byteIndex mod blockSize) value) |) =
          cfile2;
          ~ blockNum < nextFreeBlock cfile2; blockNum < numBlocks;
          i < blockSize; byteIndex div blockSize < numBlocks;
          byteIndex < fileSize cfile1 |]
       ==> blockNum ~= byteIndex div blockSize"
apply (simp add: nextFreeBlockInvariant_def)
apply (subgoal_tac "byteIndex div blockSize < nextFreeBlock cfile1")
apply force
apply (subgoal_tac "nextFreeBlock cfile1 =
  (fileSize cfile1 + blockSize - Suc 0) div blockSize", simp_all)
apply (insert mod_round_lt)
apply force
done

lemma cfWritePreservesUnallocatedBlocksInvariant:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2
    |] ==> unallocatedBlocksInvariant cfile2"
apply (simp add: reachabilityInvariant_def)
apply (subgoal_tac "nextFreeBlock cfile1 <= nextFreeBlock cfile2")
apply (simp add: unallocatedBlocksInvariant_def cfWrite_def)
apply auto
apply (case_tac "byteIndex div blockSize < numBlocks", simp_all)
apply (case_tac "byteIndex < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply (simp_all add: writeCArray_def readCArray_def)
apply (subgoal_tac "blockNum ~= byteIndex div blockSize")
apply force
apply (simp add: blockNumNELemma)
apply (subgoal_tac "~ blockNum < nextFreeBlock cfile1")
apply (subgoal_tac "blockNum ~= byteIndex div blockSize")
apply auto
apply (simp add: nextFreeBlockIncreases)
done

lemma cfWritePreservesLastBlockInvariant:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2 |] ==>
    lastBlockInvariant cfile2"
apply (simp add: reachabilityInvariant_def)
apply (subgoal_tac "nextFreeBlock cfile1 <= nextFreeBlock cfile2")
apply (simp add: cfWrite_def)
apply (simp (no_asm) add: lastBlockInvariant_def)
apply auto
apply (case_tac "byteIndex div blockSize < numBlocks", simp_all)
apply (case_tac "byteIndex < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def Let_def cfExtendFile_def)
apply (simp_all add: writeCArray_def readCArray_def)
apply (simp add: lastBlockInvariant_def)
apply (subgoal_tac "index ~= byteIndex")
apply (case_tac "index div blockSize ~= byteIndex div blockSize")
apply force
apply (subgoal_tac "index mod blockSize ~= byteIndex mod blockSize")
apply force
apply (insert modInequalityLemma)
apply force
apply force
apply (subgoal_tac "index ~= byteIndex")
apply (case_tac "index div blockSize ~= byteIndex div blockSize", simp_all)
apply force
apply (subgoal_tac "index mod blockSize ~= byteIndex mod blockSize")
apply (case_tac "nextFreeBlock cfile1 = Suc (index div blockSize)")
apply (subgoal_tac "~ index < fileSize cfile1");
apply (simp add: lastBlockInvariant_def)
apply auto
apply (simp add: unallocatedBlocksInvariant_def)
apply (erule_tac x="index div blockSize" in allE)
apply (erule_tac x="index mod blockSize" in allE)
apply (simp add: nonZeroBlockSize)
apply (insert modInequalityLemma)
apply auto
apply (simp add: nextFreeBlockIncreases)
done

text {* Final statement that all invariants are preserved. *}
lemma cfWritePreserves:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2 |] ==>
    reachabilityInvariant cfile2"
apply (simp (no_asm) add: reachabilityInvariant_def)
apply (simp add: cfWritePreservesNextFreeBlockInvariant)
apply (simp add: cfWritePreservesUnallocatedBlocksInvariant)
apply (simp add: cfWritePreservesLastBlockInvariant)
done

(* ---------------------------------------------------------------*)
subsection {* Commuting Diagrams for Simulation Relation *}

text {* Here we show correctness of file system operations. *}

(* ---------------------------------------------------------------*)
subsubsection {* Abstraction Function *}

definition abstFn :: "CFile => AFile" where
  "abstFn cfile == (fileSize cfile,
                    % index . case cfRead cfile index of
                                None       => fillByte
                              | Some value => value)"

primrec oAbstFn :: "CFile option => AFile option" where
  "oAbstFn None = None"
| "oAbstFn (Some s) = Some (abstFn s)"

(* ---------------------------------------------------------------*)
subsubsection {* Creating a File *}

lemma makeCFCorrect: "abstFn makeCF = makeAF"
by (simp add: makeCF_def makeAF_def abstFn_def cfRead_def
    split add: bool.splits option.splits)

subsubsection {* File Size *}

lemma fileSizeCorrect:
  "cfSize cfile = afSize (abstFn cfile)"
by (simp add: cfSize_def afSize_def abstFn_def)

subsubsection {* Read Operation *}

lemma readCorrect:
  "cfRead cfile = afRead (abstFn cfile)"
apply (simp add: abstFn_def)
apply (rule ext)
apply (simp add: cfRead_def afRead_def Let_def)
done

subsubsection {* Write Operation *}

lemma writeNoExtendCorrect:
  "[| index < fileSize cfile1;
      Some cfile2 = cfWrite cfile1 index value
   |] ==> Some (abstFn cfile2) = afWrite (abstFn cfile1) index value"
apply (simp add: abstFn_def afWrite_def raWrite_def Let_def cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (simp_all add: cfWriteNoExtend_def Let_def)
apply (rule ext)
apply (simp add: cfRead_def writeCArray_def readCArray_def Let_def)
apply (case_tac "indexa < fileSize cfile1", simp_all)
apply (case_tac "indexa = index", simp_all)
apply (case_tac "indexa mod blockSize = index mod blockSize", simp_all)
apply (subgoal_tac "indexa div blockSize ~= index div blockSize", simp_all)
apply (simp_all add: modInequalityLemma)
done

lemma writeFailCorrect:
  "cfWrite cfile1 index value = None ==>
   afWrite (abstFn cfile1) index value = None"
apply (simp add: abstFn_def cfWrite_def afWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (case_tac "index < fileSize cfile1", simp_all)
done

lemma writeCorrect:
  "reachabilityInvariant cfile1 ==>
   oAbstFn (cfWrite cfile1 index value) = afWrite (abstFn cfile1) index value"
apply (simp add: reachabilityInvariant_def)
apply (case_tac "cfWrite cfile1 index value")
apply (simp add: writeFailCorrect)
apply (simp add: writeSucceedCorrect)
done

end


(*<*)
theory definitionCategory imports FreeLogic LaTeXsugar InverseSemigroup

begin
(*>*)

(*<*)
 (*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 120]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 e spass]
  nitpick_params [user_axioms, show_all, format = 2]
  (*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)
(*>*)
(*<*)

typedecl \<alpha> \<comment>\<open>This type can be thought of representing the morphisms of a category.\<close>

locale category =
           \<comment>\<open>We need three functions and constant to define a category.\<close>
  fixes domain:: "\<alpha> \<Rightarrow> \<alpha>" ("dom _" [108] 109) and
        codomain:: "\<alpha> \<Rightarrow> \<alpha>" ("cod _" [110] 111) and
        composition:: "\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" (infix "\<cdot>" 110) and
        star::\<alpha> ("\<^bold>*") \<comment>\<open>Symbol for non-existing elements in terms of free logic\<close>

  assumes
\<comment>\<open>Here we define the axioms that the morphisms
    in interaction with the functions have to obey.\<close>

\<comment>\<open>The existence of the domain of a morphism implies the existence of the morphism.\<close>
        S1: "E(dom x) \<^bold>\<rightarrow> E x" and
        S2: "E(cod y) \<^bold>\<rightarrow> E y" and         \<comment>\<open>The same goes for the codomain.\<close>

\<comment>\<open>As we have seen, the composition only exists if the two morphisms are composable.\<close>
\<comment>\<open>We use \<simeq> to denote the existing equality which requires that both sides
    of the equation exist.\<close>
        S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and

        S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and     \<comment>\<open>Composition of morphisms is associative.\<close>
\<comment>\<open>We use \<cong> to denote the Kleene equality which only implies equality
    if at least one side of the equation exists\<close>

\<comment>\<open>The domain of a morphisms serves as the right identity for composition.\<close>
        S5: "x\<cdot>(dom x) \<cong> x" and
        S6: "(cod y)\<cdot>y \<cong> y" and   \<comment>\<open>So does the codomain as a left identity.\<close>

\<comment>\<open>Finally we make sure that there is only one non-existing morphism.\<close>
        L1: "\<^bold>\<not>(E m) \<^bold>\<rightarrow> (m = \<^bold>*)"

begin
\<comment>\<open>We show consistency.\<close>
lemma "True" nitpick[satisfy] oops

\<comment>\<open>As desired non-existing morphisms are equal.\<close>
lemma "(\<^bold>\<not>(E x) \<^bold>\<and> \<^bold>\<not>(E y)) \<^bold>\<rightarrow> (x = y \<^bold>\<and> x = \<^bold>*)"
  using L1 by blast

end

text
\<open>
We want to give a brief explanation of the symbols used. Again this will be a short treatment and
we refer to \cite{J40} and \cite{R58} for a more complete account. It is worth noting that the
following functions were defined polymorphic in order for the free logic implementation to be used
type independent. This is why @{text "'a"} appears in the following as the type of the variables.

\begin{itemize}
\item The predicate @{text "E"} is defined as @{const_typ FreeLogic.fExistence} and tells us whether or
not the individual passed as a parameter exists.

\item @{const ExId} is called the \emph{existing identity} and is defined as \[ @{abbrev FreeLogic.ExId}. \]
Therefore, it is only true if both elements being compared exist and are equal.

\item @{const KlEq} is called the \emph{Kleene equality} and is defined as \[ @{abbrev KlEq}. \] Therefore,
this equality does not imply the existence of the elements being compared.
\end{itemize}

Moreover, we will encounter @{text "\<^bold>\<forall>"} and @{text "\<^bold>\<exists>"} which have been
redefined to quantify only over the existing individuals. This is done by defining \[ @{abbrev fForall} \]
and \[ @{abbrev fExists}. \] Note that writing @{term "\<^bold>\<forall>x. \<Phi> x"} really means @{text "\<^bold>\<forall>\<Phi>::'a \<Rightarrow> bool"} since we
have the quantification in the definition of @{text "\<^bold>\<forall>"}. The situation is analogue for @{text "\<^bold>\<exists>"}.
\<close>

section\<open>Two axiomatizations of an inverse category\<close>

text
\<open>
Given this framework our goal now is to show that by adding to a category the axioms of an inverse semigroup that are
responsible for shaping the inverse (definition \ref{def: inverse}, axioms 2), 3) and 4) ) we arrive at a category that is
equivalent to the definition of an inverse category.

\begin{definition}[Inverse category\footnotemark] \footcitetext{Kastl1979}
  A small category $\cat C$ is called an inverse category if for any morphism $s: X \to Y \in \cat C$
  there exists a unique morphisms $\hat{s}: Y \to X$ such that $s = s \cdot \hat{s} \cdot s$ and
  $\hat{s} = \hat{s} \cdot s \cdot \hat{s}$.
\end{definition}

We will rewrite this in order to avoid to run into the problem with skolemization again as we did
in \ref{sec: inverseSemi}. In Isabelle/HOL we define the inverse in the @{text "locale category"}
and then go on to define an inverse category.
\<close>

abbreviation (in category) inverseDef::"\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool" ("_ inverseOf _")
  where "t inverseOf s \<equiv> s \<cong> s\<cdot>(t\<cdot>s) \<^bold>\<and> t \<cong> t\<cdot>(s\<cdot>t)"
\<comment>\<open>On the right hand side we find the definition for the inverse.\<close>

locale inverseCategory = category +
\<comment>\<open>We introduce the new function symbol representing the inverse in the signature.\<close>
  fixes inverse::"\<alpha> \<Rightarrow> \<alpha>" ("inv _")
  assumes  uniqueInv:
\<comment>\<open>We axiomatize that every morphism has a unique inverse.\<close>
     "\<forall>s. (((inv s) inverseOf s) \<^bold>\<and> (\<forall>w. (w inverseOf s) \<^bold>\<rightarrow> w \<cong> (inv s)))"

\<comment>\<open>exNot: "$\exists x::\alpha. \neg (E x)$" was also tested as an axiom and nitpick confirmed satisfiability\<close>
begin
lemma "True" nitpick[satisfy] oops

\<comment>\<open>We prove that the existence of a morphism implies the existence of its inverse and the converse.\<close>
lemma exInv: "(E x) \<^bold>\<rightarrow> (E (inv x))"
  by (metis S1 S2 S3 uniqueInv)

lemma "E (inv x) \<^bold>\<rightarrow> (E x)"
  by (metis S1 S3 uniqueInv)

end

text
\<open>
Next we want to prove that the set of axioms used in an inverse semigroup to characterize the inverse
also hold in an inverse category.
\<close>

context inverseCategory begin

proposition Regularity: "x\<cdot>((inv x)\<cdot>x) \<cong> x"
  by (metis uniqueInv)

proposition InvInv: "((inv (inv x)) \<cong> x)"
  by (metis uniqueInv)

proposition IdemComm:
  "((x\<cdot>inv x)\<cdot>(y\<cdot>(inv y))) \<cong> ((y\<cdot>(inv y)) \<cdot> (x\<cdot>(inv x)))" oops

text
\<open>
The last proposition cannot be proved at this moment by automation. The case is very similar to
what we have already encountered in the proof of proposition \ref{prop: equInvToAx}. And in fact in this
section we did the proof by hand. The same proof works here in analogy once we establish
that given a morphism $x$ in an inverse category it holds that $x \cdot \hat{x}$ is idempotent.
\<close>

abbreviation (in category) Idem::"\<alpha> \<Rightarrow> bool" ("Idem _")
  where "Idem x \<equiv> (x \<cdot> x \<cong> x)"

lemma compIdem: "(Idem (x\<cdot>(inv x)))"
  by (metis S2 S3 S4 uniqueInv)
end

text
\<open>
Hence we have shown that those three inverse semigroup axioms hold in an inverse category.
Next we want to show that the converse also works and therefore we will have found a quantifier free
axiomatization of an inverse category.
\<close>

locale inverseCategoryQantFree = category +
\<comment>\<open>We introduce the new function symbol representing the inverse in the signature.\<close>
  fixes inverse::"\<alpha> \<Rightarrow> \<alpha>" ("inv _")
\<comment>\<open>We add the axioms that shape the inverse in an inverse semigroup.\<close>
  assumes C1: "x\<cdot>((inv x)\<cdot>x) \<cong> x" and
          C2: "((inv (inv x)) \<cong> x)" and
          C3: "((x\<cdot>inv x) \<cdot> (y\<cdot>(inv y))) \<cong> ((y\<cdot>(inv y)) \<cdot> (x\<cdot>(inv x)))"

begin
lemma "True" nitpick[satisfy] oops

\<comment>\<open>We show the strictness of @{text "E"} for the inverse\<close>
lemma "(E x) \<^bold>\<leftrightarrow> (E (inv x))"
  by (metis C1 C2 S1 S2 S3)

\<comment>\<open>We need to build some theory in this context to show the result\<close>
lemma IdemComp: "Idem (x \<cdot> (inv x))"
  by (smt S1 S3 S4 C1)

lemma (in inverseCategoryQantFree) IdempotentsCommute:
  "((E x) \<^bold>\<and> (E y) \<^bold>\<and> (Idem x) \<^bold>\<and> (Idem y)) \<^bold>\<rightarrow> (x\<cdot>y \<cong> y\<cdot>x)"
    by (smt C3 S1 S2 S3 S4 inverseCategoryQantFree.C1
        inverseCategoryQantFree.C2 inverseCategoryQantFree_axioms)

lemma inverseUnique: "((y inverseOf x) \<^bold>\<and> (z inverseOf x)) \<^bold>\<rightarrow> (y \<cong> z)"
  by (metis IdempotentsCommute S1 S2 S3 S4)

\<comment>\<open>The next proposition is the result we wanted to show.\<close>
proposition  inverseUnique2:
  "\<forall>s. (((inv s) inverseOf s) \<^bold>\<and> (\<forall>w. (w inverseOf s) \<^bold>\<rightarrow> w \<cong> (inv s)))"
  by (smt C1 C2 S1 S2 S3 inverseUnique)

end

section\<open>Inverse category as a generalization of an inverse semigroup\<close>

text
\<open>
A category can be seen as a generalization of a monoid in the sense that a one object category is a
monoid. After what we have seen the inverse category seems to be a generalization of an inverse
semigroup. We will prove now that this is indeed true.

\begin{proposition}
  Let $\cat C$ be an inverse category with exactly one object. Then $\cat C$ is an inverse semigroup.
\end{proposition}

We will try to do the proof by inclusion of locales in Isabelle/HOL. Therefore we will define an
inverse category for which we require to have exactly one object and then show that this is a
sublocale of an inverse semigroup. Note that in this case we can assume all morphisms to exist
because the composition is total if there is just one object. We make use of the element @{text "\<^bold>*"}
which represents the non-existing element if a non-existing element is present. Because we assume all morphisms
to exist we can use @{text "\<^bold>*"} to represent the single existing object.
Also note that as a result the quantifiers for free logic collapse to the quantifiers of classical logic
in a one-object inverse category.
\<close>

locale inverseCategoryOneObject = inverseCategoryQantFree +
  assumes only_star: "(E \<^bold>*) \<^bold>\<and> (\<forall>x. dom(x) = \<^bold>* \<^bold>\<and> cod(x) = \<^bold>*)"
begin
lemma "True"  nitpick[satisfy] oops

lemma "\<forall>x::\<alpha>. (E x)"
  using S1 only_star by auto

lemma associative: "((x\<cdot>y)\<cdot>z) = (x\<cdot>(y\<cdot>z))"
  using S2 S4 only_star by auto

\<comment>\<open>It is possible to have more than just one morphism. Exactly what we want.\<close>
lemma "\<forall>x::\<alpha>. x = star" nitpick oops

end

sublocale inverseCategoryOneObject \<subseteq> inverseSemigroup "inverse" "composition"
proof -
  have f1: "\<forall>a. E (a::\<alpha>)"
    by (metis S2 only_star)
  then have f2:
      "\<forall>x. \<forall>y. ((y \<cdot> ((inv y) \<cdot> (x \<cdot> (inv x))) \<^bold>= (x \<cdot> ((inv x) \<cdot> (y \<cdot> (inv y))))))"
        using C3 associative by auto
  then show "inverseSemigroup inverse (\<cdot>)"
    using f1 by (simp add: C1 C2 associative inverseSemigroup.intro)
qed

text
\<open>
We have succeeded to prove that an inverse category with one element is a semigroup with the
Isabelle/HOL command @{text "sledgehammer"}. It gave back a Isar proof in which we had to slightly
correct parentheses but except for that it worked out of the box.

As a result we may now try to formulate the semimodeloidal axioms in the context of inverse categories.
The outcome we want is that these axioms in a one object inverse category will form a semimodeloid.
\<close>

(*>*)
context inverseCategoryQantFree
begin
(*
lemma "\<forall>x. E(dom x)  \<^bold>\<rightarrow> (\<^bold>\<exists>y. ((dom y) \<simeq> (cod y)))"
  by (metis S3 S5 S6)

lemma "(E x \<and> x \<cong> y)  \<^bold>\<rightarrow> E y"
  by blast
*)
\<comment>\<open>It is to note that we do not need to specify the domain and codomain of the idempotent.\<close>
abbreviation natOrder:: "\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool" ("_ \<^bold>\<le> _" 111) where
  "(x \<^bold>\<le> y) \<equiv> (\<exists>e. (Idem e) \<and>  (x \<cong> y\<cdot>e))"
(*abbreviation atomar::"\<alpha> \<Rightarrow> bool" ("Atom _")
  where "(Atom e) \<equiv> (((E e) \<longrightarrow> (e \<noteq> zero)) \<and> (\<forall>f. ((f \<^bold>\<le> e) \<longrightarrow> ((f \<cong> e) \<or> ( f \<cong> zero)))))"

lemma "\<^bold>\<not>(E x) \<longrightarrow> (Atom x)"
  using S1 S3 by blast

lemma assumes "(E f) \<and> (E a) \<and> (E c) \<and> (c \<^bold>\<le> (f \<cdot> (a \<cdot> (inv f)))) \<and> (Idem a) \<and> (Atom a)" shows "(((inv f) \<cdot> (c \<cdot> f)) = zero) \<longrightarrow> (c inverseOf ((inv f) \<cdot> (c \<cdot> f)))"
  by (smt IdempotentsCommute S1 S3 S4 assms inverseCategoryQantFree.C2 inverseCategoryQantFree0.axioms(2) inverseCategoryQantFree0_axioms inverseCategoryQantFree0_axioms_def inverseCategoryQantFree_axioms inverseUnique2)

lemma assumes "(E f) \<and> (E a) \<and> (E c) \<and> (c \<^bold>\<le> (f \<cdot> (a \<cdot> (inv f)))) \<and> (Idem a) \<and> (Atom a)" shows "(((inv f) \<cdot> (c \<cdot> f)) = zero) \<longrightarrow> (c = zero)"
  by (smt IdemComp S2 S3 S4 assms inverseCategoryQantFree.IdempotentsCommute inverseCategoryQantFree0.axioms(2) inverseCategoryQantFree0_axioms inverseCategoryQantFree0_axioms_def inverseCategoryQantFree_axioms inverseUnique2)
*)

lemma Nr1: "((Idem a) \<^bold>\<and> (Idem b)) \<^bold>\<rightarrow> (a\<cdot>b = b\<cdot>a)"
  by (metis IdempotentsCommute L1 S1 S2 S3)

lemma Nr2a: "(E (t\<cdot>s)) \<^bold>\<rightarrow>  (dom(t\<cdot>s) \<simeq> dom(s))"
  by (metis S2 S3 S4 S5)

lemma Nr2b: "(E (t\<cdot>s)) \<^bold>\<rightarrow> (cod(t\<cdot>s) \<simeq> cod(t))"
  by (metis S1 S3 S4 S6)

lemma helpInvSwitch: "(s\<cdot>t)\<cdot>(((inv t) \<cdot> (inv s))\<cdot>(s\<cdot>t)) \<cong> (s\<cdot>t)"
proof -
  have "( s\<cdot> ( (t\<cdot>(inv t)) \<cdot> (((inv s)\<cdot>s)\<cdot>t))) \<cong> ((s \<cdot> (inv s)) \<cdot> s) \<cdot> ((t \<cdot> (inv t)) \<cdot> t)"
    by (smt Nr1 S1 S3 S4 inverseUnique2)
  then show ?thesis
by (smt S1 S2 S3 S4 inverseUnique2)
qed

lemma Nr3: "(inv (t\<cdot>s)) \<cong> (inv s) \<cdot> (inv t)"
  by (smt L1 helpInvSwitch inverseUnique2)

lemma Nr4a: "dom (inv (s)) \<cong> cod(s)"
  by (metis S1 S2 S3 inverseUnique2)

lemma Nr4b: "(cod (inv s)) \<cong> dom(s)"
  by (metis S1 S2 S3 inverseUnique2)

lemma Nr5: "(s \<^bold>\<le> t) \<^bold>\<rightarrow> ((inv s) \<^bold>\<le> (inv t))"
  by (metis S2 S3 S4 inverseUnique2)

lemma Nr6a: "(s \<^bold>\<le> t) \<^bold>\<rightarrow> (s \<cong> (t\<cdot>((inv s)\<cdot>s)))"
  by (smt Nr1 L1 category.S4 category_axioms inverseUnique2)

lemma Nr6b: "(s \<^bold>\<le> t) \<^bold>\<rightarrow> (s \<cong> (s\<cdot>((inv s)\<cdot>t)))"
  by (smt C2 L1 Nr2b Nr3 Nr4b S1 S4 inverseUnique2)

lemma helpNr7: assumes "(s \<^bold>\<le> t)" shows "(t \<cdot> ((inv s) \<cdot> s)) \<cong> (s \<cdot> ((inv s) \<cdot> t))"
  by (smt Nr6a Nr6b assms)

\<comment>\<open>This proof somehow is really really hard for sledgehammer.\<close>
lemma Nr7: assumes f1: "((a \<^bold>\<le> s) \<^bold>\<and> (b \<^bold>\<le> t))" shows "((b\<cdot>a)\<^bold>\<le>(t\<cdot>s))"
proof-
  from f1 have f2: "a \<cong> s \<cdot> ((inv a) \<cdot> a)"
    using Nr6a by auto
  from f1 have f3: "b \<cong> (b \<cdot> (inv b)) \<cdot> t"
    by (smt Nr6b S4)
  have f4: "b\<cdot>a \<cong> ((b \<cdot> (inv b))\<cdot>t)\<cdot>(s \<cdot>((inv a) \<cdot> a))"
    by (metis L1 f2 f3)
  then have "(inv (b\<cdot>a)) \<cong> (inv (t\<cdot>(s\<cdot>((inv a)\<cdot>a)))) \<cdot> (b \<cdot> (inv b))"
    by (smt L1 Nr3 category.S4 category_axioms inverseUnique2)
  then have "(inv (b\<cdot>a)) \<^bold>\<le> (inv (t\<cdot>(s\<cdot>((inv a)\<cdot>a))))"
    by (smt IdemComp)
  then have "(inv (inv (b\<cdot>a))) \<^bold>\<le> (inv (inv(t\<cdot>(s\<cdot>((inv a)\<cdot>a)))))"
    using Nr5 by auto
  then have f5: "(b\<cdot>a)  \<^bold>\<le> (t\<cdot>(s\<cdot>((inv a)\<cdot>a)))"
    by (metis C2 Nr2b S2)
  then have "\<exists>e. (Idem e) \<and> b\<cdot>a \<cong> ((t\<cdot>s)\<cdot>e)"
    by (smt C1 C2 IdemComp L1 Nr1 Nr2b Nr3 Nr4a S3 S4  category.S1 category.S2 category_axioms f2 f4 inverseUnique2)
  then show ?thesis
    by blast
qed
end

(*<*)
end
(*>*)