--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Correctness.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,812 @@
+theory Correctness
+imports PIPBasics
+begin
+
+
+text {*
+ The following two auxiliary lemmas are used to reason about @{term Max}.
+*}
+lemma image_Max_eqI:
+ assumes "finite B"
+ and "b \<in> B"
+ and "\<forall> x \<in> B. f x \<le> f b"
+ shows "Max (f ` B) = f b"
+ using assms
+ using Max_eqI by blast
+
+lemma image_Max_subset:
+ assumes "finite A"
+ and "B \<subseteq> A"
+ and "a \<in> B"
+ and "Max (f ` A) = f a"
+ shows "Max (f ` B) = f a"
+proof(rule image_Max_eqI)
+ show "finite B"
+ using assms(1) assms(2) finite_subset by auto
+next
+ show "a \<in> B" using assms by simp
+next
+ show "\<forall>x\<in>B. f x \<le> f a"
+ by (metis Max_ge assms(1) assms(2) assms(4)
+ finite_imageI image_eqI subsetCE)
+qed
+
+text {*
+ The following locale @{text "highest_gen"} sets the basic context for our
+ investigation: supposing thread @{text th} holds the highest @{term cp}-value
+ in state @{text s}, which means the task for @{text th} is the
+ most urgent. We want to show that
+ @{text th} is treated correctly by PIP, which means
+ @{text th} will not be blocked unreasonably by other less urgent
+ threads.
+*}
+locale highest_gen =
+ fixes s th prio tm
+ assumes vt_s: "vt s"
+ and threads_s: "th \<in> threads s"
+ and highest: "preced th s = Max ((cp s)`threads s)"
+ -- {* The internal structure of @{term th}'s precedence is exposed:*}
+ and preced_th: "preced th s = Prc prio tm"
+
+-- {* @{term s} is a valid trace, so it will inherit all results derived for
+ a valid trace: *}
+sublocale highest_gen < vat_s: valid_trace "s"
+ by (unfold_locales, insert vt_s, simp)
+
+context highest_gen
+begin
+
+text {*
+ @{term tm} is the time when the precedence of @{term th} is set, so
+ @{term tm} must be a valid moment index into @{term s}.
+*}
+lemma lt_tm: "tm < length s"
+ by (insert preced_tm_lt[OF threads_s preced_th], simp)
+
+text {*
+ Since @{term th} holds the highest precedence and @{text "cp"}
+ is the highest precedence of all threads in the sub-tree of
+ @{text "th"} and @{text th} is among these threads,
+ its @{term cp} must equal to its precedence:
+*}
+lemma eq_cp_s_th: "cp s th = preced th s" (is "?L = ?R")
+proof -
+ have "?L \<le> ?R"
+ by (unfold highest, rule Max_ge,
+ auto simp:threads_s finite_threads)
+ moreover have "?R \<le> ?L"
+ by (unfold vat_s.cp_rec, rule Max_ge,
+ auto simp:the_preced_def vat_s.fsbttRAGs.finite_children)
+ ultimately show ?thesis by auto
+qed
+
+lemma highest_cp_preced: "cp s th = Max (the_preced s ` threads s)"
+ using eq_cp_s_th highest max_cp_eq the_preced_def by presburger
+
+
+lemma highest_preced_thread: "preced th s = Max (the_preced s ` threads s)"
+ by (fold eq_cp_s_th, unfold highest_cp_preced, simp)
+
+lemma highest': "cp s th = Max (cp s ` threads s)"
+ by (simp add: eq_cp_s_th highest)
+
+end
+
+locale extend_highest_gen = highest_gen +
+ fixes t
+ assumes vt_t: "vt (t@s)"
+ and create_low: "Create th' prio' \<in> set t \<Longrightarrow> prio' \<le> prio"
+ and set_diff_low: "Set th' prio' \<in> set t \<Longrightarrow> th' \<noteq> th \<and> prio' \<le> prio"
+ and exit_diff: "Exit th' \<in> set t \<Longrightarrow> th' \<noteq> th"
+
+sublocale extend_highest_gen < vat_t: valid_trace "t@s"
+ by (unfold_locales, insert vt_t, simp)
+
+lemma step_back_vt_app:
+ assumes vt_ts: "vt (t@s)"
+ shows "vt s"
+proof -
+ from vt_ts show ?thesis
+ proof(induct t)
+ case Nil
+ from Nil show ?case by auto
+ next
+ case (Cons e t)
+ assume ih: " vt (t @ s) \<Longrightarrow> vt s"
+ and vt_et: "vt ((e # t) @ s)"
+ show ?case
+ proof(rule ih)
+ show "vt (t @ s)"
+ proof(rule step_back_vt)
+ from vt_et show "vt (e # t @ s)" by simp
+ qed
+ qed
+ qed
+qed
+
+(* locale red_extend_highest_gen = extend_highest_gen +
+ fixes i::nat
+*)
+
+(*
+sublocale red_extend_highest_gen < red_moment: extend_highest_gen "s" "th" "prio" "tm" "(moment i t)"
+ apply (insert extend_highest_gen_axioms, subst (asm) (1) moment_restm_s [of i t, symmetric])
+ apply (unfold extend_highest_gen_def extend_highest_gen_axioms_def, clarsimp)
+ by (unfold highest_gen_def, auto dest:step_back_vt_app)
+*)
+
+context extend_highest_gen
+begin
+
+ lemma ind [consumes 0, case_names Nil Cons, induct type]:
+ assumes
+ h0: "R []"
+ and h2: "\<And> e t. \<lbrakk>vt (t@s); step (t@s) e;
+ extend_highest_gen s th prio tm t;
+ extend_highest_gen s th prio tm (e#t); R t\<rbrakk> \<Longrightarrow> R (e#t)"
+ shows "R t"
+proof -
+ from vt_t extend_highest_gen_axioms show ?thesis
+ proof(induct t)
+ from h0 show "R []" .
+ next
+ case (Cons e t')
+ assume ih: "\<lbrakk>vt (t' @ s); extend_highest_gen s th prio tm t'\<rbrakk> \<Longrightarrow> R t'"
+ and vt_e: "vt ((e # t') @ s)"
+ and et: "extend_highest_gen s th prio tm (e # t')"
+ from vt_e and step_back_step have stp: "step (t'@s) e" by auto
+ from vt_e and step_back_vt have vt_ts: "vt (t'@s)" by auto
+ show ?case
+ proof(rule h2 [OF vt_ts stp _ _ _ ])
+ show "R t'"
+ proof(rule ih)
+ from et show ext': "extend_highest_gen s th prio tm t'"
+ by (unfold extend_highest_gen_def extend_highest_gen_axioms_def, auto dest:step_back_vt)
+ next
+ from vt_ts show "vt (t' @ s)" .
+ qed
+ next
+ from et show "extend_highest_gen s th prio tm (e # t')" .
+ next
+ from et show ext': "extend_highest_gen s th prio tm t'"
+ by (unfold extend_highest_gen_def extend_highest_gen_axioms_def, auto dest:step_back_vt)
+ qed
+ qed
+qed
+
+
+lemma th_kept: "th \<in> threads (t @ s) \<and>
+ preced th (t@s) = preced th s" (is "?Q t")
+proof -
+ show ?thesis
+ proof(induct rule:ind)
+ case Nil
+ from threads_s
+ show ?case
+ by auto
+ next
+ case (Cons e t)
+ interpret h_e: extend_highest_gen _ _ _ _ "(e # t)" using Cons by auto
+ interpret h_t: extend_highest_gen _ _ _ _ t using Cons by auto
+ show ?case
+ proof(cases e)
+ case (Create thread prio)
+ show ?thesis
+ proof -
+ from Cons and Create have "step (t@s) (Create thread prio)" by auto
+ hence "th \<noteq> thread"
+ proof(cases)
+ case thread_create
+ with Cons show ?thesis by auto
+ qed
+ hence "preced th ((e # t) @ s) = preced th (t @ s)"
+ by (unfold Create, auto simp:preced_def)
+ moreover note Cons
+ ultimately show ?thesis
+ by (auto simp:Create)
+ qed
+ next
+ case (Exit thread)
+ from h_e.exit_diff and Exit
+ have neq_th: "thread \<noteq> th" by auto
+ with Cons
+ show ?thesis
+ by (unfold Exit, auto simp:preced_def)
+ next
+ case (P thread cs)
+ with Cons
+ show ?thesis
+ by (auto simp:P preced_def)
+ next
+ case (V thread cs)
+ with Cons
+ show ?thesis
+ by (auto simp:V preced_def)
+ next
+ case (Set thread prio')
+ show ?thesis
+ proof -
+ from h_e.set_diff_low and Set
+ have "th \<noteq> thread" by auto
+ hence "preced th ((e # t) @ s) = preced th (t @ s)"
+ by (unfold Set, auto simp:preced_def)
+ moreover note Cons
+ ultimately show ?thesis
+ by (auto simp:Set)
+ qed
+ qed
+ qed
+qed
+
+text {*
+ According to @{thm th_kept}, thread @{text "th"} has its living status
+ and precedence kept along the way of @{text "t"}. The following lemma
+ shows that this preserved precedence of @{text "th"} remains as the highest
+ along the way of @{text "t"}.
+
+ The proof goes by induction over @{text "t"} using the specialized
+ induction rule @{thm ind}, followed by case analysis of each possible
+ operations of PIP. All cases follow the same pattern rendered by the
+ generalized introduction rule @{thm "image_Max_eqI"}.
+
+ The very essence is to show that precedences, no matter whether they
+ are newly introduced or modified, are always lower than the one held
+ by @{term "th"}, which by @{thm th_kept} is preserved along the way.
+*}
+lemma max_kept: "Max (the_preced (t @ s) ` (threads (t@s))) = preced th s"
+proof(induct rule:ind)
+ case Nil
+ from highest_preced_thread
+ show ?case by simp
+next
+ case (Cons e t)
+ interpret h_e: extend_highest_gen _ _ _ _ "(e # t)" using Cons by auto
+ interpret h_t: extend_highest_gen _ _ _ _ t using Cons by auto
+ show ?case
+ proof(cases e)
+ case (Create thread prio')
+ show ?thesis (is "Max (?f ` ?A) = ?t")
+ proof -
+ -- {* The following is the common pattern of each branch of the case analysis. *}
+ -- {* The major part is to show that @{text "th"} holds the highest precedence: *}
+ have "Max (?f ` ?A) = ?f th"
+ proof(rule image_Max_eqI)
+ show "finite ?A" using h_e.finite_threads by auto
+ next
+ show "th \<in> ?A" using h_e.th_kept by auto
+ next
+ show "\<forall>x\<in>?A. ?f x \<le> ?f th"
+ proof
+ fix x
+ assume "x \<in> ?A"
+ hence "x = thread \<or> x \<in> threads (t@s)" by (auto simp:Create)
+ thus "?f x \<le> ?f th"
+ proof
+ assume "x = thread"
+ thus ?thesis
+ apply (simp add:Create the_preced_def preced_def, fold preced_def)
+ using Create h_e.create_low h_t.th_kept lt_tm preced_leI2
+ preced_th by force
+ next
+ assume h: "x \<in> threads (t @ s)"
+ from Cons(2)[unfolded Create]
+ have "x \<noteq> thread" using h by (cases, auto)
+ hence "?f x = the_preced (t@s) x"
+ by (simp add:Create the_preced_def preced_def)
+ hence "?f x \<le> Max (the_preced (t@s) ` threads (t@s))"
+ by (simp add: h_t.finite_threads h)
+ also have "... = ?f th"
+ by (metis Cons.hyps(5) h_e.th_kept the_preced_def)
+ finally show ?thesis .
+ qed
+ qed
+ qed
+ -- {* The minor part is to show that the precedence of @{text "th"}
+ equals to preserved one, given by the foregoing lemma @{thm th_kept} *}
+ also have "... = ?t" using h_e.th_kept the_preced_def by auto
+ -- {* Then it follows trivially that the precedence preserved
+ for @{term "th"} remains the maximum of all living threads along the way. *}
+ finally show ?thesis .
+ qed
+ next
+ case (Exit thread)
+ show ?thesis (is "Max (?f ` ?A) = ?t")
+ proof -
+ have "Max (?f ` ?A) = ?f th"
+ proof(rule image_Max_eqI)
+ show "finite ?A" using h_e.finite_threads by auto
+ next
+ show "th \<in> ?A" using h_e.th_kept by auto
+ next
+ show "\<forall>x\<in>?A. ?f x \<le> ?f th"
+ proof
+ fix x
+ assume "x \<in> ?A"
+ hence "x \<in> threads (t@s)" by (simp add: Exit)
+ hence "?f x \<le> Max (?f ` threads (t@s))"
+ by (simp add: h_t.finite_threads)
+ also have "... \<le> ?f th"
+ apply (simp add:Exit the_preced_def preced_def, fold preced_def)
+ using Cons.hyps(5) h_t.th_kept the_preced_def by auto
+ finally show "?f x \<le> ?f th" .
+ qed
+ qed
+ also have "... = ?t" using h_e.th_kept the_preced_def by auto
+ finally show ?thesis .
+ qed
+ next
+ case (P thread cs)
+ with Cons
+ show ?thesis by (auto simp:preced_def the_preced_def)
+ next
+ case (V thread cs)
+ with Cons
+ show ?thesis by (auto simp:preced_def the_preced_def)
+ next
+ case (Set thread prio')
+ show ?thesis (is "Max (?f ` ?A) = ?t")
+ proof -
+ have "Max (?f ` ?A) = ?f th"
+ proof(rule image_Max_eqI)
+ show "finite ?A" using h_e.finite_threads by auto
+ next
+ show "th \<in> ?A" using h_e.th_kept by auto
+ next
+ show "\<forall>x\<in>?A. ?f x \<le> ?f th"
+ proof
+ fix x
+ assume h: "x \<in> ?A"
+ show "?f x \<le> ?f th"
+ proof(cases "x = thread")
+ case True
+ moreover have "the_preced (Set thread prio' # t @ s) thread \<le> the_preced (t @ s) th"
+ proof -
+ have "the_preced (t @ s) th = Prc prio tm"
+ using h_t.th_kept preced_th by (simp add:the_preced_def)
+ moreover have "prio' \<le> prio" using Set h_e.set_diff_low by auto
+ ultimately show ?thesis by (insert lt_tm, auto simp:the_preced_def preced_def)
+ qed
+ ultimately show ?thesis
+ by (unfold Set, simp add:the_preced_def preced_def)
+ next
+ case False
+ then have "?f x = the_preced (t@s) x"
+ by (simp add:the_preced_def preced_def Set)
+ also have "... \<le> Max (the_preced (t@s) ` threads (t@s))"
+ using Set h h_t.finite_threads by auto
+ also have "... = ?f th" by (metis Cons.hyps(5) h_e.th_kept the_preced_def)
+ finally show ?thesis .
+ qed
+ qed
+ qed
+ also have "... = ?t" using h_e.th_kept the_preced_def by auto
+ finally show ?thesis .
+ qed
+ qed
+qed
+
+lemma max_preced: "preced th (t@s) = Max (the_preced (t@s) ` (threads (t@s)))"
+ by (insert th_kept max_kept, auto)
+
+text {*
+ The reason behind the following lemma is that:
+ Since @{term "cp"} is defined as the maximum precedence
+ of those threads contained in the sub-tree of node @{term "Th th"}
+ in @{term "RAG (t@s)"}, and all these threads are living threads, and
+ @{term "th"} is also among them, the maximum precedence of
+ them all must be the one for @{text "th"}.
+*}
+lemma th_cp_max_preced:
+ "cp (t@s) th = Max (the_preced (t@s) ` (threads (t@s)))" (is "?L = ?R")
+proof -
+ let ?f = "the_preced (t@s)"
+ have "?L = ?f th"
+ proof(unfold cp_alt_def, rule image_Max_eqI)
+ show "finite {th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}"
+ proof -
+ have "{th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)} =
+ the_thread ` {n . n \<in> subtree (RAG (t @ s)) (Th th) \<and>
+ (\<exists> th'. n = Th th')}"
+ by (smt Collect_cong Setcompr_eq_image mem_Collect_eq the_thread.simps)
+ moreover have "finite ..." by (simp add: vat_t.fsbtRAGs.finite_subtree)
+ ultimately show ?thesis by simp
+ qed
+ next
+ show "th \<in> {th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}"
+ by (auto simp:subtree_def)
+ next
+ show "\<forall>x\<in>{th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}.
+ the_preced (t @ s) x \<le> the_preced (t @ s) th"
+ proof
+ fix th'
+ assume "th' \<in> {th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}"
+ hence "Th th' \<in> subtree (RAG (t @ s)) (Th th)" by auto
+ moreover have "... \<subseteq> Field (RAG (t @ s)) \<union> {Th th}"
+ by (meson subtree_Field)
+ ultimately have "Th th' \<in> ..." by auto
+ hence "th' \<in> threads (t@s)"
+ proof
+ assume "Th th' \<in> {Th th}"
+ thus ?thesis using th_kept by auto
+ next
+ assume "Th th' \<in> Field (RAG (t @ s))"
+ thus ?thesis using vat_t.not_in_thread_isolated by blast
+ qed
+ thus "the_preced (t @ s) th' \<le> the_preced (t @ s) th"
+ by (metis Max_ge finite_imageI finite_threads image_eqI
+ max_kept th_kept the_preced_def)
+ qed
+ qed
+ also have "... = ?R" by (simp add: max_preced the_preced_def)
+ finally show ?thesis .
+qed
+
+lemma th_cp_max[simp]: "Max (cp (t@s) ` threads (t@s)) = cp (t@s) th"
+ using max_cp_eq th_cp_max_preced the_preced_def vt_t by presburger
+
+lemma [simp]: "Max (cp (t@s) ` threads (t@s)) = Max (the_preced (t@s) ` threads (t@s))"
+ by (simp add: th_cp_max_preced)
+
+lemma [simp]: "Max (the_preced (t@s) ` threads (t@s)) = the_preced (t@s) th"
+ using max_kept th_kept the_preced_def by auto
+
+lemma [simp]: "the_preced (t@s) th = preced th (t@s)"
+ using the_preced_def by auto
+
+lemma [simp]: "preced th (t@s) = preced th s"
+ by (simp add: th_kept)
+
+lemma [simp]: "cp s th = preced th s"
+ by (simp add: eq_cp_s_th)
+
+lemma th_cp_preced [simp]: "cp (t@s) th = preced th s"
+ by (fold max_kept, unfold th_cp_max_preced, simp)
+
+lemma preced_less:
+ assumes th'_in: "th' \<in> threads s"
+ and neq_th': "th' \<noteq> th"
+ shows "preced th' s < preced th s"
+ using assms
+by (metis Max.coboundedI finite_imageI highest not_le order.trans
+ preced_linorder rev_image_eqI threads_s vat_s.finite_threads
+ vat_s.le_cp)
+
+section {* The `blocking thread` *}
+
+text {*
+
+ The purpose of PIP is to ensure that the most urgent thread @{term
+ th} is not blocked unreasonably. Therefore, below, we will derive
+ properties of the blocking thread. By blocking thread, we mean a
+ thread in running state t @ s, but is different from thread @{term
+ th}.
+
+ The first lemmas shows that the @{term cp}-value of the blocking
+ thread @{text th'} equals to the highest precedence in the whole
+ system.
+
+*}
+
+lemma runing_preced_inversion:
+ assumes runing': "th' \<in> runing (t @ s)"
+ shows "cp (t @ s) th' = preced th s"
+proof -
+ have "cp (t @ s) th' = Max (cp (t @ s) ` readys (t @ s))"
+ using assms by (unfold runing_def, auto)
+ also have "\<dots> = preced th s"
+ by (metis th_cp_max th_cp_preced vat_t.max_cp_readys_threads)
+ finally show ?thesis .
+qed
+
+text {*
+
+ The next lemma shows how the counters for @{term "P"} and @{term
+ "V"} operations relate to the running threads in the states @{term
+ s} and @{term "t @ s"}: if a thread's @{term "P"}-count equals its
+ @{term "V"}-count (which means it no longer has any resource in its
+ possession), it cannot be a running thread.
+
+ The proof is by contraction with the assumption @{text "th' \<noteq> th"}.
+ The key is the use of @{thm count_eq_dependants} to derive the
+ emptiness of @{text th'}s @{term dependants}-set from the balance of
+ its @{term P} and @{term V} counts. From this, it can be shown
+ @{text th'}s @{term cp}-value equals to its own precedence.
+
+ On the other hand, since @{text th'} is running, by @{thm
+ runing_preced_inversion}, its @{term cp}-value equals to the
+ precedence of @{term th}.
+
+ Combining the above two results we have that @{text th'} and @{term
+ th} have the same precedence. By uniqueness of precedences, we have
+ @{text "th' = th"}, which is in contradiction with the assumption
+ @{text "th' \<noteq> th"}.
+
+*}
+
+lemma eq_pv_blocked: (* ddd *)
+ assumes neq_th': "th' \<noteq> th"
+ and eq_pv: "cntP (t @ s) th' = cntV (t @ s) th'"
+ shows "th' \<notin> runing (t @ s)"
+proof
+ assume otherwise: "th' \<in> runing (t @ s)"
+ show False
+ proof -
+ have th'_in: "th' \<in> threads (t @ s)"
+ using otherwise readys_threads runing_def by auto
+ have "th' = th"
+ proof(rule preced_unique)
+ -- {* The proof goes like this:
+ it is first shown that the @{term preced}-value of @{term th'}
+ equals to that of @{term th}, then by uniqueness
+ of @{term preced}-values (given by lemma @{thm preced_unique}),
+ @{term th'} equals to @{term th}: *}
+ show "preced th' (t @ s) = preced th (t @ s)" (is "?L = ?R")
+ proof -
+ -- {* Since the counts of @{term th'} are balanced, the subtree
+ of it contains only itself, so, its @{term cp}-value
+ equals its @{term preced}-value: *}
+ have "?L = cp (t @ s) th'"
+ by (unfold cp_eq_cpreced cpreced_def count_eq_dependants[OF eq_pv], simp)
+ -- {* Since @{term "th'"} is running, by @{thm runing_preced_inversion},
+ its @{term cp}-value equals @{term "preced th s"},
+ which equals to @{term "?R"} by simplification: *}
+ also have "... = ?R"
+ using runing_preced_inversion[OF otherwise] by simp
+ finally show ?thesis .
+ qed
+ qed (auto simp: th'_in th_kept)
+ with `th' \<noteq> th` show ?thesis by simp
+ qed
+qed
+
+text {*
+ The following lemma is the extrapolation of @{thm eq_pv_blocked}.
+ It says if a thread, different from @{term th},
+ does not hold any resource at the very beginning,
+ it will keep hand-emptied in the future @{term "t@s"}.
+*}
+lemma eq_pv_persist: (* ddd *)
+ assumes neq_th': "th' \<noteq> th"
+ and eq_pv: "cntP s th' = cntV s th'"
+ shows "cntP (t @ s) th' = cntV (t @ s) th'"
+proof(induction rule: ind)
+ -- {* The nontrivial case is for the @{term Cons}: *}
+ case (Cons e t)
+ -- {* All results derived so far hold for both @{term s} and @{term "t@s"}: *}
+ interpret vat_t: extend_highest_gen s th prio tm t using Cons by simp
+ interpret vat_e: extend_highest_gen s th prio tm "(e # t)" using Cons by simp
+ show ?case
+ proof -
+ -- {* It can be proved that @{term cntP}-value of @{term th'} does not change
+ by the happening of event @{term e}: *}
+ have "cntP ((e#t)@s) th' = cntP (t@s) th'"
+ proof(rule ccontr) -- {* Proof by contradiction. *}
+ -- {* Suppose @{term cntP}-value of @{term th'} is changed by @{term e}: *}
+ assume otherwise: "cntP ((e # t) @ s) th' \<noteq> cntP (t @ s) th'"
+ -- {* Then the actor of @{term e} must be @{term th'} and @{term e}
+ must be a @{term P}-event: *}
+ hence "isP e" "actor e = th'" by (auto simp:cntP_diff_inv)
+ with vat_t.actor_inv[OF Cons(2)]
+ -- {* According to @{thm actor_inv}, @{term th'} must be running at
+ the moment @{term "t@s"}: *}
+ have "th' \<in> runing (t@s)" by (cases e, auto)
+ -- {* However, an application of @{thm eq_pv_blocked} to induction hypothesis
+ shows @{term th'} can not be running at moment @{term "t@s"}: *}
+ moreover have "th' \<notin> runing (t@s)"
+ using vat_t.eq_pv_blocked[OF neq_th' Cons(5)] .
+ -- {* Contradiction is finally derived: *}
+ ultimately show False by simp
+ qed
+ -- {* It can also be proved that @{term cntV}-value of @{term th'} does not change
+ by the happening of event @{term e}: *}
+ -- {* The proof follows exactly the same pattern as the case for @{term cntP}-value: *}
+ moreover have "cntV ((e#t)@s) th' = cntV (t@s) th'"
+ proof(rule ccontr) -- {* Proof by contradiction. *}
+ assume otherwise: "cntV ((e # t) @ s) th' \<noteq> cntV (t @ s) th'"
+ hence "isV e" "actor e = th'" by (auto simp:cntV_diff_inv)
+ with vat_t.actor_inv[OF Cons(2)]
+ have "th' \<in> runing (t@s)" by (cases e, auto)
+ moreover have "th' \<notin> runing (t@s)"
+ using vat_t.eq_pv_blocked[OF neq_th' Cons(5)] .
+ ultimately show False by simp
+ qed
+ -- {* Finally, it can be shown that the @{term cntP} and @{term cntV}
+ value for @{term th'} are still in balance, so @{term th'}
+ is still hand-emptied after the execution of event @{term e}: *}
+ ultimately show ?thesis using Cons(5) by metis
+ qed
+qed (auto simp:eq_pv)
+
+text {*
+
+ By combining @{thm eq_pv_blocked} and @{thm eq_pv_persist}, it can
+ be derived easily that @{term th'} can not be running in the future:
+
+*}
+
+lemma eq_pv_blocked_persist:
+ assumes neq_th': "th' \<noteq> th"
+ and eq_pv: "cntP s th' = cntV s th'"
+ shows "th' \<notin> runing (t @ s)"
+ using assms
+ by (simp add: eq_pv_blocked eq_pv_persist)
+
+text {*
+
+ The following lemma shows the blocking thread @{term th'} must hold
+ some resource in the very beginning.
+
+*}
+
+lemma runing_cntP_cntV_inv: (* ddd *)
+ assumes is_runing: "th' \<in> runing (t @ s)"
+ and neq_th': "th' \<noteq> th"
+ shows "cntP s th' > cntV s th'"
+ using assms
+proof -
+ -- {* First, it can be shown that the number of @{term P} and
+ @{term V} operations can not be equal for thred @{term th'} *}
+ have "cntP s th' \<noteq> cntV s th'"
+ proof
+ -- {* The proof goes by contradiction, suppose otherwise: *}
+ assume otherwise: "cntP s th' = cntV s th'"
+ -- {* By applying @{thm eq_pv_blocked_persist} to this: *}
+ from eq_pv_blocked_persist[OF neq_th' otherwise]
+ -- {* we have that @{term th'} can not be running at moment @{term "t@s"}: *}
+ have "th' \<notin> runing (t@s)" .
+ -- {* This is obvious in contradiction with assumption @{thm is_runing} *}
+ thus False using is_runing by simp
+ qed
+ -- {* However, the number of @{term V} is always less or equal to @{term P}: *}
+ moreover have "cntV s th' \<le> cntP s th'" using vat_s.cnp_cnv_cncs by auto
+ -- {* Thesis is finally derived by combining the these two results: *}
+ ultimately show ?thesis by auto
+qed
+
+
+text {*
+
+ The following lemmas shows the blocking thread @{text th'} must be
+ live at the very beginning, i.e. the moment (or state) @{term s}.
+ The proof is a simple combination of the results above:
+
+*}
+
+lemma runing_threads_inv:
+ assumes runing': "th' \<in> runing (t@s)"
+ and neq_th': "th' \<noteq> th"
+ shows "th' \<in> threads s"
+proof(rule ccontr) -- {* Proof by contradiction: *}
+ assume otherwise: "th' \<notin> threads s"
+ have "th' \<notin> runing (t @ s)"
+ proof -
+ from vat_s.cnp_cnv_eq[OF otherwise]
+ have "cntP s th' = cntV s th'" .
+ from eq_pv_blocked_persist[OF neq_th' this]
+ show ?thesis .
+ qed
+ with runing' show False by simp
+qed
+
+text {*
+
+ The following lemma summarises the above lemmas to give an overall
+ characterisationof the blocking thread @{text "th'"}:
+
+*}
+
+lemma runing_inversion: (* ddd, one of the main lemmas to present *)
+ assumes runing': "th' \<in> runing (t@s)"
+ and neq_th: "th' \<noteq> th"
+ shows "th' \<in> threads s"
+ and "\<not>detached s th'"
+ and "cp (t@s) th' = preced th s"
+proof -
+ from runing_threads_inv[OF assms]
+ show "th' \<in> threads s" .
+next
+ from runing_cntP_cntV_inv[OF runing' neq_th]
+ show "\<not>detached s th'" using vat_s.detached_eq by simp
+next
+ from runing_preced_inversion[OF runing']
+ show "cp (t@s) th' = preced th s" .
+qed
+
+
+section {* The existence of `blocking thread` *}
+
+text {*
+
+ Suppose @{term th} is not running, it is first shown that there is a
+ path in RAG leading from node @{term th} to another thread @{text
+ "th'"} in the @{term readys}-set (So @{text "th'"} is an ancestor of
+ @{term th}}).
+
+ Now, since @{term readys}-set is non-empty, there must be one in it
+ which holds the highest @{term cp}-value, which, by definition, is
+ the @{term runing}-thread. However, we are going to show more: this
+ running thread is exactly @{term "th'"}.
+
+*}
+
+lemma th_blockedE: (* ddd, the other main lemma to be presented: *)
+ assumes "th \<notin> runing (t@s)"
+ obtains th' where "Th th' \<in> ancestors (RAG (t @ s)) (Th th)"
+ "th' \<in> runing (t@s)"
+proof -
+ -- {* According to @{thm vat_t.th_chain_to_ready}, either
+ @{term "th"} is in @{term "readys"} or there is path leading from it to
+ one thread in @{term "readys"}. *}
+ have "th \<in> readys (t @ s) \<or> (\<exists>th'. th' \<in> readys (t @ s) \<and> (Th th, Th th') \<in> (RAG (t @ s))\<^sup>+)"
+ using th_kept vat_t.th_chain_to_ready by auto
+ -- {* However, @{term th} can not be in @{term readys}, because otherwise, since
+ @{term th} holds the highest @{term cp}-value, it must be @{term "runing"}. *}
+ moreover have "th \<notin> readys (t@s)"
+ using assms runing_def th_cp_max vat_t.max_cp_readys_threads by auto
+ -- {* So, there must be a path from @{term th} to another thread @{text "th'"} in
+ term @{term readys}: *}
+ ultimately obtain th' where th'_in: "th' \<in> readys (t@s)"
+ and dp: "(Th th, Th th') \<in> (RAG (t @ s))\<^sup>+" by auto
+ -- {* We are going to show that this @{term th'} is running. *}
+ have "th' \<in> runing (t@s)"
+ proof -
+ -- {* We only need to show that this @{term th'} holds the highest @{term cp}-value: *}
+ have "cp (t@s) th' = Max (cp (t@s) ` readys (t@s))" (is "?L = ?R")
+ proof -
+ have "?L = Max ((the_preced (t @ s) \<circ> the_thread) ` subtree (tRAG (t @ s)) (Th th'))"
+ by (unfold cp_alt_def1, simp)
+ also have "... = (the_preced (t @ s) \<circ> the_thread) (Th th)"
+ proof(rule image_Max_subset)
+ show "finite (Th ` (threads (t@s)))" by (simp add: vat_t.finite_threads)
+ next
+ show "subtree (tRAG (t @ s)) (Th th') \<subseteq> Th ` threads (t @ s)"
+ by (metis Range.intros dp trancl_range vat_t.range_in vat_t.subtree_tRAG_thread)
+ next
+ show "Th th \<in> subtree (tRAG (t @ s)) (Th th')" using dp
+ by (unfold tRAG_subtree_eq, auto simp:subtree_def)
+ next
+ show "Max ((the_preced (t @ s) \<circ> the_thread) ` Th ` threads (t @ s)) =
+ (the_preced (t @ s) \<circ> the_thread) (Th th)" (is "Max ?L = _")
+ proof -
+ have "?L = the_preced (t @ s) ` threads (t @ s)"
+ by (unfold image_comp, rule image_cong, auto)
+ thus ?thesis using max_preced the_preced_def by auto
+ qed
+ qed
+ also have "... = ?R"
+ using th_cp_max th_cp_preced th_kept
+ the_preced_def vat_t.max_cp_readys_threads by auto
+ finally show ?thesis .
+ qed
+ -- {* Now, since @{term th'} holds the highest @{term cp}
+ and we have already show it is in @{term readys},
+ it is @{term runing} by definition. *}
+ with `th' \<in> readys (t@s)` show ?thesis by (simp add: runing_def)
+ qed
+ -- {* It is easy to show @{term th'} is an ancestor of @{term th}: *}
+ moreover have "Th th' \<in> ancestors (RAG (t @ s)) (Th th)"
+ using `(Th th, Th th') \<in> (RAG (t @ s))\<^sup>+` by (auto simp:ancestors_def)
+ ultimately show ?thesis using that by metis
+qed
+
+text {*
+
+ Now it is easy to see there is always a thread to run by case
+ analysis on whether thread @{term th} is running: if the answer is
+ yes, the the running thread is obviously @{term th} itself;
+ otherwise, the running thread is the @{text th'} given by lemma
+ @{thm th_blockedE}.
+
+*}
+
+lemma live: "runing (t@s) \<noteq> {}"
+proof(cases "th \<in> runing (t@s)")
+ case True thus ?thesis by auto
+next
+ case False
+ thus ?thesis using th_blockedE by auto
+qed
+
+
+end
+end
--- a/CpsG.thy Wed May 14 11:52:53 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1997 +0,0 @@
-theory CpsG
-imports PrioG
-begin
-
-lemma not_thread_holdents:
- fixes th s
- assumes vt: "vt s"
- and not_in: "th \<notin> threads s"
- shows "holdents s th = {}"
-proof -
- from vt not_in show ?thesis
- proof(induct arbitrary:th)
- case (vt_cons s e th)
- assume vt: "vt s"
- and ih: "\<And>th. th \<notin> threads s \<Longrightarrow> holdents s th = {}"
- and stp: "step s e"
- and not_in: "th \<notin> threads (e # s)"
- from stp show ?case
- proof(cases)
- case (thread_create thread prio)
- assume eq_e: "e = Create thread prio"
- and not_in': "thread \<notin> threads s"
- have "holdents (e # s) th = holdents s th"
- apply (unfold eq_e holdents_test)
- by (simp add:depend_create_unchanged)
- moreover have "th \<notin> threads s"
- proof -
- from not_in eq_e show ?thesis by simp
- qed
- moreover note ih ultimately show ?thesis by auto
- next
- case (thread_exit thread)
- assume eq_e: "e = Exit thread"
- and nh: "holdents s thread = {}"
- show ?thesis
- proof(cases "th = thread")
- case True
- with nh eq_e
- show ?thesis
- by (auto simp:holdents_test depend_exit_unchanged)
- next
- case False
- with not_in and eq_e
- have "th \<notin> threads s" by simp
- from ih[OF this] False eq_e show ?thesis
- by (auto simp:holdents_test depend_exit_unchanged)
- qed
- next
- case (thread_P thread cs)
- assume eq_e: "e = P thread cs"
- and is_runing: "thread \<in> runing s"
- from assms thread_exit ih stp not_in vt eq_e have vtp: "vt (P thread cs#s)" by auto
- have neq_th: "th \<noteq> thread"
- proof -
- from not_in eq_e have "th \<notin> threads s" by simp
- moreover from is_runing have "thread \<in> threads s"
- by (simp add:runing_def readys_def)
- ultimately show ?thesis by auto
- qed
- hence "holdents (e # s) th = holdents s th "
- apply (unfold cntCS_def holdents_test eq_e)
- by (unfold step_depend_p[OF vtp], auto)
- moreover have "holdents s th = {}"
- proof(rule ih)
- from not_in eq_e show "th \<notin> threads s" by simp
- qed
- ultimately show ?thesis by simp
- next
- case (thread_V thread cs)
- assume eq_e: "e = V thread cs"
- and is_runing: "thread \<in> runing s"
- and hold: "holding s thread cs"
- have neq_th: "th \<noteq> thread"
- proof -
- from not_in eq_e have "th \<notin> threads s" by simp
- moreover from is_runing have "thread \<in> threads s"
- by (simp add:runing_def readys_def)
- ultimately show ?thesis by auto
- qed
- from assms thread_V eq_e ih stp not_in vt have vtv: "vt (V thread cs#s)" by auto
- from hold obtain rest
- where eq_wq: "wq s cs = thread # rest"
- by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
- from not_in eq_e eq_wq
- have "\<not> next_th s thread cs th"
- apply (auto simp:next_th_def)
- proof -
- assume ne: "rest \<noteq> []"
- and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> threads s" (is "?t \<notin> threads s")
- have "?t \<in> set rest"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vtv], of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x assume "distinct x \<and> set x = set rest" with ne
- show "hd x \<in> set rest" by (cases x, auto)
- qed
- with eq_wq have "?t \<in> set (wq s cs)" by simp
- from wq_threads[OF step_back_vt[OF vtv], OF this] and ni
- show False by auto
- qed
- moreover note neq_th eq_wq
- ultimately have "holdents (e # s) th = holdents s th"
- by (unfold eq_e cntCS_def holdents_test step_depend_v[OF vtv], auto)
- moreover have "holdents s th = {}"
- proof(rule ih)
- from not_in eq_e show "th \<notin> threads s" by simp
- qed
- ultimately show ?thesis by simp
- next
- case (thread_set thread prio)
- print_facts
- assume eq_e: "e = Set thread prio"
- and is_runing: "thread \<in> runing s"
- from not_in and eq_e have "th \<notin> threads s" by auto
- from ih [OF this] and eq_e
- show ?thesis
- apply (unfold eq_e cntCS_def holdents_test)
- by (simp add:depend_set_unchanged)
- qed
- next
- case vt_nil
- show ?case
- by (auto simp:count_def holdents_test s_depend_def wq_def cs_holding_def)
- qed
-qed
-
-
-
-lemma next_th_neq:
- assumes vt: "vt s"
- and nt: "next_th s th cs th'"
- shows "th' \<noteq> th"
-proof -
- from nt show ?thesis
- apply (auto simp:next_th_def)
- proof -
- fix rest
- assume eq_wq: "wq s cs = hd (SOME q. distinct q \<and> set q = set rest) # rest"
- and ne: "rest \<noteq> []"
- have "hd (SOME q. distinct q \<and> set q = set rest) \<in> set rest"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x
- assume "distinct x \<and> set x = set rest"
- hence eq_set: "set x = set rest" by auto
- with ne have "x \<noteq> []" by auto
- hence "hd x \<in> set x" by auto
- with eq_set show "hd x \<in> set rest" by auto
- qed
- with wq_distinct[OF vt, of cs] eq_wq show False by auto
- qed
-qed
-
-lemma next_th_unique:
- assumes nt1: "next_th s th cs th1"
- and nt2: "next_th s th cs th2"
- shows "th1 = th2"
-proof -
- from assms show ?thesis
- by (unfold next_th_def, auto)
-qed
-
-lemma pp_sub: "(r^+)^+ \<subseteq> r^+"
- by auto
-
-lemma wf_depend:
- assumes vt: "vt s"
- shows "wf (depend s)"
-proof(rule finite_acyclic_wf)
- from finite_depend[OF vt] show "finite (depend s)" .
-next
- from acyclic_depend[OF vt] show "acyclic (depend s)" .
-qed
-
-lemma Max_Union:
- assumes fc: "finite C"
- and ne: "C \<noteq> {}"
- and fa: "\<And> A. A \<in> C \<Longrightarrow> finite A \<and> A \<noteq> {}"
- shows "Max (\<Union> C) = Max (Max ` C)"
-proof -
- from fc ne fa show ?thesis
- proof(induct)
- case (insert x F)
- assume ih: "\<lbrakk>F \<noteq> {}; \<And>A. A \<in> F \<Longrightarrow> finite A \<and> A \<noteq> {}\<rbrakk> \<Longrightarrow> Max (\<Union>F) = Max (Max ` F)"
- and h: "\<And> A. A \<in> insert x F \<Longrightarrow> finite A \<and> A \<noteq> {}"
- show ?case (is "?L = ?R")
- proof(cases "F = {}")
- case False
- from Union_insert have "?L = Max (x \<union> (\<Union> F))" by simp
- also have "\<dots> = max (Max x) (Max(\<Union> F))"
- proof(rule Max_Un)
- from h[of x] show "finite x" by auto
- next
- from h[of x] show "x \<noteq> {}" by auto
- next
- show "finite (\<Union>F)"
- proof(rule finite_Union)
- show "finite F" by fact
- next
- from h show "\<And>M. M \<in> F \<Longrightarrow> finite M" by auto
- qed
- next
- from False and h show "\<Union>F \<noteq> {}" by auto
- qed
- also have "\<dots> = ?R"
- proof -
- have "?R = Max (Max ` ({x} \<union> F))" by simp
- also have "\<dots> = Max ({Max x} \<union> (Max ` F))" by simp
- also have "\<dots> = max (Max x) (Max (\<Union>F))"
- proof -
- have "Max ({Max x} \<union> Max ` F) = max (Max {Max x}) (Max (Max ` F))"
- proof(rule Max_Un)
- show "finite {Max x}" by simp
- next
- show "{Max x} \<noteq> {}" by simp
- next
- from insert show "finite (Max ` F)" by auto
- next
- from False show "Max ` F \<noteq> {}" by auto
- qed
- moreover have "Max {Max x} = Max x" by simp
- moreover have "Max (\<Union>F) = Max (Max ` F)"
- proof(rule ih)
- show "F \<noteq> {}" by fact
- next
- from h show "\<And>A. A \<in> F \<Longrightarrow> finite A \<and> A \<noteq> {}"
- by auto
- qed
- ultimately show ?thesis by auto
- qed
- finally show ?thesis by simp
- qed
- finally show ?thesis by simp
- next
- case True
- thus ?thesis by auto
- qed
- next
- case empty
- assume "{} \<noteq> {}" show ?case by auto
- qed
-qed
-
-definition child :: "state \<Rightarrow> (node \<times> node) set"
- where "child s \<equiv>
- {(Th th', Th th) | th th'. \<exists> cs. (Th th', Cs cs) \<in> depend s \<and> (Cs cs, Th th) \<in> depend s}"
-
-definition children :: "state \<Rightarrow> thread \<Rightarrow> thread set"
- where "children s th \<equiv> {th'. (Th th', Th th) \<in> child s}"
-
-lemma children_def2:
- "children s th \<equiv> {th'. \<exists> cs. (Th th', Cs cs) \<in> depend s \<and> (Cs cs, Th th) \<in> depend s}"
-unfolding child_def children_def by simp
-
-lemma children_dependents: "children s th \<subseteq> dependents (wq s) th"
- by (unfold children_def child_def cs_dependents_def, auto simp:eq_depend)
-
-lemma child_unique:
- assumes vt: "vt s"
- and ch1: "(Th th, Th th1) \<in> child s"
- and ch2: "(Th th, Th th2) \<in> child s"
- shows "th1 = th2"
-proof -
- from ch1 ch2 show ?thesis
- proof(unfold child_def, clarsimp)
- fix cs csa
- assume h1: "(Th th, Cs cs) \<in> depend s"
- and h2: "(Cs cs, Th th1) \<in> depend s"
- and h3: "(Th th, Cs csa) \<in> depend s"
- and h4: "(Cs csa, Th th2) \<in> depend s"
- from unique_depend[OF vt h1 h3] have "cs = csa" by simp
- with h4 have "(Cs cs, Th th2) \<in> depend s" by simp
- from unique_depend[OF vt h2 this]
- show "th1 = th2" by simp
- qed
-qed
-
-
-lemma cp_eq_cpreced_f: "cp s = cpreced (wq s) s"
-proof -
- from fun_eq_iff
- have h:"\<And>f g. (\<forall> x. f x = g x) \<Longrightarrow> f = g" by auto
- show ?thesis
- proof(rule h)
- from cp_eq_cpreced show "\<forall>x. cp s x = cpreced (wq s) s x" by auto
- qed
-qed
-
-lemma depend_children:
- assumes h: "(Th th1, Th th2) \<in> (depend s)^+"
- shows "th1 \<in> children s th2 \<or> (\<exists> th3. th3 \<in> children s th2 \<and> (Th th1, Th th3) \<in> (depend s)^+)"
-proof -
- from h show ?thesis
- proof(induct rule: tranclE)
- fix c th2
- assume h1: "(Th th1, c) \<in> (depend s)\<^sup>+"
- and h2: "(c, Th th2) \<in> depend s"
- from h2 obtain cs where eq_c: "c = Cs cs"
- by (case_tac c, auto simp:s_depend_def)
- show "th1 \<in> children s th2 \<or> (\<exists>th3. th3 \<in> children s th2 \<and> (Th th1, Th th3) \<in> (depend s)\<^sup>+)"
- proof(rule tranclE[OF h1])
- fix ca
- assume h3: "(Th th1, ca) \<in> (depend s)\<^sup>+"
- and h4: "(ca, c) \<in> depend s"
- show "th1 \<in> children s th2 \<or> (\<exists>th3. th3 \<in> children s th2 \<and> (Th th1, Th th3) \<in> (depend s)\<^sup>+)"
- proof -
- from eq_c and h4 obtain th3 where eq_ca: "ca = Th th3"
- by (case_tac ca, auto simp:s_depend_def)
- from eq_ca h4 h2 eq_c
- have "th3 \<in> children s th2" by (auto simp:children_def child_def)
- moreover from h3 eq_ca have "(Th th1, Th th3) \<in> (depend s)\<^sup>+" by simp
- ultimately show ?thesis by auto
- qed
- next
- assume "(Th th1, c) \<in> depend s"
- with h2 eq_c
- have "th1 \<in> children s th2"
- by (auto simp:children_def child_def)
- thus ?thesis by auto
- qed
- next
- assume "(Th th1, Th th2) \<in> depend s"
- thus ?thesis
- by (auto simp:s_depend_def)
- qed
-qed
-
-lemma sub_child: "child s \<subseteq> (depend s)^+"
- by (unfold child_def, auto)
-
-lemma wf_child:
- assumes vt: "vt s"
- shows "wf (child s)"
-proof(rule wf_subset)
- from wf_trancl[OF wf_depend[OF vt]]
- show "wf ((depend s)\<^sup>+)" .
-next
- from sub_child show "child s \<subseteq> (depend s)\<^sup>+" .
-qed
-
-lemma depend_child_pre:
- assumes vt: "vt s"
- shows
- "(Th th, n) \<in> (depend s)^+ \<longrightarrow> (\<forall> th'. n = (Th th') \<longrightarrow> (Th th, Th th') \<in> (child s)^+)" (is "?P n")
-proof -
- from wf_trancl[OF wf_depend[OF vt]]
- have wf: "wf ((depend s)^+)" .
- show ?thesis
- proof(rule wf_induct[OF wf, of ?P], clarsimp)
- fix th'
- assume ih[rule_format]: "\<forall>y. (y, Th th') \<in> (depend s)\<^sup>+ \<longrightarrow>
- (Th th, y) \<in> (depend s)\<^sup>+ \<longrightarrow> (\<forall>th'. y = Th th' \<longrightarrow> (Th th, Th th') \<in> (child s)\<^sup>+)"
- and h: "(Th th, Th th') \<in> (depend s)\<^sup>+"
- show "(Th th, Th th') \<in> (child s)\<^sup>+"
- proof -
- from depend_children[OF h]
- have "th \<in> children s th' \<or> (\<exists>th3. th3 \<in> children s th' \<and> (Th th, Th th3) \<in> (depend s)\<^sup>+)" .
- thus ?thesis
- proof
- assume "th \<in> children s th'"
- thus "(Th th, Th th') \<in> (child s)\<^sup>+" by (auto simp:children_def)
- next
- assume "\<exists>th3. th3 \<in> children s th' \<and> (Th th, Th th3) \<in> (depend s)\<^sup>+"
- then obtain th3 where th3_in: "th3 \<in> children s th'"
- and th_dp: "(Th th, Th th3) \<in> (depend s)\<^sup>+" by auto
- from th3_in have "(Th th3, Th th') \<in> (depend s)^+" by (auto simp:children_def child_def)
- from ih[OF this th_dp, of th3] have "(Th th, Th th3) \<in> (child s)\<^sup>+" by simp
- with th3_in show "(Th th, Th th') \<in> (child s)\<^sup>+" by (auto simp:children_def)
- qed
- qed
- qed
-qed
-
-lemma depend_child: "\<lbrakk>vt s; (Th th, Th th') \<in> (depend s)^+\<rbrakk> \<Longrightarrow> (Th th, Th th') \<in> (child s)^+"
- by (insert depend_child_pre, auto)
-
-lemma child_depend_p:
- assumes "(n1, n2) \<in> (child s)^+"
- shows "(n1, n2) \<in> (depend s)^+"
-proof -
- from assms show ?thesis
- proof(induct)
- case (base y)
- with sub_child show ?case by auto
- next
- case (step y z)
- assume "(y, z) \<in> child s"
- with sub_child have "(y, z) \<in> (depend s)^+" by auto
- moreover have "(n1, y) \<in> (depend s)^+" by fact
- ultimately show ?case by auto
- qed
-qed
-
-lemma child_depend_eq:
- assumes vt: "vt s"
- shows
- "((Th th1, Th th2) \<in> (child s)^+) =
- ((Th th1, Th th2) \<in> (depend s)^+)"
- by (auto intro: depend_child[OF vt] child_depend_p)
-
-lemma children_no_dep:
- fixes s th th1 th2 th3
- assumes vt: "vt s"
- and ch1: "(Th th1, Th th) \<in> child s"
- and ch2: "(Th th2, Th th) \<in> child s"
- and ch3: "(Th th1, Th th2) \<in> (depend s)^+"
- shows "False"
-proof -
- from depend_child[OF vt ch3]
- have "(Th th1, Th th2) \<in> (child s)\<^sup>+" .
- thus ?thesis
- proof(rule converse_tranclE)
- thm tranclD
- assume "(Th th1, Th th2) \<in> child s"
- from child_unique[OF vt ch1 this] have "th = th2" by simp
- with ch2 have "(Th th2, Th th2) \<in> child s" by simp
- with wf_child[OF vt] show ?thesis by auto
- next
- fix c
- assume h1: "(Th th1, c) \<in> child s"
- and h2: "(c, Th th2) \<in> (child s)\<^sup>+"
- from h1 obtain th3 where eq_c: "c = Th th3" by (unfold child_def, auto)
- with h1 have "(Th th1, Th th3) \<in> child s" by simp
- from child_unique[OF vt ch1 this] have eq_th3: "th3 = th" by simp
- with eq_c and h2 have "(Th th, Th th2) \<in> (child s)\<^sup>+" by simp
- with ch2 have "(Th th, Th th) \<in> (child s)\<^sup>+" by auto
- moreover have "wf ((child s)\<^sup>+)"
- proof(rule wf_trancl)
- from wf_child[OF vt] show "wf (child s)" .
- qed
- ultimately show False by auto
- qed
-qed
-
-lemma unique_depend_p:
- assumes vt: "vt s"
- and dp1: "(n, n1) \<in> (depend s)^+"
- and dp2: "(n, n2) \<in> (depend s)^+"
- and neq: "n1 \<noteq> n2"
- shows "(n1, n2) \<in> (depend s)^+ \<or> (n2, n1) \<in> (depend s)^+"
-proof(rule unique_chain [OF _ dp1 dp2 neq])
- from unique_depend[OF vt]
- show "\<And>a b c. \<lbrakk>(a, b) \<in> depend s; (a, c) \<in> depend s\<rbrakk> \<Longrightarrow> b = c" by auto
-qed
-
-lemma dependents_child_unique:
- fixes s th th1 th2 th3
- assumes vt: "vt s"
- and ch1: "(Th th1, Th th) \<in> child s"
- and ch2: "(Th th2, Th th) \<in> child s"
- and dp1: "th3 \<in> dependents s th1"
- and dp2: "th3 \<in> dependents s th2"
-shows "th1 = th2"
-proof -
- { assume neq: "th1 \<noteq> th2"
- from dp1 have dp1: "(Th th3, Th th1) \<in> (depend s)^+"
- by (simp add:s_dependents_def eq_depend)
- from dp2 have dp2: "(Th th3, Th th2) \<in> (depend s)^+"
- by (simp add:s_dependents_def eq_depend)
- from unique_depend_p[OF vt dp1 dp2] and neq
- have "(Th th1, Th th2) \<in> (depend s)\<^sup>+ \<or> (Th th2, Th th1) \<in> (depend s)\<^sup>+" by auto
- hence False
- proof
- assume "(Th th1, Th th2) \<in> (depend s)\<^sup>+ "
- from children_no_dep[OF vt ch1 ch2 this] show ?thesis .
- next
- assume " (Th th2, Th th1) \<in> (depend s)\<^sup>+"
- from children_no_dep[OF vt ch2 ch1 this] show ?thesis .
- qed
- } thus ?thesis by auto
-qed
-
-lemma cp_rec:
- fixes s th
- assumes vt: "vt s"
- shows "cp s th = Max ({preced th s} \<union> (cp s ` children s th))"
-proof(unfold cp_eq_cpreced_f cpreced_def)
- let ?f = "(\<lambda>th. preced th s)"
- show "Max ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th)) =
- Max ({preced th s} \<union> (\<lambda>th. Max ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th))) ` children s th)"
- proof(cases " children s th = {}")
- case False
- have "(\<lambda>th. Max ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th))) ` children s th =
- {Max ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) | th' . th' \<in> children s th}"
- (is "?L = ?R")
- by auto
- also have "\<dots> =
- Max ` {((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) | th' . th' \<in> children s th}"
- (is "_ = Max ` ?C")
- by auto
- finally have "Max ?L = Max (Max ` ?C)" by auto
- also have "\<dots> = Max (\<Union> ?C)"
- proof(rule Max_Union[symmetric])
- from children_dependents[of s th] finite_threads[OF vt] and dependents_threads[OF vt, of th]
- show "finite {(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th}"
- by (auto simp:finite_subset)
- next
- from False
- show "{(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th} \<noteq> {}"
- by simp
- next
- show "\<And>A. A \<in> {(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th} \<Longrightarrow>
- finite A \<and> A \<noteq> {}"
- apply (auto simp:finite_subset)
- proof -
- fix th'
- from finite_threads[OF vt] and dependents_threads[OF vt, of th']
- show "finite ((\<lambda>th. preced th s) ` dependents (wq s) th')" by (auto simp:finite_subset)
- qed
- qed
- also have "\<dots> = Max ((\<lambda>th. preced th s) ` dependents (wq s) th)"
- (is "Max ?A = Max ?B")
- proof -
- have "?A = ?B"
- proof
- show "\<Union>{(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th}
- \<subseteq> (\<lambda>th. preced th s) ` dependents (wq s) th"
- proof
- fix x
- assume "x \<in> \<Union>{(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th}"
- then obtain th' where
- th'_in: "th' \<in> children s th"
- and x_in: "x \<in> ?f ` ({th'} \<union> dependents (wq s) th')" by auto
- hence "x = ?f th' \<or> x \<in> (?f ` dependents (wq s) th')" by auto
- thus "x \<in> ?f ` dependents (wq s) th"
- proof
- assume "x = preced th' s"
- with th'_in and children_dependents
- show "x \<in> (\<lambda>th. preced th s) ` dependents (wq s) th" by auto
- next
- assume "x \<in> (\<lambda>th. preced th s) ` dependents (wq s) th'"
- moreover note th'_in
- ultimately show " x \<in> (\<lambda>th. preced th s) ` dependents (wq s) th"
- by (unfold cs_dependents_def children_def child_def, auto simp:eq_depend)
- qed
- qed
- next
- show "?f ` dependents (wq s) th
- \<subseteq> \<Union>{?f ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th}"
- proof
- fix x
- assume x_in: "x \<in> (\<lambda>th. preced th s) ` dependents (wq s) th"
- then obtain th' where
- eq_x: "x = ?f th'" and dp: "(Th th', Th th) \<in> (depend s)^+"
- by (auto simp:cs_dependents_def eq_depend)
- from depend_children[OF dp]
- have "th' \<in> children s th \<or> (\<exists>th3. th3 \<in> children s th \<and> (Th th', Th th3) \<in> (depend s)\<^sup>+)" .
- thus "x \<in> \<Union>{(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th}"
- proof
- assume "th' \<in> children s th"
- with eq_x
- show "x \<in> \<Union>{(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th}"
- by auto
- next
- assume "\<exists>th3. th3 \<in> children s th \<and> (Th th', Th th3) \<in> (depend s)\<^sup>+"
- then obtain th3 where th3_in: "th3 \<in> children s th"
- and dp3: "(Th th', Th th3) \<in> (depend s)\<^sup>+" by auto
- show "x \<in> \<Union>{(\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th') |th'. th' \<in> children s th}"
- proof -
- from dp3
- have "th' \<in> dependents (wq s) th3"
- by (auto simp:cs_dependents_def eq_depend)
- with eq_x th3_in show ?thesis by auto
- qed
- qed
- qed
- qed
- thus ?thesis by simp
- qed
- finally have "Max ((\<lambda>th. preced th s) ` dependents (wq s) th) = Max (?L)"
- (is "?X = ?Y") by auto
- moreover have "Max ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th)) =
- max (?f th) ?X"
- proof -
- have "Max ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th)) =
- Max ({?f th} \<union> ?f ` (dependents (wq s) th))" by simp
- also have "\<dots> = max (Max {?f th}) (Max (?f ` (dependents (wq s) th)))"
- proof(rule Max_Un, auto)
- from finite_threads[OF vt] and dependents_threads[OF vt, of th]
- show "finite ((\<lambda>th. preced th s) ` dependents (wq s) th)" by (auto simp:finite_subset)
- next
- assume "dependents (wq s) th = {}"
- with False and children_dependents show False by auto
- qed
- also have "\<dots> = max (?f th) ?X" by simp
- finally show ?thesis .
- qed
- moreover have "Max ({preced th s} \<union>
- (\<lambda>th. Max ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th))) ` children s th) =
- max (?f th) ?Y"
- proof -
- have "Max ({preced th s} \<union>
- (\<lambda>th. Max ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th))) ` children s th) =
- max (Max {preced th s}) ?Y"
- proof(rule Max_Un, auto)
- from finite_threads[OF vt] dependents_threads[OF vt, of th] children_dependents [of s th]
- show "finite ((\<lambda>th. Max (insert (preced th s) ((\<lambda>th. preced th s) ` dependents (wq s) th))) `
- children s th)"
- by (auto simp:finite_subset)
- next
- assume "children s th = {}"
- with False show False by auto
- qed
- thus ?thesis by simp
- qed
- ultimately show ?thesis by auto
- next
- case True
- moreover have "dependents (wq s) th = {}"
- proof -
- { fix th'
- assume "th' \<in> dependents (wq s) th"
- hence " (Th th', Th th) \<in> (depend s)\<^sup>+" by (simp add:cs_dependents_def eq_depend)
- from depend_children[OF this] and True
- have "False" by auto
- } thus ?thesis by auto
- qed
- ultimately show ?thesis by auto
- qed
-qed
-
-definition cps:: "state \<Rightarrow> (thread \<times> precedence) set"
-where "cps s = {(th, cp s th) | th . th \<in> threads s}"
-
-locale step_set_cps =
- fixes s' th prio s
- defines s_def : "s \<equiv> (Set th prio#s')"
- assumes vt_s: "vt s"
-
-context step_set_cps
-begin
-
-lemma eq_preced:
- fixes th'
- assumes "th' \<noteq> th"
- shows "preced th' s = preced th' s'"
-proof -
- from assms show ?thesis
- by (unfold s_def, auto simp:preced_def)
-qed
-
-lemma eq_dep: "depend s = depend s'"
- by (unfold s_def depend_set_unchanged, auto)
-
-lemma eq_cp_pre:
- fixes th'
- assumes neq_th: "th' \<noteq> th"
- and nd: "th \<notin> dependents s th'"
- shows "cp s th' = cp s' th'"
- apply (unfold cp_eq_cpreced cpreced_def)
-proof -
- have eq_dp: "\<And> th. dependents (wq s) th = dependents (wq s') th"
- by (unfold cs_dependents_def, auto simp:eq_dep eq_depend)
- moreover {
- fix th1
- assume "th1 \<in> {th'} \<union> dependents (wq s') th'"
- hence "th1 = th' \<or> th1 \<in> dependents (wq s') th'" by auto
- hence "preced th1 s = preced th1 s'"
- proof
- assume "th1 = th'"
- with eq_preced[OF neq_th]
- show "preced th1 s = preced th1 s'" by simp
- next
- assume "th1 \<in> dependents (wq s') th'"
- with nd and eq_dp have "th1 \<noteq> th"
- by (auto simp:eq_depend cs_dependents_def s_dependents_def eq_dep)
- from eq_preced[OF this] show "preced th1 s = preced th1 s'" by simp
- qed
- } ultimately have "((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))"
- by (auto simp:image_def)
- thus "Max ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- Max ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))" by simp
-qed
-
-lemma no_dependents:
- assumes "th' \<noteq> th"
- shows "th \<notin> dependents s th'"
-proof
- assume h: "th \<in> dependents s th'"
- from step_back_step [OF vt_s[unfolded s_def]]
- have "step s' (Set th prio)" .
- hence "th \<in> runing s'" by (cases, simp)
- hence rd_th: "th \<in> readys s'"
- by (simp add:readys_def runing_def)
- from h have "(Th th, Th th') \<in> (depend s')\<^sup>+"
- by (unfold s_dependents_def, unfold eq_depend, unfold eq_dep, auto)
- from tranclD[OF this]
- obtain z where "(Th th, z) \<in> depend s'" by auto
- with rd_th show "False"
- apply (case_tac z, auto simp:readys_def s_waiting_def s_depend_def s_waiting_def cs_waiting_def)
- by (fold wq_def, blast)
-qed
-
-(* Result improved *)
-lemma eq_cp:
- fixes th'
- assumes neq_th: "th' \<noteq> th"
- shows "cp s th' = cp s' th'"
-proof(rule eq_cp_pre [OF neq_th])
- from no_dependents[OF neq_th]
- show "th \<notin> dependents s th'" .
-qed
-
-lemma eq_up:
- fixes th' th''
- assumes dp1: "th \<in> dependents s th'"
- and dp2: "th' \<in> dependents s th''"
- and eq_cps: "cp s th' = cp s' th'"
- shows "cp s th'' = cp s' th''"
-proof -
- from dp2
- have "(Th th', Th th'') \<in> (depend (wq s))\<^sup>+" by (simp add:s_dependents_def)
- from depend_child[OF vt_s this[unfolded eq_depend]]
- have ch_th': "(Th th', Th th'') \<in> (child s)\<^sup>+" .
- moreover { fix n th''
- have "\<lbrakk>(Th th', n) \<in> (child s)^+\<rbrakk> \<Longrightarrow>
- (\<forall> th'' . n = Th th'' \<longrightarrow> cp s th'' = cp s' th'')"
- proof(erule trancl_induct, auto)
- fix y th''
- assume y_ch: "(y, Th th'') \<in> child s"
- and ih: "\<forall>th''. y = Th th'' \<longrightarrow> cp s th'' = cp s' th''"
- and ch': "(Th th', y) \<in> (child s)\<^sup>+"
- from y_ch obtain thy where eq_y: "y = Th thy" by (auto simp:child_def)
- with ih have eq_cpy:"cp s thy = cp s' thy" by blast
- from dp1 have "(Th th, Th th') \<in> (depend s)^+" by (auto simp:s_dependents_def eq_depend)
- moreover from child_depend_p[OF ch'] and eq_y
- have "(Th th', Th thy) \<in> (depend s)^+" by simp
- ultimately have dp_thy: "(Th th, Th thy) \<in> (depend s)^+" by auto
- show "cp s th'' = cp s' th''"
- apply (subst cp_rec[OF vt_s])
- proof -
- have "preced th'' s = preced th'' s'"
- proof(rule eq_preced)
- show "th'' \<noteq> th"
- proof
- assume "th'' = th"
- with dp_thy y_ch[unfolded eq_y]
- have "(Th th, Th th) \<in> (depend s)^+"
- by (auto simp:child_def)
- with wf_trancl[OF wf_depend[OF vt_s]]
- show False by auto
- qed
- qed
- moreover {
- fix th1
- assume th1_in: "th1 \<in> children s th''"
- have "cp s th1 = cp s' th1"
- proof(cases "th1 = thy")
- case True
- with eq_cpy show ?thesis by simp
- next
- case False
- have neq_th1: "th1 \<noteq> th"
- proof
- assume eq_th1: "th1 = th"
- with dp_thy have "(Th th1, Th thy) \<in> (depend s)^+" by simp
- from children_no_dep[OF vt_s _ _ this] and
- th1_in y_ch eq_y show False by (auto simp:children_def)
- qed
- have "th \<notin> dependents s th1"
- proof
- assume h:"th \<in> dependents s th1"
- from eq_y dp_thy have "th \<in> dependents s thy" by (auto simp:s_dependents_def eq_depend)
- from dependents_child_unique[OF vt_s _ _ h this]
- th1_in y_ch eq_y have "th1 = thy" by (auto simp:children_def child_def)
- with False show False by auto
- qed
- from eq_cp_pre[OF neq_th1 this]
- show ?thesis .
- qed
- }
- ultimately have "{preced th'' s} \<union> (cp s ` children s th'') =
- {preced th'' s'} \<union> (cp s' ` children s th'')" by (auto simp:image_def)
- moreover have "children s th'' = children s' th''"
- by (unfold children_def child_def s_def depend_set_unchanged, simp)
- ultimately show "Max ({preced th'' s} \<union> cp s ` children s th'') = cp s' th''"
- by (simp add:cp_rec[OF step_back_vt[OF vt_s[unfolded s_def]]])
- qed
- next
- fix th''
- assume dp': "(Th th', Th th'') \<in> child s"
- show "cp s th'' = cp s' th''"
- apply (subst cp_rec[OF vt_s])
- proof -
- have "preced th'' s = preced th'' s'"
- proof(rule eq_preced)
- show "th'' \<noteq> th"
- proof
- assume "th'' = th"
- with dp1 dp'
- have "(Th th, Th th) \<in> (depend s)^+"
- by (auto simp:child_def s_dependents_def eq_depend)
- with wf_trancl[OF wf_depend[OF vt_s]]
- show False by auto
- qed
- qed
- moreover {
- fix th1
- assume th1_in: "th1 \<in> children s th''"
- have "cp s th1 = cp s' th1"
- proof(cases "th1 = th'")
- case True
- with eq_cps show ?thesis by simp
- next
- case False
- have neq_th1: "th1 \<noteq> th"
- proof
- assume eq_th1: "th1 = th"
- with dp1 have "(Th th1, Th th') \<in> (depend s)^+"
- by (auto simp:s_dependents_def eq_depend)
- from children_no_dep[OF vt_s _ _ this]
- th1_in dp'
- show False by (auto simp:children_def)
- qed
- thus ?thesis
- proof(rule eq_cp_pre)
- show "th \<notin> dependents s th1"
- proof
- assume "th \<in> dependents s th1"
- from dependents_child_unique[OF vt_s _ _ this dp1]
- th1_in dp' have "th1 = th'"
- by (auto simp:children_def)
- with False show False by auto
- qed
- qed
- qed
- }
- ultimately have "{preced th'' s} \<union> (cp s ` children s th'') =
- {preced th'' s'} \<union> (cp s' ` children s th'')" by (auto simp:image_def)
- moreover have "children s th'' = children s' th''"
- by (unfold children_def child_def s_def depend_set_unchanged, simp)
- ultimately show "Max ({preced th'' s} \<union> cp s ` children s th'') = cp s' th''"
- by (simp add:cp_rec[OF step_back_vt[OF vt_s[unfolded s_def]]])
- qed
- qed
- }
- ultimately show ?thesis by auto
-qed
-
-lemma eq_up_self:
- fixes th' th''
- assumes dp: "th \<in> dependents s th''"
- and eq_cps: "cp s th = cp s' th"
- shows "cp s th'' = cp s' th''"
-proof -
- from dp
- have "(Th th, Th th'') \<in> (depend (wq s))\<^sup>+" by (simp add:s_dependents_def)
- from depend_child[OF vt_s this[unfolded eq_depend]]
- have ch_th': "(Th th, Th th'') \<in> (child s)\<^sup>+" .
- moreover { fix n th''
- have "\<lbrakk>(Th th, n) \<in> (child s)^+\<rbrakk> \<Longrightarrow>
- (\<forall> th'' . n = Th th'' \<longrightarrow> cp s th'' = cp s' th'')"
- proof(erule trancl_induct, auto)
- fix y th''
- assume y_ch: "(y, Th th'') \<in> child s"
- and ih: "\<forall>th''. y = Th th'' \<longrightarrow> cp s th'' = cp s' th''"
- and ch': "(Th th, y) \<in> (child s)\<^sup>+"
- from y_ch obtain thy where eq_y: "y = Th thy" by (auto simp:child_def)
- with ih have eq_cpy:"cp s thy = cp s' thy" by blast
- from child_depend_p[OF ch'] and eq_y
- have dp_thy: "(Th th, Th thy) \<in> (depend s)^+" by simp
- show "cp s th'' = cp s' th''"
- apply (subst cp_rec[OF vt_s])
- proof -
- have "preced th'' s = preced th'' s'"
- proof(rule eq_preced)
- show "th'' \<noteq> th"
- proof
- assume "th'' = th"
- with dp_thy y_ch[unfolded eq_y]
- have "(Th th, Th th) \<in> (depend s)^+"
- by (auto simp:child_def)
- with wf_trancl[OF wf_depend[OF vt_s]]
- show False by auto
- qed
- qed
- moreover {
- fix th1
- assume th1_in: "th1 \<in> children s th''"
- have "cp s th1 = cp s' th1"
- proof(cases "th1 = thy")
- case True
- with eq_cpy show ?thesis by simp
- next
- case False
- have neq_th1: "th1 \<noteq> th"
- proof
- assume eq_th1: "th1 = th"
- with dp_thy have "(Th th1, Th thy) \<in> (depend s)^+" by simp
- from children_no_dep[OF vt_s _ _ this] and
- th1_in y_ch eq_y show False by (auto simp:children_def)
- qed
- have "th \<notin> dependents s th1"
- proof
- assume h:"th \<in> dependents s th1"
- from eq_y dp_thy have "th \<in> dependents s thy" by (auto simp:s_dependents_def eq_depend)
- from dependents_child_unique[OF vt_s _ _ h this]
- th1_in y_ch eq_y have "th1 = thy" by (auto simp:children_def child_def)
- with False show False by auto
- qed
- from eq_cp_pre[OF neq_th1 this]
- show ?thesis .
- qed
- }
- ultimately have "{preced th'' s} \<union> (cp s ` children s th'') =
- {preced th'' s'} \<union> (cp s' ` children s th'')" by (auto simp:image_def)
- moreover have "children s th'' = children s' th''"
- by (unfold children_def child_def s_def depend_set_unchanged, simp)
- ultimately show "Max ({preced th'' s} \<union> cp s ` children s th'') = cp s' th''"
- by (simp add:cp_rec[OF step_back_vt[OF vt_s[unfolded s_def]]])
- qed
- next
- fix th''
- assume dp': "(Th th, Th th'') \<in> child s"
- show "cp s th'' = cp s' th''"
- apply (subst cp_rec[OF vt_s])
- proof -
- have "preced th'' s = preced th'' s'"
- proof(rule eq_preced)
- show "th'' \<noteq> th"
- proof
- assume "th'' = th"
- with dp dp'
- have "(Th th, Th th) \<in> (depend s)^+"
- by (auto simp:child_def s_dependents_def eq_depend)
- with wf_trancl[OF wf_depend[OF vt_s]]
- show False by auto
- qed
- qed
- moreover {
- fix th1
- assume th1_in: "th1 \<in> children s th''"
- have "cp s th1 = cp s' th1"
- proof(cases "th1 = th")
- case True
- with eq_cps show ?thesis by simp
- next
- case False
- assume neq_th1: "th1 \<noteq> th"
- thus ?thesis
- proof(rule eq_cp_pre)
- show "th \<notin> dependents s th1"
- proof
- assume "th \<in> dependents s th1"
- hence "(Th th, Th th1) \<in> (depend s)^+" by (auto simp:s_dependents_def eq_depend)
- from children_no_dep[OF vt_s _ _ this]
- and th1_in dp' show False
- by (auto simp:children_def)
- qed
- qed
- qed
- }
- ultimately have "{preced th'' s} \<union> (cp s ` children s th'') =
- {preced th'' s'} \<union> (cp s' ` children s th'')" by (auto simp:image_def)
- moreover have "children s th'' = children s' th''"
- by (unfold children_def child_def s_def depend_set_unchanged, simp)
- ultimately show "Max ({preced th'' s} \<union> cp s ` children s th'') = cp s' th''"
- by (simp add:cp_rec[OF step_back_vt[OF vt_s[unfolded s_def]]])
- qed
- qed
- }
- ultimately show ?thesis by auto
-qed
-end
-
-lemma next_waiting:
- assumes vt: "vt s"
- and nxt: "next_th s th cs th'"
- shows "waiting s th' cs"
-proof -
- from assms show ?thesis
- apply (auto simp:next_th_def s_waiting_def[folded wq_def])
- proof -
- fix rest
- assume ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
- and eq_wq: "wq s cs = th # rest"
- and ne: "rest \<noteq> []"
- have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
- qed
- with ni
- have "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set (SOME q. distinct q \<and> set q = set rest)"
- by simp
- moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- from ne show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> x \<noteq> []" by auto
- qed
- ultimately show "hd (SOME q. distinct q \<and> set q = set rest) = th" by auto
- next
- fix rest
- assume eq_wq: "wq s cs = hd (SOME q. distinct q \<and> set q = set rest) # rest"
- and ne: "rest \<noteq> []"
- have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- from ne show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> x \<noteq> []" by auto
- qed
- hence "hd (SOME q. distinct q \<and> set q = set rest) \<in> set (SOME q. distinct q \<and> set q = set rest)"
- by auto
- moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
- qed
- ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<in> set rest" by simp
- with eq_wq and wq_distinct[OF vt, of cs]
- show False by auto
- qed
-qed
-
-
-
-
-locale step_v_cps =
- fixes s' th cs s
- defines s_def : "s \<equiv> (V th cs#s')"
- assumes vt_s: "vt s"
-
-locale step_v_cps_nt = step_v_cps +
- fixes th'
- assumes nt: "next_th s' th cs th'"
-
-context step_v_cps_nt
-begin
-
-lemma depend_s:
- "depend s = (depend s' - {(Cs cs, Th th), (Th th', Cs cs)}) \<union>
- {(Cs cs, Th th')}"
-proof -
- from step_depend_v[OF vt_s[unfolded s_def], folded s_def]
- and nt show ?thesis by (auto intro:next_th_unique)
-qed
-
-lemma dependents_kept:
- fixes th''
- assumes neq1: "th'' \<noteq> th"
- and neq2: "th'' \<noteq> th'"
- shows "dependents (wq s) th'' = dependents (wq s') th''"
-proof(auto)
- fix x
- assume "x \<in> dependents (wq s) th''"
- hence dp: "(Th x, Th th'') \<in> (depend s)^+"
- by (auto simp:cs_dependents_def eq_depend)
- { fix n
- have "(n, Th th'') \<in> (depend s)^+ \<Longrightarrow> (n, Th th'') \<in> (depend s')^+"
- proof(induct rule:converse_trancl_induct)
- fix y
- assume "(y, Th th'') \<in> depend s"
- with depend_s neq1 neq2
- have "(y, Th th'') \<in> depend s'" by auto
- thus "(y, Th th'') \<in> (depend s')\<^sup>+" by auto
- next
- fix y z
- assume yz: "(y, z) \<in> depend s"
- and ztp: "(z, Th th'') \<in> (depend s)\<^sup>+"
- and ztp': "(z, Th th'') \<in> (depend s')\<^sup>+"
- have "y \<noteq> Cs cs \<and> y \<noteq> Th th'"
- proof
- show "y \<noteq> Cs cs"
- proof
- assume eq_y: "y = Cs cs"
- with yz have dp_yz: "(Cs cs, z) \<in> depend s" by simp
- from depend_s
- have cst': "(Cs cs, Th th') \<in> depend s" by simp
- from unique_depend[OF vt_s this dp_yz]
- have eq_z: "z = Th th'" by simp
- with ztp have "(Th th', Th th'') \<in> (depend s)^+" by simp
- from converse_tranclE[OF this]
- obtain cs' where dp'': "(Th th', Cs cs') \<in> depend s"
- by (auto simp:s_depend_def)
- with depend_s have dp': "(Th th', Cs cs') \<in> depend s'" by auto
- from dp'' eq_y yz eq_z have "(Cs cs, Cs cs') \<in> (depend s)^+" by auto
- moreover have "cs' = cs"
- proof -
- from next_waiting[OF step_back_vt[OF vt_s[unfolded s_def]] nt]
- have "(Th th', Cs cs) \<in> depend s'"
- by (auto simp:s_waiting_def wq_def s_depend_def cs_waiting_def)
- from unique_depend[OF step_back_vt[OF vt_s[unfolded s_def]] this dp']
- show ?thesis by simp
- qed
- ultimately have "(Cs cs, Cs cs) \<in> (depend s)^+" by simp
- moreover note wf_trancl[OF wf_depend[OF vt_s]]
- ultimately show False by auto
- qed
- next
- show "y \<noteq> Th th'"
- proof
- assume eq_y: "y = Th th'"
- with yz have dps: "(Th th', z) \<in> depend s" by simp
- with depend_s have dps': "(Th th', z) \<in> depend s'" by auto
- have "z = Cs cs"
- proof -
- from next_waiting[OF step_back_vt[OF vt_s[unfolded s_def]] nt]
- have "(Th th', Cs cs) \<in> depend s'"
- by (auto simp:s_waiting_def wq_def s_depend_def cs_waiting_def)
- from unique_depend[OF step_back_vt[OF vt_s[unfolded s_def]] dps' this]
- show ?thesis .
- qed
- with dps depend_s show False by auto
- qed
- qed
- with depend_s yz have "(y, z) \<in> depend s'" by auto
- with ztp'
- show "(y, Th th'') \<in> (depend s')\<^sup>+" by auto
- qed
- }
- from this[OF dp]
- show "x \<in> dependents (wq s') th''"
- by (auto simp:cs_dependents_def eq_depend)
-next
- fix x
- assume "x \<in> dependents (wq s') th''"
- hence dp: "(Th x, Th th'') \<in> (depend s')^+"
- by (auto simp:cs_dependents_def eq_depend)
- { fix n
- have "(n, Th th'') \<in> (depend s')^+ \<Longrightarrow> (n, Th th'') \<in> (depend s)^+"
- proof(induct rule:converse_trancl_induct)
- fix y
- assume "(y, Th th'') \<in> depend s'"
- with depend_s neq1 neq2
- have "(y, Th th'') \<in> depend s" by auto
- thus "(y, Th th'') \<in> (depend s)\<^sup>+" by auto
- next
- fix y z
- assume yz: "(y, z) \<in> depend s'"
- and ztp: "(z, Th th'') \<in> (depend s')\<^sup>+"
- and ztp': "(z, Th th'') \<in> (depend s)\<^sup>+"
- have "y \<noteq> Cs cs \<and> y \<noteq> Th th'"
- proof
- show "y \<noteq> Cs cs"
- proof
- assume eq_y: "y = Cs cs"
- with yz have dp_yz: "(Cs cs, z) \<in> depend s'" by simp
- from this have eq_z: "z = Th th"
- proof -
- from step_back_step[OF vt_s[unfolded s_def]]
- have "(Cs cs, Th th) \<in> depend s'"
- by(cases, auto simp: wq_def s_depend_def cs_holding_def s_holding_def)
- from unique_depend[OF step_back_vt[OF vt_s[unfolded s_def]] this dp_yz]
- show ?thesis by simp
- qed
- from converse_tranclE[OF ztp]
- obtain u where "(z, u) \<in> depend s'" by auto
- moreover
- from step_back_step[OF vt_s[unfolded s_def]]
- have "th \<in> readys s'" by (cases, simp add:runing_def)
- moreover note eq_z
- ultimately show False
- by (auto simp:readys_def wq_def s_depend_def s_waiting_def cs_waiting_def)
- qed
- next
- show "y \<noteq> Th th'"
- proof
- assume eq_y: "y = Th th'"
- with yz have dps: "(Th th', z) \<in> depend s'" by simp
- have "z = Cs cs"
- proof -
- from next_waiting[OF step_back_vt[OF vt_s[unfolded s_def]] nt]
- have "(Th th', Cs cs) \<in> depend s'"
- by (auto simp:s_waiting_def wq_def s_depend_def cs_waiting_def)
- from unique_depend[OF step_back_vt[OF vt_s[unfolded s_def]] dps this]
- show ?thesis .
- qed
- with ztp have cs_i: "(Cs cs, Th th'') \<in> (depend s')\<^sup>+" by simp
- from step_back_step[OF vt_s[unfolded s_def]]
- have cs_th: "(Cs cs, Th th) \<in> depend s'"
- by(cases, auto simp: s_depend_def wq_def cs_holding_def s_holding_def)
- have "(Cs cs, Th th'') \<notin> depend s'"
- proof
- assume "(Cs cs, Th th'') \<in> depend s'"
- from unique_depend[OF step_back_vt[OF vt_s[unfolded s_def]] this cs_th]
- and neq1 show "False" by simp
- qed
- with converse_tranclE[OF cs_i]
- obtain u where cu: "(Cs cs, u) \<in> depend s'"
- and u_t: "(u, Th th'') \<in> (depend s')\<^sup>+" by auto
- have "u = Th th"
- proof -
- from unique_depend[OF step_back_vt[OF vt_s[unfolded s_def]] cu cs_th]
- show ?thesis .
- qed
- with u_t have "(Th th, Th th'') \<in> (depend s')\<^sup>+" by simp
- from converse_tranclE[OF this]
- obtain v where "(Th th, v) \<in> (depend s')" by auto
- moreover from step_back_step[OF vt_s[unfolded s_def]]
- have "th \<in> readys s'" by (cases, simp add:runing_def)
- ultimately show False
- by (auto simp:readys_def wq_def s_depend_def s_waiting_def cs_waiting_def)
- qed
- qed
- with depend_s yz have "(y, z) \<in> depend s" by auto
- with ztp'
- show "(y, Th th'') \<in> (depend s)\<^sup>+" by auto
- qed
- }
- from this[OF dp]
- show "x \<in> dependents (wq s) th''"
- by (auto simp:cs_dependents_def eq_depend)
-qed
-
-lemma cp_kept:
- fixes th''
- assumes neq1: "th'' \<noteq> th"
- and neq2: "th'' \<noteq> th'"
- shows "cp s th'' = cp s' th''"
-proof -
- from dependents_kept[OF neq1 neq2]
- have "dependents (wq s) th'' = dependents (wq s') th''" .
- moreover {
- fix th1
- assume "th1 \<in> dependents (wq s) th''"
- have "preced th1 s = preced th1 s'"
- by (unfold s_def, auto simp:preced_def)
- }
- moreover have "preced th'' s = preced th'' s'"
- by (unfold s_def, auto simp:preced_def)
- ultimately have "((\<lambda>th. preced th s) ` ({th''} \<union> dependents (wq s) th'')) =
- ((\<lambda>th. preced th s') ` ({th''} \<union> dependents (wq s') th''))"
- by (auto simp:image_def)
- thus ?thesis
- by (unfold cp_eq_cpreced cpreced_def, simp)
-qed
-
-end
-
-locale step_v_cps_nnt = step_v_cps +
- assumes nnt: "\<And> th'. (\<not> next_th s' th cs th')"
-
-context step_v_cps_nnt
-begin
-
-lemma nw_cs: "(Th th1, Cs cs) \<notin> depend s'"
-proof
- assume "(Th th1, Cs cs) \<in> depend s'"
- thus "False"
- apply (auto simp:s_depend_def cs_waiting_def)
- proof -
- assume h1: "th1 \<in> set (wq s' cs)"
- and h2: "th1 \<noteq> hd (wq s' cs)"
- from step_back_step[OF vt_s[unfolded s_def]]
- show "False"
- proof(cases)
- assume "holding s' th cs"
- then obtain rest where
- eq_wq: "wq s' cs = th#rest"
- apply (unfold s_holding_def wq_def[symmetric])
- by (case_tac "(wq s' cs)", auto)
- with h1 h2 have ne: "rest \<noteq> []" by auto
- with eq_wq
- have "next_th s' th cs (hd (SOME q. distinct q \<and> set q = set rest))"
- by(unfold next_th_def, rule_tac x = "rest" in exI, auto)
- with nnt show ?thesis by auto
- qed
- qed
-qed
-
-lemma depend_s: "depend s = depend s' - {(Cs cs, Th th)}"
-proof -
- from nnt and step_depend_v[OF vt_s[unfolded s_def], folded s_def]
- show ?thesis by auto
-qed
-
-lemma child_kept_left:
- assumes
- "(n1, n2) \<in> (child s')^+"
- shows "(n1, n2) \<in> (child s)^+"
-proof -
- from assms show ?thesis
- proof(induct rule: converse_trancl_induct)
- case (base y)
- from base obtain th1 cs1 th2
- where h1: "(Th th1, Cs cs1) \<in> depend s'"
- and h2: "(Cs cs1, Th th2) \<in> depend s'"
- and eq_y: "y = Th th1" and eq_n2: "n2 = Th th2" by (auto simp:child_def)
- have "cs1 \<noteq> cs"
- proof
- assume eq_cs: "cs1 = cs"
- with h1 have "(Th th1, Cs cs1) \<in> depend s'" by simp
- with nw_cs eq_cs show False by auto
- qed
- with h1 h2 depend_s have
- h1': "(Th th1, Cs cs1) \<in> depend s" and
- h2': "(Cs cs1, Th th2) \<in> depend s" by auto
- hence "(Th th1, Th th2) \<in> child s" by (auto simp:child_def)
- with eq_y eq_n2 have "(y, n2) \<in> child s" by simp
- thus ?case by auto
- next
- case (step y z)
- have "(y, z) \<in> child s'" by fact
- then obtain th1 cs1 th2
- where h1: "(Th th1, Cs cs1) \<in> depend s'"
- and h2: "(Cs cs1, Th th2) \<in> depend s'"
- and eq_y: "y = Th th1" and eq_z: "z = Th th2" by (auto simp:child_def)
- have "cs1 \<noteq> cs"
- proof
- assume eq_cs: "cs1 = cs"
- with h1 have "(Th th1, Cs cs1) \<in> depend s'" by simp
- with nw_cs eq_cs show False by auto
- qed
- with h1 h2 depend_s have
- h1': "(Th th1, Cs cs1) \<in> depend s" and
- h2': "(Cs cs1, Th th2) \<in> depend s" by auto
- hence "(Th th1, Th th2) \<in> child s" by (auto simp:child_def)
- with eq_y eq_z have "(y, z) \<in> child s" by simp
- moreover have "(z, n2) \<in> (child s)^+" by fact
- ultimately show ?case by auto
- qed
-qed
-
-lemma child_kept_right:
- assumes
- "(n1, n2) \<in> (child s)^+"
- shows "(n1, n2) \<in> (child s')^+"
-proof -
- from assms show ?thesis
- proof(induct)
- case (base y)
- from base and depend_s
- have "(n1, y) \<in> child s'"
- by (auto simp:child_def)
- thus ?case by auto
- next
- case (step y z)
- have "(y, z) \<in> child s" by fact
- with depend_s have "(y, z) \<in> child s'"
- by (auto simp:child_def)
- moreover have "(n1, y) \<in> (child s')\<^sup>+" by fact
- ultimately show ?case by auto
- qed
-qed
-
-lemma eq_child: "(child s)^+ = (child s')^+"
- by (insert child_kept_left child_kept_right, auto)
-
-lemma eq_cp:
- fixes th'
- shows "cp s th' = cp s' th'"
- apply (unfold cp_eq_cpreced cpreced_def)
-proof -
- have eq_dp: "\<And> th. dependents (wq s) th = dependents (wq s') th"
- apply (unfold cs_dependents_def, unfold eq_depend)
- proof -
- from eq_child
- have "\<And>th. {th'. (Th th', Th th) \<in> (child s)\<^sup>+} = {th'. (Th th', Th th) \<in> (child s')\<^sup>+}"
- by simp
- with child_depend_eq[OF vt_s] child_depend_eq[OF step_back_vt[OF vt_s[unfolded s_def]]]
- show "\<And>th. {th'. (Th th', Th th) \<in> (depend s)\<^sup>+} = {th'. (Th th', Th th) \<in> (depend s')\<^sup>+}"
- by simp
- qed
- moreover {
- fix th1
- assume "th1 \<in> {th'} \<union> dependents (wq s') th'"
- hence "th1 = th' \<or> th1 \<in> dependents (wq s') th'" by auto
- hence "preced th1 s = preced th1 s'"
- proof
- assume "th1 = th'"
- show "preced th1 s = preced th1 s'" by (simp add:s_def preced_def)
- next
- assume "th1 \<in> dependents (wq s') th'"
- show "preced th1 s = preced th1 s'" by (simp add:s_def preced_def)
- qed
- } ultimately have "((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))"
- by (auto simp:image_def)
- thus "Max ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- Max ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))" by simp
-qed
-
-end
-
-locale step_P_cps =
- fixes s' th cs s
- defines s_def : "s \<equiv> (P th cs#s')"
- assumes vt_s: "vt s"
-
-locale step_P_cps_ne =step_P_cps +
- assumes ne: "wq s' cs \<noteq> []"
-
-locale step_P_cps_e =step_P_cps +
- assumes ee: "wq s' cs = []"
-
-context step_P_cps_e
-begin
-
-lemma depend_s: "depend s = depend s' \<union> {(Cs cs, Th th)}"
-proof -
- from ee and step_depend_p[OF vt_s[unfolded s_def], folded s_def]
- show ?thesis by auto
-qed
-
-lemma child_kept_left:
- assumes
- "(n1, n2) \<in> (child s')^+"
- shows "(n1, n2) \<in> (child s)^+"
-proof -
- from assms show ?thesis
- proof(induct rule: converse_trancl_induct)
- case (base y)
- from base obtain th1 cs1 th2
- where h1: "(Th th1, Cs cs1) \<in> depend s'"
- and h2: "(Cs cs1, Th th2) \<in> depend s'"
- and eq_y: "y = Th th1" and eq_n2: "n2 = Th th2" by (auto simp:child_def)
- have "cs1 \<noteq> cs"
- proof
- assume eq_cs: "cs1 = cs"
- with h1 have "(Th th1, Cs cs) \<in> depend s'" by simp
- with ee show False
- by (auto simp:s_depend_def cs_waiting_def)
- qed
- with h1 h2 depend_s have
- h1': "(Th th1, Cs cs1) \<in> depend s" and
- h2': "(Cs cs1, Th th2) \<in> depend s" by auto
- hence "(Th th1, Th th2) \<in> child s" by (auto simp:child_def)
- with eq_y eq_n2 have "(y, n2) \<in> child s" by simp
- thus ?case by auto
- next
- case (step y z)
- have "(y, z) \<in> child s'" by fact
- then obtain th1 cs1 th2
- where h1: "(Th th1, Cs cs1) \<in> depend s'"
- and h2: "(Cs cs1, Th th2) \<in> depend s'"
- and eq_y: "y = Th th1" and eq_z: "z = Th th2" by (auto simp:child_def)
- have "cs1 \<noteq> cs"
- proof
- assume eq_cs: "cs1 = cs"
- with h1 have "(Th th1, Cs cs) \<in> depend s'" by simp
- with ee show False
- by (auto simp:s_depend_def cs_waiting_def)
- qed
- with h1 h2 depend_s have
- h1': "(Th th1, Cs cs1) \<in> depend s" and
- h2': "(Cs cs1, Th th2) \<in> depend s" by auto
- hence "(Th th1, Th th2) \<in> child s" by (auto simp:child_def)
- with eq_y eq_z have "(y, z) \<in> child s" by simp
- moreover have "(z, n2) \<in> (child s)^+" by fact
- ultimately show ?case by auto
- qed
-qed
-
-lemma child_kept_right:
- assumes
- "(n1, n2) \<in> (child s)^+"
- shows "(n1, n2) \<in> (child s')^+"
-proof -
- from assms show ?thesis
- proof(induct)
- case (base y)
- from base and depend_s
- have "(n1, y) \<in> child s'"
- apply (auto simp:child_def)
- proof -
- fix th'
- assume "(Th th', Cs cs) \<in> depend s'"
- with ee have "False"
- by (auto simp:s_depend_def cs_waiting_def)
- thus "\<exists>cs. (Th th', Cs cs) \<in> depend s' \<and> (Cs cs, Th th) \<in> depend s'" by auto
- qed
- thus ?case by auto
- next
- case (step y z)
- have "(y, z) \<in> child s" by fact
- with depend_s have "(y, z) \<in> child s'"
- apply (auto simp:child_def)
- proof -
- fix th'
- assume "(Th th', Cs cs) \<in> depend s'"
- with ee have "False"
- by (auto simp:s_depend_def cs_waiting_def)
- thus "\<exists>cs. (Th th', Cs cs) \<in> depend s' \<and> (Cs cs, Th th) \<in> depend s'" by auto
- qed
- moreover have "(n1, y) \<in> (child s')\<^sup>+" by fact
- ultimately show ?case by auto
- qed
-qed
-
-lemma eq_child: "(child s)^+ = (child s')^+"
- by (insert child_kept_left child_kept_right, auto)
-
-lemma eq_cp:
- fixes th'
- shows "cp s th' = cp s' th'"
- apply (unfold cp_eq_cpreced cpreced_def)
-proof -
- have eq_dp: "\<And> th. dependents (wq s) th = dependents (wq s') th"
- apply (unfold cs_dependents_def, unfold eq_depend)
- proof -
- from eq_child
- have "\<And>th. {th'. (Th th', Th th) \<in> (child s)\<^sup>+} = {th'. (Th th', Th th) \<in> (child s')\<^sup>+}"
- by auto
- with child_depend_eq[OF vt_s] child_depend_eq[OF step_back_vt[OF vt_s[unfolded s_def]]]
- show "\<And>th. {th'. (Th th', Th th) \<in> (depend s)\<^sup>+} = {th'. (Th th', Th th) \<in> (depend s')\<^sup>+}"
- by simp
- qed
- moreover {
- fix th1
- assume "th1 \<in> {th'} \<union> dependents (wq s') th'"
- hence "th1 = th' \<or> th1 \<in> dependents (wq s') th'" by auto
- hence "preced th1 s = preced th1 s'"
- proof
- assume "th1 = th'"
- show "preced th1 s = preced th1 s'" by (simp add:s_def preced_def)
- next
- assume "th1 \<in> dependents (wq s') th'"
- show "preced th1 s = preced th1 s'" by (simp add:s_def preced_def)
- qed
- } ultimately have "((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))"
- by (auto simp:image_def)
- thus "Max ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- Max ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))" by simp
-qed
-
-end
-
-context step_P_cps_ne
-begin
-
-lemma depend_s: "depend s = depend s' \<union> {(Th th, Cs cs)}"
-proof -
- from step_depend_p[OF vt_s[unfolded s_def]] and ne
- show ?thesis by (simp add:s_def)
-qed
-
-lemma eq_child_left:
- assumes nd: "(Th th, Th th') \<notin> (child s)^+"
- shows "(n1, Th th') \<in> (child s)^+ \<Longrightarrow> (n1, Th th') \<in> (child s')^+"
-proof(induct rule:converse_trancl_induct)
- case (base y)
- from base obtain th1 cs1
- where h1: "(Th th1, Cs cs1) \<in> depend s"
- and h2: "(Cs cs1, Th th') \<in> depend s"
- and eq_y: "y = Th th1" by (auto simp:child_def)
- have "th1 \<noteq> th"
- proof
- assume "th1 = th"
- with base eq_y have "(Th th, Th th') \<in> child s" by simp
- with nd show False by auto
- qed
- with h1 h2 depend_s
- have h1': "(Th th1, Cs cs1) \<in> depend s'" and
- h2': "(Cs cs1, Th th') \<in> depend s'" by auto
- with eq_y show ?case by (auto simp:child_def)
-next
- case (step y z)
- have yz: "(y, z) \<in> child s" by fact
- then obtain th1 cs1 th2
- where h1: "(Th th1, Cs cs1) \<in> depend s"
- and h2: "(Cs cs1, Th th2) \<in> depend s"
- and eq_y: "y = Th th1" and eq_z: "z = Th th2" by (auto simp:child_def)
- have "th1 \<noteq> th"
- proof
- assume "th1 = th"
- with yz eq_y have "(Th th, z) \<in> child s" by simp
- moreover have "(z, Th th') \<in> (child s)^+" by fact
- ultimately have "(Th th, Th th') \<in> (child s)^+" by auto
- with nd show False by auto
- qed
- with h1 h2 depend_s have h1': "(Th th1, Cs cs1) \<in> depend s'"
- and h2': "(Cs cs1, Th th2) \<in> depend s'" by auto
- with eq_y eq_z have "(y, z) \<in> child s'" by (auto simp:child_def)
- moreover have "(z, Th th') \<in> (child s')^+" by fact
- ultimately show ?case by auto
-qed
-
-lemma eq_child_right:
- shows "(n1, Th th') \<in> (child s')^+ \<Longrightarrow> (n1, Th th') \<in> (child s)^+"
-proof(induct rule:converse_trancl_induct)
- case (base y)
- with depend_s show ?case by (auto simp:child_def)
-next
- case (step y z)
- have "(y, z) \<in> child s'" by fact
- with depend_s have "(y, z) \<in> child s" by (auto simp:child_def)
- moreover have "(z, Th th') \<in> (child s)^+" by fact
- ultimately show ?case by auto
-qed
-
-lemma eq_child:
- assumes nd: "(Th th, Th th') \<notin> (child s)^+"
- shows "((n1, Th th') \<in> (child s)^+) = ((n1, Th th') \<in> (child s')^+)"
- by (insert eq_child_left[OF nd] eq_child_right, auto)
-
-lemma eq_cp:
- fixes th'
- assumes nd: "th \<notin> dependents s th'"
- shows "cp s th' = cp s' th'"
- apply (unfold cp_eq_cpreced cpreced_def)
-proof -
- have nd': "(Th th, Th th') \<notin> (child s)^+"
- proof
- assume "(Th th, Th th') \<in> (child s)\<^sup>+"
- with child_depend_eq[OF vt_s]
- have "(Th th, Th th') \<in> (depend s)\<^sup>+" by simp
- with nd show False
- by (simp add:s_dependents_def eq_depend)
- qed
- have eq_dp: "dependents (wq s) th' = dependents (wq s') th'"
- proof(auto)
- fix x assume " x \<in> dependents (wq s) th'"
- thus "x \<in> dependents (wq s') th'"
- apply (auto simp:cs_dependents_def eq_depend)
- proof -
- assume "(Th x, Th th') \<in> (depend s)\<^sup>+"
- with child_depend_eq[OF vt_s] have "(Th x, Th th') \<in> (child s)\<^sup>+" by simp
- with eq_child[OF nd'] have "(Th x, Th th') \<in> (child s')^+" by simp
- with child_depend_eq[OF step_back_vt[OF vt_s[unfolded s_def]]]
- show "(Th x, Th th') \<in> (depend s')\<^sup>+" by simp
- qed
- next
- fix x assume "x \<in> dependents (wq s') th'"
- thus "x \<in> dependents (wq s) th'"
- apply (auto simp:cs_dependents_def eq_depend)
- proof -
- assume "(Th x, Th th') \<in> (depend s')\<^sup>+"
- with child_depend_eq[OF step_back_vt[OF vt_s[unfolded s_def]]]
- have "(Th x, Th th') \<in> (child s')\<^sup>+" by simp
- with eq_child[OF nd'] have "(Th x, Th th') \<in> (child s)^+" by simp
- with child_depend_eq[OF vt_s]
- show "(Th x, Th th') \<in> (depend s)\<^sup>+" by simp
- qed
- qed
- moreover {
- fix th1 have "preced th1 s = preced th1 s'" by (simp add:s_def preced_def)
- } ultimately have "((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))"
- by (auto simp:image_def)
- thus "Max ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- Max ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))" by simp
-qed
-
-lemma eq_up:
- fixes th' th''
- assumes dp1: "th \<in> dependents s th'"
- and dp2: "th' \<in> dependents s th''"
- and eq_cps: "cp s th' = cp s' th'"
- shows "cp s th'' = cp s' th''"
-proof -
- from dp2
- have "(Th th', Th th'') \<in> (depend (wq s))\<^sup>+" by (simp add:s_dependents_def)
- from depend_child[OF vt_s this[unfolded eq_depend]]
- have ch_th': "(Th th', Th th'') \<in> (child s)\<^sup>+" .
- moreover {
- fix n th''
- have "\<lbrakk>(Th th', n) \<in> (child s)^+\<rbrakk> \<Longrightarrow>
- (\<forall> th'' . n = Th th'' \<longrightarrow> cp s th'' = cp s' th'')"
- proof(erule trancl_induct, auto)
- fix y th''
- assume y_ch: "(y, Th th'') \<in> child s"
- and ih: "\<forall>th''. y = Th th'' \<longrightarrow> cp s th'' = cp s' th''"
- and ch': "(Th th', y) \<in> (child s)\<^sup>+"
- from y_ch obtain thy where eq_y: "y = Th thy" by (auto simp:child_def)
- with ih have eq_cpy:"cp s thy = cp s' thy" by blast
- from dp1 have "(Th th, Th th') \<in> (depend s)^+" by (auto simp:s_dependents_def eq_depend)
- moreover from child_depend_p[OF ch'] and eq_y
- have "(Th th', Th thy) \<in> (depend s)^+" by simp
- ultimately have dp_thy: "(Th th, Th thy) \<in> (depend s)^+" by auto
- show "cp s th'' = cp s' th''"
- apply (subst cp_rec[OF vt_s])
- proof -
- have "preced th'' s = preced th'' s'"
- by (simp add:s_def preced_def)
- moreover {
- fix th1
- assume th1_in: "th1 \<in> children s th''"
- have "cp s th1 = cp s' th1"
- proof(cases "th1 = thy")
- case True
- with eq_cpy show ?thesis by simp
- next
- case False
- have neq_th1: "th1 \<noteq> th"
- proof
- assume eq_th1: "th1 = th"
- with dp_thy have "(Th th1, Th thy) \<in> (depend s)^+" by simp
- from children_no_dep[OF vt_s _ _ this] and
- th1_in y_ch eq_y show False by (auto simp:children_def)
- qed
- have "th \<notin> dependents s th1"
- proof
- assume h:"th \<in> dependents s th1"
- from eq_y dp_thy have "th \<in> dependents s thy" by (auto simp:s_dependents_def eq_depend)
- from dependents_child_unique[OF vt_s _ _ h this]
- th1_in y_ch eq_y have "th1 = thy" by (auto simp:children_def child_def)
- with False show False by auto
- qed
- from eq_cp[OF this]
- show ?thesis .
- qed
- }
- ultimately have "{preced th'' s} \<union> (cp s ` children s th'') =
- {preced th'' s'} \<union> (cp s' ` children s th'')" by (auto simp:image_def)
- moreover have "children s th'' = children s' th''"
- apply (unfold children_def child_def s_def depend_set_unchanged, simp)
- apply (fold s_def, auto simp:depend_s)
- proof -
- assume "(Cs cs, Th th'') \<in> depend s'"
- with depend_s have cs_th': "(Cs cs, Th th'') \<in> depend s" by auto
- from dp1 have "(Th th, Th th') \<in> (depend s)^+"
- by (auto simp:s_dependents_def eq_depend)
- from converse_tranclE[OF this]
- obtain cs1 where h1: "(Th th, Cs cs1) \<in> depend s"
- and h2: "(Cs cs1 , Th th') \<in> (depend s)\<^sup>+"
- by (auto simp:s_depend_def)
- have eq_cs: "cs1 = cs"
- proof -
- from depend_s have "(Th th, Cs cs) \<in> depend s" by simp
- from unique_depend[OF vt_s this h1]
- show ?thesis by simp
- qed
- have False
- proof(rule converse_tranclE[OF h2])
- assume "(Cs cs1, Th th') \<in> depend s"
- with eq_cs have "(Cs cs, Th th') \<in> depend s" by simp
- from unique_depend[OF vt_s this cs_th']
- have "th' = th''" by simp
- with ch' y_ch have "(Th th'', Th th'') \<in> (child s)^+" by auto
- with wf_trancl[OF wf_child[OF vt_s]]
- show False by auto
- next
- fix y
- assume "(Cs cs1, y) \<in> depend s"
- and ytd: " (y, Th th') \<in> (depend s)\<^sup>+"
- with eq_cs have csy: "(Cs cs, y) \<in> depend s" by simp
- from unique_depend[OF vt_s this cs_th']
- have "y = Th th''" .
- with ytd have "(Th th'', Th th') \<in> (depend s)^+" by simp
- from depend_child[OF vt_s this]
- have "(Th th'', Th th') \<in> (child s)\<^sup>+" .
- moreover from ch' y_ch have ch'': "(Th th', Th th'') \<in> (child s)^+" by auto
- ultimately have "(Th th'', Th th'') \<in> (child s)^+" by auto
- with wf_trancl[OF wf_child[OF vt_s]]
- show False by auto
- qed
- thus "\<exists>cs. (Th th, Cs cs) \<in> depend s' \<and> (Cs cs, Th th'') \<in> depend s'" by auto
- qed
- ultimately show "Max ({preced th'' s} \<union> cp s ` children s th'') = cp s' th''"
- by (simp add:cp_rec[OF step_back_vt[OF vt_s[unfolded s_def]]])
- qed
- next
- fix th''
- assume dp': "(Th th', Th th'') \<in> child s"
- show "cp s th'' = cp s' th''"
- apply (subst cp_rec[OF vt_s])
- proof -
- have "preced th'' s = preced th'' s'"
- by (simp add:s_def preced_def)
- moreover {
- fix th1
- assume th1_in: "th1 \<in> children s th''"
- have "cp s th1 = cp s' th1"
- proof(cases "th1 = th'")
- case True
- with eq_cps show ?thesis by simp
- next
- case False
- have neq_th1: "th1 \<noteq> th"
- proof
- assume eq_th1: "th1 = th"
- with dp1 have "(Th th1, Th th') \<in> (depend s)^+"
- by (auto simp:s_dependents_def eq_depend)
- from children_no_dep[OF vt_s _ _ this]
- th1_in dp'
- show False by (auto simp:children_def)
- qed
- show ?thesis
- proof(rule eq_cp)
- show "th \<notin> dependents s th1"
- proof
- assume "th \<in> dependents s th1"
- from dependents_child_unique[OF vt_s _ _ this dp1]
- th1_in dp' have "th1 = th'"
- by (auto simp:children_def)
- with False show False by auto
- qed
- qed
- qed
- }
- ultimately have "{preced th'' s} \<union> (cp s ` children s th'') =
- {preced th'' s'} \<union> (cp s' ` children s th'')" by (auto simp:image_def)
- moreover have "children s th'' = children s' th''"
- apply (unfold children_def child_def s_def depend_set_unchanged, simp)
- apply (fold s_def, auto simp:depend_s)
- proof -
- assume "(Cs cs, Th th'') \<in> depend s'"
- with depend_s have cs_th': "(Cs cs, Th th'') \<in> depend s" by auto
- from dp1 have "(Th th, Th th') \<in> (depend s)^+"
- by (auto simp:s_dependents_def eq_depend)
- from converse_tranclE[OF this]
- obtain cs1 where h1: "(Th th, Cs cs1) \<in> depend s"
- and h2: "(Cs cs1 , Th th') \<in> (depend s)\<^sup>+"
- by (auto simp:s_depend_def)
- have eq_cs: "cs1 = cs"
- proof -
- from depend_s have "(Th th, Cs cs) \<in> depend s" by simp
- from unique_depend[OF vt_s this h1]
- show ?thesis by simp
- qed
- have False
- proof(rule converse_tranclE[OF h2])
- assume "(Cs cs1, Th th') \<in> depend s"
- with eq_cs have "(Cs cs, Th th') \<in> depend s" by simp
- from unique_depend[OF vt_s this cs_th']
- have "th' = th''" by simp
- with dp' have "(Th th'', Th th'') \<in> (child s)^+" by auto
- with wf_trancl[OF wf_child[OF vt_s]]
- show False by auto
- next
- fix y
- assume "(Cs cs1, y) \<in> depend s"
- and ytd: " (y, Th th') \<in> (depend s)\<^sup>+"
- with eq_cs have csy: "(Cs cs, y) \<in> depend s" by simp
- from unique_depend[OF vt_s this cs_th']
- have "y = Th th''" .
- with ytd have "(Th th'', Th th') \<in> (depend s)^+" by simp
- from depend_child[OF vt_s this]
- have "(Th th'', Th th') \<in> (child s)\<^sup>+" .
- moreover from dp' have ch'': "(Th th', Th th'') \<in> (child s)^+" by auto
- ultimately have "(Th th'', Th th'') \<in> (child s)^+" by auto
- with wf_trancl[OF wf_child[OF vt_s]]
- show False by auto
- qed
- thus "\<exists>cs. (Th th, Cs cs) \<in> depend s' \<and> (Cs cs, Th th'') \<in> depend s'" by auto
- qed
- ultimately show "Max ({preced th'' s} \<union> cp s ` children s th'') = cp s' th''"
- by (simp add:cp_rec[OF step_back_vt[OF vt_s[unfolded s_def]]])
- qed
- qed
- }
- ultimately show ?thesis by auto
-qed
-
-end
-
-locale step_create_cps =
- fixes s' th prio s
- defines s_def : "s \<equiv> (Create th prio#s')"
- assumes vt_s: "vt s"
-
-context step_create_cps
-begin
-
-lemma eq_dep: "depend s = depend s'"
- by (unfold s_def depend_create_unchanged, auto)
-
-lemma eq_cp:
- fixes th'
- assumes neq_th: "th' \<noteq> th"
- shows "cp s th' = cp s' th'"
- apply (unfold cp_eq_cpreced cpreced_def)
-proof -
- have nd: "th \<notin> dependents s th'"
- proof
- assume "th \<in> dependents s th'"
- hence "(Th th, Th th') \<in> (depend s)^+" by (simp add:s_dependents_def eq_depend)
- with eq_dep have "(Th th, Th th') \<in> (depend s')^+" by simp
- from converse_tranclE[OF this]
- obtain y where "(Th th, y) \<in> depend s'" by auto
- with dm_depend_threads[OF step_back_vt[OF vt_s[unfolded s_def]]]
- have in_th: "th \<in> threads s'" by auto
- from step_back_step[OF vt_s[unfolded s_def]]
- show False
- proof(cases)
- assume "th \<notin> threads s'"
- with in_th show ?thesis by simp
- qed
- qed
- have eq_dp: "\<And> th. dependents (wq s) th = dependents (wq s') th"
- by (unfold cs_dependents_def, auto simp:eq_dep eq_depend)
- moreover {
- fix th1
- assume "th1 \<in> {th'} \<union> dependents (wq s') th'"
- hence "th1 = th' \<or> th1 \<in> dependents (wq s') th'" by auto
- hence "preced th1 s = preced th1 s'"
- proof
- assume "th1 = th'"
- with neq_th
- show "preced th1 s = preced th1 s'" by (auto simp:s_def preced_def)
- next
- assume "th1 \<in> dependents (wq s') th'"
- with nd and eq_dp have "th1 \<noteq> th"
- by (auto simp:eq_depend cs_dependents_def s_dependents_def eq_dep)
- thus "preced th1 s = preced th1 s'" by (auto simp:s_def preced_def)
- qed
- } ultimately have "((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))"
- by (auto simp:image_def)
- thus "Max ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- Max ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))" by simp
-qed
-
-lemma nil_dependents: "dependents s th = {}"
-proof -
- from step_back_step[OF vt_s[unfolded s_def]]
- show ?thesis
- proof(cases)
- assume "th \<notin> threads s'"
- from not_thread_holdents[OF step_back_vt[OF vt_s[unfolded s_def]] this]
- have hdn: " holdents s' th = {}" .
- have "dependents s' th = {}"
- proof -
- { assume "dependents s' th \<noteq> {}"
- then obtain th' where dp: "(Th th', Th th) \<in> (depend s')^+"
- by (auto simp:s_dependents_def eq_depend)
- from tranclE[OF this] obtain cs' where
- "(Cs cs', Th th) \<in> depend s'" by (auto simp:s_depend_def)
- with hdn
- have False by (auto simp:holdents_test)
- } thus ?thesis by auto
- qed
- thus ?thesis
- by (unfold s_def s_dependents_def eq_depend depend_create_unchanged, simp)
- qed
-qed
-
-lemma eq_cp_th: "cp s th = preced th s"
- apply (unfold cp_eq_cpreced cpreced_def)
- by (insert nil_dependents, unfold s_dependents_def cs_dependents_def, auto)
-
-end
-
-
-locale step_exit_cps =
- fixes s' th prio s
- defines s_def : "s \<equiv> (Exit th#s')"
- assumes vt_s: "vt s"
-
-context step_exit_cps
-begin
-
-lemma eq_dep: "depend s = depend s'"
- by (unfold s_def depend_exit_unchanged, auto)
-
-lemma eq_cp:
- fixes th'
- assumes neq_th: "th' \<noteq> th"
- shows "cp s th' = cp s' th'"
- apply (unfold cp_eq_cpreced cpreced_def)
-proof -
- have nd: "th \<notin> dependents s th'"
- proof
- assume "th \<in> dependents s th'"
- hence "(Th th, Th th') \<in> (depend s)^+" by (simp add:s_dependents_def eq_depend)
- with eq_dep have "(Th th, Th th') \<in> (depend s')^+" by simp
- from converse_tranclE[OF this]
- obtain cs' where bk: "(Th th, Cs cs') \<in> depend s'"
- by (auto simp:s_depend_def)
- from step_back_step[OF vt_s[unfolded s_def]]
- show False
- proof(cases)
- assume "th \<in> runing s'"
- with bk show ?thesis
- apply (unfold runing_def readys_def s_waiting_def s_depend_def)
- by (auto simp:cs_waiting_def wq_def)
- qed
- qed
- have eq_dp: "\<And> th. dependents (wq s) th = dependents (wq s') th"
- by (unfold cs_dependents_def, auto simp:eq_dep eq_depend)
- moreover {
- fix th1
- assume "th1 \<in> {th'} \<union> dependents (wq s') th'"
- hence "th1 = th' \<or> th1 \<in> dependents (wq s') th'" by auto
- hence "preced th1 s = preced th1 s'"
- proof
- assume "th1 = th'"
- with neq_th
- show "preced th1 s = preced th1 s'" by (auto simp:s_def preced_def)
- next
- assume "th1 \<in> dependents (wq s') th'"
- with nd and eq_dp have "th1 \<noteq> th"
- by (auto simp:eq_depend cs_dependents_def s_dependents_def eq_dep)
- thus "preced th1 s = preced th1 s'" by (auto simp:s_def preced_def)
- qed
- } ultimately have "((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))"
- by (auto simp:image_def)
- thus "Max ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')) =
- Max ((\<lambda>th. preced th s') ` ({th'} \<union> dependents (wq s') th'))" by simp
-qed
-
-end
-end
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/CpsG.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,3891 @@
+theory CpsG
+imports PIPDefs
+begin
+
+(* I am going to use this file as a start point to retrofiting
+ PIPBasics.thy, which is originally called CpsG.ghy *)
+
+locale valid_trace =
+ fixes s
+ assumes vt : "vt s"
+
+locale valid_trace_e = valid_trace +
+ fixes e
+ assumes vt_e: "vt (e#s)"
+begin
+
+lemma pip_e: "PIP s e"
+ using vt_e by (cases, simp)
+
+end
+
+lemma runing_ready:
+ shows "runing s \<subseteq> readys s"
+ unfolding runing_def readys_def
+ by auto
+
+lemma readys_threads:
+ shows "readys s \<subseteq> threads s"
+ unfolding readys_def
+ by auto
+
+lemma wq_v_neq [simp]:
+ "cs \<noteq> cs' \<Longrightarrow> wq (V thread cs#s) cs' = wq s cs'"
+ by (auto simp:wq_def Let_def cp_def split:list.splits)
+
+lemma runing_head:
+ assumes "th \<in> runing s"
+ and "th \<in> set (wq_fun (schs s) cs)"
+ shows "th = hd (wq_fun (schs s) cs)"
+ using assms
+ by (simp add:runing_def readys_def s_waiting_def wq_def)
+
+context valid_trace
+begin
+
+lemma actor_inv:
+ assumes "PIP s e"
+ and "\<not> isCreate e"
+ shows "actor e \<in> runing s"
+ using assms
+ by (induct, auto)
+
+
+lemma isP_E:
+ assumes "isP e"
+ obtains cs where "e = P (actor e) cs"
+ using assms by (cases e, auto)
+
+lemma isV_E:
+ assumes "isV e"
+ obtains cs where "e = V (actor e) cs"
+ using assms by (cases e, auto)
+
+
+lemma ind [consumes 0, case_names Nil Cons, induct type]:
+ assumes "PP []"
+ and "(\<And>s e. valid_trace s \<Longrightarrow> valid_trace (e#s) \<Longrightarrow>
+ PP s \<Longrightarrow> PIP s e \<Longrightarrow> PP (e # s))"
+ shows "PP s"
+proof(rule vt.induct[OF vt])
+ from assms(1) show "PP []" .
+next
+ fix s e
+ assume h: "vt s" "PP s" "PIP s e"
+ show "PP (e # s)"
+ proof(cases rule:assms(2))
+ from h(1) show v1: "valid_trace s" by (unfold_locales, simp)
+ next
+ from h(1,3) have "vt (e#s)" by auto
+ thus "valid_trace (e # s)" by (unfold_locales, simp)
+ qed (insert h, auto)
+qed
+
+lemma wq_distinct: "distinct (wq s cs)"
+proof(induct rule:ind)
+ case (Cons s e)
+ from Cons(4,3)
+ show ?case
+ proof(induct)
+ case (thread_P th s cs1)
+ show ?case
+ proof(cases "cs = cs1")
+ case True
+ thus ?thesis (is "distinct ?L")
+ proof -
+ have "?L = wq_fun (schs s) cs1 @ [th]" using True
+ by (simp add:wq_def wf_def Let_def split:list.splits)
+ moreover have "distinct ..."
+ proof -
+ have "th \<notin> set (wq_fun (schs s) cs1)"
+ proof
+ assume otherwise: "th \<in> set (wq_fun (schs s) cs1)"
+ from runing_head[OF thread_P(1) this]
+ have "th = hd (wq_fun (schs s) cs1)" .
+ hence "(Cs cs1, Th th) \<in> (RAG s)" using otherwise
+ by (simp add:s_RAG_def s_holding_def wq_def cs_holding_def)
+ with thread_P(2) show False by auto
+ qed
+ moreover have "distinct (wq_fun (schs s) cs1)"
+ using True thread_P wq_def by auto
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis by simp
+ qed
+ next
+ case False
+ with thread_P(3)
+ show ?thesis
+ by (auto simp:wq_def wf_def Let_def split:list.splits)
+ qed
+ next
+ case (thread_V th s cs1)
+ thus ?case
+ proof(cases "cs = cs1")
+ case True
+ show ?thesis (is "distinct ?L")
+ proof(cases "(wq s cs)")
+ case Nil
+ thus ?thesis
+ by (auto simp:wq_def wf_def Let_def split:list.splits)
+ next
+ case (Cons w_hd w_tl)
+ moreover have "distinct (SOME q. distinct q \<and> set q = set w_tl)"
+ proof(rule someI2)
+ from thread_V(3)[unfolded Cons]
+ show "distinct w_tl \<and> set w_tl = set w_tl" by auto
+ qed auto
+ ultimately show ?thesis
+ by (auto simp:wq_def wf_def Let_def True split:list.splits)
+ qed
+ next
+ case False
+ with thread_V(3)
+ show ?thesis
+ by (auto simp:wq_def wf_def Let_def split:list.splits)
+ qed
+ qed (insert Cons, auto simp: wq_def Let_def split:list.splits)
+qed (unfold wq_def Let_def, simp)
+
+end
+
+context valid_trace_e
+begin
+
+text {*
+ The following lemma shows that only the @{text "P"}
+ operation can add new thread into waiting queues.
+ Such kind of lemmas are very obvious, but need to be checked formally.
+ This is a kind of confirmation that our modelling is correct.
+*}
+
+lemma wq_in_inv:
+ assumes s_ni: "thread \<notin> set (wq s cs)"
+ and s_i: "thread \<in> set (wq (e#s) cs)"
+ shows "e = P thread cs"
+proof(cases e)
+ -- {* This is the only non-trivial case: *}
+ case (V th cs1)
+ have False
+ proof(cases "cs1 = cs")
+ case True
+ show ?thesis
+ proof(cases "(wq s cs1)")
+ case (Cons w_hd w_tl)
+ have "set (wq (e#s) cs) \<subseteq> set (wq s cs)"
+ proof -
+ have "(wq (e#s) cs) = (SOME q. distinct q \<and> set q = set w_tl)"
+ using Cons V by (auto simp:wq_def Let_def True split:if_splits)
+ moreover have "set ... \<subseteq> set (wq s cs)"
+ proof(rule someI2)
+ show "distinct w_tl \<and> set w_tl = set w_tl"
+ by (metis distinct.simps(2) local.Cons wq_distinct)
+ qed (insert Cons True, auto)
+ ultimately show ?thesis by simp
+ qed
+ with assms show ?thesis by auto
+ qed (insert assms V True, auto simp:wq_def Let_def split:if_splits)
+ qed (insert assms V, auto simp:wq_def Let_def split:if_splits)
+ thus ?thesis by auto
+qed (insert assms, auto simp:wq_def Let_def split:if_splits)
+
+lemma wq_out_inv:
+ assumes s_in: "thread \<in> set (wq s cs)"
+ and s_hd: "thread = hd (wq s cs)"
+ and s_i: "thread \<noteq> hd (wq (e#s) cs)"
+ shows "e = V thread cs"
+proof(cases e)
+-- {* There are only two non-trivial cases: *}
+ case (V th cs1)
+ show ?thesis
+ proof(cases "cs1 = cs")
+ case True
+ have "PIP s (V th cs)" using pip_e[unfolded V[unfolded True]] .
+ thus ?thesis
+ proof(cases)
+ case (thread_V)
+ moreover have "th = thread" using thread_V(2) s_hd
+ by (unfold s_holding_def wq_def, simp)
+ ultimately show ?thesis using V True by simp
+ qed
+ qed (insert assms V, auto simp:wq_def Let_def split:if_splits)
+next
+ case (P th cs1)
+ show ?thesis
+ proof(cases "cs1 = cs")
+ case True
+ with P have "wq (e#s) cs = wq_fun (schs s) cs @ [th]"
+ by (auto simp:wq_def Let_def split:if_splits)
+ with s_i s_hd s_in have False
+ by (metis empty_iff hd_append2 list.set(1) wq_def)
+ thus ?thesis by simp
+ qed (insert assms P, auto simp:wq_def Let_def split:if_splits)
+qed (insert assms, auto simp:wq_def Let_def split:if_splits)
+
+end
+
+text {*
+ The following lemmas is also obvious and shallow. It says
+ that only running thread can request for a critical resource
+ and that the requested resource must be one which is
+ not current held by the thread.
+*}
+
+lemma p_pre: "\<lbrakk>vt ((P thread cs)#s)\<rbrakk> \<Longrightarrow>
+ thread \<in> runing s \<and> (Cs cs, Th thread) \<notin> (RAG s)^+"
+apply (ind_cases "vt ((P thread cs)#s)")
+apply (ind_cases "step s (P thread cs)")
+by auto
+
+lemma abs1:
+ assumes ein: "e \<in> set es"
+ and neq: "hd es \<noteq> hd (es @ [x])"
+ shows "False"
+proof -
+ from ein have "es \<noteq> []" by auto
+ then obtain e ess where "es = e # ess" by (cases es, auto)
+ with neq show ?thesis by auto
+qed
+
+lemma q_head: "Q (hd es) \<Longrightarrow> hd es = hd [th\<leftarrow>es . Q th]"
+ by (cases es, auto)
+
+inductive_cases evt_cons: "vt (a#s)"
+
+context valid_trace_e
+begin
+
+lemma abs2:
+ assumes inq: "thread \<in> set (wq s cs)"
+ and nh: "thread = hd (wq s cs)"
+ and qt: "thread \<noteq> hd (wq (e#s) cs)"
+ and inq': "thread \<in> set (wq (e#s) cs)"
+ shows "False"
+proof -
+ from vt_e assms show "False"
+ apply (cases e)
+ apply ((simp split:if_splits add:Let_def wq_def)[1])+
+ apply (insert abs1, fast)[1]
+ apply (auto simp:wq_def simp:Let_def split:if_splits list.splits)
+ proof -
+ fix th qs
+ assume vt: "vt (V th cs # s)"
+ and th_in: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
+ and eq_wq: "wq_fun (schs s) cs = thread # qs"
+ show "False"
+ proof -
+ from wq_distinct[of cs]
+ and eq_wq[folded wq_def] have "distinct (thread#qs)" by simp
+ moreover have "thread \<in> set qs"
+ proof -
+ have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
+ proof(rule someI2)
+ from wq_distinct [of cs]
+ and eq_wq [folded wq_def]
+ show "distinct qs \<and> set qs = set qs" by auto
+ next
+ fix x assume "distinct x \<and> set x = set qs"
+ thus "set x = set qs" by auto
+ qed
+ with th_in show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ qed
+qed
+
+end
+
+
+context valid_trace
+begin
+lemma vt_moment: "\<And> t. vt (moment t s)"
+proof(induct rule:ind)
+ case Nil
+ thus ?case by (simp add:vt_nil)
+next
+ case (Cons s e t)
+ show ?case
+ proof(cases "t \<ge> length (e#s)")
+ case True
+ from True have "moment t (e#s) = e#s" by simp
+ thus ?thesis using Cons
+ by (simp add:valid_trace_def)
+ next
+ case False
+ from Cons have "vt (moment t s)" by simp
+ moreover have "moment t (e#s) = moment t s"
+ proof -
+ from False have "t \<le> length s" by simp
+ from moment_app [OF this, of "[e]"]
+ show ?thesis by simp
+ qed
+ ultimately show ?thesis by simp
+ qed
+qed
+end
+
+
+locale valid_moment = valid_trace +
+ fixes i :: nat
+
+sublocale valid_moment < vat_moment: valid_trace "(moment i s)"
+ by (unfold_locales, insert vt_moment, auto)
+
+context valid_trace
+begin
+
+
+text {* (* ddd *)
+ The nature of the work is like this: since it starts from a very simple and basic
+ model, even intuitively very `basic` and `obvious` properties need to derived from scratch.
+ For instance, the fact
+ that one thread can not be blocked by two critical resources at the same time
+ is obvious, because only running threads can make new requests, if one is waiting for
+ a critical resource and get blocked, it can not make another resource request and get
+ blocked the second time (because it is not running).
+
+ To derive this fact, one needs to prove by contraction and
+ reason about time (or @{text "moement"}). The reasoning is based on a generic theorem
+ named @{text "p_split"}, which is about status changing along the time axis. It says if
+ a condition @{text "Q"} is @{text "True"} at a state @{text "s"},
+ but it was @{text "False"} at the very beginning, then there must exits a moment @{text "t"}
+ in the history of @{text "s"} (notice that @{text "s"} itself is essentially the history
+ of events leading to it), such that @{text "Q"} switched
+ from being @{text "False"} to @{text "True"} and kept being @{text "True"}
+ till the last moment of @{text "s"}.
+
+ Suppose a thread @{text "th"} is blocked
+ on @{text "cs1"} and @{text "cs2"} in some state @{text "s"},
+ since no thread is blocked at the very beginning, by applying
+ @{text "p_split"} to these two blocking facts, there exist
+ two moments @{text "t1"} and @{text "t2"} in @{text "s"}, such that
+ @{text "th"} got blocked on @{text "cs1"} and @{text "cs2"}
+ and kept on blocked on them respectively ever since.
+
+ Without lost of generality, we assume @{text "t1"} is earlier than @{text "t2"}.
+ However, since @{text "th"} was blocked ever since memonent @{text "t1"}, so it was still
+ in blocked state at moment @{text "t2"} and could not
+ make any request and get blocked the second time: Contradiction.
+*}
+
+lemma waiting_unique_pre: (* ccc *)
+ assumes h11: "thread \<in> set (wq s cs1)"
+ and h12: "thread \<noteq> hd (wq s cs1)"
+ assumes h21: "thread \<in> set (wq s cs2)"
+ and h22: "thread \<noteq> hd (wq s cs2)"
+ and neq12: "cs1 \<noteq> cs2"
+ shows "False"
+proof -
+ let "?Q" = "\<lambda> cs s. thread \<in> set (wq s cs) \<and> thread \<noteq> hd (wq s cs)"
+ from h11 and h12 have q1: "?Q cs1 s" by simp
+ from h21 and h22 have q2: "?Q cs2 s" by simp
+ have nq1: "\<not> ?Q cs1 []" by (simp add:wq_def)
+ have nq2: "\<not> ?Q cs2 []" by (simp add:wq_def)
+ from p_split [of "?Q cs1", OF q1 nq1]
+ obtain t1 where lt1: "t1 < length s"
+ and np1: "\<not> ?Q cs1 (moment t1 s)"
+ and nn1: "(\<forall>i'>t1. ?Q cs1 (moment i' s))" by auto
+ from p_split [of "?Q cs2", OF q2 nq2]
+ obtain t2 where lt2: "t2 < length s"
+ and np2: "\<not> ?Q cs2 (moment t2 s)"
+ and nn2: "(\<forall>i'>t2. ?Q cs2 (moment i' s))" by auto
+ { fix s cs
+ assume q: "?Q cs s"
+ have "thread \<notin> runing s"
+ proof
+ assume "thread \<in> runing s"
+ hence " \<forall>cs. \<not> (thread \<in> set (wq_fun (schs s) cs) \<and>
+ thread \<noteq> hd (wq_fun (schs s) cs))"
+ by (unfold runing_def s_waiting_def readys_def, auto)
+ from this[rule_format, of cs] q
+ show False by (simp add: wq_def)
+ qed
+ } note q_not_runing = this
+ { fix i1 i2
+ let ?i3 = "Suc i2"
+ assume lt12: "i1 < i2"
+ and "i1 < length s" "i2 < length s"
+ hence le_i3: "?i3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?i3 s = e#moment i2 s" by auto
+ have "i2 < ?i3" by simp
+ from nn2 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t2 s" "e"
+ by (unfold_locales, auto, cases, simp)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre[OF False h1]
+ have "e = P thread cs2" .
+ with vt_e.vt_e have "vt ((P thread cs2)# moment t2 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t2 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t2 s)" by auto
+ with nn1 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ }
+ show ?thesis
+ proof -
+ {
+ assume lt12: "t1 < t2"
+ let ?t3 = "Suc t2"
+ from lt2 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t2 s" by auto
+ have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t2 s" "e"
+ by (unfold_locales, auto, cases, simp)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre[OF False h1]
+ have "e = P thread cs2" .
+ with vt_e.vt_e have "vt ((P thread cs2)# moment t2 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t2 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t2 s)" by auto
+ with nn1 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume lt12: "t2 < t1"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 True eq_th h2 h1
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have "e = P thread cs1" .
+ with vt_e.vt_e have "vt ((P thread cs1)# moment t1 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t1 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t1 s)" by auto
+ with nn2 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume eqt12: "t1 = t2"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have vt_e: "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have eq_e1: "e = P thread cs1" .
+ have lt_t3: "t1 < ?t3" by simp
+ with eqt12 have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m and eqt12
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ show ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e and eqt12 have "vt (e#moment t2 s)" by simp
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.abs2 [OF True eq_th h2 h1]
+ show ?thesis .
+ next
+ case False
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment eqt12
+ have "vt (moment (Suc t2) s)" by auto
+ with eq_m eqt12 show ?thesis by simp
+ qed
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.block_pre [OF False h1]
+ have "e = P thread cs2" .
+ with eq_e1 neq12 show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by arith
+ qed
+qed
+
+text {*
+ This lemma is a simple corrolary of @{text "waiting_unique_pre"}.
+*}
+
+lemma waiting_unique:
+ assumes "waiting s th cs1"
+ and "waiting s th cs2"
+ shows "cs1 = cs2"
+using waiting_unique_pre assms
+unfolding wq_def s_waiting_def
+by auto
+
+end
+
+(* not used *)
+text {*
+ Every thread can only be blocked on one critical resource,
+ symmetrically, every critical resource can only be held by one thread.
+ This fact is much more easier according to our definition.
+*}
+lemma held_unique:
+ assumes "holding (s::event list) th1 cs"
+ and "holding s th2 cs"
+ shows "th1 = th2"
+ by (insert assms, unfold s_holding_def, auto)
+
+
+lemma last_set_lt: "th \<in> threads s \<Longrightarrow> last_set th s < length s"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits)
+
+lemma last_set_unique:
+ "\<lbrakk>last_set th1 s = last_set th2 s; th1 \<in> threads s; th2 \<in> threads s\<rbrakk>
+ \<Longrightarrow> th1 = th2"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits dest:last_set_lt)
+
+lemma preced_unique :
+ assumes pcd_eq: "preced th1 s = preced th2 s"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "th1 = th2"
+proof -
+ from pcd_eq have "last_set th1 s = last_set th2 s" by (simp add:preced_def)
+ from last_set_unique [OF this th_in1 th_in2]
+ show ?thesis .
+qed
+
+lemma preced_linorder:
+ assumes neq_12: "th1 \<noteq> th2"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "preced th1 s < preced th2 s \<or> preced th1 s > preced th2 s"
+proof -
+ from preced_unique [OF _ th_in1 th_in2] and neq_12
+ have "preced th1 s \<noteq> preced th2 s" by auto
+ thus ?thesis by auto
+qed
+
+(* An aux lemma used later *)
+lemma unique_minus:
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz and neq show ?thesis
+ proof(induct)
+ case (base ya)
+ have "(x, ya) \<in> r" by fact
+ from unique [OF xy this] have "y = ya" .
+ with base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from step True show ?thesis by simp
+ next
+ case False
+ from step False
+ show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_base:
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz neq_yz show ?thesis
+ proof(induct)
+ case (base ya)
+ from xy unique base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step
+ have "(y, ya) \<in> r\<^sup>+" by auto
+ with step show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_chain:
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r^+"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+ \<or> (z, y) \<in> r^+"
+proof -
+ from xy xz neq_yz show ?thesis
+ proof(induct)
+ case (base y)
+ have h1: "(x, y) \<in> r" and h2: "(x, z) \<in> r\<^sup>+" and h3: "y \<noteq> z" using base by auto
+ from unique_base [OF _ h1 h2 h3] and unique show ?case by auto
+ next
+ case (step y za)
+ show ?case
+ proof(cases "y = z")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step have "(y, z) \<in> r\<^sup>+ \<or> (z, y) \<in> r\<^sup>+" by auto
+ thus ?thesis
+ proof
+ assume "(z, y) \<in> r\<^sup>+"
+ with step have "(z, za) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ next
+ assume h: "(y, z) \<in> r\<^sup>+"
+ from step have yza: "(y, za) \<in> r" by simp
+ from step have "za \<noteq> z" by simp
+ from unique_minus [OF _ yza h this] and unique
+ have "(za, z) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ qed
+ qed
+ qed
+qed
+
+text {*
+ The following three lemmas show that @{text "RAG"} does not change
+ by the happening of @{text "Set"}, @{text "Create"} and @{text "Exit"}
+ events, respectively.
+*}
+
+lemma RAG_set_unchanged: "(RAG (Set th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_create_unchanged: "(RAG (Create th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_exit_unchanged: "(RAG (Exit th # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+
+text {*
+ The following lemmas are used in the proof of
+ lemma @{text "step_RAG_v"}, which characterizes how the @{text "RAG"} is changed
+ by @{text "V"}-events.
+ However, since our model is very concise, such seemingly obvious lemmas need to be derived from scratch,
+ starting from the model definitions.
+*}
+lemma step_v_hold_inv[elim_format]:
+ "\<And>c t. \<lbrakk>vt (V th cs # s);
+ \<not> holding (wq s) t c; holding (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow>
+ next_th s th cs t \<and> c = cs"
+proof -
+ fix c t
+ assume vt: "vt (V th cs # s)"
+ and nhd: "\<not> holding (wq s) t c"
+ and hd: "holding (wq (V th cs # s)) t c"
+ show "next_th s th cs t \<and> c = cs"
+ proof(cases "c = cs")
+ case False
+ with nhd hd show ?thesis
+ by (unfold cs_holding_def wq_def, auto simp:Let_def)
+ next
+ case True
+ with step_back_step [OF vt]
+ have "step s (V th c)" by simp
+ hence "next_th s th cs t"
+ proof(cases)
+ assume "holding s th c"
+ with nhd hd show ?thesis
+ apply (unfold s_holding_def cs_holding_def wq_def next_th_def,
+ auto simp:Let_def split:list.splits if_splits)
+ proof -
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ next
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ qed
+ qed
+ with True show ?thesis by auto
+ qed
+qed
+
+text {*
+ The following @{text "step_v_wait_inv"} is also an obvious lemma, which, however, needs to be
+ derived from scratch, which confirms the correctness of the definition of @{text "next_th"}.
+*}
+lemma step_v_wait_inv[elim_format]:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); \<not> waiting (wq (V th cs # s)) t c; waiting (wq s) t c
+ \<rbrakk>
+ \<Longrightarrow> (next_th s th cs t \<and> cs = c)"
+proof -
+ fix t c
+ assume vt: "vt (V th cs # s)"
+ and nw: "\<not> waiting (wq (V th cs # s)) t c"
+ and wt: "waiting (wq s) t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp)
+ show "next_th s th cs t \<and> cs = c"
+ proof(cases "cs = c")
+ case False
+ with nw wt show ?thesis
+ by (auto simp:cs_waiting_def wq_def Let_def)
+ next
+ case True
+ from nw[folded True] wt[folded True]
+ have "next_th s th cs t"
+ apply (unfold next_th_def, auto simp:cs_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "a = th" by auto
+ next
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "t = hd (SOME q. distinct q \<and> set q = set list)" by auto
+ next
+ fix a list
+ assume eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step[OF vt]
+ show "a = th"
+ proof(cases)
+ assume "holding s th cs"
+ with eq_wq show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+ with True show ?thesis by simp
+ qed
+qed
+
+lemma step_v_not_wait[consumes 3]:
+ "\<lbrakk>vt (V th cs # s); next_th s th cs t; waiting (wq (V th cs # s)) t cs\<rbrakk> \<Longrightarrow> False"
+ by (unfold next_th_def cs_waiting_def wq_def, auto simp:Let_def)
+
+lemma step_v_release:
+ "\<lbrakk>vt (V th cs # s); holding (wq (V th cs # s)) th cs\<rbrakk> \<Longrightarrow> False"
+proof -
+ assume vt: "vt (V th cs # s)"
+ and hd: "holding (wq (V th cs # s)) th cs"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ from step_back_step [OF vt] and hd
+ show "False"
+ proof(cases)
+ assume "holding (wq (V th cs # s)) th cs" and "holding s th cs"
+ thus ?thesis
+ apply (unfold s_holding_def wq_def cs_holding_def)
+ apply (auto simp:Let_def split:list.splits)
+ proof -
+ fix list
+ assume eq_wq[folded wq_def]:
+ "wq_fun (schs s) cs = hd (SOME q. distinct q \<and> set q = set list) # list"
+ and hd_in: "hd (SOME q. distinct q \<and> set q = set list)
+ \<in> set (SOME q. distinct q \<and> set q = set list)"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ moreover have "distinct (hd (SOME q. distinct q \<and> set q = set list) # list)"
+ proof -
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show ?thesis by auto
+ qed
+ moreover note eq_wq and hd_in
+ ultimately show "False" by auto
+ qed
+ qed
+qed
+
+lemma step_v_get_hold:
+ "\<And>th'. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) th' cs; next_th s th cs th'\<rbrakk> \<Longrightarrow> False"
+ apply (unfold cs_holding_def next_th_def wq_def,
+ auto simp:Let_def)
+proof -
+ fix rest
+ assume vt: "vt (V th cs # s)"
+ and eq_wq[folded wq_def]: " wq_fun (schs s) cs = th # rest"
+ and nrest: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest)
+ \<notin> set (SOME q. distinct q \<and> set q = set rest)"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ hence "set x = set rest" by auto
+ with nrest
+ show "x \<noteq> []" by (case_tac x, auto)
+ qed
+ with ni show "False" by auto
+qed
+
+lemma step_v_release_inv[elim_format]:
+"\<And>c t. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) t c; holding (wq s) t c\<rbrakk> \<Longrightarrow>
+ c = cs \<and> t = th"
+ apply (unfold cs_holding_def wq_def, auto simp:Let_def split:if_splits list.splits)
+ proof -
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ next
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+
+lemma step_v_waiting_mono:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); waiting (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow> waiting (wq s) t c"
+proof -
+ fix t c
+ let ?s' = "(V th cs # s)"
+ assume vt: "vt ?s'"
+ and wt: "waiting (wq ?s') t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ show "waiting (wq s) t c"
+ proof(cases "c = cs")
+ case False
+ assume neq_cs: "c \<noteq> cs"
+ hence "waiting (wq ?s') t c = waiting (wq s) t c"
+ by (unfold cs_waiting_def wq_def, auto simp:Let_def)
+ with wt show ?thesis by simp
+ next
+ case True
+ with wt show ?thesis
+ apply (unfold cs_waiting_def wq_def, auto simp:Let_def split:list.splits)
+ proof -
+ fix a list
+ assume not_in: "t \<notin> set list"
+ and is_in: "t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ with not_in is_in show "t = a" by auto
+ next
+ fix list
+ assume is_waiting: "waiting (wq (V th cs # s)) t cs"
+ and eq_wq: "wq_fun (schs s) cs = t # list"
+ hence "t \<in> set list"
+ apply (unfold wq_def, auto simp:Let_def cs_waiting_def)
+ proof -
+ assume " t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ moreover have "\<dots> = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ ultimately show "t \<in> set list" by simp
+ qed
+ with eq_wq and vt_v.wq_distinct [of cs, unfolded wq_def]
+ show False by auto
+ qed
+ qed
+qed
+
+text {* (* ddd *)
+ The following @{text "step_RAG_v"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "V"}-events:
+*}
+lemma step_RAG_v:
+assumes vt:
+ "vt (V th cs#s)"
+shows "
+ RAG (V th cs # s) =
+ RAG s - {(Cs cs, Th th)} -
+ {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ apply (insert vt, unfold s_RAG_def)
+ apply (auto split:if_splits list.splits simp:Let_def)
+ apply (auto elim: step_v_waiting_mono step_v_hold_inv
+ step_v_release step_v_wait_inv
+ step_v_get_hold step_v_release_inv)
+ apply (erule_tac step_v_not_wait, auto)
+ done
+
+text {*
+ The following @{text "step_RAG_p"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "P"}-events:
+*}
+lemma step_RAG_p:
+ "vt (P th cs#s) \<Longrightarrow>
+ RAG (P th cs # s) = (if (wq s cs = []) then RAG s \<union> {(Cs cs, Th th)}
+ else RAG s \<union> {(Th th, Cs cs)})"
+ apply(simp only: s_RAG_def wq_def)
+ apply (auto split:list.splits prod.splits simp:Let_def wq_def cs_waiting_def cs_holding_def)
+ apply(case_tac "csa = cs", auto)
+ apply(fold wq_def)
+ apply(drule_tac step_back_step)
+ apply(ind_cases " step s (P (hd (wq s cs)) cs)")
+ apply(simp add:s_RAG_def wq_def cs_holding_def)
+ apply(auto)
+ done
+
+
+lemma RAG_target_th: "(Th th, x) \<in> RAG (s::state) \<Longrightarrow> \<exists> cs. x = Cs cs"
+ by (unfold s_RAG_def, auto)
+
+context valid_trace
+begin
+
+text {*
+ The following lemma shows that @{text "RAG"} is acyclic.
+ The overall structure is by induction on the formation of @{text "vt s"}
+ and then case analysis on event @{text "e"}, where the non-trivial cases
+ for those for @{text "V"} and @{text "P"} events.
+*}
+lemma acyclic_RAG:
+ shows "acyclic (RAG s)"
+using vt
+proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "acyclic (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de:
+ "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ from ih have ac: "acyclic (?A - ?B - ?C)" by (auto elim:acyclic_subset)
+ from step_back_step [OF vtt]
+ have "step s (V th cs)" .
+ thus ?thesis
+ proof(cases)
+ assume "holding s th cs"
+ hence th_in: "th \<in> set (wq s cs)" and
+ eq_hd: "th = hd (wq s cs)" unfolding s_holding_def wq_def by auto
+ then obtain rest where
+ eq_wq: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ show ?thesis
+ proof(cases "rest = []")
+ case False
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ from eq_wq False have eq_D: "?D = {(Cs cs, Th ?th')}"
+ by (unfold next_th_def, auto)
+ let ?E = "(?A - ?B - ?C)"
+ have "(Th ?th', Cs cs) \<notin> ?E\<^sup>*"
+ proof
+ assume "(Th ?th', Cs cs) \<in> ?E\<^sup>*"
+ hence " (Th ?th', Cs cs) \<in> ?E\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD [OF this]
+ obtain x where th'_e: "(Th ?th', x) \<in> ?E" by blast
+ hence th_d: "(Th ?th', x) \<in> ?A" by simp
+ from RAG_target_th [OF this]
+ obtain cs' where eq_x: "x = Cs cs'" by auto
+ with th_d have "(Th ?th', Cs cs') \<in> ?A" by simp
+ hence wt_th': "waiting s ?th' cs'"
+ unfolding s_RAG_def s_waiting_def cs_waiting_def wq_def by simp
+ hence "cs' = cs"
+ proof(rule vt_s.waiting_unique)
+ from eq_wq vt_s.wq_distinct[of cs]
+ show "waiting s ?th' cs"
+ apply (unfold s_waiting_def wq_def, auto)
+ proof -
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq_fun (schs s) cs = th # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show "hd (SOME q. distinct q \<and> set q = set rest) = th" by auto
+ next
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = hd (SOME q. distinct q \<and> set q = set rest) # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show False by auto
+ qed
+ qed
+ with th'_e eq_x have "(Th ?th', Cs cs) \<in> ?E" by simp
+ with False
+ show "False" by (auto simp: next_th_def eq_wq)
+ qed
+ with acyclic_insert[symmetric] and ac
+ and eq_de eq_D show ?thesis by auto
+ next
+ case True
+ with eq_wq
+ have eq_D: "?D = {}"
+ by (unfold next_th_def, auto)
+ with eq_de ac
+ show ?thesis by auto
+ qed
+ qed
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "acyclic ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ have "(Th th, Cs cs) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Th th, Cs cs) \<in> (RAG s)\<^sup>*"
+ hence "(Th th, Cs cs) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD2 [OF this]
+ obtain x where "(x, Cs cs) \<in> RAG s" by auto
+ with True show False by (auto simp:s_RAG_def cs_waiting_def)
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ next
+ case False
+ hence eq_r: "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ have "(Cs cs, Th th) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Cs cs, Th th) \<in> (RAG s)\<^sup>*"
+ hence "(Cs cs, Th th) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ moreover from step_back_step [OF vtt] have "step s (P th cs)" .
+ ultimately show False
+ proof -
+ show " \<lbrakk>(Cs cs, Th th) \<in> (RAG s)\<^sup>+; step s (P th cs)\<rbrakk> \<Longrightarrow> False"
+ by (ind_cases "step s (P th cs)", simp)
+ qed
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (Set thread prio)
+ with ih
+ thm RAG_set_unchanged
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "acyclic (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+qed
+
+
+lemma finite_RAG:
+ shows "finite (RAG s)"
+proof -
+ from vt show ?thesis
+ proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "finite (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de: "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}
+"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ moreover from ih have ac: "finite (?A - ?B - ?C)" by simp
+ moreover have "finite ?D"
+ proof -
+ have "?D = {} \<or> (\<exists> a. ?D = {a})"
+ by (unfold next_th_def, auto)
+ thus ?thesis
+ proof
+ assume h: "?D = {}"
+ show ?thesis by (unfold h, simp)
+ next
+ assume "\<exists> a. ?D = {a}"
+ thus ?thesis
+ by (metis finite.simps)
+ qed
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "finite ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ with True and ih show ?thesis by auto
+ next
+ case False
+ hence "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ with False and ih show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ next
+ case (Set thread prio)
+ with ih
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "finite (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+ qed
+qed
+
+text {* Several useful lemmas *}
+
+lemma wf_dep_converse:
+ shows "wf ((RAG s)^-1)"
+proof(rule finite_acyclic_wf_converse)
+ from finite_RAG
+ show "finite (RAG s)" .
+next
+ from acyclic_RAG
+ show "acyclic (RAG s)" .
+qed
+
+end
+
+lemma hd_np_in: "x \<in> set l \<Longrightarrow> hd l \<in> set l"
+ by (induct l, auto)
+
+lemma th_chasing: "(Th th, Cs cs) \<in> RAG (s::state) \<Longrightarrow> \<exists> th'. (Cs cs, Th th') \<in> RAG s"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+
+context valid_trace
+begin
+
+lemma wq_threads:
+ assumes h: "th \<in> set (wq s cs)"
+ shows "th \<in> threads s"
+proof -
+ from vt and h show ?thesis
+ proof(induct arbitrary: th cs)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s
+ using vt_cons(1) by (unfold_locales, auto)
+ assume ih: "\<And>th cs. th \<in> set (wq s cs) \<Longrightarrow> th \<in> threads s"
+ and stp: "step s e"
+ and vt: "vt s"
+ and h: "th \<in> set (wq (e # s) cs)"
+ show ?case
+ proof(cases e)
+ case (Create th' prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ next
+ case (Exit th')
+ with stp ih h show ?thesis
+ apply (auto simp:wq_def Let_def)
+ apply (ind_cases "step s (Exit th')")
+ apply (auto simp:runing_def readys_def s_holding_def s_waiting_def holdents_def
+ s_RAG_def s_holding_def cs_holding_def)
+ done
+ next
+ case (V th' cs')
+ show ?thesis
+ proof(cases "cs' = cs")
+ case False
+ with h
+ show ?thesis
+ apply(unfold wq_def V, auto simp:Let_def V split:prod.splits, fold wq_def)
+ by (drule_tac ih, simp)
+ next
+ case True
+ from h
+ show ?thesis
+ proof(unfold V wq_def)
+ assume th_in: "th \<in> set (wq_fun (schs (V th' cs' # s)) cs)" (is "th \<in> set ?l")
+ show "th \<in> threads (V th' cs' # s)"
+ proof(cases "cs = cs'")
+ case False
+ hence "?l = wq_fun (schs s) cs" by (simp add:Let_def)
+ with th_in have " th \<in> set (wq s cs)"
+ by (fold wq_def, simp)
+ from ih [OF this] show ?thesis by simp
+ next
+ case True
+ show ?thesis
+ proof(cases "wq_fun (schs s) cs'")
+ case Nil
+ with h V show ?thesis
+ apply (auto simp:wq_def Let_def split:if_splits)
+ by (fold wq_def, drule_tac ih, simp)
+ next
+ case (Cons a rest)
+ assume eq_wq: "wq_fun (schs s) cs' = a # rest"
+ with h V show ?thesis
+ apply (auto simp:Let_def wq_def split:if_splits)
+ proof -
+ assume th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs'] and eq_wq[folded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ with eq_wq th_in have "th \<in> set (wq_fun (schs s) cs')" by auto
+ from ih[OF this[folded wq_def]] show "th \<in> threads s" .
+ next
+ assume th_in: "th \<in> set (wq_fun (schs s) cs)"
+ from ih[OF this[folded wq_def]]
+ show "th \<in> threads s" .
+ qed
+ qed
+ qed
+ qed
+ qed
+ next
+ case (P th' cs')
+ from h stp
+ show ?thesis
+ apply (unfold P wq_def)
+ apply (auto simp:Let_def split:if_splits, fold wq_def)
+ apply (auto intro:ih)
+ apply(ind_cases "step s (P th' cs')")
+ by (unfold runing_def readys_def, auto)
+ next
+ case (Set thread prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ qed
+ next
+ case vt_nil
+ thus ?case by (auto simp:wq_def)
+ qed
+qed
+
+lemma range_in: "\<lbrakk>(Th th) \<in> Range (RAG (s::state))\<rbrakk> \<Longrightarrow> th \<in> threads s"
+ apply(unfold s_RAG_def cs_waiting_def cs_holding_def)
+ by (auto intro:wq_threads)
+
+lemma readys_v_eq:
+ assumes neq_th: "th \<noteq> thread"
+ and eq_wq: "wq s cs = thread#rest"
+ and not_in: "th \<notin> set rest"
+ shows "(th \<in> readys (V thread cs#s)) = (th \<in> readys s)"
+proof -
+ from assms show ?thesis
+ apply (auto simp:readys_def)
+ apply(simp add:s_waiting_def[folded wq_def])
+ apply (erule_tac x = csa in allE)
+ apply (simp add:s_waiting_def wq_def Let_def split:if_splits)
+ apply (case_tac "csa = cs", simp)
+ apply (erule_tac x = cs in allE)
+ apply(auto simp add: s_waiting_def[folded wq_def] Let_def split: list.splits)
+ apply(auto simp add: wq_def)
+ apply (auto simp:s_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ assume th_nin: "th \<notin> set rest"
+ and th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ and eq_wq: "wq_fun (schs s) cs = thread # rest"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from wq_distinct[of cs, unfolded wq_def] and eq_wq[unfolded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ with th_nin th_in show False by auto
+ qed
+qed
+
+text {* \noindent
+ The following lemmas shows that: starting from any node in @{text "RAG"},
+ by chasing out-going edges, it is always possible to reach a node representing a ready
+ thread. In this lemma, it is the @{text "th'"}.
+*}
+
+lemma chain_building:
+ shows "node \<in> Domain (RAG s) \<longrightarrow> (\<exists> th'. th' \<in> readys s \<and> (node, Th th') \<in> (RAG s)^+)"
+proof -
+ from wf_dep_converse
+ have h: "wf ((RAG s)\<inverse>)" .
+ show ?thesis
+ proof(induct rule:wf_induct [OF h])
+ fix x
+ assume ih [rule_format]:
+ "\<forall>y. (y, x) \<in> (RAG s)\<inverse> \<longrightarrow>
+ y \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (y, Th th') \<in> (RAG s)\<^sup>+)"
+ show "x \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+)"
+ proof
+ assume x_d: "x \<in> Domain (RAG s)"
+ show "\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+"
+ proof(cases x)
+ case (Th th)
+ from x_d Th obtain cs where x_in: "(Th th, Cs cs) \<in> RAG s" by (auto simp:s_RAG_def)
+ with Th have x_in_r: "(Cs cs, x) \<in> (RAG s)^-1" by simp
+ from th_chasing [OF x_in] obtain th' where "(Cs cs, Th th') \<in> RAG s" by blast
+ hence "Cs cs \<in> Domain (RAG s)" by auto
+ from ih [OF x_in_r this] obtain th'
+ where th'_ready: " th' \<in> readys s" and cs_in: "(Cs cs, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "(x, Th th') \<in> (RAG s)\<^sup>+" using Th x_in cs_in by auto
+ with th'_ready show ?thesis by auto
+ next
+ case (Cs cs)
+ from x_d Cs obtain th' where th'_d: "(Th th', x) \<in> (RAG s)^-1" by (auto simp:s_RAG_def)
+ show ?thesis
+ proof(cases "th' \<in> readys s")
+ case True
+ from True and th'_d show ?thesis by auto
+ next
+ case False
+ from th'_d and range_in have "th' \<in> threads s" by auto
+ with False have "Th th' \<in> Domain (RAG s)"
+ by (auto simp:readys_def wq_def s_waiting_def s_RAG_def cs_waiting_def Domain_def)
+ from ih [OF th'_d this]
+ obtain th'' where
+ th''_r: "th'' \<in> readys s" and
+ th''_in: "(Th th', Th th'') \<in> (RAG s)\<^sup>+" by auto
+ from th'_d and th''_in
+ have "(x, Th th'') \<in> (RAG s)\<^sup>+" by auto
+ with th''_r show ?thesis by auto
+ qed
+ qed
+ qed
+ qed
+qed
+
+text {* \noindent
+ The following is just an instance of @{text "chain_building"}.
+*}
+lemma th_chain_to_ready:
+ assumes th_in: "th \<in> threads s"
+ shows "th \<in> readys s \<or> (\<exists> th'. th' \<in> readys s \<and> (Th th, Th th') \<in> (RAG s)^+)"
+proof(cases "th \<in> readys s")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ from False and th_in have "Th th \<in> Domain (RAG s)"
+ by (auto simp:readys_def s_waiting_def s_RAG_def wq_def cs_waiting_def Domain_def)
+ from chain_building [rule_format, OF this]
+ show ?thesis by auto
+qed
+
+end
+
+lemma waiting_eq: "waiting s th cs = waiting (wq s) th cs"
+ by (unfold s_waiting_def cs_waiting_def wq_def, auto)
+
+lemma holding_eq: "holding (s::state) th cs = holding (wq s) th cs"
+ by (unfold s_holding_def wq_def cs_holding_def, simp)
+
+lemma holding_unique: "\<lbrakk>holding (s::state) th1 cs; holding s th2 cs\<rbrakk> \<Longrightarrow> th1 = th2"
+ by (unfold s_holding_def cs_holding_def, auto)
+
+context valid_trace
+begin
+
+lemma unique_RAG: "\<lbrakk>(n, n1) \<in> RAG s; (n, n2) \<in> RAG s\<rbrakk> \<Longrightarrow> n1 = n2"
+ apply(unfold s_RAG_def, auto, fold waiting_eq holding_eq)
+ by(auto elim:waiting_unique holding_unique)
+
+end
+
+
+lemma trancl_split: "(a, b) \<in> r^+ \<Longrightarrow> \<exists> c. (a, c) \<in> r"
+by (induct rule:trancl_induct, auto)
+
+context valid_trace
+begin
+
+lemma dchain_unique:
+ assumes th1_d: "(n, Th th1) \<in> (RAG s)^+"
+ and th1_r: "th1 \<in> readys s"
+ and th2_d: "(n, Th th2) \<in> (RAG s)^+"
+ and th2_r: "th2 \<in> readys s"
+ shows "th1 = th2"
+proof -
+ { assume neq: "th1 \<noteq> th2"
+ hence "Th th1 \<noteq> Th th2" by simp
+ from unique_chain [OF _ th1_d th2_d this] and unique_RAG
+ have "(Th th1, Th th2) \<in> (RAG s)\<^sup>+ \<or> (Th th2, Th th1) \<in> (RAG s)\<^sup>+" by auto
+ hence "False"
+ proof
+ assume "(Th th1, Th th2) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th1, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th1 \<notin> readys s"
+ by (auto simp:readys_def s_RAG_def wq_def s_waiting_def cs_waiting_def)
+ with th1_r show ?thesis by auto
+ next
+ assume "(Th th2, Th th1) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th2, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th2 \<notin> readys s"
+ by (auto simp:readys_def wq_def s_RAG_def s_waiting_def cs_waiting_def)
+ with th2_r show ?thesis by auto
+ qed
+ } thus ?thesis by auto
+qed
+
+end
+
+
+lemma step_holdents_p_add:
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs = []"
+ shows "holdents (P th cs#s) th = holdents s th \<union> {cs}"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by (auto)
+qed
+
+lemma step_holdents_p_eq:
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs \<noteq> []"
+ shows "holdents (P th cs#s) th = holdents s th"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by auto
+qed
+
+
+lemma (in valid_trace) finite_holding :
+ shows "finite (holdents s th)"
+proof -
+ let ?F = "\<lambda> (x, y). the_cs x"
+ from finite_RAG
+ have "finite (RAG s)" .
+ hence "finite (?F `(RAG s))" by simp
+ moreover have "{cs . (Cs cs, Th th) \<in> RAG s} \<subseteq> \<dots>"
+ proof -
+ { have h: "\<And> a A f. a \<in> A \<Longrightarrow> f a \<in> f ` A" by auto
+ fix x assume "(Cs x, Th th) \<in> RAG s"
+ hence "?F (Cs x, Th th) \<in> ?F `(RAG s)" by (rule h)
+ moreover have "?F (Cs x, Th th) = x" by simp
+ ultimately have "x \<in> (\<lambda>(x, y). the_cs x) ` RAG s" by simp
+ } thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (unfold holdents_test, auto intro:finite_subset)
+qed
+
+lemma cntCS_v_dec:
+ assumes vtv: "vt (V thread cs#s)"
+ shows "(cntCS (V thread cs#s) thread + 1) = cntCS s thread"
+proof -
+ from vtv interpret vt_s: valid_trace s
+ by (cases, unfold_locales, simp)
+ from vtv interpret vt_v: valid_trace "V thread cs#s"
+ by (unfold_locales, simp)
+ from step_back_step[OF vtv]
+ have cs_in: "cs \<in> holdents s thread"
+ apply (cases, unfold holdents_test s_RAG_def, simp)
+ by (unfold cs_holding_def s_holding_def wq_def, auto)
+ moreover have cs_not_in:
+ "(holdents (V thread cs#s) thread) = holdents s thread - {cs}"
+ apply (insert vt_s.wq_distinct[of cs])
+ apply (unfold holdents_test, unfold step_RAG_v[OF vtv],
+ auto simp:next_th_def)
+ proof -
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately
+ show "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ next
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately show "False" by auto
+ qed
+ ultimately
+ have "holdents s thread = insert cs (holdents (V thread cs#s) thread)"
+ by auto
+ moreover have "card \<dots> =
+ Suc (card ((holdents (V thread cs#s) thread) - {cs}))"
+ proof(rule card_insert)
+ from vt_v.finite_holding
+ show " finite (holdents (V thread cs # s) thread)" .
+ qed
+ moreover from cs_not_in
+ have "cs \<notin> (holdents (V thread cs#s) thread)" by auto
+ ultimately show ?thesis by (simp add:cntCS_def)
+qed
+
+lemma count_rec1 [simp]:
+ assumes "Q e"
+ shows "count Q (e#es) = Suc (count Q es)"
+ using assms
+ by (unfold count_def, auto)
+
+lemma count_rec2 [simp]:
+ assumes "\<not>Q e"
+ shows "count Q (e#es) = (count Q es)"
+ using assms
+ by (unfold count_def, auto)
+
+lemma count_rec3 [simp]:
+ shows "count Q [] = 0"
+ by (unfold count_def, auto)
+
+lemma cntP_diff_inv:
+ assumes "cntP (e#s) th \<noteq> cntP s th"
+ shows "isP e \<and> actor e = th"
+proof(cases e)
+ case (P th' pty)
+ show ?thesis
+ by (cases "(\<lambda>e. \<exists>cs. e = P th cs) (P th' pty)",
+ insert assms P, auto simp:cntP_def)
+qed (insert assms, auto simp:cntP_def)
+
+lemma cntV_diff_inv:
+ assumes "cntV (e#s) th \<noteq> cntV s th"
+ shows "isV e \<and> actor e = th"
+proof(cases e)
+ case (V th' pty)
+ show ?thesis
+ by (cases "(\<lambda>e. \<exists>cs. e = V th cs) (V th' pty)",
+ insert assms V, auto simp:cntV_def)
+qed (insert assms, auto simp:cntV_def)
+
+context valid_trace
+begin
+
+text {* (* ddd *) \noindent
+ The relationship between @{text "cntP"}, @{text "cntV"} and @{text "cntCS"}
+ of one particular thread.
+*}
+
+lemma cnp_cnv_cncs:
+ shows "cntP s th = cntV s th + (if (th \<in> readys s \<or> th \<notin> threads s)
+ then cntCS s th else cntCS s th + 1)"
+proof -
+ from vt show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1) by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. cntP s th = cntV s th +
+ (if (th \<in> readys s \<or> th \<notin> threads s) then cntCS s th else cntCS s th + 1)"
+ and stp: "step s e"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in: "thread \<notin> threads s"
+ show ?thesis
+ proof -
+ { fix cs
+ assume "thread \<in> set (wq s cs)"
+ from vt_s.wq_threads [OF this] have "thread \<in> threads s" .
+ with not_in have "False" by simp
+ } with eq_e have eq_readys: "readys (e#s) = readys s \<union> {thread}"
+ by (auto simp:readys_def threads.simps s_waiting_def
+ wq_def cs_waiting_def Let_def)
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_create_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih not_in
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with not_in ih have " cntP s th = cntV s th + cntCS s th" by simp
+ moreover from eq_th and eq_readys have "th \<in> readys (e#s)" by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and is_runing: "thread \<in> runing s"
+ and no_hold: "holdents s thread = {}"
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_exit_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ apply (simp add:threads.simps readys_def)
+ apply (subst s_waiting_def)
+ apply (simp add:Let_def)
+ apply (subst s_waiting_def, simp)
+ done
+ with eq_cnp eq_cnv eq_cncs ih
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with ih is_runing have " cntP s th = cntV s th + cntCS s th"
+ by (simp add:runing_def)
+ moreover from eq_th eq_e have "th \<notin> threads (e#s)"
+ by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ and no_dep: "(Cs cs, Th thread) \<notin> (RAG s)\<^sup>+"
+ from thread_P vt stp ih have vtp: "vt (P thread cs#s)" by auto
+ then interpret vt_p: valid_trace "(P thread cs#s)"
+ by (unfold_locales, simp)
+ show ?thesis
+ proof -
+ { have hh: "\<And> A B C. (B = C) \<Longrightarrow> (A \<and> B) = (A \<and> C)" by blast
+ assume neq_th: "th \<noteq> thread"
+ with eq_e
+ have eq_readys: "(th \<in> readys (e#s)) = (th \<in> readys (s))"
+ apply (simp add:readys_def s_waiting_def wq_def Let_def)
+ apply (rule_tac hh)
+ apply (intro iffI allI, clarify)
+ apply (erule_tac x = csa in allE, auto)
+ apply (subgoal_tac "wq_fun (schs s) cs \<noteq> []", auto)
+ apply (erule_tac x = cs in allE, auto)
+ by (case_tac "(wq_fun (schs s) cs)", auto)
+ moreover from neq_th eq_e have "cntCS (e # s) th = cntCS s th"
+ apply (simp add:cntCS_def holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto)
+ moreover from eq_e neq_th have "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ moreover from eq_e neq_th have "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ moreover from eq_e neq_th have "threads (e#s) = threads s" by simp
+ moreover note ih [of th]
+ ultimately have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ have ?thesis
+ proof -
+ from eq_e eq_th have eq_cnp: "cntP (e # s) th = 1 + (cntP s th)"
+ by (simp add:cntP_def count_def)
+ from eq_e eq_th have eq_cnv: "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ show ?thesis
+ proof (cases "wq s cs = []")
+ case True
+ with is_runing
+ have "th \<in> readys (e#s)"
+ apply (unfold eq_e wq_def, unfold readys_def s_RAG_def)
+ apply (simp add: wq_def[symmetric] runing_def eq_th s_waiting_def)
+ by (auto simp:readys_def wq_def Let_def s_waiting_def wq_def)
+ moreover have "cntCS (e # s) th = 1 + cntCS s th"
+ proof -
+ have "card {csa. csa = cs \<or> (Cs csa, Th thread) \<in> RAG s} =
+ Suc (card {cs. (Cs cs, Th thread) \<in> RAG s})" (is "card ?L = Suc (card ?R)")
+ proof -
+ have "?L = insert cs ?R" by auto
+ moreover have "card \<dots> = Suc (card (?R - {cs}))"
+ proof(rule card_insert)
+ from vt_s.finite_holding [of thread]
+ show " finite {cs. (Cs cs, Th thread) \<in> RAG s}"
+ by (unfold holdents_test, simp)
+ qed
+ moreover have "?R - {cs} = ?R"
+ proof -
+ have "cs \<notin> ?R"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th thread) \<in> RAG s}"
+ with no_dep show False by auto
+ qed
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ thus ?thesis
+ apply (unfold eq_e eq_th cntCS_def)
+ apply (simp add: holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto simp:True)
+ qed
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ moreover note eq_cnp eq_cnv ih [of th]
+ ultimately show ?thesis by auto
+ next
+ case False
+ have eq_wq: "wq (e#s) cs = wq s cs @ [th]"
+ by (unfold eq_th eq_e wq_def, auto simp:Let_def)
+ have "th \<notin> readys (e#s)"
+ proof
+ assume "th \<in> readys (e#s)"
+ hence "\<forall>cs. \<not> waiting (e # s) th cs" by (simp add:readys_def)
+ from this[rule_format, of cs] have " \<not> waiting (e # s) th cs" .
+ hence "th \<in> set (wq (e#s) cs) \<Longrightarrow> th = hd (wq (e#s) cs)"
+ by (simp add:s_waiting_def wq_def)
+ moreover from eq_wq have "th \<in> set (wq (e#s) cs)" by auto
+ ultimately have "th = hd (wq (e#s) cs)" by blast
+ with eq_wq have "th = hd (wq s cs @ [th])" by simp
+ hence "th = hd (wq s cs)" using False by auto
+ with False eq_wq vt_p.wq_distinct [of cs]
+ show False by (fold eq_e, auto)
+ qed
+ moreover from is_runing have "th \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def eq_th)
+ moreover have "cntCS (e # s) th = cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_p[OF vtp])
+ by (auto simp:False)
+ moreover note eq_cnp eq_cnv ih[of th]
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ ultimately show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_V thread cs)
+ from assms vt stp ih thread_V have vtv: "vt (V thread cs # s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs # s)" by (unfold_locales, simp)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ have eq_threads: "threads (e#s) = threads s" by (simp add: eq_e)
+ have eq_set: "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ show ?thesis
+ proof -
+ { assume eq_th: "th = thread"
+ from eq_th have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (unfold eq_e, simp add:cntP_def count_def)
+ moreover from eq_th have eq_cnv: "cntV (e#s) th = 1 + cntV s th"
+ by (unfold eq_e, simp add:cntV_def count_def)
+ moreover from cntCS_v_dec [OF vtv]
+ have "cntCS (e # s) thread + 1 = cntCS s thread"
+ by (simp add:eq_e)
+ moreover from is_runing have rd_before: "thread \<in> readys s"
+ by (unfold runing_def, simp)
+ moreover have "thread \<in> readys (e # s)"
+ proof -
+ from is_runing
+ have "thread \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def)
+ moreover have "\<forall> cs1. \<not> waiting (e#s) thread cs1"
+ proof
+ fix cs1
+ { assume eq_cs: "cs1 = cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from eq_wq
+ have "thread \<notin> set (wq (e#s) cs1)"
+ apply(unfold eq_e wq_def eq_cs s_holding_def)
+ apply (auto simp:Let_def)
+ proof -
+ assume "thread \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ with eq_set have "thread \<in> set rest" by simp
+ with vt_v.wq_distinct[of cs]
+ and eq_wq show False
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ qed
+ thus ?thesis by (simp add:wq_def s_waiting_def)
+ qed
+ } moreover {
+ assume neq_cs: "cs1 \<noteq> cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from wq_v_neq [OF neq_cs[symmetric]]
+ have "wq (V thread cs # s) cs1 = wq s cs1" .
+ moreover have "\<not> waiting s thread cs1"
+ proof -
+ from runing_ready and is_runing
+ have "thread \<in> readys s" by auto
+ thus ?thesis by (simp add:readys_def)
+ qed
+ ultimately show ?thesis
+ by (auto simp:wq_def s_waiting_def eq_e)
+ qed
+ } ultimately show "\<not> waiting (e # s) thread cs1" by blast
+ qed
+ ultimately show ?thesis by (simp add:readys_def)
+ qed
+ moreover note eq_th ih
+ ultimately have ?thesis by auto
+ } moreover {
+ assume neq_th: "th \<noteq> thread"
+ from neq_th eq_e have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ from neq_th eq_e have eq_cnv: "cntV (e # s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ have ?thesis
+ proof(cases "th \<in> set rest")
+ case False
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ apply (insert step_back_vt[OF vtv])
+ by (simp add: False eq_e eq_wq neq_th vt_s.readys_v_eq)
+ moreover have "cntCS (e#s) th = cntCS s th"
+ apply (insert neq_th, unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ proof -
+ have "{csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from False eq_wq
+ have " next_th s thread cs th \<Longrightarrow> (Cs cs, Th th) \<in> RAG s"
+ apply (unfold next_th_def, auto)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = thread # rest"
+ from eq_set ni have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)
+ " by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[ of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with ne show "x \<noteq> []" by auto
+ qed
+ ultimately show
+ "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ qed
+ thus ?thesis by auto
+ qed
+ thus "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ card {cs. (Cs cs, Th th) \<in> RAG s}" by simp
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ assume th_in: "th \<in> set rest"
+ show ?thesis
+ proof(cases "next_th s thread cs th")
+ case False
+ with eq_wq and th_in have
+ neq_hd: "th \<noteq> hd (SOME q. distinct q \<and> set q = set rest)" (is "th \<noteq> hd ?rest")
+ by (auto simp:next_th_def)
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ proof -
+ from eq_wq and th_in
+ have "\<not> th \<in> readys s"
+ apply (auto simp:readys_def s_waiting_def)
+ apply (rule_tac x = cs in exI, auto)
+ by (insert vt_s.wq_distinct[of cs], auto simp add: wq_def)
+ moreover
+ from eq_wq and th_in and neq_hd
+ have "\<not> (th \<in> readys (e # s))"
+ apply (auto simp:readys_def s_waiting_def eq_e wq_def Let_def split:list.splits)
+ by (rule_tac x = cs in exI, auto simp:eq_set)
+ ultimately show ?thesis by auto
+ qed
+ moreover have "cntCS (e#s) th = cntCS s th"
+ proof -
+ from eq_wq and th_in and neq_hd
+ have "(holdents (e # s) th) = (holdents s th)"
+ apply (unfold eq_e step_RAG_v[OF vtv],
+ auto simp:next_th_def eq_set s_RAG_def holdents_test wq_def
+ Let_def cs_holding_def)
+ by (insert vt_s.wq_distinct[of cs], auto simp:wq_def)
+ thus ?thesis by (simp add:cntCS_def)
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ let ?rest = " (SOME q. distinct q \<and> set q = set rest)"
+ let ?t = "hd ?rest"
+ from True eq_wq th_in neq_th
+ have "th \<in> readys (e # s)"
+ apply (auto simp:eq_e readys_def s_waiting_def wq_def
+ Let_def next_th_def)
+ proof -
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ show "?t \<in> threads s"
+ proof(rule vt_s.wq_threads)
+ from eq_wq and t_in
+ show "?t \<in> set (wq s cs)" by (auto simp:wq_def)
+ qed
+ next
+ fix csa
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ and neq_cs: "csa \<noteq> cs"
+ and t_in': "?t \<in> set (wq_fun (schs s) csa)"
+ show "?t = hd (wq_fun (schs s) csa)"
+ proof -
+ { assume neq_hd': "?t \<noteq> hd (wq_fun (schs s) csa)"
+ from vt_s.wq_distinct[of cs] and
+ eq_wq[folded wq_def] and t_in eq_wq
+ have "?t \<noteq> thread" by auto
+ with eq_wq and t_in
+ have w1: "waiting s ?t cs"
+ by (auto simp:s_waiting_def wq_def)
+ from t_in' neq_hd'
+ have w2: "waiting s ?t csa"
+ by (auto simp:s_waiting_def wq_def)
+ from vt_s.waiting_unique[OF w1 w2]
+ and neq_cs have "False" by auto
+ } thus ?thesis by auto
+ qed
+ qed
+ moreover have "cntP s th = cntV s th + cntCS s th + 1"
+ proof -
+ have "th \<notin> readys s"
+ proof -
+ from True eq_wq neq_th th_in
+ show ?thesis
+ apply (unfold readys_def s_waiting_def, auto)
+ by (rule_tac x = cs in exI, auto simp add: wq_def)
+ qed
+ moreover have "th \<in> threads s"
+ proof -
+ from th_in eq_wq
+ have "th \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads [OF this]
+ show ?thesis .
+ qed
+ ultimately show ?thesis using ih by auto
+ qed
+ moreover from True neq_th have "cntCS (e # s) th = 1 + cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_v[OF vtv], auto)
+ proof -
+ show "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs} =
+ Suc (card {cs. (Cs cs, Th th) \<in> RAG s})"
+ (is "card ?A = Suc (card ?B)")
+ proof -
+ have "?A = insert cs ?B" by auto
+ hence "card ?A = card (insert cs ?B)" by simp
+ also have "\<dots> = Suc (card ?B)"
+ proof(rule card_insert_disjoint)
+ have "?B \<subseteq> ((\<lambda> (x, y). the_cs x) ` RAG s)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Cs x, Th th)" in bexI, auto)
+ with vt_s.finite_RAG
+ show "finite {cs. (Cs cs, Th th) \<in> RAG s}" by (auto intro:finite_subset)
+ next
+ show "cs \<notin> {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th th) \<in> RAG s}"
+ hence "(Cs cs, Th th) \<in> RAG s" by simp
+ with True neq_th eq_wq show False
+ by (auto simp:next_th_def s_RAG_def cs_holding_def)
+ qed
+ qed
+ finally show ?thesis .
+ qed
+ qed
+ moreover note eq_cnp eq_cnv
+ ultimately show ?thesis by simp
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_set thread prio)
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ show ?thesis
+ proof -
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_set_unchanged eq_e)
+ from eq_e have eq_readys: "readys (e#s) = readys s"
+ by (simp add:readys_def cs_waiting_def s_waiting_def wq_def,
+ auto simp:Let_def)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih is_runing
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with is_runing ih have " cntP s th = cntV s th + cntCS s th"
+ by (unfold runing_def, auto)
+ moreover from eq_th and eq_readys is_runing have "th \<in> readys (e#s)"
+ by (simp add:runing_def)
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntP_def cntV_def cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+lemma not_thread_cncs:
+ assumes not_in: "th \<notin> threads s"
+ shows "cntCS s th = 0"
+proof -
+ from vt not_in show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e th)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. th \<notin> threads s \<Longrightarrow> cntCS s th = 0"
+ and stp: "step s e"
+ and not_in: "th \<notin> threads (e # s)"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in': "thread \<notin> threads s"
+ have "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_create_unchanged)
+ moreover have "th \<notin> threads s"
+ proof -
+ from not_in eq_e show ?thesis by simp
+ qed
+ moreover note ih ultimately show ?thesis by auto
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and nh: "holdents s thread = {}"
+ have eq_cns: "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_exit_unchanged)
+ show ?thesis
+ proof(cases "th = thread")
+ case True
+ have "cntCS s th = 0" by (unfold cntCS_def, auto simp:nh True)
+ with eq_cns show ?thesis by simp
+ next
+ case False
+ with not_in and eq_e
+ have "th \<notin> threads s" by simp
+ from ih[OF this] and eq_cns show ?thesis by simp
+ qed
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ from assms thread_P ih vt stp thread_P have vtp: "vt (P thread cs#s)" by auto
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ hence "cntCS (e # s) th = cntCS s th "
+ apply (unfold cntCS_def holdents_test eq_e)
+ by (unfold step_RAG_p[OF vtp], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_V thread cs)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ from assms thread_V vt stp ih
+ have vtv: "vt (V thread cs#s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs#s)"
+ by (unfold_locales, simp)
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ from not_in eq_e eq_wq
+ have "\<not> next_th s thread cs th"
+ apply (auto simp:next_th_def)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> threads s" (is "?t \<notin> threads s")
+ have "?t \<in> set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ fix x assume "distinct x \<and> set x = set rest" with ne
+ show "hd x \<in> set rest" by (cases x, auto)
+ qed
+ with eq_wq have "?t \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads[OF this] and ni
+ show False
+ using `hd (SOME q. distinct q \<and> set q = set rest) \<in> set (wq s cs)`
+ ni vt_s.wq_threads by blast
+ qed
+ moreover note neq_th eq_wq
+ ultimately have "cntCS (e # s) th = cntCS s th"
+ by (unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_set thread prio)
+ print_facts
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ from not_in and eq_e have "th \<notin> threads s" by auto
+ from ih [OF this] and eq_e
+ show ?thesis
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+end
+
+lemma eq_waiting: "waiting (wq (s::state)) th cs = waiting s th cs"
+ by (auto simp:s_waiting_def cs_waiting_def wq_def)
+
+context valid_trace
+begin
+
+lemma dm_RAG_threads:
+ assumes in_dom: "(Th th) \<in> Domain (RAG s)"
+ shows "th \<in> threads s"
+proof -
+ from in_dom obtain n where "(Th th, n) \<in> RAG s" by auto
+ moreover from RAG_target_th[OF this] obtain cs where "n = Cs cs" by auto
+ ultimately have "(Th th, Cs cs) \<in> RAG s" by simp
+ hence "th \<in> set (wq s cs)"
+ by (unfold s_RAG_def, auto simp:cs_waiting_def)
+ from wq_threads [OF this] show ?thesis .
+qed
+
+end
+
+lemma cp_eq_cpreced: "cp s th = cpreced (wq s) s th"
+unfolding cp_def wq_def
+apply(induct s rule: schs.induct)
+thm cpreced_initial
+apply(simp add: Let_def cpreced_initial)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+done
+
+context valid_trace
+begin
+
+lemma runing_unique:
+ assumes runing_1: "th1 \<in> runing s"
+ and runing_2: "th2 \<in> runing s"
+ shows "th1 = th2"
+proof -
+ from runing_1 and runing_2 have "cp s th1 = cp s th2"
+ unfolding runing_def
+ apply(simp)
+ done
+ hence eq_max: "Max ((\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)) =
+ Max ((\<lambda>th. preced th s) ` ({th2} \<union> dependants (wq s) th2))"
+ (is "Max (?f ` ?A) = Max (?f ` ?B)")
+ unfolding cp_eq_cpreced
+ unfolding cpreced_def .
+ obtain th1' where th1_in: "th1' \<in> ?A" and eq_f_th1: "?f th1' = Max (?f ` ?A)"
+ proof -
+ have h1: "finite (?f ` ?A)"
+ proof -
+ have "finite ?A"
+ proof -
+ have "finite (dependants (wq s) th1)"
+ proof-
+ have "finite {th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th1)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?A) \<noteq> {}"
+ proof -
+ have "?A \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?A) \<in> (?f ` ?A)" .
+ thus ?thesis
+ thm cpreced_def
+ unfolding cpreced_def[symmetric]
+ unfolding cp_eq_cpreced[symmetric]
+ unfolding cpreced_def
+ using that[intro] by (auto)
+ qed
+ obtain th2' where th2_in: "th2' \<in> ?B" and eq_f_th2: "?f th2' = Max (?f ` ?B)"
+ proof -
+ have h1: "finite (?f ` ?B)"
+ proof -
+ have "finite ?B"
+ proof -
+ have "finite (dependants (wq s) th2)"
+ proof-
+ have "finite {th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th2)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?B) \<noteq> {}"
+ proof -
+ have "?B \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?B) \<in> (?f ` ?B)" .
+ thus ?thesis by (auto intro:that)
+ qed
+ from eq_f_th1 eq_f_th2 eq_max
+ have eq_preced: "preced th1' s = preced th2' s" by auto
+ hence eq_th12: "th1' = th2'"
+ proof (rule preced_unique)
+ from th1_in have "th1' = th1 \<or> (th1' \<in> dependants (wq s) th1)" by simp
+ thus "th1' \<in> threads s"
+ proof
+ assume "th1' \<in> dependants (wq s) th1"
+ hence "(Th th1') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th1') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th1' = th1"
+ with runing_1 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ next
+ from th2_in have "th2' = th2 \<or> (th2' \<in> dependants (wq s) th2)" by simp
+ thus "th2' \<in> threads s"
+ proof
+ assume "th2' \<in> dependants (wq s) th2"
+ hence "(Th th2') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th2') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th2' = th2"
+ with runing_2 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ qed
+ from th1_in have "th1' = th1 \<or> th1' \<in> dependants (wq s) th1" by simp
+ thus ?thesis
+ proof
+ assume eq_th': "th1' = th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2" thus ?thesis using eq_th' eq_th12 by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 eq_th' have "th1 \<in> dependants (wq s) th2" by simp
+ hence "(Th th1, Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th1 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th1 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th1, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th1, Cs cs') \<in> RAG s" by simp
+ with runing_1 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ qed
+ next
+ assume th1'_in: "th1' \<in> dependants (wq s) th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2"
+ with th1'_in eq_th12 have "th2 \<in> dependants (wq s) th1" by simp
+ hence "(Th th2, Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th2 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th2 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th2, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th2, Cs cs') \<in> RAG s" by simp
+ with runing_2 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 have "th1' \<in> dependants (wq s) th2" by simp
+ hence h1: "(Th th1', Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ from th1'_in have h2: "(Th th1', Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ show ?thesis
+ proof(rule dchain_unique[OF h1 _ h2, symmetric])
+ from runing_1 show "th1 \<in> readys s" by (simp add:runing_def)
+ from runing_2 show "th2 \<in> readys s" by (simp add:runing_def)
+ qed
+ qed
+ qed
+qed
+
+
+lemma "card (runing s) \<le> 1"
+apply(subgoal_tac "finite (runing s)")
+prefer 2
+apply (metis finite_nat_set_iff_bounded lessI runing_unique)
+apply(rule ccontr)
+apply(simp)
+apply(case_tac "Suc (Suc 0) \<le> card (runing s)")
+apply(subst (asm) card_le_Suc_iff)
+apply(simp)
+apply(auto)[1]
+apply (metis insertCI runing_unique)
+apply(auto)
+done
+
+end
+
+
+lemma create_pre:
+ assumes stp: "step s e"
+ and not_in: "th \<notin> threads s"
+ and is_in: "th \<in> threads (e#s)"
+ obtains prio where "e = Create th prio"
+proof -
+ from assms
+ show ?thesis
+ proof(cases)
+ case (thread_create thread prio)
+ with is_in not_in have "e = Create th prio" by simp
+ from that[OF this] show ?thesis .
+ next
+ case (thread_exit thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_P thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_V thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_set thread)
+ with assms show ?thesis by (auto intro!:that)
+ qed
+qed
+
+lemma length_down_to_in:
+ assumes le_ij: "i \<le> j"
+ and le_js: "j \<le> length s"
+ shows "length (down_to j i s) = j - i"
+proof -
+ have "length (down_to j i s) = length (from_to i j (rev s))"
+ by (unfold down_to_def, auto)
+ also have "\<dots> = j - i"
+ proof(rule length_from_to_in[OF le_ij])
+ from le_js show "j \<le> length (rev s)" by simp
+ qed
+ finally show ?thesis .
+qed
+
+
+lemma moment_head:
+ assumes le_it: "Suc i \<le> length t"
+ obtains e where "moment (Suc i) t = e#moment i t"
+proof -
+ have "i \<le> Suc i" by simp
+ from length_down_to_in [OF this le_it]
+ have "length (down_to (Suc i) i t) = 1" by auto
+ then obtain e where "down_to (Suc i) i t = [e]"
+ apply (cases "(down_to (Suc i) i t)") by auto
+ moreover have "down_to (Suc i) 0 t = down_to (Suc i) i t @ down_to i 0 t"
+ by (rule down_to_conc[symmetric], auto)
+ ultimately have eq_me: "moment (Suc i) t = e#(moment i t)"
+ by (auto simp:down_to_moment)
+ from that [OF this] show ?thesis .
+qed
+
+context valid_trace
+begin
+
+lemma cnp_cnv_eq:
+ assumes "th \<notin> threads s"
+ shows "cntP s th = cntV s th"
+ using assms
+ using cnp_cnv_cncs not_thread_cncs by auto
+
+end
+
+
+lemma eq_RAG:
+ "RAG (wq s) = RAG s"
+by (unfold cs_RAG_def s_RAG_def, auto)
+
+context valid_trace
+begin
+
+lemma count_eq_dependants:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "dependants (wq s) th = {}"
+proof -
+ from cnp_cnv_cncs and eq_pv
+ have "cntCS s th = 0"
+ by (auto split:if_splits)
+ moreover have "finite {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from finite_holding[of th] show ?thesis
+ by (simp add:holdents_test)
+ qed
+ ultimately have h: "{cs. (Cs cs, Th th) \<in> RAG s} = {}"
+ by (unfold cntCS_def holdents_test cs_dependants_def, auto)
+ show ?thesis
+ proof(unfold cs_dependants_def)
+ { assume "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}"
+ then obtain th' where "(Th th', Th th) \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "False"
+ proof(cases)
+ assume "(Th th', Th th) \<in> RAG (wq s)"
+ thus "False" by (auto simp:cs_RAG_def)
+ next
+ fix c
+ assume "(c, Th th) \<in> RAG (wq s)"
+ with h and eq_RAG show "False"
+ by (cases c, auto simp:cs_RAG_def)
+ qed
+ } thus "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} = {}" by auto
+ qed
+qed
+
+lemma dependants_threads:
+ shows "dependants (wq s) th \<subseteq> threads s"
+proof
+ { fix th th'
+ assume h: "th \<in> {th'a. (Th th'a, Th th') \<in> (RAG (wq s))\<^sup>+}"
+ have "Th th \<in> Domain (RAG s)"
+ proof -
+ from h obtain th' where "(Th th, Th th') \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "(Th th) \<in> Domain ( (RAG (wq s))\<^sup>+)" by (auto simp:Domain_def)
+ with trancl_domain have "(Th th) \<in> Domain (RAG (wq s))" by simp
+ thus ?thesis using eq_RAG by simp
+ qed
+ from dm_RAG_threads[OF this]
+ have "th \<in> threads s" .
+ } note hh = this
+ fix th1
+ assume "th1 \<in> dependants (wq s) th"
+ hence "th1 \<in> {th'a. (Th th'a, Th th) \<in> (RAG (wq s))\<^sup>+}"
+ by (unfold cs_dependants_def, simp)
+ from hh [OF this] show "th1 \<in> threads s" .
+qed
+
+lemma finite_threads:
+ shows "finite (threads s)"
+using vt by (induct) (auto elim: step.cases)
+
+end
+
+lemma Max_f_mono:
+ assumes seq: "A \<subseteq> B"
+ and np: "A \<noteq> {}"
+ and fnt: "finite B"
+ shows "Max (f ` A) \<le> Max (f ` B)"
+proof(rule Max_mono)
+ from seq show "f ` A \<subseteq> f ` B" by auto
+next
+ from np show "f ` A \<noteq> {}" by auto
+next
+ from fnt and seq show "finite (f ` B)" by auto
+qed
+
+context valid_trace
+begin
+
+lemma cp_le:
+ assumes th_in: "th \<in> threads s"
+ shows "cp s th \<le> Max ((\<lambda> th. (preced th s)) ` threads s)"
+proof(unfold cp_eq_cpreced cpreced_def cs_dependants_def)
+ show "Max ((\<lambda>th. preced th s) ` ({th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}))
+ \<le> Max ((\<lambda>th. preced th s) ` threads s)"
+ (is "Max (?f ` ?A) \<le> Max (?f ` ?B)")
+ proof(rule Max_f_mono)
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}" by simp
+ next
+ from finite_threads
+ show "finite (threads s)" .
+ next
+ from th_in
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> threads s"
+ apply (auto simp:Domain_def)
+ apply (rule_tac dm_RAG_threads)
+ apply (unfold trancl_domain [of "RAG s", symmetric])
+ by (unfold cs_RAG_def s_RAG_def, auto simp:Domain_def)
+ qed
+qed
+
+lemma le_cp:
+ shows "preced th s \<le> cp s th"
+proof(unfold cp_eq_cpreced preced_def cpreced_def, simp)
+ show "Prc (priority th s) (last_set th s)
+ \<le> Max (insert (Prc (priority th s) (last_set th s))
+ ((\<lambda>th. Prc (priority th s) (last_set th s)) ` dependants (wq s) th))"
+ (is "?l \<le> Max (insert ?l ?A)")
+ proof(cases "?A = {}")
+ case False
+ have "finite ?A" (is "finite (?f ` ?B)")
+ proof -
+ have "finite ?B"
+ proof-
+ have "finite {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ from Max_insert [OF this False, of ?l] show ?thesis by auto
+ next
+ case True
+ thus ?thesis by auto
+ qed
+qed
+
+lemma max_cp_eq:
+ shows "Max ((cp s) ` threads s) = Max ((\<lambda> th. (preced th s)) ` threads s)"
+ (is "?l = ?r")
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ have "?l \<in> ((cp s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ next
+ from False show "cp s ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th
+ where th_in: "th \<in> threads s" and eq_l: "?l = cp s th" by auto
+ have "\<dots> \<le> ?r" by (rule cp_le[OF th_in])
+ moreover have "?r \<le> cp s th" (is "Max (?f ` ?A) \<le> cp s th")
+ proof -
+ have "?r \<in> (?f ` ?A)"
+ proof(rule Max_in)
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by auto
+ next
+ from False show " (\<lambda>th. preced th s) ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th' where
+ th_in': "th' \<in> ?A " and eq_r: "?r = ?f th'" by auto
+ from le_cp [of th'] eq_r
+ have "?r \<le> cp s th'" by auto
+ moreover have "\<dots> \<le> cp s th"
+ proof(fold eq_l)
+ show " cp s th' \<le> Max (cp s ` threads s)"
+ proof(rule Max_ge)
+ from th_in' show "cp s th' \<in> cp s ` threads s"
+ by auto
+ next
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ qed
+ qed
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis using eq_l by auto
+qed
+
+lemma max_cp_readys_threads_pre:
+ assumes np: "threads s \<noteq> {}"
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(unfold max_cp_eq)
+ show "Max (cp s ` readys s) = Max ((\<lambda>th. preced th s) ` threads s)"
+ proof -
+ let ?p = "Max ((\<lambda>th. preced th s) ` threads s)"
+ let ?f = "(\<lambda>th. preced th s)"
+ have "?p \<in> ((\<lambda>th. preced th s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads show "finite (?f ` threads s)" by simp
+ next
+ from np show "?f ` threads s \<noteq> {}" by simp
+ qed
+ then obtain tm where tm_max: "?f tm = ?p" and tm_in: "tm \<in> threads s"
+ by (auto simp:Image_def)
+ from th_chain_to_ready [OF tm_in]
+ have "tm \<in> readys s \<or> (\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+)" .
+ thus ?thesis
+ proof
+ assume "\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+ "
+ then obtain th' where th'_in: "th' \<in> readys s"
+ and tm_chain:"(Th tm, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "cp s th' = ?f tm"
+ proof(subst cp_eq_cpreced, subst cpreced_def, rule Max_eqI)
+ from dependants_threads finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th'))"
+ by (auto intro:finite_subset)
+ next
+ fix p assume p_in: "p \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ from tm_max have " preced tm s = Max ((\<lambda>th. preced th s) ` threads s)" .
+ moreover have "p \<le> \<dots>"
+ proof(rule Max_ge)
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ from p_in and th'_in and dependants_threads[of th']
+ show "p \<in> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ ultimately show "p \<le> preced tm s" by auto
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ proof -
+ from tm_chain
+ have "tm \<in> dependants (wq s) th'"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, auto)
+ thus ?thesis by auto
+ qed
+ qed
+ with tm_max
+ have h: "cp s th' = Max ((\<lambda>th. preced th s) ` threads s)" by simp
+ show ?thesis
+ proof (fold h, rule Max_eqI)
+ fix q
+ assume "q \<in> cp s ` readys s"
+ then obtain th1 where th1_in: "th1 \<in> readys s"
+ and eq_q: "q = cp s th1" by auto
+ show "q \<le> cp s th'"
+ apply (unfold h eq_q)
+ apply (unfold cp_eq_cpreced cpreced_def)
+ apply (rule Max_mono)
+ proof -
+ from dependants_threads [of th1] th1_in
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<subseteq>
+ (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}" by simp
+ next
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ from th'_in
+ show "cp s th' \<in> cp s ` readys s" by simp
+ qed
+ next
+ assume tm_ready: "tm \<in> readys s"
+ show ?thesis
+ proof(fold tm_max)
+ have cp_eq_p: "cp s tm = preced tm s"
+ proof(unfold cp_eq_cpreced cpreced_def, rule Max_eqI)
+ fix y
+ assume hy: "y \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ show "y \<le> preced tm s"
+ proof -
+ { fix y'
+ assume hy' : "y' \<in> ((\<lambda>th. preced th s) ` dependants (wq s) tm)"
+ have "y' \<le> preced tm s"
+ proof(unfold tm_max, rule Max_ge)
+ from hy' dependants_threads[of tm]
+ show "y' \<in> (\<lambda>th. preced th s) ` threads s" by auto
+ next
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ } with hy show ?thesis by auto
+ qed
+ next
+ from dependants_threads[of tm] finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm))"
+ by (auto intro:finite_subset)
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ by simp
+ qed
+ moreover have "Max (cp s ` readys s) = cp s tm"
+ proof(rule Max_eqI)
+ from tm_ready show "cp s tm \<in> cp s ` readys s" by simp
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ fix y assume "y \<in> cp s ` readys s"
+ then obtain th1 where th1_readys: "th1 \<in> readys s"
+ and h: "y = cp s th1" by auto
+ show "y \<le> cp s tm"
+ apply(unfold cp_eq_p h)
+ apply(unfold cp_eq_cpreced cpreced_def tm_max, rule Max_mono)
+ proof -
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}"
+ by simp
+ next
+ from dependants_threads[of th1] th1_readys
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)
+ \<subseteq> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ qed
+ ultimately show " Max (cp s ` readys s) = preced tm s" by simp
+ qed
+ qed
+ qed
+qed
+
+text {* (* ccc *) \noindent
+ Since the current precedence of the threads in ready queue will always be boosted,
+ there must be one inside it has the maximum precedence of the whole system.
+*}
+lemma max_cp_readys_threads:
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis
+ by (auto simp:readys_def)
+next
+ case False
+ show ?thesis by (rule max_cp_readys_threads_pre[OF False])
+qed
+
+end
+
+lemma eq_holding: "holding (wq s) th cs = holding s th cs"
+ apply (unfold s_holding_def cs_holding_def wq_def, simp)
+ done
+
+lemma f_image_eq:
+ assumes h: "\<And> a. a \<in> A \<Longrightarrow> f a = g a"
+ shows "f ` A = g ` A"
+proof
+ show "f ` A \<subseteq> g ` A"
+ by(rule image_subsetI, auto intro:h)
+next
+ show "g ` A \<subseteq> f ` A"
+ by (rule image_subsetI, auto intro:h[symmetric])
+qed
+
+
+definition detached :: "state \<Rightarrow> thread \<Rightarrow> bool"
+ where "detached s th \<equiv> (\<not>(\<exists> cs. holding s th cs)) \<and> (\<not>(\<exists>cs. waiting s th cs))"
+
+
+lemma detached_test:
+ shows "detached s th = (Th th \<notin> Field (RAG s))"
+apply(simp add: detached_def Field_def)
+apply(simp add: s_RAG_def)
+apply(simp add: s_holding_abv s_waiting_abv)
+apply(simp add: Domain_iff Range_iff)
+apply(simp add: wq_def)
+apply(auto)
+done
+
+context valid_trace
+begin
+
+lemma detached_intro:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "detached s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_cnt: "cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ hence cncs_zero: "cntCS s th = 0"
+ by (auto simp:eq_pv split:if_splits)
+ with eq_cnt
+ have "th \<in> readys s \<or> th \<notin> threads s" by (auto simp:eq_pv)
+ thus ?thesis
+ proof
+ assume "th \<notin> threads s"
+ with range_in dm_RAG_threads
+ show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def Domain_iff Range_iff)
+ next
+ assume "th \<in> readys s"
+ moreover have "Th th \<notin> Range (RAG s)"
+ proof -
+ from card_0_eq [OF finite_holding] and cncs_zero
+ have "holdents s th = {}"
+ by (simp add:cntCS_def)
+ thus ?thesis
+ apply(auto simp:holdents_test)
+ apply(case_tac a)
+ apply(auto simp:holdents_test s_RAG_def)
+ done
+ qed
+ ultimately show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def readys_def)
+ qed
+qed
+
+lemma detached_elim:
+ assumes dtc: "detached s th"
+ shows "cntP s th = cntV s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_pv: " cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ have cncs_z: "cntCS s th = 0"
+ proof -
+ from dtc have "holdents s th = {}"
+ unfolding detached_def holdents_test s_RAG_def
+ by (simp add: s_waiting_abv wq_def s_holding_abv Domain_iff Range_iff)
+ thus ?thesis by (auto simp:cntCS_def)
+ qed
+ show ?thesis
+ proof(cases "th \<in> threads s")
+ case True
+ with dtc
+ have "th \<in> readys s"
+ by (unfold readys_def detached_def Field_def Domain_def Range_def,
+ auto simp:eq_waiting s_RAG_def)
+ with cncs_z and eq_pv show ?thesis by simp
+ next
+ case False
+ with cncs_z and eq_pv show ?thesis by simp
+ qed
+qed
+
+lemma detached_eq:
+ shows "(detached s th) = (cntP s th = cntV s th)"
+ by (insert vt, auto intro:detached_intro detached_elim)
+
+end
+
+text {*
+ The lemmas in this .thy file are all obvious lemmas, however, they still needs to be derived
+ from the concise and miniature model of PIP given in PrioGDef.thy.
+*}
+
+lemma eq_dependants: "dependants (wq s) = dependants s"
+ by (simp add: s_dependants_abv wq_def)
+
+lemma next_th_unique:
+ assumes nt1: "next_th s th cs th1"
+ and nt2: "next_th s th cs th2"
+ shows "th1 = th2"
+using assms by (unfold next_th_def, auto)
+
+lemma birth_time_lt: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ apply (induct s, simp)
+proof -
+ fix a s
+ assume ih: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ and eq_as: "a # s \<noteq> []"
+ show "last_set th (a # s) < length (a # s)"
+ proof(cases "s \<noteq> []")
+ case False
+ from False show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ next
+ case True
+ from ih [OF True] show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ qed
+qed
+
+lemma th_in_ne: "th \<in> threads s \<Longrightarrow> s \<noteq> []"
+ by (induct s, auto simp:threads.simps)
+
+lemma preced_tm_lt: "th \<in> threads s \<Longrightarrow> preced th s = Prc x y \<Longrightarrow> y < length s"
+ apply (drule_tac th_in_ne)
+ by (unfold preced_def, auto intro: birth_time_lt)
+
+lemma inj_the_preced:
+ "inj_on (the_preced s) (threads s)"
+ by (metis inj_onI preced_unique the_preced_def)
+
+lemma tRAG_alt_def:
+ "tRAG s = {(Th th1, Th th2) | th1 th2.
+ \<exists> cs. (Th th1, Cs cs) \<in> RAG s \<and> (Cs cs, Th th2) \<in> RAG s}"
+ by (auto simp:tRAG_def RAG_split wRAG_def hRAG_def)
+
+lemma tRAG_Field:
+ "Field (tRAG s) \<subseteq> Field (RAG s)"
+ by (unfold tRAG_alt_def Field_def, auto)
+
+lemma tRAG_ancestorsE:
+ assumes "x \<in> ancestors (tRAG s) u"
+ obtains th where "x = Th th"
+proof -
+ from assms have "(u, x) \<in> (tRAG s)^+"
+ by (unfold ancestors_def, auto)
+ from tranclE[OF this] obtain c where "(c, x) \<in> tRAG s" by auto
+ then obtain th where "x = Th th"
+ by (unfold tRAG_alt_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma tRAG_mono:
+ assumes "RAG s' \<subseteq> RAG s"
+ shows "tRAG s' \<subseteq> tRAG s"
+ using assms
+ by (unfold tRAG_alt_def, auto)
+
+lemma holding_next_thI:
+ assumes "holding s th cs"
+ and "length (wq s cs) > 1"
+ obtains th' where "next_th s th cs th'"
+proof -
+ from assms(1)[folded eq_holding, unfolded cs_holding_def]
+ have " th \<in> set (wq s cs) \<and> th = hd (wq s cs)" .
+ then obtain rest where h1: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ with assms(2) have h2: "rest \<noteq> []" by auto
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ have "next_th s th cs ?th'" using h1(1) h2
+ by (unfold next_th_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma RAG_tRAG_transfer:
+ assumes "vt s'"
+ assumes "RAG s = RAG s' \<union> {(Th th, Cs cs)}"
+ and "(Cs cs, Th th'') \<in> RAG s'"
+ shows "tRAG s = tRAG s' \<union> {(Th th, Th th'')}" (is "?L = ?R")
+proof -
+ interpret vt_s': valid_trace "s'" using assms(1)
+ by (unfold_locales, simp)
+ interpret rtree: rtree "RAG s'"
+ proof
+ show "single_valued (RAG s')"
+ apply (intro_locales)
+ by (unfold single_valued_def,
+ auto intro:vt_s'.unique_RAG)
+
+ show "acyclic (RAG s')"
+ by (rule vt_s'.acyclic_RAG)
+ qed
+ { fix n1 n2
+ assume "(n1, n2) \<in> ?L"
+ from this[unfolded tRAG_alt_def]
+ obtain th1 th2 cs' where
+ h: "n1 = Th th1" "n2 = Th th2"
+ "(Th th1, Cs cs') \<in> RAG s"
+ "(Cs cs', Th th2) \<in> RAG s" by auto
+ from h(4) and assms(2) have cs_in: "(Cs cs', Th th2) \<in> RAG s'" by auto
+ from h(3) and assms(2)
+ have "(Th th1, Cs cs') = (Th th, Cs cs) \<or>
+ (Th th1, Cs cs') \<in> RAG s'" by auto
+ hence "(n1, n2) \<in> ?R"
+ proof
+ assume h1: "(Th th1, Cs cs') = (Th th, Cs cs)"
+ hence eq_th1: "th1 = th" by simp
+ moreover have "th2 = th''"
+ proof -
+ from h1 have "cs' = cs" by simp
+ from assms(3) cs_in[unfolded this] rtree.sgv
+ show ?thesis
+ by (unfold single_valued_def, auto)
+ qed
+ ultimately show ?thesis using h(1,2) by auto
+ next
+ assume "(Th th1, Cs cs') \<in> RAG s'"
+ with cs_in have "(Th th1, Th th2) \<in> tRAG s'"
+ by (unfold tRAG_alt_def, auto)
+ from this[folded h(1, 2)] show ?thesis by auto
+ qed
+ } moreover {
+ fix n1 n2
+ assume "(n1, n2) \<in> ?R"
+ hence "(n1, n2) \<in>tRAG s' \<or> (n1, n2) = (Th th, Th th'')" by auto
+ hence "(n1, n2) \<in> ?L"
+ proof
+ assume "(n1, n2) \<in> tRAG s'"
+ moreover have "... \<subseteq> ?L"
+ proof(rule tRAG_mono)
+ show "RAG s' \<subseteq> RAG s" by (unfold assms(2), auto)
+ qed
+ ultimately show ?thesis by auto
+ next
+ assume eq_n: "(n1, n2) = (Th th, Th th'')"
+ from assms(2, 3) have "(Cs cs, Th th'') \<in> RAG s" by auto
+ moreover have "(Th th, Cs cs) \<in> RAG s" using assms(2) by auto
+ ultimately show ?thesis
+ by (unfold eq_n tRAG_alt_def, auto)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+context valid_trace
+begin
+
+lemmas RAG_tRAG_transfer = RAG_tRAG_transfer[OF vt]
+
+end
+
+lemma cp_alt_def:
+ "cp s th =
+ Max ((the_preced s) ` {th'. Th th' \<in> (subtree (RAG s) (Th th))})"
+proof -
+ have "Max (the_preced s ` ({th} \<union> dependants (wq s) th)) =
+ Max (the_preced s ` {th'. Th th' \<in> subtree (RAG s) (Th th)})"
+ (is "Max (_ ` ?L) = Max (_ ` ?R)")
+ proof -
+ have "?L = ?R"
+ by (auto dest:rtranclD simp:cs_dependants_def cs_RAG_def s_RAG_def subtree_def)
+ thus ?thesis by simp
+ qed
+ thus ?thesis by (unfold cp_eq_cpreced cpreced_def, fold the_preced_def, simp)
+qed
+
+lemma cp_gen_alt_def:
+ "cp_gen s = (Max \<circ> (\<lambda>x. (the_preced s \<circ> the_thread) ` subtree (tRAG s) x))"
+ by (auto simp:cp_gen_def)
+
+lemma tRAG_nodeE:
+ assumes "(n1, n2) \<in> tRAG s"
+ obtains th1 th2 where "n1 = Th th1" "n2 = Th th2"
+ using assms
+ by (auto simp: tRAG_def wRAG_def hRAG_def tRAG_def)
+
+lemma subtree_nodeE:
+ assumes "n \<in> subtree (tRAG s) (Th th)"
+ obtains th1 where "n = Th th1"
+proof -
+ show ?thesis
+ proof(rule subtreeE[OF assms])
+ assume "n = Th th"
+ from that[OF this] show ?thesis .
+ next
+ assume "Th th \<in> ancestors (tRAG s) n"
+ hence "(n, Th th) \<in> (tRAG s)^+" by (auto simp:ancestors_def)
+ hence "\<exists> th1. n = Th th1"
+ proof(induct)
+ case (base y)
+ from tRAG_nodeE[OF this] show ?case by metis
+ next
+ case (step y z)
+ thus ?case by auto
+ qed
+ with that show ?thesis by auto
+ qed
+qed
+
+lemma tRAG_star_RAG: "(tRAG s)^* \<subseteq> (RAG s)^*"
+proof -
+ have "(wRAG s O hRAG s)^* \<subseteq> (RAG s O RAG s)^*"
+ by (rule rtrancl_mono, auto simp:RAG_split)
+ also have "... \<subseteq> ((RAG s)^*)^*"
+ by (rule rtrancl_mono, auto)
+ also have "... = (RAG s)^*" by simp
+ finally show ?thesis by (unfold tRAG_def, simp)
+qed
+
+lemma tRAG_subtree_RAG: "subtree (tRAG s) x \<subseteq> subtree (RAG s) x"
+proof -
+ { fix a
+ assume "a \<in> subtree (tRAG s) x"
+ hence "(a, x) \<in> (tRAG s)^*" by (auto simp:subtree_def)
+ with tRAG_star_RAG[of s]
+ have "(a, x) \<in> (RAG s)^*" by auto
+ hence "a \<in> subtree (RAG s) x" by (auto simp:subtree_def)
+ } thus ?thesis by auto
+qed
+
+lemma tRAG_trancl_eq:
+ "{th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {th'. (Th th', Th th) \<in> (RAG s)^+}"
+ (is "?L = ?R")
+proof -
+ { fix th'
+ assume "th' \<in> ?L"
+ hence "(Th th', Th th) \<in> (tRAG s)^+" by auto
+ from tranclD[OF this]
+ obtain z where h: "(Th th', z) \<in> tRAG s" "(z, Th th) \<in> (tRAG s)\<^sup>*" by auto
+ from tRAG_subtree_RAG[of s] and this(2)
+ have "(z, Th th) \<in> (RAG s)^*" by (meson subsetCE tRAG_star_RAG)
+ moreover from h(1) have "(Th th', z) \<in> (RAG s)^+" using tRAG_alt_def by auto
+ ultimately have "th' \<in> ?R" by auto
+ } moreover
+ { fix th'
+ assume "th' \<in> ?R"
+ hence "(Th th', Th th) \<in> (RAG s)^+" by (auto)
+ from plus_rpath[OF this]
+ obtain xs where rp: "rpath (RAG s) (Th th') xs (Th th)" "xs \<noteq> []" by auto
+ hence "(Th th', Th th) \<in> (tRAG s)^+"
+ proof(induct xs arbitrary:th' th rule:length_induct)
+ case (1 xs th' th)
+ then obtain x1 xs1 where Cons1: "xs = x1#xs1" by (cases xs, auto)
+ show ?case
+ proof(cases "xs1")
+ case Nil
+ from 1(2)[unfolded Cons1 Nil]
+ have rp: "rpath (RAG s) (Th th') [x1] (Th th)" .
+ hence "(Th th', x1) \<in> (RAG s)" by (cases, simp)
+ then obtain cs where "x1 = Cs cs"
+ by (unfold s_RAG_def, auto)
+ from rpath_nnl_lastE[OF rp[unfolded this]]
+ show ?thesis by auto
+ next
+ case (Cons x2 xs2)
+ from 1(2)[unfolded Cons1[unfolded this]]
+ have rp: "rpath (RAG s) (Th th') (x1 # x2 # xs2) (Th th)" .
+ from rpath_edges_on[OF this]
+ have eds: "edges_on (Th th' # x1 # x2 # xs2) \<subseteq> RAG s" .
+ have "(Th th', x1) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ with eds have rg1: "(Th th', x1) \<in> RAG s" by auto
+ then obtain cs1 where eq_x1: "x1 = Cs cs1" by (unfold s_RAG_def, auto)
+ have "(x1, x2) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ from this eds
+ have rg2: "(x1, x2) \<in> RAG s" by auto
+ from this[unfolded eq_x1]
+ obtain th1 where eq_x2: "x2 = Th th1" by (unfold s_RAG_def, auto)
+ from rg1[unfolded eq_x1] rg2[unfolded eq_x1 eq_x2]
+ have rt1: "(Th th', Th th1) \<in> tRAG s" by (unfold tRAG_alt_def, auto)
+ from rp have "rpath (RAG s) x2 xs2 (Th th)"
+ by (elim rpath_ConsE, simp)
+ from this[unfolded eq_x2] have rp': "rpath (RAG s) (Th th1) xs2 (Th th)" .
+ show ?thesis
+ proof(cases "xs2 = []")
+ case True
+ from rpath_nilE[OF rp'[unfolded this]]
+ have "th1 = th" by auto
+ from rt1[unfolded this] show ?thesis by auto
+ next
+ case False
+ from 1(1)[rule_format, OF _ rp' this, unfolded Cons1 Cons]
+ have "(Th th1, Th th) \<in> (tRAG s)\<^sup>+" by simp
+ with rt1 show ?thesis by auto
+ qed
+ qed
+ qed
+ hence "th' \<in> ?L" by auto
+ } ultimately show ?thesis by blast
+qed
+
+lemma tRAG_trancl_eq_Th:
+ "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}"
+ using tRAG_trancl_eq by auto
+
+lemma dependants_alt_def:
+ "dependants s th = {th'. (Th th', Th th) \<in> (tRAG s)^+}"
+ by (metis eq_RAG s_dependants_def tRAG_trancl_eq)
+
+context valid_trace
+begin
+
+lemma count_eq_tRAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using assms count_eq_dependants dependants_alt_def eq_dependants by auto
+
+lemma count_eq_RAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using assms count_eq_dependants cs_dependants_def eq_RAG by auto
+
+lemma count_eq_RAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using count_eq_RAG_plus[OF assms] by auto
+
+lemma count_eq_tRAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using count_eq_tRAG_plus[OF assms] by auto
+
+end
+
+lemma tRAG_subtree_eq:
+ "(subtree (tRAG s) (Th th)) = {Th th' | th'. Th th' \<in> (subtree (RAG s) (Th th))}"
+ (is "?L = ?R")
+proof -
+ { fix n
+ assume h: "n \<in> ?L"
+ hence "n \<in> ?R"
+ by (smt mem_Collect_eq subsetCE subtree_def subtree_nodeE tRAG_subtree_RAG)
+ } moreover {
+ fix n
+ assume "n \<in> ?R"
+ then obtain th' where h: "n = Th th'" "(Th th', Th th) \<in> (RAG s)^*"
+ by (auto simp:subtree_def)
+ from rtranclD[OF this(2)]
+ have "n \<in> ?L"
+ proof
+ assume "Th th' \<noteq> Th th \<and> (Th th', Th th) \<in> (RAG s)\<^sup>+"
+ with h have "n \<in> {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}" by auto
+ thus ?thesis using subtree_def tRAG_trancl_eq by fastforce
+ qed (insert h, auto simp:subtree_def)
+ } ultimately show ?thesis by auto
+qed
+
+lemma threads_set_eq:
+ "the_thread ` (subtree (tRAG s) (Th th)) =
+ {th'. Th th' \<in> (subtree (RAG s) (Th th))}" (is "?L = ?R")
+ by (auto intro:rev_image_eqI simp:tRAG_subtree_eq)
+
+lemma cp_alt_def1:
+ "cp s th = Max ((the_preced s o the_thread) ` (subtree (tRAG s) (Th th)))"
+proof -
+ have "(the_preced s ` the_thread ` subtree (tRAG s) (Th th)) =
+ ((the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th))"
+ by auto
+ thus ?thesis by (unfold cp_alt_def, fold threads_set_eq, auto)
+qed
+
+lemma cp_gen_def_cond:
+ assumes "x = Th th"
+ shows "cp s th = cp_gen s (Th th)"
+by (unfold cp_alt_def1 cp_gen_def, simp)
+
+lemma cp_gen_over_set:
+ assumes "\<forall> x \<in> A. \<exists> th. x = Th th"
+ shows "cp_gen s ` A = (cp s \<circ> the_thread) ` A"
+proof(rule f_image_eq)
+ fix a
+ assume "a \<in> A"
+ from assms[rule_format, OF this]
+ obtain th where eq_a: "a = Th th" by auto
+ show "cp_gen s a = (cp s \<circ> the_thread) a"
+ by (unfold eq_a, simp, unfold cp_gen_def_cond[OF refl[of "Th th"]], simp)
+qed
+
+
+context valid_trace
+begin
+
+lemma RAG_threads:
+ assumes "(Th th) \<in> Field (RAG s)"
+ shows "th \<in> threads s"
+ using assms
+ by (metis Field_def UnE dm_RAG_threads range_in vt)
+
+lemma subtree_tRAG_thread:
+ assumes "th \<in> threads s"
+ shows "subtree (tRAG s) (Th th) \<subseteq> Th ` threads s" (is "?L \<subseteq> ?R")
+proof -
+ have "?L = {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ by (unfold tRAG_subtree_eq, simp)
+ also have "... \<subseteq> ?R"
+ proof
+ fix x
+ assume "x \<in> {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ then obtain th' where h: "x = Th th'" "Th th' \<in> subtree (RAG s) (Th th)" by auto
+ from this(2)
+ show "x \<in> ?R"
+ proof(cases rule:subtreeE)
+ case 1
+ thus ?thesis by (simp add: assms h(1))
+ next
+ case 2
+ thus ?thesis by (metis ancestors_Field dm_RAG_threads h(1) image_eqI)
+ qed
+ qed
+ finally show ?thesis .
+qed
+
+lemma readys_root:
+ assumes "th \<in> readys s"
+ shows "root (RAG s) (Th th)"
+proof -
+ { fix x
+ assume "x \<in> ancestors (RAG s) (Th th)"
+ hence h: "(Th th, x) \<in> (RAG s)^+" by (auto simp:ancestors_def)
+ from tranclD[OF this]
+ obtain z where "(Th th, z) \<in> RAG s" by auto
+ with assms(1) have False
+ apply (case_tac z, auto simp:readys_def s_RAG_def s_waiting_def cs_waiting_def)
+ by (fold wq_def, blast)
+ } thus ?thesis by (unfold root_def, auto)
+qed
+
+lemma readys_in_no_subtree:
+ assumes "th \<in> readys s"
+ and "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s) (Th th')"
+proof
+ assume "Th th \<in> subtree (RAG s) (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 1
+ with assms show ?thesis by auto
+ next
+ case 2
+ with readys_root[OF assms(1)]
+ show ?thesis by (auto simp:root_def)
+ qed
+qed
+
+lemma not_in_thread_isolated:
+ assumes "th \<notin> threads s"
+ shows "(Th th) \<notin> Field (RAG s)"
+proof
+ assume "(Th th) \<in> Field (RAG s)"
+ with dm_RAG_threads and range_in assms
+ show False by (unfold Field_def, blast)
+qed
+
+lemma wf_RAG: "wf (RAG s)"
+proof(rule finite_acyclic_wf)
+ from finite_RAG show "finite (RAG s)" .
+next
+ from acyclic_RAG show "acyclic (RAG s)" .
+qed
+
+lemma sgv_wRAG: "single_valued (wRAG s)"
+ using waiting_unique
+ by (unfold single_valued_def wRAG_def, auto)
+
+lemma sgv_hRAG: "single_valued (hRAG s)"
+ using holding_unique
+ by (unfold single_valued_def hRAG_def, auto)
+
+lemma sgv_tRAG: "single_valued (tRAG s)"
+ by (unfold tRAG_def, rule single_valued_relcomp,
+ insert sgv_wRAG sgv_hRAG, auto)
+
+lemma acyclic_tRAG: "acyclic (tRAG s)"
+proof(unfold tRAG_def, rule acyclic_compose)
+ show "acyclic (RAG s)" using acyclic_RAG .
+next
+ show "wRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+next
+ show "hRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+qed
+
+lemma sgv_RAG: "single_valued (RAG s)"
+ using unique_RAG by (auto simp:single_valued_def)
+
+lemma rtree_RAG: "rtree (RAG s)"
+ using sgv_RAG acyclic_RAG
+ by (unfold rtree_def rtree_axioms_def sgv_def, auto)
+
+end
+
+sublocale valid_trace < rtree_RAG: rtree "RAG s"
+proof
+ show "single_valued (RAG s)"
+ apply (intro_locales)
+ by (unfold single_valued_def,
+ auto intro:unique_RAG)
+
+ show "acyclic (RAG s)"
+ by (rule acyclic_RAG)
+qed
+
+sublocale valid_trace < rtree_s: rtree "tRAG s"
+proof(unfold_locales)
+ from sgv_tRAG show "single_valued (tRAG s)" .
+next
+ from acyclic_tRAG show "acyclic (tRAG s)" .
+qed
+
+sublocale valid_trace < fsbtRAGs : fsubtree "RAG s"
+proof -
+ show "fsubtree (RAG s)"
+ proof(intro_locales)
+ show "fbranch (RAG s)" using finite_fbranchI[OF finite_RAG] .
+ next
+ show "fsubtree_axioms (RAG s)"
+ proof(unfold fsubtree_axioms_def)
+ from wf_RAG show "wf (RAG s)" .
+ qed
+ qed
+qed
+
+sublocale valid_trace < fsbttRAGs: fsubtree "tRAG s"
+proof -
+ have "fsubtree (tRAG s)"
+ proof -
+ have "fbranch (tRAG s)"
+ proof(unfold tRAG_def, rule fbranch_compose)
+ show "fbranch (wRAG s)"
+ proof(rule finite_fbranchI)
+ from finite_RAG show "finite (wRAG s)"
+ by (unfold RAG_split, auto)
+ qed
+ next
+ show "fbranch (hRAG s)"
+ proof(rule finite_fbranchI)
+ from finite_RAG
+ show "finite (hRAG s)" by (unfold RAG_split, auto)
+ qed
+ qed
+ moreover have "wf (tRAG s)"
+ proof(rule wf_subset)
+ show "wf (RAG s O RAG s)" using wf_RAG
+ by (fold wf_comp_self, simp)
+ next
+ show "tRAG s \<subseteq> (RAG s O RAG s)"
+ by (unfold tRAG_alt_def, auto)
+ qed
+ ultimately show ?thesis
+ by (unfold fsubtree_def fsubtree_axioms_def,auto)
+ qed
+ from this[folded tRAG_def] show "fsubtree (tRAG s)" .
+qed
+
+lemma Max_UNION:
+ assumes "finite A"
+ and "A \<noteq> {}"
+ and "\<forall> M \<in> f ` A. finite M"
+ and "\<forall> M \<in> f ` A. M \<noteq> {}"
+ shows "Max (\<Union>x\<in> A. f x) = Max (Max ` f ` A)" (is "?L = ?R")
+ using assms[simp]
+proof -
+ have "?L = Max (\<Union>(f ` A))"
+ by (fold Union_image_eq, simp)
+ also have "... = ?R"
+ by (subst Max_Union, simp+)
+ finally show ?thesis .
+qed
+
+lemma max_Max_eq:
+ assumes "finite A"
+ and "A \<noteq> {}"
+ and "x = y"
+ shows "max x (Max A) = Max ({y} \<union> A)" (is "?L = ?R")
+proof -
+ have "?R = Max (insert y A)" by simp
+ also from assms have "... = ?L"
+ by (subst Max.insert, simp+)
+ finally show ?thesis by simp
+qed
+
+context valid_trace
+begin
+
+(* ddd *)
+lemma cp_gen_rec:
+ assumes "x = Th th"
+ shows "cp_gen s x = Max ({the_preced s th} \<union> (cp_gen s) ` children (tRAG s) x)"
+proof(cases "children (tRAG s) x = {}")
+ case True
+ show ?thesis
+ by (unfold True cp_gen_def subtree_children, simp add:assms)
+next
+ case False
+ hence [simp]: "children (tRAG s) x \<noteq> {}" by auto
+ note fsbttRAGs.finite_subtree[simp]
+ have [simp]: "finite (children (tRAG s) x)"
+ by (intro rev_finite_subset[OF fsbttRAGs.finite_subtree],
+ rule children_subtree)
+ { fix r x
+ have "subtree r x \<noteq> {}" by (auto simp:subtree_def)
+ } note this[simp]
+ have [simp]: "\<exists>x\<in>children (tRAG s) x. subtree (tRAG s) x \<noteq> {}"
+ proof -
+ from False obtain q where "q \<in> children (tRAG s) x" by blast
+ moreover have "subtree (tRAG s) q \<noteq> {}" by simp
+ ultimately show ?thesis by blast
+ qed
+ have h: "Max ((the_preced s \<circ> the_thread) `
+ ({x} \<union> \<Union>(subtree (tRAG s) ` children (tRAG s) x))) =
+ Max ({the_preced s th} \<union> cp_gen s ` children (tRAG s) x)"
+ (is "?L = ?R")
+ proof -
+ let "Max (?f ` (?A \<union> \<Union> (?g ` ?B)))" = ?L
+ let "Max (_ \<union> (?h ` ?B))" = ?R
+ let ?L1 = "?f ` \<Union>(?g ` ?B)"
+ have eq_Max_L1: "Max ?L1 = Max (?h ` ?B)"
+ proof -
+ have "?L1 = ?f ` (\<Union> x \<in> ?B.(?g x))" by simp
+ also have "... = (\<Union> x \<in> ?B. ?f ` (?g x))" by auto
+ finally have "Max ?L1 = Max ..." by simp
+ also have "... = Max (Max ` (\<lambda>x. ?f ` subtree (tRAG s) x) ` ?B)"
+ by (subst Max_UNION, simp+)
+ also have "... = Max (cp_gen s ` children (tRAG s) x)"
+ by (unfold image_comp cp_gen_alt_def, simp)
+ finally show ?thesis .
+ qed
+ show ?thesis
+ proof -
+ have "?L = Max (?f ` ?A \<union> ?L1)" by simp
+ also have "... = max (the_preced s (the_thread x)) (Max ?L1)"
+ by (subst Max_Un, simp+)
+ also have "... = max (?f x) (Max (?h ` ?B))"
+ by (unfold eq_Max_L1, simp)
+ also have "... =?R"
+ by (rule max_Max_eq, (simp)+, unfold assms, simp)
+ finally show ?thesis .
+ qed
+ qed thus ?thesis
+ by (fold h subtree_children, unfold cp_gen_def, simp)
+qed
+
+lemma cp_rec:
+ "cp s th = Max ({the_preced s th} \<union>
+ (cp s o the_thread) ` children (tRAG s) (Th th))"
+proof -
+ have "Th th = Th th" by simp
+ note h = cp_gen_def_cond[OF this] cp_gen_rec[OF this]
+ show ?thesis
+ proof -
+ have "cp_gen s ` children (tRAG s) (Th th) =
+ (cp s \<circ> the_thread) ` children (tRAG s) (Th th)"
+ proof(rule cp_gen_over_set)
+ show " \<forall>x\<in>children (tRAG s) (Th th). \<exists>th. x = Th th"
+ by (unfold tRAG_alt_def, auto simp:children_def)
+ qed
+ thus ?thesis by (subst (1) h(1), unfold h(2), simp)
+ qed
+qed
+
+end
+
+(* keep *)
+lemma next_th_holding:
+ assumes vt: "vt s"
+ and nxt: "next_th s th cs th'"
+ shows "holding (wq s) th cs"
+proof -
+ from nxt[unfolded next_th_def]
+ obtain rest where h: "wq s cs = th # rest"
+ "rest \<noteq> []"
+ "th' = hd (SOME q. distinct q \<and> set q = set rest)" by auto
+ thus ?thesis
+ by (unfold cs_holding_def, auto)
+qed
+
+context valid_trace
+begin
+
+lemma next_th_waiting:
+ assumes nxt: "next_th s th cs th'"
+ shows "waiting (wq s) th' cs"
+proof -
+ from nxt[unfolded next_th_def]
+ obtain rest where h: "wq s cs = th # rest"
+ "rest \<noteq> []"
+ "th' = hd (SOME q. distinct q \<and> set q = set rest)" by auto
+ from wq_distinct[of cs, unfolded h]
+ have dst: "distinct (th # rest)" .
+ have in_rest: "th' \<in> set rest"
+ proof(unfold h, rule someI2)
+ show "distinct rest \<and> set rest = set rest" using dst by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with h(2)
+ show "hd x \<in> set (rest)" by (cases x, auto)
+ qed
+ hence "th' \<in> set (wq s cs)" by (unfold h(1), auto)
+ moreover have "th' \<noteq> hd (wq s cs)"
+ by (unfold h(1), insert in_rest dst, auto)
+ ultimately show ?thesis by (auto simp:cs_waiting_def)
+qed
+
+lemma next_th_RAG:
+ assumes nxt: "next_th (s::event list) th cs th'"
+ shows "{(Cs cs, Th th), (Th th', Cs cs)} \<subseteq> RAG s"
+ using vt assms next_th_holding next_th_waiting
+ by (unfold s_RAG_def, simp)
+
+end
+
+-- {* A useless definition *}
+definition cps:: "state \<Rightarrow> (thread \<times> precedence) set"
+where "cps s = {(th, cp s th) | th . th \<in> threads s}"
+
+end
--- a/ExtGG.thy Wed May 14 11:52:53 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1046 +0,0 @@
-theory ExtGG
-imports PrioG
-begin
-
-lemma birth_time_lt: "s \<noteq> [] \<Longrightarrow> birthtime th s < length s"
- apply (induct s, simp)
-proof -
- fix a s
- assume ih: "s \<noteq> [] \<Longrightarrow> birthtime th s < length s"
- and eq_as: "a # s \<noteq> []"
- show "birthtime th (a # s) < length (a # s)"
- proof(cases "s \<noteq> []")
- case False
- from False show ?thesis
- by (cases a, auto simp:birthtime.simps)
- next
- case True
- from ih [OF True] show ?thesis
- by (cases a, auto simp:birthtime.simps)
- qed
-qed
-
-lemma th_in_ne: "th \<in> threads s \<Longrightarrow> s \<noteq> []"
- by (induct s, auto simp:threads.simps)
-
-lemma preced_tm_lt: "th \<in> threads s \<Longrightarrow> preced th s = Prc x y \<Longrightarrow> y < length s"
- apply (drule_tac th_in_ne)
- by (unfold preced_def, auto intro: birth_time_lt)
-
-locale highest_gen =
- fixes s th prio tm
- assumes vt_s: "vt s"
- and threads_s: "th \<in> threads s"
- and highest: "preced th s = Max ((cp s)`threads s)"
- and preced_th: "preced th s = Prc prio tm"
-
-context highest_gen
-begin
-
-
-
-lemma lt_tm: "tm < length s"
- by (insert preced_tm_lt[OF threads_s preced_th], simp)
-
-lemma eq_cp_s_th: "cp s th = preced th s"
-proof -
- from highest and max_cp_eq[OF vt_s]
- have is_max: "preced th s = Max ((\<lambda>th. preced th s) ` threads s)" by simp
- have sbs: "({th} \<union> dependents (wq s) th) \<subseteq> threads s"
- proof -
- from threads_s and dependents_threads[OF vt_s, of th]
- show ?thesis by auto
- qed
- show ?thesis
- proof(unfold cp_eq_cpreced cpreced_def, rule Max_eqI)
- show "preced th s \<in> (\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th)" by simp
- next
- fix y
- assume "y \<in> (\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th)"
- then obtain th1 where th1_in: "th1 \<in> ({th} \<union> dependents (wq s) th)"
- and eq_y: "y = preced th1 s" by auto
- show "y \<le> preced th s"
- proof(unfold is_max, rule Max_ge)
- from finite_threads[OF vt_s]
- show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
- next
- from sbs th1_in and eq_y
- show "y \<in> (\<lambda>th. preced th s) ` threads s" by auto
- qed
- next
- from sbs and finite_threads[OF vt_s]
- show "finite ((\<lambda>th. preced th s) ` ({th} \<union> dependents (wq s) th))"
- by (auto intro:finite_subset)
- qed
-qed
-
-lemma highest_cp_preced: "cp s th = Max ((\<lambda> th'. preced th' s) ` threads s)"
- by (fold max_cp_eq[OF vt_s], unfold eq_cp_s_th, insert highest, simp)
-
-lemma highest_preced_thread: "preced th s = Max ((\<lambda> th'. preced th' s) ` threads s)"
- by (fold eq_cp_s_th, unfold highest_cp_preced, simp)
-
-lemma highest': "cp s th = Max (cp s ` threads s)"
-proof -
- from highest_cp_preced max_cp_eq[OF vt_s, symmetric]
- show ?thesis by simp
-qed
-
-end
-
-locale extend_highest_gen = highest_gen +
- fixes t
- assumes vt_t: "vt (t@s)"
- and create_low: "Create th' prio' \<in> set t \<Longrightarrow> prio' \<le> prio"
- and set_diff_low: "Set th' prio' \<in> set t \<Longrightarrow> th' \<noteq> th \<and> prio' \<le> prio"
- and exit_diff: "Exit th' \<in> set t \<Longrightarrow> th' \<noteq> th"
-
-lemma step_back_vt_app:
- assumes vt_ts: "vt (t@s)"
- shows "vt s"
-proof -
- from vt_ts show ?thesis
- proof(induct t)
- case Nil
- from Nil show ?case by auto
- next
- case (Cons e t)
- assume ih: " vt (t @ s) \<Longrightarrow> vt s"
- and vt_et: "vt ((e # t) @ s)"
- show ?case
- proof(rule ih)
- show "vt (t @ s)"
- proof(rule step_back_vt)
- from vt_et show "vt (e # t @ s)" by simp
- qed
- qed
- qed
-qed
-
-context extend_highest_gen
-begin
-
-thm extend_highest_gen_axioms_def
-
-lemma red_moment:
- "extend_highest_gen s th prio tm (moment i t)"
- apply (insert extend_highest_gen_axioms, subst (asm) (1) moment_restm_s [of i t, symmetric])
- apply (unfold extend_highest_gen_def extend_highest_gen_axioms_def, clarsimp)
- by (unfold highest_gen_def, auto dest:step_back_vt_app)
-
-lemma ind [consumes 0, case_names Nil Cons, induct type]:
- assumes
- h0: "R []"
- and h2: "\<And> e t. \<lbrakk>vt (t@s); step (t@s) e;
- extend_highest_gen s th prio tm t;
- extend_highest_gen s th prio tm (e#t); R t\<rbrakk> \<Longrightarrow> R (e#t)"
- shows "R t"
-proof -
- from vt_t extend_highest_gen_axioms show ?thesis
- proof(induct t)
- from h0 show "R []" .
- next
- case (Cons e t')
- assume ih: "\<lbrakk>vt (t' @ s); extend_highest_gen s th prio tm t'\<rbrakk> \<Longrightarrow> R t'"
- and vt_e: "vt ((e # t') @ s)"
- and et: "extend_highest_gen s th prio tm (e # t')"
- from vt_e and step_back_step have stp: "step (t'@s) e" by auto
- from vt_e and step_back_vt have vt_ts: "vt (t'@s)" by auto
- show ?case
- proof(rule h2 [OF vt_ts stp _ _ _ ])
- show "R t'"
- proof(rule ih)
- from et show ext': "extend_highest_gen s th prio tm t'"
- by (unfold extend_highest_gen_def extend_highest_gen_axioms_def, auto dest:step_back_vt)
- next
- from vt_ts show "vt (t' @ s)" .
- qed
- next
- from et show "extend_highest_gen s th prio tm (e # t')" .
- next
- from et show ext': "extend_highest_gen s th prio tm t'"
- by (unfold extend_highest_gen_def extend_highest_gen_axioms_def, auto dest:step_back_vt)
- qed
- qed
-qed
-
-lemma th_kept: "th \<in> threads (t @ s) \<and>
- preced th (t@s) = preced th s" (is "?Q t")
-proof -
- show ?thesis
- proof(induct rule:ind)
- case Nil
- from threads_s
- show "th \<in> threads ([] @ s) \<and> preced th ([] @ s) = preced th s"
- by auto
- next
- case (Cons e t)
- show ?case
- proof(cases e)
- case (Create thread prio)
- assume eq_e: " e = Create thread prio"
- show ?thesis
- proof -
- from Cons and eq_e have "step (t@s) (Create thread prio)" by auto
- hence "th \<noteq> thread"
- proof(cases)
- assume "thread \<notin> threads (t @ s)"
- with Cons show ?thesis by auto
- qed
- hence "preced th ((e # t) @ s) = preced th (t @ s)"
- by (unfold eq_e, auto simp:preced_def)
- moreover note Cons
- ultimately show ?thesis
- by (auto simp:eq_e)
- qed
- next
- case (Exit thread)
- assume eq_e: "e = Exit thread"
- from Cons have "extend_highest_gen s th prio tm (e # t)" by auto
- from extend_highest_gen.exit_diff [OF this] and eq_e
- have neq_th: "thread \<noteq> th" by auto
- with Cons
- show ?thesis
- by (unfold eq_e, auto simp:preced_def)
- next
- case (P thread cs)
- assume eq_e: "e = P thread cs"
- with Cons
- show ?thesis
- by (auto simp:eq_e preced_def)
- next
- case (V thread cs)
- assume eq_e: "e = V thread cs"
- with Cons
- show ?thesis
- by (auto simp:eq_e preced_def)
- next
- case (Set thread prio')
- assume eq_e: " e = Set thread prio'"
- show ?thesis
- proof -
- from Cons have "extend_highest_gen s th prio tm (e # t)" by auto
- from extend_highest_gen.set_diff_low[OF this] and eq_e
- have "th \<noteq> thread" by auto
- hence "preced th ((e # t) @ s) = preced th (t @ s)"
- by (unfold eq_e, auto simp:preced_def)
- moreover note Cons
- ultimately show ?thesis
- by (auto simp:eq_e)
- qed
- qed
- qed
-qed
-
-lemma max_kept: "Max ((\<lambda> th'. preced th' (t @ s)) ` (threads (t@s))) = preced th s"
-proof(induct rule:ind)
- case Nil
- from highest_preced_thread
- show "Max ((\<lambda>th'. preced th' ([] @ s)) ` threads ([] @ s)) = preced th s"
- by simp
-next
- case (Cons e t)
- show ?case
- proof(cases e)
- case (Create thread prio')
- assume eq_e: " e = Create thread prio'"
- from Cons and eq_e have stp: "step (t@s) (Create thread prio')" by auto
- hence neq_thread: "thread \<noteq> th"
- proof(cases)
- assume "thread \<notin> threads (t @ s)"
- moreover have "th \<in> threads (t@s)"
- proof -
- from Cons have "extend_highest_gen s th prio tm t" by auto
- from extend_highest_gen.th_kept[OF this] show ?thesis by (simp)
- qed
- ultimately show ?thesis by auto
- qed
- from Cons have "extend_highest_gen s th prio tm t" by auto
- from extend_highest_gen.th_kept[OF this]
- have h': " th \<in> threads (t @ s) \<and> preced th (t @ s) = preced th s"
- by (auto)
- from stp
- have thread_ts: "thread \<notin> threads (t @ s)"
- by (cases, auto)
- show ?thesis (is "Max (?f ` ?A) = ?t")
- proof -
- have "Max (?f ` ?A) = Max(insert (?f thread) (?f ` (threads (t@s))))"
- by (unfold eq_e, simp)
- moreover have "\<dots> = max (?f thread) (Max (?f ` (threads (t@s))))"
- proof(rule Max_insert)
- from Cons have "vt (t @ s)" by auto
- from finite_threads[OF this]
- show "finite (?f ` (threads (t@s)))" by simp
- next
- from h' show "(?f ` (threads (t@s))) \<noteq> {}" by auto
- qed
- moreover have "(Max (?f ` (threads (t@s)))) = ?t"
- proof -
- have "(\<lambda>th'. preced th' ((e # t) @ s)) ` threads (t @ s) =
- (\<lambda>th'. preced th' (t @ s)) ` threads (t @ s)" (is "?f1 ` ?B = ?f2 ` ?B")
- proof -
- { fix th'
- assume "th' \<in> ?B"
- with thread_ts eq_e
- have "?f1 th' = ?f2 th'" by (auto simp:preced_def)
- } thus ?thesis
- apply (auto simp:Image_def)
- proof -
- fix th'
- assume h: "\<And>th'. th' \<in> threads (t @ s) \<Longrightarrow>
- preced th' (e # t @ s) = preced th' (t @ s)"
- and h1: "th' \<in> threads (t @ s)"
- show "preced th' (t @ s) \<in> (\<lambda>th'. preced th' (e # t @ s)) ` threads (t @ s)"
- proof -
- from h1 have "?f1 th' \<in> ?f1 ` ?B" by auto
- moreover from h[OF h1] have "?f1 th' = ?f2 th'" by simp
- ultimately show ?thesis by simp
- qed
- qed
- qed
- with Cons show ?thesis by auto
- qed
- moreover have "?f thread < ?t"
- proof -
- from Cons have "extend_highest_gen s th prio tm (e # t)" by auto
- from extend_highest_gen.create_low[OF this] and eq_e
- have "prio' \<le> prio" by auto
- thus ?thesis
- by (unfold preced_th, unfold eq_e, insert lt_tm,
- auto simp:preced_def precedence_less_def preced_th)
- qed
- ultimately show ?thesis by (auto simp:max_def)
- qed
-next
- case (Exit thread)
- assume eq_e: "e = Exit thread"
- from Cons have vt_e: "vt (e#(t @ s))" by auto
- from Cons and eq_e have stp: "step (t@s) (Exit thread)" by auto
- from stp have thread_ts: "thread \<in> threads (t @ s)"
- by(cases, unfold runing_def readys_def, auto)
- from Cons have "extend_highest_gen s th prio tm (e # t)" by auto
- from extend_highest_gen.exit_diff[OF this] and eq_e
- have neq_thread: "thread \<noteq> th" by auto
- from Cons have "extend_highest_gen s th prio tm t" by auto
- from extend_highest_gen.th_kept[OF this]
- have h': "th \<in> threads (t @ s) \<and> preced th (t @ s) = preced th s" .
- show ?thesis (is "Max (?f ` ?A) = ?t")
- proof -
- have "threads (t@s) = insert thread ?A"
- by (insert stp thread_ts, unfold eq_e, auto)
- hence "Max (?f ` (threads (t@s))) = Max (?f ` \<dots>)" by simp
- also from this have "\<dots> = Max (insert (?f thread) (?f ` ?A))" by simp
- also have "\<dots> = max (?f thread) (Max (?f ` ?A))"
- proof(rule Max_insert)
- from finite_threads [OF vt_e]
- show "finite (?f ` ?A)" by simp
- next
- from Cons have "extend_highest_gen s th prio tm (e # t)" by auto
- from extend_highest_gen.th_kept[OF this]
- show "?f ` ?A \<noteq> {}" by auto
- qed
- finally have "Max (?f ` (threads (t@s))) = max (?f thread) (Max (?f ` ?A))" .
- moreover have "Max (?f ` (threads (t@s))) = ?t"
- proof -
- from Cons show ?thesis
- by (unfold eq_e, auto simp:preced_def)
- qed
- ultimately have "max (?f thread) (Max (?f ` ?A)) = ?t" by simp
- moreover have "?f thread < ?t"
- proof(unfold eq_e, simp add:preced_def, fold preced_def)
- show "preced thread (t @ s) < ?t"
- proof -
- have "preced thread (t @ s) \<le> ?t"
- proof -
- from Cons
- have "?t = Max ((\<lambda>th'. preced th' (t @ s)) ` threads (t @ s))"
- (is "?t = Max (?g ` ?B)") by simp
- moreover have "?g thread \<le> \<dots>"
- proof(rule Max_ge)
- have "vt (t@s)" by fact
- from finite_threads [OF this]
- show "finite (?g ` ?B)" by simp
- next
- from thread_ts
- show "?g thread \<in> (?g ` ?B)" by auto
- qed
- ultimately show ?thesis by auto
- qed
- moreover have "preced thread (t @ s) \<noteq> ?t"
- proof
- assume "preced thread (t @ s) = preced th s"
- with h' have "preced thread (t @ s) = preced th (t@s)" by simp
- from preced_unique [OF this] have "thread = th"
- proof
- from h' show "th \<in> threads (t @ s)" by simp
- next
- from thread_ts show "thread \<in> threads (t @ s)" .
- qed(simp)
- with neq_thread show "False" by simp
- qed
- ultimately show ?thesis by auto
- qed
- qed
- ultimately show ?thesis
- by (auto simp:max_def split:if_splits)
- qed
- next
- case (P thread cs)
- with Cons
- show ?thesis by (auto simp:preced_def)
- next
- case (V thread cs)
- with Cons
- show ?thesis by (auto simp:preced_def)
- next
- case (Set thread prio')
- show ?thesis (is "Max (?f ` ?A) = ?t")
- proof -
- let ?B = "threads (t@s)"
- from Cons have "extend_highest_gen s th prio tm (e # t)" by auto
- from extend_highest_gen.set_diff_low[OF this] and Set
- have neq_thread: "thread \<noteq> th" and le_p: "prio' \<le> prio" by auto
- from Set have "Max (?f ` ?A) = Max (?f ` ?B)" by simp
- also have "\<dots> = ?t"
- proof(rule Max_eqI)
- fix y
- assume y_in: "y \<in> ?f ` ?B"
- then obtain th1 where
- th1_in: "th1 \<in> ?B" and eq_y: "y = ?f th1" by auto
- show "y \<le> ?t"
- proof(cases "th1 = thread")
- case True
- with neq_thread le_p eq_y Set
- show ?thesis
- apply (subst preced_th, insert lt_tm)
- by (auto simp:preced_def precedence_le_def)
- next
- case False
- with Set eq_y
- have "y = preced th1 (t@s)"
- by (simp add:preced_def)
- moreover have "\<dots> \<le> ?t"
- proof -
- from Cons
- have "?t = Max ((\<lambda> th'. preced th' (t@s)) ` (threads (t@s)))"
- by auto
- moreover have "preced th1 (t@s) \<le> \<dots>"
- proof(rule Max_ge)
- from th1_in
- show "preced th1 (t @ s) \<in> (\<lambda>th'. preced th' (t @ s)) ` threads (t @ s)"
- by simp
- next
- show "finite ((\<lambda>th'. preced th' (t @ s)) ` threads (t @ s))"
- proof -
- from Cons have "vt (t @ s)" by auto
- from finite_threads[OF this] show ?thesis by auto
- qed
- qed
- ultimately show ?thesis by auto
- qed
- ultimately show ?thesis by auto
- qed
- next
- from Cons and finite_threads
- show "finite (?f ` ?B)" by auto
- next
- from Cons have "extend_highest_gen s th prio tm t" by auto
- from extend_highest_gen.th_kept [OF this]
- have h: "th \<in> threads (t @ s) \<and> preced th (t @ s) = preced th s" .
- show "?t \<in> (?f ` ?B)"
- proof -
- from neq_thread Set h
- have "?t = ?f th" by (auto simp:preced_def)
- with h show ?thesis by auto
- qed
- qed
- finally show ?thesis .
- qed
- qed
-qed
-
-lemma max_preced: "preced th (t@s) = Max ((\<lambda> th'. preced th' (t @ s)) ` (threads (t@s)))"
- by (insert th_kept max_kept, auto)
-
-lemma th_cp_max_preced: "cp (t@s) th = Max ((\<lambda> th'. preced th' (t @ s)) ` (threads (t@s)))"
- (is "?L = ?R")
-proof -
- have "?L = cpreced (wq (t@s)) (t@s) th"
- by (unfold cp_eq_cpreced, simp)
- also have "\<dots> = ?R"
- proof(unfold cpreced_def)
- show "Max ((\<lambda>th. preced th (t @ s)) ` ({th} \<union> dependents (wq (t @ s)) th)) =
- Max ((\<lambda>th'. preced th' (t @ s)) ` threads (t @ s))"
- (is "Max (?f ` ({th} \<union> ?A)) = Max (?f ` ?B)")
- proof(cases "?A = {}")
- case False
- have "Max (?f ` ({th} \<union> ?A)) = Max (insert (?f th) (?f ` ?A))" by simp
- moreover have "\<dots> = max (?f th) (Max (?f ` ?A))"
- proof(rule Max_insert)
- show "finite (?f ` ?A)"
- proof -
- from dependents_threads[OF vt_t]
- have "?A \<subseteq> threads (t@s)" .
- moreover from finite_threads[OF vt_t] have "finite \<dots>" .
- ultimately show ?thesis
- by (auto simp:finite_subset)
- qed
- next
- from False show "(?f ` ?A) \<noteq> {}" by simp
- qed
- moreover have "\<dots> = Max (?f ` ?B)"
- proof -
- from max_preced have "?f th = Max (?f ` ?B)" .
- moreover have "Max (?f ` ?A) \<le> \<dots>"
- proof(rule Max_mono)
- from False show "(?f ` ?A) \<noteq> {}" by simp
- next
- show "?f ` ?A \<subseteq> ?f ` ?B"
- proof -
- have "?A \<subseteq> ?B" by (rule dependents_threads[OF vt_t])
- thus ?thesis by auto
- qed
- next
- from finite_threads[OF vt_t]
- show "finite (?f ` ?B)" by simp
- qed
- ultimately show ?thesis
- by (auto simp:max_def)
- qed
- ultimately show ?thesis by auto
- next
- case True
- with max_preced show ?thesis by auto
- qed
- qed
- finally show ?thesis .
-qed
-
-lemma th_cp_max: "cp (t@s) th = Max (cp (t@s) ` threads (t@s))"
- by (unfold max_cp_eq[OF vt_t] th_cp_max_preced, simp)
-
-lemma th_cp_preced: "cp (t@s) th = preced th s"
- by (fold max_kept, unfold th_cp_max_preced, simp)
-
-lemma preced_less:
- fixes th'
- assumes th'_in: "th' \<in> threads s"
- and neq_th': "th' \<noteq> th"
- shows "preced th' s < preced th s"
-proof -
- have "preced th' s \<le> Max ((\<lambda>th'. preced th' s) ` threads s)"
- proof(rule Max_ge)
- from finite_threads [OF vt_s]
- show "finite ((\<lambda>th'. preced th' s) ` threads s)" by simp
- next
- from th'_in show "preced th' s \<in> (\<lambda>th'. preced th' s) ` threads s"
- by simp
- qed
- moreover have "preced th' s \<noteq> preced th s"
- proof
- assume "preced th' s = preced th s"
- from preced_unique[OF this th'_in] neq_th' threads_s
- show "False" by (auto simp:readys_def)
- qed
- ultimately show ?thesis using highest_preced_thread
- by auto
-qed
-
-lemma pv_blocked_pre:
- fixes th'
- assumes th'_in: "th' \<in> threads (t@s)"
- and neq_th': "th' \<noteq> th"
- and eq_pv: "cntP (t@s) th' = cntV (t@s) th'"
- shows "th' \<notin> runing (t@s)"
-proof
- assume "th' \<in> runing (t@s)"
- hence "cp (t@s) th' = Max (cp (t@s) ` readys (t@s))"
- by (auto simp:runing_def)
- with max_cp_readys_threads [OF vt_t]
- have "cp (t @ s) th' = Max (cp (t@s) ` threads (t@s))"
- by auto
- moreover from th_cp_max have "cp (t @ s) th = \<dots>" by simp
- ultimately have "cp (t @ s) th' = cp (t @ s) th" by simp
- moreover from th_cp_preced and th_kept have "\<dots> = preced th (t @ s)"
- by simp
- finally have h: "cp (t @ s) th' = preced th (t @ s)" .
- show False
- proof -
- have "dependents (wq (t @ s)) th' = {}"
- by (rule count_eq_dependents [OF vt_t eq_pv])
- moreover have "preced th' (t @ s) \<noteq> preced th (t @ s)"
- proof
- assume "preced th' (t @ s) = preced th (t @ s)"
- hence "th' = th"
- proof(rule preced_unique)
- from th_kept show "th \<in> threads (t @ s)" by simp
- next
- from th'_in show "th' \<in> threads (t @ s)" by simp
- qed
- with assms show False by simp
- qed
- ultimately show ?thesis
- by (insert h, unfold cp_eq_cpreced cpreced_def, simp)
- qed
-qed
-
-lemmas pv_blocked = pv_blocked_pre[folded detached_eq [OF vt_t]]
-
-lemma runing_precond_pre:
- fixes th'
- assumes th'_in: "th' \<in> threads s"
- and eq_pv: "cntP s th' = cntV s th'"
- and neq_th': "th' \<noteq> th"
- shows "th' \<in> threads (t@s) \<and>
- cntP (t@s) th' = cntV (t@s) th'"
-proof -
- show ?thesis
- proof(induct rule:ind)
- case (Cons e t)
- from Cons
- have in_thread: "th' \<in> threads (t @ s)"
- and not_holding: "cntP (t @ s) th' = cntV (t @ s) th'" by auto
- from Cons have "extend_highest_gen s th prio tm t" by auto
- then have not_runing: "th' \<notin> runing (t @ s)"
- apply(rule extend_highest_gen.pv_blocked)
- using Cons(1) in_thread neq_th' not_holding
- apply(simp_all add: detached_eq)
- done
- show ?case
- proof(cases e)
- case (V thread cs)
- from Cons and V have vt_v: "vt (V thread cs#(t@s))" by auto
-
- show ?thesis
- proof -
- from Cons and V have "step (t@s) (V thread cs)" by auto
- hence neq_th': "thread \<noteq> th'"
- proof(cases)
- assume "thread \<in> runing (t@s)"
- moreover have "th' \<notin> runing (t@s)" by fact
- ultimately show ?thesis by auto
- qed
- with not_holding have cnt_eq: "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'"
- by (unfold V, simp add:cntP_def cntV_def count_def)
- moreover from in_thread
- have in_thread': "th' \<in> threads ((e # t) @ s)" by (unfold V, simp)
- ultimately show ?thesis by auto
- qed
- next
- case (P thread cs)
- from Cons and P have "step (t@s) (P thread cs)" by auto
- hence neq_th': "thread \<noteq> th'"
- proof(cases)
- assume "thread \<in> runing (t@s)"
- moreover note not_runing
- ultimately show ?thesis by auto
- qed
- with Cons and P have eq_cnt: "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'"
- by (auto simp:cntP_def cntV_def count_def)
- moreover from Cons and P have in_thread': "th' \<in> threads ((e # t) @ s)"
- by auto
- ultimately show ?thesis by auto
- next
- case (Create thread prio')
- from Cons and Create have "step (t@s) (Create thread prio')" by auto
- hence neq_th': "thread \<noteq> th'"
- proof(cases)
- assume "thread \<notin> threads (t @ s)"
- moreover have "th' \<in> threads (t@s)" by fact
- ultimately show ?thesis by auto
- qed
- with Cons and Create
- have eq_cnt: "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'"
- by (auto simp:cntP_def cntV_def count_def)
- moreover from Cons and Create
- have in_thread': "th' \<in> threads ((e # t) @ s)" by auto
- ultimately show ?thesis by auto
- next
- case (Exit thread)
- from Cons and Exit have "step (t@s) (Exit thread)" by auto
- hence neq_th': "thread \<noteq> th'"
- proof(cases)
- assume "thread \<in> runing (t @ s)"
- moreover note not_runing
- ultimately show ?thesis by auto
- qed
- with Cons and Exit
- have eq_cnt: "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'"
- by (auto simp:cntP_def cntV_def count_def)
- moreover from Cons and Exit and neq_th'
- have in_thread': "th' \<in> threads ((e # t) @ s)"
- by auto
- ultimately show ?thesis by auto
- next
- case (Set thread prio')
- with Cons
- show ?thesis
- by (auto simp:cntP_def cntV_def count_def)
- qed
- next
- case Nil
- with assms
- show ?case by auto
- qed
-qed
-
-(*
-lemma runing_precond:
- fixes th'
- assumes th'_in: "th' \<in> threads s"
- and eq_pv: "cntP s th' = cntV s th'"
- and neq_th': "th' \<noteq> th"
- shows "th' \<notin> runing (t@s)"
-proof -
- from runing_precond_pre[OF th'_in eq_pv neq_th']
- have h1: "th' \<in> threads (t @ s)" and h2: "cntP (t @ s) th' = cntV (t @ s) th'" by auto
- from pv_blocked[OF h1 neq_th' h2]
- show ?thesis .
-qed
-*)
-
-lemmas runing_precond_pre_dtc = runing_precond_pre[folded detached_eq[OF vt_t] detached_eq[OF vt_s]]
-
-lemma runing_precond:
- fixes th'
- assumes th'_in: "th' \<in> threads s"
- and neq_th': "th' \<noteq> th"
- and is_runing: "th' \<in> runing (t@s)"
- shows "cntP s th' > cntV s th'"
-proof -
- have "cntP s th' \<noteq> cntV s th'"
- proof
- assume eq_pv: "cntP s th' = cntV s th'"
- from runing_precond_pre[OF th'_in eq_pv neq_th']
- have h1: "th' \<in> threads (t @ s)"
- and h2: "cntP (t @ s) th' = cntV (t @ s) th'" by auto
- from pv_blocked_pre[OF h1 neq_th' h2] have " th' \<notin> runing (t @ s)" .
- with is_runing show "False" by simp
- qed
- moreover from cnp_cnv_cncs[OF vt_s, of th']
- have "cntV s th' \<le> cntP s th'" by auto
- ultimately show ?thesis by auto
-qed
-
-lemma moment_blocked_pre:
- assumes neq_th': "th' \<noteq> th"
- and th'_in: "th' \<in> threads ((moment i t)@s)"
- and eq_pv: "cntP ((moment i t)@s) th' = cntV ((moment i t)@s) th'"
- shows "cntP ((moment (i+j) t)@s) th' = cntV ((moment (i+j) t)@s) th' \<and>
- th' \<in> threads ((moment (i+j) t)@s)"
-proof(induct j)
- case (Suc k)
- show ?case
- proof -
- { assume True: "Suc (i+k) \<le> length t"
- from moment_head [OF this]
- obtain e where
- eq_me: "moment (Suc(i+k)) t = e#(moment (i+k) t)"
- by blast
- from red_moment[of "Suc(i+k)"]
- and eq_me have "extend_highest_gen s th prio tm (e # moment (i + k) t)" by simp
- hence vt_e: "vt (e#(moment (i + k) t)@s)"
- by (unfold extend_highest_gen_def extend_highest_gen_axioms_def
- highest_gen_def, auto)
- have not_runing': "th' \<notin> runing (moment (i + k) t @ s)"
- proof -
- show "th' \<notin> runing (moment (i + k) t @ s)"
- proof(rule extend_highest_gen.pv_blocked)
- from Suc show "th' \<in> threads (moment (i + k) t @ s)"
- by simp
- next
- from neq_th' show "th' \<noteq> th" .
- next
- from red_moment show "extend_highest_gen s th prio tm (moment (i + k) t)" .
- next
- from Suc vt_e show "detached (moment (i + k) t @ s) th'"
- apply(subst detached_eq)
- apply(auto intro: vt_e evt_cons)
- done
- qed
- qed
- from step_back_step[OF vt_e]
- have "step ((moment (i + k) t)@s) e" .
- hence "cntP (e#(moment (i + k) t)@s) th' = cntV (e#(moment (i + k) t)@s) th' \<and>
- th' \<in> threads (e#(moment (i + k) t)@s)"
- proof(cases)
- case (thread_create thread prio)
- with Suc show ?thesis by (auto simp:cntP_def cntV_def count_def)
- next
- case (thread_exit thread)
- moreover have "thread \<noteq> th'"
- proof -
- have "thread \<in> runing (moment (i + k) t @ s)" by fact
- moreover note not_runing'
- ultimately show ?thesis by auto
- qed
- moreover note Suc
- ultimately show ?thesis by (auto simp:cntP_def cntV_def count_def)
- next
- case (thread_P thread cs)
- moreover have "thread \<noteq> th'"
- proof -
- have "thread \<in> runing (moment (i + k) t @ s)" by fact
- moreover note not_runing'
- ultimately show ?thesis by auto
- qed
- moreover note Suc
- ultimately show ?thesis by (auto simp:cntP_def cntV_def count_def)
- next
- case (thread_V thread cs)
- moreover have "thread \<noteq> th'"
- proof -
- have "thread \<in> runing (moment (i + k) t @ s)" by fact
- moreover note not_runing'
- ultimately show ?thesis by auto
- qed
- moreover note Suc
- ultimately show ?thesis by (auto simp:cntP_def cntV_def count_def)
- next
- case (thread_set thread prio')
- with Suc show ?thesis
- by (auto simp:cntP_def cntV_def count_def)
- qed
- with eq_me have ?thesis using eq_me by auto
- } note h = this
- show ?thesis
- proof(cases "Suc (i+k) \<le> length t")
- case True
- from h [OF this] show ?thesis .
- next
- case False
- with moment_ge
- have eq_m: "moment (i + Suc k) t = moment (i+k) t" by auto
- with Suc show ?thesis by auto
- qed
- qed
-next
- case 0
- from assms show ?case by auto
-qed
-
-lemma moment_blocked_eqpv:
- assumes neq_th': "th' \<noteq> th"
- and th'_in: "th' \<in> threads ((moment i t)@s)"
- and eq_pv: "cntP ((moment i t)@s) th' = cntV ((moment i t)@s) th'"
- and le_ij: "i \<le> j"
- shows "cntP ((moment j t)@s) th' = cntV ((moment j t)@s) th' \<and>
- th' \<in> threads ((moment j t)@s) \<and>
- th' \<notin> runing ((moment j t)@s)"
-proof -
- from moment_blocked_pre [OF neq_th' th'_in eq_pv, of "j-i"] and le_ij
- have h1: "cntP ((moment j t)@s) th' = cntV ((moment j t)@s) th'"
- and h2: "th' \<in> threads ((moment j t)@s)" by auto
- with extend_highest_gen.pv_blocked
- show ?thesis
- using red_moment [of j] h2 neq_th' h1
- apply(auto)
- by (metis extend_highest_gen.pv_blocked_pre)
-qed
-
-lemma moment_blocked:
- assumes neq_th': "th' \<noteq> th"
- and th'_in: "th' \<in> threads ((moment i t)@s)"
- and dtc: "detached (moment i t @ s) th'"
- and le_ij: "i \<le> j"
- shows "detached (moment j t @ s) th' \<and>
- th' \<in> threads ((moment j t)@s) \<and>
- th' \<notin> runing ((moment j t)@s)"
-proof -
- from vt_moment[OF vt_t, of "i+length s"] moment_prefix[of i t s]
- have vt_i: "vt (moment i t @ s)" by auto
- from vt_moment[OF vt_t, of "j+length s"] moment_prefix[of j t s]
- have vt_j: "vt (moment j t @ s)" by auto
- from moment_blocked_eqpv [OF neq_th' th'_in detached_elim [OF vt_i dtc] le_ij,
- folded detached_eq[OF vt_j]]
- show ?thesis .
-qed
-
-lemma runing_inversion_1:
- assumes neq_th': "th' \<noteq> th"
- and runing': "th' \<in> runing (t@s)"
- shows "th' \<in> threads s \<and> cntV s th' < cntP s th'"
-proof(cases "th' \<in> threads s")
- case True
- with runing_precond [OF this neq_th' runing'] show ?thesis by simp
-next
- case False
- let ?Q = "\<lambda> t. th' \<in> threads (t@s)"
- let ?q = "moment 0 t"
- from moment_eq and False have not_thread: "\<not> ?Q ?q" by simp
- from runing' have "th' \<in> threads (t@s)" by (simp add:runing_def readys_def)
- from p_split_gen [of ?Q, OF this not_thread]
- obtain i where lt_its: "i < length t"
- and le_i: "0 \<le> i"
- and pre: " th' \<notin> threads (moment i t @ s)" (is "th' \<notin> threads ?pre")
- and post: "(\<forall>i'>i. th' \<in> threads (moment i' t @ s))" by auto
- from lt_its have "Suc i \<le> length t" by auto
- from moment_head[OF this] obtain e where
- eq_me: "moment (Suc i) t = e # moment i t" by blast
- from red_moment[of "Suc i"] and eq_me
- have "extend_highest_gen s th prio tm (e # moment i t)" by simp
- hence vt_e: "vt (e#(moment i t)@s)"
- by (unfold extend_highest_gen_def extend_highest_gen_axioms_def
- highest_gen_def, auto)
- from step_back_step[OF this] have stp_i: "step (moment i t @ s) e" .
- from post[rule_format, of "Suc i"] and eq_me
- have not_in': "th' \<in> threads (e # moment i t@s)" by auto
- from create_pre[OF stp_i pre this]
- obtain prio where eq_e: "e = Create th' prio" .
- have "cntP (moment i t@s) th' = cntV (moment i t@s) th'"
- proof(rule cnp_cnv_eq)
- from step_back_vt [OF vt_e]
- show "vt (moment i t @ s)" .
- next
- from eq_e and stp_i
- have "step (moment i t @ s) (Create th' prio)" by simp
- thus "th' \<notin> threads (moment i t @ s)" by (cases, simp)
- qed
- with eq_e
- have "cntP ((e#moment i t)@s) th' = cntV ((e#moment i t)@s) th'"
- by (simp add:cntP_def cntV_def count_def)
- with eq_me[symmetric]
- have h1: "cntP (moment (Suc i) t @ s) th' = cntV (moment (Suc i) t@ s) th'"
- by simp
- from eq_e have "th' \<in> threads ((e#moment i t)@s)" by simp
- with eq_me [symmetric]
- have h2: "th' \<in> threads (moment (Suc i) t @ s)" by simp
- from moment_blocked_eqpv [OF neq_th' h2 h1, of "length t"] and lt_its
- and moment_ge
- have "th' \<notin> runing (t @ s)" by auto
- with runing'
- show ?thesis by auto
-qed
-
-lemma runing_inversion_2:
- assumes runing': "th' \<in> runing (t@s)"
- shows "th' = th \<or> (th' \<noteq> th \<and> th' \<in> threads s \<and> cntV s th' < cntP s th')"
-proof -
- from runing_inversion_1[OF _ runing']
- show ?thesis by auto
-qed
-
-lemma runing_preced_inversion:
- assumes runing': "th' \<in> runing (t@s)"
- shows "cp (t@s) th' = preced th s"
-proof -
- from runing' have "cp (t@s) th' = Max (cp (t @ s) ` readys (t @ s))"
- by (unfold runing_def, auto)
- also have "\<dots> = preced th s"
- proof -
- from max_cp_readys_threads[OF vt_t]
- have "\<dots> = Max (cp (t @ s) ` threads (t @ s))" .
- also have "\<dots> = preced th s"
- proof -
- from max_kept
- and max_cp_eq [OF vt_t]
- show ?thesis by auto
- qed
- finally show ?thesis .
- qed
- finally show ?thesis .
-qed
-
-lemma runing_inversion_3:
- assumes runing': "th' \<in> runing (t@s)"
- and neq_th: "th' \<noteq> th"
- shows "th' \<in> threads s \<and> (cntV s th' < cntP s th' \<and> cp (t@s) th' = preced th s)"
-proof -
- from runing_inversion_2 [OF runing']
- and neq_th
- and runing_preced_inversion[OF runing']
- show ?thesis by auto
-qed
-
-lemma runing_inversion_4:
- assumes runing': "th' \<in> runing (t@s)"
- and neq_th: "th' \<noteq> th"
- shows "th' \<in> threads s"
- and "\<not>detached s th'"
- and "cp (t@s) th' = preced th s"
-using runing_inversion_3 [OF runing']
- and neq_th
- and runing_preced_inversion[OF runing']
-apply(auto simp add: detached_eq[OF vt_s])
-done
-
-
-
-lemma live: "runing (t@s) \<noteq> {}"
-proof(cases "th \<in> runing (t@s)")
- case True thus ?thesis by auto
-next
- case False
- then have not_ready: "th \<notin> readys (t@s)"
- apply (unfold runing_def,
- insert th_cp_max max_cp_readys_threads[OF vt_t, symmetric])
- by auto
- from th_kept have "th \<in> threads (t@s)" by auto
- from th_chain_to_ready[OF vt_t this] and not_ready
- obtain th' where th'_in: "th' \<in> readys (t@s)"
- and dp: "(Th th, Th th') \<in> (depend (t @ s))\<^sup>+" by auto
- have "th' \<in> runing (t@s)"
- proof -
- have "cp (t @ s) th' = Max (cp (t @ s) ` readys (t @ s))"
- proof -
- have " Max ((\<lambda>th. preced th (t @ s)) ` ({th'} \<union> dependents (wq (t @ s)) th')) =
- preced th (t@s)"
- proof(rule Max_eqI)
- fix y
- assume "y \<in> (\<lambda>th. preced th (t @ s)) ` ({th'} \<union> dependents (wq (t @ s)) th')"
- then obtain th1 where
- h1: "th1 = th' \<or> th1 \<in> dependents (wq (t @ s)) th'"
- and eq_y: "y = preced th1 (t@s)" by auto
- show "y \<le> preced th (t @ s)"
- proof -
- from max_preced
- have "preced th (t @ s) = Max ((\<lambda>th'. preced th' (t @ s)) ` threads (t @ s))" .
- moreover have "y \<le> \<dots>"
- proof(rule Max_ge)
- from h1
- have "th1 \<in> threads (t@s)"
- proof
- assume "th1 = th'"
- with th'_in show ?thesis by (simp add:readys_def)
- next
- assume "th1 \<in> dependents (wq (t @ s)) th'"
- with dependents_threads [OF vt_t]
- show "th1 \<in> threads (t @ s)" by auto
- qed
- with eq_y show " y \<in> (\<lambda>th'. preced th' (t @ s)) ` threads (t @ s)" by simp
- next
- from finite_threads[OF vt_t]
- show "finite ((\<lambda>th'. preced th' (t @ s)) ` threads (t @ s))" by simp
- qed
- ultimately show ?thesis by auto
- qed
- next
- from finite_threads[OF vt_t] dependents_threads [OF vt_t, of th']
- show "finite ((\<lambda>th. preced th (t @ s)) ` ({th'} \<union> dependents (wq (t @ s)) th'))"
- by (auto intro:finite_subset)
- next
- from dp
- have "th \<in> dependents (wq (t @ s)) th'"
- by (unfold cs_dependents_def, auto simp:eq_depend)
- thus "preced th (t @ s) \<in>
- (\<lambda>th. preced th (t @ s)) ` ({th'} \<union> dependents (wq (t @ s)) th')"
- by auto
- qed
- moreover have "\<dots> = Max (cp (t @ s) ` readys (t @ s))"
- proof -
- from max_preced and max_cp_eq[OF vt_t, symmetric]
- have "preced th (t @ s) = Max (cp (t @ s) ` threads (t @ s))" by simp
- with max_cp_readys_threads[OF vt_t] show ?thesis by simp
- qed
- ultimately show ?thesis by (unfold cp_eq_cpreced cpreced_def, simp)
- qed
- with th'_in show ?thesis by (auto simp:runing_def)
- qed
- thus ?thesis by auto
-qed
-
-end
-end
-
-
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ExtGG.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,922 @@
+theory ExtGG
+imports PrioG CpsG
+begin
+
+text {*
+ The following two auxiliary lemmas are used to reason about @{term Max}.
+*}
+lemma image_Max_eqI:
+ assumes "finite B"
+ and "b \<in> B"
+ and "\<forall> x \<in> B. f x \<le> f b"
+ shows "Max (f ` B) = f b"
+ using assms
+ using Max_eqI by blast
+
+lemma image_Max_subset:
+ assumes "finite A"
+ and "B \<subseteq> A"
+ and "a \<in> B"
+ and "Max (f ` A) = f a"
+ shows "Max (f ` B) = f a"
+proof(rule image_Max_eqI)
+ show "finite B"
+ using assms(1) assms(2) finite_subset by auto
+next
+ show "a \<in> B" using assms by simp
+next
+ show "\<forall>x\<in>B. f x \<le> f a"
+ by (metis Max_ge assms(1) assms(2) assms(4)
+ finite_imageI image_eqI subsetCE)
+qed
+
+text {*
+ The following locale @{text "highest_gen"} sets the basic context for our
+ investigation: supposing thread @{text th} holds the highest @{term cp}-value
+ in state @{text s}, which means the task for @{text th} is the
+ most urgent. We want to show that
+ @{text th} is treated correctly by PIP, which means
+ @{text th} will not be blocked unreasonably by other less urgent
+ threads.
+*}
+locale highest_gen =
+ fixes s th prio tm
+ assumes vt_s: "vt s"
+ and threads_s: "th \<in> threads s"
+ and highest: "preced th s = Max ((cp s)`threads s)"
+ -- {* The internal structure of @{term th}'s precedence is exposed:*}
+ and preced_th: "preced th s = Prc prio tm"
+
+-- {* @{term s} is a valid trace, so it will inherit all results derived for
+ a valid trace: *}
+sublocale highest_gen < vat_s: valid_trace "s"
+ by (unfold_locales, insert vt_s, simp)
+
+context highest_gen
+begin
+
+text {*
+ @{term tm} is the time when the precedence of @{term th} is set, so
+ @{term tm} must be a valid moment index into @{term s}.
+*}
+lemma lt_tm: "tm < length s"
+ by (insert preced_tm_lt[OF threads_s preced_th], simp)
+
+text {*
+ Since @{term th} holds the highest precedence and @{text "cp"}
+ is the highest precedence of all threads in the sub-tree of
+ @{text "th"} and @{text th} is among these threads,
+ its @{term cp} must equal to its precedence:
+*}
+lemma eq_cp_s_th: "cp s th = preced th s" (is "?L = ?R")
+proof -
+ have "?L \<le> ?R"
+ by (unfold highest, rule Max_ge,
+ auto simp:threads_s finite_threads)
+ moreover have "?R \<le> ?L"
+ by (unfold vat_s.cp_rec, rule Max_ge,
+ auto simp:the_preced_def vat_s.fsbttRAGs.finite_children)
+ ultimately show ?thesis by auto
+qed
+
+(* ccc *)
+lemma highest_cp_preced: "cp s th = Max ((\<lambda> th'. preced th' s) ` threads s)"
+ by (fold max_cp_eq, unfold eq_cp_s_th, insert highest, simp)
+
+lemma highest_preced_thread: "preced th s = Max ((\<lambda> th'. preced th' s) ` threads s)"
+ by (fold eq_cp_s_th, unfold highest_cp_preced, simp)
+
+lemma highest': "cp s th = Max (cp s ` threads s)"
+proof -
+ from highest_cp_preced max_cp_eq[symmetric]
+ show ?thesis by simp
+qed
+
+end
+
+locale extend_highest_gen = highest_gen +
+ fixes t
+ assumes vt_t: "vt (t@s)"
+ and create_low: "Create th' prio' \<in> set t \<Longrightarrow> prio' \<le> prio"
+ and set_diff_low: "Set th' prio' \<in> set t \<Longrightarrow> th' \<noteq> th \<and> prio' \<le> prio"
+ and exit_diff: "Exit th' \<in> set t \<Longrightarrow> th' \<noteq> th"
+
+sublocale extend_highest_gen < vat_t: valid_trace "t@s"
+ by (unfold_locales, insert vt_t, simp)
+
+lemma step_back_vt_app:
+ assumes vt_ts: "vt (t@s)"
+ shows "vt s"
+proof -
+ from vt_ts show ?thesis
+ proof(induct t)
+ case Nil
+ from Nil show ?case by auto
+ next
+ case (Cons e t)
+ assume ih: " vt (t @ s) \<Longrightarrow> vt s"
+ and vt_et: "vt ((e # t) @ s)"
+ show ?case
+ proof(rule ih)
+ show "vt (t @ s)"
+ proof(rule step_back_vt)
+ from vt_et show "vt (e # t @ s)" by simp
+ qed
+ qed
+ qed
+qed
+
+
+locale red_extend_highest_gen = extend_highest_gen +
+ fixes i::nat
+
+sublocale red_extend_highest_gen < red_moment: extend_highest_gen "s" "th" "prio" "tm" "(moment i t)"
+ apply (insert extend_highest_gen_axioms, subst (asm) (1) moment_restm_s [of i t, symmetric])
+ apply (unfold extend_highest_gen_def extend_highest_gen_axioms_def, clarsimp)
+ by (unfold highest_gen_def, auto dest:step_back_vt_app)
+
+
+context extend_highest_gen
+begin
+
+ lemma ind [consumes 0, case_names Nil Cons, induct type]:
+ assumes
+ h0: "R []"
+ and h2: "\<And> e t. \<lbrakk>vt (t@s); step (t@s) e;
+ extend_highest_gen s th prio tm t;
+ extend_highest_gen s th prio tm (e#t); R t\<rbrakk> \<Longrightarrow> R (e#t)"
+ shows "R t"
+proof -
+ from vt_t extend_highest_gen_axioms show ?thesis
+ proof(induct t)
+ from h0 show "R []" .
+ next
+ case (Cons e t')
+ assume ih: "\<lbrakk>vt (t' @ s); extend_highest_gen s th prio tm t'\<rbrakk> \<Longrightarrow> R t'"
+ and vt_e: "vt ((e # t') @ s)"
+ and et: "extend_highest_gen s th prio tm (e # t')"
+ from vt_e and step_back_step have stp: "step (t'@s) e" by auto
+ from vt_e and step_back_vt have vt_ts: "vt (t'@s)" by auto
+ show ?case
+ proof(rule h2 [OF vt_ts stp _ _ _ ])
+ show "R t'"
+ proof(rule ih)
+ from et show ext': "extend_highest_gen s th prio tm t'"
+ by (unfold extend_highest_gen_def extend_highest_gen_axioms_def, auto dest:step_back_vt)
+ next
+ from vt_ts show "vt (t' @ s)" .
+ qed
+ next
+ from et show "extend_highest_gen s th prio tm (e # t')" .
+ next
+ from et show ext': "extend_highest_gen s th prio tm t'"
+ by (unfold extend_highest_gen_def extend_highest_gen_axioms_def, auto dest:step_back_vt)
+ qed
+ qed
+qed
+
+
+lemma th_kept: "th \<in> threads (t @ s) \<and>
+ preced th (t@s) = preced th s" (is "?Q t")
+proof -
+ show ?thesis
+ proof(induct rule:ind)
+ case Nil
+ from threads_s
+ show ?case
+ by auto
+ next
+ case (Cons e t)
+ interpret h_e: extend_highest_gen _ _ _ _ "(e # t)" using Cons by auto
+ interpret h_t: extend_highest_gen _ _ _ _ t using Cons by auto
+ show ?case
+ proof(cases e)
+ case (Create thread prio)
+ show ?thesis
+ proof -
+ from Cons and Create have "step (t@s) (Create thread prio)" by auto
+ hence "th \<noteq> thread"
+ proof(cases)
+ case thread_create
+ with Cons show ?thesis by auto
+ qed
+ hence "preced th ((e # t) @ s) = preced th (t @ s)"
+ by (unfold Create, auto simp:preced_def)
+ moreover note Cons
+ ultimately show ?thesis
+ by (auto simp:Create)
+ qed
+ next
+ case (Exit thread)
+ from h_e.exit_diff and Exit
+ have neq_th: "thread \<noteq> th" by auto
+ with Cons
+ show ?thesis
+ by (unfold Exit, auto simp:preced_def)
+ next
+ case (P thread cs)
+ with Cons
+ show ?thesis
+ by (auto simp:P preced_def)
+ next
+ case (V thread cs)
+ with Cons
+ show ?thesis
+ by (auto simp:V preced_def)
+ next
+ case (Set thread prio')
+ show ?thesis
+ proof -
+ from h_e.set_diff_low and Set
+ have "th \<noteq> thread" by auto
+ hence "preced th ((e # t) @ s) = preced th (t @ s)"
+ by (unfold Set, auto simp:preced_def)
+ moreover note Cons
+ ultimately show ?thesis
+ by (auto simp:Set)
+ qed
+ qed
+ qed
+qed
+
+text {*
+ According to @{thm th_kept}, thread @{text "th"} has its living status
+ and precedence kept along the way of @{text "t"}. The following lemma
+ shows that this preserved precedence of @{text "th"} remains as the highest
+ along the way of @{text "t"}.
+
+ The proof goes by induction over @{text "t"} using the specialized
+ induction rule @{thm ind}, followed by case analysis of each possible
+ operations of PIP. All cases follow the same pattern rendered by the
+ generalized introduction rule @{thm "image_Max_eqI"}.
+
+ The very essence is to show that precedences, no matter whether they are newly introduced
+ or modified, are always lower than the one held by @{term "th"},
+ which by @{thm th_kept} is preserved along the way.
+*}
+lemma max_kept: "Max (the_preced (t @ s) ` (threads (t@s))) = preced th s"
+proof(induct rule:ind)
+ case Nil
+ from highest_preced_thread
+ show ?case
+ by (unfold the_preced_def, simp)
+next
+ case (Cons e t)
+ interpret h_e: extend_highest_gen _ _ _ _ "(e # t)" using Cons by auto
+ interpret h_t: extend_highest_gen _ _ _ _ t using Cons by auto
+ show ?case
+ proof(cases e)
+ case (Create thread prio')
+ show ?thesis (is "Max (?f ` ?A) = ?t")
+ proof -
+ -- {* The following is the common pattern of each branch of the case analysis. *}
+ -- {* The major part is to show that @{text "th"} holds the highest precedence: *}
+ have "Max (?f ` ?A) = ?f th"
+ proof(rule image_Max_eqI)
+ show "finite ?A" using h_e.finite_threads by auto
+ next
+ show "th \<in> ?A" using h_e.th_kept by auto
+ next
+ show "\<forall>x\<in>?A. ?f x \<le> ?f th"
+ proof
+ fix x
+ assume "x \<in> ?A"
+ hence "x = thread \<or> x \<in> threads (t@s)" by (auto simp:Create)
+ thus "?f x \<le> ?f th"
+ proof
+ assume "x = thread"
+ thus ?thesis
+ apply (simp add:Create the_preced_def preced_def, fold preced_def)
+ using Create h_e.create_low h_t.th_kept lt_tm preced_leI2 preced_th by force
+ next
+ assume h: "x \<in> threads (t @ s)"
+ from Cons(2)[unfolded Create]
+ have "x \<noteq> thread" using h by (cases, auto)
+ hence "?f x = the_preced (t@s) x"
+ by (simp add:Create the_preced_def preced_def)
+ hence "?f x \<le> Max (the_preced (t@s) ` threads (t@s))"
+ by (simp add: h_t.finite_threads h)
+ also have "... = ?f th"
+ by (metis Cons.hyps(5) h_e.th_kept the_preced_def)
+ finally show ?thesis .
+ qed
+ qed
+ qed
+ -- {* The minor part is to show that the precedence of @{text "th"}
+ equals to preserved one, given by the foregoing lemma @{thm th_kept} *}
+ also have "... = ?t" using h_e.th_kept the_preced_def by auto
+ -- {* Then it follows trivially that the precedence preserved
+ for @{term "th"} remains the maximum of all living threads along the way. *}
+ finally show ?thesis .
+ qed
+ next
+ case (Exit thread)
+ show ?thesis (is "Max (?f ` ?A) = ?t")
+ proof -
+ have "Max (?f ` ?A) = ?f th"
+ proof(rule image_Max_eqI)
+ show "finite ?A" using h_e.finite_threads by auto
+ next
+ show "th \<in> ?A" using h_e.th_kept by auto
+ next
+ show "\<forall>x\<in>?A. ?f x \<le> ?f th"
+ proof
+ fix x
+ assume "x \<in> ?A"
+ hence "x \<in> threads (t@s)" by (simp add: Exit)
+ hence "?f x \<le> Max (?f ` threads (t@s))"
+ by (simp add: h_t.finite_threads)
+ also have "... \<le> ?f th"
+ apply (simp add:Exit the_preced_def preced_def, fold preced_def)
+ using Cons.hyps(5) h_t.th_kept the_preced_def by auto
+ finally show "?f x \<le> ?f th" .
+ qed
+ qed
+ also have "... = ?t" using h_e.th_kept the_preced_def by auto
+ finally show ?thesis .
+ qed
+ next
+ case (P thread cs)
+ with Cons
+ show ?thesis by (auto simp:preced_def the_preced_def)
+ next
+ case (V thread cs)
+ with Cons
+ show ?thesis by (auto simp:preced_def the_preced_def)
+ next
+ case (Set thread prio')
+ show ?thesis (is "Max (?f ` ?A) = ?t")
+ proof -
+ have "Max (?f ` ?A) = ?f th"
+ proof(rule image_Max_eqI)
+ show "finite ?A" using h_e.finite_threads by auto
+ next
+ show "th \<in> ?A" using h_e.th_kept by auto
+ next
+ show "\<forall>x\<in>?A. ?f x \<le> ?f th"
+ proof
+ fix x
+ assume h: "x \<in> ?A"
+ show "?f x \<le> ?f th"
+ proof(cases "x = thread")
+ case True
+ moreover have "the_preced (Set thread prio' # t @ s) thread \<le> the_preced (t @ s) th"
+ proof -
+ have "the_preced (t @ s) th = Prc prio tm"
+ using h_t.th_kept preced_th by (simp add:the_preced_def)
+ moreover have "prio' \<le> prio" using Set h_e.set_diff_low by auto
+ ultimately show ?thesis by (insert lt_tm, auto simp:the_preced_def preced_def)
+ qed
+ ultimately show ?thesis
+ by (unfold Set, simp add:the_preced_def preced_def)
+ next
+ case False
+ then have "?f x = the_preced (t@s) x"
+ by (simp add:the_preced_def preced_def Set)
+ also have "... \<le> Max (the_preced (t@s) ` threads (t@s))"
+ using Set h h_t.finite_threads by auto
+ also have "... = ?f th" by (metis Cons.hyps(5) h_e.th_kept the_preced_def)
+ finally show ?thesis .
+ qed
+ qed
+ qed
+ also have "... = ?t" using h_e.th_kept the_preced_def by auto
+ finally show ?thesis .
+ qed
+ qed
+qed
+
+lemma max_preced: "preced th (t@s) = Max (the_preced (t@s) ` (threads (t@s)))"
+ by (insert th_kept max_kept, auto)
+
+text {*
+ The reason behind the following lemma is that:
+ Since @{term "cp"} is defined as the maximum precedence
+ of those threads contained in the sub-tree of node @{term "Th th"}
+ in @{term "RAG (t@s)"}, and all these threads are living threads, and
+ @{term "th"} is also among them, the maximum precedence of
+ them all must be the one for @{text "th"}.
+*}
+lemma th_cp_max_preced:
+ "cp (t@s) th = Max (the_preced (t@s) ` (threads (t@s)))" (is "?L = ?R")
+proof -
+ let ?f = "the_preced (t@s)"
+ have "?L = ?f th"
+ proof(unfold cp_alt_def, rule image_Max_eqI)
+ show "finite {th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}"
+ proof -
+ have "{th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)} =
+ the_thread ` {n . n \<in> subtree (RAG (t @ s)) (Th th) \<and>
+ (\<exists> th'. n = Th th')}"
+ by (smt Collect_cong Setcompr_eq_image mem_Collect_eq the_thread.simps)
+ moreover have "finite ..." by (simp add: vat_t.fsbtRAGs.finite_subtree)
+ ultimately show ?thesis by simp
+ qed
+ next
+ show "th \<in> {th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}"
+ by (auto simp:subtree_def)
+ next
+ show "\<forall>x\<in>{th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}.
+ the_preced (t @ s) x \<le> the_preced (t @ s) th"
+ proof
+ fix th'
+ assume "th' \<in> {th'. Th th' \<in> subtree (RAG (t @ s)) (Th th)}"
+ hence "Th th' \<in> subtree (RAG (t @ s)) (Th th)" by auto
+ moreover have "... \<subseteq> Field (RAG (t @ s)) \<union> {Th th}"
+ by (meson subtree_Field)
+ ultimately have "Th th' \<in> ..." by auto
+ hence "th' \<in> threads (t@s)"
+ proof
+ assume "Th th' \<in> {Th th}"
+ thus ?thesis using th_kept by auto
+ next
+ assume "Th th' \<in> Field (RAG (t @ s))"
+ thus ?thesis using vat_t.not_in_thread_isolated by blast
+ qed
+ thus "the_preced (t @ s) th' \<le> the_preced (t @ s) th"
+ by (metis Max_ge finite_imageI finite_threads image_eqI
+ max_kept th_kept the_preced_def)
+ qed
+ qed
+ also have "... = ?R" by (simp add: max_preced the_preced_def)
+ finally show ?thesis .
+qed
+
+lemma th_cp_max: "cp (t@s) th = Max (cp (t@s) ` threads (t@s))"
+ using max_cp_eq th_cp_max_preced the_preced_def vt_t by presburger
+
+lemma th_cp_preced: "cp (t@s) th = preced th s"
+ by (fold max_kept, unfold th_cp_max_preced, simp)
+
+lemma preced_less:
+ assumes th'_in: "th' \<in> threads s"
+ and neq_th': "th' \<noteq> th"
+ shows "preced th' s < preced th s"
+ using assms
+by (metis Max.coboundedI finite_imageI highest not_le order.trans
+ preced_linorder rev_image_eqI threads_s vat_s.finite_threads
+ vat_s.le_cp)
+
+text {*
+ Counting of the number of @{term "P"} and @{term "V"} operations
+ is the cornerstone of a large number of the following proofs.
+ The reason is that this counting is quite easy to calculate and
+ convenient to use in the reasoning.
+
+ The following lemma shows that the counting controls whether
+ a thread is running or not.
+*}
+
+lemma pv_blocked_pre:
+ assumes th'_in: "th' \<in> threads (t@s)"
+ and neq_th': "th' \<noteq> th"
+ and eq_pv: "cntP (t@s) th' = cntV (t@s) th'"
+ shows "th' \<notin> runing (t@s)"
+proof
+ assume otherwise: "th' \<in> runing (t@s)"
+ show False
+ proof -
+ have "th' = th"
+ proof(rule preced_unique)
+ show "preced th' (t @ s) = preced th (t @ s)" (is "?L = ?R")
+ proof -
+ have "?L = cp (t@s) th'"
+ by (unfold cp_eq_cpreced cpreced_def count_eq_dependants[OF eq_pv], simp)
+ also have "... = cp (t @ s) th" using otherwise
+ by (metis (mono_tags, lifting) mem_Collect_eq
+ runing_def th_cp_max vat_t.max_cp_readys_threads)
+ also have "... = ?R" by (metis th_cp_preced th_kept)
+ finally show ?thesis .
+ qed
+ qed (auto simp: th'_in th_kept)
+ moreover have "th' \<noteq> th" using neq_th' .
+ ultimately show ?thesis by simp
+ qed
+qed
+
+lemmas pv_blocked = pv_blocked_pre[folded detached_eq]
+
+lemma runing_precond_pre:
+ fixes th'
+ assumes th'_in: "th' \<in> threads s"
+ and eq_pv: "cntP s th' = cntV s th'"
+ and neq_th': "th' \<noteq> th"
+ shows "th' \<in> threads (t@s) \<and>
+ cntP (t@s) th' = cntV (t@s) th'"
+proof(induct rule:ind)
+ case (Cons e t)
+ interpret vat_t: extend_highest_gen s th prio tm t using Cons by simp
+ interpret vat_e: extend_highest_gen s th prio tm "(e # t)" using Cons by simp
+ show ?case
+ proof(cases e)
+ case (P thread cs)
+ show ?thesis
+ proof -
+ have "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'"
+ proof -
+ have "thread \<noteq> th'"
+ proof -
+ have "step (t@s) (P thread cs)" using Cons P by auto
+ thus ?thesis
+ proof(cases)
+ assume "thread \<in> runing (t@s)"
+ moreover have "th' \<notin> runing (t@s)" using Cons(5)
+ by (metis neq_th' vat_t.pv_blocked_pre)
+ ultimately show ?thesis by auto
+ qed
+ qed with Cons show ?thesis
+ by (unfold P, simp add:cntP_def cntV_def count_def)
+ qed
+ moreover have "th' \<in> threads ((e # t) @ s)" using Cons by (unfold P, simp)
+ ultimately show ?thesis by auto
+ qed
+ next
+ case (V thread cs)
+ show ?thesis
+ proof -
+ have "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'"
+ proof -
+ have "thread \<noteq> th'"
+ proof -
+ have "step (t@s) (V thread cs)" using Cons V by auto
+ thus ?thesis
+ proof(cases)
+ assume "thread \<in> runing (t@s)"
+ moreover have "th' \<notin> runing (t@s)" using Cons(5)
+ by (metis neq_th' vat_t.pv_blocked_pre)
+ ultimately show ?thesis by auto
+ qed
+ qed with Cons show ?thesis
+ by (unfold V, simp add:cntP_def cntV_def count_def)
+ qed
+ moreover have "th' \<in> threads ((e # t) @ s)" using Cons by (unfold V, simp)
+ ultimately show ?thesis by auto
+ qed
+ next
+ case (Create thread prio')
+ show ?thesis
+ proof -
+ have "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'"
+ proof -
+ have "thread \<noteq> th'"
+ proof -
+ have "step (t@s) (Create thread prio')" using Cons Create by auto
+ thus ?thesis using Cons(5) by (cases, auto)
+ qed with Cons show ?thesis
+ by (unfold Create, simp add:cntP_def cntV_def count_def)
+ qed
+ moreover have "th' \<in> threads ((e # t) @ s)" using Cons by (unfold Create, simp)
+ ultimately show ?thesis by auto
+ qed
+ next
+ case (Exit thread)
+ show ?thesis
+ proof -
+ have neq_thread: "thread \<noteq> th'"
+ proof -
+ have "step (t@s) (Exit thread)" using Cons Exit by auto
+ thus ?thesis apply (cases) using Cons(5)
+ by (metis neq_th' vat_t.pv_blocked_pre)
+ qed
+ hence "cntP ((e # t) @ s) th' = cntV ((e # t) @ s) th'" using Cons
+ by (unfold Exit, simp add:cntP_def cntV_def count_def)
+ moreover have "th' \<in> threads ((e # t) @ s)" using Cons neq_thread
+ by (unfold Exit, simp)
+ ultimately show ?thesis by auto
+ qed
+ next
+ case (Set thread prio')
+ with Cons
+ show ?thesis
+ by (auto simp:cntP_def cntV_def count_def)
+ qed
+next
+ case Nil
+ with assms
+ show ?case by auto
+qed
+
+text {* Changing counting balance to detachedness *}
+lemmas runing_precond_pre_dtc = runing_precond_pre
+ [folded vat_t.detached_eq vat_s.detached_eq]
+
+lemma runing_precond:
+ fixes th'
+ assumes th'_in: "th' \<in> threads s"
+ and neq_th': "th' \<noteq> th"
+ and is_runing: "th' \<in> runing (t@s)"
+ shows "cntP s th' > cntV s th'"
+ using assms
+proof -
+ have "cntP s th' \<noteq> cntV s th'"
+ by (metis is_runing neq_th' pv_blocked_pre runing_precond_pre th'_in)
+ moreover have "cntV s th' \<le> cntP s th'" using vat_s.cnp_cnv_cncs by auto
+ ultimately show ?thesis by auto
+qed
+
+lemma moment_blocked_pre:
+ assumes neq_th': "th' \<noteq> th"
+ and th'_in: "th' \<in> threads ((moment i t)@s)"
+ and eq_pv: "cntP ((moment i t)@s) th' = cntV ((moment i t)@s) th'"
+ shows "cntP ((moment (i+j) t)@s) th' = cntV ((moment (i+j) t)@s) th' \<and>
+ th' \<in> threads ((moment (i+j) t)@s)"
+proof -
+ interpret h_i: red_extend_highest_gen _ _ _ _ _ i
+ by (unfold_locales)
+ interpret h_j: red_extend_highest_gen _ _ _ _ _ "i+j"
+ by (unfold_locales)
+ interpret h: extend_highest_gen "((moment i t)@s)" th prio tm "moment j (restm i t)"
+ proof(unfold_locales)
+ show "vt (moment i t @ s)" by (metis h_i.vt_t)
+ next
+ show "th \<in> threads (moment i t @ s)" by (metis h_i.th_kept)
+ next
+ show "preced th (moment i t @ s) =
+ Max (cp (moment i t @ s) ` threads (moment i t @ s))"
+ by (metis h_i.th_cp_max h_i.th_cp_preced h_i.th_kept)
+ next
+ show "preced th (moment i t @ s) = Prc prio tm" by (metis h_i.th_kept preced_th)
+ next
+ show "vt (moment j (restm i t) @ moment i t @ s)"
+ using moment_plus_split by (metis add.commute append_assoc h_j.vt_t)
+ next
+ fix th' prio'
+ assume "Create th' prio' \<in> set (moment j (restm i t))"
+ thus "prio' \<le> prio" using assms
+ by (metis Un_iff add.commute h_j.create_low moment_plus_split set_append)
+ next
+ fix th' prio'
+ assume "Set th' prio' \<in> set (moment j (restm i t))"
+ thus "th' \<noteq> th \<and> prio' \<le> prio"
+ by (metis Un_iff add.commute h_j.set_diff_low moment_plus_split set_append)
+ next
+ fix th'
+ assume "Exit th' \<in> set (moment j (restm i t))"
+ thus "th' \<noteq> th"
+ by (metis Un_iff add.commute h_j.exit_diff moment_plus_split set_append)
+ qed
+ show ?thesis
+ by (metis add.commute append_assoc eq_pv h.runing_precond_pre
+ moment_plus_split neq_th' th'_in)
+qed
+
+lemma moment_blocked_eqpv:
+ assumes neq_th': "th' \<noteq> th"
+ and th'_in: "th' \<in> threads ((moment i t)@s)"
+ and eq_pv: "cntP ((moment i t)@s) th' = cntV ((moment i t)@s) th'"
+ and le_ij: "i \<le> j"
+ shows "cntP ((moment j t)@s) th' = cntV ((moment j t)@s) th' \<and>
+ th' \<in> threads ((moment j t)@s) \<and>
+ th' \<notin> runing ((moment j t)@s)"
+proof -
+ from moment_blocked_pre [OF neq_th' th'_in eq_pv, of "j-i"] and le_ij
+ have h1: "cntP ((moment j t)@s) th' = cntV ((moment j t)@s) th'"
+ and h2: "th' \<in> threads ((moment j t)@s)" by auto
+ moreover have "th' \<notin> runing ((moment j t)@s)"
+ proof -
+ interpret h: red_extend_highest_gen _ _ _ _ _ j by (unfold_locales)
+ show ?thesis
+ using h.pv_blocked_pre h1 h2 neq_th' by auto
+ qed
+ ultimately show ?thesis by auto
+qed
+
+(* The foregoing two lemmas are preparation for this one, but
+ in long run can be combined. Maybe I am wrong.
+*)
+lemma moment_blocked:
+ assumes neq_th': "th' \<noteq> th"
+ and th'_in: "th' \<in> threads ((moment i t)@s)"
+ and dtc: "detached (moment i t @ s) th'"
+ and le_ij: "i \<le> j"
+ shows "detached (moment j t @ s) th' \<and>
+ th' \<in> threads ((moment j t)@s) \<and>
+ th' \<notin> runing ((moment j t)@s)"
+proof -
+ interpret h_i: red_extend_highest_gen _ _ _ _ _ i by (unfold_locales)
+ interpret h_j: red_extend_highest_gen _ _ _ _ _ j by (unfold_locales)
+ have cnt_i: "cntP (moment i t @ s) th' = cntV (moment i t @ s) th'"
+ by (metis dtc h_i.detached_elim)
+ from moment_blocked_eqpv[OF neq_th' th'_in cnt_i le_ij]
+ show ?thesis by (metis h_j.detached_intro)
+qed
+
+lemma runing_preced_inversion:
+ assumes runing': "th' \<in> runing (t@s)"
+ shows "cp (t@s) th' = preced th s" (is "?L = ?R")
+proof -
+ have "?L = Max (cp (t @ s) ` readys (t @ s))" using assms
+ by (unfold runing_def, auto)
+ also have "\<dots> = ?R"
+ by (metis th_cp_max th_cp_preced vat_t.max_cp_readys_threads)
+ finally show ?thesis .
+qed
+
+text {*
+ The situation when @{term "th"} is blocked is analyzed by the following lemmas.
+*}
+
+text {*
+ The following lemmas shows the running thread @{text "th'"}, if it is different from
+ @{term th}, must be live at the very beginning. By the term {\em the very beginning},
+ we mean the moment where the formal investigation starts, i.e. the moment (or state)
+ @{term s}.
+*}
+
+lemma runing_inversion_0:
+ assumes neq_th': "th' \<noteq> th"
+ and runing': "th' \<in> runing (t@s)"
+ shows "th' \<in> threads s"
+proof -
+ -- {* The proof is by contradiction: *}
+ { assume otherwise: "\<not> ?thesis"
+ have "th' \<notin> runing (t @ s)"
+ proof -
+ -- {* Since @{term "th'"} is running at time @{term "t@s"}, so it exists that time. *}
+ have th'_in: "th' \<in> threads (t@s)" using runing' by (simp add:runing_def readys_def)
+ -- {* However, @{text "th'"} does not exist at very beginning. *}
+ have th'_notin: "th' \<notin> threads (moment 0 t @ s)" using otherwise
+ by (metis append.simps(1) moment_zero)
+ -- {* Therefore, there must be a moment during @{text "t"}, when
+ @{text "th'"} came into being. *}
+ -- {* Let us suppose the moment being @{text "i"}: *}
+ from p_split_gen[OF th'_in th'_notin]
+ obtain i where lt_its: "i < length t"
+ and le_i: "0 \<le> i"
+ and pre: " th' \<notin> threads (moment i t @ s)" (is "th' \<notin> threads ?pre")
+ and post: "(\<forall>i'>i. th' \<in> threads (moment i' t @ s))" by (auto)
+ interpret h_i: red_extend_highest_gen _ _ _ _ _ i by (unfold_locales)
+ interpret h_i': red_extend_highest_gen _ _ _ _ _ "(Suc i)" by (unfold_locales)
+ from lt_its have "Suc i \<le> length t" by auto
+ -- {* Let us also suppose the event which makes this change is @{text e}: *}
+ from moment_head[OF this] obtain e where
+ eq_me: "moment (Suc i) t = e # moment i t" by blast
+ hence "vt (e # (moment i t @ s))" by (metis append_Cons h_i'.vt_t)
+ hence "PIP (moment i t @ s) e" by (cases, simp)
+ -- {* It can be derived that this event @{text "e"}, which
+ gives birth to @{term "th'"} must be a @{term "Create"}: *}
+ from create_pre[OF this, of th']
+ obtain prio where eq_e: "e = Create th' prio"
+ by (metis append_Cons eq_me lessI post pre)
+ have h1: "th' \<in> threads (moment (Suc i) t @ s)" using post by auto
+ have h2: "cntP (moment (Suc i) t @ s) th' = cntV (moment (Suc i) t@ s) th'"
+ proof -
+ have "cntP (moment i t@s) th' = cntV (moment i t@s) th'"
+ by (metis h_i.cnp_cnv_eq pre)
+ thus ?thesis by (simp add:eq_me eq_e cntP_def cntV_def count_def)
+ qed
+ show ?thesis
+ using moment_blocked_eqpv [OF neq_th' h1 h2, of "length t"] lt_its moment_ge
+ by auto
+ qed
+ with `th' \<in> runing (t@s)`
+ have False by simp
+ } thus ?thesis by auto
+qed
+
+text {*
+ The second lemma says, if the running thread @{text th'} is different from
+ @{term th}, then this @{text th'} must in the possession of some resources
+ at the very beginning.
+
+ To ease the reasoning of resource possession of one particular thread,
+ we used two auxiliary functions @{term cntV} and @{term cntP},
+ which are the counters of @{term P}-operations and
+ @{term V}-operations respectively.
+ If the number of @{term V}-operation is less than the number of
+ @{term "P"}-operations, the thread must have some unreleased resource.
+*}
+
+lemma runing_inversion_1: (* ddd *)
+ assumes neq_th': "th' \<noteq> th"
+ and runing': "th' \<in> runing (t@s)"
+ -- {* thread @{term "th'"} is a live on in state @{term "s"} and
+ it has some unreleased resource. *}
+ shows "th' \<in> threads s \<and> cntV s th' < cntP s th'"
+proof -
+ -- {* The proof is a simple composition of @{thm runing_inversion_0} and
+ @{thm runing_precond}: *}
+ -- {* By applying @{thm runing_inversion_0} to assumptions,
+ it can be shown that @{term th'} is live in state @{term s}: *}
+ have "th' \<in> threads s" using runing_inversion_0[OF assms(1,2)] .
+ -- {* Then the thesis is derived easily by applying @{thm runing_precond}: *}
+ with runing_precond [OF this neq_th' runing'] show ?thesis by simp
+qed
+
+text {*
+ The following lemma is just a rephrasing of @{thm runing_inversion_1}:
+*}
+lemma runing_inversion_2:
+ assumes runing': "th' \<in> runing (t@s)"
+ shows "th' = th \<or> (th' \<noteq> th \<and> th' \<in> threads s \<and> cntV s th' < cntP s th')"
+proof -
+ from runing_inversion_1[OF _ runing']
+ show ?thesis by auto
+qed
+
+lemma runing_inversion_3:
+ assumes runing': "th' \<in> runing (t@s)"
+ and neq_th: "th' \<noteq> th"
+ shows "th' \<in> threads s \<and> (cntV s th' < cntP s th' \<and> cp (t@s) th' = preced th s)"
+ by (metis neq_th runing' runing_inversion_2 runing_preced_inversion)
+
+lemma runing_inversion_4:
+ assumes runing': "th' \<in> runing (t@s)"
+ and neq_th: "th' \<noteq> th"
+ shows "th' \<in> threads s"
+ and "\<not>detached s th'"
+ and "cp (t@s) th' = preced th s"
+ apply (metis neq_th runing' runing_inversion_2)
+ apply (metis neq_th pv_blocked runing' runing_inversion_2 runing_precond_pre_dtc)
+ by (metis neq_th runing' runing_inversion_3)
+
+
+text {*
+ Suppose @{term th} is not running, it is first shown that
+ there is a path in RAG leading from node @{term th} to another thread @{text "th'"}
+ in the @{term readys}-set (So @{text "th'"} is an ancestor of @{term th}}).
+
+ Now, since @{term readys}-set is non-empty, there must be
+ one in it which holds the highest @{term cp}-value, which, by definition,
+ is the @{term runing}-thread. However, we are going to show more: this running thread
+ is exactly @{term "th'"}.
+ *}
+lemma th_blockedE: (* ddd *)
+ assumes "th \<notin> runing (t@s)"
+ obtains th' where "Th th' \<in> ancestors (RAG (t @ s)) (Th th)"
+ "th' \<in> runing (t@s)"
+proof -
+ -- {* According to @{thm vat_t.th_chain_to_ready}, either
+ @{term "th"} is in @{term "readys"} or there is path leading from it to
+ one thread in @{term "readys"}. *}
+ have "th \<in> readys (t @ s) \<or> (\<exists>th'. th' \<in> readys (t @ s) \<and> (Th th, Th th') \<in> (RAG (t @ s))\<^sup>+)"
+ using th_kept vat_t.th_chain_to_ready by auto
+ -- {* However, @{term th} can not be in @{term readys}, because otherwise, since
+ @{term th} holds the highest @{term cp}-value, it must be @{term "runing"}. *}
+ moreover have "th \<notin> readys (t@s)"
+ using assms runing_def th_cp_max vat_t.max_cp_readys_threads by auto
+ -- {* So, there must be a path from @{term th} to another thread @{text "th'"} in
+ term @{term readys}: *}
+ ultimately obtain th' where th'_in: "th' \<in> readys (t@s)"
+ and dp: "(Th th, Th th') \<in> (RAG (t @ s))\<^sup>+" by auto
+ -- {* We are going to show that this @{term th'} is running. *}
+ have "th' \<in> runing (t@s)"
+ proof -
+ -- {* We only need to show that this @{term th'} holds the highest @{term cp}-value: *}
+ have "cp (t@s) th' = Max (cp (t@s) ` readys (t@s))" (is "?L = ?R")
+ proof -
+ have "?L = Max ((the_preced (t @ s) \<circ> the_thread) ` subtree (tRAG (t @ s)) (Th th'))"
+ by (unfold cp_alt_def1, simp)
+ also have "... = (the_preced (t @ s) \<circ> the_thread) (Th th)"
+ proof(rule image_Max_subset)
+ show "finite (Th ` (threads (t@s)))" by (simp add: vat_t.finite_threads)
+ next
+ show "subtree (tRAG (t @ s)) (Th th') \<subseteq> Th ` threads (t @ s)"
+ by (metis Range.intros dp trancl_range vat_t.range_in vat_t.subtree_tRAG_thread)
+ next
+ show "Th th \<in> subtree (tRAG (t @ s)) (Th th')" using dp
+ by (unfold tRAG_subtree_eq, auto simp:subtree_def)
+ next
+ show "Max ((the_preced (t @ s) \<circ> the_thread) ` Th ` threads (t @ s)) =
+ (the_preced (t @ s) \<circ> the_thread) (Th th)" (is "Max ?L = _")
+ proof -
+ have "?L = the_preced (t @ s) ` threads (t @ s)"
+ by (unfold image_comp, rule image_cong, auto)
+ thus ?thesis using max_preced the_preced_def by auto
+ qed
+ qed
+ also have "... = ?R"
+ using th_cp_max th_cp_preced th_kept
+ the_preced_def vat_t.max_cp_readys_threads by auto
+ finally show ?thesis .
+ qed
+ -- {* Now, since @{term th'} holds the highest @{term cp}
+ and we have already show it is in @{term readys},
+ it is @{term runing} by definition. *}
+ with `th' \<in> readys (t@s)` show ?thesis by (simp add: runing_def)
+ qed
+ -- {* It is easy to show @{term th'} is an ancestor of @{term th}: *}
+ moreover have "Th th' \<in> ancestors (RAG (t @ s)) (Th th)"
+ using `(Th th, Th th') \<in> (RAG (t @ s))\<^sup>+` by (auto simp:ancestors_def)
+ ultimately show ?thesis using that by metis
+qed
+
+text {*
+ Now it is easy to see there is always a thread to run by case analysis
+ on whether thread @{term th} is running: if the answer is Yes, the
+ the running thread is obviously @{term th} itself; otherwise, the running
+ thread is the @{text th'} given by lemma @{thm th_blockedE}.
+*}
+lemma live: "runing (t@s) \<noteq> {}"
+proof(cases "th \<in> runing (t@s)")
+ case True thus ?thesis by auto
+next
+ case False
+ thus ?thesis using th_blockedE by auto
+qed
+
+end
+end
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Graphs.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,76 @@
+theory Graphs
+imports Main
+begin
+
+lemma rtrancl_eq_trancl [simp]:
+ assumes "x \<noteq> y"
+ shows "(x, y) \<in> r\<^sup>* \<longleftrightarrow> (x, y) \<in> r\<^sup>+"
+using assms by (metis rtrancl_eq_or_trancl)
+
+(* NOT NEEDED : FIXME *)
+lemma trancl_split:
+ "(a, b) \<in> r^+ \<Longrightarrow> \<exists> c. (a, c) \<in> r"
+by (induct rule:trancl_induct, auto)
+
+
+section {* Single_Valuedness *}
+
+lemma single_valued_Collect:
+ assumes "single_valuedP r"
+ and "inj f"
+ shows "single_valued {(f x, g y) | x y. r x y}"
+using assms
+unfolding single_valued_def inj_on_def
+apply(auto)
+done
+
+lemma single_valued_union:
+ assumes "single_valued r" "single_valued q"
+ and "Domain r \<inter> Domain q = {}"
+ shows "single_valued (r \<union> q)"
+using assms
+unfolding single_valued_def
+by auto
+
+lemma single_valuedP_update:
+ assumes "single_valuedP r"
+ shows "single_valuedP (r(x := y))"
+using assms
+oops
+
+lemma single_valued_confluent2:
+ assumes unique: "single_valued r"
+ and xy: "(x, y) \<in> r^+"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+ \<or> (z, y) \<in> r^+"
+proof -
+ have "(x, y) \<in> r^*" "(x, z) \<in> r^*" using xy xz by simp_all
+ with single_valued_confluent[OF unique]
+ have "(y, z) \<in> r\<^sup>* \<or> (z, y) \<in> r\<^sup>*" by auto
+ with neq_yz
+ show "(y, z) \<in> r^+ \<or> (z, y) \<in> r^+" by simp
+qed
+
+lemmas unique_chain = single_valued_confluent2
+
+
+
+definition funof :: "[('a * 'b)set, 'a] => 'b" where
+ "funof r == (\<lambda>x. THE y. (x, y) \<in> r)"
+
+lemma funof_eq: "[|single_valued r; (x, y) \<in> r|] ==> funof r x = y"
+by (simp add: funof_def single_valued_def, blast)
+
+lemma funof_Pair_in:
+ "[|single_valued r; x \<in> Domain r|] ==> (x, funof r x) \<in> r"
+by (force simp add: funof_eq)
+
+lemma funof_in:
+ "[|r `` {x} \<subseteq> A; single_valued r; x \<in> Domain r|] ==> funof r x \<in> A"
+by (force simp add: funof_eq)
+
+
+
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Implementation.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,920 @@
+section {*
+ This file contains lemmas used to guide the recalculation of current precedence
+ after every system call (or system operation)
+*}
+theory Implementation
+imports PIPBasics
+begin
+
+text {* (* ddd *)
+ One beauty of our modelling is that we follow the definitional extension tradition of HOL.
+ The benefit of such a concise and miniature model is that large number of intuitively
+ obvious facts are derived as lemmas, rather than asserted as axioms.
+*}
+
+text {*
+ However, the lemmas in the forthcoming several locales are no longer
+ obvious. These lemmas show how the current precedences should be recalculated
+ after every execution step (in our model, every step is represented by an event,
+ which in turn, represents a system call, or operation). Each operation is
+ treated in a separate locale.
+
+ The complication of current precedence recalculation comes
+ because the changing of RAG needs to be taken into account,
+ in addition to the changing of precedence.
+
+ The reason RAG changing affects current precedence is that,
+ according to the definition, current precedence
+ of a thread is the maximum of the precedences of every threads in its subtree,
+ where the notion of sub-tree in RAG is defined in RTree.thy.
+
+ Therefore, for each operation, lemmas about the change of precedences
+ and RAG are derived first, on which lemmas about current precedence
+ recalculation are based on.
+*}
+
+section {* The @{term Set} operation *}
+
+text {* (* ddd *)
+ The following locale @{text "step_set_cps"} investigates the recalculation
+ after the @{text "Set"} operation.
+*}
+locale step_set_cps =
+ fixes s' th prio s
+ -- {* @{text "s'"} is the system state before the operation *}
+ -- {* @{text "s"} is the system state after the operation *}
+ defines s_def : "s \<equiv> (Set th prio#s')"
+ -- {* @{text "s"} is assumed to be a legitimate state, from which
+ the legitimacy of @{text "s"} can be derived. *}
+ assumes vt_s: "vt s"
+
+sublocale step_set_cps < vat_s : valid_trace "s"
+proof
+ from vt_s show "vt s" .
+qed
+
+sublocale step_set_cps < vat_s' : valid_trace "s'"
+proof
+ from step_back_vt[OF vt_s[unfolded s_def]] show "vt s'" .
+qed
+
+context step_set_cps
+begin
+
+text {* (* ddd *)
+ The following two lemmas confirm that @{text "Set"}-operation
+ only changes the precedence of the initiating thread (or actor)
+ of the operation (or event).
+*}
+
+lemma eq_preced:
+ assumes "th' \<noteq> th"
+ shows "preced th' s = preced th' s'"
+proof -
+ from assms show ?thesis
+ by (unfold s_def, auto simp:preced_def)
+qed
+
+lemma eq_the_preced:
+ assumes "th' \<noteq> th"
+ shows "the_preced s th' = the_preced s' th'"
+ using assms
+ by (unfold the_preced_def, intro eq_preced, simp)
+
+text {*
+ The following lemma assures that the resetting of priority does not change the RAG.
+*}
+
+lemma eq_dep: "RAG s = RAG s'"
+ by (unfold s_def RAG_set_unchanged, auto)
+
+text {* (* ddd *)
+ Th following lemma @{text "eq_cp_pre"} says that the priority change of @{text "th"}
+ only affects those threads, which as @{text "Th th"} in their sub-trees.
+
+ The proof of this lemma is simplified by using the alternative definition
+ of @{text "cp"}.
+*}
+
+lemma eq_cp_pre:
+ assumes nd: "Th th \<notin> subtree (RAG s') (Th th')"
+ shows "cp s th' = cp s' th'"
+proof -
+ -- {* After unfolding using the alternative definition, elements
+ affecting the @{term "cp"}-value of threads become explicit.
+ We only need to prove the following: *}
+ have "Max (the_preced s ` {th'a. Th th'a \<in> subtree (RAG s) (Th th')}) =
+ Max (the_preced s' ` {th'a. Th th'a \<in> subtree (RAG s') (Th th')})"
+ (is "Max (?f ` ?S1) = Max (?g ` ?S2)")
+ proof -
+ -- {* The base sets are equal. *}
+ have "?S1 = ?S2" using eq_dep by simp
+ -- {* The function values on the base set are equal as well. *}
+ moreover have "\<forall> e \<in> ?S2. ?f e = ?g e"
+ proof
+ fix th1
+ assume "th1 \<in> ?S2"
+ with nd have "th1 \<noteq> th" by (auto)
+ from eq_the_preced[OF this]
+ show "the_preced s th1 = the_preced s' th1" .
+ qed
+ -- {* Therefore, the image of the functions are equal. *}
+ ultimately have "(?f ` ?S1) = (?g ` ?S2)" by (auto intro!:f_image_eq)
+ thus ?thesis by simp
+ qed
+ thus ?thesis by (simp add:cp_alt_def)
+qed
+
+text {*
+ The following lemma shows that @{term "th"} is not in the
+ sub-tree of any other thread.
+*}
+lemma th_in_no_subtree:
+ assumes "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s') (Th th')"
+proof -
+ have "th \<in> readys s'"
+ proof -
+ from step_back_step [OF vt_s[unfolded s_def]]
+ have "step s' (Set th prio)" .
+ hence "th \<in> runing s'" by (cases, simp)
+ thus ?thesis by (simp add:readys_def runing_def)
+ qed
+ from vat_s'.readys_in_no_subtree[OF this assms(1)]
+ show ?thesis by blast
+qed
+
+text {*
+ By combining @{thm "eq_cp_pre"} and @{thm "th_in_no_subtree"},
+ it is obvious that the change of priority only affects the @{text "cp"}-value
+ of the initiating thread @{text "th"}.
+*}
+lemma eq_cp:
+ assumes "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+ by (rule eq_cp_pre[OF th_in_no_subtree[OF assms]])
+
+end
+
+section {* The @{term V} operation *}
+
+text {*
+ The following @{text "step_v_cps"} is the locale for @{text "V"}-operation.
+*}
+
+locale step_v_cps =
+ -- {* @{text "th"} is the initiating thread *}
+ -- {* @{text "cs"} is the critical resource release by the @{text "V"}-operation *}
+ fixes s' th cs s -- {* @{text "s'"} is the state before operation*}
+ defines s_def : "s \<equiv> (V th cs#s')" -- {* @{text "s"} is the state after operation*}
+ -- {* @{text "s"} is assumed to be valid, which implies the validity of @{text "s'"} *}
+ assumes vt_s: "vt s"
+
+sublocale step_v_cps < vat_s : valid_trace "s"
+proof
+ from vt_s show "vt s" .
+qed
+
+sublocale step_v_cps < vat_s' : valid_trace "s'"
+proof
+ from step_back_vt[OF vt_s[unfolded s_def]] show "vt s'" .
+qed
+
+context step_v_cps
+begin
+
+lemma ready_th_s': "th \<in> readys s'"
+ using step_back_step[OF vt_s[unfolded s_def]]
+ by (cases, simp add:runing_def)
+
+lemma ancestors_th: "ancestors (RAG s') (Th th) = {}"
+proof -
+ from vat_s'.readys_root[OF ready_th_s']
+ show ?thesis
+ by (unfold root_def, simp)
+qed
+
+lemma holding_th: "holding s' th cs"
+proof -
+ from vt_s[unfolded s_def]
+ have " PIP s' (V th cs)" by (cases, simp)
+ thus ?thesis by (cases, auto)
+qed
+
+lemma edge_of_th:
+ "(Cs cs, Th th) \<in> RAG s'"
+proof -
+ from holding_th
+ show ?thesis
+ by (unfold s_RAG_def holding_eq, auto)
+qed
+
+lemma ancestors_cs:
+ "ancestors (RAG s') (Cs cs) = {Th th}"
+proof -
+ have "ancestors (RAG s') (Cs cs) = ancestors (RAG s') (Th th) \<union> {Th th}"
+ proof(rule vat_s'.rtree_RAG.ancestors_accum)
+ from vt_s[unfolded s_def]
+ have " PIP s' (V th cs)" by (cases, simp)
+ thus "(Cs cs, Th th) \<in> RAG s'"
+ proof(cases)
+ assume "holding s' th cs"
+ from this[unfolded holding_eq]
+ show ?thesis by (unfold s_RAG_def, auto)
+ qed
+ qed
+ from this[unfolded ancestors_th] show ?thesis by simp
+qed
+
+lemma preced_kept: "the_preced s = the_preced s'"
+ by (auto simp: s_def the_preced_def preced_def)
+
+end
+
+text {*
+ The following @{text "step_v_cps_nt"} is the sub-locale for @{text "V"}-operation,
+ which represents the case when there is another thread @{text "th'"}
+ to take over the critical resource released by the initiating thread @{text "th"}.
+*}
+locale step_v_cps_nt = step_v_cps +
+ fixes th'
+ -- {* @{text "th'"} is assumed to take over @{text "cs"} *}
+ assumes nt: "next_th s' th cs th'"
+
+context step_v_cps_nt
+begin
+
+text {*
+ Lemma @{text "RAG_s"} confirms the change of RAG:
+ two edges removed and one added, as shown by the following diagram.
+*}
+
+(*
+ RAG before the V-operation
+ th1 ----|
+ |
+ th' ----|
+ |----> cs -----|
+ th2 ----| |
+ | |
+ th3 ----| |
+ |------> th
+ th4 ----| |
+ | |
+ th5 ----| |
+ |----> cs'-----|
+ th6 ----|
+ |
+ th7 ----|
+
+ RAG after the V-operation
+ th1 ----|
+ |
+ |----> cs ----> th'
+ th2 ----|
+ |
+ th3 ----|
+
+ th4 ----|
+ |
+ th5 ----|
+ |----> cs'----> th
+ th6 ----|
+ |
+ th7 ----|
+*)
+
+lemma sub_RAGs': "{(Cs cs, Th th), (Th th', Cs cs)} \<subseteq> RAG s'"
+ using next_th_RAG[OF nt] .
+
+lemma ancestors_th':
+ "ancestors (RAG s') (Th th') = {Th th, Cs cs}"
+proof -
+ have "ancestors (RAG s') (Th th') = ancestors (RAG s') (Cs cs) \<union> {Cs cs}"
+ proof(rule vat_s'.rtree_RAG.ancestors_accum)
+ from sub_RAGs' show "(Th th', Cs cs) \<in> RAG s'" by auto
+ qed
+ thus ?thesis using ancestors_th ancestors_cs by auto
+qed
+
+lemma RAG_s:
+ "RAG s = (RAG s' - {(Cs cs, Th th), (Th th', Cs cs)}) \<union>
+ {(Cs cs, Th th')}"
+proof -
+ from step_RAG_v[OF vt_s[unfolded s_def], folded s_def]
+ and nt show ?thesis by (auto intro:next_th_unique)
+qed
+
+lemma subtree_kept: (* ddd *)
+ assumes "th1 \<notin> {th, th'}"
+ shows "subtree (RAG s) (Th th1) = subtree (RAG s') (Th th1)" (is "_ = ?R")
+proof -
+ let ?RAG' = "(RAG s' - {(Cs cs, Th th), (Th th', Cs cs)})"
+ let ?RAG'' = "?RAG' \<union> {(Cs cs, Th th')}"
+ have "subtree ?RAG' (Th th1) = ?R"
+ proof(rule subset_del_subtree_outside)
+ show "Range {(Cs cs, Th th), (Th th', Cs cs)} \<inter> subtree (RAG s') (Th th1) = {}"
+ proof -
+ have "(Th th) \<notin> subtree (RAG s') (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s') (Th th)"
+ by (unfold ancestors_th, simp)
+ next
+ from assms show "Th th1 \<noteq> Th th" by simp
+ qed
+ moreover have "(Cs cs) \<notin> subtree (RAG s') (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s') (Cs cs)"
+ by (unfold ancestors_cs, insert assms, auto)
+ qed simp
+ ultimately have "{Th th, Cs cs} \<inter> subtree (RAG s') (Th th1) = {}" by auto
+ thus ?thesis by simp
+ qed
+ qed
+ moreover have "subtree ?RAG'' (Th th1) = subtree ?RAG' (Th th1)"
+ proof(rule subtree_insert_next)
+ show "Th th' \<notin> subtree (RAG s' - {(Cs cs, Th th), (Th th', Cs cs)}) (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s' - {(Cs cs, Th th), (Th th', Cs cs)}) (Th th')"
+ (is "_ \<notin> ?R")
+ proof -
+ have "?R \<subseteq> ancestors (RAG s') (Th th')" by (rule ancestors_mono, auto)
+ moreover have "Th th1 \<notin> ..." using ancestors_th' assms by simp
+ ultimately show ?thesis by auto
+ qed
+ next
+ from assms show "Th th1 \<noteq> Th th'" by simp
+ qed
+ qed
+ ultimately show ?thesis by (unfold RAG_s, simp)
+qed
+
+lemma cp_kept:
+ assumes "th1 \<notin> {th, th'}"
+ shows "cp s th1 = cp s' th1"
+ by (unfold cp_alt_def preced_kept subtree_kept[OF assms], simp)
+
+end
+
+locale step_v_cps_nnt = step_v_cps +
+ assumes nnt: "\<And> th'. (\<not> next_th s' th cs th')"
+
+context step_v_cps_nnt
+begin
+
+lemma RAG_s: "RAG s = RAG s' - {(Cs cs, Th th)}"
+proof -
+ from nnt and step_RAG_v[OF vt_s[unfolded s_def], folded s_def]
+ show ?thesis by auto
+qed
+
+lemma subtree_kept:
+ assumes "th1 \<noteq> th"
+ shows "subtree (RAG s) (Th th1) = subtree (RAG s') (Th th1)"
+proof(unfold RAG_s, rule subset_del_subtree_outside)
+ show "Range {(Cs cs, Th th)} \<inter> subtree (RAG s') (Th th1) = {}"
+ proof -
+ have "(Th th) \<notin> subtree (RAG s') (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s') (Th th)"
+ by (unfold ancestors_th, simp)
+ next
+ from assms show "Th th1 \<noteq> Th th" by simp
+ qed
+ thus ?thesis by auto
+ qed
+qed
+
+lemma cp_kept_1:
+ assumes "th1 \<noteq> th"
+ shows "cp s th1 = cp s' th1"
+ by (unfold cp_alt_def preced_kept subtree_kept[OF assms], simp)
+
+lemma subtree_cs: "subtree (RAG s') (Cs cs) = {Cs cs}"
+proof -
+ { fix n
+ have "(Cs cs) \<notin> ancestors (RAG s') n"
+ proof
+ assume "Cs cs \<in> ancestors (RAG s') n"
+ hence "(n, Cs cs) \<in> (RAG s')^+" by (auto simp:ancestors_def)
+ from tranclE[OF this] obtain nn where h: "(nn, Cs cs) \<in> RAG s'" by auto
+ then obtain th' where "nn = Th th'"
+ by (unfold s_RAG_def, auto)
+ from h[unfolded this] have "(Th th', Cs cs) \<in> RAG s'" .
+ from this[unfolded s_RAG_def]
+ have "waiting (wq s') th' cs" by auto
+ from this[unfolded cs_waiting_def]
+ have "1 < length (wq s' cs)"
+ by (cases "wq s' cs", auto)
+ from holding_next_thI[OF holding_th this]
+ obtain th' where "next_th s' th cs th'" by auto
+ with nnt show False by auto
+ qed
+ } note h = this
+ { fix n
+ assume "n \<in> subtree (RAG s') (Cs cs)"
+ hence "n = (Cs cs)"
+ by (elim subtreeE, insert h, auto)
+ } moreover have "(Cs cs) \<in> subtree (RAG s') (Cs cs)"
+ by (auto simp:subtree_def)
+ ultimately show ?thesis by auto
+qed
+
+lemma subtree_th:
+ "subtree (RAG s) (Th th) = subtree (RAG s') (Th th) - {Cs cs}"
+proof(unfold RAG_s, fold subtree_cs, rule vat_s'.rtree_RAG.subtree_del_inside)
+ from edge_of_th
+ show "(Cs cs, Th th) \<in> edges_in (RAG s') (Th th)"
+ by (unfold edges_in_def, auto simp:subtree_def)
+qed
+
+lemma cp_kept_2:
+ shows "cp s th = cp s' th"
+ by (unfold cp_alt_def subtree_th preced_kept, auto)
+
+lemma eq_cp:
+ shows "cp s th' = cp s' th'"
+ using cp_kept_1 cp_kept_2
+ by (cases "th' = th", auto)
+end
+
+
+locale step_P_cps =
+ fixes s' th cs s
+ defines s_def : "s \<equiv> (P th cs#s')"
+ assumes vt_s: "vt s"
+
+sublocale step_P_cps < vat_s : valid_trace "s"
+proof
+ from vt_s show "vt s" .
+qed
+
+section {* The @{term P} operation *}
+
+sublocale step_P_cps < vat_s' : valid_trace "s'"
+proof
+ from step_back_vt[OF vt_s[unfolded s_def]] show "vt s'" .
+qed
+
+context step_P_cps
+begin
+
+lemma readys_th: "th \<in> readys s'"
+proof -
+ from step_back_step [OF vt_s[unfolded s_def]]
+ have "PIP s' (P th cs)" .
+ hence "th \<in> runing s'" by (cases, simp)
+ thus ?thesis by (simp add:readys_def runing_def)
+qed
+
+lemma root_th: "root (RAG s') (Th th)"
+ using readys_root[OF readys_th] .
+
+lemma in_no_others_subtree:
+ assumes "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s') (Th th')"
+proof
+ assume "Th th \<in> subtree (RAG s') (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 1
+ with assms show ?thesis by auto
+ next
+ case 2
+ with root_th show ?thesis by (auto simp:root_def)
+ qed
+qed
+
+lemma preced_kept: "the_preced s = the_preced s'"
+ by (auto simp: s_def the_preced_def preced_def)
+
+end
+
+locale step_P_cps_ne =step_P_cps +
+ fixes th'
+ assumes ne: "wq s' cs \<noteq> []"
+ defines th'_def: "th' \<equiv> hd (wq s' cs)"
+
+locale step_P_cps_e =step_P_cps +
+ assumes ee: "wq s' cs = []"
+
+context step_P_cps_e
+begin
+
+lemma RAG_s: "RAG s = RAG s' \<union> {(Cs cs, Th th)}"
+proof -
+ from ee and step_RAG_p[OF vt_s[unfolded s_def], folded s_def]
+ show ?thesis by auto
+qed
+
+lemma subtree_kept:
+ assumes "th' \<noteq> th"
+ shows "subtree (RAG s) (Th th') = subtree (RAG s') (Th th')"
+proof(unfold RAG_s, rule subtree_insert_next)
+ from in_no_others_subtree[OF assms]
+ show "Th th \<notin> subtree (RAG s') (Th th')" .
+qed
+
+lemma cp_kept:
+ assumes "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+proof -
+ have "(the_preced s ` {th'a. Th th'a \<in> subtree (RAG s) (Th th')}) =
+ (the_preced s' ` {th'a. Th th'a \<in> subtree (RAG s') (Th th')})"
+ by (unfold preced_kept subtree_kept[OF assms], simp)
+ thus ?thesis by (unfold cp_alt_def, simp)
+qed
+
+end
+
+context step_P_cps_ne
+begin
+
+lemma RAG_s: "RAG s = RAG s' \<union> {(Th th, Cs cs)}"
+proof -
+ from step_RAG_p[OF vt_s[unfolded s_def]] and ne
+ show ?thesis by (simp add:s_def)
+qed
+
+lemma cs_held: "(Cs cs, Th th') \<in> RAG s'"
+proof -
+ have "(Cs cs, Th th') \<in> hRAG s'"
+ proof -
+ from ne
+ have " holding s' th' cs"
+ by (unfold th'_def holding_eq cs_holding_def, auto)
+ thus ?thesis
+ by (unfold hRAG_def, auto)
+ qed
+ thus ?thesis by (unfold RAG_split, auto)
+qed
+
+lemma tRAG_s:
+ "tRAG s = tRAG s' \<union> {(Th th, Th th')}"
+ using RAG_tRAG_transfer[OF RAG_s cs_held] .
+
+lemma cp_kept:
+ assumes "Th th'' \<notin> ancestors (tRAG s) (Th th)"
+ shows "cp s th'' = cp s' th''"
+proof -
+ have h: "subtree (tRAG s) (Th th'') = subtree (tRAG s') (Th th'')"
+ proof -
+ have "Th th' \<notin> subtree (tRAG s') (Th th'')"
+ proof
+ assume "Th th' \<in> subtree (tRAG s') (Th th'')"
+ thus False
+ proof(rule subtreeE)
+ assume "Th th' = Th th''"
+ from assms[unfolded tRAG_s ancestors_def, folded this]
+ show ?thesis by auto
+ next
+ assume "Th th'' \<in> ancestors (tRAG s') (Th th')"
+ moreover have "... \<subseteq> ancestors (tRAG s) (Th th')"
+ proof(rule ancestors_mono)
+ show "tRAG s' \<subseteq> tRAG s" by (unfold tRAG_s, auto)
+ qed
+ ultimately have "Th th'' \<in> ancestors (tRAG s) (Th th')" by auto
+ moreover have "Th th' \<in> ancestors (tRAG s) (Th th)"
+ by (unfold tRAG_s, auto simp:ancestors_def)
+ ultimately have "Th th'' \<in> ancestors (tRAG s) (Th th)"
+ by (auto simp:ancestors_def)
+ with assms show ?thesis by auto
+ qed
+ qed
+ from subtree_insert_next[OF this]
+ have "subtree (tRAG s' \<union> {(Th th, Th th')}) (Th th'') = subtree (tRAG s') (Th th'')" .
+ from this[folded tRAG_s] show ?thesis .
+ qed
+ show ?thesis by (unfold cp_alt_def1 h preced_kept, simp)
+qed
+
+lemma cp_gen_update_stop: (* ddd *)
+ assumes "u \<in> ancestors (tRAG s) (Th th)"
+ and "cp_gen s u = cp_gen s' u"
+ and "y \<in> ancestors (tRAG s) u"
+ shows "cp_gen s y = cp_gen s' y"
+ using assms(3)
+proof(induct rule:wf_induct[OF vat_s.fsbttRAGs.wf])
+ case (1 x)
+ show ?case (is "?L = ?R")
+ proof -
+ from tRAG_ancestorsE[OF 1(2)]
+ obtain th2 where eq_x: "x = Th th2" by blast
+ from vat_s.cp_gen_rec[OF this]
+ have "?L =
+ Max ({the_preced s th2} \<union> cp_gen s ` RTree.children (tRAG s) x)" .
+ also have "... =
+ Max ({the_preced s' th2} \<union> cp_gen s' ` RTree.children (tRAG s') x)"
+
+ proof -
+ from preced_kept have "the_preced s th2 = the_preced s' th2" by simp
+ moreover have "cp_gen s ` RTree.children (tRAG s) x =
+ cp_gen s' ` RTree.children (tRAG s') x"
+ proof -
+ have "RTree.children (tRAG s) x = RTree.children (tRAG s') x"
+ proof(unfold tRAG_s, rule children_union_kept)
+ have start: "(Th th, Th th') \<in> tRAG s"
+ by (unfold tRAG_s, auto)
+ note x_u = 1(2)
+ show "x \<notin> Range {(Th th, Th th')}"
+ proof
+ assume "x \<in> Range {(Th th, Th th')}"
+ hence eq_x: "x = Th th'" using RangeE by auto
+ show False
+ proof(cases rule:vat_s.rtree_s.ancestors_headE[OF assms(1) start])
+ case 1
+ from x_u[folded this, unfolded eq_x] vat_s.acyclic_tRAG
+ show ?thesis by (auto simp:ancestors_def acyclic_def)
+ next
+ case 2
+ with x_u[unfolded eq_x]
+ have "(Th th', Th th') \<in> (tRAG s)^+" by (auto simp:ancestors_def)
+ with vat_s.acyclic_tRAG show ?thesis by (auto simp:acyclic_def)
+ qed
+ qed
+ qed
+ moreover have "cp_gen s ` RTree.children (tRAG s) x =
+ cp_gen s' ` RTree.children (tRAG s) x" (is "?f ` ?A = ?g ` ?A")
+ proof(rule f_image_eq)
+ fix a
+ assume a_in: "a \<in> ?A"
+ from 1(2)
+ show "?f a = ?g a"
+ proof(cases rule:vat_s.rtree_s.ancestors_childrenE[case_names in_ch out_ch])
+ case in_ch
+ show ?thesis
+ proof(cases "a = u")
+ case True
+ from assms(2)[folded this] show ?thesis .
+ next
+ case False
+ have a_not_in: "a \<notin> ancestors (tRAG s) (Th th)"
+ proof
+ assume a_in': "a \<in> ancestors (tRAG s) (Th th)"
+ have "a = u"
+ proof(rule vat_s.rtree_s.ancestors_children_unique)
+ from a_in' a_in show "a \<in> ancestors (tRAG s) (Th th) \<inter>
+ RTree.children (tRAG s) x" by auto
+ next
+ from assms(1) in_ch show "u \<in> ancestors (tRAG s) (Th th) \<inter>
+ RTree.children (tRAG s) x" by auto
+ qed
+ with False show False by simp
+ qed
+ from a_in obtain th_a where eq_a: "a = Th th_a"
+ by (unfold RTree.children_def tRAG_alt_def, auto)
+ from cp_kept[OF a_not_in[unfolded eq_a]]
+ have "cp s th_a = cp s' th_a" .
+ from this [unfolded cp_gen_def_cond[OF eq_a], folded eq_a]
+ show ?thesis .
+ qed
+ next
+ case (out_ch z)
+ hence h: "z \<in> ancestors (tRAG s) u" "z \<in> RTree.children (tRAG s) x" by auto
+ show ?thesis
+ proof(cases "a = z")
+ case True
+ from h(2) have zx_in: "(z, x) \<in> (tRAG s)" by (auto simp:RTree.children_def)
+ from 1(1)[rule_format, OF this h(1)]
+ have eq_cp_gen: "cp_gen s z = cp_gen s' z" .
+ with True show ?thesis by metis
+ next
+ case False
+ from a_in obtain th_a where eq_a: "a = Th th_a"
+ by (auto simp:RTree.children_def tRAG_alt_def)
+ have "a \<notin> ancestors (tRAG s) (Th th)"
+ proof
+ assume a_in': "a \<in> ancestors (tRAG s) (Th th)"
+ have "a = z"
+ proof(rule vat_s.rtree_s.ancestors_children_unique)
+ from assms(1) h(1) have "z \<in> ancestors (tRAG s) (Th th)"
+ by (auto simp:ancestors_def)
+ with h(2) show " z \<in> ancestors (tRAG s) (Th th) \<inter>
+ RTree.children (tRAG s) x" by auto
+ next
+ from a_in a_in'
+ show "a \<in> ancestors (tRAG s) (Th th) \<inter> RTree.children (tRAG s) x"
+ by auto
+ qed
+ with False show False by auto
+ qed
+ from cp_kept[OF this[unfolded eq_a]]
+ have "cp s th_a = cp s' th_a" .
+ from this[unfolded cp_gen_def_cond[OF eq_a], folded eq_a]
+ show ?thesis .
+ qed
+ qed
+ qed
+ ultimately show ?thesis by metis
+ qed
+ ultimately show ?thesis by simp
+ qed
+ also have "... = ?R"
+ by (fold vat_s'.cp_gen_rec[OF eq_x], simp)
+ finally show ?thesis .
+ qed
+qed
+
+lemma cp_up:
+ assumes "(Th th') \<in> ancestors (tRAG s) (Th th)"
+ and "cp s th' = cp s' th'"
+ and "(Th th'') \<in> ancestors (tRAG s) (Th th')"
+ shows "cp s th'' = cp s' th''"
+proof -
+ have "cp_gen s (Th th'') = cp_gen s' (Th th'')"
+ proof(rule cp_gen_update_stop[OF assms(1) _ assms(3)])
+ from assms(2) cp_gen_def_cond[OF refl[of "Th th'"]]
+ show "cp_gen s (Th th') = cp_gen s' (Th th')" by metis
+ qed
+ with cp_gen_def_cond[OF refl[of "Th th''"]]
+ show ?thesis by metis
+qed
+
+end
+
+section {* The @{term Create} operation *}
+
+locale step_create_cps =
+ fixes s' th prio s
+ defines s_def : "s \<equiv> (Create th prio#s')"
+ assumes vt_s: "vt s"
+
+sublocale step_create_cps < vat_s: valid_trace "s"
+ by (unfold_locales, insert vt_s, simp)
+
+sublocale step_create_cps < vat_s': valid_trace "s'"
+ by (unfold_locales, insert step_back_vt[OF vt_s[unfolded s_def]], simp)
+
+context step_create_cps
+begin
+
+lemma RAG_kept: "RAG s = RAG s'"
+ by (unfold s_def RAG_create_unchanged, auto)
+
+lemma tRAG_kept: "tRAG s = tRAG s'"
+ by (unfold tRAG_alt_def RAG_kept, auto)
+
+lemma preced_kept:
+ assumes "th' \<noteq> th"
+ shows "the_preced s th' = the_preced s' th'"
+ by (unfold s_def the_preced_def preced_def, insert assms, auto)
+
+lemma th_not_in: "Th th \<notin> Field (tRAG s')"
+proof -
+ from vt_s[unfolded s_def]
+ have "PIP s' (Create th prio)" by (cases, simp)
+ hence "th \<notin> threads s'" by(cases, simp)
+ from vat_s'.not_in_thread_isolated[OF this]
+ have "Th th \<notin> Field (RAG s')" .
+ with tRAG_Field show ?thesis by auto
+qed
+
+lemma eq_cp:
+ assumes neq_th: "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+proof -
+ have "(the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th') =
+ (the_preced s' \<circ> the_thread) ` subtree (tRAG s') (Th th')"
+ proof(unfold tRAG_kept, rule f_image_eq)
+ fix a
+ assume a_in: "a \<in> subtree (tRAG s') (Th th')"
+ then obtain th_a where eq_a: "a = Th th_a"
+ proof(cases rule:subtreeE)
+ case 2
+ from ancestors_Field[OF 2(2)]
+ and that show ?thesis by (unfold tRAG_alt_def, auto)
+ qed auto
+ have neq_th_a: "th_a \<noteq> th"
+ proof -
+ have "(Th th) \<notin> subtree (tRAG s') (Th th')"
+ proof
+ assume "Th th \<in> subtree (tRAG s') (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 2
+ from ancestors_Field[OF this(2)]
+ and th_not_in[unfolded Field_def]
+ show ?thesis by auto
+ qed (insert assms, auto)
+ qed
+ with a_in[unfolded eq_a] show ?thesis by auto
+ qed
+ from preced_kept[OF this]
+ show "(the_preced s \<circ> the_thread) a = (the_preced s' \<circ> the_thread) a"
+ by (unfold eq_a, simp)
+ qed
+ thus ?thesis by (unfold cp_alt_def1, simp)
+qed
+
+lemma children_of_th: "RTree.children (tRAG s) (Th th) = {}"
+proof -
+ { fix a
+ assume "a \<in> RTree.children (tRAG s) (Th th)"
+ hence "(a, Th th) \<in> tRAG s" by (auto simp:RTree.children_def)
+ with th_not_in have False
+ by (unfold Field_def tRAG_kept, auto)
+ } thus ?thesis by auto
+qed
+
+lemma eq_cp_th: "cp s th = preced th s"
+ by (unfold vat_s.cp_rec children_of_th, simp add:the_preced_def)
+
+end
+
+locale step_exit_cps =
+ fixes s' th prio s
+ defines s_def : "s \<equiv> Exit th # s'"
+ assumes vt_s: "vt s"
+
+sublocale step_exit_cps < vat_s: valid_trace "s"
+ by (unfold_locales, insert vt_s, simp)
+
+sublocale step_exit_cps < vat_s': valid_trace "s'"
+ by (unfold_locales, insert step_back_vt[OF vt_s[unfolded s_def]], simp)
+
+context step_exit_cps
+begin
+
+lemma preced_kept:
+ assumes "th' \<noteq> th"
+ shows "the_preced s th' = the_preced s' th'"
+ by (unfold s_def the_preced_def preced_def, insert assms, auto)
+
+lemma RAG_kept: "RAG s = RAG s'"
+ by (unfold s_def RAG_exit_unchanged, auto)
+
+lemma tRAG_kept: "tRAG s = tRAG s'"
+ by (unfold tRAG_alt_def RAG_kept, auto)
+
+lemma th_ready: "th \<in> readys s'"
+proof -
+ from vt_s[unfolded s_def]
+ have "PIP s' (Exit th)" by (cases, simp)
+ hence h: "th \<in> runing s' \<and> holdents s' th = {}" by (cases, metis)
+ thus ?thesis by (unfold runing_def, auto)
+qed
+
+lemma th_holdents: "holdents s' th = {}"
+proof -
+ from vt_s[unfolded s_def]
+ have "PIP s' (Exit th)" by (cases, simp)
+ thus ?thesis by (cases, metis)
+qed
+
+lemma th_RAG: "Th th \<notin> Field (RAG s')"
+proof -
+ have "Th th \<notin> Range (RAG s')"
+ proof
+ assume "Th th \<in> Range (RAG s')"
+ then obtain cs where "holding (wq s') th cs"
+ by (unfold Range_iff s_RAG_def, auto)
+ with th_holdents[unfolded holdents_def]
+ show False by (unfold eq_holding, auto)
+ qed
+ moreover have "Th th \<notin> Domain (RAG s')"
+ proof
+ assume "Th th \<in> Domain (RAG s')"
+ then obtain cs where "waiting (wq s') th cs"
+ by (unfold Domain_iff s_RAG_def, auto)
+ with th_ready show False by (unfold readys_def eq_waiting, auto)
+ qed
+ ultimately show ?thesis by (auto simp:Field_def)
+qed
+
+lemma th_tRAG: "(Th th) \<notin> Field (tRAG s')"
+ using th_RAG tRAG_Field[of s'] by auto
+
+lemma eq_cp:
+ assumes neq_th: "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+proof -
+ have "(the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th') =
+ (the_preced s' \<circ> the_thread) ` subtree (tRAG s') (Th th')"
+ proof(unfold tRAG_kept, rule f_image_eq)
+ fix a
+ assume a_in: "a \<in> subtree (tRAG s') (Th th')"
+ then obtain th_a where eq_a: "a = Th th_a"
+ proof(cases rule:subtreeE)
+ case 2
+ from ancestors_Field[OF 2(2)]
+ and that show ?thesis by (unfold tRAG_alt_def, auto)
+ qed auto
+ have neq_th_a: "th_a \<noteq> th"
+ proof -
+ from vat_s'.readys_in_no_subtree[OF th_ready assms]
+ have "(Th th) \<notin> subtree (RAG s') (Th th')" .
+ with tRAG_subtree_RAG[of s' "Th th'"]
+ have "(Th th) \<notin> subtree (tRAG s') (Th th')" by auto
+ with a_in[unfolded eq_a] show ?thesis by auto
+ qed
+ from preced_kept[OF this]
+ show "(the_preced s \<circ> the_thread) a = (the_preced s' \<circ> the_thread) a"
+ by (unfold eq_a, simp)
+ qed
+ thus ?thesis by (unfold cp_alt_def1, simp)
+qed
+
+end
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Implementation.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,913 @@
+section {*
+ This file contains lemmas used to guide the recalculation of current precedence
+ after every system call (or system operation)
+*}
+theory Implementation
+imports PIPBasics
+begin
+
+text {* (* ddd *)
+ One beauty of our modelling is that we follow the definitional extension tradition of HOL.
+ The benefit of such a concise and miniature model is that large number of intuitively
+ obvious facts are derived as lemmas, rather than asserted as axioms.
+*}
+
+text {*
+ However, the lemmas in the forthcoming several locales are no longer
+ obvious. These lemmas show how the current precedences should be recalculated
+ after every execution step (in our model, every step is represented by an event,
+ which in turn, represents a system call, or operation). Each operation is
+ treated in a separate locale.
+
+ The complication of current precedence recalculation comes
+ because the changing of RAG needs to be taken into account,
+ in addition to the changing of precedence.
+ The reason RAG changing affects current precedence is that,
+ according to the definition, current precedence
+ of a thread is the maximum of the precedences of its dependants,
+ where the dependants are defined in terms of RAG.
+
+ Therefore, each operation, lemmas concerning the change of the precedences
+ and RAG are derived first, so that the lemmas about
+ current precedence recalculation can be based on.
+*}
+
+text {* (* ddd *)
+ The following locale @{text "step_set_cps"} investigates the recalculation
+ after the @{text "Set"} operation.
+*}
+locale step_set_cps =
+ fixes s' th prio s
+ -- {* @{text "s'"} is the system state before the operation *}
+ -- {* @{text "s"} is the system state after the operation *}
+ defines s_def : "s \<equiv> (Set th prio#s')"
+ -- {* @{text "s"} is assumed to be a legitimate state, from which
+ the legitimacy of @{text "s"} can be derived. *}
+ assumes vt_s: "vt s"
+
+sublocale step_set_cps < vat_s : valid_trace "s"
+proof
+ from vt_s show "vt s" .
+qed
+
+sublocale step_set_cps < vat_s' : valid_trace "s'"
+proof
+ from step_back_vt[OF vt_s[unfolded s_def]] show "vt s'" .
+qed
+
+context step_set_cps
+begin
+
+text {* (* ddd *)
+ The following two lemmas confirm that @{text "Set"}-operating only changes the precedence
+ of the initiating thread.
+*}
+
+lemma eq_preced:
+ assumes "th' \<noteq> th"
+ shows "preced th' s = preced th' s'"
+proof -
+ from assms show ?thesis
+ by (unfold s_def, auto simp:preced_def)
+qed
+
+lemma eq_the_preced:
+ fixes th'
+ assumes "th' \<noteq> th"
+ shows "the_preced s th' = the_preced s' th'"
+ using assms
+ by (unfold the_preced_def, intro eq_preced, simp)
+
+text {*
+ The following lemma assures that the resetting of priority does not change the RAG.
+*}
+
+lemma eq_dep: "RAG s = RAG s'"
+ by (unfold s_def RAG_set_unchanged, auto)
+
+text {* (* ddd *)
+ Th following lemma @{text "eq_cp_pre"} says the priority change of @{text "th"}
+ only affects those threads, which as @{text "Th th"} in their sub-trees.
+
+ The proof of this lemma is simplified by using the alternative definition of @{text "cp"}.
+*}
+
+lemma eq_cp_pre:
+ fixes th'
+ assumes nd: "Th th \<notin> subtree (RAG s') (Th th')"
+ shows "cp s th' = cp s' th'"
+proof -
+ -- {* After unfolding using the alternative definition, elements
+ affecting the @{term "cp"}-value of threads become explicit.
+ We only need to prove the following: *}
+ have "Max (the_preced s ` {th'a. Th th'a \<in> subtree (RAG s) (Th th')}) =
+ Max (the_preced s' ` {th'a. Th th'a \<in> subtree (RAG s') (Th th')})"
+ (is "Max (?f ` ?S1) = Max (?g ` ?S2)")
+ proof -
+ -- {* The base sets are equal. *}
+ have "?S1 = ?S2" using eq_dep by simp
+ -- {* The function values on the base set are equal as well. *}
+ moreover have "\<forall> e \<in> ?S2. ?f e = ?g e"
+ proof
+ fix th1
+ assume "th1 \<in> ?S2"
+ with nd have "th1 \<noteq> th" by (auto)
+ from eq_the_preced[OF this]
+ show "the_preced s th1 = the_preced s' th1" .
+ qed
+ -- {* Therefore, the image of the functions are equal. *}
+ ultimately have "(?f ` ?S1) = (?g ` ?S2)" by (auto intro!:f_image_eq)
+ thus ?thesis by simp
+ qed
+ thus ?thesis by (simp add:cp_alt_def)
+qed
+
+text {*
+ The following lemma shows that @{term "th"} is not in the
+ sub-tree of any other thread.
+*}
+lemma th_in_no_subtree:
+ assumes "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s') (Th th')"
+proof -
+ have "th \<in> readys s'"
+ proof -
+ from step_back_step [OF vt_s[unfolded s_def]]
+ have "step s' (Set th prio)" .
+ hence "th \<in> runing s'" by (cases, simp)
+ thus ?thesis by (simp add:readys_def runing_def)
+ qed
+ from vat_s'.readys_in_no_subtree[OF this assms(1)]
+ show ?thesis by blast
+qed
+
+text {*
+ By combining @{thm "eq_cp_pre"} and @{thm "th_in_no_subtree"},
+ it is obvious that the change of priority only affects the @{text "cp"}-value
+ of the initiating thread @{text "th"}.
+*}
+lemma eq_cp:
+ fixes th'
+ assumes "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+ by (rule eq_cp_pre[OF th_in_no_subtree[OF assms]])
+
+end
+
+text {*
+ The following @{text "step_v_cps"} is the locale for @{text "V"}-operation.
+*}
+
+locale step_v_cps =
+ -- {* @{text "th"} is the initiating thread *}
+ -- {* @{text "cs"} is the critical resource release by the @{text "V"}-operation *}
+ fixes s' th cs s -- {* @{text "s'"} is the state before operation*}
+ defines s_def : "s \<equiv> (V th cs#s')" -- {* @{text "s"} is the state after operation*}
+ -- {* @{text "s"} is assumed to be valid, which implies the validity of @{text "s'"} *}
+ assumes vt_s: "vt s"
+
+sublocale step_v_cps < vat_s : valid_trace "s"
+proof
+ from vt_s show "vt s" .
+qed
+
+sublocale step_v_cps < vat_s' : valid_trace "s'"
+proof
+ from step_back_vt[OF vt_s[unfolded s_def]] show "vt s'" .
+qed
+
+context step_v_cps
+begin
+
+lemma ready_th_s': "th \<in> readys s'"
+ using step_back_step[OF vt_s[unfolded s_def]]
+ by (cases, simp add:runing_def)
+
+lemma ancestors_th: "ancestors (RAG s') (Th th) = {}"
+proof -
+ from vat_s'.readys_root[OF ready_th_s']
+ show ?thesis
+ by (unfold root_def, simp)
+qed
+
+lemma holding_th: "holding s' th cs"
+proof -
+ from vt_s[unfolded s_def]
+ have " PIP s' (V th cs)" by (cases, simp)
+ thus ?thesis by (cases, auto)
+qed
+
+lemma edge_of_th:
+ "(Cs cs, Th th) \<in> RAG s'"
+proof -
+ from holding_th
+ show ?thesis
+ by (unfold s_RAG_def holding_eq, auto)
+qed
+
+lemma ancestors_cs:
+ "ancestors (RAG s') (Cs cs) = {Th th}"
+proof -
+ have "ancestors (RAG s') (Cs cs) = ancestors (RAG s') (Th th) \<union> {Th th}"
+ proof(rule vat_s'.rtree_RAG.ancestors_accum)
+ from vt_s[unfolded s_def]
+ have " PIP s' (V th cs)" by (cases, simp)
+ thus "(Cs cs, Th th) \<in> RAG s'"
+ proof(cases)
+ assume "holding s' th cs"
+ from this[unfolded holding_eq]
+ show ?thesis by (unfold s_RAG_def, auto)
+ qed
+ qed
+ from this[unfolded ancestors_th] show ?thesis by simp
+qed
+
+lemma preced_kept: "the_preced s = the_preced s'"
+ by (auto simp: s_def the_preced_def preced_def)
+
+end
+
+text {*
+ The following @{text "step_v_cps_nt"} is the sub-locale for @{text "V"}-operation,
+ which represents the case when there is another thread @{text "th'"}
+ to take over the critical resource released by the initiating thread @{text "th"}.
+*}
+locale step_v_cps_nt = step_v_cps +
+ fixes th'
+ -- {* @{text "th'"} is assumed to take over @{text "cs"} *}
+ assumes nt: "next_th s' th cs th'"
+
+context step_v_cps_nt
+begin
+
+text {*
+ Lemma @{text "RAG_s"} confirms the change of RAG:
+ two edges removed and one added, as shown by the following diagram.
+*}
+
+(*
+ RAG before the V-operation
+ th1 ----|
+ |
+ th' ----|
+ |----> cs -----|
+ th2 ----| |
+ | |
+ th3 ----| |
+ |------> th
+ th4 ----| |
+ | |
+ th5 ----| |
+ |----> cs'-----|
+ th6 ----|
+ |
+ th7 ----|
+
+ RAG after the V-operation
+ th1 ----|
+ |
+ |----> cs ----> th'
+ th2 ----|
+ |
+ th3 ----|
+
+ th4 ----|
+ |
+ th5 ----|
+ |----> cs'----> th
+ th6 ----|
+ |
+ th7 ----|
+*)
+
+lemma sub_RAGs': "{(Cs cs, Th th), (Th th', Cs cs)} \<subseteq> RAG s'"
+ using next_th_RAG[OF nt] .
+
+lemma ancestors_th':
+ "ancestors (RAG s') (Th th') = {Th th, Cs cs}"
+proof -
+ have "ancestors (RAG s') (Th th') = ancestors (RAG s') (Cs cs) \<union> {Cs cs}"
+ proof(rule vat_s'.rtree_RAG.ancestors_accum)
+ from sub_RAGs' show "(Th th', Cs cs) \<in> RAG s'" by auto
+ qed
+ thus ?thesis using ancestors_th ancestors_cs by auto
+qed
+
+lemma RAG_s:
+ "RAG s = (RAG s' - {(Cs cs, Th th), (Th th', Cs cs)}) \<union>
+ {(Cs cs, Th th')}"
+proof -
+ from step_RAG_v[OF vt_s[unfolded s_def], folded s_def]
+ and nt show ?thesis by (auto intro:next_th_unique)
+qed
+
+lemma subtree_kept:
+ assumes "th1 \<notin> {th, th'}"
+ shows "subtree (RAG s) (Th th1) = subtree (RAG s') (Th th1)" (is "_ = ?R")
+proof -
+ let ?RAG' = "(RAG s' - {(Cs cs, Th th), (Th th', Cs cs)})"
+ let ?RAG'' = "?RAG' \<union> {(Cs cs, Th th')}"
+ have "subtree ?RAG' (Th th1) = ?R"
+ proof(rule subset_del_subtree_outside)
+ show "Range {(Cs cs, Th th), (Th th', Cs cs)} \<inter> subtree (RAG s') (Th th1) = {}"
+ proof -
+ have "(Th th) \<notin> subtree (RAG s') (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s') (Th th)"
+ by (unfold ancestors_th, simp)
+ next
+ from assms show "Th th1 \<noteq> Th th" by simp
+ qed
+ moreover have "(Cs cs) \<notin> subtree (RAG s') (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s') (Cs cs)"
+ by (unfold ancestors_cs, insert assms, auto)
+ qed simp
+ ultimately have "{Th th, Cs cs} \<inter> subtree (RAG s') (Th th1) = {}" by auto
+ thus ?thesis by simp
+ qed
+ qed
+ moreover have "subtree ?RAG'' (Th th1) = subtree ?RAG' (Th th1)"
+ proof(rule subtree_insert_next)
+ show "Th th' \<notin> subtree (RAG s' - {(Cs cs, Th th), (Th th', Cs cs)}) (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s' - {(Cs cs, Th th), (Th th', Cs cs)}) (Th th')"
+ (is "_ \<notin> ?R")
+ proof -
+ have "?R \<subseteq> ancestors (RAG s') (Th th')" by (rule ancestors_mono, auto)
+ moreover have "Th th1 \<notin> ..." using ancestors_th' assms by simp
+ ultimately show ?thesis by auto
+ qed
+ next
+ from assms show "Th th1 \<noteq> Th th'" by simp
+ qed
+ qed
+ ultimately show ?thesis by (unfold RAG_s, simp)
+qed
+
+lemma cp_kept:
+ assumes "th1 \<notin> {th, th'}"
+ shows "cp s th1 = cp s' th1"
+ by (unfold cp_alt_def preced_kept subtree_kept[OF assms], simp)
+
+end
+
+locale step_v_cps_nnt = step_v_cps +
+ assumes nnt: "\<And> th'. (\<not> next_th s' th cs th')"
+
+context step_v_cps_nnt
+begin
+
+lemma RAG_s: "RAG s = RAG s' - {(Cs cs, Th th)}"
+proof -
+ from nnt and step_RAG_v[OF vt_s[unfolded s_def], folded s_def]
+ show ?thesis by auto
+qed
+
+lemma subtree_kept:
+ assumes "th1 \<noteq> th"
+ shows "subtree (RAG s) (Th th1) = subtree (RAG s') (Th th1)"
+proof(unfold RAG_s, rule subset_del_subtree_outside)
+ show "Range {(Cs cs, Th th)} \<inter> subtree (RAG s') (Th th1) = {}"
+ proof -
+ have "(Th th) \<notin> subtree (RAG s') (Th th1)"
+ proof(rule subtree_refute)
+ show "Th th1 \<notin> ancestors (RAG s') (Th th)"
+ by (unfold ancestors_th, simp)
+ next
+ from assms show "Th th1 \<noteq> Th th" by simp
+ qed
+ thus ?thesis by auto
+ qed
+qed
+
+lemma cp_kept_1:
+ assumes "th1 \<noteq> th"
+ shows "cp s th1 = cp s' th1"
+ by (unfold cp_alt_def preced_kept subtree_kept[OF assms], simp)
+
+lemma subtree_cs: "subtree (RAG s') (Cs cs) = {Cs cs}"
+proof -
+ { fix n
+ have "(Cs cs) \<notin> ancestors (RAG s') n"
+ proof
+ assume "Cs cs \<in> ancestors (RAG s') n"
+ hence "(n, Cs cs) \<in> (RAG s')^+" by (auto simp:ancestors_def)
+ from tranclE[OF this] obtain nn where h: "(nn, Cs cs) \<in> RAG s'" by auto
+ then obtain th' where "nn = Th th'"
+ by (unfold s_RAG_def, auto)
+ from h[unfolded this] have "(Th th', Cs cs) \<in> RAG s'" .
+ from this[unfolded s_RAG_def]
+ have "waiting (wq s') th' cs" by auto
+ from this[unfolded cs_waiting_def]
+ have "1 < length (wq s' cs)"
+ by (cases "wq s' cs", auto)
+ from holding_next_thI[OF holding_th this]
+ obtain th' where "next_th s' th cs th'" by auto
+ with nnt show False by auto
+ qed
+ } note h = this
+ { fix n
+ assume "n \<in> subtree (RAG s') (Cs cs)"
+ hence "n = (Cs cs)"
+ by (elim subtreeE, insert h, auto)
+ } moreover have "(Cs cs) \<in> subtree (RAG s') (Cs cs)"
+ by (auto simp:subtree_def)
+ ultimately show ?thesis by auto
+qed
+
+lemma subtree_th:
+ "subtree (RAG s) (Th th) = subtree (RAG s') (Th th) - {Cs cs}"
+proof(unfold RAG_s, fold subtree_cs, rule vat_s'.rtree_RAG.subtree_del_inside)
+ from edge_of_th
+ show "(Cs cs, Th th) \<in> edges_in (RAG s') (Th th)"
+ by (unfold edges_in_def, auto simp:subtree_def)
+qed
+
+lemma cp_kept_2:
+ shows "cp s th = cp s' th"
+ by (unfold cp_alt_def subtree_th preced_kept, auto)
+
+lemma eq_cp:
+ fixes th'
+ shows "cp s th' = cp s' th'"
+ using cp_kept_1 cp_kept_2
+ by (cases "th' = th", auto)
+end
+
+
+locale step_P_cps =
+ fixes s' th cs s
+ defines s_def : "s \<equiv> (P th cs#s')"
+ assumes vt_s: "vt s"
+
+sublocale step_P_cps < vat_s : valid_trace "s"
+proof
+ from vt_s show "vt s" .
+qed
+
+sublocale step_P_cps < vat_s' : valid_trace "s'"
+proof
+ from step_back_vt[OF vt_s[unfolded s_def]] show "vt s'" .
+qed
+
+context step_P_cps
+begin
+
+lemma readys_th: "th \<in> readys s'"
+proof -
+ from step_back_step [OF vt_s[unfolded s_def]]
+ have "PIP s' (P th cs)" .
+ hence "th \<in> runing s'" by (cases, simp)
+ thus ?thesis by (simp add:readys_def runing_def)
+qed
+
+lemma root_th: "root (RAG s') (Th th)"
+ using readys_root[OF readys_th] .
+
+lemma in_no_others_subtree:
+ assumes "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s') (Th th')"
+proof
+ assume "Th th \<in> subtree (RAG s') (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 1
+ with assms show ?thesis by auto
+ next
+ case 2
+ with root_th show ?thesis by (auto simp:root_def)
+ qed
+qed
+
+lemma preced_kept: "the_preced s = the_preced s'"
+ by (auto simp: s_def the_preced_def preced_def)
+
+end
+
+locale step_P_cps_ne =step_P_cps +
+ fixes th'
+ assumes ne: "wq s' cs \<noteq> []"
+ defines th'_def: "th' \<equiv> hd (wq s' cs)"
+
+locale step_P_cps_e =step_P_cps +
+ assumes ee: "wq s' cs = []"
+
+context step_P_cps_e
+begin
+
+lemma RAG_s: "RAG s = RAG s' \<union> {(Cs cs, Th th)}"
+proof -
+ from ee and step_RAG_p[OF vt_s[unfolded s_def], folded s_def]
+ show ?thesis by auto
+qed
+
+lemma subtree_kept:
+ assumes "th' \<noteq> th"
+ shows "subtree (RAG s) (Th th') = subtree (RAG s') (Th th')"
+proof(unfold RAG_s, rule subtree_insert_next)
+ from in_no_others_subtree[OF assms]
+ show "Th th \<notin> subtree (RAG s') (Th th')" .
+qed
+
+lemma cp_kept:
+ assumes "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+proof -
+ have "(the_preced s ` {th'a. Th th'a \<in> subtree (RAG s) (Th th')}) =
+ (the_preced s' ` {th'a. Th th'a \<in> subtree (RAG s') (Th th')})"
+ by (unfold preced_kept subtree_kept[OF assms], simp)
+ thus ?thesis by (unfold cp_alt_def, simp)
+qed
+
+end
+
+context step_P_cps_ne
+begin
+
+lemma RAG_s: "RAG s = RAG s' \<union> {(Th th, Cs cs)}"
+proof -
+ from step_RAG_p[OF vt_s[unfolded s_def]] and ne
+ show ?thesis by (simp add:s_def)
+qed
+
+lemma cs_held: "(Cs cs, Th th') \<in> RAG s'"
+proof -
+ have "(Cs cs, Th th') \<in> hRAG s'"
+ proof -
+ from ne
+ have " holding s' th' cs"
+ by (unfold th'_def holding_eq cs_holding_def, auto)
+ thus ?thesis
+ by (unfold hRAG_def, auto)
+ qed
+ thus ?thesis by (unfold RAG_split, auto)
+qed
+
+lemma tRAG_s:
+ "tRAG s = tRAG s' \<union> {(Th th, Th th')}"
+ using RAG_tRAG_transfer[OF RAG_s cs_held] .
+
+lemma cp_kept:
+ assumes "Th th'' \<notin> ancestors (tRAG s) (Th th)"
+ shows "cp s th'' = cp s' th''"
+proof -
+ have h: "subtree (tRAG s) (Th th'') = subtree (tRAG s') (Th th'')"
+ proof -
+ have "Th th' \<notin> subtree (tRAG s') (Th th'')"
+ proof
+ assume "Th th' \<in> subtree (tRAG s') (Th th'')"
+ thus False
+ proof(rule subtreeE)
+ assume "Th th' = Th th''"
+ from assms[unfolded tRAG_s ancestors_def, folded this]
+ show ?thesis by auto
+ next
+ assume "Th th'' \<in> ancestors (tRAG s') (Th th')"
+ moreover have "... \<subseteq> ancestors (tRAG s) (Th th')"
+ proof(rule ancestors_mono)
+ show "tRAG s' \<subseteq> tRAG s" by (unfold tRAG_s, auto)
+ qed
+ ultimately have "Th th'' \<in> ancestors (tRAG s) (Th th')" by auto
+ moreover have "Th th' \<in> ancestors (tRAG s) (Th th)"
+ by (unfold tRAG_s, auto simp:ancestors_def)
+ ultimately have "Th th'' \<in> ancestors (tRAG s) (Th th)"
+ by (auto simp:ancestors_def)
+ with assms show ?thesis by auto
+ qed
+ qed
+ from subtree_insert_next[OF this]
+ have "subtree (tRAG s' \<union> {(Th th, Th th')}) (Th th'') = subtree (tRAG s') (Th th'')" .
+ from this[folded tRAG_s] show ?thesis .
+ qed
+ show ?thesis by (unfold cp_alt_def1 h preced_kept, simp)
+qed
+
+lemma cp_gen_update_stop: (* ddd *)
+ assumes "u \<in> ancestors (tRAG s) (Th th)"
+ and "cp_gen s u = cp_gen s' u"
+ and "y \<in> ancestors (tRAG s) u"
+ shows "cp_gen s y = cp_gen s' y"
+ using assms(3)
+proof(induct rule:wf_induct[OF vat_s.fsbttRAGs.wf])
+ case (1 x)
+ show ?case (is "?L = ?R")
+ proof -
+ from tRAG_ancestorsE[OF 1(2)]
+ obtain th2 where eq_x: "x = Th th2" by blast
+ from vat_s.cp_gen_rec[OF this]
+ have "?L =
+ Max ({the_preced s th2} \<union> cp_gen s ` RTree.children (tRAG s) x)" .
+ also have "... =
+ Max ({the_preced s' th2} \<union> cp_gen s' ` RTree.children (tRAG s') x)"
+
+ proof -
+ from preced_kept have "the_preced s th2 = the_preced s' th2" by simp
+ moreover have "cp_gen s ` RTree.children (tRAG s) x =
+ cp_gen s' ` RTree.children (tRAG s') x"
+ proof -
+ have "RTree.children (tRAG s) x = RTree.children (tRAG s') x"
+ proof(unfold tRAG_s, rule children_union_kept)
+ have start: "(Th th, Th th') \<in> tRAG s"
+ by (unfold tRAG_s, auto)
+ note x_u = 1(2)
+ show "x \<notin> Range {(Th th, Th th')}"
+ proof
+ assume "x \<in> Range {(Th th, Th th')}"
+ hence eq_x: "x = Th th'" using RangeE by auto
+ show False
+ proof(cases rule:vat_s.rtree_s.ancestors_headE[OF assms(1) start])
+ case 1
+ from x_u[folded this, unfolded eq_x] vat_s.acyclic_tRAG
+ show ?thesis by (auto simp:ancestors_def acyclic_def)
+ next
+ case 2
+ with x_u[unfolded eq_x]
+ have "(Th th', Th th') \<in> (tRAG s)^+" by (auto simp:ancestors_def)
+ with vat_s.acyclic_tRAG show ?thesis by (auto simp:acyclic_def)
+ qed
+ qed
+ qed
+ moreover have "cp_gen s ` RTree.children (tRAG s) x =
+ cp_gen s' ` RTree.children (tRAG s) x" (is "?f ` ?A = ?g ` ?A")
+ proof(rule f_image_eq)
+ fix a
+ assume a_in: "a \<in> ?A"
+ from 1(2)
+ show "?f a = ?g a"
+ proof(cases rule:vat_s.rtree_s.ancestors_childrenE[case_names in_ch out_ch])
+ case in_ch
+ show ?thesis
+ proof(cases "a = u")
+ case True
+ from assms(2)[folded this] show ?thesis .
+ next
+ case False
+ have a_not_in: "a \<notin> ancestors (tRAG s) (Th th)"
+ proof
+ assume a_in': "a \<in> ancestors (tRAG s) (Th th)"
+ have "a = u"
+ proof(rule vat_s.rtree_s.ancestors_children_unique)
+ from a_in' a_in show "a \<in> ancestors (tRAG s) (Th th) \<inter>
+ RTree.children (tRAG s) x" by auto
+ next
+ from assms(1) in_ch show "u \<in> ancestors (tRAG s) (Th th) \<inter>
+ RTree.children (tRAG s) x" by auto
+ qed
+ with False show False by simp
+ qed
+ from a_in obtain th_a where eq_a: "a = Th th_a"
+ by (unfold RTree.children_def tRAG_alt_def, auto)
+ from cp_kept[OF a_not_in[unfolded eq_a]]
+ have "cp s th_a = cp s' th_a" .
+ from this [unfolded cp_gen_def_cond[OF eq_a], folded eq_a]
+ show ?thesis .
+ qed
+ next
+ case (out_ch z)
+ hence h: "z \<in> ancestors (tRAG s) u" "z \<in> RTree.children (tRAG s) x" by auto
+ show ?thesis
+ proof(cases "a = z")
+ case True
+ from h(2) have zx_in: "(z, x) \<in> (tRAG s)" by (auto simp:RTree.children_def)
+ from 1(1)[rule_format, OF this h(1)]
+ have eq_cp_gen: "cp_gen s z = cp_gen s' z" .
+ with True show ?thesis by metis
+ next
+ case False
+ from a_in obtain th_a where eq_a: "a = Th th_a"
+ by (auto simp:RTree.children_def tRAG_alt_def)
+ have "a \<notin> ancestors (tRAG s) (Th th)"
+ proof
+ assume a_in': "a \<in> ancestors (tRAG s) (Th th)"
+ have "a = z"
+ proof(rule vat_s.rtree_s.ancestors_children_unique)
+ from assms(1) h(1) have "z \<in> ancestors (tRAG s) (Th th)"
+ by (auto simp:ancestors_def)
+ with h(2) show " z \<in> ancestors (tRAG s) (Th th) \<inter>
+ RTree.children (tRAG s) x" by auto
+ next
+ from a_in a_in'
+ show "a \<in> ancestors (tRAG s) (Th th) \<inter> RTree.children (tRAG s) x"
+ by auto
+ qed
+ with False show False by auto
+ qed
+ from cp_kept[OF this[unfolded eq_a]]
+ have "cp s th_a = cp s' th_a" .
+ from this[unfolded cp_gen_def_cond[OF eq_a], folded eq_a]
+ show ?thesis .
+ qed
+ qed
+ qed
+ ultimately show ?thesis by metis
+ qed
+ ultimately show ?thesis by simp
+ qed
+ also have "... = ?R"
+ by (fold vat_s'.cp_gen_rec[OF eq_x], simp)
+ finally show ?thesis .
+ qed
+qed
+
+lemma cp_up:
+ assumes "(Th th') \<in> ancestors (tRAG s) (Th th)"
+ and "cp s th' = cp s' th'"
+ and "(Th th'') \<in> ancestors (tRAG s) (Th th')"
+ shows "cp s th'' = cp s' th''"
+proof -
+ have "cp_gen s (Th th'') = cp_gen s' (Th th'')"
+ proof(rule cp_gen_update_stop[OF assms(1) _ assms(3)])
+ from assms(2) cp_gen_def_cond[OF refl[of "Th th'"]]
+ show "cp_gen s (Th th') = cp_gen s' (Th th')" by metis
+ qed
+ with cp_gen_def_cond[OF refl[of "Th th''"]]
+ show ?thesis by metis
+qed
+
+end
+
+locale step_create_cps =
+ fixes s' th prio s
+ defines s_def : "s \<equiv> (Create th prio#s')"
+ assumes vt_s: "vt s"
+
+sublocale step_create_cps < vat_s: valid_trace "s"
+ by (unfold_locales, insert vt_s, simp)
+
+sublocale step_create_cps < vat_s': valid_trace "s'"
+ by (unfold_locales, insert step_back_vt[OF vt_s[unfolded s_def]], simp)
+
+context step_create_cps
+begin
+
+lemma RAG_kept: "RAG s = RAG s'"
+ by (unfold s_def RAG_create_unchanged, auto)
+
+lemma tRAG_kept: "tRAG s = tRAG s'"
+ by (unfold tRAG_alt_def RAG_kept, auto)
+
+lemma preced_kept:
+ assumes "th' \<noteq> th"
+ shows "the_preced s th' = the_preced s' th'"
+ by (unfold s_def the_preced_def preced_def, insert assms, auto)
+
+lemma th_not_in: "Th th \<notin> Field (tRAG s')"
+proof -
+ from vt_s[unfolded s_def]
+ have "PIP s' (Create th prio)" by (cases, simp)
+ hence "th \<notin> threads s'" by(cases, simp)
+ from vat_s'.not_in_thread_isolated[OF this]
+ have "Th th \<notin> Field (RAG s')" .
+ with tRAG_Field show ?thesis by auto
+qed
+
+lemma eq_cp:
+ assumes neq_th: "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+proof -
+ have "(the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th') =
+ (the_preced s' \<circ> the_thread) ` subtree (tRAG s') (Th th')"
+ proof(unfold tRAG_kept, rule f_image_eq)
+ fix a
+ assume a_in: "a \<in> subtree (tRAG s') (Th th')"
+ then obtain th_a where eq_a: "a = Th th_a"
+ proof(cases rule:subtreeE)
+ case 2
+ from ancestors_Field[OF 2(2)]
+ and that show ?thesis by (unfold tRAG_alt_def, auto)
+ qed auto
+ have neq_th_a: "th_a \<noteq> th"
+ proof -
+ have "(Th th) \<notin> subtree (tRAG s') (Th th')"
+ proof
+ assume "Th th \<in> subtree (tRAG s') (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 2
+ from ancestors_Field[OF this(2)]
+ and th_not_in[unfolded Field_def]
+ show ?thesis by auto
+ qed (insert assms, auto)
+ qed
+ with a_in[unfolded eq_a] show ?thesis by auto
+ qed
+ from preced_kept[OF this]
+ show "(the_preced s \<circ> the_thread) a = (the_preced s' \<circ> the_thread) a"
+ by (unfold eq_a, simp)
+ qed
+ thus ?thesis by (unfold cp_alt_def1, simp)
+qed
+
+lemma children_of_th: "RTree.children (tRAG s) (Th th) = {}"
+proof -
+ { fix a
+ assume "a \<in> RTree.children (tRAG s) (Th th)"
+ hence "(a, Th th) \<in> tRAG s" by (auto simp:RTree.children_def)
+ with th_not_in have False
+ by (unfold Field_def tRAG_kept, auto)
+ } thus ?thesis by auto
+qed
+
+lemma eq_cp_th: "cp s th = preced th s"
+ by (unfold vat_s.cp_rec children_of_th, simp add:the_preced_def)
+
+end
+
+locale step_exit_cps =
+ fixes s' th prio s
+ defines s_def : "s \<equiv> Exit th # s'"
+ assumes vt_s: "vt s"
+
+sublocale step_exit_cps < vat_s: valid_trace "s"
+ by (unfold_locales, insert vt_s, simp)
+
+sublocale step_exit_cps < vat_s': valid_trace "s'"
+ by (unfold_locales, insert step_back_vt[OF vt_s[unfolded s_def]], simp)
+
+context step_exit_cps
+begin
+
+lemma preced_kept:
+ assumes "th' \<noteq> th"
+ shows "the_preced s th' = the_preced s' th'"
+ by (unfold s_def the_preced_def preced_def, insert assms, auto)
+
+lemma RAG_kept: "RAG s = RAG s'"
+ by (unfold s_def RAG_exit_unchanged, auto)
+
+lemma tRAG_kept: "tRAG s = tRAG s'"
+ by (unfold tRAG_alt_def RAG_kept, auto)
+
+lemma th_ready: "th \<in> readys s'"
+proof -
+ from vt_s[unfolded s_def]
+ have "PIP s' (Exit th)" by (cases, simp)
+ hence h: "th \<in> runing s' \<and> holdents s' th = {}" by (cases, metis)
+ thus ?thesis by (unfold runing_def, auto)
+qed
+
+lemma th_holdents: "holdents s' th = {}"
+proof -
+ from vt_s[unfolded s_def]
+ have "PIP s' (Exit th)" by (cases, simp)
+ thus ?thesis by (cases, metis)
+qed
+
+lemma th_RAG: "Th th \<notin> Field (RAG s')"
+proof -
+ have "Th th \<notin> Range (RAG s')"
+ proof
+ assume "Th th \<in> Range (RAG s')"
+ then obtain cs where "holding (wq s') th cs"
+ by (unfold Range_iff s_RAG_def, auto)
+ with th_holdents[unfolded holdents_def]
+ show False by (unfold eq_holding, auto)
+ qed
+ moreover have "Th th \<notin> Domain (RAG s')"
+ proof
+ assume "Th th \<in> Domain (RAG s')"
+ then obtain cs where "waiting (wq s') th cs"
+ by (unfold Domain_iff s_RAG_def, auto)
+ with th_ready show False by (unfold readys_def eq_waiting, auto)
+ qed
+ ultimately show ?thesis by (auto simp:Field_def)
+qed
+
+lemma th_tRAG: "(Th th) \<notin> Field (tRAG s')"
+ using th_RAG tRAG_Field[of s'] by auto
+
+lemma eq_cp:
+ assumes neq_th: "th' \<noteq> th"
+ shows "cp s th' = cp s' th'"
+proof -
+ have "(the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th') =
+ (the_preced s' \<circ> the_thread) ` subtree (tRAG s') (Th th')"
+ proof(unfold tRAG_kept, rule f_image_eq)
+ fix a
+ assume a_in: "a \<in> subtree (tRAG s') (Th th')"
+ then obtain th_a where eq_a: "a = Th th_a"
+ proof(cases rule:subtreeE)
+ case 2
+ from ancestors_Field[OF 2(2)]
+ and that show ?thesis by (unfold tRAG_alt_def, auto)
+ qed auto
+ have neq_th_a: "th_a \<noteq> th"
+ proof -
+ from vat_s'.readys_in_no_subtree[OF th_ready assms]
+ have "(Th th) \<notin> subtree (RAG s') (Th th')" .
+ with tRAG_subtree_RAG[of s' "Th th'"]
+ have "(Th th) \<notin> subtree (tRAG s') (Th th')" by auto
+ with a_in[unfolded eq_a] show ?thesis by auto
+ qed
+ from preced_kept[OF this]
+ show "(the_preced s \<circ> the_thread) a = (the_preced s' \<circ> the_thread) a"
+ by (unfold eq_a, simp)
+ qed
+ thus ?thesis by (unfold cp_alt_def1, simp)
+qed
+
+end
+
+end
+
--- a/Journal/Paper.thy Wed May 14 11:52:53 2014 +0100
+++ b/Journal/Paper.thy Wed Jan 27 13:50:02 2016 +0000
@@ -1,66 +1,65 @@
(*<*)
theory Paper
-imports "../CpsG" "../ExtGG" "~~/src/HOL/Library/LaTeXsugar"
+imports "../Implementation"
+ "../Correctness"
+ "~~/src/HOL/Library/LaTeXsugar"
begin
-
declare [[show_question_marks = false]]
-
notation (latex output)
Cons ("_::_" [78,77] 73) and
+ If ("(\<^raw:\textrm{>if\<^raw:}> (_)/ \<^raw:\textrm{>then\<^raw:}> (_)/ \<^raw:\textrm{>else\<^raw:}> (_))" 10) and
vt ("valid'_state") and
runing ("running") and
- birthtime ("last'_set") and
- If ("(\<^raw:\textrm{>if\<^raw:}> (_)/ \<^raw:\textrm{>then\<^raw:}> (_)/ \<^raw:\textrm{>else\<^raw:}> (_))" 10) and
Prc ("'(_, _')") and
holding ("holds") and
waiting ("waits") and
Th ("T") and
Cs ("C") and
readys ("ready") and
- depend ("RAG") and
preced ("prec") and
+(* preceds ("precs") and*)
cpreced ("cprec") and
- dependents ("dependants") and
cp ("cprec") and
holdents ("resources") and
- original_priority ("priority") and
- DUMMY ("\<^raw:\mbox{$\_\!\_$}>")
+ DUMMY ("\<^raw:\mbox{$\_\!\_$}>") and
+ cntP ("c\<^bsub>P\<^esub>") and
+ cntV ("c\<^bsub>V\<^esub>")
-
(*>*)
section {* Introduction *}
text {*
- Many real-time systems need to support threads involving priorities and
- locking of resources. Locking of resources ensures mutual exclusion
- when accessing shared data or devices that cannot be
+
+ Many real-time systems need to support threads involving priorities
+ and locking of resources. Locking of resources ensures mutual
+ exclusion when accessing shared data or devices that cannot be
preempted. Priorities allow scheduling of threads that need to
finish their work within deadlines. Unfortunately, both features
can interact in subtle ways leading to a problem, called
\emph{Priority Inversion}. Suppose three threads having priorities
$H$(igh), $M$(edium) and $L$(ow). We would expect that the thread
- $H$ blocks any other thread with lower priority and the thread itself cannot
- be blocked indefinitely by threads with lower priority. Alas, in a naive
- implementation of resource locking and priorities this property can
- be violated. For this let $L$ be in the
+ $H$ blocks any other thread with lower priority and the thread
+ itself cannot be blocked indefinitely by threads with lower
+ priority. Alas, in a naive implementation of resource locking and
+ priorities this property can be violated. For this let $L$ be in the
possession of a lock for a resource that $H$ also needs. $H$ must
therefore wait for $L$ to exit the critical section and release this
- lock. The problem is that $L$ might in turn be blocked by any
- thread with priority $M$, and so $H$ sits there potentially waiting
- indefinitely. Since $H$ is blocked by threads with lower
- priorities, the problem is called Priority Inversion. It was first
- described in \cite{Lampson80} in the context of the
- Mesa programming language designed for concurrent programming.
+ lock. The problem is that $L$ might in turn be blocked by any thread
+ with priority $M$, and so $H$ sits there potentially waiting
+ indefinitely. Since $H$ is blocked by threads with lower priorities,
+ the problem is called Priority Inversion. It was first described in
+ \cite{Lampson80} in the context of the Mesa programming language
+ designed for concurrent programming.
If the problem of Priority Inversion is ignored, real-time systems
can become unpredictable and resulting bugs can be hard to diagnose.
The classic example where this happened is the software that
- controlled the Mars Pathfinder mission in 1997 \cite{Reeves98}.
- On Earth the software run mostly without any problem, but
- once the spacecraft landed on Mars, it shut down at irregular
+ controlled the Mars Pathfinder mission in 1997 \cite{Reeves98}. On
+ Earth the software run mostly without any problem, but once the
+ spacecraft landed on Mars, it shut down at irregular, but frequent,
intervals leading to loss of project time as normal operation of the
craft could only resume the next day (the mission and data already
collected were fortunately not lost, because of a clever system
@@ -71,11 +70,11 @@
rectified by enabling the \emph{Priority Inheritance Protocol} (PIP)
\cite{Sha90}\footnote{Sha et al.~call it the \emph{Basic Priority
Inheritance Protocol} \cite{Sha90} and others sometimes also call it
- \emph{Priority Boosting}, \emph{Priority Donation} or \emph{Priority Lending}.}
- in the scheduling software.
+ \emph{Priority Boosting}, \emph{Priority Donation} or \emph{Priority
+ Lending}.} in the scheduling software.
- The idea behind PIP is to let the thread $L$ temporarily inherit
- the high priority from $H$ until $L$ leaves the critical section
+ The idea behind PIP is to let the thread $L$ temporarily inherit the
+ high priority from $H$ until $L$ leaves the critical section
unlocking the resource. This solves the problem of $H$ having to
wait indefinitely, because $L$ cannot be blocked by threads having
priority $M$. While a few other solutions exist for the Priority
@@ -83,21 +82,21 @@
implemented. This includes VxWorks (a proprietary real-time OS used
in the Mars Pathfinder mission, in Boeing's 787 Dreamliner, Honda's
ASIMO robot, etc.) and ThreadX (another proprietary real-time OS
- used in HP inkjet printers \cite{ThreadX}), but also
- the POSIX 1003.1c Standard realised for
- example in libraries for FreeBSD, Solaris and Linux.
+ used in nearly all HP inkjet printers \cite{ThreadX}), but also the
+ POSIX 1003.1c Standard realised for example in libraries for
+ FreeBSD, Solaris and Linux.
- Two advantages of PIP are that it is deterministic and that increasing the priority of a thread
- can be performed dynamically by the scheduler.
- This is in contrast to \emph{Priority Ceiling}
+ Two advantages of PIP are that it is deterministic and that
+ increasing the priority of a thread can be performed dynamically by
+ the scheduler. This is in contrast to \emph{Priority Ceiling}
\cite{Sha90}, another solution to the Priority Inversion problem,
which requires static analysis of the program in order to prevent
- Priority Inversion, and also in contrast to the Windows NT scheduler, which avoids
- this problem by randomly boosting the priority of ready low-priority threads
- (see for instance~\cite{WINDOWSNT}).
- However, there has also been strong criticism against
- PIP. For instance, PIP cannot prevent deadlocks when lock
- dependencies are circular, and also blocking times can be
+ Priority Inversion, and also in contrast to the approach taken in
+ the Windows NT scheduler, which avoids this problem by randomly
+ boosting the priority of ready low-priority threads (see for
+ instance~\cite{WINDOWSNT}). However, there has also been strong
+ criticism against PIP. For instance, PIP cannot prevent deadlocks
+ when lock dependencies are circular, and also blocking times can be
substantial (more than just the duration of a critical section).
Though, most criticism against PIP centres around unreliable
implementations and PIP being too complicated and too inefficient.
@@ -108,18 +107,19 @@
are either incomplete (and unreliable) or surprisingly complex and intrusive.''
\end{quote}
- \noindent
- He suggests avoiding PIP altogether by designing the system so that no
- priority inversion may happen in the first place. However, such ideal designs may
- not always be achievable in practice.
+ \noindent He suggests avoiding PIP altogether by designing the
+ system so that no priority inversion may happen in the first
+ place. However, such ideal designs may not always be achievable in
+ practice.
In our opinion, there is clearly a need for investigating correct
- algorithms for PIP. A few specifications for PIP exist (in English)
- and also a few high-level descriptions of implementations (e.g.~in
- the textbook \cite[Section 5.6.5]{Vahalia96}), but they help little
- with actual implementations. That this is a problem in practice is
- proved by an email by Baker, who wrote on 13 July 2009 on the Linux
- Kernel mailing list:
+ algorithms for PIP. A few specifications for PIP exist (in informal
+ English) and also a few high-level descriptions of implementations
+ (e.g.~in the textbooks \cite[Section 12.3.1]{Liu00} and
+ \cite[Section 5.6.5]{Vahalia96}), but they help little with actual
+ implementations. That this is a problem in practice is proved by an
+ email by Baker, who wrote on 13 July 2009 on the Linux Kernel
+ mailing list:
\begin{quote}
\it{}``I observed in the kernel code (to my disgust), the Linux PIP
@@ -129,64 +129,147 @@
wait operations.''
\end{quote}
- \noindent
- The criticism by Yodaiken, Baker and others suggests another look
- at PIP from a more abstract level (but still concrete enough
- to inform an implementation), and makes PIP a good candidate for a
- formal verification. An additional reason is that the original
- presentation of PIP~\cite{Sha90}, despite being informally
- ``proved'' correct, is actually \emph{flawed}.
+ \noindent The criticism by Yodaiken, Baker and others suggests
+ another look at PIP from a more abstract level (but still concrete
+ enough to inform an implementation), and makes PIP a good candidate
+ for a formal verification. An additional reason is that the original
+ specification of PIP~\cite{Sha90}, despite being informally
+ ``proved'' correct, is actually \emph{flawed}.
+
+ Yodaiken \cite{Yodaiken02} and also Moylan et
+ al.~\cite{deinheritance} point to a subtlety that had been
+ overlooked in the informal proof by Sha et al. They specify PIP in
+ \cite{Sha90} so that after the thread (whose priority has been
+ raised) completes its critical section and releases the lock, it
+ ``{\it returns to its original priority level}''. This leads them to
+ believe that an implementation of PIP is ``{\it rather
+ straightforward}''~\cite{Sha90}. Unfortunately, as Yodaiken and
+ Moylan et al.~point out, this behaviour is too simplistic. Moylan et
+ al.~write that there are ``{\it some hidden
+ traps}''~\cite{deinheritance}. Consider the case where the low
+ priority thread $L$ locks \emph{two} resources, and two
+ high-priority threads $H$ and $H'$ each wait for one of them. If
+ $L$ releases one resource so that $H$, say, can proceed, then we
+ still have Priority Inversion with $H'$ (which waits for the other
+ resource). The correct behaviour for $L$ is to switch to the highest
+ remaining priority of the threads that it blocks. A similar error
+ is made in the textbook \cite[Section 2.3.1]{book} which specifies
+ for a process that inherited a higher priority and exits a critical
+ section ``{\it it resumes the priority it had at the point of entry
+ into the critical section}''. This error can also be found in the
+ more recent textbook \cite[Page 119]{Laplante11} where the authors
+ state: ``{\it when [the task] exits the critical section that caused
+ the block, it reverts to the priority it had when it entered that
+ section}''. The textbook \cite[Page 286]{Liu00} contains a simlar
+ flawed specification and even goes on to develop pseudo-code based
+ on this flawed specification. Accordingly, the operating system
+ primitives for inheritance and restoration of priorities in
+ \cite{Liu00} depend on maintaining a data structure called
+ \emph{inheritance log}. This log is maintained for every thread and
+ broadly specified as containing ``{\it [h]istorical information on
+ how the thread inherited its current priority}'' \cite[Page
+ 527]{Liu00}. Unfortunately, the important information about actually
+ computing the priority to be restored solely from this log is not
+ explained in \cite{Liu00} but left as an ``{\it excercise}'' to the
+ reader. Of course, a correct version of PIP does not need to
+ maintain this (potentially expensive) data structure at
+ all. Surprisingly also the widely read and frequently updated
+ textbook \cite{Silberschatz13} gives the wrong specification. For
+ example on Page 254 the authors write: ``{\it Upon releasing the
+ lock, the [low-priority] thread will revert to its original
+ priority.}'' The same error is also repeated later in this textbook.
+
+
+ While \cite{Laplante11,Liu00,book,Sha90,Silberschatz13} are the only
+ formal publications we have found that specify the incorrect
+ behaviour, it seems also many informal descriptions of PIP overlook
+ the possibility that another high-priority might wait for a
+ low-priority process to finish. A notable exception is the texbook
+ \cite{buttazzo}, which gives the correct behaviour of resetting the
+ priority of a thread to the highest remaining priority of the
+ threads it blocks. This textbook also gives an informal proof for
+ the correctness of PIP in the style of Sha et al. Unfortunately,
+ this informal proof is too vague to be useful for formalising the
+ correctness of PIP and the specification leaves out nearly all
+ details in order to implement PIP efficiently.\medskip\smallskip
+ %
+ %The advantage of formalising the
+ %correctness of a high-level specification of PIP in a theorem prover
+ %is that such issues clearly show up and cannot be overlooked as in
+ %informal reasoning (since we have to analyse all possible behaviours
+ %of threads, i.e.~\emph{traces}, that could possibly happen).
- Yodaiken \cite{Yodaiken02} and also Moylan et al.~\cite{deinheritance}
- point to a subtlety that had been
- overlooked in the informal proof by Sha et al. They specify in
- \cite{Sha90} that after the thread (whose priority has been raised)
- completes its critical section and releases the lock, it ``returns
- to its original priority level.'' This leads them to believe that an
- implementation of PIP is ``rather straightforward''~\cite{Sha90}.
- Unfortunately, as Yodaiken and Moylan et al.~point out, this behaviour is too
- simplistic. Consider the case where the low priority thread $L$
- locks \emph{two} resources, and two high-priority threads $H$ and
- $H'$ each wait for one of them. If $L$ releases one resource
- so that $H$, say, can proceed, then we still have Priority Inversion
- with $H'$ (which waits for the other resource). The correct
- behaviour for $L$ is to switch to the highest remaining priority of
- the threads that it blocks. A similar error is made in the textbook
- \cite[Section 2.3.1]{book} which specifies for a process that
- inherited a higher priority and exits a critical section ``it resumes
- the priority it had at the point of entry into the critical section''.
-
- While \cite{book} and
- \cite{Sha90} are the only formal publications we have
- found that describe the incorrect behaviour, not all, but many
- informal\footnote{informal as in ``found on the Web''}
- descriptions of PIP overlook the possibility that another
- high-priority might wait for a low-priority process to finish.
- The advantage of formalising the
- correctness of a high-level specification of PIP in a theorem prover
- is that such issues clearly show up and cannot be overlooked as in
- informal reasoning (since we have to analyse all possible behaviours
- of threads, i.e.~\emph{traces}, that could possibly happen).\medskip\smallskip
+ \noindent {\bf Contributions:} There have been earlier formal
+ investigations into PIP \cite{Faria08,Jahier09,Wellings07}, but they
+ employ model checking techniques. This paper presents a formalised
+ and mechanically checked proof for the correctness of PIP. For this
+ we needed to design a new correctness criterion for PIP. In contrast
+ to model checking, our formalisation provides insight into why PIP
+ is correct and allows us to prove stronger properties that, as we
+ will show, can help with an efficient implementation of PIP. We
+ illustrate this with an implementation of PIP in the educational
+ PINTOS operating system \cite{PINTOS}. For example, we found by
+ ``playing'' with the formalisation that the choice of the next
+ thread to take over a lock when a resource is released is irrelevant
+ for PIP being correct---a fact that has not been mentioned in the
+ literature and not been used in the reference implementation of PIP
+ in PINTOS. This fact, however, is important for an efficient
+ implementation of PIP, because we can give the lock to the thread
+ with the highest priority so that it terminates more quickly. We
+ were also being able to generalise the scheduler of Sha et
+ al.~\cite{Sha90} to the practically relevant case where critical
+ sections can overlap; see Figure~\ref{overlap} \emph{a)} below for
+ an example of this restriction. In the existing literature there is
+ no proof and also no proving method that cover this generalised
+ case.
+
+ \begin{figure}
+ \begin{center}
+ \begin{tikzpicture}[scale=1]
+ %%\draw[step=2mm] (0,0) grid (10,2);
+ \draw [->,line width=0.6mm] (0,0) -- (10,0);
+ \draw [->,line width=0.6mm] (0,1.5) -- (10,1.5);
+ \draw [line width=0.6mm, pattern=horizontal lines] (0.8,0) rectangle (4,0.5);
+ \draw [line width=0.6mm, pattern=north east lines] (3.0,0) rectangle (6,0.5);
+ \draw [line width=0.6mm, pattern=vertical lines] (5.0,0) rectangle (9,0.5);
- \noindent
- {\bf Contributions:} There have been earlier formal investigations
- into PIP \cite{Faria08,Jahier09,Wellings07}, but they employ model
- checking techniques. This paper presents a formalised and
- mechanically checked proof for the correctness of PIP. For this we
- needed to design a new correctness criterion for PIP. In contrast to model checking, our
- formalisation provides insight into why PIP is correct and allows us
- to prove stronger properties that, as we will show, can help with an
- efficient implementation of PIP in the educational PINTOS operating
- system \cite{PINTOS}. For example, we found by ``playing'' with the
- formalisation that the choice of the next thread to take over a lock
- when a resource is released is irrelevant for PIP being correct---a
- fact that has not been mentioned in the literature and not been used
- in the reference implementation of PIP in PINTOS. This fact, however, is important
- for an efficient implementation of PIP, because we can give the lock
- to the thread with the highest priority so that it terminates more
- quickly. We were also able to generalise the scheduler of Sha
- et al.~\cite{Sha90} to the practically relevant case where critical
- sections can overlap.
+ \draw [line width=0.6mm, pattern=horizontal lines] (0.6,1.5) rectangle (4.0,2);
+ \draw [line width=0.6mm, pattern=north east lines] (1.0,1.5) rectangle (3.4,2);
+ \draw [line width=0.6mm, pattern=vertical lines] (5.0,1.5) rectangle (8.8,2);
+
+ \node at (0.8,-0.3) {@{term "P\<^sub>1"}};
+ \node at (3.0,-0.3) {@{term "P\<^sub>2"}};
+ \node at (4.0,-0.3) {@{term "V\<^sub>1"}};
+ \node at (5.0,-0.3) {@{term "P\<^sub>3"}};
+ \node at (6.0,-0.3) {@{term "V\<^sub>2"}};
+ \node at (9.0,-0.3) {@{term "V\<^sub>3"}};
+
+ \node at (0.6,1.2) {@{term "P\<^sub>1"}};
+ \node at (1.0,1.2) {@{term "P\<^sub>2"}};
+ \node at (3.4,1.2) {@{term "V\<^sub>2"}};
+ \node at (4.0,1.2) {@{term "V\<^sub>1"}};
+ \node at (5.0,1.2) {@{term "P\<^sub>3"}};
+ \node at (8.8,1.2) {@{term "V\<^sub>3"}};
+ \node at (10.3,0) {$t$};
+ \node at (10.3,1.5) {$t$};
+
+ \node at (-0.3,0.2) {$b)$};
+ \node at (-0.3,1.7) {$a)$};
+ \end{tikzpicture}\mbox{}\\[-10mm]\mbox{}
+ \end{center}
+ \caption{Assume a process is over time locking and unlocking, say, three resources.
+ The locking requests are labelled @{term "P\<^sub>1"}, @{term "P\<^sub>2"}, and @{term "P\<^sub>3"}
+ respectively, and the corresponding unlocking operations are labelled
+ @{term "V\<^sub>1"}, @{term "V\<^sub>2"}, and @{term "V\<^sub>3"}.
+ Then graph $a)$ shows \emph{properly nested} critical sections as required
+ by Sha et al.~\cite{Sha90} in their proof---the sections must either be contained within
+ each other
+ (the section @{term "P\<^sub>2"}--@{term "V\<^sub>2"} is contained in @{term "P\<^sub>1"}--@{term "V\<^sub>1"}) or
+ be independent (@{term "P\<^sub>3"}--@{term "V\<^sub>3"} is independent from the other
+ two). Graph $b)$ shows the general case where
+ the locking and unlocking of different critical sections can
+ overlap.\label{overlap}}
+ \end{figure}
*}
section {* Formal Model of the Priority Inheritance Protocol\label{model} *}
@@ -205,9 +288,9 @@
\begin{isabelle}\ \ \ \ \ %%%
\mbox{\begin{tabular}{r@ {\hspace{2mm}}c@ {\hspace{2mm}}l@ {\hspace{7mm}}l}
\isacommand{datatype} event
- & @{text "="} & @{term "Create thread priority"}\\
+ & @{text "="} & @{term "Create thread priority\<iota>"}\\
& @{text "|"} & @{term "Exit thread"} \\
- & @{text "|"} & @{term "Set thread priority"} & {\rm reset of the priority for} @{text thread}\\
+ & @{text "|"} & @{term "Set thread priority\<iota>"} & {\rm reset of the priority for} @{text thread}\\
& @{text "|"} & @{term "P thread cs"} & {\rm request of resource} @{text "cs"} {\rm by} @{text "thread"}\\
& @{text "|"} & @{term "V thread cs"} & {\rm release of resource} @{text "cs"} {\rm by} @{text "thread"}
\end{tabular}}
@@ -235,37 +318,37 @@
\end{isabelle}
\noindent
- In this definition @{term "DUMMY # DUMMY"} stands for list-cons.
+ In this definition @{term "DUMMY # DUMMY"} stands for list-cons and @{term "[]"} for the empty list.
Another function calculates the priority for a thread @{text "th"}, which is
defined as
\begin{isabelle}\ \ \ \ \ %%%
\mbox{\begin{tabular}{lcl}
- @{thm (lhs) original_priority.simps(1)[where thread="th"]} & @{text "\<equiv>"} &
- @{thm (rhs) original_priority.simps(1)[where thread="th"]}\\
- @{thm (lhs) original_priority.simps(2)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
- @{thm (rhs) original_priority.simps(2)[where thread="th" and thread'="th'"]}\\
- @{thm (lhs) original_priority.simps(3)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
- @{thm (rhs) original_priority.simps(3)[where thread="th" and thread'="th'"]}\\
- @{term "original_priority th (DUMMY#s)"} & @{text "\<equiv>"} & @{term "original_priority th s"}\\
+ @{thm (lhs) priority.simps(1)[where thread="th"]} & @{text "\<equiv>"} &
+ @{thm (rhs) priority.simps(1)[where thread="th"]}\\
+ @{thm (lhs) priority.simps(2)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
+ @{thm (rhs) priority.simps(2)[where thread="th" and thread'="th'"]}\\
+ @{thm (lhs) priority.simps(3)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
+ @{thm (rhs) priority.simps(3)[where thread="th" and thread'="th'"]}\\
+ @{term "priority th (DUMMY#s)"} & @{text "\<equiv>"} & @{term "priority th s"}\\
\end{tabular}}
\end{isabelle}
\noindent
In this definition we set @{text 0} as the default priority for
threads that have not (yet) been created. The last function we need
- calculates the ``time'', or index, at which time a process had its
+ calculates the ``time'', or index, at which time a thread had its
priority last set.
\begin{isabelle}\ \ \ \ \ %%%
\mbox{\begin{tabular}{lcl}
- @{thm (lhs) birthtime.simps(1)[where thread="th"]} & @{text "\<equiv>"} &
- @{thm (rhs) birthtime.simps(1)[where thread="th"]}\\
- @{thm (lhs) birthtime.simps(2)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
- @{thm (rhs) birthtime.simps(2)[where thread="th" and thread'="th'"]}\\
- @{thm (lhs) birthtime.simps(3)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
- @{thm (rhs) birthtime.simps(3)[where thread="th" and thread'="th'"]}\\
- @{term "birthtime th (DUMMY#s)"} & @{text "\<equiv>"} & @{term "birthtime th s"}\\
+ @{thm (lhs) last_set.simps(1)[where thread="th"]} & @{text "\<equiv>"} &
+ @{thm (rhs) last_set.simps(1)[where thread="th"]}\\
+ @{thm (lhs) last_set.simps(2)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
+ @{thm (rhs) last_set.simps(2)[where thread="th" and thread'="th'"]}\\
+ @{thm (lhs) last_set.simps(3)[where thread="th" and thread'="th'"]} & @{text "\<equiv>"} &
+ @{thm (rhs) last_set.simps(3)[where thread="th" and thread'="th'"]}\\
+ @{term "last_set th (DUMMY#s)"} & @{text "\<equiv>"} & @{term "last_set th s"}\\
\end{tabular}}
\end{isabelle}
@@ -280,14 +363,41 @@
\end{isabelle}
\noindent
+ We also use the abbreviation
+
+ \begin{isabelle}\ \ \ \ \ %%%
+ ???preceds s ths
+ \end{isabelle}
+
+ \noindent
+ for the set of precedences of threads @{text ths} in state @{text s}.
The point of precedences is to schedule threads not according to priorities (because what should
we do in case two threads have the same priority), but according to precedences.
Precedences allow us to always discriminate between two threads with equal priority by
taking into account the time when the priority was last set. We order precedences so
that threads with the same priority get a higher precedence if their priority has been
set earlier, since for such threads it is more urgent to finish their work. In an implementation
- this choice would translate to a quite natural FIFO-scheduling of processes with
- the same priority.
+ this choice would translate to a quite natural FIFO-scheduling of threads with
+ the same priority.
+
+ Moylan et al.~\cite{deinheritance} considered the alternative of
+ ``time-slicing'' threads with equal priority, but found that it does not lead to
+ advantages in practice. On the contrary, according to their work having a policy
+ like our FIFO-scheduling of threads with equal priority reduces the number of
+ tasks involved in the inheritance process and thus minimises the number
+ of potentially expensive thread-switches.
+
+ We will also need counters for @{term P} and @{term V} events of a thread @{term th}
+ in a state @{term s}. This can be straightforwardly defined in Isabelle as
+
+ \begin{isabelle}\ \ \ \ \ %%%
+ \mbox{\begin{tabular}{@ {}l}
+ @{thm cntP_def}\\
+ @{thm cntV_def}
+ \end{tabular}}
+ \end{isabelle}
+
+ \noindent using the predefined function @{const count} for lists.
Next, we introduce the concept of \emph{waiting queues}. They are
lists of threads associated with every resource. The first thread in
@@ -335,7 +445,7 @@
as the union of the sets of waiting and holding edges, namely
\begin{isabelle}\ \ \ \ \ %%%
- @{thm cs_depend_def}
+ @{thm cs_RAG_def}
\end{isabelle}
@@ -385,7 +495,7 @@
so that every thread can be in the possession of several resources, that is
it has potentially several incoming holding edges in the RAG, but has at most one outgoing
waiting edge. The reason is that when a thread asks for resource that is locked
- already, then the process is blocked and cannot ask for another resource.
+ already, then the thread is blocked and cannot ask for another resource.
Clearly, also every resource can only have at most one outgoing holding edge---indicating
that the resource is locked. In this way we can always start at a thread waiting for a
resource and ``chase'' outgoing arrows leading to a single root of a tree.
@@ -394,16 +504,16 @@
The use of relations for representing RAGs allows us to conveniently define
the notion of the \emph{dependants} of a thread using the transitive closure
- operation for relations. This gives
+ operation for relations, written ~@{term "trancl DUMMY"}. This gives
\begin{isabelle}\ \ \ \ \ %%%
- @{thm cs_dependents_def}
+ @{thm cs_dependants_def}
\end{isabelle}
\noindent
This definition needs to account for all threads that wait for a thread to
release a resource. This means we need to include threads that transitively
- wait for a resource being released (in the picture above this means the dependants
+ wait for a resource to be released (in the picture above this means the dependants
of @{text "th\<^sub>0"} are @{text "th\<^sub>1"} and @{text "th\<^sub>2"}, which wait for resource @{text "cs\<^sub>1"},
but also @{text "th\<^sub>3"},
which cannot make any progress unless @{text "th\<^sub>2"} makes progress, which
@@ -423,7 +533,7 @@
\noindent
where the dependants of @{text th} are given by the waiting queue function.
- While the precedence @{term prec} of a thread is determined statically
+ While the precedence @{term prec} of any thread is determined statically
(for example when the thread is
created), the point of the current precedence is to let the scheduler increase this
precedence, if needed according to PIP. Therefore the current precedence of @{text th} is
@@ -431,7 +541,8 @@
threads that are dependants of @{text th}. Since the notion @{term "dependants"} is
defined as the transitive closure of all dependent threads, we deal correctly with the
problem in the informal algorithm by Sha et al.~\cite{Sha90} where a priority of a thread is
- lowered prematurely.
+ lowered prematurely. We again introduce an abbreviation for current precedeces of
+ a set of threads, written @{term "cprecs wq s ths"}.
The next function, called @{term schs}, defines the behaviour of the scheduler. It will be defined
by recursion on the state (a list of events); this function returns a \emph{schedule state}, which
@@ -542,16 +653,18 @@
\end{tabular}
\end{isabelle}
- Having the scheduler function @{term schs} at our disposal, we can ``lift'', or
- overload, the notions
- @{term waiting}, @{term holding}, @{term depend} and @{term cp} to operate on states only.
+ Having the scheduler function @{term schs} at our disposal, we can
+ ``lift'', or overload, the notions @{term waiting}, @{term holding},
+ @{term RAG}, @{term dependants} and @{term cp} to operate on states
+ only.
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}rcl}
- @{thm (lhs) s_holding_abv} & @{text "\<equiv>"} & @{thm (rhs) s_holding_abv}\\
- @{thm (lhs) s_waiting_abv} & @{text "\<equiv>"} & @{thm (rhs) s_waiting_abv}\\
- @{thm (lhs) s_depend_abv} & @{text "\<equiv>"} & @{thm (rhs) s_depend_abv}\\
- @{thm (lhs) cp_def} & @{text "\<equiv>"} & @{thm (rhs) cp_def}
+ @{thm (lhs) s_holding_abv} & @{text "\<equiv>"} & @{thm (rhs) s_holding_abv}\\
+ @{thm (lhs) s_waiting_abv} & @{text "\<equiv>"} & @{thm (rhs) s_waiting_abv}\\
+ @{thm (lhs) s_RAG_abv} & @{text "\<equiv>"} & @{thm (rhs) s_RAG_abv}\\
+ @{thm (lhs) s_dependants_abv}& @{text "\<equiv>"} & @{thm (rhs) s_dependants_abv}\\
+ @{thm (lhs) cp_def} & @{text "\<equiv>"} & @{thm (rhs) cp_def}\\
\end{tabular}
\end{isabelle}
@@ -570,7 +683,7 @@
\end{isabelle}
\noindent
- In the second definition @{term "DUMMY ` DUMMY"} stands for the image of a set under a function.
+ %%In the second definition @{term "DUMMY ` DUMMY"} stands for the image of a set under a function.
Note that in the initial state, that is where the list of events is empty, the set
@{term threads} is empty and therefore there is neither a thread ready nor running.
If there is one or more threads ready, then there can only be \emph{one} thread
@@ -648,7 +761,7 @@
assumption on how different resources can be locked and released relative to each
other. In our model it is possible that critical sections overlap. This is in
contrast to Sha et al \cite{Sha90} who require that critical sections are
- properly nested.
+ properly nested (recall Fig.~\ref{overlap}).
A valid state of PIP can then be conveniently be defined as follows:
@@ -671,51 +784,56 @@
begin
(*>*)
text {*
+
Sha et al.~state their first correctness criterion for PIP in terms
of the number of low-priority threads \cite[Theorem 3]{Sha90}: if
there are @{text n} low-priority threads, then a blocked job with
high priority can only be blocked a maximum of @{text n} times.
- Their second correctness criterion is given
- in terms of the number of critical resources \cite[Theorem 6]{Sha90}: if there are
- @{text m} critical resources, then a blocked job with high priority
- can only be blocked a maximum of @{text m} times. Both results on their own, strictly speaking, do
- \emph{not} prevent indefinite, or unbounded, Priority Inversion,
- because if a low-priority thread does not give up its critical
- resource (the one the high-priority thread is waiting for), then the
- high-priority thread can never run. The argument of Sha et al.~is
- that \emph{if} threads release locked resources in a finite amount
- of time, then indefinite Priority Inversion cannot occur---the high-priority
- thread is guaranteed to run eventually. The assumption is that
- programmers must ensure that threads are programmed in this way. However, even
- taking this assumption into account, the correctness properties of
- Sha et al.~are
- \emph{not} true for their version of PIP---despite being ``proved''. As Yodaiken
- \cite{Yodaiken02} and Moylan et al.~\cite{deinheritance} pointed out: If a low-priority thread possesses
- locks to two resources for which two high-priority threads are
- waiting for, then lowering the priority prematurely after giving up
- only one lock, can cause indefinite Priority Inversion for one of the
- high-priority threads, invalidating their two bounds.
+ Their second correctness criterion is given in terms of the number
+ of critical resources \cite[Theorem 6]{Sha90}: if there are @{text
+ m} critical resources, then a blocked job with high priority can
+ only be blocked a maximum of @{text m} times. Both results on their
+ own, strictly speaking, do \emph{not} prevent indefinite, or
+ unbounded, Priority Inversion, because if a low-priority thread does
+ not give up its critical resource (the one the high-priority thread
+ is waiting for), then the high-priority thread can never run. The
+ argument of Sha et al.~is that \emph{if} threads release locked
+ resources in a finite amount of time, then indefinite Priority
+ Inversion cannot occur---the high-priority thread is guaranteed to
+ run eventually. The assumption is that programmers must ensure that
+ threads are programmed in this way. However, even taking this
+ assumption into account, the correctness properties of Sha et
+ al.~are \emph{not} true for their version of PIP---despite being
+ ``proved''. As Yodaiken \cite{Yodaiken02} and Moylan et
+ al.~\cite{deinheritance} pointed out: If a low-priority thread
+ possesses locks to two resources for which two high-priority threads
+ are waiting for, then lowering the priority prematurely after giving
+ up only one lock, can cause indefinite Priority Inversion for one of
+ the high-priority threads, invalidating their two bounds.
Even when fixed, their proof idea does not seem to go through for
us, because of the way we have set up our formal model of PIP. One
- reason is that we allow critical sections, which start with a @{text P}-event
- and finish with a corresponding @{text V}-event, to arbitrarily overlap
- (something Sha et al.~explicitly exclude). Therefore we have
- designed a different correctness criterion for PIP. The idea behind
- our criterion is as follows: for all states @{text s}, we know the
- corresponding thread @{text th} with the highest precedence; we show
- that in every future state (denoted by @{text "s' @ s"}) in which
- @{text th} is still alive, either @{text th} is running or it is
- blocked by a thread that was alive in the state @{text s} and was waiting
- for or in the possession of a lock in @{text s}. Since in @{text s}, as in
- every state, the set of alive threads is finite, @{text th} can only
- be blocked a finite number of times. This is independent of how many
- threads of lower priority are created in @{text "s'"}. We will actually prove a
+ reason is that we allow critical sections, which start with a @{text
+ P}-event and finish with a corresponding @{text V}-event, to
+ arbitrarily overlap (something Sha et al.~explicitly exclude).
+ Therefore we have designed a different correctness criterion for
+ PIP. The idea behind our criterion is as follows: for all states
+ @{text s}, we know the corresponding thread @{text th} with the
+ highest precedence; we show that in every future state (denoted by
+ @{text "s' @ s"}) in which @{text th} is still alive, either @{text
+ th} is running or it is blocked by a thread that was alive in the
+ state @{text s} and was waiting for or in the possession of a lock
+ in @{text s}. Since in @{text s}, as in every state, the set of
+ alive threads is finite, @{text th} can only be blocked a finite
+ number of times. This is independent of how many threads of lower
+ priority are created in @{text "s'"}. We will actually prove a
stronger statement where we also provide the current precedence of
- the blocking thread. However, this correctness criterion hinges upon
- a number of assumptions about the states @{text s} and @{text "s' @
- s"}, the thread @{text th} and the events happening in @{text
- s'}. We list them next:
+ the blocking thread.
+
+ However, this correctness criterion hinges upon a number of
+ assumptions about the states @{text s} and @{text "s' @ s"}, the
+ thread @{text th} and the events happening in @{text s'}. We list
+ them next:
\begin{quote}
{\bf Assumptions on the states {\boldmath@{text s}} and
@@ -736,7 +854,7 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{l}
@{term "th \<in> threads s"}\\
- @{term "prec th s = Max (cprec s ` threads s)"}\\
+ @{term "prec th s = Max (cprecs s (threads s))"}\\
@{term "prec th s = (prio, DUMMY)"}
\end{tabular}
\end{isabelle}
@@ -759,9 +877,9 @@
\end{isabelle}
\end{quote}
- \noindent
- The locale mechanism of Isabelle helps us to manage conveniently such assumptions~\cite{Haftmann08}.
- Under these assumptions we shall prove the following correctness property:
+ \noindent The locale mechanism of Isabelle helps us to manage
+ conveniently such assumptions~\cite{Haftmann08}. Under these
+ assumptions we shall prove the following correctness property:
\begin{theorem}\label{mainthm}
Given the assumptions about states @{text "s"} and @{text "s' @ s"},
@@ -771,31 +889,130 @@
@{term "cp (s' @ s) th' = prec th s"}.
\end{theorem}
- \noindent
- This theorem ensures that the thread @{text th}, which has the
- highest precedence in the state @{text s}, can only be blocked in
- the state @{text "s' @ s"} by a thread @{text th'} that already
- existed in @{text s} and requested or had a lock on at least
- one resource---that means the thread was not \emph{detached} in @{text s}.
- As we shall see shortly, that means there are only finitely
- many threads that can block @{text th} in this way and then they
+ \noindent This theorem ensures that the thread @{text th}, which has
+ the highest precedence in the state @{text s}, can only be blocked
+ in the state @{text "s' @ s"} by a thread @{text th'} that already
+ existed in @{text s} and requested or had a lock on at least one
+ resource---that means the thread was not \emph{detached} in @{text
+ s}. As we shall see shortly, that means there are only finitely
+ many threads that can block @{text th} in this way and then they
need to run with the same precedence as @{text th}.
- Like in the argument by Sha et al.~our
- finite bound does not guarantee absence of indefinite Priority
- Inversion. For this we further have to assume that every thread
- gives up its resources after a finite amount of time. We found that
- this assumption is awkward to formalise in our model. Therefore we
- leave it out and let the programmer assume the responsibility to
- program threads in such a benign manner (in addition to causing no
- circularity in the RAG). In this detail, we do not
- make any progress in comparison with the work by Sha et al.
+ Like in the argument by Sha et al.~our finite bound does not
+ guarantee absence of indefinite Priority Inversion. For this we
+ further have to assume that every thread gives up its resources
+ after a finite amount of time. We found that this assumption is
+ awkward to formalise in our model. There are mainly two reasons for
+ this: First, we do not specify what ``running'' the code of a thread
+ means, for example by giving an operational semantics for machine
+ instructions. Therefore we cannot characterise what are ``good''
+ programs that contain for every looking request also a corresponding
+ unlocking request for a resource. Second, we would need to specify a
+ kind of global clock that tracks the time how long a thread locks a
+ resource. But this seems difficult, because how do we conveniently
+ distinguish between a thread that ``just'' locks a resource for a
+ very long time and one that locks it forever. Therefore we decided
+ to leave out this property and let the programmer assume the
+ responsibility to program threads in such a benign manner (in
+ addition to causing no circularity in the RAG). In this detail, we
+ do not make any progress in comparison with the work by Sha et al.
However, we are able to combine their two separate bounds into a
single theorem improving their bound.
+ In what follows we will describe properties of PIP that allow us to
+ prove Theorem~\ref{mainthm} and, when instructive, briefly describe
+ our argument. Recall we want to prove that in state @{term "s' @ s"}
+ either @{term th} is either running or blocked by a thread @{term
+ "th'"} (@{term "th \<noteq> th'"}) which was alive in state @{term s}. We
+ can show that
+
+
+
+ \begin{lemma}
+ If @{thm (prem 2) eq_pv_blocked}
+ then @{thm (concl) eq_pv_blocked}
+ \end{lemma}
+
+ \begin{lemma}
+ If @{thm (prem 2) eq_pv_persist}
+ then @{thm (concl) eq_pv_persist}
+ \end{lemma}
+
+ \subsection*{\bf OUTLINE}
+
+ Since @{term "th"} is the most urgent thread, if it is somehow
+ blocked, people want to know why and wether this blocking is
+ reasonable.
+
+ @{thm [source] th_blockedE} @{thm th_blockedE}
+
+ if @{term "th"} is blocked, then there is a path leading from
+ @{term "th"} to @{term "th'"}, which means:
+ there is a chain of demand leading from @{term th} to @{term th'}.
+
+ %%% in other words
+ %%% th -> cs1 -> th1 -> cs2 -> th2 -> ... -> csn -> thn -> cs -> th'.
+ %%%
+ %%% We says that th is blocked by "th'".
+
+ THEN
+
+ @{thm [source] vat_t.th_chain_to_ready} @{thm vat_t.th_chain_to_ready}
+
+ It is basic propery with non-trival proof.
+
+ THEN
+
+ @{thm [source] max_preced} @{thm max_preced}
+
+ which says @{term "th"} holds the max precedence.
+
+ THEN
+
+ @{thm [source] th_cp_max th_cp_preced th_kept}
+ @{thm th_cp_max th_cp_preced th_kept}
+
+ THENTHEN
+
+ (here) %@ {thm [source] runing_inversion_4} @ {thm runing_inversion_4}
+
+ which explains what the @{term "th'"} looks like. Now, we have found the
+ @{term "th'"} which blocks @{term th}, we need to know more about it.
+ To see what kind of thread can block @{term th}.
+
+ From these two lemmas we can see the correctness of PIP, which is
+ that: the blockage of th is reasonable and under control.
+
+ Lemmas we want to describe:
+
+
+
+ \begin{lemma}
+ @{thm runing_cntP_cntV_inv}
+ \end{lemma}
+
+ \noindent
+ Remember we do not have the well-nestedness restriction in our
+ proof, which means the difference between the counters @{const cntV}
+ and @{const cntP} can be larger than @{term 1}.
+
+ \begin{lemma}
+ @{thm runing_inversion}
+ \end{lemma}
+
+
+ \begin{lemma}
+ @{thm th_blockedE}
+ \end{lemma}
+
+ \subsection*{END OUTLINE}
+
+
+
+
In what follows we will describe properties of PIP that allow us to prove
Theorem~\ref{mainthm} and, when instructive, briefly describe our argument.
- It is relatively easy to see that
+ It is relatively easy to see that:
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
@@ -805,14 +1022,15 @@
\end{isabelle}
\noindent
- The second property is by induction of @{term vt}. The next three
- properties are
+ The second property is by induction on @{term vt}. The next three
+ properties are:
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{thm[mode=IfThen] waiting_unique[of _ _ "cs\<^sub>1" "cs\<^sub>2"]}\\
- @{thm[mode=IfThen] held_unique[of _ "th\<^sub>1" _ "th\<^sub>2"]}\\
- @{thm[mode=IfThen] runing_unique[of _ "th\<^sub>1" "th\<^sub>2"]}
+ HERE??
+ %@ {thm[mode=IfThen] waiting_unique[of _ _ "cs\<^sub>1" "cs\<^sub>2"]}\\
+ %@ {thm[mode=IfThen] held_unique[of _ "th\<^sub>1" _ "th\<^sub>2"]}\\
+ %@ {thm[mode=IfThen] runing_unique[of _ "th\<^sub>1" "th\<^sub>2"]}
\end{tabular}
\end{isabelle}
@@ -826,13 +1044,13 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{text If}~@{thm (prem 1) acyclic_depend}~@{text "then"}:\\
- \hspace{5mm}@{thm (concl) acyclic_depend},
- @{thm (concl) finite_depend} and
+ HERE?? %@{text If}~@ {thm (prem 1) acyclic_RAG}~@{text "then"}:\\
+ \hspace{5mm}@{thm (concl) acyclic_RAG},
+ @{thm (concl) finite_RAG} and
@{thm (concl) wf_dep_converse},\\
- \hspace{5mm}@{text "if"}~@{thm (prem 2) dm_depend_threads}~@{text "then"}~@{thm (concl) dm_depend_threads}
+ %\hspace{5mm}@{text "if"}~@ {thm (prem 2) dm_RAG_threads}~@{text "then"}~@{thm (concl) dm_RAG_threads}
and\\
- \hspace{5mm}@{text "if"}~@{thm (prem 2) range_in}~@{text "then"}~@{thm (concl) range_in}.
+ %\hspace{5mm}@{text "if"}~@ {thm (prem 2) range_in}~@{text "then"}~@{thm (concl) range_in}.
\end{tabular}
\end{isabelle}
@@ -941,8 +1159,8 @@
% @ {thm [display] not_thread_holdents}
%\item When the number of @{text "P"} equals the number of @{text "V"}, the relevant
% thread does not hold any critical resource, therefore no thread can depend on it
- % (@{text "count_eq_dependents"}):
- % @ {thm [display] count_eq_dependents}
+ % (@{text "count_eq_dependants"}):
+ % @ {thm [display] count_eq_dependants}
%\end{enumerate}
%The reason that only threads which already held some resoures
@@ -1011,6 +1229,20 @@
%if every such thread can release all its resources in finite duration, then after finite
%duration, none of them may block @{term "th"} anymore. So, no priority inversion may happen
%then.
+
+ NOTE: about bounds in sha et al and ours:
+
+ There are low priority threads,
+ which do not hold any resources,
+ such thread will not block th.
+ Their Theorem 3 does not exclude such threads.
+
+ There are resources, which are not held by any low prioirty threads,
+ such resources can not cause blockage of th neither. And similiary,
+ theorem 6 does not exlude them.
+
+ Our one bound excudle them by using a different formaulation. "
+
*}
(*<*)
end
@@ -1031,7 +1263,7 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{thm children_def2}
+ HERE?? %%@ {thm children_def2}
\end{tabular}
\end{isabelle}
@@ -1041,15 +1273,15 @@
a resource). We can prove the following lemma.
\begin{lemma}\label{childrenlem}
- @{text "If"} @{thm (prem 1) cp_rec} @{text "then"}
+ HERE %@{text "If"} @ {thm (prem 1) cp_rec} @{text "then"}
\begin{center}
- @{thm (concl) cp_rec}.
+ %@ {thm (concl) cp_rec}.
\end{center}
\end{lemma}
\noindent
That means the current precedence of a thread @{text th} can be
- computed locally by considering only the children of @{text th}. In
+ computed locally by considering only the current precedences of the children of @{text th}. In
effect, it only needs to be recomputed for @{text th} when one of
its children changes its current precedence. Once the current
precedence is computed in this more efficient manner, the selection
@@ -1057,6 +1289,10 @@
a standard scheduling operation implemented in most operating
systems.
+ %\begin{proof}[of Lemma~\ref{childrenlem}]
+ %Test
+ %\end{proof}
+
Of course the main work for implementing PIP involves the
scheduler and coding how it should react to events. Below we
outline how our formalisation guides this implementation for each
@@ -1075,7 +1311,7 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{thm eq_dep},\\
+ HERE ?? %@ {thm eq_dep},\\
@{thm eq_cp_th}, and\\
@{thm[mode=IfThen] eq_cp}
\end{tabular}
@@ -1099,7 +1335,7 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{thm eq_dep}, and\\
+ HERE %@ {thm eq_dep}, and\\
@{thm[mode=IfThen] eq_cp}
\end{tabular}
\end{isabelle}
@@ -1148,9 +1384,9 @@
%
%\begin{isabelle}\ \ \ \ \ %%%
%\begin{tabular}{@ {}l}
- %@{thm[mode=IfThen] eq_up_self}\\
- %@{text "If"} @{thm (prem 1) eq_up}, @{thm (prem 2) eq_up} and @{thm (prem 3) eq_up}\\
- %@{text "then"} @{thm (concl) eq_up}.
+ %@ {thm[mode=IfThen] eq_up_self}\\
+ %@{text "If"} @ {thm (prem 1) eq_up}, @ {thm (prem 2) eq_up} and @ {thm (prem 3) eq_up}\\
+ %@{text "then"} @ {thm (concl) eq_up}.
%\end{tabular}
%\end{isabelle}
%
@@ -1178,7 +1414,7 @@
\begin{isabelle}\ \ \ \ \ %%%
- @{thm depend_s}
+ @{thm RAG_s}
\end{isabelle}
\noindent
@@ -1201,7 +1437,7 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{thm depend_s}\\
+ @{thm RAG_s}\\
@{thm eq_cp}
\end{tabular}
\end{isabelle}
@@ -1220,8 +1456,8 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{thm depend_s}\\
- @{thm eq_cp}
+ @{thm RAG_s}\\
+ HERE %@ {thm eq_cp}
\end{tabular}
\end{isabelle}
@@ -1233,8 +1469,8 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
- @{thm depend_s}\\
- @{thm[mode=IfThen] eq_cp}
+ @{thm RAG_s}\\
+ HERE %@ {thm[mode=IfThen] eq_cp}
\end{tabular}
\end{isabelle}
@@ -1253,11 +1489,12 @@
\begin{isabelle}\ \ \ \ \ %%%
\begin{tabular}{@ {}l}
%%@ {t hm[mode=IfThen] eq_up_self}\\
- @{text "If"} @{thm (prem 1) eq_up}, @{thm (prem 2) eq_up} and @{thm (prem 3) eq_up}\\
- @{text "then"} @{thm (concl) eq_up}.
+ HERE
+ %@{text "If"} @ {thm (prem 1) eq_up}, @ {thm (prem 2) eq_up} and @ {thm (prem 3) eq_up}\\
+ %@{text "then"} @ {thm (concl) eq_up}.
\end{tabular}
\end{isabelle}
-
+
\noindent
This lemma states that if an intermediate @{term cp}-value does not change, then
the procedure can also stop, because none of its dependent threads will
@@ -1269,7 +1506,13 @@
be recalculated for an event. This information is provided by the lemmas we proved.
We confirmed that our observations translate into practice by implementing
our version of PIP on top of PINTOS, a small operating system written in C and used for teaching at
- Stanford University \cite{PINTOS}. To implement PIP, we only need to modify the kernel
+ Stanford University \cite{PINTOS}. An alternative would have been the small Xv6 operating
+ system used for teaching at MIT \cite{Xv6link,Xv6}. However this operating system implements
+ a simple round robin scheduler that lacks stubs for dealing with priorities. This
+ is inconvenient for our purposes.
+
+
+ To implement PIP in PINTOS, we only need to modify the kernel
functions corresponding to the events in our formal model. The events translate to the following
function interface in PINTOS:
@@ -1450,7 +1693,15 @@
the next thread which takes over a lock is irrelevant for the correctness
of PIP. Moreover, we eliminated a crucial restriction present in
the proof of Sha et al.: they require that critical sections nest properly,
- whereas our scheduler allows critical sections to overlap.
+ whereas our scheduler allows critical sections to overlap. What we
+ are not able to do is to mechanically ``synthesise'' an actual implementation
+ from our formalisation. To do so for C-code seems quite hard and is beyond
+ current technology available for Isabelle. Also our proof-method based
+ on events is not ``computational'' in the sense of having a concrete
+ algorithm behind it: our formalisation is really more about the
+ specification of PIP and ensuring that it has the desired properties
+ (the informal specification by Sha et al.~did not).
+
PIP is a scheduling algorithm for single-processor systems. We are
now living in a multi-processor world. Priority Inversion certainly
@@ -1472,7 +1723,7 @@
points out an error in a paper about Preemption
Threshold Scheduling \cite{ThreadX}. The use of a theorem prover was
invaluable to us in order to be confident about the correctness of our reasoning
- (no case can be overlooked).
+ (for example no corner case can be overlooked).
The most closely related work to ours is the formal verification in
PVS of the Priority Ceiling Protocol done by Dutertre
\cite{dutertre99b}---another solution to the Priority Inversion
--- a/Journal/document/root.bib Wed May 14 11:52:53 2014 +0100
+++ b/Journal/document/root.bib Wed Jan 27 13:50:02 2016 +0000
@@ -1,3 +1,50 @@
+
+@Book{Silberschatz13,
+ author = {A.~Silberschatz and P.~B.~Galvin and G.~Gagne},
+ title = {Operating System Concepts},
+ publisher = {John Wiley \& Sons},
+ year = {2013},
+ edition = {9th}
+}
+
+@Book{liu00,
+ author = {J.~W.~S.~Liu},
+ title = {{R}eal-{T}ime {S}ystems},
+ publisher = {Prentice Hall},
+ year = {2000}
+}
+
+@Book{buttazzo,
+ author = {G.~C.~Buttazzo},
+ title = {{H}ard {R}eal-{T}ime {C}omputing {S}ystems: {P}redictable {S}cheduling
+ {A}lgorithms and {A}pplications},
+ publisher = {Springer},
+ year = {2011},
+ edition = {3rd}
+}
+
+@Book{Laplante11,
+ author = {P.~A.~Laplante and S.~J.~Ovaska},
+ title = {{R}eal-{T}ime {S}ystems {D}esign and {A}nalysis: {T}ools for the {P}ractitioner},
+ publisher = {Wiley-IEEE Press},
+ year = {2011},
+ edition = {4th}
+}
+
+@TechReport{Xv6,
+ author = {R.~Cox and F.~Kaashoek and R.~Morris},
+ title = {{X}v6: {A} {S}imple, {U}nix-like {T}eaching {O}perating {S}ystem},
+ institution = {MIT},
+ year = {2012}
+}
+
+@Misc{Xv6link,
+ author = {R.~Cox and F.~Kaashoek and R.~Morris},
+ title = {{Xv6}},
+ note = {\url{http://pdos.csail.mit.edu/6.828/2012/xv6.html}},
+}
+
+
@inproceedings{ThreadX,
author = {Y.~Wang and M.~Saksena},
title = {{S}cheduling {F}ixed-{P}riority {T}asks with {P}reemption {T}hreshold},
@@ -62,7 +109,7 @@
}
@phdthesis{Brandenburg11,
- Author = {Bj\"{o}rn B. Brandenburg},
+ Author = {B.~B.~Brandenburg},
School = {The University of North Carolina at Chapel Hill},
Title = {{S}cheduling and {L}ocking in
{M}ultiprocessor {R}eal-{T}ime {O}perating {S}ystems},
--- a/Journal/document/root.tex Wed May 14 11:52:53 2014 +0100
+++ b/Journal/document/root.tex Wed Jan 27 13:50:02 2016 +0000
@@ -18,6 +18,7 @@
\usepackage{url}
\usepackage{color}
\usepackage{courier}
+\usetikzlibrary{patterns}
\usepackage{listings}
\lstset{language=C,
numbers=left,
@@ -49,7 +50,12 @@
\begin{document}
\renewcommand{\thefootnote}{$\star$}
-\footnotetext[1]{This paper is a revised, corrected and expanded version of \cite{ZhangUrbanWu12}.}
+\footnotetext[1]{This paper is a revised, corrected and expanded version of \cite{ZhangUrbanWu12}.
+Compared with that paper we give an actual implementation of our formalised scheduling
+algorithm in C and the operating system PINTOS. Our implementation follows closely all results
+we proved about optimisations of the Priority Inheritance Protocol. We are giving in this paper
+more details about the proof and also surveying
+the existing literature in more depth.}
\renewcommand{\thefootnote}{\arabic{footnote}}
\title{Priority Inheritance Protocol Proved Correct}
@@ -59,28 +65,28 @@
\maketitle
\begin{abstract}
-In real-time systems with threads, resource locking and
-priority sched\-uling, one faces the problem of Priority
-Inversion. This problem can make the behaviour of threads
-unpredictable and the resulting bugs can be hard to find. The
-Priority Inheritance Protocol is one solution implemented in many
-systems for solving this problem, but the correctness of this solution
-has never been formally verified in a theorem prover. As already
-pointed out in the literature, the original informal investigation of
-the Property Inheritance Protocol presents a correctness ``proof'' for
-an \emph{incorrect} algorithm. In this paper we fix the problem of
-this proof by making all notions precise and implementing a variant of
-a solution proposed earlier. We also generalise the original informal proof to the
-practically relevant case where critical sections can
-overlap. Our formalisation in Isabelle/HOL not just
-uncovers facts not mentioned in the literature, but also shows how to
-efficiently implement this protocol. Earlier correct implementations
-were criticised as too inefficient. Our formalisation is based on
-Paulson's inductive approach to verifying protocols; our implementation
-builds on top of the small PINTOS operating system.\medskip
+In real-time systems with threads, resource locking and priority
+sched\-uling, one faces the problem of Priority Inversion. This
+problem can make the behaviour of threads unpredictable and the
+resulting bugs can be hard to find. The Priority Inheritance Protocol
+is one solution implemented in many systems for solving this problem,
+but the correctness of this solution has never been formally verified
+in a theorem prover. As already pointed out in the literature, the
+original informal investigation of the Property Inheritance Protocol
+presents a correctness ``proof'' for an \emph{incorrect} algorithm. In
+this paper we fix the problem of this proof by making all notions
+precise and implementing a variant of a solution proposed earlier. We
+also generalise the scheduling problem to the practically relevant case where
+critical sections can overlap. Our formalisation in Isabelle/HOL not
+just uncovers facts not mentioned in the literature, but also helps
+with implementing efficiently this protocol. Earlier correct
+implementations were criticised as too inefficient. Our formalisation
+is based on Paulson's inductive approach to verifying protocols; our
+implementation builds on top of the small PINTOS operating system used
+for teaching.\medskip
-%{\bf Keywords:} Priority Inheritance Protocol, formal correctness proof,
-%real-time systems, Isabelle/HOL
+{\bf Keywords:} Priority Inheritance Protocol, formal correctness proof,
+real-time systems, Isabelle/HOL
\end{abstract}
\input{session}
Binary file Literature/Hard_Real-Time_Computing_Sys.pdf has changed
Binary file Literature/Real-Time_systems-Liu.pdf has changed
Binary file Literature/disinheritance.pdf has changed
Binary file Literature/pip-multi-proc.pdf has changed
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Max.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,78 @@
+theory Max
+imports Main
+begin
+
+section {* Some generic facts about Max *}
+
+
+lemma Max_insert:
+ assumes "finite B"
+ and "B \<noteq> {}"
+ shows "Max ({x} \<union> B) = max x (Max B)"
+using assms by (simp add: Lattices_Big.Max.insert)
+
+lemma Max_Union:
+ assumes fc: "finite C"
+ and ne: "C \<noteq> {}"
+ and fa: "\<And> A. A \<in> C \<Longrightarrow> finite A \<and> A \<noteq> {}"
+ shows "Max (\<Union>C) = Max (Max ` C)"
+using assms
+proof(induct rule: finite_induct)
+ case (insert x F)
+ assume ih: "\<lbrakk>F \<noteq> {}; \<And>A. A \<in> F \<Longrightarrow> finite A \<and> A \<noteq> {}\<rbrakk> \<Longrightarrow> Max (\<Union>F) = Max (Max ` F)"
+ and h: "\<And> A. A \<in> insert x F \<Longrightarrow> finite A \<and> A \<noteq> {}"
+ show ?case (is "?L = ?R")
+ proof(cases "F = {}")
+ case False
+ from Union_insert have "?L = Max (x \<union> (\<Union> F))" by simp
+ also have "\<dots> = max (Max x) (Max(\<Union> F))"
+ proof(rule Max_Un)
+ from h[of x] show "finite x" by auto
+ next
+ from h[of x] show "x \<noteq> {}" by auto
+ next
+ show "finite (\<Union>F)"
+ by (metis (full_types) finite_Union h insert.hyps(1) insertCI)
+ next
+ from False and h show "\<Union>F \<noteq> {}" by auto
+ qed
+ also have "\<dots> = ?R"
+ proof -
+ have "?R = Max (Max ` ({x} \<union> F))" by simp
+ also have "\<dots> = Max ({Max x} \<union> (Max ` F))" by simp
+ also have "\<dots> = max (Max x) (Max (\<Union>F))"
+ proof -
+ have "Max ({Max x} \<union> Max ` F) = max (Max {Max x}) (Max (Max ` F))"
+ proof(rule Max_Un)
+ show "finite {Max x}" by simp
+ next
+ show "{Max x} \<noteq> {}" by simp
+ next
+ from insert show "finite (Max ` F)" by auto
+ next
+ from False show "Max ` F \<noteq> {}" by auto
+ qed
+ moreover have "Max {Max x} = Max x" by simp
+ moreover have "Max (\<Union>F) = Max (Max ` F)"
+ proof(rule ih)
+ show "F \<noteq> {}" by fact
+ next
+ from h show "\<And>A. A \<in> F \<Longrightarrow> finite A \<and> A \<noteq> {}"
+ by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ finally show ?thesis by simp
+ qed
+ finally show ?thesis by simp
+ next
+ case True
+ thus ?thesis by auto
+ qed
+next
+ case empty
+ assume "{} \<noteq> {}" show ?case by auto
+qed
+
+
+end
\ No newline at end of file
--- a/Moment.thy Wed May 14 11:52:53 2014 +0100
+++ b/Moment.thy Wed Jan 27 13:50:02 2016 +0000
@@ -2,782 +2,98 @@
imports Main
begin
-fun firstn :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
-where
- "firstn 0 s = []" |
- "firstn (Suc n) [] = []" |
- "firstn (Suc n) (e#s) = e#(firstn n s)"
-
-fun restn :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
-where "restn n s = rev (firstn (length s - n) (rev s))"
-
definition moment :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
-where "moment n s = rev (firstn n (rev s))"
-
-definition restm :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
-where "restm n s = rev (restn n (rev s))"
-
-definition from_to :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
- where "from_to i j s = firstn (j - i) (restn i s)"
-
-definition down_to :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
-where "down_to j i s = rev (from_to i j (rev s))"
-
-(*
-value "down_to 6 2 [10, 9, 8, 7, 6, 5, 4, 3, 2, 1, 0]"
-value "from_to 2 6 [0, 1, 2, 3, 4, 5, 6, 7]"
-*)
-
-lemma length_eq_elim_l: "\<lbrakk>length xs = length ys; xs@us = ys@vs\<rbrakk> \<Longrightarrow> xs = ys \<and> us = vs"
- by auto
-
-lemma length_eq_elim_r: "\<lbrakk>length us = length vs; xs@us = ys@vs\<rbrakk> \<Longrightarrow> xs = ys \<and> us = vs"
- by simp
-
-lemma firstn_nil [simp]: "firstn n [] = []"
- by (cases n, simp+)
-
-(*
-value "from_to 0 2 [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] @
- from_to 2 5 [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]"
-*)
-
-lemma firstn_le: "\<And> n s'. n \<le> length s \<Longrightarrow> firstn n (s@s') = firstn n s"
-proof (induct s, simp)
- fix a s n s'
- assume ih: "\<And>n s'. n \<le> length s \<Longrightarrow> firstn n (s @ s') = firstn n s"
- and le_n: " n \<le> length (a # s)"
- show "firstn n ((a # s) @ s') = firstn n (a # s)"
- proof(cases n, simp)
- fix k
- assume eq_n: "n = Suc k"
- with le_n have "k \<le> length s" by auto
- from ih [OF this] and eq_n
- show "firstn n ((a # s) @ s') = firstn n (a # s)" by auto
- qed
-qed
-
-lemma firstn_ge [simp]: "\<And>n. length s \<le> n \<Longrightarrow> firstn n s = s"
-proof(induct s, simp)
- fix a s n
- assume ih: "\<And>n. length s \<le> n \<Longrightarrow> firstn n s = s"
- and le: "length (a # s) \<le> n"
- show "firstn n (a # s) = a # s"
- proof(cases n)
- assume eq_n: "n = 0" with le show ?thesis by simp
- next
- fix k
- assume eq_n: "n = Suc k"
- with le have le_k: "length s \<le> k" by simp
- from ih [OF this] have "firstn k s = s" .
- from eq_n and this
- show ?thesis by simp
- qed
-qed
-
-lemma firstn_eq [simp]: "firstn (length s) s = s"
- by simp
-
-lemma firstn_restn_s: "(firstn n (s::'a list)) @ (restn n s) = s"
-proof(induct n arbitrary:s, simp)
- fix n s
- assume ih: "\<And>t. firstn n (t::'a list) @ restn n t = t"
- show "firstn (Suc n) (s::'a list) @ restn (Suc n) s = s"
- proof(cases s, simp)
- fix x xs
- assume eq_s: "s = x#xs"
- show "firstn (Suc n) s @ restn (Suc n) s = s"
- proof -
- have "firstn (Suc n) s @ restn (Suc n) s = x # (firstn n xs @ restn n xs)"
- proof -
- from eq_s have "firstn (Suc n) s = x # firstn n xs" by simp
- moreover have "restn (Suc n) s = restn n xs"
- proof -
- from eq_s have "restn (Suc n) s = rev (firstn (length xs - n) (rev xs @ [x]))" by simp
- also have "\<dots> = restn n xs"
- proof -
- have "(firstn (length xs - n) (rev xs @ [x])) = (firstn (length xs - n) (rev xs))"
- by(rule firstn_le, simp)
- hence "rev (firstn (length xs - n) (rev xs @ [x])) =
- rev (firstn (length xs - n) (rev xs))" by simp
- also have "\<dots> = rev (firstn (length (rev xs) - n) (rev xs))" by simp
- finally show ?thesis by simp
- qed
- finally show ?thesis by simp
- qed
- ultimately show ?thesis by simp
- qed with ih eq_s show ?thesis by simp
- qed
- qed
-qed
-
-lemma moment_restm_s: "(restm n s)@(moment n s) = s"
-proof -
- have " rev ((firstn n (rev s)) @ (restn n (rev s))) = s" (is "rev ?x = s")
- proof -
- have "?x = rev s" by (simp only:firstn_restn_s)
- thus ?thesis by auto
- qed
- thus ?thesis
- by (auto simp:restm_def moment_def)
-qed
-
-declare restn.simps [simp del] firstn.simps[simp del]
-
-lemma length_firstn_ge: "length s \<le> n \<Longrightarrow> length (firstn n s) = length s"
-proof(induct n arbitrary:s, simp add:firstn.simps)
- case (Suc k)
- assume ih: "\<And> s. length (s::'a list) \<le> k \<Longrightarrow> length (firstn k s) = length s"
- and le: "length s \<le> Suc k"
- show ?case
- proof(cases s)
- case Nil
- from Nil show ?thesis by simp
- next
- case (Cons x xs)
- from le and Cons have "length xs \<le> k" by simp
- from ih [OF this] have "length (firstn k xs) = length xs" .
- moreover from Cons have "length (firstn (Suc k) s) = Suc (length (firstn k xs))"
- by (simp add:firstn.simps)
- moreover note Cons
- ultimately show ?thesis by simp
- qed
-qed
+where "moment n s = rev (take n (rev s))"
-lemma length_firstn_le: "n \<le> length s \<Longrightarrow> length (firstn n s) = n"
-proof(induct n arbitrary:s, simp add:firstn.simps)
- case (Suc k)
- assume ih: "\<And>s. k \<le> length (s::'a list) \<Longrightarrow> length (firstn k s) = k"
- and le: "Suc k \<le> length s"
- show ?case
- proof(cases s)
- case Nil
- from Nil and le show ?thesis by auto
- next
- case (Cons x xs)
- from le and Cons have "k \<le> length xs" by simp
- from ih [OF this] have "length (firstn k xs) = k" .
- moreover from Cons have "length (firstn (Suc k) s) = Suc (length (firstn k xs))"
- by (simp add:firstn.simps)
- ultimately show ?thesis by simp
- qed
-qed
-
-lemma app_firstn_restn:
- fixes s1 s2
- shows "s1 = firstn (length s1) (s1 @ s2) \<and> s2 = restn (length s1) (s1 @ s2)"
-proof(rule length_eq_elim_l)
- have "length s1 \<le> length (s1 @ s2)" by simp
- from length_firstn_le [OF this]
- show "length s1 = length (firstn (length s1) (s1 @ s2))" by simp
-next
- from firstn_restn_s
- show "s1 @ s2 = firstn (length s1) (s1 @ s2) @ restn (length s1) (s1 @ s2)"
- by metis
-qed
-
-
-lemma length_moment_le:
- fixes k s
- assumes le_k: "k \<le> length s"
- shows "length (moment k s) = k"
-proof -
- have "length (rev (firstn k (rev s))) = k"
- proof -
- have "length (rev (firstn k (rev s))) = length (firstn k (rev s))" by simp
- also have "\<dots> = k"
- proof(rule length_firstn_le)
- from le_k show "k \<le> length (rev s)" by simp
- qed
- finally show ?thesis .
- qed
- thus ?thesis by (simp add:moment_def)
-qed
-
-lemma app_moment_restm:
- fixes s1 s2
- shows "s1 = restm (length s2) (s1 @ s2) \<and> s2 = moment (length s2) (s1 @ s2)"
-proof(rule length_eq_elim_r)
- have "length s2 \<le> length (s1 @ s2)" by simp
- from length_moment_le [OF this]
- show "length s2 = length (moment (length s2) (s1 @ s2))" by simp
-next
- from moment_restm_s
- show "s1 @ s2 = restm (length s2) (s1 @ s2) @ moment (length s2) (s1 @ s2)"
- by metis
-qed
-
-lemma length_moment_ge:
- fixes k s
- assumes le_k: "length s \<le> k"
- shows "length (moment k s) = (length s)"
-proof -
- have "length (rev (firstn k (rev s))) = length s"
- proof -
- have "length (rev (firstn k (rev s))) = length (firstn k (rev s))" by simp
- also have "\<dots> = length s"
- proof -
- have "\<dots> = length (rev s)"
- proof(rule length_firstn_ge)
- from le_k show "length (rev s) \<le> k" by simp
- qed
- also have "\<dots> = length s" by simp
- finally show ?thesis .
- qed
- finally show ?thesis .
- qed
- thus ?thesis by (simp add:moment_def)
-qed
-
-lemma length_firstn: "(length (firstn n s) = length s) \<or> (length (firstn n s) = n)"
-proof(cases "n \<le> length s")
- case True
- from length_firstn_le [OF True] show ?thesis by auto
-next
- case False
- from False have "length s \<le> n" by simp
- from firstn_ge [OF this] show ?thesis by auto
-qed
-
-lemma firstn_conc:
- fixes m n
- assumes le_mn: "m \<le> n"
- shows "firstn m s = firstn m (firstn n s)"
-proof(cases "m \<le> length s")
- case True
- have "s = (firstn n s) @ (restn n s)" by (simp add:firstn_restn_s)
- hence "firstn m s = firstn m \<dots>" by simp
- also have "\<dots> = firstn m (firstn n s)"
- proof -
- from length_firstn [of n s]
- have "m \<le> length (firstn n s)"
- proof
- assume "length (firstn n s) = length s" with True show ?thesis by simp
- next
- assume "length (firstn n s) = n " with le_mn show ?thesis by simp
- qed
- from firstn_le [OF this, of "restn n s"]
- show ?thesis .
- qed
- finally show ?thesis by simp
-next
- case False
- from False and le_mn have "length s \<le> n" by simp
- from firstn_ge [OF this] show ?thesis by simp
-qed
-
-lemma restn_conc:
- fixes i j k s
- assumes eq_k: "j + i = k"
- shows "restn k s = restn j (restn i s)"
-proof -
- have "(firstn (length s - k) (rev s)) =
- (firstn (length (rev (firstn (length s - i) (rev s))) - j)
- (rev (rev (firstn (length s - i) (rev s)))))"
- proof -
- have "(firstn (length s - k) (rev s)) =
- (firstn (length (rev (firstn (length s - i) (rev s))) - j)
- (firstn (length s - i) (rev s)))"
- proof -
- have " (length (rev (firstn (length s - i) (rev s))) - j) = length s - k"
- proof -
- have "(length (rev (firstn (length s - i) (rev s))) - j) = (length s - i) - j"
- proof -
- have "(length (rev (firstn (length s - i) (rev s))) - j) =
- length ((firstn (length s - i) (rev s))) - j"
- by simp
- also have "\<dots> = length ((firstn (length (rev s) - i) (rev s))) - j" by simp
- also have "\<dots> = (length (rev s) - i) - j"
- proof -
- have "length ((firstn (length (rev s) - i) (rev s))) = (length (rev s) - i)"
- by (rule length_firstn_le, simp)
- thus ?thesis by simp
- qed
- also have "\<dots> = (length s - i) - j" by simp
- finally show ?thesis .
- qed
- with eq_k show ?thesis by auto
- qed
- moreover have "(firstn (length s - k) (rev s)) =
- (firstn (length s - k) (firstn (length s - i) (rev s)))"
- proof(rule firstn_conc)
- from eq_k show "length s - k \<le> length s - i" by simp
- qed
- ultimately show ?thesis by simp
- qed
- thus ?thesis by simp
- qed
- thus ?thesis by (simp only:restn.simps)
-qed
-
-(*
-value "down_to 2 0 [5, 4, 3, 2, 1, 0]"
-value "moment 2 [5, 4, 3, 2, 1, 0]"
-*)
-
-lemma from_to_firstn: "from_to 0 k s = firstn k s"
-by (simp add:from_to_def restn.simps)
+value "moment 3 [0, 1, 2, 3, 4, 5, 6, 7, 8, 9::int]"
+value "moment 2 [5, 4, 3, 2, 1, 0::int]"
lemma moment_app [simp]:
- assumes
- ile: "i \<le> length s"
- shows "moment i (s'@s) = moment i s"
-proof -
- have "moment i (s'@s) = rev (firstn i (rev (s'@s)))" by (simp add:moment_def)
- moreover have "firstn i (rev (s'@s)) = firstn i (rev s @ rev s')" by simp
- moreover have "\<dots> = firstn i (rev s)"
- proof(rule firstn_le)
- have "length (rev s) = length s" by simp
- with ile show "i \<le> length (rev s)" by simp
- qed
- ultimately show ?thesis by (simp add:moment_def)
-qed
+ assumes ile: "i \<le> length s"
+ shows "moment i (s' @ s) = moment i s"
+using assms unfolding moment_def by simp
-lemma moment_eq [simp]: "moment (length s) (s'@s) = s"
-proof -
- have "length s \<le> length s" by simp
- from moment_app [OF this, of s']
- have " moment (length s) (s' @ s) = moment (length s) s" .
- moreover have "\<dots> = s" by (simp add:moment_def)
- ultimately show ?thesis by simp
-qed
+lemma moment_eq [simp]: "moment (length s) (s' @ s) = s"
+ unfolding moment_def by simp
lemma moment_ge [simp]: "length s \<le> n \<Longrightarrow> moment n s = s"
by (unfold moment_def, simp)
lemma moment_zero [simp]: "moment 0 s = []"
- by (simp add:moment_def firstn.simps)
+ by (simp add:moment_def)
-lemma p_split_gen:
- "\<lbrakk>Q s; \<not> Q (moment k s)\<rbrakk> \<Longrightarrow>
- (\<exists> i. i < length s \<and> k \<le> i \<and> \<not> Q (moment i s) \<and> (\<forall> i' > i. Q (moment i' s)))"
-proof (induct s, simp)
- fix a s
- assume ih: "\<lbrakk>Q s; \<not> Q (moment k s)\<rbrakk>
- \<Longrightarrow> \<exists>i<length s. k \<le> i \<and> \<not> Q (moment i s) \<and> (\<forall>i'>i. Q (moment i' s))"
- and nq: "\<not> Q (moment k (a # s))" and qa: "Q (a # s)"
- have le_k: "k \<le> length s"
- proof -
- { assume "length s < k"
- hence "length (a#s) \<le> k" by simp
- from moment_ge [OF this] and nq and qa
- have "False" by auto
- } thus ?thesis by arith
- qed
- have nq_k: "\<not> Q (moment k s)"
- proof -
- have "moment k (a#s) = moment k s"
- proof -
- from moment_app [OF le_k, of "[a]"] show ?thesis by simp
- qed
- with nq show ?thesis by simp
- qed
- show "\<exists>i<length (a # s). k \<le> i \<and> \<not> Q (moment i (a # s)) \<and> (\<forall>i'>i. Q (moment i' (a # s)))"
- proof -
- { assume "Q s"
- from ih [OF this nq_k]
- obtain i where lti: "i < length s"
- and nq: "\<not> Q (moment i s)"
- and rst: "\<forall>i'>i. Q (moment i' s)"
- and lki: "k \<le> i" by auto
- have ?thesis
- proof -
- from lti have "i < length (a # s)" by auto
- moreover have " \<not> Q (moment i (a # s))"
- proof -
- from lti have "i \<le> (length s)" by simp
- from moment_app [OF this, of "[a]"]
- have "moment i (a # s) = moment i s" by simp
- with nq show ?thesis by auto
- qed
- moreover have " (\<forall>i'>i. Q (moment i' (a # s)))"
- proof -
- {
- fix i'
- assume lti': "i < i'"
- have "Q (moment i' (a # s))"
- proof(cases "length (a#s) \<le> i'")
- case True
- from True have "moment i' (a#s) = a#s" by simp
- with qa show ?thesis by simp
- next
- case False
- from False have "i' \<le> length s" by simp
- from moment_app [OF this, of "[a]"]
- have "moment i' (a#s) = moment i' s" by simp
- with rst lti' show ?thesis by auto
- qed
- } thus ?thesis by auto
- qed
- moreover note lki
- ultimately show ?thesis by auto
- qed
- } moreover {
- assume ns: "\<not> Q s"
- have ?thesis
- proof -
- let ?i = "length s"
- have "\<not> Q (moment ?i (a#s))"
- proof -
- have "?i \<le> length s" by simp
- from moment_app [OF this, of "[a]"]
- have "moment ?i (a#s) = moment ?i s" by simp
- moreover have "\<dots> = s" by simp
- ultimately show ?thesis using ns by auto
- qed
- moreover have "\<forall> i' > ?i. Q (moment i' (a#s))"
- proof -
- { fix i'
- assume "i' > ?i"
- hence "length (a#s) \<le> i'" by simp
- from moment_ge [OF this]
- have " moment i' (a # s) = a # s" .
- with qa have "Q (moment i' (a#s))" by simp
- } thus ?thesis by auto
- qed
- moreover have "?i < length (a#s)" by simp
- moreover note le_k
- ultimately show ?thesis by auto
- qed
- } ultimately show ?thesis by auto
- qed
-qed
+lemma least_idx:
+ assumes "Q (i::nat)"
+ obtains j where "j \<le> i" "Q j" "\<forall> k < j. \<not> Q k"
+ using assms
+ by (metis ex_least_nat_le le0 not_less0)
-lemma p_split:
- "\<And> s Q. \<lbrakk>Q s; \<not> Q []\<rbrakk> \<Longrightarrow>
- (\<exists> i. i < length s \<and> \<not> Q (moment i s) \<and> (\<forall> i' > i. Q (moment i' s)))"
+lemma duration_idx:
+ assumes "\<not> Q (i::nat)"
+ and "Q j"
+ and "i \<le> j"
+ obtains k where "i \<le> k" "k < j" "\<not> Q k" "\<forall> i'. k < i' \<and> i' \<le> j \<longrightarrow> Q i'"
proof -
- fix s Q
- assume qs: "Q s" and nq: "\<not> Q []"
- from nq have "\<not> Q (moment 0 s)" by simp
- from p_split_gen [of Q s 0, OF qs this]
- show "(\<exists> i. i < length s \<and> \<not> Q (moment i s) \<and> (\<forall> i' > i. Q (moment i' s)))"
- by auto
-qed
-
-lemma moment_plus:
- "Suc i \<le> length s \<Longrightarrow> moment (Suc i) s = (hd (moment (Suc i) s)) # (moment i s)"
-proof(induct s, simp+)
- fix a s
- assume ih: "Suc i \<le> length s \<Longrightarrow> moment (Suc i) s = hd (moment (Suc i) s) # moment i s"
- and le_i: "i \<le> length s"
- show "moment (Suc i) (a # s) = hd (moment (Suc i) (a # s)) # moment i (a # s)"
- proof(cases "i= length s")
- case True
- hence "Suc i = length (a#s)" by simp
- with moment_eq have "moment (Suc i) (a#s) = a#s" by auto
- moreover have "moment i (a#s) = s"
- proof -
- from moment_app [OF le_i, of "[a]"]
- and True show ?thesis by simp
- qed
- ultimately show ?thesis by auto
- next
- case False
- from False and le_i have lti: "i < length s" by arith
- hence les_i: "Suc i \<le> length s" by arith
- show ?thesis
- proof -
- from moment_app [OF les_i, of "[a]"]
- have "moment (Suc i) (a # s) = moment (Suc i) s" by simp
- moreover have "moment i (a#s) = moment i s"
- proof -
- from lti have "i \<le> length s" by simp
- from moment_app [OF this, of "[a]"] show ?thesis by simp
- qed
- moreover note ih [OF les_i]
- ultimately show ?thesis by auto
- qed
- qed
-qed
-
-lemma from_to_conc:
- fixes i j k s
- assumes le_ij: "i \<le> j"
- and le_jk: "j \<le> k"
- shows "from_to i j s @ from_to j k s = from_to i k s"
-proof -
- let ?ris = "restn i s"
- have "firstn (j - i) (restn i s) @ firstn (k - j) (restn j s) =
- firstn (k - i) (restn i s)" (is "?x @ ?y = ?z")
- proof -
- let "firstn (k-j) ?u" = "?y"
- let ?rst = " restn (k - j) (restn (j - i) ?ris)"
- let ?rst' = "restn (k - i) ?ris"
- have "?u = restn (j-i) ?ris"
- proof(rule restn_conc)
- from le_ij show "j - i + i = j" by simp
- qed
- hence "?x @ ?y = ?x @ firstn (k-j) (restn (j-i) ?ris)" by simp
- moreover have "firstn (k - j) (restn (j - i) (restn i s)) @ ?rst =
- restn (j-i) ?ris" by (simp add:firstn_restn_s)
- ultimately have "?x @ ?y @ ?rst = ?x @ (restn (j-i) ?ris)" by simp
- also have "\<dots> = ?ris" by (simp add:firstn_restn_s)
- finally have "?x @ ?y @ ?rst = ?ris" .
- moreover have "?z @ ?rst = ?ris"
- proof -
- have "?z @ ?rst' = ?ris" by (simp add:firstn_restn_s)
- moreover have "?rst' = ?rst"
- proof(rule restn_conc)
- from le_ij le_jk show "k - j + (j - i) = k - i" by auto
- qed
- ultimately show ?thesis by simp
- qed
- ultimately have "?x @ ?y @ ?rst = ?z @ ?rst" by simp
- thus ?thesis by auto
- qed
- thus ?thesis by (simp only:from_to_def)
-qed
-
-lemma down_to_conc:
- fixes i j k s
- assumes le_ij: "i \<le> j"
- and le_jk: "j \<le> k"
- shows "down_to k j s @ down_to j i s = down_to k i s"
-proof -
- have "rev (from_to j k (rev s)) @ rev (from_to i j (rev s)) = rev (from_to i k (rev s))"
- (is "?L = ?R")
- proof -
- have "?L = rev (from_to i j (rev s) @ from_to j k (rev s))" by simp
- also have "\<dots> = ?R" (is "rev ?x = rev ?y")
- proof -
- have "?x = ?y" by (rule from_to_conc[OF le_ij le_jk])
- thus ?thesis by simp
- qed
- finally show ?thesis .
- qed
- thus ?thesis by (simp add:down_to_def)
-qed
-
-lemma restn_ge:
- fixes s k
- assumes le_k: "length s \<le> k"
- shows "restn k s = []"
-proof -
- from firstn_restn_s [of k s, symmetric] have "s = (firstn k s) @ (restn k s)" .
- hence "length s = length \<dots>" by simp
- also have "\<dots> = length (firstn k s) + length (restn k s)" by simp
- finally have "length s = ..." by simp
- moreover from length_firstn_ge and le_k
- have "length (firstn k s) = length s" by simp
- ultimately have "length (restn k s) = 0" by auto
- thus ?thesis by auto
+ let ?Q = "\<lambda> t. t \<le> j \<and> \<not> Q (j - t)"
+ have "?Q (j - i)" using assms by (simp add: assms(1))
+ from least_idx [of ?Q, OF this]
+ obtain l
+ where h: "l \<le> j - i" "\<not> Q (j - l)" "\<forall>k<l. \<not> (k \<le> j \<and> \<not> Q (j - k))"
+ by metis
+ let ?k = "j - l"
+ have "i \<le> ?k" using assms(3) h(1) by linarith
+ moreover have "?k < j" by (metis assms(2) diff_le_self h(2) le_neq_implies_less)
+ moreover have "\<not> Q ?k" by (simp add: h(2))
+ moreover have "\<forall> i'. ?k < i' \<and> i' \<le> j \<longrightarrow> Q i'"
+ by (metis diff_diff_cancel diff_le_self diff_less_mono2 h(3)
+ less_imp_diff_less not_less)
+ ultimately show ?thesis using that by metis
qed
-lemma from_to_ge: "length s \<le> k \<Longrightarrow> from_to k j s = []"
-proof(simp only:from_to_def)
- assume "length s \<le> k"
- from restn_ge [OF this]
- show "firstn (j - k) (restn k s) = []" by simp
-qed
+lemma p_split_gen:
+ assumes "Q s"
+ and "\<not> Q (moment k s)"
+ shows "(\<exists> i. i < length s \<and> k \<le> i \<and> \<not> Q (moment i s) \<and> (\<forall> i' > i. Q (moment i' s)))"
+proof(cases "k \<le> length s")
+ case True
+ let ?Q = "\<lambda> t. Q (moment t s)"
+ have "?Q (length s)" using assms(1) by simp
+ from duration_idx[of ?Q, OF assms(2) this True]
+ obtain i where h: "k \<le> i" "i < length s" "\<not> Q (moment i s)"
+ "\<forall>i'. i < i' \<and> i' \<le> length s \<longrightarrow> Q (moment i' s)" by metis
+ moreover have "(\<forall> i' > i. Q (moment i' s))" using h(4) assms(1) not_less
+ by fastforce
+ ultimately show ?thesis by metis
+qed (insert assms, auto)
-(*
-value "from_to 2 5 [0, 1, 2, 3, 4]"
-value "restn 2 [0, 1, 2, 3, 4]"
-*)
-
-lemma from_to_restn:
- fixes k j s
- assumes le_j: "length s \<le> j"
- shows "from_to k j s = restn k s"
+lemma p_split:
+ assumes qs: "Q s"
+ and nq: "\<not> Q []"
+ shows "(\<exists> i. i < length s \<and> \<not> Q (moment i s) \<and> (\<forall> i' > i. Q (moment i' s)))"
proof -
- have "from_to 0 k s @ from_to k j s = from_to 0 j s"
- proof(cases "k \<le> j")
- case True
- from from_to_conc True show ?thesis by auto
- next
- case False
- from False le_j have lek: "length s \<le> k" by auto
- from from_to_ge [OF this] have "from_to k j s = []" .
- hence "from_to 0 k s @ from_to k j s = from_to 0 k s" by simp
- also have "\<dots> = s"
- proof -
- from from_to_firstn [of k s]
- have "\<dots> = firstn k s" .
- also have "\<dots> = s" by (rule firstn_ge [OF lek])
- finally show ?thesis .
- qed
- finally have "from_to 0 k s @ from_to k j s = s" .
- moreover have "from_to 0 j s = s"
- proof -
- have "from_to 0 j s = firstn j s" by (simp add:from_to_firstn)
- also have "\<dots> = s"
- proof(rule firstn_ge)
- from le_j show "length s \<le> j " by simp
- qed
- finally show ?thesis .
- qed
- ultimately show ?thesis by auto
- qed
- also have "\<dots> = s"
- proof -
- from from_to_firstn have "\<dots> = firstn j s" .
- also have "\<dots> = s"
- proof(rule firstn_ge)
- from le_j show "length s \<le> j" by simp
- qed
- finally show ?thesis .
- qed
- finally have "from_to 0 k s @ from_to k j s = s" .
- moreover have "from_to 0 k s @ restn k s = s"
- proof -
- from from_to_firstn [of k s]
- have "from_to 0 k s = firstn k s" .
- thus ?thesis by (simp add:firstn_restn_s)
- qed
- ultimately have "from_to 0 k s @ from_to k j s =
- from_to 0 k s @ restn k s" by simp
- thus ?thesis by auto
-qed
-
-lemma down_to_moment: "down_to k 0 s = moment k s"
-proof -
- have "rev (from_to 0 k (rev s)) = rev (firstn k (rev s))"
- using from_to_firstn by metis
- thus ?thesis by (simp add:down_to_def moment_def)
-qed
-
-lemma down_to_restm:
- assumes le_s: "length s \<le> j"
- shows "down_to j k s = restm k s"
-proof -
- have "rev (from_to k j (rev s)) = rev (restn k (rev s))" (is "?L = ?R")
- proof -
- from le_s have "length (rev s) \<le> j" by simp
- from from_to_restn [OF this, of k] show ?thesis by simp
- qed
- thus ?thesis by (simp add:down_to_def restm_def)
-qed
-
-lemma moment_split: "moment (m+i) s = down_to (m+i) i s @down_to i 0 s"
-proof -
- have "moment (m + i) s = down_to (m+i) 0 s" using down_to_moment by metis
- also have "\<dots> = (down_to (m+i) i s) @ (down_to i 0 s)"
- by(rule down_to_conc[symmetric], auto)
- finally show ?thesis .
+ from nq have "\<not> Q (moment 0 s)" by simp
+ from p_split_gen [of Q s 0, OF qs this]
+ show ?thesis by auto
qed
-lemma length_restn: "length (restn i s) = length s - i"
-proof(cases "i \<le> length s")
- case True
- from length_firstn_le [OF this] have "length (firstn i s) = i" .
- moreover have "length s = length (firstn i s) + length (restn i s)"
- proof -
- have "s = firstn i s @ restn i s" using firstn_restn_s by metis
- hence "length s = length \<dots>" by simp
- thus ?thesis by simp
- qed
- ultimately show ?thesis by simp
-next
- case False
- hence "length s \<le> i" by simp
- from restn_ge [OF this] have "restn i s = []" .
- with False show ?thesis by simp
-qed
-
-lemma length_from_to_in:
- fixes i j s
- assumes le_ij: "i \<le> j"
- and le_j: "j \<le> length s"
- shows "length (from_to i j s) = j - i"
+lemma moment_Suc_tl:
+ assumes "Suc i \<le> length s"
+ shows "tl (moment (Suc i) s) = moment i s"
+ using assms
+ by (simp add:moment_def rev_take,
+ metis Suc_diff_le diff_Suc_Suc drop_Suc tl_drop)
+
+lemma moment_plus:
+ assumes "Suc i \<le> length s"
+ shows "(moment (Suc i) s) = (hd (moment (Suc i) s)) # (moment i s)"
proof -
- have "from_to 0 j s = from_to 0 i s @ from_to i j s"
- by (rule from_to_conc[symmetric, OF _ le_ij], simp)
- moreover have "length (from_to 0 j s) = j"
- proof -
- have "from_to 0 j s = firstn j s" using from_to_firstn by metis
- moreover have "length \<dots> = j" by (rule length_firstn_le [OF le_j])
- ultimately show ?thesis by simp
- qed
- moreover have "length (from_to 0 i s) = i"
- proof -
- have "from_to 0 i s = firstn i s" using from_to_firstn by metis
- moreover have "length \<dots> = i"
- proof (rule length_firstn_le)
- from le_ij le_j show "i \<le> length s" by simp
- qed
- ultimately show ?thesis by simp
- qed
- ultimately show ?thesis by auto
+ have "(moment (Suc i) s) \<noteq> []" using assms
+ by (simp add:moment_def rev_take)
+ hence "(moment (Suc i) s) = (hd (moment (Suc i) s)) # tl (moment (Suc i) s)"
+ by auto
+ with moment_Suc_tl[OF assms]
+ show ?thesis by metis
qed
-lemma firstn_restn_from_to: "from_to i (m + i) s = firstn m (restn i s)"
-proof(cases "m+i \<le> length s")
- case True
- have "restn i s = from_to i (m+i) s @ from_to (m+i) (length s) s"
- proof -
- have "restn i s = from_to i (length s) s"
- by(rule from_to_restn[symmetric], simp)
- also have "\<dots> = from_to i (m+i) s @ from_to (m+i) (length s) s"
- by(rule from_to_conc[symmetric, OF _ True], simp)
- finally show ?thesis .
- qed
- hence "firstn m (restn i s) = firstn m \<dots>" by simp
- moreover have "\<dots> = firstn (length (from_to i (m+i) s))
- (from_to i (m+i) s @ from_to (m+i) (length s) s)"
- proof -
- have "length (from_to i (m+i) s) = m"
- proof -
- have "length (from_to i (m+i) s) = (m+i) - i"
- by(rule length_from_to_in [OF _ True], simp)
- thus ?thesis by simp
- qed
- thus ?thesis by simp
- qed
- ultimately show ?thesis using app_firstn_restn by metis
-next
- case False
- hence "length s \<le> m + i" by simp
- from from_to_restn [OF this]
- have "from_to i (m + i) s = restn i s" .
- moreover have "firstn m (restn i s) = restn i s"
- proof(rule firstn_ge)
- show "length (restn i s) \<le> m"
- proof -
- have "length (restn i s) = length s - i" using length_restn by metis
- with False show ?thesis by simp
- qed
- qed
- ultimately show ?thesis by simp
-qed
+end
-lemma down_to_moment_restm:
- fixes m i s
- shows "down_to (m + i) i s = moment m (restm i s)"
- by (simp add:firstn_restn_from_to down_to_def moment_def restm_def)
-
-lemma moment_plus_split:
- fixes m i s
- shows "moment (m + i) s = moment m (restm i s) @ moment i s"
-proof -
- from moment_split [of m i s]
- have "moment (m + i) s = down_to (m + i) i s @ down_to i 0 s" .
- also have "\<dots> = down_to (m+i) i s @ moment i s" using down_to_moment by simp
- also from down_to_moment_restm have "\<dots> = moment m (restm i s) @ moment i s"
- by simp
- finally show ?thesis .
-qed
-
-lemma length_restm: "length (restm i s) = length s - i"
-proof -
- have "length (rev (restn i (rev s))) = length s - i" (is "?L = ?R")
- proof -
- have "?L = length (restn i (rev s))" by simp
- also have "\<dots> = length (rev s) - i" using length_restn by metis
- also have "\<dots> = ?R" by simp
- finally show ?thesis .
- qed
- thus ?thesis by (simp add:restm_def)
-qed
-
-lemma moment_prefix: "(moment i t @ s) = moment (i + length s) (t @ s)"
-proof -
- from moment_plus_split [of i "length s" "t@s"]
- have " moment (i + length s) (t @ s) = moment i (restm (length s) (t @ s)) @ moment (length s) (t @ s)"
- by auto
- with app_moment_restm[of t s]
- have "moment (i + length s) (t @ s) = moment i t @ moment (length s) (t @ s)" by simp
- with moment_app show ?thesis by auto
-qed
-
-end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PIPBasics.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,3778 @@
+theory PIPBasics
+imports PIPDefs
+begin
+
+locale valid_trace =
+ fixes s
+ assumes vt : "vt s"
+
+locale valid_trace_e = valid_trace +
+ fixes e
+ assumes vt_e: "vt (e#s)"
+begin
+
+lemma pip_e: "PIP s e"
+ using vt_e by (cases, simp)
+
+end
+
+lemma runing_ready:
+ shows "runing s \<subseteq> readys s"
+ unfolding runing_def readys_def
+ by auto
+
+lemma readys_threads:
+ shows "readys s \<subseteq> threads s"
+ unfolding readys_def
+ by auto
+
+lemma wq_v_neq:
+ "cs \<noteq> cs' \<Longrightarrow> wq (V thread cs#s) cs' = wq s cs'"
+ by (auto simp:wq_def Let_def cp_def split:list.splits)
+
+lemma runing_head:
+ assumes "th \<in> runing s"
+ and "th \<in> set (wq_fun (schs s) cs)"
+ shows "th = hd (wq_fun (schs s) cs)"
+ using assms
+ by (simp add:runing_def readys_def s_waiting_def wq_def)
+
+context valid_trace
+begin
+
+lemma actor_inv:
+ assumes "PIP s e"
+ and "\<not> isCreate e"
+ shows "actor e \<in> runing s"
+ using assms
+ by (induct, auto)
+
+lemma ind [consumes 0, case_names Nil Cons, induct type]:
+ assumes "PP []"
+ and "(\<And>s e. valid_trace s \<Longrightarrow> valid_trace (e#s) \<Longrightarrow>
+ PP s \<Longrightarrow> PIP s e \<Longrightarrow> PP (e # s))"
+ shows "PP s"
+proof(rule vt.induct[OF vt])
+ from assms(1) show "PP []" .
+next
+ fix s e
+ assume h: "vt s" "PP s" "PIP s e"
+ show "PP (e # s)"
+ proof(cases rule:assms(2))
+ from h(1) show v1: "valid_trace s" by (unfold_locales, simp)
+ next
+ from h(1,3) have "vt (e#s)" by auto
+ thus "valid_trace (e # s)" by (unfold_locales, simp)
+ qed (insert h, auto)
+qed
+
+lemma wq_distinct: "distinct (wq s cs)"
+proof(induct rule:ind)
+ case (Cons s e)
+ from Cons(4,3)
+ show ?case
+ proof(induct)
+ case (thread_P th s cs1)
+ show ?case
+ proof(cases "cs = cs1")
+ case True
+ thus ?thesis (is "distinct ?L")
+ proof -
+ have "?L = wq_fun (schs s) cs1 @ [th]" using True
+ by (simp add:wq_def wf_def Let_def split:list.splits)
+ moreover have "distinct ..."
+ proof -
+ have "th \<notin> set (wq_fun (schs s) cs1)"
+ proof
+ assume otherwise: "th \<in> set (wq_fun (schs s) cs1)"
+ from runing_head[OF thread_P(1) this]
+ have "th = hd (wq_fun (schs s) cs1)" .
+ hence "(Cs cs1, Th th) \<in> (RAG s)" using otherwise
+ by (simp add:s_RAG_def s_holding_def wq_def cs_holding_def)
+ with thread_P(2) show False by auto
+ qed
+ moreover have "distinct (wq_fun (schs s) cs1)"
+ using True thread_P wq_def by auto
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis by simp
+ qed
+ next
+ case False
+ with thread_P(3)
+ show ?thesis
+ by (auto simp:wq_def wf_def Let_def split:list.splits)
+ qed
+ next
+ case (thread_V th s cs1)
+ thus ?case
+ proof(cases "cs = cs1")
+ case True
+ show ?thesis (is "distinct ?L")
+ proof(cases "(wq s cs)")
+ case Nil
+ thus ?thesis
+ by (auto simp:wq_def wf_def Let_def split:list.splits)
+ next
+ case (Cons w_hd w_tl)
+ moreover have "distinct (SOME q. distinct q \<and> set q = set w_tl)"
+ proof(rule someI2)
+ from thread_V(3)[unfolded Cons]
+ show "distinct w_tl \<and> set w_tl = set w_tl" by auto
+ qed auto
+ ultimately show ?thesis
+ by (auto simp:wq_def wf_def Let_def True split:list.splits)
+ qed
+ next
+ case False
+ with thread_V(3)
+ show ?thesis
+ by (auto simp:wq_def wf_def Let_def split:list.splits)
+ qed
+ qed (insert Cons, auto simp: wq_def Let_def split:list.splits)
+qed (unfold wq_def Let_def, simp)
+
+end
+
+
+context valid_trace_e
+begin
+
+text {*
+ The following lemma shows that only the @{text "P"}
+ operation can add new thread into waiting queues.
+ Such kind of lemmas are very obvious, but need to be checked formally.
+ This is a kind of confirmation that our modelling is correct.
+*}
+
+lemma block_pre:
+ assumes s_ni: "thread \<notin> set (wq s cs)"
+ and s_i: "thread \<in> set (wq (e#s) cs)"
+ shows "e = P thread cs"
+proof(cases e)
+ -- {* This is the only non-trivial case: *}
+ case (V th cs1)
+ have False
+ proof(cases "cs1 = cs")
+ case True
+ show ?thesis
+ proof(cases "(wq s cs1)")
+ case (Cons w_hd w_tl)
+ have "set (wq (e#s) cs) \<subseteq> set (wq s cs)"
+ proof -
+ have "(wq (e#s) cs) = (SOME q. distinct q \<and> set q = set w_tl)"
+ using Cons V by (auto simp:wq_def Let_def True split:if_splits)
+ moreover have "set ... \<subseteq> set (wq s cs)"
+ proof(rule someI2)
+ show "distinct w_tl \<and> set w_tl = set w_tl"
+ by (metis distinct.simps(2) local.Cons wq_distinct)
+ qed (insert Cons True, auto)
+ ultimately show ?thesis by simp
+ qed
+ with assms show ?thesis by auto
+ qed (insert assms V True, auto simp:wq_def Let_def split:if_splits)
+ qed (insert assms V, auto simp:wq_def Let_def split:if_splits)
+ thus ?thesis by auto
+qed (insert assms, auto simp:wq_def Let_def split:if_splits)
+
+end
+
+text {*
+ The following lemmas is also obvious and shallow. It says
+ that only running thread can request for a critical resource
+ and that the requested resource must be one which is
+ not current held by the thread.
+*}
+
+lemma p_pre: "\<lbrakk>vt ((P thread cs)#s)\<rbrakk> \<Longrightarrow>
+ thread \<in> runing s \<and> (Cs cs, Th thread) \<notin> (RAG s)^+"
+apply (ind_cases "vt ((P thread cs)#s)")
+apply (ind_cases "step s (P thread cs)")
+by auto
+
+lemma abs1:
+ assumes ein: "e \<in> set es"
+ and neq: "hd es \<noteq> hd (es @ [x])"
+ shows "False"
+proof -
+ from ein have "es \<noteq> []" by auto
+ then obtain e ess where "es = e # ess" by (cases es, auto)
+ with neq show ?thesis by auto
+qed
+
+lemma q_head: "Q (hd es) \<Longrightarrow> hd es = hd [th\<leftarrow>es . Q th]"
+ by (cases es, auto)
+
+inductive_cases evt_cons: "vt (a#s)"
+
+context valid_trace_e
+begin
+
+lemma abs2:
+ assumes inq: "thread \<in> set (wq s cs)"
+ and nh: "thread = hd (wq s cs)"
+ and qt: "thread \<noteq> hd (wq (e#s) cs)"
+ and inq': "thread \<in> set (wq (e#s) cs)"
+ shows "False"
+proof -
+ from vt_e assms show "False"
+ apply (cases e)
+ apply ((simp split:if_splits add:Let_def wq_def)[1])+
+ apply (insert abs1, fast)[1]
+ apply (auto simp:wq_def simp:Let_def split:if_splits list.splits)
+ proof -
+ fix th qs
+ assume vt: "vt (V th cs # s)"
+ and th_in: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
+ and eq_wq: "wq_fun (schs s) cs = thread # qs"
+ show "False"
+ proof -
+ from wq_distinct[of cs]
+ and eq_wq[folded wq_def] have "distinct (thread#qs)" by simp
+ moreover have "thread \<in> set qs"
+ proof -
+ have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
+ proof(rule someI2)
+ from wq_distinct [of cs]
+ and eq_wq [folded wq_def]
+ show "distinct qs \<and> set qs = set qs" by auto
+ next
+ fix x assume "distinct x \<and> set x = set qs"
+ thus "set x = set qs" by auto
+ qed
+ with th_in show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ qed
+qed
+
+end
+
+
+context valid_trace
+begin
+lemma vt_moment: "\<And> t. vt (moment t s)"
+proof(induct rule:ind)
+ case Nil
+ thus ?case by (simp add:vt_nil)
+next
+ case (Cons s e t)
+ show ?case
+ proof(cases "t \<ge> length (e#s)")
+ case True
+ from True have "moment t (e#s) = e#s" by simp
+ thus ?thesis using Cons
+ by (simp add:valid_trace_def)
+ next
+ case False
+ from Cons have "vt (moment t s)" by simp
+ moreover have "moment t (e#s) = moment t s"
+ proof -
+ from False have "t \<le> length s" by simp
+ from moment_app [OF this, of "[e]"]
+ show ?thesis by simp
+ qed
+ ultimately show ?thesis by simp
+ qed
+qed
+end
+
+locale valid_moment = valid_trace +
+ fixes i :: nat
+
+sublocale valid_moment < vat_moment: valid_trace "(moment i s)"
+ by (unfold_locales, insert vt_moment, auto)
+
+context valid_trace
+begin
+
+
+text {* (* ddd *)
+ The nature of the work is like this: since it starts from a very simple and basic
+ model, even intuitively very `basic` and `obvious` properties need to derived from scratch.
+ For instance, the fact
+ that one thread can not be blocked by two critical resources at the same time
+ is obvious, because only running threads can make new requests, if one is waiting for
+ a critical resource and get blocked, it can not make another resource request and get
+ blocked the second time (because it is not running).
+
+ To derive this fact, one needs to prove by contraction and
+ reason about time (or @{text "moement"}). The reasoning is based on a generic theorem
+ named @{text "p_split"}, which is about status changing along the time axis. It says if
+ a condition @{text "Q"} is @{text "True"} at a state @{text "s"},
+ but it was @{text "False"} at the very beginning, then there must exits a moment @{text "t"}
+ in the history of @{text "s"} (notice that @{text "s"} itself is essentially the history
+ of events leading to it), such that @{text "Q"} switched
+ from being @{text "False"} to @{text "True"} and kept being @{text "True"}
+ till the last moment of @{text "s"}.
+
+ Suppose a thread @{text "th"} is blocked
+ on @{text "cs1"} and @{text "cs2"} in some state @{text "s"},
+ since no thread is blocked at the very beginning, by applying
+ @{text "p_split"} to these two blocking facts, there exist
+ two moments @{text "t1"} and @{text "t2"} in @{text "s"}, such that
+ @{text "th"} got blocked on @{text "cs1"} and @{text "cs2"}
+ and kept on blocked on them respectively ever since.
+
+ Without lost of generality, we assume @{text "t1"} is earlier than @{text "t2"}.
+ However, since @{text "th"} was blocked ever since memonent @{text "t1"}, so it was still
+ in blocked state at moment @{text "t2"} and could not
+ make any request and get blocked the second time: Contradiction.
+*}
+
+lemma waiting_unique_pre: (* ccc *)
+ assumes h11: "thread \<in> set (wq s cs1)"
+ and h12: "thread \<noteq> hd (wq s cs1)"
+ assumes h21: "thread \<in> set (wq s cs2)"
+ and h22: "thread \<noteq> hd (wq s cs2)"
+ and neq12: "cs1 \<noteq> cs2"
+ shows "False"
+proof -
+ let "?Q cs s" = "thread \<in> set (wq s cs) \<and> thread \<noteq> hd (wq s cs)"
+ from h11 and h12 have q1: "?Q cs1 s" by simp
+ from h21 and h22 have q2: "?Q cs2 s" by simp
+ have nq1: "\<not> ?Q cs1 []" by (simp add:wq_def)
+ have nq2: "\<not> ?Q cs2 []" by (simp add:wq_def)
+ from p_split [of "?Q cs1", OF q1 nq1]
+ obtain t1 where lt1: "t1 < length s"
+ and np1: "\<not>(thread \<in> set (wq (moment t1 s) cs1) \<and>
+ thread \<noteq> hd (wq (moment t1 s) cs1))"
+ and nn1: "(\<forall>i'>t1. thread \<in> set (wq (moment i' s) cs1) \<and>
+ thread \<noteq> hd (wq (moment i' s) cs1))" by auto
+ from p_split [of "?Q cs2", OF q2 nq2]
+ obtain t2 where lt2: "t2 < length s"
+ and np2: "\<not>(thread \<in> set (wq (moment t2 s) cs2) \<and>
+ thread \<noteq> hd (wq (moment t2 s) cs2))"
+ and nn2: "(\<forall>i'>t2. thread \<in> set (wq (moment i' s) cs2) \<and>
+ thread \<noteq> hd (wq (moment i' s) cs2))" by auto
+ show ?thesis
+ proof -
+ {
+ assume lt12: "t1 < t2"
+ let ?t3 = "Suc t2"
+ from lt2 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t2 s" by auto
+ have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t2 s" "e"
+ by (unfold_locales, auto, cases, simp)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre[OF False h1]
+ have "e = P thread cs2" .
+ with vt_e.vt_e have "vt ((P thread cs2)# moment t2 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t2 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t2 s)" by auto
+ with nn1 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume lt12: "t2 < t1"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 True eq_th h2 h1
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have "e = P thread cs1" .
+ with vt_e.vt_e have "vt ((P thread cs1)# moment t1 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t1 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t1 s)" by auto
+ with nn2 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume eqt12: "t1 = t2"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have vt_e: "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have eq_e1: "e = P thread cs1" .
+ have lt_t3: "t1 < ?t3" by simp
+ with eqt12 have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m and eqt12
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ show ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e and eqt12 have "vt (e#moment t2 s)" by simp
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.abs2 [OF True eq_th h2 h1]
+ show ?thesis .
+ next
+ case False
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment eqt12
+ have "vt (moment (Suc t2) s)" by auto
+ with eq_m eqt12 show ?thesis by simp
+ qed
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.block_pre [OF False h1]
+ have "e = P thread cs2" .
+ with eq_e1 neq12 show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by arith
+ qed
+qed
+
+text {*
+ This lemma is a simple corrolary of @{text "waiting_unique_pre"}.
+*}
+
+lemma waiting_unique:
+ assumes "waiting s th cs1"
+ and "waiting s th cs2"
+ shows "cs1 = cs2"
+using waiting_unique_pre assms
+unfolding wq_def s_waiting_def
+by auto
+
+end
+
+(* not used *)
+text {*
+ Every thread can only be blocked on one critical resource,
+ symmetrically, every critical resource can only be held by one thread.
+ This fact is much more easier according to our definition.
+*}
+lemma held_unique:
+ assumes "holding (s::event list) th1 cs"
+ and "holding s th2 cs"
+ shows "th1 = th2"
+ by (insert assms, unfold s_holding_def, auto)
+
+
+lemma last_set_lt: "th \<in> threads s \<Longrightarrow> last_set th s < length s"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits)
+
+lemma last_set_unique:
+ "\<lbrakk>last_set th1 s = last_set th2 s; th1 \<in> threads s; th2 \<in> threads s\<rbrakk>
+ \<Longrightarrow> th1 = th2"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits dest:last_set_lt)
+
+lemma preced_unique :
+ assumes pcd_eq: "preced th1 s = preced th2 s"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "th1 = th2"
+proof -
+ from pcd_eq have "last_set th1 s = last_set th2 s" by (simp add:preced_def)
+ from last_set_unique [OF this th_in1 th_in2]
+ show ?thesis .
+qed
+
+lemma preced_linorder:
+ assumes neq_12: "th1 \<noteq> th2"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "preced th1 s < preced th2 s \<or> preced th1 s > preced th2 s"
+proof -
+ from preced_unique [OF _ th_in1 th_in2] and neq_12
+ have "preced th1 s \<noteq> preced th2 s" by auto
+ thus ?thesis by auto
+qed
+
+(* An aux lemma used later *)
+lemma unique_minus:
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz and neq show ?thesis
+ proof(induct)
+ case (base ya)
+ have "(x, ya) \<in> r" by fact
+ from unique [OF xy this] have "y = ya" .
+ with base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from step True show ?thesis by simp
+ next
+ case False
+ from step False
+ show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_base:
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz neq_yz show ?thesis
+ proof(induct)
+ case (base ya)
+ from xy unique base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step
+ have "(y, ya) \<in> r\<^sup>+" by auto
+ with step show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_chain:
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r^+"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+ \<or> (z, y) \<in> r^+"
+proof -
+ from xy xz neq_yz show ?thesis
+ proof(induct)
+ case (base y)
+ have h1: "(x, y) \<in> r" and h2: "(x, z) \<in> r\<^sup>+" and h3: "y \<noteq> z" using base by auto
+ from unique_base [OF _ h1 h2 h3] and unique show ?case by auto
+ next
+ case (step y za)
+ show ?case
+ proof(cases "y = z")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step have "(y, z) \<in> r\<^sup>+ \<or> (z, y) \<in> r\<^sup>+" by auto
+ thus ?thesis
+ proof
+ assume "(z, y) \<in> r\<^sup>+"
+ with step have "(z, za) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ next
+ assume h: "(y, z) \<in> r\<^sup>+"
+ from step have yza: "(y, za) \<in> r" by simp
+ from step have "za \<noteq> z" by simp
+ from unique_minus [OF _ yza h this] and unique
+ have "(za, z) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ qed
+ qed
+ qed
+qed
+
+text {*
+ The following three lemmas show that @{text "RAG"} does not change
+ by the happening of @{text "Set"}, @{text "Create"} and @{text "Exit"}
+ events, respectively.
+*}
+
+lemma RAG_set_unchanged: "(RAG (Set th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_create_unchanged: "(RAG (Create th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_exit_unchanged: "(RAG (Exit th # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+
+text {*
+ The following lemmas are used in the proof of
+ lemma @{text "step_RAG_v"}, which characterizes how the @{text "RAG"} is changed
+ by @{text "V"}-events.
+ However, since our model is very concise, such seemingly obvious lemmas need to be derived from scratch,
+ starting from the model definitions.
+*}
+lemma step_v_hold_inv[elim_format]:
+ "\<And>c t. \<lbrakk>vt (V th cs # s);
+ \<not> holding (wq s) t c; holding (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow>
+ next_th s th cs t \<and> c = cs"
+proof -
+ fix c t
+ assume vt: "vt (V th cs # s)"
+ and nhd: "\<not> holding (wq s) t c"
+ and hd: "holding (wq (V th cs # s)) t c"
+ show "next_th s th cs t \<and> c = cs"
+ proof(cases "c = cs")
+ case False
+ with nhd hd show ?thesis
+ by (unfold cs_holding_def wq_def, auto simp:Let_def)
+ next
+ case True
+ with step_back_step [OF vt]
+ have "step s (V th c)" by simp
+ hence "next_th s th cs t"
+ proof(cases)
+ assume "holding s th c"
+ with nhd hd show ?thesis
+ apply (unfold s_holding_def cs_holding_def wq_def next_th_def,
+ auto simp:Let_def split:list.splits if_splits)
+ proof -
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ next
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ qed
+ qed
+ with True show ?thesis by auto
+ qed
+qed
+
+text {*
+ The following @{text "step_v_wait_inv"} is also an obvious lemma, which, however, needs to be
+ derived from scratch, which confirms the correctness of the definition of @{text "next_th"}.
+*}
+lemma step_v_wait_inv[elim_format]:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); \<not> waiting (wq (V th cs # s)) t c; waiting (wq s) t c
+ \<rbrakk>
+ \<Longrightarrow> (next_th s th cs t \<and> cs = c)"
+proof -
+ fix t c
+ assume vt: "vt (V th cs # s)"
+ and nw: "\<not> waiting (wq (V th cs # s)) t c"
+ and wt: "waiting (wq s) t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp)
+ show "next_th s th cs t \<and> cs = c"
+ proof(cases "cs = c")
+ case False
+ with nw wt show ?thesis
+ by (auto simp:cs_waiting_def wq_def Let_def)
+ next
+ case True
+ from nw[folded True] wt[folded True]
+ have "next_th s th cs t"
+ apply (unfold next_th_def, auto simp:cs_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "a = th" by auto
+ next
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "t = hd (SOME q. distinct q \<and> set q = set list)" by auto
+ next
+ fix a list
+ assume eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step[OF vt]
+ show "a = th"
+ proof(cases)
+ assume "holding s th cs"
+ with eq_wq show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+ with True show ?thesis by simp
+ qed
+qed
+
+lemma step_v_not_wait[consumes 3]:
+ "\<lbrakk>vt (V th cs # s); next_th s th cs t; waiting (wq (V th cs # s)) t cs\<rbrakk> \<Longrightarrow> False"
+ by (unfold next_th_def cs_waiting_def wq_def, auto simp:Let_def)
+
+lemma step_v_release:
+ "\<lbrakk>vt (V th cs # s); holding (wq (V th cs # s)) th cs\<rbrakk> \<Longrightarrow> False"
+proof -
+ assume vt: "vt (V th cs # s)"
+ and hd: "holding (wq (V th cs # s)) th cs"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ from step_back_step [OF vt] and hd
+ show "False"
+ proof(cases)
+ assume "holding (wq (V th cs # s)) th cs" and "holding s th cs"
+ thus ?thesis
+ apply (unfold s_holding_def wq_def cs_holding_def)
+ apply (auto simp:Let_def split:list.splits)
+ proof -
+ fix list
+ assume eq_wq[folded wq_def]:
+ "wq_fun (schs s) cs = hd (SOME q. distinct q \<and> set q = set list) # list"
+ and hd_in: "hd (SOME q. distinct q \<and> set q = set list)
+ \<in> set (SOME q. distinct q \<and> set q = set list)"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ moreover have "distinct (hd (SOME q. distinct q \<and> set q = set list) # list)"
+ proof -
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show ?thesis by auto
+ qed
+ moreover note eq_wq and hd_in
+ ultimately show "False" by auto
+ qed
+ qed
+qed
+
+lemma step_v_get_hold:
+ "\<And>th'. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) th' cs; next_th s th cs th'\<rbrakk> \<Longrightarrow> False"
+ apply (unfold cs_holding_def next_th_def wq_def,
+ auto simp:Let_def)
+proof -
+ fix rest
+ assume vt: "vt (V th cs # s)"
+ and eq_wq[folded wq_def]: " wq_fun (schs s) cs = th # rest"
+ and nrest: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest)
+ \<notin> set (SOME q. distinct q \<and> set q = set rest)"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ hence "set x = set rest" by auto
+ with nrest
+ show "x \<noteq> []" by (case_tac x, auto)
+ qed
+ with ni show "False" by auto
+qed
+
+lemma step_v_release_inv[elim_format]:
+"\<And>c t. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) t c; holding (wq s) t c\<rbrakk> \<Longrightarrow>
+ c = cs \<and> t = th"
+ apply (unfold cs_holding_def wq_def, auto simp:Let_def split:if_splits list.splits)
+ proof -
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ next
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+
+lemma step_v_waiting_mono:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); waiting (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow> waiting (wq s) t c"
+proof -
+ fix t c
+ let ?s' = "(V th cs # s)"
+ assume vt: "vt ?s'"
+ and wt: "waiting (wq ?s') t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ show "waiting (wq s) t c"
+ proof(cases "c = cs")
+ case False
+ assume neq_cs: "c \<noteq> cs"
+ hence "waiting (wq ?s') t c = waiting (wq s) t c"
+ by (unfold cs_waiting_def wq_def, auto simp:Let_def)
+ with wt show ?thesis by simp
+ next
+ case True
+ with wt show ?thesis
+ apply (unfold cs_waiting_def wq_def, auto simp:Let_def split:list.splits)
+ proof -
+ fix a list
+ assume not_in: "t \<notin> set list"
+ and is_in: "t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ with not_in is_in show "t = a" by auto
+ next
+ fix list
+ assume is_waiting: "waiting (wq (V th cs # s)) t cs"
+ and eq_wq: "wq_fun (schs s) cs = t # list"
+ hence "t \<in> set list"
+ apply (unfold wq_def, auto simp:Let_def cs_waiting_def)
+ proof -
+ assume " t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ moreover have "\<dots> = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ ultimately show "t \<in> set list" by simp
+ qed
+ with eq_wq and vt_v.wq_distinct [of cs, unfolded wq_def]
+ show False by auto
+ qed
+ qed
+qed
+
+text {* (* ddd *)
+ The following @{text "step_RAG_v"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "V"}-events:
+*}
+lemma step_RAG_v:
+assumes vt:
+ "vt (V th cs#s)"
+shows "
+ RAG (V th cs # s) =
+ RAG s - {(Cs cs, Th th)} -
+ {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ apply (insert vt, unfold s_RAG_def)
+ apply (auto split:if_splits list.splits simp:Let_def)
+ apply (auto elim: step_v_waiting_mono step_v_hold_inv
+ step_v_release step_v_wait_inv
+ step_v_get_hold step_v_release_inv)
+ apply (erule_tac step_v_not_wait, auto)
+ done
+
+text {*
+ The following @{text "step_RAG_p"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "P"}-events:
+*}
+lemma step_RAG_p:
+ "vt (P th cs#s) \<Longrightarrow>
+ RAG (P th cs # s) = (if (wq s cs = []) then RAG s \<union> {(Cs cs, Th th)}
+ else RAG s \<union> {(Th th, Cs cs)})"
+ apply(simp only: s_RAG_def wq_def)
+ apply (auto split:list.splits prod.splits simp:Let_def wq_def cs_waiting_def cs_holding_def)
+ apply(case_tac "csa = cs", auto)
+ apply(fold wq_def)
+ apply(drule_tac step_back_step)
+ apply(ind_cases " step s (P (hd (wq s cs)) cs)")
+ apply(simp add:s_RAG_def wq_def cs_holding_def)
+ apply(auto)
+ done
+
+
+lemma RAG_target_th: "(Th th, x) \<in> RAG (s::state) \<Longrightarrow> \<exists> cs. x = Cs cs"
+ by (unfold s_RAG_def, auto)
+
+context valid_trace
+begin
+
+text {*
+ The following lemma shows that @{text "RAG"} is acyclic.
+ The overall structure is by induction on the formation of @{text "vt s"}
+ and then case analysis on event @{text "e"}, where the non-trivial cases
+ for those for @{text "V"} and @{text "P"} events.
+*}
+lemma acyclic_RAG:
+ shows "acyclic (RAG s)"
+using vt
+proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "acyclic (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de:
+ "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ from ih have ac: "acyclic (?A - ?B - ?C)" by (auto elim:acyclic_subset)
+ from step_back_step [OF vtt]
+ have "step s (V th cs)" .
+ thus ?thesis
+ proof(cases)
+ assume "holding s th cs"
+ hence th_in: "th \<in> set (wq s cs)" and
+ eq_hd: "th = hd (wq s cs)" unfolding s_holding_def wq_def by auto
+ then obtain rest where
+ eq_wq: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ show ?thesis
+ proof(cases "rest = []")
+ case False
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ from eq_wq False have eq_D: "?D = {(Cs cs, Th ?th')}"
+ by (unfold next_th_def, auto)
+ let ?E = "(?A - ?B - ?C)"
+ have "(Th ?th', Cs cs) \<notin> ?E\<^sup>*"
+ proof
+ assume "(Th ?th', Cs cs) \<in> ?E\<^sup>*"
+ hence " (Th ?th', Cs cs) \<in> ?E\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD [OF this]
+ obtain x where th'_e: "(Th ?th', x) \<in> ?E" by blast
+ hence th_d: "(Th ?th', x) \<in> ?A" by simp
+ from RAG_target_th [OF this]
+ obtain cs' where eq_x: "x = Cs cs'" by auto
+ with th_d have "(Th ?th', Cs cs') \<in> ?A" by simp
+ hence wt_th': "waiting s ?th' cs'"
+ unfolding s_RAG_def s_waiting_def cs_waiting_def wq_def by simp
+ hence "cs' = cs"
+ proof(rule vt_s.waiting_unique)
+ from eq_wq vt_s.wq_distinct[of cs]
+ show "waiting s ?th' cs"
+ apply (unfold s_waiting_def wq_def, auto)
+ proof -
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq_fun (schs s) cs = th # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show "hd (SOME q. distinct q \<and> set q = set rest) = th" by auto
+ next
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = hd (SOME q. distinct q \<and> set q = set rest) # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show False by auto
+ qed
+ qed
+ with th'_e eq_x have "(Th ?th', Cs cs) \<in> ?E" by simp
+ with False
+ show "False" by (auto simp: next_th_def eq_wq)
+ qed
+ with acyclic_insert[symmetric] and ac
+ and eq_de eq_D show ?thesis by auto
+ next
+ case True
+ with eq_wq
+ have eq_D: "?D = {}"
+ by (unfold next_th_def, auto)
+ with eq_de ac
+ show ?thesis by auto
+ qed
+ qed
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "acyclic ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ have "(Th th, Cs cs) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Th th, Cs cs) \<in> (RAG s)\<^sup>*"
+ hence "(Th th, Cs cs) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD2 [OF this]
+ obtain x where "(x, Cs cs) \<in> RAG s" by auto
+ with True show False by (auto simp:s_RAG_def cs_waiting_def)
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ next
+ case False
+ hence eq_r: "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ have "(Cs cs, Th th) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Cs cs, Th th) \<in> (RAG s)\<^sup>*"
+ hence "(Cs cs, Th th) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ moreover from step_back_step [OF vtt] have "step s (P th cs)" .
+ ultimately show False
+ proof -
+ show " \<lbrakk>(Cs cs, Th th) \<in> (RAG s)\<^sup>+; step s (P th cs)\<rbrakk> \<Longrightarrow> False"
+ by (ind_cases "step s (P th cs)", simp)
+ qed
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (Set thread prio)
+ with ih
+ thm RAG_set_unchanged
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "acyclic (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+qed
+
+
+lemma finite_RAG:
+ shows "finite (RAG s)"
+proof -
+ from vt show ?thesis
+ proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "finite (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de: "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}
+"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ moreover from ih have ac: "finite (?A - ?B - ?C)" by simp
+ moreover have "finite ?D"
+ proof -
+ have "?D = {} \<or> (\<exists> a. ?D = {a})"
+ by (unfold next_th_def, auto)
+ thus ?thesis
+ proof
+ assume h: "?D = {}"
+ show ?thesis by (unfold h, simp)
+ next
+ assume "\<exists> a. ?D = {a}"
+ thus ?thesis
+ by (metis finite.simps)
+ qed
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "finite ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ with True and ih show ?thesis by auto
+ next
+ case False
+ hence "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ with False and ih show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ next
+ case (Set thread prio)
+ with ih
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "finite (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+ qed
+qed
+
+text {* Several useful lemmas *}
+
+lemma wf_dep_converse:
+ shows "wf ((RAG s)^-1)"
+proof(rule finite_acyclic_wf_converse)
+ from finite_RAG
+ show "finite (RAG s)" .
+next
+ from acyclic_RAG
+ show "acyclic (RAG s)" .
+qed
+
+end
+
+lemma hd_np_in: "x \<in> set l \<Longrightarrow> hd l \<in> set l"
+ by (induct l, auto)
+
+lemma th_chasing: "(Th th, Cs cs) \<in> RAG (s::state) \<Longrightarrow> \<exists> th'. (Cs cs, Th th') \<in> RAG s"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+
+context valid_trace
+begin
+
+lemma wq_threads:
+ assumes h: "th \<in> set (wq s cs)"
+ shows "th \<in> threads s"
+proof -
+ from vt and h show ?thesis
+ proof(induct arbitrary: th cs)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s
+ using vt_cons(1) by (unfold_locales, auto)
+ assume ih: "\<And>th cs. th \<in> set (wq s cs) \<Longrightarrow> th \<in> threads s"
+ and stp: "step s e"
+ and vt: "vt s"
+ and h: "th \<in> set (wq (e # s) cs)"
+ show ?case
+ proof(cases e)
+ case (Create th' prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ next
+ case (Exit th')
+ with stp ih h show ?thesis
+ apply (auto simp:wq_def Let_def)
+ apply (ind_cases "step s (Exit th')")
+ apply (auto simp:runing_def readys_def s_holding_def s_waiting_def holdents_def
+ s_RAG_def s_holding_def cs_holding_def)
+ done
+ next
+ case (V th' cs')
+ show ?thesis
+ proof(cases "cs' = cs")
+ case False
+ with h
+ show ?thesis
+ apply(unfold wq_def V, auto simp:Let_def V split:prod.splits, fold wq_def)
+ by (drule_tac ih, simp)
+ next
+ case True
+ from h
+ show ?thesis
+ proof(unfold V wq_def)
+ assume th_in: "th \<in> set (wq_fun (schs (V th' cs' # s)) cs)" (is "th \<in> set ?l")
+ show "th \<in> threads (V th' cs' # s)"
+ proof(cases "cs = cs'")
+ case False
+ hence "?l = wq_fun (schs s) cs" by (simp add:Let_def)
+ with th_in have " th \<in> set (wq s cs)"
+ by (fold wq_def, simp)
+ from ih [OF this] show ?thesis by simp
+ next
+ case True
+ show ?thesis
+ proof(cases "wq_fun (schs s) cs'")
+ case Nil
+ with h V show ?thesis
+ apply (auto simp:wq_def Let_def split:if_splits)
+ by (fold wq_def, drule_tac ih, simp)
+ next
+ case (Cons a rest)
+ assume eq_wq: "wq_fun (schs s) cs' = a # rest"
+ with h V show ?thesis
+ apply (auto simp:Let_def wq_def split:if_splits)
+ proof -
+ assume th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs'] and eq_wq[folded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ with eq_wq th_in have "th \<in> set (wq_fun (schs s) cs')" by auto
+ from ih[OF this[folded wq_def]] show "th \<in> threads s" .
+ next
+ assume th_in: "th \<in> set (wq_fun (schs s) cs)"
+ from ih[OF this[folded wq_def]]
+ show "th \<in> threads s" .
+ qed
+ qed
+ qed
+ qed
+ qed
+ next
+ case (P th' cs')
+ from h stp
+ show ?thesis
+ apply (unfold P wq_def)
+ apply (auto simp:Let_def split:if_splits, fold wq_def)
+ apply (auto intro:ih)
+ apply(ind_cases "step s (P th' cs')")
+ by (unfold runing_def readys_def, auto)
+ next
+ case (Set thread prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ qed
+ next
+ case vt_nil
+ thus ?case by (auto simp:wq_def)
+ qed
+qed
+
+lemma range_in: "\<lbrakk>(Th th) \<in> Range (RAG (s::state))\<rbrakk> \<Longrightarrow> th \<in> threads s"
+ apply(unfold s_RAG_def cs_waiting_def cs_holding_def)
+ by (auto intro:wq_threads)
+
+lemma readys_v_eq:
+ assumes neq_th: "th \<noteq> thread"
+ and eq_wq: "wq s cs = thread#rest"
+ and not_in: "th \<notin> set rest"
+ shows "(th \<in> readys (V thread cs#s)) = (th \<in> readys s)"
+proof -
+ from assms show ?thesis
+ apply (auto simp:readys_def)
+ apply(simp add:s_waiting_def[folded wq_def])
+ apply (erule_tac x = csa in allE)
+ apply (simp add:s_waiting_def wq_def Let_def split:if_splits)
+ apply (case_tac "csa = cs", simp)
+ apply (erule_tac x = cs in allE)
+ apply(auto simp add: s_waiting_def[folded wq_def] Let_def split: list.splits)
+ apply(auto simp add: wq_def)
+ apply (auto simp:s_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ assume th_nin: "th \<notin> set rest"
+ and th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ and eq_wq: "wq_fun (schs s) cs = thread # rest"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from wq_distinct[of cs, unfolded wq_def] and eq_wq[unfolded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ with th_nin th_in show False by auto
+ qed
+qed
+
+text {* \noindent
+ The following lemmas shows that: starting from any node in @{text "RAG"},
+ by chasing out-going edges, it is always possible to reach a node representing a ready
+ thread. In this lemma, it is the @{text "th'"}.
+*}
+
+lemma chain_building:
+ shows "node \<in> Domain (RAG s) \<longrightarrow> (\<exists> th'. th' \<in> readys s \<and> (node, Th th') \<in> (RAG s)^+)"
+proof -
+ from wf_dep_converse
+ have h: "wf ((RAG s)\<inverse>)" .
+ show ?thesis
+ proof(induct rule:wf_induct [OF h])
+ fix x
+ assume ih [rule_format]:
+ "\<forall>y. (y, x) \<in> (RAG s)\<inverse> \<longrightarrow>
+ y \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (y, Th th') \<in> (RAG s)\<^sup>+)"
+ show "x \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+)"
+ proof
+ assume x_d: "x \<in> Domain (RAG s)"
+ show "\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+"
+ proof(cases x)
+ case (Th th)
+ from x_d Th obtain cs where x_in: "(Th th, Cs cs) \<in> RAG s" by (auto simp:s_RAG_def)
+ with Th have x_in_r: "(Cs cs, x) \<in> (RAG s)^-1" by simp
+ from th_chasing [OF x_in] obtain th' where "(Cs cs, Th th') \<in> RAG s" by blast
+ hence "Cs cs \<in> Domain (RAG s)" by auto
+ from ih [OF x_in_r this] obtain th'
+ where th'_ready: " th' \<in> readys s" and cs_in: "(Cs cs, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "(x, Th th') \<in> (RAG s)\<^sup>+" using Th x_in cs_in by auto
+ with th'_ready show ?thesis by auto
+ next
+ case (Cs cs)
+ from x_d Cs obtain th' where th'_d: "(Th th', x) \<in> (RAG s)^-1" by (auto simp:s_RAG_def)
+ show ?thesis
+ proof(cases "th' \<in> readys s")
+ case True
+ from True and th'_d show ?thesis by auto
+ next
+ case False
+ from th'_d and range_in have "th' \<in> threads s" by auto
+ with False have "Th th' \<in> Domain (RAG s)"
+ by (auto simp:readys_def wq_def s_waiting_def s_RAG_def cs_waiting_def Domain_def)
+ from ih [OF th'_d this]
+ obtain th'' where
+ th''_r: "th'' \<in> readys s" and
+ th''_in: "(Th th', Th th'') \<in> (RAG s)\<^sup>+" by auto
+ from th'_d and th''_in
+ have "(x, Th th'') \<in> (RAG s)\<^sup>+" by auto
+ with th''_r show ?thesis by auto
+ qed
+ qed
+ qed
+ qed
+qed
+
+text {* \noindent
+ The following is just an instance of @{text "chain_building"}.
+*}
+lemma th_chain_to_ready:
+ assumes th_in: "th \<in> threads s"
+ shows "th \<in> readys s \<or> (\<exists> th'. th' \<in> readys s \<and> (Th th, Th th') \<in> (RAG s)^+)"
+proof(cases "th \<in> readys s")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ from False and th_in have "Th th \<in> Domain (RAG s)"
+ by (auto simp:readys_def s_waiting_def s_RAG_def wq_def cs_waiting_def Domain_def)
+ from chain_building [rule_format, OF this]
+ show ?thesis by auto
+qed
+
+end
+
+lemma waiting_eq: "waiting s th cs = waiting (wq s) th cs"
+ by (unfold s_waiting_def cs_waiting_def wq_def, auto)
+
+lemma holding_eq: "holding (s::state) th cs = holding (wq s) th cs"
+ by (unfold s_holding_def wq_def cs_holding_def, simp)
+
+lemma holding_unique: "\<lbrakk>holding (s::state) th1 cs; holding s th2 cs\<rbrakk> \<Longrightarrow> th1 = th2"
+ by (unfold s_holding_def cs_holding_def, auto)
+
+context valid_trace
+begin
+
+lemma unique_RAG: "\<lbrakk>(n, n1) \<in> RAG s; (n, n2) \<in> RAG s\<rbrakk> \<Longrightarrow> n1 = n2"
+ apply(unfold s_RAG_def, auto, fold waiting_eq holding_eq)
+ by(auto elim:waiting_unique holding_unique)
+
+end
+
+
+lemma trancl_split: "(a, b) \<in> r^+ \<Longrightarrow> \<exists> c. (a, c) \<in> r"
+by (induct rule:trancl_induct, auto)
+
+context valid_trace
+begin
+
+lemma dchain_unique:
+ assumes th1_d: "(n, Th th1) \<in> (RAG s)^+"
+ and th1_r: "th1 \<in> readys s"
+ and th2_d: "(n, Th th2) \<in> (RAG s)^+"
+ and th2_r: "th2 \<in> readys s"
+ shows "th1 = th2"
+proof -
+ { assume neq: "th1 \<noteq> th2"
+ hence "Th th1 \<noteq> Th th2" by simp
+ from unique_chain [OF _ th1_d th2_d this] and unique_RAG
+ have "(Th th1, Th th2) \<in> (RAG s)\<^sup>+ \<or> (Th th2, Th th1) \<in> (RAG s)\<^sup>+" by auto
+ hence "False"
+ proof
+ assume "(Th th1, Th th2) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th1, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th1 \<notin> readys s"
+ by (auto simp:readys_def s_RAG_def wq_def s_waiting_def cs_waiting_def)
+ with th1_r show ?thesis by auto
+ next
+ assume "(Th th2, Th th1) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th2, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th2 \<notin> readys s"
+ by (auto simp:readys_def wq_def s_RAG_def s_waiting_def cs_waiting_def)
+ with th2_r show ?thesis by auto
+ qed
+ } thus ?thesis by auto
+qed
+
+end
+
+
+lemma step_holdents_p_add:
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs = []"
+ shows "holdents (P th cs#s) th = holdents s th \<union> {cs}"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by (auto)
+qed
+
+lemma step_holdents_p_eq:
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs \<noteq> []"
+ shows "holdents (P th cs#s) th = holdents s th"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by auto
+qed
+
+
+lemma (in valid_trace) finite_holding :
+ shows "finite (holdents s th)"
+proof -
+ let ?F = "\<lambda> (x, y). the_cs x"
+ from finite_RAG
+ have "finite (RAG s)" .
+ hence "finite (?F `(RAG s))" by simp
+ moreover have "{cs . (Cs cs, Th th) \<in> RAG s} \<subseteq> \<dots>"
+ proof -
+ { have h: "\<And> a A f. a \<in> A \<Longrightarrow> f a \<in> f ` A" by auto
+ fix x assume "(Cs x, Th th) \<in> RAG s"
+ hence "?F (Cs x, Th th) \<in> ?F `(RAG s)" by (rule h)
+ moreover have "?F (Cs x, Th th) = x" by simp
+ ultimately have "x \<in> (\<lambda>(x, y). the_cs x) ` RAG s" by simp
+ } thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (unfold holdents_test, auto intro:finite_subset)
+qed
+
+lemma cntCS_v_dec:
+ assumes vtv: "vt (V thread cs#s)"
+ shows "(cntCS (V thread cs#s) thread + 1) = cntCS s thread"
+proof -
+ from vtv interpret vt_s: valid_trace s
+ by (cases, unfold_locales, simp)
+ from vtv interpret vt_v: valid_trace "V thread cs#s"
+ by (unfold_locales, simp)
+ from step_back_step[OF vtv]
+ have cs_in: "cs \<in> holdents s thread"
+ apply (cases, unfold holdents_test s_RAG_def, simp)
+ by (unfold cs_holding_def s_holding_def wq_def, auto)
+ moreover have cs_not_in:
+ "(holdents (V thread cs#s) thread) = holdents s thread - {cs}"
+ apply (insert vt_s.wq_distinct[of cs])
+ apply (unfold holdents_test, unfold step_RAG_v[OF vtv],
+ auto simp:next_th_def)
+ proof -
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately
+ show "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ next
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately show "False" by auto
+ qed
+ ultimately
+ have "holdents s thread = insert cs (holdents (V thread cs#s) thread)"
+ by auto
+ moreover have "card \<dots> =
+ Suc (card ((holdents (V thread cs#s) thread) - {cs}))"
+ proof(rule card_insert)
+ from vt_v.finite_holding
+ show " finite (holdents (V thread cs # s) thread)" .
+ qed
+ moreover from cs_not_in
+ have "cs \<notin> (holdents (V thread cs#s) thread)" by auto
+ ultimately show ?thesis by (simp add:cntCS_def)
+qed
+
+lemma count_rec1 [simp]:
+ assumes "Q e"
+ shows "count Q (e#es) = Suc (count Q es)"
+ using assms
+ by (unfold count_def, auto)
+
+lemma count_rec2 [simp]:
+ assumes "\<not>Q e"
+ shows "count Q (e#es) = (count Q es)"
+ using assms
+ by (unfold count_def, auto)
+
+lemma count_rec3 [simp]:
+ shows "count Q [] = 0"
+ by (unfold count_def, auto)
+
+lemma cntP_diff_inv:
+ assumes "cntP (e#s) th \<noteq> cntP s th"
+ shows "isP e \<and> actor e = th"
+proof(cases e)
+ case (P th' pty)
+ show ?thesis
+ by (cases "(\<lambda>e. \<exists>cs. e = P th cs) (P th' pty)",
+ insert assms P, auto simp:cntP_def)
+qed (insert assms, auto simp:cntP_def)
+
+lemma isP_E:
+ assumes "isP e"
+ obtains cs where "e = P (actor e) cs"
+ using assms by (cases e, auto)
+
+lemma isV_E:
+ assumes "isV e"
+ obtains cs where "e = V (actor e) cs"
+ using assms by (cases e, auto) (* ccc *)
+
+lemma cntV_diff_inv:
+ assumes "cntV (e#s) th \<noteq> cntV s th"
+ shows "isV e \<and> actor e = th"
+proof(cases e)
+ case (V th' pty)
+ show ?thesis
+ by (cases "(\<lambda>e. \<exists>cs. e = V th cs) (V th' pty)",
+ insert assms V, auto simp:cntV_def)
+qed (insert assms, auto simp:cntV_def)
+
+context valid_trace
+begin
+
+text {* (* ddd *) \noindent
+ The relationship between @{text "cntP"}, @{text "cntV"} and @{text "cntCS"}
+ of one particular thread.
+*}
+
+lemma cnp_cnv_cncs:
+ shows "cntP s th = cntV s th + (if (th \<in> readys s \<or> th \<notin> threads s)
+ then cntCS s th else cntCS s th + 1)"
+proof -
+ from vt show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1) by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. cntP s th = cntV s th +
+ (if (th \<in> readys s \<or> th \<notin> threads s) then cntCS s th else cntCS s th + 1)"
+ and stp: "step s e"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in: "thread \<notin> threads s"
+ show ?thesis
+ proof -
+ { fix cs
+ assume "thread \<in> set (wq s cs)"
+ from vt_s.wq_threads [OF this] have "thread \<in> threads s" .
+ with not_in have "False" by simp
+ } with eq_e have eq_readys: "readys (e#s) = readys s \<union> {thread}"
+ by (auto simp:readys_def threads.simps s_waiting_def
+ wq_def cs_waiting_def Let_def)
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_create_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih not_in
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with not_in ih have " cntP s th = cntV s th + cntCS s th" by simp
+ moreover from eq_th and eq_readys have "th \<in> readys (e#s)" by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and is_runing: "thread \<in> runing s"
+ and no_hold: "holdents s thread = {}"
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_exit_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ apply (simp add:threads.simps readys_def)
+ apply (subst s_waiting_def)
+ apply (simp add:Let_def)
+ apply (subst s_waiting_def, simp)
+ done
+ with eq_cnp eq_cnv eq_cncs ih
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with ih is_runing have " cntP s th = cntV s th + cntCS s th"
+ by (simp add:runing_def)
+ moreover from eq_th eq_e have "th \<notin> threads (e#s)"
+ by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ and no_dep: "(Cs cs, Th thread) \<notin> (RAG s)\<^sup>+"
+ from thread_P vt stp ih have vtp: "vt (P thread cs#s)" by auto
+ then interpret vt_p: valid_trace "(P thread cs#s)"
+ by (unfold_locales, simp)
+ show ?thesis
+ proof -
+ { have hh: "\<And> A B C. (B = C) \<Longrightarrow> (A \<and> B) = (A \<and> C)" by blast
+ assume neq_th: "th \<noteq> thread"
+ with eq_e
+ have eq_readys: "(th \<in> readys (e#s)) = (th \<in> readys (s))"
+ apply (simp add:readys_def s_waiting_def wq_def Let_def)
+ apply (rule_tac hh)
+ apply (intro iffI allI, clarify)
+ apply (erule_tac x = csa in allE, auto)
+ apply (subgoal_tac "wq_fun (schs s) cs \<noteq> []", auto)
+ apply (erule_tac x = cs in allE, auto)
+ by (case_tac "(wq_fun (schs s) cs)", auto)
+ moreover from neq_th eq_e have "cntCS (e # s) th = cntCS s th"
+ apply (simp add:cntCS_def holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto)
+ moreover from eq_e neq_th have "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ moreover from eq_e neq_th have "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ moreover from eq_e neq_th have "threads (e#s) = threads s" by simp
+ moreover note ih [of th]
+ ultimately have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ have ?thesis
+ proof -
+ from eq_e eq_th have eq_cnp: "cntP (e # s) th = 1 + (cntP s th)"
+ by (simp add:cntP_def count_def)
+ from eq_e eq_th have eq_cnv: "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ show ?thesis
+ proof (cases "wq s cs = []")
+ case True
+ with is_runing
+ have "th \<in> readys (e#s)"
+ apply (unfold eq_e wq_def, unfold readys_def s_RAG_def)
+ apply (simp add: wq_def[symmetric] runing_def eq_th s_waiting_def)
+ by (auto simp:readys_def wq_def Let_def s_waiting_def wq_def)
+ moreover have "cntCS (e # s) th = 1 + cntCS s th"
+ proof -
+ have "card {csa. csa = cs \<or> (Cs csa, Th thread) \<in> RAG s} =
+ Suc (card {cs. (Cs cs, Th thread) \<in> RAG s})" (is "card ?L = Suc (card ?R)")
+ proof -
+ have "?L = insert cs ?R" by auto
+ moreover have "card \<dots> = Suc (card (?R - {cs}))"
+ proof(rule card_insert)
+ from vt_s.finite_holding [of thread]
+ show " finite {cs. (Cs cs, Th thread) \<in> RAG s}"
+ by (unfold holdents_test, simp)
+ qed
+ moreover have "?R - {cs} = ?R"
+ proof -
+ have "cs \<notin> ?R"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th thread) \<in> RAG s}"
+ with no_dep show False by auto
+ qed
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ thus ?thesis
+ apply (unfold eq_e eq_th cntCS_def)
+ apply (simp add: holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto simp:True)
+ qed
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ moreover note eq_cnp eq_cnv ih [of th]
+ ultimately show ?thesis by auto
+ next
+ case False
+ have eq_wq: "wq (e#s) cs = wq s cs @ [th]"
+ by (unfold eq_th eq_e wq_def, auto simp:Let_def)
+ have "th \<notin> readys (e#s)"
+ proof
+ assume "th \<in> readys (e#s)"
+ hence "\<forall>cs. \<not> waiting (e # s) th cs" by (simp add:readys_def)
+ from this[rule_format, of cs] have " \<not> waiting (e # s) th cs" .
+ hence "th \<in> set (wq (e#s) cs) \<Longrightarrow> th = hd (wq (e#s) cs)"
+ by (simp add:s_waiting_def wq_def)
+ moreover from eq_wq have "th \<in> set (wq (e#s) cs)" by auto
+ ultimately have "th = hd (wq (e#s) cs)" by blast
+ with eq_wq have "th = hd (wq s cs @ [th])" by simp
+ hence "th = hd (wq s cs)" using False by auto
+ with False eq_wq vt_p.wq_distinct [of cs]
+ show False by (fold eq_e, auto)
+ qed
+ moreover from is_runing have "th \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def eq_th)
+ moreover have "cntCS (e # s) th = cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_p[OF vtp])
+ by (auto simp:False)
+ moreover note eq_cnp eq_cnv ih[of th]
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ ultimately show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_V thread cs)
+ from assms vt stp ih thread_V have vtv: "vt (V thread cs # s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs # s)" by (unfold_locales, simp)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ have eq_threads: "threads (e#s) = threads s" by (simp add: eq_e)
+ have eq_set: "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ show ?thesis
+ proof -
+ { assume eq_th: "th = thread"
+ from eq_th have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (unfold eq_e, simp add:cntP_def count_def)
+ moreover from eq_th have eq_cnv: "cntV (e#s) th = 1 + cntV s th"
+ by (unfold eq_e, simp add:cntV_def count_def)
+ moreover from cntCS_v_dec [OF vtv]
+ have "cntCS (e # s) thread + 1 = cntCS s thread"
+ by (simp add:eq_e)
+ moreover from is_runing have rd_before: "thread \<in> readys s"
+ by (unfold runing_def, simp)
+ moreover have "thread \<in> readys (e # s)"
+ proof -
+ from is_runing
+ have "thread \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def)
+ moreover have "\<forall> cs1. \<not> waiting (e#s) thread cs1"
+ proof
+ fix cs1
+ { assume eq_cs: "cs1 = cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from eq_wq
+ have "thread \<notin> set (wq (e#s) cs1)"
+ apply(unfold eq_e wq_def eq_cs s_holding_def)
+ apply (auto simp:Let_def)
+ proof -
+ assume "thread \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ with eq_set have "thread \<in> set rest" by simp
+ with vt_v.wq_distinct[of cs]
+ and eq_wq show False
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ qed
+ thus ?thesis by (simp add:wq_def s_waiting_def)
+ qed
+ } moreover {
+ assume neq_cs: "cs1 \<noteq> cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from wq_v_neq [OF neq_cs[symmetric]]
+ have "wq (V thread cs # s) cs1 = wq s cs1" .
+ moreover have "\<not> waiting s thread cs1"
+ proof -
+ from runing_ready and is_runing
+ have "thread \<in> readys s" by auto
+ thus ?thesis by (simp add:readys_def)
+ qed
+ ultimately show ?thesis
+ by (auto simp:wq_def s_waiting_def eq_e)
+ qed
+ } ultimately show "\<not> waiting (e # s) thread cs1" by blast
+ qed
+ ultimately show ?thesis by (simp add:readys_def)
+ qed
+ moreover note eq_th ih
+ ultimately have ?thesis by auto
+ } moreover {
+ assume neq_th: "th \<noteq> thread"
+ from neq_th eq_e have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ from neq_th eq_e have eq_cnv: "cntV (e # s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ have ?thesis
+ proof(cases "th \<in> set rest")
+ case False
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ apply (insert step_back_vt[OF vtv])
+ by (simp add: False eq_e eq_wq neq_th vt_s.readys_v_eq)
+ moreover have "cntCS (e#s) th = cntCS s th"
+ apply (insert neq_th, unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ proof -
+ have "{csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from False eq_wq
+ have " next_th s thread cs th \<Longrightarrow> (Cs cs, Th th) \<in> RAG s"
+ apply (unfold next_th_def, auto)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = thread # rest"
+ from eq_set ni have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)
+ " by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[ of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with ne show "x \<noteq> []" by auto
+ qed
+ ultimately show
+ "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ qed
+ thus ?thesis by auto
+ qed
+ thus "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ card {cs. (Cs cs, Th th) \<in> RAG s}" by simp
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ assume th_in: "th \<in> set rest"
+ show ?thesis
+ proof(cases "next_th s thread cs th")
+ case False
+ with eq_wq and th_in have
+ neq_hd: "th \<noteq> hd (SOME q. distinct q \<and> set q = set rest)" (is "th \<noteq> hd ?rest")
+ by (auto simp:next_th_def)
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ proof -
+ from eq_wq and th_in
+ have "\<not> th \<in> readys s"
+ apply (auto simp:readys_def s_waiting_def)
+ apply (rule_tac x = cs in exI, auto)
+ by (insert vt_s.wq_distinct[of cs], auto simp add: wq_def)
+ moreover
+ from eq_wq and th_in and neq_hd
+ have "\<not> (th \<in> readys (e # s))"
+ apply (auto simp:readys_def s_waiting_def eq_e wq_def Let_def split:list.splits)
+ by (rule_tac x = cs in exI, auto simp:eq_set)
+ ultimately show ?thesis by auto
+ qed
+ moreover have "cntCS (e#s) th = cntCS s th"
+ proof -
+ from eq_wq and th_in and neq_hd
+ have "(holdents (e # s) th) = (holdents s th)"
+ apply (unfold eq_e step_RAG_v[OF vtv],
+ auto simp:next_th_def eq_set s_RAG_def holdents_test wq_def
+ Let_def cs_holding_def)
+ by (insert vt_s.wq_distinct[of cs], auto simp:wq_def)
+ thus ?thesis by (simp add:cntCS_def)
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ let ?rest = " (SOME q. distinct q \<and> set q = set rest)"
+ let ?t = "hd ?rest"
+ from True eq_wq th_in neq_th
+ have "th \<in> readys (e # s)"
+ apply (auto simp:eq_e readys_def s_waiting_def wq_def
+ Let_def next_th_def)
+ proof -
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ show "?t \<in> threads s"
+ proof(rule vt_s.wq_threads)
+ from eq_wq and t_in
+ show "?t \<in> set (wq s cs)" by (auto simp:wq_def)
+ qed
+ next
+ fix csa
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ and neq_cs: "csa \<noteq> cs"
+ and t_in': "?t \<in> set (wq_fun (schs s) csa)"
+ show "?t = hd (wq_fun (schs s) csa)"
+ proof -
+ { assume neq_hd': "?t \<noteq> hd (wq_fun (schs s) csa)"
+ from vt_s.wq_distinct[of cs] and
+ eq_wq[folded wq_def] and t_in eq_wq
+ have "?t \<noteq> thread" by auto
+ with eq_wq and t_in
+ have w1: "waiting s ?t cs"
+ by (auto simp:s_waiting_def wq_def)
+ from t_in' neq_hd'
+ have w2: "waiting s ?t csa"
+ by (auto simp:s_waiting_def wq_def)
+ from vt_s.waiting_unique[OF w1 w2]
+ and neq_cs have "False" by auto
+ } thus ?thesis by auto
+ qed
+ qed
+ moreover have "cntP s th = cntV s th + cntCS s th + 1"
+ proof -
+ have "th \<notin> readys s"
+ proof -
+ from True eq_wq neq_th th_in
+ show ?thesis
+ apply (unfold readys_def s_waiting_def, auto)
+ by (rule_tac x = cs in exI, auto simp add: wq_def)
+ qed
+ moreover have "th \<in> threads s"
+ proof -
+ from th_in eq_wq
+ have "th \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads [OF this]
+ show ?thesis .
+ qed
+ ultimately show ?thesis using ih by auto
+ qed
+ moreover from True neq_th have "cntCS (e # s) th = 1 + cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_v[OF vtv], auto)
+ proof -
+ show "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs} =
+ Suc (card {cs. (Cs cs, Th th) \<in> RAG s})"
+ (is "card ?A = Suc (card ?B)")
+ proof -
+ have "?A = insert cs ?B" by auto
+ hence "card ?A = card (insert cs ?B)" by simp
+ also have "\<dots> = Suc (card ?B)"
+ proof(rule card_insert_disjoint)
+ have "?B \<subseteq> ((\<lambda> (x, y). the_cs x) ` RAG s)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Cs x, Th th)" in bexI, auto)
+ with vt_s.finite_RAG
+ show "finite {cs. (Cs cs, Th th) \<in> RAG s}" by (auto intro:finite_subset)
+ next
+ show "cs \<notin> {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th th) \<in> RAG s}"
+ hence "(Cs cs, Th th) \<in> RAG s" by simp
+ with True neq_th eq_wq show False
+ by (auto simp:next_th_def s_RAG_def cs_holding_def)
+ qed
+ qed
+ finally show ?thesis .
+ qed
+ qed
+ moreover note eq_cnp eq_cnv
+ ultimately show ?thesis by simp
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_set thread prio)
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ show ?thesis
+ proof -
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_set_unchanged eq_e)
+ from eq_e have eq_readys: "readys (e#s) = readys s"
+ by (simp add:readys_def cs_waiting_def s_waiting_def wq_def,
+ auto simp:Let_def)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih is_runing
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with is_runing ih have " cntP s th = cntV s th + cntCS s th"
+ by (unfold runing_def, auto)
+ moreover from eq_th and eq_readys is_runing have "th \<in> readys (e#s)"
+ by (simp add:runing_def)
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntP_def cntV_def cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+lemma not_thread_cncs:
+ assumes not_in: "th \<notin> threads s"
+ shows "cntCS s th = 0"
+proof -
+ from vt not_in show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e th)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. th \<notin> threads s \<Longrightarrow> cntCS s th = 0"
+ and stp: "step s e"
+ and not_in: "th \<notin> threads (e # s)"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in': "thread \<notin> threads s"
+ have "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_create_unchanged)
+ moreover have "th \<notin> threads s"
+ proof -
+ from not_in eq_e show ?thesis by simp
+ qed
+ moreover note ih ultimately show ?thesis by auto
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and nh: "holdents s thread = {}"
+ have eq_cns: "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_exit_unchanged)
+ show ?thesis
+ proof(cases "th = thread")
+ case True
+ have "cntCS s th = 0" by (unfold cntCS_def, auto simp:nh True)
+ with eq_cns show ?thesis by simp
+ next
+ case False
+ with not_in and eq_e
+ have "th \<notin> threads s" by simp
+ from ih[OF this] and eq_cns show ?thesis by simp
+ qed
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ from assms thread_P ih vt stp thread_P have vtp: "vt (P thread cs#s)" by auto
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ hence "cntCS (e # s) th = cntCS s th "
+ apply (unfold cntCS_def holdents_test eq_e)
+ by (unfold step_RAG_p[OF vtp], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_V thread cs)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ from assms thread_V vt stp ih
+ have vtv: "vt (V thread cs#s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs#s)"
+ by (unfold_locales, simp)
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ from not_in eq_e eq_wq
+ have "\<not> next_th s thread cs th"
+ apply (auto simp:next_th_def)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> threads s" (is "?t \<notin> threads s")
+ have "?t \<in> set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ fix x assume "distinct x \<and> set x = set rest" with ne
+ show "hd x \<in> set rest" by (cases x, auto)
+ qed
+ with eq_wq have "?t \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads[OF this] and ni
+ show False
+ using `hd (SOME q. distinct q \<and> set q = set rest) \<in> set (wq s cs)`
+ ni vt_s.wq_threads by blast
+ qed
+ moreover note neq_th eq_wq
+ ultimately have "cntCS (e # s) th = cntCS s th"
+ by (unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_set thread prio)
+ print_facts
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ from not_in and eq_e have "th \<notin> threads s" by auto
+ from ih [OF this] and eq_e
+ show ?thesis
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+end
+
+lemma eq_waiting: "waiting (wq (s::state)) th cs = waiting s th cs"
+ by (auto simp:s_waiting_def cs_waiting_def wq_def)
+
+context valid_trace
+begin
+
+lemma dm_RAG_threads:
+ assumes in_dom: "(Th th) \<in> Domain (RAG s)"
+ shows "th \<in> threads s"
+proof -
+ from in_dom obtain n where "(Th th, n) \<in> RAG s" by auto
+ moreover from RAG_target_th[OF this] obtain cs where "n = Cs cs" by auto
+ ultimately have "(Th th, Cs cs) \<in> RAG s" by simp
+ hence "th \<in> set (wq s cs)"
+ by (unfold s_RAG_def, auto simp:cs_waiting_def)
+ from wq_threads [OF this] show ?thesis .
+qed
+
+end
+
+lemma cp_eq_cpreced: "cp s th = cpreced (wq s) s th"
+unfolding cp_def wq_def
+apply(induct s rule: schs.induct)
+thm cpreced_initial
+apply(simp add: Let_def cpreced_initial)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+done
+
+context valid_trace
+begin
+
+lemma runing_unique:
+ assumes runing_1: "th1 \<in> runing s"
+ and runing_2: "th2 \<in> runing s"
+ shows "th1 = th2"
+proof -
+ from runing_1 and runing_2 have "cp s th1 = cp s th2"
+ unfolding runing_def
+ apply(simp)
+ done
+ hence eq_max: "Max ((\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)) =
+ Max ((\<lambda>th. preced th s) ` ({th2} \<union> dependants (wq s) th2))"
+ (is "Max (?f ` ?A) = Max (?f ` ?B)")
+ unfolding cp_eq_cpreced
+ unfolding cpreced_def .
+ obtain th1' where th1_in: "th1' \<in> ?A" and eq_f_th1: "?f th1' = Max (?f ` ?A)"
+ proof -
+ have h1: "finite (?f ` ?A)"
+ proof -
+ have "finite ?A"
+ proof -
+ have "finite (dependants (wq s) th1)"
+ proof-
+ have "finite {th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th1)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?A) \<noteq> {}"
+ proof -
+ have "?A \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?A) \<in> (?f ` ?A)" .
+ thus ?thesis
+ thm cpreced_def
+ unfolding cpreced_def[symmetric]
+ unfolding cp_eq_cpreced[symmetric]
+ unfolding cpreced_def
+ using that[intro] by (auto)
+ qed
+ obtain th2' where th2_in: "th2' \<in> ?B" and eq_f_th2: "?f th2' = Max (?f ` ?B)"
+ proof -
+ have h1: "finite (?f ` ?B)"
+ proof -
+ have "finite ?B"
+ proof -
+ have "finite (dependants (wq s) th2)"
+ proof-
+ have "finite {th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th2)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?B) \<noteq> {}"
+ proof -
+ have "?B \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?B) \<in> (?f ` ?B)" .
+ thus ?thesis by (auto intro:that)
+ qed
+ from eq_f_th1 eq_f_th2 eq_max
+ have eq_preced: "preced th1' s = preced th2' s" by auto
+ hence eq_th12: "th1' = th2'"
+ proof (rule preced_unique)
+ from th1_in have "th1' = th1 \<or> (th1' \<in> dependants (wq s) th1)" by simp
+ thus "th1' \<in> threads s"
+ proof
+ assume "th1' \<in> dependants (wq s) th1"
+ hence "(Th th1') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th1') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th1' = th1"
+ with runing_1 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ next
+ from th2_in have "th2' = th2 \<or> (th2' \<in> dependants (wq s) th2)" by simp
+ thus "th2' \<in> threads s"
+ proof
+ assume "th2' \<in> dependants (wq s) th2"
+ hence "(Th th2') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th2') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th2' = th2"
+ with runing_2 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ qed
+ from th1_in have "th1' = th1 \<or> th1' \<in> dependants (wq s) th1" by simp
+ thus ?thesis
+ proof
+ assume eq_th': "th1' = th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2" thus ?thesis using eq_th' eq_th12 by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 eq_th' have "th1 \<in> dependants (wq s) th2" by simp
+ hence "(Th th1, Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th1 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th1 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th1, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th1, Cs cs') \<in> RAG s" by simp
+ with runing_1 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ qed
+ next
+ assume th1'_in: "th1' \<in> dependants (wq s) th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2"
+ with th1'_in eq_th12 have "th2 \<in> dependants (wq s) th1" by simp
+ hence "(Th th2, Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th2 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th2 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th2, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th2, Cs cs') \<in> RAG s" by simp
+ with runing_2 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 have "th1' \<in> dependants (wq s) th2" by simp
+ hence h1: "(Th th1', Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ from th1'_in have h2: "(Th th1', Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ show ?thesis
+ proof(rule dchain_unique[OF h1 _ h2, symmetric])
+ from runing_1 show "th1 \<in> readys s" by (simp add:runing_def)
+ from runing_2 show "th2 \<in> readys s" by (simp add:runing_def)
+ qed
+ qed
+ qed
+qed
+
+
+lemma "card (runing s) \<le> 1"
+apply(subgoal_tac "finite (runing s)")
+prefer 2
+apply (metis finite_nat_set_iff_bounded lessI runing_unique)
+apply(rule ccontr)
+apply(simp)
+apply(case_tac "Suc (Suc 0) \<le> card (runing s)")
+apply(subst (asm) card_le_Suc_iff)
+apply(simp)
+apply(auto)[1]
+apply (metis insertCI runing_unique)
+apply(auto)
+done
+
+end
+
+
+lemma create_pre:
+ assumes stp: "step s e"
+ and not_in: "th \<notin> threads s"
+ and is_in: "th \<in> threads (e#s)"
+ obtains prio where "e = Create th prio"
+proof -
+ from assms
+ show ?thesis
+ proof(cases)
+ case (thread_create thread prio)
+ with is_in not_in have "e = Create th prio" by simp
+ from that[OF this] show ?thesis .
+ next
+ case (thread_exit thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_P thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_V thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_set thread)
+ with assms show ?thesis by (auto intro!:that)
+ qed
+qed
+
+
+context valid_trace
+begin
+
+lemma cnp_cnv_eq:
+ assumes "th \<notin> threads s"
+ shows "cntP s th = cntV s th"
+ using assms
+ using cnp_cnv_cncs not_thread_cncs by auto
+
+end
+
+
+lemma eq_RAG:
+ "RAG (wq s) = RAG s"
+by (unfold cs_RAG_def s_RAG_def, auto)
+
+context valid_trace
+begin
+
+lemma count_eq_dependants:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "dependants (wq s) th = {}"
+proof -
+ from cnp_cnv_cncs and eq_pv
+ have "cntCS s th = 0"
+ by (auto split:if_splits)
+ moreover have "finite {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from finite_holding[of th] show ?thesis
+ by (simp add:holdents_test)
+ qed
+ ultimately have h: "{cs. (Cs cs, Th th) \<in> RAG s} = {}"
+ by (unfold cntCS_def holdents_test cs_dependants_def, auto)
+ show ?thesis
+ proof(unfold cs_dependants_def)
+ { assume "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}"
+ then obtain th' where "(Th th', Th th) \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "False"
+ proof(cases)
+ assume "(Th th', Th th) \<in> RAG (wq s)"
+ thus "False" by (auto simp:cs_RAG_def)
+ next
+ fix c
+ assume "(c, Th th) \<in> RAG (wq s)"
+ with h and eq_RAG show "False"
+ by (cases c, auto simp:cs_RAG_def)
+ qed
+ } thus "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} = {}" by auto
+ qed
+qed
+
+lemma dependants_threads:
+ shows "dependants (wq s) th \<subseteq> threads s"
+proof
+ { fix th th'
+ assume h: "th \<in> {th'a. (Th th'a, Th th') \<in> (RAG (wq s))\<^sup>+}"
+ have "Th th \<in> Domain (RAG s)"
+ proof -
+ from h obtain th' where "(Th th, Th th') \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "(Th th) \<in> Domain ( (RAG (wq s))\<^sup>+)" by (auto simp:Domain_def)
+ with trancl_domain have "(Th th) \<in> Domain (RAG (wq s))" by simp
+ thus ?thesis using eq_RAG by simp
+ qed
+ from dm_RAG_threads[OF this]
+ have "th \<in> threads s" .
+ } note hh = this
+ fix th1
+ assume "th1 \<in> dependants (wq s) th"
+ hence "th1 \<in> {th'a. (Th th'a, Th th) \<in> (RAG (wq s))\<^sup>+}"
+ by (unfold cs_dependants_def, simp)
+ from hh [OF this] show "th1 \<in> threads s" .
+qed
+
+lemma finite_threads:
+ shows "finite (threads s)"
+using vt by (induct) (auto elim: step.cases)
+
+end
+
+lemma Max_f_mono:
+ assumes seq: "A \<subseteq> B"
+ and np: "A \<noteq> {}"
+ and fnt: "finite B"
+ shows "Max (f ` A) \<le> Max (f ` B)"
+proof(rule Max_mono)
+ from seq show "f ` A \<subseteq> f ` B" by auto
+next
+ from np show "f ` A \<noteq> {}" by auto
+next
+ from fnt and seq show "finite (f ` B)" by auto
+qed
+
+context valid_trace
+begin
+
+lemma cp_le:
+ assumes th_in: "th \<in> threads s"
+ shows "cp s th \<le> Max ((\<lambda> th. (preced th s)) ` threads s)"
+proof(unfold cp_eq_cpreced cpreced_def cs_dependants_def)
+ show "Max ((\<lambda>th. preced th s) ` ({th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}))
+ \<le> Max ((\<lambda>th. preced th s) ` threads s)"
+ (is "Max (?f ` ?A) \<le> Max (?f ` ?B)")
+ proof(rule Max_f_mono)
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}" by simp
+ next
+ from finite_threads
+ show "finite (threads s)" .
+ next
+ from th_in
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> threads s"
+ apply (auto simp:Domain_def)
+ apply (rule_tac dm_RAG_threads)
+ apply (unfold trancl_domain [of "RAG s", symmetric])
+ by (unfold cs_RAG_def s_RAG_def, auto simp:Domain_def)
+ qed
+qed
+
+lemma le_cp:
+ shows "preced th s \<le> cp s th"
+proof(unfold cp_eq_cpreced preced_def cpreced_def, simp)
+ show "Prc (priority th s) (last_set th s)
+ \<le> Max (insert (Prc (priority th s) (last_set th s))
+ ((\<lambda>th. Prc (priority th s) (last_set th s)) ` dependants (wq s) th))"
+ (is "?l \<le> Max (insert ?l ?A)")
+ proof(cases "?A = {}")
+ case False
+ have "finite ?A" (is "finite (?f ` ?B)")
+ proof -
+ have "finite ?B"
+ proof-
+ have "finite {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ from Max_insert [OF this False, of ?l] show ?thesis by auto
+ next
+ case True
+ thus ?thesis by auto
+ qed
+qed
+
+lemma max_cp_eq:
+ shows "Max ((cp s) ` threads s) = Max ((\<lambda> th. (preced th s)) ` threads s)"
+ (is "?l = ?r")
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ have "?l \<in> ((cp s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ next
+ from False show "cp s ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th
+ where th_in: "th \<in> threads s" and eq_l: "?l = cp s th" by auto
+ have "\<dots> \<le> ?r" by (rule cp_le[OF th_in])
+ moreover have "?r \<le> cp s th" (is "Max (?f ` ?A) \<le> cp s th")
+ proof -
+ have "?r \<in> (?f ` ?A)"
+ proof(rule Max_in)
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by auto
+ next
+ from False show " (\<lambda>th. preced th s) ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th' where
+ th_in': "th' \<in> ?A " and eq_r: "?r = ?f th'" by auto
+ from le_cp [of th'] eq_r
+ have "?r \<le> cp s th'" by auto
+ moreover have "\<dots> \<le> cp s th"
+ proof(fold eq_l)
+ show " cp s th' \<le> Max (cp s ` threads s)"
+ proof(rule Max_ge)
+ from th_in' show "cp s th' \<in> cp s ` threads s"
+ by auto
+ next
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ qed
+ qed
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis using eq_l by auto
+qed
+
+lemma max_cp_readys_threads_pre:
+ assumes np: "threads s \<noteq> {}"
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(unfold max_cp_eq)
+ show "Max (cp s ` readys s) = Max ((\<lambda>th. preced th s) ` threads s)"
+ proof -
+ let ?p = "Max ((\<lambda>th. preced th s) ` threads s)"
+ let ?f = "(\<lambda>th. preced th s)"
+ have "?p \<in> ((\<lambda>th. preced th s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads show "finite (?f ` threads s)" by simp
+ next
+ from np show "?f ` threads s \<noteq> {}" by simp
+ qed
+ then obtain tm where tm_max: "?f tm = ?p" and tm_in: "tm \<in> threads s"
+ by (auto simp:Image_def)
+ from th_chain_to_ready [OF tm_in]
+ have "tm \<in> readys s \<or> (\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+)" .
+ thus ?thesis
+ proof
+ assume "\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+ "
+ then obtain th' where th'_in: "th' \<in> readys s"
+ and tm_chain:"(Th tm, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "cp s th' = ?f tm"
+ proof(subst cp_eq_cpreced, subst cpreced_def, rule Max_eqI)
+ from dependants_threads finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th'))"
+ by (auto intro:finite_subset)
+ next
+ fix p assume p_in: "p \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ from tm_max have " preced tm s = Max ((\<lambda>th. preced th s) ` threads s)" .
+ moreover have "p \<le> \<dots>"
+ proof(rule Max_ge)
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ from p_in and th'_in and dependants_threads[of th']
+ show "p \<in> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ ultimately show "p \<le> preced tm s" by auto
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ proof -
+ from tm_chain
+ have "tm \<in> dependants (wq s) th'"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, auto)
+ thus ?thesis by auto
+ qed
+ qed
+ with tm_max
+ have h: "cp s th' = Max ((\<lambda>th. preced th s) ` threads s)" by simp
+ show ?thesis
+ proof (fold h, rule Max_eqI)
+ fix q
+ assume "q \<in> cp s ` readys s"
+ then obtain th1 where th1_in: "th1 \<in> readys s"
+ and eq_q: "q = cp s th1" by auto
+ show "q \<le> cp s th'"
+ apply (unfold h eq_q)
+ apply (unfold cp_eq_cpreced cpreced_def)
+ apply (rule Max_mono)
+ proof -
+ from dependants_threads [of th1] th1_in
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<subseteq>
+ (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}" by simp
+ next
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ from th'_in
+ show "cp s th' \<in> cp s ` readys s" by simp
+ qed
+ next
+ assume tm_ready: "tm \<in> readys s"
+ show ?thesis
+ proof(fold tm_max)
+ have cp_eq_p: "cp s tm = preced tm s"
+ proof(unfold cp_eq_cpreced cpreced_def, rule Max_eqI)
+ fix y
+ assume hy: "y \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ show "y \<le> preced tm s"
+ proof -
+ { fix y'
+ assume hy' : "y' \<in> ((\<lambda>th. preced th s) ` dependants (wq s) tm)"
+ have "y' \<le> preced tm s"
+ proof(unfold tm_max, rule Max_ge)
+ from hy' dependants_threads[of tm]
+ show "y' \<in> (\<lambda>th. preced th s) ` threads s" by auto
+ next
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ } with hy show ?thesis by auto
+ qed
+ next
+ from dependants_threads[of tm] finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm))"
+ by (auto intro:finite_subset)
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ by simp
+ qed
+ moreover have "Max (cp s ` readys s) = cp s tm"
+ proof(rule Max_eqI)
+ from tm_ready show "cp s tm \<in> cp s ` readys s" by simp
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ fix y assume "y \<in> cp s ` readys s"
+ then obtain th1 where th1_readys: "th1 \<in> readys s"
+ and h: "y = cp s th1" by auto
+ show "y \<le> cp s tm"
+ apply(unfold cp_eq_p h)
+ apply(unfold cp_eq_cpreced cpreced_def tm_max, rule Max_mono)
+ proof -
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}"
+ by simp
+ next
+ from dependants_threads[of th1] th1_readys
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)
+ \<subseteq> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ qed
+ ultimately show " Max (cp s ` readys s) = preced tm s" by simp
+ qed
+ qed
+ qed
+qed
+
+text {* (* ccc *) \noindent
+ Since the current precedence of the threads in ready queue will always be boosted,
+ there must be one inside it has the maximum precedence of the whole system.
+*}
+lemma max_cp_readys_threads:
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis
+ by (auto simp:readys_def)
+next
+ case False
+ show ?thesis by (rule max_cp_readys_threads_pre[OF False])
+qed
+
+end
+
+lemma eq_holding: "holding (wq s) th cs = holding s th cs"
+ apply (unfold s_holding_def cs_holding_def wq_def, simp)
+ done
+
+lemma f_image_eq:
+ assumes h: "\<And> a. a \<in> A \<Longrightarrow> f a = g a"
+ shows "f ` A = g ` A"
+proof
+ show "f ` A \<subseteq> g ` A"
+ by(rule image_subsetI, auto intro:h)
+next
+ show "g ` A \<subseteq> f ` A"
+ by (rule image_subsetI, auto intro:h[symmetric])
+qed
+
+
+definition detached :: "state \<Rightarrow> thread \<Rightarrow> bool"
+ where "detached s th \<equiv> (\<not>(\<exists> cs. holding s th cs)) \<and> (\<not>(\<exists>cs. waiting s th cs))"
+
+
+lemma detached_test:
+ shows "detached s th = (Th th \<notin> Field (RAG s))"
+apply(simp add: detached_def Field_def)
+apply(simp add: s_RAG_def)
+apply(simp add: s_holding_abv s_waiting_abv)
+apply(simp add: Domain_iff Range_iff)
+apply(simp add: wq_def)
+apply(auto)
+done
+
+context valid_trace
+begin
+
+lemma detached_intro:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "detached s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_cnt: "cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ hence cncs_zero: "cntCS s th = 0"
+ by (auto simp:eq_pv split:if_splits)
+ with eq_cnt
+ have "th \<in> readys s \<or> th \<notin> threads s" by (auto simp:eq_pv)
+ thus ?thesis
+ proof
+ assume "th \<notin> threads s"
+ with range_in dm_RAG_threads
+ show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def Domain_iff Range_iff)
+ next
+ assume "th \<in> readys s"
+ moreover have "Th th \<notin> Range (RAG s)"
+ proof -
+ from card_0_eq [OF finite_holding] and cncs_zero
+ have "holdents s th = {}"
+ by (simp add:cntCS_def)
+ thus ?thesis
+ apply(auto simp:holdents_test)
+ apply(case_tac a)
+ apply(auto simp:holdents_test s_RAG_def)
+ done
+ qed
+ ultimately show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def readys_def)
+ qed
+qed
+
+lemma detached_elim:
+ assumes dtc: "detached s th"
+ shows "cntP s th = cntV s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_pv: " cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ have cncs_z: "cntCS s th = 0"
+ proof -
+ from dtc have "holdents s th = {}"
+ unfolding detached_def holdents_test s_RAG_def
+ by (simp add: s_waiting_abv wq_def s_holding_abv Domain_iff Range_iff)
+ thus ?thesis by (auto simp:cntCS_def)
+ qed
+ show ?thesis
+ proof(cases "th \<in> threads s")
+ case True
+ with dtc
+ have "th \<in> readys s"
+ by (unfold readys_def detached_def Field_def Domain_def Range_def,
+ auto simp:eq_waiting s_RAG_def)
+ with cncs_z and eq_pv show ?thesis by simp
+ next
+ case False
+ with cncs_z and eq_pv show ?thesis by simp
+ qed
+qed
+
+lemma detached_eq:
+ shows "(detached s th) = (cntP s th = cntV s th)"
+ by (insert vt, auto intro:detached_intro detached_elim)
+
+end
+
+text {*
+ The lemmas in this .thy file are all obvious lemmas, however, they still needs to be derived
+ from the concise and miniature model of PIP given in PrioGDef.thy.
+*}
+
+lemma eq_dependants: "dependants (wq s) = dependants s"
+ by (simp add: s_dependants_abv wq_def)
+
+lemma next_th_unique:
+ assumes nt1: "next_th s th cs th1"
+ and nt2: "next_th s th cs th2"
+ shows "th1 = th2"
+using assms by (unfold next_th_def, auto)
+
+lemma birth_time_lt: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ apply (induct s, simp)
+proof -
+ fix a s
+ assume ih: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ and eq_as: "a # s \<noteq> []"
+ show "last_set th (a # s) < length (a # s)"
+ proof(cases "s \<noteq> []")
+ case False
+ from False show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ next
+ case True
+ from ih [OF True] show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ qed
+qed
+
+lemma th_in_ne: "th \<in> threads s \<Longrightarrow> s \<noteq> []"
+ by (induct s, auto simp:threads.simps)
+
+lemma preced_tm_lt: "th \<in> threads s \<Longrightarrow> preced th s = Prc x y \<Longrightarrow> y < length s"
+ apply (drule_tac th_in_ne)
+ by (unfold preced_def, auto intro: birth_time_lt)
+
+lemma inj_the_preced:
+ "inj_on (the_preced s) (threads s)"
+ by (metis inj_onI preced_unique the_preced_def)
+
+lemma tRAG_alt_def:
+ "tRAG s = {(Th th1, Th th2) | th1 th2.
+ \<exists> cs. (Th th1, Cs cs) \<in> RAG s \<and> (Cs cs, Th th2) \<in> RAG s}"
+ by (auto simp:tRAG_def RAG_split wRAG_def hRAG_def)
+
+lemma tRAG_Field:
+ "Field (tRAG s) \<subseteq> Field (RAG s)"
+ by (unfold tRAG_alt_def Field_def, auto)
+
+lemma tRAG_ancestorsE:
+ assumes "x \<in> ancestors (tRAG s) u"
+ obtains th where "x = Th th"
+proof -
+ from assms have "(u, x) \<in> (tRAG s)^+"
+ by (unfold ancestors_def, auto)
+ from tranclE[OF this] obtain c where "(c, x) \<in> tRAG s" by auto
+ then obtain th where "x = Th th"
+ by (unfold tRAG_alt_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma tRAG_mono:
+ assumes "RAG s' \<subseteq> RAG s"
+ shows "tRAG s' \<subseteq> tRAG s"
+ using assms
+ by (unfold tRAG_alt_def, auto)
+
+lemma holding_next_thI:
+ assumes "holding s th cs"
+ and "length (wq s cs) > 1"
+ obtains th' where "next_th s th cs th'"
+proof -
+ from assms(1)[folded eq_holding, unfolded cs_holding_def]
+ have " th \<in> set (wq s cs) \<and> th = hd (wq s cs)" .
+ then obtain rest where h1: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ with assms(2) have h2: "rest \<noteq> []" by auto
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ have "next_th s th cs ?th'" using h1(1) h2
+ by (unfold next_th_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma RAG_tRAG_transfer:
+ assumes "vt s'"
+ assumes "RAG s = RAG s' \<union> {(Th th, Cs cs)}"
+ and "(Cs cs, Th th'') \<in> RAG s'"
+ shows "tRAG s = tRAG s' \<union> {(Th th, Th th'')}" (is "?L = ?R")
+proof -
+ interpret vt_s': valid_trace "s'" using assms(1)
+ by (unfold_locales, simp)
+ interpret rtree: rtree "RAG s'"
+ proof
+ show "single_valued (RAG s')"
+ apply (intro_locales)
+ by (unfold single_valued_def,
+ auto intro:vt_s'.unique_RAG)
+
+ show "acyclic (RAG s')"
+ by (rule vt_s'.acyclic_RAG)
+ qed
+ { fix n1 n2
+ assume "(n1, n2) \<in> ?L"
+ from this[unfolded tRAG_alt_def]
+ obtain th1 th2 cs' where
+ h: "n1 = Th th1" "n2 = Th th2"
+ "(Th th1, Cs cs') \<in> RAG s"
+ "(Cs cs', Th th2) \<in> RAG s" by auto
+ from h(4) and assms(2) have cs_in: "(Cs cs', Th th2) \<in> RAG s'" by auto
+ from h(3) and assms(2)
+ have "(Th th1, Cs cs') = (Th th, Cs cs) \<or>
+ (Th th1, Cs cs') \<in> RAG s'" by auto
+ hence "(n1, n2) \<in> ?R"
+ proof
+ assume h1: "(Th th1, Cs cs') = (Th th, Cs cs)"
+ hence eq_th1: "th1 = th" by simp
+ moreover have "th2 = th''"
+ proof -
+ from h1 have "cs' = cs" by simp
+ from assms(3) cs_in[unfolded this] rtree.sgv
+ show ?thesis
+ by (unfold single_valued_def, auto)
+ qed
+ ultimately show ?thesis using h(1,2) by auto
+ next
+ assume "(Th th1, Cs cs') \<in> RAG s'"
+ with cs_in have "(Th th1, Th th2) \<in> tRAG s'"
+ by (unfold tRAG_alt_def, auto)
+ from this[folded h(1, 2)] show ?thesis by auto
+ qed
+ } moreover {
+ fix n1 n2
+ assume "(n1, n2) \<in> ?R"
+ hence "(n1, n2) \<in>tRAG s' \<or> (n1, n2) = (Th th, Th th'')" by auto
+ hence "(n1, n2) \<in> ?L"
+ proof
+ assume "(n1, n2) \<in> tRAG s'"
+ moreover have "... \<subseteq> ?L"
+ proof(rule tRAG_mono)
+ show "RAG s' \<subseteq> RAG s" by (unfold assms(2), auto)
+ qed
+ ultimately show ?thesis by auto
+ next
+ assume eq_n: "(n1, n2) = (Th th, Th th'')"
+ from assms(2, 3) have "(Cs cs, Th th'') \<in> RAG s" by auto
+ moreover have "(Th th, Cs cs) \<in> RAG s" using assms(2) by auto
+ ultimately show ?thesis
+ by (unfold eq_n tRAG_alt_def, auto)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+context valid_trace
+begin
+
+lemmas RAG_tRAG_transfer = RAG_tRAG_transfer[OF vt]
+
+end
+
+lemma cp_alt_def:
+ "cp s th =
+ Max ((the_preced s) ` {th'. Th th' \<in> (subtree (RAG s) (Th th))})"
+proof -
+ have "Max (the_preced s ` ({th} \<union> dependants (wq s) th)) =
+ Max (the_preced s ` {th'. Th th' \<in> subtree (RAG s) (Th th)})"
+ (is "Max (_ ` ?L) = Max (_ ` ?R)")
+ proof -
+ have "?L = ?R"
+ by (auto dest:rtranclD simp:cs_dependants_def cs_RAG_def s_RAG_def subtree_def)
+ thus ?thesis by simp
+ qed
+ thus ?thesis by (unfold cp_eq_cpreced cpreced_def, fold the_preced_def, simp)
+qed
+
+lemma cp_gen_alt_def:
+ "cp_gen s = (Max \<circ> (\<lambda>x. (the_preced s \<circ> the_thread) ` subtree (tRAG s) x))"
+ by (auto simp:cp_gen_def)
+
+lemma tRAG_nodeE:
+ assumes "(n1, n2) \<in> tRAG s"
+ obtains th1 th2 where "n1 = Th th1" "n2 = Th th2"
+ using assms
+ by (auto simp: tRAG_def wRAG_def hRAG_def tRAG_def)
+
+lemma subtree_nodeE:
+ assumes "n \<in> subtree (tRAG s) (Th th)"
+ obtains th1 where "n = Th th1"
+proof -
+ show ?thesis
+ proof(rule subtreeE[OF assms])
+ assume "n = Th th"
+ from that[OF this] show ?thesis .
+ next
+ assume "Th th \<in> ancestors (tRAG s) n"
+ hence "(n, Th th) \<in> (tRAG s)^+" by (auto simp:ancestors_def)
+ hence "\<exists> th1. n = Th th1"
+ proof(induct)
+ case (base y)
+ from tRAG_nodeE[OF this] show ?case by metis
+ next
+ case (step y z)
+ thus ?case by auto
+ qed
+ with that show ?thesis by auto
+ qed
+qed
+
+lemma tRAG_star_RAG: "(tRAG s)^* \<subseteq> (RAG s)^*"
+proof -
+ have "(wRAG s O hRAG s)^* \<subseteq> (RAG s O RAG s)^*"
+ by (rule rtrancl_mono, auto simp:RAG_split)
+ also have "... \<subseteq> ((RAG s)^*)^*"
+ by (rule rtrancl_mono, auto)
+ also have "... = (RAG s)^*" by simp
+ finally show ?thesis by (unfold tRAG_def, simp)
+qed
+
+lemma tRAG_subtree_RAG: "subtree (tRAG s) x \<subseteq> subtree (RAG s) x"
+proof -
+ { fix a
+ assume "a \<in> subtree (tRAG s) x"
+ hence "(a, x) \<in> (tRAG s)^*" by (auto simp:subtree_def)
+ with tRAG_star_RAG[of s]
+ have "(a, x) \<in> (RAG s)^*" by auto
+ hence "a \<in> subtree (RAG s) x" by (auto simp:subtree_def)
+ } thus ?thesis by auto
+qed
+
+lemma tRAG_trancl_eq:
+ "{th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {th'. (Th th', Th th) \<in> (RAG s)^+}"
+ (is "?L = ?R")
+proof -
+ { fix th'
+ assume "th' \<in> ?L"
+ hence "(Th th', Th th) \<in> (tRAG s)^+" by auto
+ from tranclD[OF this]
+ obtain z where h: "(Th th', z) \<in> tRAG s" "(z, Th th) \<in> (tRAG s)\<^sup>*" by auto
+ from tRAG_subtree_RAG[of s] and this(2)
+ have "(z, Th th) \<in> (RAG s)^*" by (meson subsetCE tRAG_star_RAG)
+ moreover from h(1) have "(Th th', z) \<in> (RAG s)^+" using tRAG_alt_def by auto
+ ultimately have "th' \<in> ?R" by auto
+ } moreover
+ { fix th'
+ assume "th' \<in> ?R"
+ hence "(Th th', Th th) \<in> (RAG s)^+" by (auto)
+ from plus_rpath[OF this]
+ obtain xs where rp: "rpath (RAG s) (Th th') xs (Th th)" "xs \<noteq> []" by auto
+ hence "(Th th', Th th) \<in> (tRAG s)^+"
+ proof(induct xs arbitrary:th' th rule:length_induct)
+ case (1 xs th' th)
+ then obtain x1 xs1 where Cons1: "xs = x1#xs1" by (cases xs, auto)
+ show ?case
+ proof(cases "xs1")
+ case Nil
+ from 1(2)[unfolded Cons1 Nil]
+ have rp: "rpath (RAG s) (Th th') [x1] (Th th)" .
+ hence "(Th th', x1) \<in> (RAG s)" by (cases, simp)
+ then obtain cs where "x1 = Cs cs"
+ by (unfold s_RAG_def, auto)
+ from rpath_nnl_lastE[OF rp[unfolded this]]
+ show ?thesis by auto
+ next
+ case (Cons x2 xs2)
+ from 1(2)[unfolded Cons1[unfolded this]]
+ have rp: "rpath (RAG s) (Th th') (x1 # x2 # xs2) (Th th)" .
+ from rpath_edges_on[OF this]
+ have eds: "edges_on (Th th' # x1 # x2 # xs2) \<subseteq> RAG s" .
+ have "(Th th', x1) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ with eds have rg1: "(Th th', x1) \<in> RAG s" by auto
+ then obtain cs1 where eq_x1: "x1 = Cs cs1" by (unfold s_RAG_def, auto)
+ have "(x1, x2) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ from this eds
+ have rg2: "(x1, x2) \<in> RAG s" by auto
+ from this[unfolded eq_x1]
+ obtain th1 where eq_x2: "x2 = Th th1" by (unfold s_RAG_def, auto)
+ from rg1[unfolded eq_x1] rg2[unfolded eq_x1 eq_x2]
+ have rt1: "(Th th', Th th1) \<in> tRAG s" by (unfold tRAG_alt_def, auto)
+ from rp have "rpath (RAG s) x2 xs2 (Th th)"
+ by (elim rpath_ConsE, simp)
+ from this[unfolded eq_x2] have rp': "rpath (RAG s) (Th th1) xs2 (Th th)" .
+ show ?thesis
+ proof(cases "xs2 = []")
+ case True
+ from rpath_nilE[OF rp'[unfolded this]]
+ have "th1 = th" by auto
+ from rt1[unfolded this] show ?thesis by auto
+ next
+ case False
+ from 1(1)[rule_format, OF _ rp' this, unfolded Cons1 Cons]
+ have "(Th th1, Th th) \<in> (tRAG s)\<^sup>+" by simp
+ with rt1 show ?thesis by auto
+ qed
+ qed
+ qed
+ hence "th' \<in> ?L" by auto
+ } ultimately show ?thesis by blast
+qed
+
+lemma tRAG_trancl_eq_Th:
+ "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}"
+ using tRAG_trancl_eq by auto
+
+lemma dependants_alt_def:
+ "dependants s th = {th'. (Th th', Th th) \<in> (tRAG s)^+}"
+ by (metis eq_RAG s_dependants_def tRAG_trancl_eq)
+
+context valid_trace
+begin
+
+lemma count_eq_tRAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using assms count_eq_dependants dependants_alt_def eq_dependants by auto
+
+lemma count_eq_RAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using assms count_eq_dependants cs_dependants_def eq_RAG by auto
+
+lemma count_eq_RAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using count_eq_RAG_plus[OF assms] by auto
+
+lemma count_eq_tRAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using count_eq_tRAG_plus[OF assms] by auto
+
+end
+
+lemma tRAG_subtree_eq:
+ "(subtree (tRAG s) (Th th)) = {Th th' | th'. Th th' \<in> (subtree (RAG s) (Th th))}"
+ (is "?L = ?R")
+proof -
+ { fix n
+ assume h: "n \<in> ?L"
+ hence "n \<in> ?R"
+ by (smt mem_Collect_eq subsetCE subtree_def subtree_nodeE tRAG_subtree_RAG)
+ } moreover {
+ fix n
+ assume "n \<in> ?R"
+ then obtain th' where h: "n = Th th'" "(Th th', Th th) \<in> (RAG s)^*"
+ by (auto simp:subtree_def)
+ from rtranclD[OF this(2)]
+ have "n \<in> ?L"
+ proof
+ assume "Th th' \<noteq> Th th \<and> (Th th', Th th) \<in> (RAG s)\<^sup>+"
+ with h have "n \<in> {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}" by auto
+ thus ?thesis using subtree_def tRAG_trancl_eq by fastforce
+ qed (insert h, auto simp:subtree_def)
+ } ultimately show ?thesis by auto
+qed
+
+lemma threads_set_eq:
+ "the_thread ` (subtree (tRAG s) (Th th)) =
+ {th'. Th th' \<in> (subtree (RAG s) (Th th))}" (is "?L = ?R")
+ by (auto intro:rev_image_eqI simp:tRAG_subtree_eq)
+
+lemma cp_alt_def1:
+ "cp s th = Max ((the_preced s o the_thread) ` (subtree (tRAG s) (Th th)))"
+proof -
+ have "(the_preced s ` the_thread ` subtree (tRAG s) (Th th)) =
+ ((the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th))"
+ by auto
+ thus ?thesis by (unfold cp_alt_def, fold threads_set_eq, auto)
+qed
+
+lemma cp_gen_def_cond:
+ assumes "x = Th th"
+ shows "cp s th = cp_gen s (Th th)"
+by (unfold cp_alt_def1 cp_gen_def, simp)
+
+lemma cp_gen_over_set:
+ assumes "\<forall> x \<in> A. \<exists> th. x = Th th"
+ shows "cp_gen s ` A = (cp s \<circ> the_thread) ` A"
+proof(rule f_image_eq)
+ fix a
+ assume "a \<in> A"
+ from assms[rule_format, OF this]
+ obtain th where eq_a: "a = Th th" by auto
+ show "cp_gen s a = (cp s \<circ> the_thread) a"
+ by (unfold eq_a, simp, unfold cp_gen_def_cond[OF refl[of "Th th"]], simp)
+qed
+
+
+context valid_trace
+begin
+
+lemma RAG_threads:
+ assumes "(Th th) \<in> Field (RAG s)"
+ shows "th \<in> threads s"
+ using assms
+ by (metis Field_def UnE dm_RAG_threads range_in vt)
+
+lemma subtree_tRAG_thread:
+ assumes "th \<in> threads s"
+ shows "subtree (tRAG s) (Th th) \<subseteq> Th ` threads s" (is "?L \<subseteq> ?R")
+proof -
+ have "?L = {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ by (unfold tRAG_subtree_eq, simp)
+ also have "... \<subseteq> ?R"
+ proof
+ fix x
+ assume "x \<in> {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ then obtain th' where h: "x = Th th'" "Th th' \<in> subtree (RAG s) (Th th)" by auto
+ from this(2)
+ show "x \<in> ?R"
+ proof(cases rule:subtreeE)
+ case 1
+ thus ?thesis by (simp add: assms h(1))
+ next
+ case 2
+ thus ?thesis by (metis ancestors_Field dm_RAG_threads h(1) image_eqI)
+ qed
+ qed
+ finally show ?thesis .
+qed
+
+lemma readys_root:
+ assumes "th \<in> readys s"
+ shows "root (RAG s) (Th th)"
+proof -
+ { fix x
+ assume "x \<in> ancestors (RAG s) (Th th)"
+ hence h: "(Th th, x) \<in> (RAG s)^+" by (auto simp:ancestors_def)
+ from tranclD[OF this]
+ obtain z where "(Th th, z) \<in> RAG s" by auto
+ with assms(1) have False
+ apply (case_tac z, auto simp:readys_def s_RAG_def s_waiting_def cs_waiting_def)
+ by (fold wq_def, blast)
+ } thus ?thesis by (unfold root_def, auto)
+qed
+
+lemma readys_in_no_subtree:
+ assumes "th \<in> readys s"
+ and "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s) (Th th')"
+proof
+ assume "Th th \<in> subtree (RAG s) (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 1
+ with assms show ?thesis by auto
+ next
+ case 2
+ with readys_root[OF assms(1)]
+ show ?thesis by (auto simp:root_def)
+ qed
+qed
+
+lemma not_in_thread_isolated:
+ assumes "th \<notin> threads s"
+ shows "(Th th) \<notin> Field (RAG s)"
+proof
+ assume "(Th th) \<in> Field (RAG s)"
+ with dm_RAG_threads and range_in assms
+ show False by (unfold Field_def, blast)
+qed
+
+lemma wf_RAG: "wf (RAG s)"
+proof(rule finite_acyclic_wf)
+ from finite_RAG show "finite (RAG s)" .
+next
+ from acyclic_RAG show "acyclic (RAG s)" .
+qed
+
+lemma sgv_wRAG: "single_valued (wRAG s)"
+ using waiting_unique
+ by (unfold single_valued_def wRAG_def, auto)
+
+lemma sgv_hRAG: "single_valued (hRAG s)"
+ using holding_unique
+ by (unfold single_valued_def hRAG_def, auto)
+
+lemma sgv_tRAG: "single_valued (tRAG s)"
+ by (unfold tRAG_def, rule single_valued_relcomp,
+ insert sgv_wRAG sgv_hRAG, auto)
+
+lemma acyclic_tRAG: "acyclic (tRAG s)"
+proof(unfold tRAG_def, rule acyclic_compose)
+ show "acyclic (RAG s)" using acyclic_RAG .
+next
+ show "wRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+next
+ show "hRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+qed
+
+lemma sgv_RAG: "single_valued (RAG s)"
+ using unique_RAG by (auto simp:single_valued_def)
+
+lemma rtree_RAG: "rtree (RAG s)"
+ using sgv_RAG acyclic_RAG
+ by (unfold rtree_def rtree_axioms_def sgv_def, auto)
+
+end
+
+sublocale valid_trace < rtree_RAG: rtree "RAG s"
+proof
+ show "single_valued (RAG s)"
+ apply (intro_locales)
+ by (unfold single_valued_def,
+ auto intro:unique_RAG)
+
+ show "acyclic (RAG s)"
+ by (rule acyclic_RAG)
+qed
+
+sublocale valid_trace < rtree_s: rtree "tRAG s"
+proof(unfold_locales)
+ from sgv_tRAG show "single_valued (tRAG s)" .
+next
+ from acyclic_tRAG show "acyclic (tRAG s)" .
+qed
+
+sublocale valid_trace < fsbtRAGs : fsubtree "RAG s"
+proof -
+ show "fsubtree (RAG s)"
+ proof(intro_locales)
+ show "fbranch (RAG s)" using finite_fbranchI[OF finite_RAG] .
+ next
+ show "fsubtree_axioms (RAG s)"
+ proof(unfold fsubtree_axioms_def)
+ from wf_RAG show "wf (RAG s)" .
+ qed
+ qed
+qed
+
+sublocale valid_trace < fsbttRAGs: fsubtree "tRAG s"
+proof -
+ have "fsubtree (tRAG s)"
+ proof -
+ have "fbranch (tRAG s)"
+ proof(unfold tRAG_def, rule fbranch_compose)
+ show "fbranch (wRAG s)"
+ proof(rule finite_fbranchI)
+ from finite_RAG show "finite (wRAG s)"
+ by (unfold RAG_split, auto)
+ qed
+ next
+ show "fbranch (hRAG s)"
+ proof(rule finite_fbranchI)
+ from finite_RAG
+ show "finite (hRAG s)" by (unfold RAG_split, auto)
+ qed
+ qed
+ moreover have "wf (tRAG s)"
+ proof(rule wf_subset)
+ show "wf (RAG s O RAG s)" using wf_RAG
+ by (fold wf_comp_self, simp)
+ next
+ show "tRAG s \<subseteq> (RAG s O RAG s)"
+ by (unfold tRAG_alt_def, auto)
+ qed
+ ultimately show ?thesis
+ by (unfold fsubtree_def fsubtree_axioms_def,auto)
+ qed
+ from this[folded tRAG_def] show "fsubtree (tRAG s)" .
+qed
+
+lemma Max_UNION:
+ assumes "finite A"
+ and "A \<noteq> {}"
+ and "\<forall> M \<in> f ` A. finite M"
+ and "\<forall> M \<in> f ` A. M \<noteq> {}"
+ shows "Max (\<Union>x\<in> A. f x) = Max (Max ` f ` A)" (is "?L = ?R")
+ using assms[simp]
+proof -
+ have "?L = Max (\<Union>(f ` A))"
+ by (fold Union_image_eq, simp)
+ also have "... = ?R"
+ by (subst Max_Union, simp+)
+ finally show ?thesis .
+qed
+
+lemma max_Max_eq:
+ assumes "finite A"
+ and "A \<noteq> {}"
+ and "x = y"
+ shows "max x (Max A) = Max ({y} \<union> A)" (is "?L = ?R")
+proof -
+ have "?R = Max (insert y A)" by simp
+ also from assms have "... = ?L"
+ by (subst Max.insert, simp+)
+ finally show ?thesis by simp
+qed
+
+context valid_trace
+begin
+
+(* ddd *)
+lemma cp_gen_rec:
+ assumes "x = Th th"
+ shows "cp_gen s x = Max ({the_preced s th} \<union> (cp_gen s) ` children (tRAG s) x)"
+proof(cases "children (tRAG s) x = {}")
+ case True
+ show ?thesis
+ by (unfold True cp_gen_def subtree_children, simp add:assms)
+next
+ case False
+ hence [simp]: "children (tRAG s) x \<noteq> {}" by auto
+ note fsbttRAGs.finite_subtree[simp]
+ have [simp]: "finite (children (tRAG s) x)"
+ by (intro rev_finite_subset[OF fsbttRAGs.finite_subtree],
+ rule children_subtree)
+ { fix r x
+ have "subtree r x \<noteq> {}" by (auto simp:subtree_def)
+ } note this[simp]
+ have [simp]: "\<exists>x\<in>children (tRAG s) x. subtree (tRAG s) x \<noteq> {}"
+ proof -
+ from False obtain q where "q \<in> children (tRAG s) x" by blast
+ moreover have "subtree (tRAG s) q \<noteq> {}" by simp
+ ultimately show ?thesis by blast
+ qed
+ have h: "Max ((the_preced s \<circ> the_thread) `
+ ({x} \<union> \<Union>(subtree (tRAG s) ` children (tRAG s) x))) =
+ Max ({the_preced s th} \<union> cp_gen s ` children (tRAG s) x)"
+ (is "?L = ?R")
+ proof -
+ let "Max (?f ` (?A \<union> \<Union> (?g ` ?B)))" = ?L
+ let "Max (_ \<union> (?h ` ?B))" = ?R
+ let ?L1 = "?f ` \<Union>(?g ` ?B)"
+ have eq_Max_L1: "Max ?L1 = Max (?h ` ?B)"
+ proof -
+ have "?L1 = ?f ` (\<Union> x \<in> ?B.(?g x))" by simp
+ also have "... = (\<Union> x \<in> ?B. ?f ` (?g x))" by auto
+ finally have "Max ?L1 = Max ..." by simp
+ also have "... = Max (Max ` (\<lambda>x. ?f ` subtree (tRAG s) x) ` ?B)"
+ by (subst Max_UNION, simp+)
+ also have "... = Max (cp_gen s ` children (tRAG s) x)"
+ by (unfold image_comp cp_gen_alt_def, simp)
+ finally show ?thesis .
+ qed
+ show ?thesis
+ proof -
+ have "?L = Max (?f ` ?A \<union> ?L1)" by simp
+ also have "... = max (the_preced s (the_thread x)) (Max ?L1)"
+ by (subst Max_Un, simp+)
+ also have "... = max (?f x) (Max (?h ` ?B))"
+ by (unfold eq_Max_L1, simp)
+ also have "... =?R"
+ by (rule max_Max_eq, (simp)+, unfold assms, simp)
+ finally show ?thesis .
+ qed
+ qed thus ?thesis
+ by (fold h subtree_children, unfold cp_gen_def, simp)
+qed
+
+lemma cp_rec:
+ "cp s th = Max ({the_preced s th} \<union>
+ (cp s o the_thread) ` children (tRAG s) (Th th))"
+proof -
+ have "Th th = Th th" by simp
+ note h = cp_gen_def_cond[OF this] cp_gen_rec[OF this]
+ show ?thesis
+ proof -
+ have "cp_gen s ` children (tRAG s) (Th th) =
+ (cp s \<circ> the_thread) ` children (tRAG s) (Th th)"
+ proof(rule cp_gen_over_set)
+ show " \<forall>x\<in>children (tRAG s) (Th th). \<exists>th. x = Th th"
+ by (unfold tRAG_alt_def, auto simp:children_def)
+ qed
+ thus ?thesis by (subst (1) h(1), unfold h(2), simp)
+ qed
+qed
+
+end
+
+(* keep *)
+lemma next_th_holding:
+ assumes vt: "vt s"
+ and nxt: "next_th s th cs th'"
+ shows "holding (wq s) th cs"
+proof -
+ from nxt[unfolded next_th_def]
+ obtain rest where h: "wq s cs = th # rest"
+ "rest \<noteq> []"
+ "th' = hd (SOME q. distinct q \<and> set q = set rest)" by auto
+ thus ?thesis
+ by (unfold cs_holding_def, auto)
+qed
+
+context valid_trace
+begin
+
+lemma next_th_waiting:
+ assumes nxt: "next_th s th cs th'"
+ shows "waiting (wq s) th' cs"
+proof -
+ from nxt[unfolded next_th_def]
+ obtain rest where h: "wq s cs = th # rest"
+ "rest \<noteq> []"
+ "th' = hd (SOME q. distinct q \<and> set q = set rest)" by auto
+ from wq_distinct[of cs, unfolded h]
+ have dst: "distinct (th # rest)" .
+ have in_rest: "th' \<in> set rest"
+ proof(unfold h, rule someI2)
+ show "distinct rest \<and> set rest = set rest" using dst by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with h(2)
+ show "hd x \<in> set (rest)" by (cases x, auto)
+ qed
+ hence "th' \<in> set (wq s cs)" by (unfold h(1), auto)
+ moreover have "th' \<noteq> hd (wq s cs)"
+ by (unfold h(1), insert in_rest dst, auto)
+ ultimately show ?thesis by (auto simp:cs_waiting_def)
+qed
+
+lemma next_th_RAG:
+ assumes nxt: "next_th (s::event list) th cs th'"
+ shows "{(Cs cs, Th th), (Th th', Cs cs)} \<subseteq> RAG s"
+ using vt assms next_th_holding next_th_waiting
+ by (unfold s_RAG_def, simp)
+
+end
+
+-- {* A useless definition *}
+definition cps:: "state \<Rightarrow> (thread \<times> precedence) set"
+where "cps s = {(th, cp s th) | th . th \<in> threads s}"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PIPBasics.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,3793 @@
+theory PIPBasics
+imports PIPDefs
+begin
+
+locale valid_trace =
+ fixes s
+ assumes vt : "vt s"
+
+locale valid_trace_e = valid_trace +
+ fixes e
+ assumes vt_e: "vt (e#s)"
+begin
+
+lemma pip_e: "PIP s e"
+ using vt_e by (cases, simp)
+
+end
+
+lemma runing_ready:
+ shows "runing s \<subseteq> readys s"
+ unfolding runing_def readys_def
+ by auto
+
+lemma readys_threads:
+ shows "readys s \<subseteq> threads s"
+ unfolding readys_def
+ by auto
+
+lemma wq_v_neq:
+ "cs \<noteq> cs' \<Longrightarrow> wq (V thread cs#s) cs' = wq s cs'"
+ by (auto simp:wq_def Let_def cp_def split:list.splits)
+
+context valid_trace
+begin
+
+lemma actor_inv:
+ assumes "PIP s e"
+ and "\<not> isCreate e"
+ shows "actor e \<in> runing s"
+ using assms
+ by (induct, auto)
+
+lemma ind [consumes 0, case_names Nil Cons, induct type]:
+ assumes "PP []"
+ and "(\<And>s e. valid_trace s \<Longrightarrow> valid_trace (e#s) \<Longrightarrow>
+ PP s \<Longrightarrow> PIP s e \<Longrightarrow> PP (e # s))"
+ shows "PP s"
+proof(rule vt.induct[OF vt])
+ from assms(1) show "PP []" .
+next
+ fix s e
+ assume h: "vt s" "PP s" "PIP s e"
+ show "PP (e # s)"
+ proof(cases rule:assms(2))
+ from h(1) show v1: "valid_trace s" by (unfold_locales, simp)
+ next
+ from h(1,3) have "vt (e#s)" by auto
+ thus "valid_trace (e # s)" by (unfold_locales, simp)
+ qed (insert h, auto)
+qed
+
+lemma wq_distinct: "distinct (wq s cs)"
+proof(rule ind, simp add:wq_def)
+ fix s e
+ assume h1: "step s e"
+ and h2: "distinct (wq s cs)"
+ thus "distinct (wq (e # s) cs)"
+ proof(induct rule:step.induct, auto simp: wq_def Let_def split:list.splits)
+ fix thread s
+ assume h1: "(Cs cs, Th thread) \<notin> (RAG s)\<^sup>+"
+ and h2: "thread \<in> set (wq_fun (schs s) cs)"
+ and h3: "thread \<in> runing s"
+ show "False"
+ proof -
+ from h3 have "\<And> cs. thread \<in> set (wq_fun (schs s) cs) \<Longrightarrow>
+ thread = hd ((wq_fun (schs s) cs))"
+ by (simp add:runing_def readys_def s_waiting_def wq_def)
+ from this [OF h2] have "thread = hd (wq_fun (schs s) cs)" .
+ with h2
+ have "(Cs cs, Th thread) \<in> (RAG s)"
+ by (simp add:s_RAG_def s_holding_def wq_def cs_holding_def)
+ with h1 show False by auto
+ qed
+ next
+ fix thread s a list
+ assume dst: "distinct list"
+ show "distinct (SOME q. distinct q \<and> set q = set list)"
+ proof(rule someI2)
+ from dst show "distinct list \<and> set list = set list" by auto
+ next
+ fix q assume "distinct q \<and> set q = set list"
+ thus "distinct q" by auto
+ qed
+ qed
+qed
+
+end
+
+
+context valid_trace_e
+begin
+
+text {*
+ The following lemma shows that only the @{text "P"}
+ operation can add new thread into waiting queues.
+ Such kind of lemmas are very obvious, but need to be checked formally.
+ This is a kind of confirmation that our modelling is correct.
+*}
+
+lemma block_pre:
+ assumes s_ni: "thread \<notin> set (wq s cs)"
+ and s_i: "thread \<in> set (wq (e#s) cs)"
+ shows "e = P thread cs"
+proof -
+ show ?thesis
+ proof(cases e)
+ case (P th cs)
+ with assms
+ show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (Create th prio)
+ with assms show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (Exit th)
+ with assms show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (Set th prio)
+ with assms show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (V th cs)
+ with vt_e assms show ?thesis
+ apply (auto simp:wq_def Let_def split:if_splits)
+ proof -
+ fix q qs
+ assume h1: "thread \<notin> set (wq_fun (schs s) cs)"
+ and h2: "q # qs = wq_fun (schs s) cs"
+ and h3: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
+ and vt: "vt (V th cs # s)"
+ from h1 and h2[symmetric] have "thread \<notin> set (q # qs)" by simp
+ moreover have "thread \<in> set qs"
+ proof -
+ have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
+ proof(rule someI2)
+ from wq_distinct [of cs]
+ and h2[symmetric, folded wq_def]
+ show "distinct qs \<and> set qs = set qs" by auto
+ next
+ fix x assume "distinct x \<and> set x = set qs"
+ thus "set x = set qs" by auto
+ qed
+ with h3 show ?thesis by simp
+ qed
+ ultimately show "False" by auto
+ qed
+ qed
+qed
+
+end
+
+text {*
+ The following lemmas is also obvious and shallow. It says
+ that only running thread can request for a critical resource
+ and that the requested resource must be one which is
+ not current held by the thread.
+*}
+
+lemma p_pre: "\<lbrakk>vt ((P thread cs)#s)\<rbrakk> \<Longrightarrow>
+ thread \<in> runing s \<and> (Cs cs, Th thread) \<notin> (RAG s)^+"
+apply (ind_cases "vt ((P thread cs)#s)")
+apply (ind_cases "step s (P thread cs)")
+by auto
+
+lemma abs1:
+ assumes ein: "e \<in> set es"
+ and neq: "hd es \<noteq> hd (es @ [x])"
+ shows "False"
+proof -
+ from ein have "es \<noteq> []" by auto
+ then obtain e ess where "es = e # ess" by (cases es, auto)
+ with neq show ?thesis by auto
+qed
+
+lemma q_head: "Q (hd es) \<Longrightarrow> hd es = hd [th\<leftarrow>es . Q th]"
+ by (cases es, auto)
+
+inductive_cases evt_cons: "vt (a#s)"
+
+context valid_trace_e
+begin
+
+lemma abs2:
+ assumes inq: "thread \<in> set (wq s cs)"
+ and nh: "thread = hd (wq s cs)"
+ and qt: "thread \<noteq> hd (wq (e#s) cs)"
+ and inq': "thread \<in> set (wq (e#s) cs)"
+ shows "False"
+proof -
+ from vt_e assms show "False"
+ apply (cases e)
+ apply ((simp split:if_splits add:Let_def wq_def)[1])+
+ apply (insert abs1, fast)[1]
+ apply (auto simp:wq_def simp:Let_def split:if_splits list.splits)
+ proof -
+ fix th qs
+ assume vt: "vt (V th cs # s)"
+ and th_in: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
+ and eq_wq: "wq_fun (schs s) cs = thread # qs"
+ show "False"
+ proof -
+ from wq_distinct[of cs]
+ and eq_wq[folded wq_def] have "distinct (thread#qs)" by simp
+ moreover have "thread \<in> set qs"
+ proof -
+ have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
+ proof(rule someI2)
+ from wq_distinct [of cs]
+ and eq_wq [folded wq_def]
+ show "distinct qs \<and> set qs = set qs" by auto
+ next
+ fix x assume "distinct x \<and> set x = set qs"
+ thus "set x = set qs" by auto
+ qed
+ with th_in show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ qed
+qed
+
+end
+
+context valid_trace
+begin
+
+lemma vt_moment: "\<And> t. vt (moment t s)"
+proof(induct rule:ind)
+ case Nil
+ thus ?case by (simp add:vt_nil)
+next
+ case (Cons s e t)
+ show ?case
+ proof(cases "t \<ge> length (e#s)")
+ case True
+ from True have "moment t (e#s) = e#s" by simp
+ thus ?thesis using Cons
+ by (simp add:valid_trace_def)
+ next
+ case False
+ from Cons have "vt (moment t s)" by simp
+ moreover have "moment t (e#s) = moment t s"
+ proof -
+ from False have "t \<le> length s" by simp
+ from moment_app [OF this, of "[e]"]
+ show ?thesis by simp
+ qed
+ ultimately show ?thesis by simp
+ qed
+qed
+
+(* Wrong:
+ lemma \<lbrakk>thread \<in> set (wq_fun cs1 s); thread \<in> set (wq_fun cs2 s)\<rbrakk> \<Longrightarrow> cs1 = cs2"
+*)
+
+text {* (* ddd *)
+ The nature of the work is like this: since it starts from a very simple and basic
+ model, even intuitively very `basic` and `obvious` properties need to derived from scratch.
+ For instance, the fact
+ that one thread can not be blocked by two critical resources at the same time
+ is obvious, because only running threads can make new requests, if one is waiting for
+ a critical resource and get blocked, it can not make another resource request and get
+ blocked the second time (because it is not running).
+
+ To derive this fact, one needs to prove by contraction and
+ reason about time (or @{text "moement"}). The reasoning is based on a generic theorem
+ named @{text "p_split"}, which is about status changing along the time axis. It says if
+ a condition @{text "Q"} is @{text "True"} at a state @{text "s"},
+ but it was @{text "False"} at the very beginning, then there must exits a moment @{text "t"}
+ in the history of @{text "s"} (notice that @{text "s"} itself is essentially the history
+ of events leading to it), such that @{text "Q"} switched
+ from being @{text "False"} to @{text "True"} and kept being @{text "True"}
+ till the last moment of @{text "s"}.
+
+ Suppose a thread @{text "th"} is blocked
+ on @{text "cs1"} and @{text "cs2"} in some state @{text "s"},
+ since no thread is blocked at the very beginning, by applying
+ @{text "p_split"} to these two blocking facts, there exist
+ two moments @{text "t1"} and @{text "t2"} in @{text "s"}, such that
+ @{text "th"} got blocked on @{text "cs1"} and @{text "cs2"}
+ and kept on blocked on them respectively ever since.
+
+ Without lose of generality, we assume @{text "t1"} is earlier than @{text "t2"}.
+ However, since @{text "th"} was blocked ever since memonent @{text "t1"}, so it was still
+ in blocked state at moment @{text "t2"} and could not
+ make any request and get blocked the second time: Contradiction.
+*}
+
+lemma waiting_unique_pre:
+ assumes h11: "thread \<in> set (wq s cs1)"
+ and h12: "thread \<noteq> hd (wq s cs1)"
+ assumes h21: "thread \<in> set (wq s cs2)"
+ and h22: "thread \<noteq> hd (wq s cs2)"
+ and neq12: "cs1 \<noteq> cs2"
+ shows "False"
+proof -
+ let "?Q cs s" = "thread \<in> set (wq s cs) \<and> thread \<noteq> hd (wq s cs)"
+ from h11 and h12 have q1: "?Q cs1 s" by simp
+ from h21 and h22 have q2: "?Q cs2 s" by simp
+ have nq1: "\<not> ?Q cs1 []" by (simp add:wq_def)
+ have nq2: "\<not> ?Q cs2 []" by (simp add:wq_def)
+ from p_split [of "?Q cs1", OF q1 nq1]
+ obtain t1 where lt1: "t1 < length s"
+ and np1: "\<not>(thread \<in> set (wq (moment t1 s) cs1) \<and>
+ thread \<noteq> hd (wq (moment t1 s) cs1))"
+ and nn1: "(\<forall>i'>t1. thread \<in> set (wq (moment i' s) cs1) \<and>
+ thread \<noteq> hd (wq (moment i' s) cs1))" by auto
+ from p_split [of "?Q cs2", OF q2 nq2]
+ obtain t2 where lt2: "t2 < length s"
+ and np2: "\<not>(thread \<in> set (wq (moment t2 s) cs2) \<and>
+ thread \<noteq> hd (wq (moment t2 s) cs2))"
+ and nn2: "(\<forall>i'>t2. thread \<in> set (wq (moment i' s) cs2) \<and>
+ thread \<noteq> hd (wq (moment i' s) cs2))" by auto
+ show ?thesis
+ proof -
+ {
+ assume lt12: "t1 < t2"
+ let ?t3 = "Suc t2"
+ from lt2 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t2 s" by auto
+ have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t2 s" "e"
+ by (unfold_locales, auto, cases, simp)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre[OF False h1]
+ have "e = P thread cs2" .
+ with vt_e.vt_e have "vt ((P thread cs2)# moment t2 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t2 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t2 s)" by auto
+ with nn1 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume lt12: "t2 < t1"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 True eq_th h2 h1
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have "e = P thread cs1" .
+ with vt_e.vt_e have "vt ((P thread cs1)# moment t1 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t1 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t1 s)" by auto
+ with nn2 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume eqt12: "t1 = t2"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have vt_e: "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have eq_e1: "e = P thread cs1" .
+ have lt_t3: "t1 < ?t3" by simp
+ with eqt12 have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m and eqt12
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ show ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e and eqt12 have "vt (e#moment t2 s)" by simp
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.abs2 [OF True eq_th h2 h1]
+ show ?thesis .
+ next
+ case False
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment eqt12
+ have "vt (moment (Suc t2) s)" by auto
+ with eq_m eqt12 show ?thesis by simp
+ qed
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.block_pre [OF False h1]
+ have "e = P thread cs2" .
+ with eq_e1 neq12 show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by arith
+ qed
+qed
+
+text {*
+ This lemma is a simple corrolary of @{text "waiting_unique_pre"}.
+*}
+
+lemma waiting_unique:
+ assumes "waiting s th cs1"
+ and "waiting s th cs2"
+ shows "cs1 = cs2"
+using waiting_unique_pre assms
+unfolding wq_def s_waiting_def
+by auto
+
+end
+
+(* not used *)
+text {*
+ Every thread can only be blocked on one critical resource,
+ symmetrically, every critical resource can only be held by one thread.
+ This fact is much more easier according to our definition.
+*}
+lemma held_unique:
+ assumes "holding (s::event list) th1 cs"
+ and "holding s th2 cs"
+ shows "th1 = th2"
+ by (insert assms, unfold s_holding_def, auto)
+
+
+lemma last_set_lt: "th \<in> threads s \<Longrightarrow> last_set th s < length s"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits)
+
+lemma last_set_unique:
+ "\<lbrakk>last_set th1 s = last_set th2 s; th1 \<in> threads s; th2 \<in> threads s\<rbrakk>
+ \<Longrightarrow> th1 = th2"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits dest:last_set_lt)
+
+lemma preced_unique :
+ assumes pcd_eq: "preced th1 s = preced th2 s"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "th1 = th2"
+proof -
+ from pcd_eq have "last_set th1 s = last_set th2 s" by (simp add:preced_def)
+ from last_set_unique [OF this th_in1 th_in2]
+ show ?thesis .
+qed
+
+lemma preced_linorder:
+ assumes neq_12: "th1 \<noteq> th2"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "preced th1 s < preced th2 s \<or> preced th1 s > preced th2 s"
+proof -
+ from preced_unique [OF _ th_in1 th_in2] and neq_12
+ have "preced th1 s \<noteq> preced th2 s" by auto
+ thus ?thesis by auto
+qed
+
+(* An aux lemma used later *)
+lemma unique_minus:
+ fixes x y z r
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz and neq show ?thesis
+ proof(induct)
+ case (base ya)
+ have "(x, ya) \<in> r" by fact
+ from unique [OF xy this] have "y = ya" .
+ with base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from step True show ?thesis by simp
+ next
+ case False
+ from step False
+ show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_base:
+ fixes r x y z
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz neq_yz show ?thesis
+ proof(induct)
+ case (base ya)
+ from xy unique base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step
+ have "(y, ya) \<in> r\<^sup>+" by auto
+ with step show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_chain:
+ fixes r x y z
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r^+"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+ \<or> (z, y) \<in> r^+"
+proof -
+ from xy xz neq_yz show ?thesis
+ proof(induct)
+ case (base y)
+ have h1: "(x, y) \<in> r" and h2: "(x, z) \<in> r\<^sup>+" and h3: "y \<noteq> z" using base by auto
+ from unique_base [OF _ h1 h2 h3] and unique show ?case by auto
+ next
+ case (step y za)
+ show ?case
+ proof(cases "y = z")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step have "(y, z) \<in> r\<^sup>+ \<or> (z, y) \<in> r\<^sup>+" by auto
+ thus ?thesis
+ proof
+ assume "(z, y) \<in> r\<^sup>+"
+ with step have "(z, za) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ next
+ assume h: "(y, z) \<in> r\<^sup>+"
+ from step have yza: "(y, za) \<in> r" by simp
+ from step have "za \<noteq> z" by simp
+ from unique_minus [OF _ yza h this] and unique
+ have "(za, z) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ qed
+ qed
+ qed
+qed
+
+text {*
+ The following three lemmas show that @{text "RAG"} does not change
+ by the happening of @{text "Set"}, @{text "Create"} and @{text "Exit"}
+ events, respectively.
+*}
+
+lemma RAG_set_unchanged: "(RAG (Set th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_create_unchanged: "(RAG (Create th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_exit_unchanged: "(RAG (Exit th # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+
+text {*
+ The following lemmas are used in the proof of
+ lemma @{text "step_RAG_v"}, which characterizes how the @{text "RAG"} is changed
+ by @{text "V"}-events.
+ However, since our model is very concise, such seemingly obvious lemmas need to be derived from scratch,
+ starting from the model definitions.
+*}
+lemma step_v_hold_inv[elim_format]:
+ "\<And>c t. \<lbrakk>vt (V th cs # s);
+ \<not> holding (wq s) t c; holding (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow>
+ next_th s th cs t \<and> c = cs"
+proof -
+ fix c t
+ assume vt: "vt (V th cs # s)"
+ and nhd: "\<not> holding (wq s) t c"
+ and hd: "holding (wq (V th cs # s)) t c"
+ show "next_th s th cs t \<and> c = cs"
+ proof(cases "c = cs")
+ case False
+ with nhd hd show ?thesis
+ by (unfold cs_holding_def wq_def, auto simp:Let_def)
+ next
+ case True
+ with step_back_step [OF vt]
+ have "step s (V th c)" by simp
+ hence "next_th s th cs t"
+ proof(cases)
+ assume "holding s th c"
+ with nhd hd show ?thesis
+ apply (unfold s_holding_def cs_holding_def wq_def next_th_def,
+ auto simp:Let_def split:list.splits if_splits)
+ proof -
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ next
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ qed
+ qed
+ with True show ?thesis by auto
+ qed
+qed
+
+text {*
+ The following @{text "step_v_wait_inv"} is also an obvious lemma, which, however, needs to be
+ derived from scratch, which confirms the correctness of the definition of @{text "next_th"}.
+*}
+lemma step_v_wait_inv[elim_format]:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); \<not> waiting (wq (V th cs # s)) t c; waiting (wq s) t c
+ \<rbrakk>
+ \<Longrightarrow> (next_th s th cs t \<and> cs = c)"
+proof -
+ fix t c
+ assume vt: "vt (V th cs # s)"
+ and nw: "\<not> waiting (wq (V th cs # s)) t c"
+ and wt: "waiting (wq s) t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp)
+ show "next_th s th cs t \<and> cs = c"
+ proof(cases "cs = c")
+ case False
+ with nw wt show ?thesis
+ by (auto simp:cs_waiting_def wq_def Let_def)
+ next
+ case True
+ from nw[folded True] wt[folded True]
+ have "next_th s th cs t"
+ apply (unfold next_th_def, auto simp:cs_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "a = th" by auto
+ next
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "t = hd (SOME q. distinct q \<and> set q = set list)" by auto
+ next
+ fix a list
+ assume eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step[OF vt]
+ show "a = th"
+ proof(cases)
+ assume "holding s th cs"
+ with eq_wq show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+ with True show ?thesis by simp
+ qed
+qed
+
+lemma step_v_not_wait[consumes 3]:
+ "\<lbrakk>vt (V th cs # s); next_th s th cs t; waiting (wq (V th cs # s)) t cs\<rbrakk> \<Longrightarrow> False"
+ by (unfold next_th_def cs_waiting_def wq_def, auto simp:Let_def)
+
+lemma step_v_release:
+ "\<lbrakk>vt (V th cs # s); holding (wq (V th cs # s)) th cs\<rbrakk> \<Longrightarrow> False"
+proof -
+ assume vt: "vt (V th cs # s)"
+ and hd: "holding (wq (V th cs # s)) th cs"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ from step_back_step [OF vt] and hd
+ show "False"
+ proof(cases)
+ assume "holding (wq (V th cs # s)) th cs" and "holding s th cs"
+ thus ?thesis
+ apply (unfold s_holding_def wq_def cs_holding_def)
+ apply (auto simp:Let_def split:list.splits)
+ proof -
+ fix list
+ assume eq_wq[folded wq_def]:
+ "wq_fun (schs s) cs = hd (SOME q. distinct q \<and> set q = set list) # list"
+ and hd_in: "hd (SOME q. distinct q \<and> set q = set list)
+ \<in> set (SOME q. distinct q \<and> set q = set list)"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ moreover have "distinct (hd (SOME q. distinct q \<and> set q = set list) # list)"
+ proof -
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show ?thesis by auto
+ qed
+ moreover note eq_wq and hd_in
+ ultimately show "False" by auto
+ qed
+ qed
+qed
+
+lemma step_v_get_hold:
+ "\<And>th'. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) th' cs; next_th s th cs th'\<rbrakk> \<Longrightarrow> False"
+ apply (unfold cs_holding_def next_th_def wq_def,
+ auto simp:Let_def)
+proof -
+ fix rest
+ assume vt: "vt (V th cs # s)"
+ and eq_wq[folded wq_def]: " wq_fun (schs s) cs = th # rest"
+ and nrest: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest)
+ \<notin> set (SOME q. distinct q \<and> set q = set rest)"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ hence "set x = set rest" by auto
+ with nrest
+ show "x \<noteq> []" by (case_tac x, auto)
+ qed
+ with ni show "False" by auto
+qed
+
+lemma step_v_release_inv[elim_format]:
+"\<And>c t. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) t c; holding (wq s) t c\<rbrakk> \<Longrightarrow>
+ c = cs \<and> t = th"
+ apply (unfold cs_holding_def wq_def, auto simp:Let_def split:if_splits list.splits)
+ proof -
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ next
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+
+lemma step_v_waiting_mono:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); waiting (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow> waiting (wq s) t c"
+proof -
+ fix t c
+ let ?s' = "(V th cs # s)"
+ assume vt: "vt ?s'"
+ and wt: "waiting (wq ?s') t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ show "waiting (wq s) t c"
+ proof(cases "c = cs")
+ case False
+ assume neq_cs: "c \<noteq> cs"
+ hence "waiting (wq ?s') t c = waiting (wq s) t c"
+ by (unfold cs_waiting_def wq_def, auto simp:Let_def)
+ with wt show ?thesis by simp
+ next
+ case True
+ with wt show ?thesis
+ apply (unfold cs_waiting_def wq_def, auto simp:Let_def split:list.splits)
+ proof -
+ fix a list
+ assume not_in: "t \<notin> set list"
+ and is_in: "t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ with not_in is_in show "t = a" by auto
+ next
+ fix list
+ assume is_waiting: "waiting (wq (V th cs # s)) t cs"
+ and eq_wq: "wq_fun (schs s) cs = t # list"
+ hence "t \<in> set list"
+ apply (unfold wq_def, auto simp:Let_def cs_waiting_def)
+ proof -
+ assume " t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ moreover have "\<dots> = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ ultimately show "t \<in> set list" by simp
+ qed
+ with eq_wq and vt_v.wq_distinct [of cs, unfolded wq_def]
+ show False by auto
+ qed
+ qed
+qed
+
+text {* (* ddd *)
+ The following @{text "step_RAG_v"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "V"}-events:
+*}
+lemma step_RAG_v:
+fixes th::thread
+assumes vt:
+ "vt (V th cs#s)"
+shows "
+ RAG (V th cs # s) =
+ RAG s - {(Cs cs, Th th)} -
+ {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ apply (insert vt, unfold s_RAG_def)
+ apply (auto split:if_splits list.splits simp:Let_def)
+ apply (auto elim: step_v_waiting_mono step_v_hold_inv
+ step_v_release step_v_wait_inv
+ step_v_get_hold step_v_release_inv)
+ apply (erule_tac step_v_not_wait, auto)
+ done
+
+text {*
+ The following @{text "step_RAG_p"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "P"}-events:
+*}
+lemma step_RAG_p:
+ "vt (P th cs#s) \<Longrightarrow>
+ RAG (P th cs # s) = (if (wq s cs = []) then RAG s \<union> {(Cs cs, Th th)}
+ else RAG s \<union> {(Th th, Cs cs)})"
+ apply(simp only: s_RAG_def wq_def)
+ apply (auto split:list.splits prod.splits simp:Let_def wq_def cs_waiting_def cs_holding_def)
+ apply(case_tac "csa = cs", auto)
+ apply(fold wq_def)
+ apply(drule_tac step_back_step)
+ apply(ind_cases " step s (P (hd (wq s cs)) cs)")
+ apply(simp add:s_RAG_def wq_def cs_holding_def)
+ apply(auto)
+ done
+
+
+lemma RAG_target_th: "(Th th, x) \<in> RAG (s::state) \<Longrightarrow> \<exists> cs. x = Cs cs"
+ by (unfold s_RAG_def, auto)
+
+context valid_trace
+begin
+
+text {*
+ The following lemma shows that @{text "RAG"} is acyclic.
+ The overall structure is by induction on the formation of @{text "vt s"}
+ and then case analysis on event @{text "e"}, where the non-trivial cases
+ for those for @{text "V"} and @{text "P"} events.
+*}
+lemma acyclic_RAG:
+ shows "acyclic (RAG s)"
+using vt
+proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "acyclic (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de:
+ "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ from ih have ac: "acyclic (?A - ?B - ?C)" by (auto elim:acyclic_subset)
+ from step_back_step [OF vtt]
+ have "step s (V th cs)" .
+ thus ?thesis
+ proof(cases)
+ assume "holding s th cs"
+ hence th_in: "th \<in> set (wq s cs)" and
+ eq_hd: "th = hd (wq s cs)" unfolding s_holding_def wq_def by auto
+ then obtain rest where
+ eq_wq: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ show ?thesis
+ proof(cases "rest = []")
+ case False
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ from eq_wq False have eq_D: "?D = {(Cs cs, Th ?th')}"
+ by (unfold next_th_def, auto)
+ let ?E = "(?A - ?B - ?C)"
+ have "(Th ?th', Cs cs) \<notin> ?E\<^sup>*"
+ proof
+ assume "(Th ?th', Cs cs) \<in> ?E\<^sup>*"
+ hence " (Th ?th', Cs cs) \<in> ?E\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD [OF this]
+ obtain x where th'_e: "(Th ?th', x) \<in> ?E" by blast
+ hence th_d: "(Th ?th', x) \<in> ?A" by simp
+ from RAG_target_th [OF this]
+ obtain cs' where eq_x: "x = Cs cs'" by auto
+ with th_d have "(Th ?th', Cs cs') \<in> ?A" by simp
+ hence wt_th': "waiting s ?th' cs'"
+ unfolding s_RAG_def s_waiting_def cs_waiting_def wq_def by simp
+ hence "cs' = cs"
+ proof(rule vt_s.waiting_unique)
+ from eq_wq vt_s.wq_distinct[of cs]
+ show "waiting s ?th' cs"
+ apply (unfold s_waiting_def wq_def, auto)
+ proof -
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq_fun (schs s) cs = th # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show "hd (SOME q. distinct q \<and> set q = set rest) = th" by auto
+ next
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = hd (SOME q. distinct q \<and> set q = set rest) # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show False by auto
+ qed
+ qed
+ with th'_e eq_x have "(Th ?th', Cs cs) \<in> ?E" by simp
+ with False
+ show "False" by (auto simp: next_th_def eq_wq)
+ qed
+ with acyclic_insert[symmetric] and ac
+ and eq_de eq_D show ?thesis by auto
+ next
+ case True
+ with eq_wq
+ have eq_D: "?D = {}"
+ by (unfold next_th_def, auto)
+ with eq_de ac
+ show ?thesis by auto
+ qed
+ qed
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "acyclic ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ have "(Th th, Cs cs) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Th th, Cs cs) \<in> (RAG s)\<^sup>*"
+ hence "(Th th, Cs cs) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD2 [OF this]
+ obtain x where "(x, Cs cs) \<in> RAG s" by auto
+ with True show False by (auto simp:s_RAG_def cs_waiting_def)
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ next
+ case False
+ hence eq_r: "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ have "(Cs cs, Th th) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Cs cs, Th th) \<in> (RAG s)\<^sup>*"
+ hence "(Cs cs, Th th) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ moreover from step_back_step [OF vtt] have "step s (P th cs)" .
+ ultimately show False
+ proof -
+ show " \<lbrakk>(Cs cs, Th th) \<in> (RAG s)\<^sup>+; step s (P th cs)\<rbrakk> \<Longrightarrow> False"
+ by (ind_cases "step s (P th cs)", simp)
+ qed
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (Set thread prio)
+ with ih
+ thm RAG_set_unchanged
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "acyclic (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+qed
+
+
+lemma finite_RAG:
+ shows "finite (RAG s)"
+proof -
+ from vt show ?thesis
+ proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "finite (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de: "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}
+"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ moreover from ih have ac: "finite (?A - ?B - ?C)" by simp
+ moreover have "finite ?D"
+ proof -
+ have "?D = {} \<or> (\<exists> a. ?D = {a})"
+ by (unfold next_th_def, auto)
+ thus ?thesis
+ proof
+ assume h: "?D = {}"
+ show ?thesis by (unfold h, simp)
+ next
+ assume "\<exists> a. ?D = {a}"
+ thus ?thesis
+ by (metis finite.simps)
+ qed
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "finite ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ with True and ih show ?thesis by auto
+ next
+ case False
+ hence "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ with False and ih show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ next
+ case (Set thread prio)
+ with ih
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "finite (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+ qed
+qed
+
+text {* Several useful lemmas *}
+
+lemma wf_dep_converse:
+ shows "wf ((RAG s)^-1)"
+proof(rule finite_acyclic_wf_converse)
+ from finite_RAG
+ show "finite (RAG s)" .
+next
+ from acyclic_RAG
+ show "acyclic (RAG s)" .
+qed
+
+end
+
+lemma hd_np_in: "x \<in> set l \<Longrightarrow> hd l \<in> set l"
+ by (induct l, auto)
+
+lemma th_chasing: "(Th th, Cs cs) \<in> RAG (s::state) \<Longrightarrow> \<exists> th'. (Cs cs, Th th') \<in> RAG s"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+
+context valid_trace
+begin
+
+lemma wq_threads:
+ assumes h: "th \<in> set (wq s cs)"
+ shows "th \<in> threads s"
+proof -
+ from vt and h show ?thesis
+ proof(induct arbitrary: th cs)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s
+ using vt_cons(1) by (unfold_locales, auto)
+ assume ih: "\<And>th cs. th \<in> set (wq s cs) \<Longrightarrow> th \<in> threads s"
+ and stp: "step s e"
+ and vt: "vt s"
+ and h: "th \<in> set (wq (e # s) cs)"
+ show ?case
+ proof(cases e)
+ case (Create th' prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ next
+ case (Exit th')
+ with stp ih h show ?thesis
+ apply (auto simp:wq_def Let_def)
+ apply (ind_cases "step s (Exit th')")
+ apply (auto simp:runing_def readys_def s_holding_def s_waiting_def holdents_def
+ s_RAG_def s_holding_def cs_holding_def)
+ done
+ next
+ case (V th' cs')
+ show ?thesis
+ proof(cases "cs' = cs")
+ case False
+ with h
+ show ?thesis
+ apply(unfold wq_def V, auto simp:Let_def V split:prod.splits, fold wq_def)
+ by (drule_tac ih, simp)
+ next
+ case True
+ from h
+ show ?thesis
+ proof(unfold V wq_def)
+ assume th_in: "th \<in> set (wq_fun (schs (V th' cs' # s)) cs)" (is "th \<in> set ?l")
+ show "th \<in> threads (V th' cs' # s)"
+ proof(cases "cs = cs'")
+ case False
+ hence "?l = wq_fun (schs s) cs" by (simp add:Let_def)
+ with th_in have " th \<in> set (wq s cs)"
+ by (fold wq_def, simp)
+ from ih [OF this] show ?thesis by simp
+ next
+ case True
+ show ?thesis
+ proof(cases "wq_fun (schs s) cs'")
+ case Nil
+ with h V show ?thesis
+ apply (auto simp:wq_def Let_def split:if_splits)
+ by (fold wq_def, drule_tac ih, simp)
+ next
+ case (Cons a rest)
+ assume eq_wq: "wq_fun (schs s) cs' = a # rest"
+ with h V show ?thesis
+ apply (auto simp:Let_def wq_def split:if_splits)
+ proof -
+ assume th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs'] and eq_wq[folded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ with eq_wq th_in have "th \<in> set (wq_fun (schs s) cs')" by auto
+ from ih[OF this[folded wq_def]] show "th \<in> threads s" .
+ next
+ assume th_in: "th \<in> set (wq_fun (schs s) cs)"
+ from ih[OF this[folded wq_def]]
+ show "th \<in> threads s" .
+ qed
+ qed
+ qed
+ qed
+ qed
+ next
+ case (P th' cs')
+ from h stp
+ show ?thesis
+ apply (unfold P wq_def)
+ apply (auto simp:Let_def split:if_splits, fold wq_def)
+ apply (auto intro:ih)
+ apply(ind_cases "step s (P th' cs')")
+ by (unfold runing_def readys_def, auto)
+ next
+ case (Set thread prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ qed
+ next
+ case vt_nil
+ thus ?case by (auto simp:wq_def)
+ qed
+qed
+
+lemma range_in: "\<lbrakk>(Th th) \<in> Range (RAG (s::state))\<rbrakk> \<Longrightarrow> th \<in> threads s"
+ apply(unfold s_RAG_def cs_waiting_def cs_holding_def)
+ by (auto intro:wq_threads)
+
+lemma readys_v_eq:
+ fixes th thread cs rest
+ assumes neq_th: "th \<noteq> thread"
+ and eq_wq: "wq s cs = thread#rest"
+ and not_in: "th \<notin> set rest"
+ shows "(th \<in> readys (V thread cs#s)) = (th \<in> readys s)"
+proof -
+ from assms show ?thesis
+ apply (auto simp:readys_def)
+ apply(simp add:s_waiting_def[folded wq_def])
+ apply (erule_tac x = csa in allE)
+ apply (simp add:s_waiting_def wq_def Let_def split:if_splits)
+ apply (case_tac "csa = cs", simp)
+ apply (erule_tac x = cs in allE)
+ apply(auto simp add: s_waiting_def[folded wq_def] Let_def split: list.splits)
+ apply(auto simp add: wq_def)
+ apply (auto simp:s_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ assume th_nin: "th \<notin> set rest"
+ and th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ and eq_wq: "wq_fun (schs s) cs = thread # rest"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from wq_distinct[of cs, unfolded wq_def] and eq_wq[unfolded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ with th_nin th_in show False by auto
+ qed
+qed
+
+text {* \noindent
+ The following lemmas shows that: starting from any node in @{text "RAG"},
+ by chasing out-going edges, it is always possible to reach a node representing a ready
+ thread. In this lemma, it is the @{text "th'"}.
+*}
+
+lemma chain_building:
+ shows "node \<in> Domain (RAG s) \<longrightarrow> (\<exists> th'. th' \<in> readys s \<and> (node, Th th') \<in> (RAG s)^+)"
+proof -
+ from wf_dep_converse
+ have h: "wf ((RAG s)\<inverse>)" .
+ show ?thesis
+ proof(induct rule:wf_induct [OF h])
+ fix x
+ assume ih [rule_format]:
+ "\<forall>y. (y, x) \<in> (RAG s)\<inverse> \<longrightarrow>
+ y \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (y, Th th') \<in> (RAG s)\<^sup>+)"
+ show "x \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+)"
+ proof
+ assume x_d: "x \<in> Domain (RAG s)"
+ show "\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+"
+ proof(cases x)
+ case (Th th)
+ from x_d Th obtain cs where x_in: "(Th th, Cs cs) \<in> RAG s" by (auto simp:s_RAG_def)
+ with Th have x_in_r: "(Cs cs, x) \<in> (RAG s)^-1" by simp
+ from th_chasing [OF x_in] obtain th' where "(Cs cs, Th th') \<in> RAG s" by blast
+ hence "Cs cs \<in> Domain (RAG s)" by auto
+ from ih [OF x_in_r this] obtain th'
+ where th'_ready: " th' \<in> readys s" and cs_in: "(Cs cs, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "(x, Th th') \<in> (RAG s)\<^sup>+" using Th x_in cs_in by auto
+ with th'_ready show ?thesis by auto
+ next
+ case (Cs cs)
+ from x_d Cs obtain th' where th'_d: "(Th th', x) \<in> (RAG s)^-1" by (auto simp:s_RAG_def)
+ show ?thesis
+ proof(cases "th' \<in> readys s")
+ case True
+ from True and th'_d show ?thesis by auto
+ next
+ case False
+ from th'_d and range_in have "th' \<in> threads s" by auto
+ with False have "Th th' \<in> Domain (RAG s)"
+ by (auto simp:readys_def wq_def s_waiting_def s_RAG_def cs_waiting_def Domain_def)
+ from ih [OF th'_d this]
+ obtain th'' where
+ th''_r: "th'' \<in> readys s" and
+ th''_in: "(Th th', Th th'') \<in> (RAG s)\<^sup>+" by auto
+ from th'_d and th''_in
+ have "(x, Th th'') \<in> (RAG s)\<^sup>+" by auto
+ with th''_r show ?thesis by auto
+ qed
+ qed
+ qed
+ qed
+qed
+
+text {* \noindent
+ The following is just an instance of @{text "chain_building"}.
+*}
+lemma th_chain_to_ready:
+ assumes th_in: "th \<in> threads s"
+ shows "th \<in> readys s \<or> (\<exists> th'. th' \<in> readys s \<and> (Th th, Th th') \<in> (RAG s)^+)"
+proof(cases "th \<in> readys s")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ from False and th_in have "Th th \<in> Domain (RAG s)"
+ by (auto simp:readys_def s_waiting_def s_RAG_def wq_def cs_waiting_def Domain_def)
+ from chain_building [rule_format, OF this]
+ show ?thesis by auto
+qed
+
+end
+
+lemma waiting_eq: "waiting s th cs = waiting (wq s) th cs"
+ by (unfold s_waiting_def cs_waiting_def wq_def, auto)
+
+lemma holding_eq: "holding (s::state) th cs = holding (wq s) th cs"
+ by (unfold s_holding_def wq_def cs_holding_def, simp)
+
+lemma holding_unique: "\<lbrakk>holding (s::state) th1 cs; holding s th2 cs\<rbrakk> \<Longrightarrow> th1 = th2"
+ by (unfold s_holding_def cs_holding_def, auto)
+
+context valid_trace
+begin
+
+lemma unique_RAG: "\<lbrakk>(n, n1) \<in> RAG s; (n, n2) \<in> RAG s\<rbrakk> \<Longrightarrow> n1 = n2"
+ apply(unfold s_RAG_def, auto, fold waiting_eq holding_eq)
+ by(auto elim:waiting_unique holding_unique)
+
+end
+
+
+lemma trancl_split: "(a, b) \<in> r^+ \<Longrightarrow> \<exists> c. (a, c) \<in> r"
+by (induct rule:trancl_induct, auto)
+
+context valid_trace
+begin
+
+lemma dchain_unique:
+ assumes th1_d: "(n, Th th1) \<in> (RAG s)^+"
+ and th1_r: "th1 \<in> readys s"
+ and th2_d: "(n, Th th2) \<in> (RAG s)^+"
+ and th2_r: "th2 \<in> readys s"
+ shows "th1 = th2"
+proof -
+ { assume neq: "th1 \<noteq> th2"
+ hence "Th th1 \<noteq> Th th2" by simp
+ from unique_chain [OF _ th1_d th2_d this] and unique_RAG
+ have "(Th th1, Th th2) \<in> (RAG s)\<^sup>+ \<or> (Th th2, Th th1) \<in> (RAG s)\<^sup>+" by auto
+ hence "False"
+ proof
+ assume "(Th th1, Th th2) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th1, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th1 \<notin> readys s"
+ by (auto simp:readys_def s_RAG_def wq_def s_waiting_def cs_waiting_def)
+ with th1_r show ?thesis by auto
+ next
+ assume "(Th th2, Th th1) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th2, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th2 \<notin> readys s"
+ by (auto simp:readys_def wq_def s_RAG_def s_waiting_def cs_waiting_def)
+ with th2_r show ?thesis by auto
+ qed
+ } thus ?thesis by auto
+qed
+
+end
+
+
+lemma step_holdents_p_add:
+ fixes th cs s
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs = []"
+ shows "holdents (P th cs#s) th = holdents s th \<union> {cs}"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by (auto)
+qed
+
+lemma step_holdents_p_eq:
+ fixes th cs s
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs \<noteq> []"
+ shows "holdents (P th cs#s) th = holdents s th"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by auto
+qed
+
+
+lemma (in valid_trace) finite_holding :
+ shows "finite (holdents s th)"
+proof -
+ let ?F = "\<lambda> (x, y). the_cs x"
+ from finite_RAG
+ have "finite (RAG s)" .
+ hence "finite (?F `(RAG s))" by simp
+ moreover have "{cs . (Cs cs, Th th) \<in> RAG s} \<subseteq> \<dots>"
+ proof -
+ { have h: "\<And> a A f. a \<in> A \<Longrightarrow> f a \<in> f ` A" by auto
+ fix x assume "(Cs x, Th th) \<in> RAG s"
+ hence "?F (Cs x, Th th) \<in> ?F `(RAG s)" by (rule h)
+ moreover have "?F (Cs x, Th th) = x" by simp
+ ultimately have "x \<in> (\<lambda>(x, y). the_cs x) ` RAG s" by simp
+ } thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (unfold holdents_test, auto intro:finite_subset)
+qed
+
+lemma cntCS_v_dec:
+ fixes s thread cs
+ assumes vtv: "vt (V thread cs#s)"
+ shows "(cntCS (V thread cs#s) thread + 1) = cntCS s thread"
+proof -
+ from vtv interpret vt_s: valid_trace s
+ by (cases, unfold_locales, simp)
+ from vtv interpret vt_v: valid_trace "V thread cs#s"
+ by (unfold_locales, simp)
+ from step_back_step[OF vtv]
+ have cs_in: "cs \<in> holdents s thread"
+ apply (cases, unfold holdents_test s_RAG_def, simp)
+ by (unfold cs_holding_def s_holding_def wq_def, auto)
+ moreover have cs_not_in:
+ "(holdents (V thread cs#s) thread) = holdents s thread - {cs}"
+ apply (insert vt_s.wq_distinct[of cs])
+ apply (unfold holdents_test, unfold step_RAG_v[OF vtv],
+ auto simp:next_th_def)
+ proof -
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately
+ show "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ next
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately show "False" by auto
+ qed
+ ultimately
+ have "holdents s thread = insert cs (holdents (V thread cs#s) thread)"
+ by auto
+ moreover have "card \<dots> =
+ Suc (card ((holdents (V thread cs#s) thread) - {cs}))"
+ proof(rule card_insert)
+ from vt_v.finite_holding
+ show " finite (holdents (V thread cs # s) thread)" .
+ qed
+ moreover from cs_not_in
+ have "cs \<notin> (holdents (V thread cs#s) thread)" by auto
+ ultimately show ?thesis by (simp add:cntCS_def)
+qed
+
+lemma count_rec1 [simp]:
+ assumes "Q e"
+ shows "count Q (e#es) = Suc (count Q es)"
+ using assms
+ by (unfold count_def, auto)
+
+lemma count_rec2 [simp]:
+ assumes "\<not>Q e"
+ shows "count Q (e#es) = (count Q es)"
+ using assms
+ by (unfold count_def, auto)
+
+lemma count_rec3 [simp]:
+ shows "count Q [] = 0"
+ by (unfold count_def, auto)
+
+lemma cntP_diff_inv:
+ assumes "cntP (e#s) th \<noteq> cntP s th"
+ shows "isP e \<and> actor e = th"
+proof(cases e)
+ case (P th' pty)
+ show ?thesis
+ by (cases "(\<lambda>e. \<exists>cs. e = P th cs) (P th' pty)",
+ insert assms P, auto simp:cntP_def)
+qed (insert assms, auto simp:cntP_def)
+
+lemma isP_E:
+ assumes "isP e"
+ obtains cs where "e = P (actor e) cs"
+ using assms by (cases e, auto)
+
+lemma isV_E:
+ assumes "isV e"
+ obtains cs where "e = V (actor e) cs"
+ using assms by (cases e, auto) (* ccc *)
+
+lemma cntV_diff_inv:
+ assumes "cntV (e#s) th \<noteq> cntV s th"
+ shows "isV e \<and> actor e = th"
+proof(cases e)
+ case (V th' pty)
+ show ?thesis
+ by (cases "(\<lambda>e. \<exists>cs. e = V th cs) (V th' pty)",
+ insert assms V, auto simp:cntV_def)
+qed (insert assms, auto simp:cntV_def)
+
+context valid_trace
+begin
+
+text {* (* ddd *) \noindent
+ The relationship between @{text "cntP"}, @{text "cntV"} and @{text "cntCS"}
+ of one particular thread.
+*}
+
+lemma cnp_cnv_cncs:
+ shows "cntP s th = cntV s th + (if (th \<in> readys s \<or> th \<notin> threads s)
+ then cntCS s th else cntCS s th + 1)"
+proof -
+ from vt show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1) by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. cntP s th = cntV s th +
+ (if (th \<in> readys s \<or> th \<notin> threads s) then cntCS s th else cntCS s th + 1)"
+ and stp: "step s e"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in: "thread \<notin> threads s"
+ show ?thesis
+ proof -
+ { fix cs
+ assume "thread \<in> set (wq s cs)"
+ from vt_s.wq_threads [OF this] have "thread \<in> threads s" .
+ with not_in have "False" by simp
+ } with eq_e have eq_readys: "readys (e#s) = readys s \<union> {thread}"
+ by (auto simp:readys_def threads.simps s_waiting_def
+ wq_def cs_waiting_def Let_def)
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_create_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih not_in
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with not_in ih have " cntP s th = cntV s th + cntCS s th" by simp
+ moreover from eq_th and eq_readys have "th \<in> readys (e#s)" by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and is_runing: "thread \<in> runing s"
+ and no_hold: "holdents s thread = {}"
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_exit_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ apply (simp add:threads.simps readys_def)
+ apply (subst s_waiting_def)
+ apply (simp add:Let_def)
+ apply (subst s_waiting_def, simp)
+ done
+ with eq_cnp eq_cnv eq_cncs ih
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with ih is_runing have " cntP s th = cntV s th + cntCS s th"
+ by (simp add:runing_def)
+ moreover from eq_th eq_e have "th \<notin> threads (e#s)"
+ by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ and no_dep: "(Cs cs, Th thread) \<notin> (RAG s)\<^sup>+"
+ from thread_P vt stp ih have vtp: "vt (P thread cs#s)" by auto
+ then interpret vt_p: valid_trace "(P thread cs#s)"
+ by (unfold_locales, simp)
+ show ?thesis
+ proof -
+ { have hh: "\<And> A B C. (B = C) \<Longrightarrow> (A \<and> B) = (A \<and> C)" by blast
+ assume neq_th: "th \<noteq> thread"
+ with eq_e
+ have eq_readys: "(th \<in> readys (e#s)) = (th \<in> readys (s))"
+ apply (simp add:readys_def s_waiting_def wq_def Let_def)
+ apply (rule_tac hh)
+ apply (intro iffI allI, clarify)
+ apply (erule_tac x = csa in allE, auto)
+ apply (subgoal_tac "wq_fun (schs s) cs \<noteq> []", auto)
+ apply (erule_tac x = cs in allE, auto)
+ by (case_tac "(wq_fun (schs s) cs)", auto)
+ moreover from neq_th eq_e have "cntCS (e # s) th = cntCS s th"
+ apply (simp add:cntCS_def holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto)
+ moreover from eq_e neq_th have "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ moreover from eq_e neq_th have "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ moreover from eq_e neq_th have "threads (e#s) = threads s" by simp
+ moreover note ih [of th]
+ ultimately have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ have ?thesis
+ proof -
+ from eq_e eq_th have eq_cnp: "cntP (e # s) th = 1 + (cntP s th)"
+ by (simp add:cntP_def count_def)
+ from eq_e eq_th have eq_cnv: "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ show ?thesis
+ proof (cases "wq s cs = []")
+ case True
+ with is_runing
+ have "th \<in> readys (e#s)"
+ apply (unfold eq_e wq_def, unfold readys_def s_RAG_def)
+ apply (simp add: wq_def[symmetric] runing_def eq_th s_waiting_def)
+ by (auto simp:readys_def wq_def Let_def s_waiting_def wq_def)
+ moreover have "cntCS (e # s) th = 1 + cntCS s th"
+ proof -
+ have "card {csa. csa = cs \<or> (Cs csa, Th thread) \<in> RAG s} =
+ Suc (card {cs. (Cs cs, Th thread) \<in> RAG s})" (is "card ?L = Suc (card ?R)")
+ proof -
+ have "?L = insert cs ?R" by auto
+ moreover have "card \<dots> = Suc (card (?R - {cs}))"
+ proof(rule card_insert)
+ from vt_s.finite_holding [of thread]
+ show " finite {cs. (Cs cs, Th thread) \<in> RAG s}"
+ by (unfold holdents_test, simp)
+ qed
+ moreover have "?R - {cs} = ?R"
+ proof -
+ have "cs \<notin> ?R"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th thread) \<in> RAG s}"
+ with no_dep show False by auto
+ qed
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ thus ?thesis
+ apply (unfold eq_e eq_th cntCS_def)
+ apply (simp add: holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto simp:True)
+ qed
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ moreover note eq_cnp eq_cnv ih [of th]
+ ultimately show ?thesis by auto
+ next
+ case False
+ have eq_wq: "wq (e#s) cs = wq s cs @ [th]"
+ by (unfold eq_th eq_e wq_def, auto simp:Let_def)
+ have "th \<notin> readys (e#s)"
+ proof
+ assume "th \<in> readys (e#s)"
+ hence "\<forall>cs. \<not> waiting (e # s) th cs" by (simp add:readys_def)
+ from this[rule_format, of cs] have " \<not> waiting (e # s) th cs" .
+ hence "th \<in> set (wq (e#s) cs) \<Longrightarrow> th = hd (wq (e#s) cs)"
+ by (simp add:s_waiting_def wq_def)
+ moreover from eq_wq have "th \<in> set (wq (e#s) cs)" by auto
+ ultimately have "th = hd (wq (e#s) cs)" by blast
+ with eq_wq have "th = hd (wq s cs @ [th])" by simp
+ hence "th = hd (wq s cs)" using False by auto
+ with False eq_wq vt_p.wq_distinct [of cs]
+ show False by (fold eq_e, auto)
+ qed
+ moreover from is_runing have "th \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def eq_th)
+ moreover have "cntCS (e # s) th = cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_p[OF vtp])
+ by (auto simp:False)
+ moreover note eq_cnp eq_cnv ih[of th]
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ ultimately show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_V thread cs)
+ from assms vt stp ih thread_V have vtv: "vt (V thread cs # s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs # s)" by (unfold_locales, simp)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ have eq_threads: "threads (e#s) = threads s" by (simp add: eq_e)
+ have eq_set: "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ show ?thesis
+ proof -
+ { assume eq_th: "th = thread"
+ from eq_th have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (unfold eq_e, simp add:cntP_def count_def)
+ moreover from eq_th have eq_cnv: "cntV (e#s) th = 1 + cntV s th"
+ by (unfold eq_e, simp add:cntV_def count_def)
+ moreover from cntCS_v_dec [OF vtv]
+ have "cntCS (e # s) thread + 1 = cntCS s thread"
+ by (simp add:eq_e)
+ moreover from is_runing have rd_before: "thread \<in> readys s"
+ by (unfold runing_def, simp)
+ moreover have "thread \<in> readys (e # s)"
+ proof -
+ from is_runing
+ have "thread \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def)
+ moreover have "\<forall> cs1. \<not> waiting (e#s) thread cs1"
+ proof
+ fix cs1
+ { assume eq_cs: "cs1 = cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from eq_wq
+ have "thread \<notin> set (wq (e#s) cs1)"
+ apply(unfold eq_e wq_def eq_cs s_holding_def)
+ apply (auto simp:Let_def)
+ proof -
+ assume "thread \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ with eq_set have "thread \<in> set rest" by simp
+ with vt_v.wq_distinct[of cs]
+ and eq_wq show False
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ qed
+ thus ?thesis by (simp add:wq_def s_waiting_def)
+ qed
+ } moreover {
+ assume neq_cs: "cs1 \<noteq> cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from wq_v_neq [OF neq_cs[symmetric]]
+ have "wq (V thread cs # s) cs1 = wq s cs1" .
+ moreover have "\<not> waiting s thread cs1"
+ proof -
+ from runing_ready and is_runing
+ have "thread \<in> readys s" by auto
+ thus ?thesis by (simp add:readys_def)
+ qed
+ ultimately show ?thesis
+ by (auto simp:wq_def s_waiting_def eq_e)
+ qed
+ } ultimately show "\<not> waiting (e # s) thread cs1" by blast
+ qed
+ ultimately show ?thesis by (simp add:readys_def)
+ qed
+ moreover note eq_th ih
+ ultimately have ?thesis by auto
+ } moreover {
+ assume neq_th: "th \<noteq> thread"
+ from neq_th eq_e have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ from neq_th eq_e have eq_cnv: "cntV (e # s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ have ?thesis
+ proof(cases "th \<in> set rest")
+ case False
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ apply (insert step_back_vt[OF vtv])
+ by (simp add: False eq_e eq_wq neq_th vt_s.readys_v_eq)
+ moreover have "cntCS (e#s) th = cntCS s th"
+ apply (insert neq_th, unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ proof -
+ have "{csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from False eq_wq
+ have " next_th s thread cs th \<Longrightarrow> (Cs cs, Th th) \<in> RAG s"
+ apply (unfold next_th_def, auto)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = thread # rest"
+ from eq_set ni have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)
+ " by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[ of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with ne show "x \<noteq> []" by auto
+ qed
+ ultimately show
+ "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ qed
+ thus ?thesis by auto
+ qed
+ thus "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ card {cs. (Cs cs, Th th) \<in> RAG s}" by simp
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ assume th_in: "th \<in> set rest"
+ show ?thesis
+ proof(cases "next_th s thread cs th")
+ case False
+ with eq_wq and th_in have
+ neq_hd: "th \<noteq> hd (SOME q. distinct q \<and> set q = set rest)" (is "th \<noteq> hd ?rest")
+ by (auto simp:next_th_def)
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ proof -
+ from eq_wq and th_in
+ have "\<not> th \<in> readys s"
+ apply (auto simp:readys_def s_waiting_def)
+ apply (rule_tac x = cs in exI, auto)
+ by (insert vt_s.wq_distinct[of cs], auto simp add: wq_def)
+ moreover
+ from eq_wq and th_in and neq_hd
+ have "\<not> (th \<in> readys (e # s))"
+ apply (auto simp:readys_def s_waiting_def eq_e wq_def Let_def split:list.splits)
+ by (rule_tac x = cs in exI, auto simp:eq_set)
+ ultimately show ?thesis by auto
+ qed
+ moreover have "cntCS (e#s) th = cntCS s th"
+ proof -
+ from eq_wq and th_in and neq_hd
+ have "(holdents (e # s) th) = (holdents s th)"
+ apply (unfold eq_e step_RAG_v[OF vtv],
+ auto simp:next_th_def eq_set s_RAG_def holdents_test wq_def
+ Let_def cs_holding_def)
+ by (insert vt_s.wq_distinct[of cs], auto simp:wq_def)
+ thus ?thesis by (simp add:cntCS_def)
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ let ?rest = " (SOME q. distinct q \<and> set q = set rest)"
+ let ?t = "hd ?rest"
+ from True eq_wq th_in neq_th
+ have "th \<in> readys (e # s)"
+ apply (auto simp:eq_e readys_def s_waiting_def wq_def
+ Let_def next_th_def)
+ proof -
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ show "?t \<in> threads s"
+ proof(rule vt_s.wq_threads)
+ from eq_wq and t_in
+ show "?t \<in> set (wq s cs)" by (auto simp:wq_def)
+ qed
+ next
+ fix csa
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ and neq_cs: "csa \<noteq> cs"
+ and t_in': "?t \<in> set (wq_fun (schs s) csa)"
+ show "?t = hd (wq_fun (schs s) csa)"
+ proof -
+ { assume neq_hd': "?t \<noteq> hd (wq_fun (schs s) csa)"
+ from vt_s.wq_distinct[of cs] and
+ eq_wq[folded wq_def] and t_in eq_wq
+ have "?t \<noteq> thread" by auto
+ with eq_wq and t_in
+ have w1: "waiting s ?t cs"
+ by (auto simp:s_waiting_def wq_def)
+ from t_in' neq_hd'
+ have w2: "waiting s ?t csa"
+ by (auto simp:s_waiting_def wq_def)
+ from vt_s.waiting_unique[OF w1 w2]
+ and neq_cs have "False" by auto
+ } thus ?thesis by auto
+ qed
+ qed
+ moreover have "cntP s th = cntV s th + cntCS s th + 1"
+ proof -
+ have "th \<notin> readys s"
+ proof -
+ from True eq_wq neq_th th_in
+ show ?thesis
+ apply (unfold readys_def s_waiting_def, auto)
+ by (rule_tac x = cs in exI, auto simp add: wq_def)
+ qed
+ moreover have "th \<in> threads s"
+ proof -
+ from th_in eq_wq
+ have "th \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads [OF this]
+ show ?thesis .
+ qed
+ ultimately show ?thesis using ih by auto
+ qed
+ moreover from True neq_th have "cntCS (e # s) th = 1 + cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_v[OF vtv], auto)
+ proof -
+ show "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs} =
+ Suc (card {cs. (Cs cs, Th th) \<in> RAG s})"
+ (is "card ?A = Suc (card ?B)")
+ proof -
+ have "?A = insert cs ?B" by auto
+ hence "card ?A = card (insert cs ?B)" by simp
+ also have "\<dots> = Suc (card ?B)"
+ proof(rule card_insert_disjoint)
+ have "?B \<subseteq> ((\<lambda> (x, y). the_cs x) ` RAG s)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Cs x, Th th)" in bexI, auto)
+ with vt_s.finite_RAG
+ show "finite {cs. (Cs cs, Th th) \<in> RAG s}" by (auto intro:finite_subset)
+ next
+ show "cs \<notin> {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th th) \<in> RAG s}"
+ hence "(Cs cs, Th th) \<in> RAG s" by simp
+ with True neq_th eq_wq show False
+ by (auto simp:next_th_def s_RAG_def cs_holding_def)
+ qed
+ qed
+ finally show ?thesis .
+ qed
+ qed
+ moreover note eq_cnp eq_cnv
+ ultimately show ?thesis by simp
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_set thread prio)
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ show ?thesis
+ proof -
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_set_unchanged eq_e)
+ from eq_e have eq_readys: "readys (e#s) = readys s"
+ by (simp add:readys_def cs_waiting_def s_waiting_def wq_def,
+ auto simp:Let_def)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih is_runing
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with is_runing ih have " cntP s th = cntV s th + cntCS s th"
+ by (unfold runing_def, auto)
+ moreover from eq_th and eq_readys is_runing have "th \<in> readys (e#s)"
+ by (simp add:runing_def)
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntP_def cntV_def cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+lemma not_thread_cncs:
+ assumes not_in: "th \<notin> threads s"
+ shows "cntCS s th = 0"
+proof -
+ from vt not_in show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e th)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. th \<notin> threads s \<Longrightarrow> cntCS s th = 0"
+ and stp: "step s e"
+ and not_in: "th \<notin> threads (e # s)"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in': "thread \<notin> threads s"
+ have "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_create_unchanged)
+ moreover have "th \<notin> threads s"
+ proof -
+ from not_in eq_e show ?thesis by simp
+ qed
+ moreover note ih ultimately show ?thesis by auto
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and nh: "holdents s thread = {}"
+ have eq_cns: "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_exit_unchanged)
+ show ?thesis
+ proof(cases "th = thread")
+ case True
+ have "cntCS s th = 0" by (unfold cntCS_def, auto simp:nh True)
+ with eq_cns show ?thesis by simp
+ next
+ case False
+ with not_in and eq_e
+ have "th \<notin> threads s" by simp
+ from ih[OF this] and eq_cns show ?thesis by simp
+ qed
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ from assms thread_P ih vt stp thread_P have vtp: "vt (P thread cs#s)" by auto
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ hence "cntCS (e # s) th = cntCS s th "
+ apply (unfold cntCS_def holdents_test eq_e)
+ by (unfold step_RAG_p[OF vtp], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_V thread cs)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ from assms thread_V vt stp ih
+ have vtv: "vt (V thread cs#s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs#s)"
+ by (unfold_locales, simp)
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ from not_in eq_e eq_wq
+ have "\<not> next_th s thread cs th"
+ apply (auto simp:next_th_def)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> threads s" (is "?t \<notin> threads s")
+ have "?t \<in> set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ fix x assume "distinct x \<and> set x = set rest" with ne
+ show "hd x \<in> set rest" by (cases x, auto)
+ qed
+ with eq_wq have "?t \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads[OF this] and ni
+ show False
+ using `hd (SOME q. distinct q \<and> set q = set rest) \<in> set (wq s cs)`
+ ni vt_s.wq_threads by blast
+ qed
+ moreover note neq_th eq_wq
+ ultimately have "cntCS (e # s) th = cntCS s th"
+ by (unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_set thread prio)
+ print_facts
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ from not_in and eq_e have "th \<notin> threads s" by auto
+ from ih [OF this] and eq_e
+ show ?thesis
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+end
+
+lemma eq_waiting: "waiting (wq (s::state)) th cs = waiting s th cs"
+ by (auto simp:s_waiting_def cs_waiting_def wq_def)
+
+context valid_trace
+begin
+
+lemma dm_RAG_threads:
+ assumes in_dom: "(Th th) \<in> Domain (RAG s)"
+ shows "th \<in> threads s"
+proof -
+ from in_dom obtain n where "(Th th, n) \<in> RAG s" by auto
+ moreover from RAG_target_th[OF this] obtain cs where "n = Cs cs" by auto
+ ultimately have "(Th th, Cs cs) \<in> RAG s" by simp
+ hence "th \<in> set (wq s cs)"
+ by (unfold s_RAG_def, auto simp:cs_waiting_def)
+ from wq_threads [OF this] show ?thesis .
+qed
+
+end
+
+lemma cp_eq_cpreced: "cp s th = cpreced (wq s) s th"
+unfolding cp_def wq_def
+apply(induct s rule: schs.induct)
+thm cpreced_initial
+apply(simp add: Let_def cpreced_initial)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+done
+
+context valid_trace
+begin
+
+lemma runing_unique:
+ assumes runing_1: "th1 \<in> runing s"
+ and runing_2: "th2 \<in> runing s"
+ shows "th1 = th2"
+proof -
+ from runing_1 and runing_2 have "cp s th1 = cp s th2"
+ unfolding runing_def
+ apply(simp)
+ done
+ hence eq_max: "Max ((\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)) =
+ Max ((\<lambda>th. preced th s) ` ({th2} \<union> dependants (wq s) th2))"
+ (is "Max (?f ` ?A) = Max (?f ` ?B)")
+ unfolding cp_eq_cpreced
+ unfolding cpreced_def .
+ obtain th1' where th1_in: "th1' \<in> ?A" and eq_f_th1: "?f th1' = Max (?f ` ?A)"
+ proof -
+ have h1: "finite (?f ` ?A)"
+ proof -
+ have "finite ?A"
+ proof -
+ have "finite (dependants (wq s) th1)"
+ proof-
+ have "finite {th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th1)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?A) \<noteq> {}"
+ proof -
+ have "?A \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?A) \<in> (?f ` ?A)" .
+ thus ?thesis
+ thm cpreced_def
+ unfolding cpreced_def[symmetric]
+ unfolding cp_eq_cpreced[symmetric]
+ unfolding cpreced_def
+ using that[intro] by (auto)
+ qed
+ obtain th2' where th2_in: "th2' \<in> ?B" and eq_f_th2: "?f th2' = Max (?f ` ?B)"
+ proof -
+ have h1: "finite (?f ` ?B)"
+ proof -
+ have "finite ?B"
+ proof -
+ have "finite (dependants (wq s) th2)"
+ proof-
+ have "finite {th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th2)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?B) \<noteq> {}"
+ proof -
+ have "?B \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?B) \<in> (?f ` ?B)" .
+ thus ?thesis by (auto intro:that)
+ qed
+ from eq_f_th1 eq_f_th2 eq_max
+ have eq_preced: "preced th1' s = preced th2' s" by auto
+ hence eq_th12: "th1' = th2'"
+ proof (rule preced_unique)
+ from th1_in have "th1' = th1 \<or> (th1' \<in> dependants (wq s) th1)" by simp
+ thus "th1' \<in> threads s"
+ proof
+ assume "th1' \<in> dependants (wq s) th1"
+ hence "(Th th1') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th1') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th1' = th1"
+ with runing_1 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ next
+ from th2_in have "th2' = th2 \<or> (th2' \<in> dependants (wq s) th2)" by simp
+ thus "th2' \<in> threads s"
+ proof
+ assume "th2' \<in> dependants (wq s) th2"
+ hence "(Th th2') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th2') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th2' = th2"
+ with runing_2 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ qed
+ from th1_in have "th1' = th1 \<or> th1' \<in> dependants (wq s) th1" by simp
+ thus ?thesis
+ proof
+ assume eq_th': "th1' = th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2" thus ?thesis using eq_th' eq_th12 by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 eq_th' have "th1 \<in> dependants (wq s) th2" by simp
+ hence "(Th th1, Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th1 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th1 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th1, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th1, Cs cs') \<in> RAG s" by simp
+ with runing_1 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ qed
+ next
+ assume th1'_in: "th1' \<in> dependants (wq s) th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2"
+ with th1'_in eq_th12 have "th2 \<in> dependants (wq s) th1" by simp
+ hence "(Th th2, Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th2 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th2 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th2, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th2, Cs cs') \<in> RAG s" by simp
+ with runing_2 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 have "th1' \<in> dependants (wq s) th2" by simp
+ hence h1: "(Th th1', Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ from th1'_in have h2: "(Th th1', Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ show ?thesis
+ proof(rule dchain_unique[OF h1 _ h2, symmetric])
+ from runing_1 show "th1 \<in> readys s" by (simp add:runing_def)
+ from runing_2 show "th2 \<in> readys s" by (simp add:runing_def)
+ qed
+ qed
+ qed
+qed
+
+
+lemma "card (runing s) \<le> 1"
+apply(subgoal_tac "finite (runing s)")
+prefer 2
+apply (metis finite_nat_set_iff_bounded lessI runing_unique)
+apply(rule ccontr)
+apply(simp)
+apply(case_tac "Suc (Suc 0) \<le> card (runing s)")
+apply(subst (asm) card_le_Suc_iff)
+apply(simp)
+apply(auto)[1]
+apply (metis insertCI runing_unique)
+apply(auto)
+done
+
+end
+
+
+lemma create_pre:
+ assumes stp: "step s e"
+ and not_in: "th \<notin> threads s"
+ and is_in: "th \<in> threads (e#s)"
+ obtains prio where "e = Create th prio"
+proof -
+ from assms
+ show ?thesis
+ proof(cases)
+ case (thread_create thread prio)
+ with is_in not_in have "e = Create th prio" by simp
+ from that[OF this] show ?thesis .
+ next
+ case (thread_exit thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_P thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_V thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_set thread)
+ with assms show ?thesis by (auto intro!:that)
+ qed
+qed
+
+lemma length_down_to_in:
+ assumes le_ij: "i \<le> j"
+ and le_js: "j \<le> length s"
+ shows "length (down_to j i s) = j - i"
+proof -
+ have "length (down_to j i s) = length (from_to i j (rev s))"
+ by (unfold down_to_def, auto)
+ also have "\<dots> = j - i"
+ proof(rule length_from_to_in[OF le_ij])
+ from le_js show "j \<le> length (rev s)" by simp
+ qed
+ finally show ?thesis .
+qed
+
+
+lemma moment_head:
+ assumes le_it: "Suc i \<le> length t"
+ obtains e where "moment (Suc i) t = e#moment i t"
+proof -
+ have "i \<le> Suc i" by simp
+ from length_down_to_in [OF this le_it]
+ have "length (down_to (Suc i) i t) = 1" by auto
+ then obtain e where "down_to (Suc i) i t = [e]"
+ apply (cases "(down_to (Suc i) i t)") by auto
+ moreover have "down_to (Suc i) 0 t = down_to (Suc i) i t @ down_to i 0 t"
+ by (rule down_to_conc[symmetric], auto)
+ ultimately have eq_me: "moment (Suc i) t = e#(moment i t)"
+ by (auto simp:down_to_moment)
+ from that [OF this] show ?thesis .
+qed
+
+context valid_trace
+begin
+
+lemma cnp_cnv_eq:
+ assumes "th \<notin> threads s"
+ shows "cntP s th = cntV s th"
+ using assms
+ using cnp_cnv_cncs not_thread_cncs by auto
+
+end
+
+
+lemma eq_RAG:
+ "RAG (wq s) = RAG s"
+by (unfold cs_RAG_def s_RAG_def, auto)
+
+context valid_trace
+begin
+
+lemma count_eq_dependants:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "dependants (wq s) th = {}"
+proof -
+ from cnp_cnv_cncs and eq_pv
+ have "cntCS s th = 0"
+ by (auto split:if_splits)
+ moreover have "finite {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from finite_holding[of th] show ?thesis
+ by (simp add:holdents_test)
+ qed
+ ultimately have h: "{cs. (Cs cs, Th th) \<in> RAG s} = {}"
+ by (unfold cntCS_def holdents_test cs_dependants_def, auto)
+ show ?thesis
+ proof(unfold cs_dependants_def)
+ { assume "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}"
+ then obtain th' where "(Th th', Th th) \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "False"
+ proof(cases)
+ assume "(Th th', Th th) \<in> RAG (wq s)"
+ thus "False" by (auto simp:cs_RAG_def)
+ next
+ fix c
+ assume "(c, Th th) \<in> RAG (wq s)"
+ with h and eq_RAG show "False"
+ by (cases c, auto simp:cs_RAG_def)
+ qed
+ } thus "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} = {}" by auto
+ qed
+qed
+
+lemma dependants_threads:
+ shows "dependants (wq s) th \<subseteq> threads s"
+proof
+ { fix th th'
+ assume h: "th \<in> {th'a. (Th th'a, Th th') \<in> (RAG (wq s))\<^sup>+}"
+ have "Th th \<in> Domain (RAG s)"
+ proof -
+ from h obtain th' where "(Th th, Th th') \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "(Th th) \<in> Domain ( (RAG (wq s))\<^sup>+)" by (auto simp:Domain_def)
+ with trancl_domain have "(Th th) \<in> Domain (RAG (wq s))" by simp
+ thus ?thesis using eq_RAG by simp
+ qed
+ from dm_RAG_threads[OF this]
+ have "th \<in> threads s" .
+ } note hh = this
+ fix th1
+ assume "th1 \<in> dependants (wq s) th"
+ hence "th1 \<in> {th'a. (Th th'a, Th th) \<in> (RAG (wq s))\<^sup>+}"
+ by (unfold cs_dependants_def, simp)
+ from hh [OF this] show "th1 \<in> threads s" .
+qed
+
+lemma finite_threads:
+ shows "finite (threads s)"
+using vt by (induct) (auto elim: step.cases)
+
+end
+
+lemma Max_f_mono:
+ assumes seq: "A \<subseteq> B"
+ and np: "A \<noteq> {}"
+ and fnt: "finite B"
+ shows "Max (f ` A) \<le> Max (f ` B)"
+proof(rule Max_mono)
+ from seq show "f ` A \<subseteq> f ` B" by auto
+next
+ from np show "f ` A \<noteq> {}" by auto
+next
+ from fnt and seq show "finite (f ` B)" by auto
+qed
+
+context valid_trace
+begin
+
+lemma cp_le:
+ assumes th_in: "th \<in> threads s"
+ shows "cp s th \<le> Max ((\<lambda> th. (preced th s)) ` threads s)"
+proof(unfold cp_eq_cpreced cpreced_def cs_dependants_def)
+ show "Max ((\<lambda>th. preced th s) ` ({th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}))
+ \<le> Max ((\<lambda>th. preced th s) ` threads s)"
+ (is "Max (?f ` ?A) \<le> Max (?f ` ?B)")
+ proof(rule Max_f_mono)
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}" by simp
+ next
+ from finite_threads
+ show "finite (threads s)" .
+ next
+ from th_in
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> threads s"
+ apply (auto simp:Domain_def)
+ apply (rule_tac dm_RAG_threads)
+ apply (unfold trancl_domain [of "RAG s", symmetric])
+ by (unfold cs_RAG_def s_RAG_def, auto simp:Domain_def)
+ qed
+qed
+
+lemma le_cp:
+ shows "preced th s \<le> cp s th"
+proof(unfold cp_eq_cpreced preced_def cpreced_def, simp)
+ show "Prc (priority th s) (last_set th s)
+ \<le> Max (insert (Prc (priority th s) (last_set th s))
+ ((\<lambda>th. Prc (priority th s) (last_set th s)) ` dependants (wq s) th))"
+ (is "?l \<le> Max (insert ?l ?A)")
+ proof(cases "?A = {}")
+ case False
+ have "finite ?A" (is "finite (?f ` ?B)")
+ proof -
+ have "finite ?B"
+ proof-
+ have "finite {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ from Max_insert [OF this False, of ?l] show ?thesis by auto
+ next
+ case True
+ thus ?thesis by auto
+ qed
+qed
+
+lemma max_cp_eq:
+ shows "Max ((cp s) ` threads s) = Max ((\<lambda> th. (preced th s)) ` threads s)"
+ (is "?l = ?r")
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ have "?l \<in> ((cp s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ next
+ from False show "cp s ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th
+ where th_in: "th \<in> threads s" and eq_l: "?l = cp s th" by auto
+ have "\<dots> \<le> ?r" by (rule cp_le[OF th_in])
+ moreover have "?r \<le> cp s th" (is "Max (?f ` ?A) \<le> cp s th")
+ proof -
+ have "?r \<in> (?f ` ?A)"
+ proof(rule Max_in)
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by auto
+ next
+ from False show " (\<lambda>th. preced th s) ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th' where
+ th_in': "th' \<in> ?A " and eq_r: "?r = ?f th'" by auto
+ from le_cp [of th'] eq_r
+ have "?r \<le> cp s th'" by auto
+ moreover have "\<dots> \<le> cp s th"
+ proof(fold eq_l)
+ show " cp s th' \<le> Max (cp s ` threads s)"
+ proof(rule Max_ge)
+ from th_in' show "cp s th' \<in> cp s ` threads s"
+ by auto
+ next
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ qed
+ qed
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis using eq_l by auto
+qed
+
+lemma max_cp_readys_threads_pre:
+ assumes np: "threads s \<noteq> {}"
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(unfold max_cp_eq)
+ show "Max (cp s ` readys s) = Max ((\<lambda>th. preced th s) ` threads s)"
+ proof -
+ let ?p = "Max ((\<lambda>th. preced th s) ` threads s)"
+ let ?f = "(\<lambda>th. preced th s)"
+ have "?p \<in> ((\<lambda>th. preced th s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads show "finite (?f ` threads s)" by simp
+ next
+ from np show "?f ` threads s \<noteq> {}" by simp
+ qed
+ then obtain tm where tm_max: "?f tm = ?p" and tm_in: "tm \<in> threads s"
+ by (auto simp:Image_def)
+ from th_chain_to_ready [OF tm_in]
+ have "tm \<in> readys s \<or> (\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+)" .
+ thus ?thesis
+ proof
+ assume "\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+ "
+ then obtain th' where th'_in: "th' \<in> readys s"
+ and tm_chain:"(Th tm, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "cp s th' = ?f tm"
+ proof(subst cp_eq_cpreced, subst cpreced_def, rule Max_eqI)
+ from dependants_threads finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th'))"
+ by (auto intro:finite_subset)
+ next
+ fix p assume p_in: "p \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ from tm_max have " preced tm s = Max ((\<lambda>th. preced th s) ` threads s)" .
+ moreover have "p \<le> \<dots>"
+ proof(rule Max_ge)
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ from p_in and th'_in and dependants_threads[of th']
+ show "p \<in> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ ultimately show "p \<le> preced tm s" by auto
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ proof -
+ from tm_chain
+ have "tm \<in> dependants (wq s) th'"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, auto)
+ thus ?thesis by auto
+ qed
+ qed
+ with tm_max
+ have h: "cp s th' = Max ((\<lambda>th. preced th s) ` threads s)" by simp
+ show ?thesis
+ proof (fold h, rule Max_eqI)
+ fix q
+ assume "q \<in> cp s ` readys s"
+ then obtain th1 where th1_in: "th1 \<in> readys s"
+ and eq_q: "q = cp s th1" by auto
+ show "q \<le> cp s th'"
+ apply (unfold h eq_q)
+ apply (unfold cp_eq_cpreced cpreced_def)
+ apply (rule Max_mono)
+ proof -
+ from dependants_threads [of th1] th1_in
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<subseteq>
+ (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}" by simp
+ next
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ from th'_in
+ show "cp s th' \<in> cp s ` readys s" by simp
+ qed
+ next
+ assume tm_ready: "tm \<in> readys s"
+ show ?thesis
+ proof(fold tm_max)
+ have cp_eq_p: "cp s tm = preced tm s"
+ proof(unfold cp_eq_cpreced cpreced_def, rule Max_eqI)
+ fix y
+ assume hy: "y \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ show "y \<le> preced tm s"
+ proof -
+ { fix y'
+ assume hy' : "y' \<in> ((\<lambda>th. preced th s) ` dependants (wq s) tm)"
+ have "y' \<le> preced tm s"
+ proof(unfold tm_max, rule Max_ge)
+ from hy' dependants_threads[of tm]
+ show "y' \<in> (\<lambda>th. preced th s) ` threads s" by auto
+ next
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ } with hy show ?thesis by auto
+ qed
+ next
+ from dependants_threads[of tm] finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm))"
+ by (auto intro:finite_subset)
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ by simp
+ qed
+ moreover have "Max (cp s ` readys s) = cp s tm"
+ proof(rule Max_eqI)
+ from tm_ready show "cp s tm \<in> cp s ` readys s" by simp
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ fix y assume "y \<in> cp s ` readys s"
+ then obtain th1 where th1_readys: "th1 \<in> readys s"
+ and h: "y = cp s th1" by auto
+ show "y \<le> cp s tm"
+ apply(unfold cp_eq_p h)
+ apply(unfold cp_eq_cpreced cpreced_def tm_max, rule Max_mono)
+ proof -
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}"
+ by simp
+ next
+ from dependants_threads[of th1] th1_readys
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)
+ \<subseteq> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ qed
+ ultimately show " Max (cp s ` readys s) = preced tm s" by simp
+ qed
+ qed
+ qed
+qed
+
+text {* (* ccc *) \noindent
+ Since the current precedence of the threads in ready queue will always be boosted,
+ there must be one inside it has the maximum precedence of the whole system.
+*}
+lemma max_cp_readys_threads:
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis
+ by (auto simp:readys_def)
+next
+ case False
+ show ?thesis by (rule max_cp_readys_threads_pre[OF False])
+qed
+
+end
+
+lemma eq_holding: "holding (wq s) th cs = holding s th cs"
+ apply (unfold s_holding_def cs_holding_def wq_def, simp)
+ done
+
+lemma f_image_eq:
+ assumes h: "\<And> a. a \<in> A \<Longrightarrow> f a = g a"
+ shows "f ` A = g ` A"
+proof
+ show "f ` A \<subseteq> g ` A"
+ by(rule image_subsetI, auto intro:h)
+next
+ show "g ` A \<subseteq> f ` A"
+ by (rule image_subsetI, auto intro:h[symmetric])
+qed
+
+
+definition detached :: "state \<Rightarrow> thread \<Rightarrow> bool"
+ where "detached s th \<equiv> (\<not>(\<exists> cs. holding s th cs)) \<and> (\<not>(\<exists>cs. waiting s th cs))"
+
+
+lemma detached_test:
+ shows "detached s th = (Th th \<notin> Field (RAG s))"
+apply(simp add: detached_def Field_def)
+apply(simp add: s_RAG_def)
+apply(simp add: s_holding_abv s_waiting_abv)
+apply(simp add: Domain_iff Range_iff)
+apply(simp add: wq_def)
+apply(auto)
+done
+
+context valid_trace
+begin
+
+lemma detached_intro:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "detached s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_cnt: "cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ hence cncs_zero: "cntCS s th = 0"
+ by (auto simp:eq_pv split:if_splits)
+ with eq_cnt
+ have "th \<in> readys s \<or> th \<notin> threads s" by (auto simp:eq_pv)
+ thus ?thesis
+ proof
+ assume "th \<notin> threads s"
+ with range_in dm_RAG_threads
+ show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def Domain_iff Range_iff)
+ next
+ assume "th \<in> readys s"
+ moreover have "Th th \<notin> Range (RAG s)"
+ proof -
+ from card_0_eq [OF finite_holding] and cncs_zero
+ have "holdents s th = {}"
+ by (simp add:cntCS_def)
+ thus ?thesis
+ apply(auto simp:holdents_test)
+ apply(case_tac a)
+ apply(auto simp:holdents_test s_RAG_def)
+ done
+ qed
+ ultimately show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def readys_def)
+ qed
+qed
+
+lemma detached_elim:
+ assumes dtc: "detached s th"
+ shows "cntP s th = cntV s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_pv: " cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ have cncs_z: "cntCS s th = 0"
+ proof -
+ from dtc have "holdents s th = {}"
+ unfolding detached_def holdents_test s_RAG_def
+ by (simp add: s_waiting_abv wq_def s_holding_abv Domain_iff Range_iff)
+ thus ?thesis by (auto simp:cntCS_def)
+ qed
+ show ?thesis
+ proof(cases "th \<in> threads s")
+ case True
+ with dtc
+ have "th \<in> readys s"
+ by (unfold readys_def detached_def Field_def Domain_def Range_def,
+ auto simp:eq_waiting s_RAG_def)
+ with cncs_z and eq_pv show ?thesis by simp
+ next
+ case False
+ with cncs_z and eq_pv show ?thesis by simp
+ qed
+qed
+
+lemma detached_eq:
+ shows "(detached s th) = (cntP s th = cntV s th)"
+ by (insert vt, auto intro:detached_intro detached_elim)
+
+end
+
+text {*
+ The lemmas in this .thy file are all obvious lemmas, however, they still needs to be derived
+ from the concise and miniature model of PIP given in PrioGDef.thy.
+*}
+
+lemma eq_dependants: "dependants (wq s) = dependants s"
+ by (simp add: s_dependants_abv wq_def)
+
+lemma next_th_unique:
+ assumes nt1: "next_th s th cs th1"
+ and nt2: "next_th s th cs th2"
+ shows "th1 = th2"
+using assms by (unfold next_th_def, auto)
+
+lemma birth_time_lt: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ apply (induct s, simp)
+proof -
+ fix a s
+ assume ih: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ and eq_as: "a # s \<noteq> []"
+ show "last_set th (a # s) < length (a # s)"
+ proof(cases "s \<noteq> []")
+ case False
+ from False show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ next
+ case True
+ from ih [OF True] show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ qed
+qed
+
+lemma th_in_ne: "th \<in> threads s \<Longrightarrow> s \<noteq> []"
+ by (induct s, auto simp:threads.simps)
+
+lemma preced_tm_lt: "th \<in> threads s \<Longrightarrow> preced th s = Prc x y \<Longrightarrow> y < length s"
+ apply (drule_tac th_in_ne)
+ by (unfold preced_def, auto intro: birth_time_lt)
+
+lemma inj_the_preced:
+ "inj_on (the_preced s) (threads s)"
+ by (metis inj_onI preced_unique the_preced_def)
+
+lemma tRAG_alt_def:
+ "tRAG s = {(Th th1, Th th2) | th1 th2.
+ \<exists> cs. (Th th1, Cs cs) \<in> RAG s \<and> (Cs cs, Th th2) \<in> RAG s}"
+ by (auto simp:tRAG_def RAG_split wRAG_def hRAG_def)
+
+lemma tRAG_Field:
+ "Field (tRAG s) \<subseteq> Field (RAG s)"
+ by (unfold tRAG_alt_def Field_def, auto)
+
+lemma tRAG_ancestorsE:
+ assumes "x \<in> ancestors (tRAG s) u"
+ obtains th where "x = Th th"
+proof -
+ from assms have "(u, x) \<in> (tRAG s)^+"
+ by (unfold ancestors_def, auto)
+ from tranclE[OF this] obtain c where "(c, x) \<in> tRAG s" by auto
+ then obtain th where "x = Th th"
+ by (unfold tRAG_alt_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma tRAG_mono:
+ assumes "RAG s' \<subseteq> RAG s"
+ shows "tRAG s' \<subseteq> tRAG s"
+ using assms
+ by (unfold tRAG_alt_def, auto)
+
+lemma holding_next_thI:
+ assumes "holding s th cs"
+ and "length (wq s cs) > 1"
+ obtains th' where "next_th s th cs th'"
+proof -
+ from assms(1)[folded eq_holding, unfolded cs_holding_def]
+ have " th \<in> set (wq s cs) \<and> th = hd (wq s cs)" .
+ then obtain rest where h1: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ with assms(2) have h2: "rest \<noteq> []" by auto
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ have "next_th s th cs ?th'" using h1(1) h2
+ by (unfold next_th_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma RAG_tRAG_transfer:
+ assumes "vt s'"
+ assumes "RAG s = RAG s' \<union> {(Th th, Cs cs)}"
+ and "(Cs cs, Th th'') \<in> RAG s'"
+ shows "tRAG s = tRAG s' \<union> {(Th th, Th th'')}" (is "?L = ?R")
+proof -
+ interpret vt_s': valid_trace "s'" using assms(1)
+ by (unfold_locales, simp)
+ interpret rtree: rtree "RAG s'"
+ proof
+ show "single_valued (RAG s')"
+ apply (intro_locales)
+ by (unfold single_valued_def,
+ auto intro:vt_s'.unique_RAG)
+
+ show "acyclic (RAG s')"
+ by (rule vt_s'.acyclic_RAG)
+ qed
+ { fix n1 n2
+ assume "(n1, n2) \<in> ?L"
+ from this[unfolded tRAG_alt_def]
+ obtain th1 th2 cs' where
+ h: "n1 = Th th1" "n2 = Th th2"
+ "(Th th1, Cs cs') \<in> RAG s"
+ "(Cs cs', Th th2) \<in> RAG s" by auto
+ from h(4) and assms(2) have cs_in: "(Cs cs', Th th2) \<in> RAG s'" by auto
+ from h(3) and assms(2)
+ have "(Th th1, Cs cs') = (Th th, Cs cs) \<or>
+ (Th th1, Cs cs') \<in> RAG s'" by auto
+ hence "(n1, n2) \<in> ?R"
+ proof
+ assume h1: "(Th th1, Cs cs') = (Th th, Cs cs)"
+ hence eq_th1: "th1 = th" by simp
+ moreover have "th2 = th''"
+ proof -
+ from h1 have "cs' = cs" by simp
+ from assms(3) cs_in[unfolded this] rtree.sgv
+ show ?thesis
+ by (unfold single_valued_def, auto)
+ qed
+ ultimately show ?thesis using h(1,2) by auto
+ next
+ assume "(Th th1, Cs cs') \<in> RAG s'"
+ with cs_in have "(Th th1, Th th2) \<in> tRAG s'"
+ by (unfold tRAG_alt_def, auto)
+ from this[folded h(1, 2)] show ?thesis by auto
+ qed
+ } moreover {
+ fix n1 n2
+ assume "(n1, n2) \<in> ?R"
+ hence "(n1, n2) \<in>tRAG s' \<or> (n1, n2) = (Th th, Th th'')" by auto
+ hence "(n1, n2) \<in> ?L"
+ proof
+ assume "(n1, n2) \<in> tRAG s'"
+ moreover have "... \<subseteq> ?L"
+ proof(rule tRAG_mono)
+ show "RAG s' \<subseteq> RAG s" by (unfold assms(2), auto)
+ qed
+ ultimately show ?thesis by auto
+ next
+ assume eq_n: "(n1, n2) = (Th th, Th th'')"
+ from assms(2, 3) have "(Cs cs, Th th'') \<in> RAG s" by auto
+ moreover have "(Th th, Cs cs) \<in> RAG s" using assms(2) by auto
+ ultimately show ?thesis
+ by (unfold eq_n tRAG_alt_def, auto)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+context valid_trace
+begin
+
+lemmas RAG_tRAG_transfer = RAG_tRAG_transfer[OF vt]
+
+end
+
+lemma cp_alt_def:
+ "cp s th =
+ Max ((the_preced s) ` {th'. Th th' \<in> (subtree (RAG s) (Th th))})"
+proof -
+ have "Max (the_preced s ` ({th} \<union> dependants (wq s) th)) =
+ Max (the_preced s ` {th'. Th th' \<in> subtree (RAG s) (Th th)})"
+ (is "Max (_ ` ?L) = Max (_ ` ?R)")
+ proof -
+ have "?L = ?R"
+ by (auto dest:rtranclD simp:cs_dependants_def cs_RAG_def s_RAG_def subtree_def)
+ thus ?thesis by simp
+ qed
+ thus ?thesis by (unfold cp_eq_cpreced cpreced_def, fold the_preced_def, simp)
+qed
+
+lemma cp_gen_alt_def:
+ "cp_gen s = (Max \<circ> (\<lambda>x. (the_preced s \<circ> the_thread) ` subtree (tRAG s) x))"
+ by (auto simp:cp_gen_def)
+
+lemma tRAG_nodeE:
+ assumes "(n1, n2) \<in> tRAG s"
+ obtains th1 th2 where "n1 = Th th1" "n2 = Th th2"
+ using assms
+ by (auto simp: tRAG_def wRAG_def hRAG_def tRAG_def)
+
+lemma subtree_nodeE:
+ assumes "n \<in> subtree (tRAG s) (Th th)"
+ obtains th1 where "n = Th th1"
+proof -
+ show ?thesis
+ proof(rule subtreeE[OF assms])
+ assume "n = Th th"
+ from that[OF this] show ?thesis .
+ next
+ assume "Th th \<in> ancestors (tRAG s) n"
+ hence "(n, Th th) \<in> (tRAG s)^+" by (auto simp:ancestors_def)
+ hence "\<exists> th1. n = Th th1"
+ proof(induct)
+ case (base y)
+ from tRAG_nodeE[OF this] show ?case by metis
+ next
+ case (step y z)
+ thus ?case by auto
+ qed
+ with that show ?thesis by auto
+ qed
+qed
+
+lemma tRAG_star_RAG: "(tRAG s)^* \<subseteq> (RAG s)^*"
+proof -
+ have "(wRAG s O hRAG s)^* \<subseteq> (RAG s O RAG s)^*"
+ by (rule rtrancl_mono, auto simp:RAG_split)
+ also have "... \<subseteq> ((RAG s)^*)^*"
+ by (rule rtrancl_mono, auto)
+ also have "... = (RAG s)^*" by simp
+ finally show ?thesis by (unfold tRAG_def, simp)
+qed
+
+lemma tRAG_subtree_RAG: "subtree (tRAG s) x \<subseteq> subtree (RAG s) x"
+proof -
+ { fix a
+ assume "a \<in> subtree (tRAG s) x"
+ hence "(a, x) \<in> (tRAG s)^*" by (auto simp:subtree_def)
+ with tRAG_star_RAG[of s]
+ have "(a, x) \<in> (RAG s)^*" by auto
+ hence "a \<in> subtree (RAG s) x" by (auto simp:subtree_def)
+ } thus ?thesis by auto
+qed
+
+lemma tRAG_trancl_eq:
+ "{th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {th'. (Th th', Th th) \<in> (RAG s)^+}"
+ (is "?L = ?R")
+proof -
+ { fix th'
+ assume "th' \<in> ?L"
+ hence "(Th th', Th th) \<in> (tRAG s)^+" by auto
+ from tranclD[OF this]
+ obtain z where h: "(Th th', z) \<in> tRAG s" "(z, Th th) \<in> (tRAG s)\<^sup>*" by auto
+ from tRAG_subtree_RAG[of s] and this(2)
+ have "(z, Th th) \<in> (RAG s)^*" by (meson subsetCE tRAG_star_RAG)
+ moreover from h(1) have "(Th th', z) \<in> (RAG s)^+" using tRAG_alt_def by auto
+ ultimately have "th' \<in> ?R" by auto
+ } moreover
+ { fix th'
+ assume "th' \<in> ?R"
+ hence "(Th th', Th th) \<in> (RAG s)^+" by (auto)
+ from plus_rpath[OF this]
+ obtain xs where rp: "rpath (RAG s) (Th th') xs (Th th)" "xs \<noteq> []" by auto
+ hence "(Th th', Th th) \<in> (tRAG s)^+"
+ proof(induct xs arbitrary:th' th rule:length_induct)
+ case (1 xs th' th)
+ then obtain x1 xs1 where Cons1: "xs = x1#xs1" by (cases xs, auto)
+ show ?case
+ proof(cases "xs1")
+ case Nil
+ from 1(2)[unfolded Cons1 Nil]
+ have rp: "rpath (RAG s) (Th th') [x1] (Th th)" .
+ hence "(Th th', x1) \<in> (RAG s)" by (cases, simp)
+ then obtain cs where "x1 = Cs cs"
+ by (unfold s_RAG_def, auto)
+ from rpath_nnl_lastE[OF rp[unfolded this]]
+ show ?thesis by auto
+ next
+ case (Cons x2 xs2)
+ from 1(2)[unfolded Cons1[unfolded this]]
+ have rp: "rpath (RAG s) (Th th') (x1 # x2 # xs2) (Th th)" .
+ from rpath_edges_on[OF this]
+ have eds: "edges_on (Th th' # x1 # x2 # xs2) \<subseteq> RAG s" .
+ have "(Th th', x1) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ with eds have rg1: "(Th th', x1) \<in> RAG s" by auto
+ then obtain cs1 where eq_x1: "x1 = Cs cs1" by (unfold s_RAG_def, auto)
+ have "(x1, x2) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ from this eds
+ have rg2: "(x1, x2) \<in> RAG s" by auto
+ from this[unfolded eq_x1]
+ obtain th1 where eq_x2: "x2 = Th th1" by (unfold s_RAG_def, auto)
+ from rg1[unfolded eq_x1] rg2[unfolded eq_x1 eq_x2]
+ have rt1: "(Th th', Th th1) \<in> tRAG s" by (unfold tRAG_alt_def, auto)
+ from rp have "rpath (RAG s) x2 xs2 (Th th)"
+ by (elim rpath_ConsE, simp)
+ from this[unfolded eq_x2] have rp': "rpath (RAG s) (Th th1) xs2 (Th th)" .
+ show ?thesis
+ proof(cases "xs2 = []")
+ case True
+ from rpath_nilE[OF rp'[unfolded this]]
+ have "th1 = th" by auto
+ from rt1[unfolded this] show ?thesis by auto
+ next
+ case False
+ from 1(1)[rule_format, OF _ rp' this, unfolded Cons1 Cons]
+ have "(Th th1, Th th) \<in> (tRAG s)\<^sup>+" by simp
+ with rt1 show ?thesis by auto
+ qed
+ qed
+ qed
+ hence "th' \<in> ?L" by auto
+ } ultimately show ?thesis by blast
+qed
+
+lemma tRAG_trancl_eq_Th:
+ "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}"
+ using tRAG_trancl_eq by auto
+
+lemma dependants_alt_def:
+ "dependants s th = {th'. (Th th', Th th) \<in> (tRAG s)^+}"
+ by (metis eq_RAG s_dependants_def tRAG_trancl_eq)
+
+context valid_trace
+begin
+
+lemma count_eq_tRAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using assms count_eq_dependants dependants_alt_def eq_dependants by auto
+
+lemma count_eq_RAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using assms count_eq_dependants cs_dependants_def eq_RAG by auto
+
+lemma count_eq_RAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using count_eq_RAG_plus[OF assms] by auto
+
+lemma count_eq_tRAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using count_eq_tRAG_plus[OF assms] by auto
+
+end
+
+lemma tRAG_subtree_eq:
+ "(subtree (tRAG s) (Th th)) = {Th th' | th'. Th th' \<in> (subtree (RAG s) (Th th))}"
+ (is "?L = ?R")
+proof -
+ { fix n
+ assume h: "n \<in> ?L"
+ hence "n \<in> ?R"
+ by (smt mem_Collect_eq subsetCE subtree_def subtree_nodeE tRAG_subtree_RAG)
+ } moreover {
+ fix n
+ assume "n \<in> ?R"
+ then obtain th' where h: "n = Th th'" "(Th th', Th th) \<in> (RAG s)^*"
+ by (auto simp:subtree_def)
+ from rtranclD[OF this(2)]
+ have "n \<in> ?L"
+ proof
+ assume "Th th' \<noteq> Th th \<and> (Th th', Th th) \<in> (RAG s)\<^sup>+"
+ with h have "n \<in> {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}" by auto
+ thus ?thesis using subtree_def tRAG_trancl_eq by fastforce
+ qed (insert h, auto simp:subtree_def)
+ } ultimately show ?thesis by auto
+qed
+
+lemma threads_set_eq:
+ "the_thread ` (subtree (tRAG s) (Th th)) =
+ {th'. Th th' \<in> (subtree (RAG s) (Th th))}" (is "?L = ?R")
+ by (auto intro:rev_image_eqI simp:tRAG_subtree_eq)
+
+lemma cp_alt_def1:
+ "cp s th = Max ((the_preced s o the_thread) ` (subtree (tRAG s) (Th th)))"
+proof -
+ have "(the_preced s ` the_thread ` subtree (tRAG s) (Th th)) =
+ ((the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th))"
+ by auto
+ thus ?thesis by (unfold cp_alt_def, fold threads_set_eq, auto)
+qed
+
+lemma cp_gen_def_cond:
+ assumes "x = Th th"
+ shows "cp s th = cp_gen s (Th th)"
+by (unfold cp_alt_def1 cp_gen_def, simp)
+
+lemma cp_gen_over_set:
+ assumes "\<forall> x \<in> A. \<exists> th. x = Th th"
+ shows "cp_gen s ` A = (cp s \<circ> the_thread) ` A"
+proof(rule f_image_eq)
+ fix a
+ assume "a \<in> A"
+ from assms[rule_format, OF this]
+ obtain th where eq_a: "a = Th th" by auto
+ show "cp_gen s a = (cp s \<circ> the_thread) a"
+ by (unfold eq_a, simp, unfold cp_gen_def_cond[OF refl[of "Th th"]], simp)
+qed
+
+
+context valid_trace
+begin
+
+lemma RAG_threads:
+ assumes "(Th th) \<in> Field (RAG s)"
+ shows "th \<in> threads s"
+ using assms
+ by (metis Field_def UnE dm_RAG_threads range_in vt)
+
+lemma subtree_tRAG_thread:
+ assumes "th \<in> threads s"
+ shows "subtree (tRAG s) (Th th) \<subseteq> Th ` threads s" (is "?L \<subseteq> ?R")
+proof -
+ have "?L = {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ by (unfold tRAG_subtree_eq, simp)
+ also have "... \<subseteq> ?R"
+ proof
+ fix x
+ assume "x \<in> {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ then obtain th' where h: "x = Th th'" "Th th' \<in> subtree (RAG s) (Th th)" by auto
+ from this(2)
+ show "x \<in> ?R"
+ proof(cases rule:subtreeE)
+ case 1
+ thus ?thesis by (simp add: assms h(1))
+ next
+ case 2
+ thus ?thesis by (metis ancestors_Field dm_RAG_threads h(1) image_eqI)
+ qed
+ qed
+ finally show ?thesis .
+qed
+
+lemma readys_root:
+ assumes "th \<in> readys s"
+ shows "root (RAG s) (Th th)"
+proof -
+ { fix x
+ assume "x \<in> ancestors (RAG s) (Th th)"
+ hence h: "(Th th, x) \<in> (RAG s)^+" by (auto simp:ancestors_def)
+ from tranclD[OF this]
+ obtain z where "(Th th, z) \<in> RAG s" by auto
+ with assms(1) have False
+ apply (case_tac z, auto simp:readys_def s_RAG_def s_waiting_def cs_waiting_def)
+ by (fold wq_def, blast)
+ } thus ?thesis by (unfold root_def, auto)
+qed
+
+lemma readys_in_no_subtree:
+ assumes "th \<in> readys s"
+ and "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s) (Th th')"
+proof
+ assume "Th th \<in> subtree (RAG s) (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 1
+ with assms show ?thesis by auto
+ next
+ case 2
+ with readys_root[OF assms(1)]
+ show ?thesis by (auto simp:root_def)
+ qed
+qed
+
+lemma not_in_thread_isolated:
+ assumes "th \<notin> threads s"
+ shows "(Th th) \<notin> Field (RAG s)"
+proof
+ assume "(Th th) \<in> Field (RAG s)"
+ with dm_RAG_threads and range_in assms
+ show False by (unfold Field_def, blast)
+qed
+
+lemma wf_RAG: "wf (RAG s)"
+proof(rule finite_acyclic_wf)
+ from finite_RAG show "finite (RAG s)" .
+next
+ from acyclic_RAG show "acyclic (RAG s)" .
+qed
+
+lemma sgv_wRAG: "single_valued (wRAG s)"
+ using waiting_unique
+ by (unfold single_valued_def wRAG_def, auto)
+
+lemma sgv_hRAG: "single_valued (hRAG s)"
+ using holding_unique
+ by (unfold single_valued_def hRAG_def, auto)
+
+lemma sgv_tRAG: "single_valued (tRAG s)"
+ by (unfold tRAG_def, rule single_valued_relcomp,
+ insert sgv_wRAG sgv_hRAG, auto)
+
+lemma acyclic_tRAG: "acyclic (tRAG s)"
+proof(unfold tRAG_def, rule acyclic_compose)
+ show "acyclic (RAG s)" using acyclic_RAG .
+next
+ show "wRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+next
+ show "hRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+qed
+
+lemma sgv_RAG: "single_valued (RAG s)"
+ using unique_RAG by (auto simp:single_valued_def)
+
+lemma rtree_RAG: "rtree (RAG s)"
+ using sgv_RAG acyclic_RAG
+ by (unfold rtree_def rtree_axioms_def sgv_def, auto)
+
+end
+
+sublocale valid_trace < rtree_RAG: rtree "RAG s"
+proof
+ show "single_valued (RAG s)"
+ apply (intro_locales)
+ by (unfold single_valued_def,
+ auto intro:unique_RAG)
+
+ show "acyclic (RAG s)"
+ by (rule acyclic_RAG)
+qed
+
+sublocale valid_trace < rtree_s: rtree "tRAG s"
+proof(unfold_locales)
+ from sgv_tRAG show "single_valued (tRAG s)" .
+next
+ from acyclic_tRAG show "acyclic (tRAG s)" .
+qed
+
+sublocale valid_trace < fsbtRAGs : fsubtree "RAG s"
+proof -
+ show "fsubtree (RAG s)"
+ proof(intro_locales)
+ show "fbranch (RAG s)" using finite_fbranchI[OF finite_RAG] .
+ next
+ show "fsubtree_axioms (RAG s)"
+ proof(unfold fsubtree_axioms_def)
+ from wf_RAG show "wf (RAG s)" .
+ qed
+ qed
+qed
+
+sublocale valid_trace < fsbttRAGs: fsubtree "tRAG s"
+proof -
+ have "fsubtree (tRAG s)"
+ proof -
+ have "fbranch (tRAG s)"
+ proof(unfold tRAG_def, rule fbranch_compose)
+ show "fbranch (wRAG s)"
+ proof(rule finite_fbranchI)
+ from finite_RAG show "finite (wRAG s)"
+ by (unfold RAG_split, auto)
+ qed
+ next
+ show "fbranch (hRAG s)"
+ proof(rule finite_fbranchI)
+ from finite_RAG
+ show "finite (hRAG s)" by (unfold RAG_split, auto)
+ qed
+ qed
+ moreover have "wf (tRAG s)"
+ proof(rule wf_subset)
+ show "wf (RAG s O RAG s)" using wf_RAG
+ by (fold wf_comp_self, simp)
+ next
+ show "tRAG s \<subseteq> (RAG s O RAG s)"
+ by (unfold tRAG_alt_def, auto)
+ qed
+ ultimately show ?thesis
+ by (unfold fsubtree_def fsubtree_axioms_def,auto)
+ qed
+ from this[folded tRAG_def] show "fsubtree (tRAG s)" .
+qed
+
+lemma Max_UNION:
+ assumes "finite A"
+ and "A \<noteq> {}"
+ and "\<forall> M \<in> f ` A. finite M"
+ and "\<forall> M \<in> f ` A. M \<noteq> {}"
+ shows "Max (\<Union>x\<in> A. f x) = Max (Max ` f ` A)" (is "?L = ?R")
+ using assms[simp]
+proof -
+ have "?L = Max (\<Union>(f ` A))"
+ by (fold Union_image_eq, simp)
+ also have "... = ?R"
+ by (subst Max_Union, simp+)
+ finally show ?thesis .
+qed
+
+lemma max_Max_eq:
+ assumes "finite A"
+ and "A \<noteq> {}"
+ and "x = y"
+ shows "max x (Max A) = Max ({y} \<union> A)" (is "?L = ?R")
+proof -
+ have "?R = Max (insert y A)" by simp
+ also from assms have "... = ?L"
+ by (subst Max.insert, simp+)
+ finally show ?thesis by simp
+qed
+
+context valid_trace
+begin
+
+(* ddd *)
+lemma cp_gen_rec:
+ assumes "x = Th th"
+ shows "cp_gen s x = Max ({the_preced s th} \<union> (cp_gen s) ` children (tRAG s) x)"
+proof(cases "children (tRAG s) x = {}")
+ case True
+ show ?thesis
+ by (unfold True cp_gen_def subtree_children, simp add:assms)
+next
+ case False
+ hence [simp]: "children (tRAG s) x \<noteq> {}" by auto
+ note fsbttRAGs.finite_subtree[simp]
+ have [simp]: "finite (children (tRAG s) x)"
+ by (intro rev_finite_subset[OF fsbttRAGs.finite_subtree],
+ rule children_subtree)
+ { fix r x
+ have "subtree r x \<noteq> {}" by (auto simp:subtree_def)
+ } note this[simp]
+ have [simp]: "\<exists>x\<in>children (tRAG s) x. subtree (tRAG s) x \<noteq> {}"
+ proof -
+ from False obtain q where "q \<in> children (tRAG s) x" by blast
+ moreover have "subtree (tRAG s) q \<noteq> {}" by simp
+ ultimately show ?thesis by blast
+ qed
+ have h: "Max ((the_preced s \<circ> the_thread) `
+ ({x} \<union> \<Union>(subtree (tRAG s) ` children (tRAG s) x))) =
+ Max ({the_preced s th} \<union> cp_gen s ` children (tRAG s) x)"
+ (is "?L = ?R")
+ proof -
+ let "Max (?f ` (?A \<union> \<Union> (?g ` ?B)))" = ?L
+ let "Max (_ \<union> (?h ` ?B))" = ?R
+ let ?L1 = "?f ` \<Union>(?g ` ?B)"
+ have eq_Max_L1: "Max ?L1 = Max (?h ` ?B)"
+ proof -
+ have "?L1 = ?f ` (\<Union> x \<in> ?B.(?g x))" by simp
+ also have "... = (\<Union> x \<in> ?B. ?f ` (?g x))" by auto
+ finally have "Max ?L1 = Max ..." by simp
+ also have "... = Max (Max ` (\<lambda>x. ?f ` subtree (tRAG s) x) ` ?B)"
+ by (subst Max_UNION, simp+)
+ also have "... = Max (cp_gen s ` children (tRAG s) x)"
+ by (unfold image_comp cp_gen_alt_def, simp)
+ finally show ?thesis .
+ qed
+ show ?thesis
+ proof -
+ have "?L = Max (?f ` ?A \<union> ?L1)" by simp
+ also have "... = max (the_preced s (the_thread x)) (Max ?L1)"
+ by (subst Max_Un, simp+)
+ also have "... = max (?f x) (Max (?h ` ?B))"
+ by (unfold eq_Max_L1, simp)
+ also have "... =?R"
+ by (rule max_Max_eq, (simp)+, unfold assms, simp)
+ finally show ?thesis .
+ qed
+ qed thus ?thesis
+ by (fold h subtree_children, unfold cp_gen_def, simp)
+qed
+
+lemma cp_rec:
+ "cp s th = Max ({the_preced s th} \<union>
+ (cp s o the_thread) ` children (tRAG s) (Th th))"
+proof -
+ have "Th th = Th th" by simp
+ note h = cp_gen_def_cond[OF this] cp_gen_rec[OF this]
+ show ?thesis
+ proof -
+ have "cp_gen s ` children (tRAG s) (Th th) =
+ (cp s \<circ> the_thread) ` children (tRAG s) (Th th)"
+ proof(rule cp_gen_over_set)
+ show " \<forall>x\<in>children (tRAG s) (Th th). \<exists>th. x = Th th"
+ by (unfold tRAG_alt_def, auto simp:children_def)
+ qed
+ thus ?thesis by (subst (1) h(1), unfold h(2), simp)
+ qed
+qed
+
+end
+
+(* keep *)
+lemma next_th_holding:
+ assumes vt: "vt s"
+ and nxt: "next_th s th cs th'"
+ shows "holding (wq s) th cs"
+proof -
+ from nxt[unfolded next_th_def]
+ obtain rest where h: "wq s cs = th # rest"
+ "rest \<noteq> []"
+ "th' = hd (SOME q. distinct q \<and> set q = set rest)" by auto
+ thus ?thesis
+ by (unfold cs_holding_def, auto)
+qed
+
+context valid_trace
+begin
+
+lemma next_th_waiting:
+ assumes nxt: "next_th s th cs th'"
+ shows "waiting (wq s) th' cs"
+proof -
+ from nxt[unfolded next_th_def]
+ obtain rest where h: "wq s cs = th # rest"
+ "rest \<noteq> []"
+ "th' = hd (SOME q. distinct q \<and> set q = set rest)" by auto
+ from wq_distinct[of cs, unfolded h]
+ have dst: "distinct (th # rest)" .
+ have in_rest: "th' \<in> set rest"
+ proof(unfold h, rule someI2)
+ show "distinct rest \<and> set rest = set rest" using dst by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with h(2)
+ show "hd x \<in> set (rest)" by (cases x, auto)
+ qed
+ hence "th' \<in> set (wq s cs)" by (unfold h(1), auto)
+ moreover have "th' \<noteq> hd (wq s cs)"
+ by (unfold h(1), insert in_rest dst, auto)
+ ultimately show ?thesis by (auto simp:cs_waiting_def)
+qed
+
+lemma next_th_RAG:
+ assumes nxt: "next_th (s::event list) th cs th'"
+ shows "{(Cs cs, Th th), (Th th', Cs cs)} \<subseteq> RAG s"
+ using vt assms next_th_holding next_th_waiting
+ by (unfold s_RAG_def, simp)
+
+end
+
+-- {* A useless definition *}
+definition cps:: "state \<Rightarrow> (thread \<times> precedence) set"
+where "cps s = {(th, cp s th) | th . th \<in> threads s}"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PIPDefs.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,663 @@
+chapter {* Definitions *}
+(*<*)
+theory PIPDefs
+imports Precedence_ord Moment RTree Max
+begin
+(*>*)
+
+text {*
+ In this section, the formal model of Priority Inheritance Protocol (PIP) is presented.
+ The model is based on Paulson's inductive protocol verification method, where
+ the state of the system is modelled as a list of events happened so far with the latest
+ event put at the head.
+*}
+
+text {*
+ To define events, the identifiers of {\em threads},
+ {\em priority} and {\em critical resources } (abbreviated as @{text "cs"})
+ need to be represented. All three are represetned using standard
+ Isabelle/HOL type @{typ "nat"}:
+*}
+
+type_synonym thread = nat -- {* Type for thread identifiers. *}
+type_synonym priority = nat -- {* Type for priorities. *}
+type_synonym cs = nat -- {* Type for critical sections (or critical resources). *}
+
+text {*
+ \noindent
+ The abstraction of Priority Inheritance Protocol (PIP) is set at the system call level.
+ Every system call is represented as an event. The format of events is defined
+ defined as follows:
+ *}
+
+datatype event =
+ Create thread priority | -- {* Thread @{text "thread"} is created with priority @{text "priority"}. *}
+ Exit thread | -- {* Thread @{text "thread"} finishing its execution. *}
+ P thread cs | -- {* Thread @{text "thread"} requesting critical resource @{text "cs"}. *}
+ V thread cs | -- {* Thread @{text "thread"} releasing critical resource @{text "cs"}. *}
+ Set thread priority -- {* Thread @{text "thread"} resets its priority to @{text "priority"}. *}
+
+fun actor :: "event \<Rightarrow> thread" where
+ "actor (Create th pty) = th" |
+ "actor (Exit th) = th" |
+ "actor (P th cs) = th" |
+ "actor (V th cs) = th" |
+ "actor (Set th pty) = th"
+
+fun isCreate :: "event \<Rightarrow> bool" where
+ "isCreate (Create th pty) = True" |
+ "isCreate _ = False"
+
+fun isP :: "event \<Rightarrow> bool" where
+ "isP (P th cs) = True" |
+ "isP _ = False"
+
+fun isV :: "event \<Rightarrow> bool" where
+ "isV (V th cs) = True" |
+ "isV _ = False"
+
+text {*
+ As mentioned earlier, in Paulson's inductive method, the states of system are represented as lists of events,
+ which is defined by the following type @{text "state"}:
+ *}
+type_synonym state = "event list"
+
+
+text {*
+\noindent
+ Resource Allocation Graph (RAG for short) is used extensively in our formal analysis.
+ The following type @{text "node"} is used to represent nodes in RAG.
+ *}
+datatype node =
+ Th "thread" | -- {* Node for thread. *}
+ Cs "cs" -- {* Node for critical resource. *}
+
+text {*
+ \noindent
+ The following function
+ @{text "threads"} is used to calculate the set of live threads (@{text "threads s"})
+ in state @{text "s"}.
+ *}
+fun threads :: "state \<Rightarrow> thread set"
+ where
+ -- {* At the start of the system, the set of threads is empty: *}
+ "threads [] = {}" |
+ -- {* New thread is added to the @{text "threads"}: *}
+ "threads (Create thread prio#s) = {thread} \<union> threads s" |
+ -- {* Finished thread is removed: *}
+ "threads (Exit thread # s) = (threads s) - {thread}" |
+ -- {* Other kind of events does not affect the value of @{text "threads"}: *}
+ "threads (e#s) = threads s"
+
+text {*
+ \noindent
+ The function @{text "threads"} defined above is one of
+ the so called {\em observation function}s which forms
+ the very basis of Paulson's inductive protocol verification method.
+ Each observation function {\em observes} one particular aspect (or attribute)
+ of the system. For example, the attribute observed by @{text "threads s"}
+ is the set of threads living in state @{text "s"}.
+ The protocol being modelled
+ The decision made the protocol being modelled is based on the {\em observation}s
+ returned by {\em observation function}s. Since {\observation function}s forms
+ the very basis on which Paulson's inductive method is based, there will be
+ a lot of such observation functions introduced in the following. In fact, any function
+ which takes event list as argument is a {\em observation function}.
+ *}
+
+text {* \noindent
+ Observation @{text "priority th s"} is
+ the {\em original priority} of thread @{text "th"} in state @{text "s"}.
+ The {\em original priority} is the priority
+ assigned to a thread when it is created or when it is reset by system call
+ (represented by event @{text "Set thread priority"}).
+*}
+
+fun priority :: "thread \<Rightarrow> state \<Rightarrow> priority"
+ where
+ -- {* @{text "0"} is assigned to threads which have never been created: *}
+ "priority thread [] = 0" |
+ "priority thread (Create thread' prio#s) =
+ (if thread' = thread then prio else priority thread s)" |
+ "priority thread (Set thread' prio#s) =
+ (if thread' = thread then prio else priority thread s)" |
+ "priority thread (e#s) = priority thread s"
+
+text {*
+ \noindent
+ Observation @{text "last_set th s"} is the last time when the priority of thread @{text "th"} is set,
+ observed from state @{text "s"}.
+ The time in the system is measured by the number of events happened so far since the very beginning.
+*}
+fun last_set :: "thread \<Rightarrow> state \<Rightarrow> nat"
+ where
+ "last_set thread [] = 0" |
+ "last_set thread ((Create thread' prio)#s) =
+ (if (thread = thread') then length s else last_set thread s)" |
+ "last_set thread ((Set thread' prio)#s) =
+ (if (thread = thread') then length s else last_set thread s)" |
+ "last_set thread (_#s) = last_set thread s"
+
+text {*
+ \noindent
+ The {\em precedence} is a notion derived from {\em priority}, where the {\em precedence} of
+ a thread is the combination of its {\em original priority} and {\em time} the priority is set.
+ The intention is to discriminate threads with the same priority by giving threads whose priority
+ is assigned earlier higher precedences, becasue such threads are more urgent to finish.
+ This explains the following definition:
+ *}
+definition preced :: "thread \<Rightarrow> state \<Rightarrow> precedence"
+ where "preced thread s \<equiv> Prc (priority thread s) (last_set thread s)"
+
+
+text {*
+ \noindent
+ A number of important notions in PIP are represented as the following functions,
+ defined in terms of the waiting queues of the system, where the waiting queues
+ , as a whole, is represented by the @{text "wq"} argument of every notion function.
+ The @{text "wq"} argument is itself a functions which maps every critical resource
+ @{text "cs"} to the list of threads which are holding or waiting for it.
+ The thread at the head of this list is designated as the thread which is current
+ holding the resrouce, which is slightly different from tradition where
+ all threads in the waiting queue are considered as waiting for the resource.
+ *}
+
+consts
+ holding :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
+ waiting :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
+ RAG :: "'b \<Rightarrow> (node \<times> node) set"
+ dependants :: "'b \<Rightarrow> thread \<Rightarrow> thread set"
+
+defs (overloaded)
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ This meaning of @{text "wq"} is reflected in the following definition of @{text "holding wq th cs"},
+ where @{text "holding wq th cs"} means thread @{text "th"} is holding the critical
+ resource @{text "cs"}. This decision is based on @{text "wq"}.
+ \end{minipage}
+ *}
+
+ cs_holding_def:
+ "holding wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread = hd (wq cs))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ In accordance with the definition of @{text "holding wq th cs"},
+ a thread @{text "th"} is considered waiting for @{text "cs"} if
+ it is in the {\em waiting queue} of critical resource @{text "cs"}, but not at the head.
+ This is reflected in the definition of @{text "waiting wq th cs"} as follows:
+ \end{minipage}
+ *}
+ cs_waiting_def:
+ "waiting wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread \<noteq> hd (wq cs))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ @{text "RAG wq"} generates RAG (a binary relations on @{text "node"})
+ out of waiting queues of the system (represented by the @{text "wq"} argument):
+ \end{minipage}
+ *}
+ cs_RAG_def:
+ "RAG (wq::cs \<Rightarrow> thread list) \<equiv>
+ {(Th th, Cs cs) | th cs. waiting wq th cs} \<union> {(Cs cs, Th th) | cs th. holding wq th cs}"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ The following @{text "dependants wq th"} represents the set of threads which are RAGing on
+ thread @{text "th"} in Resource Allocation Graph @{text "RAG wq"}.
+ Here, "RAGing" means waiting directly or indirectly on the critical resource.
+ \end{minipage}
+ *}
+ cs_dependants_def:
+ "dependants (wq::cs \<Rightarrow> thread list) th \<equiv> {th' . (Th th', Th th) \<in> (RAG wq)^+}"
+
+
+text {* \noindent
+ The following
+ @{text "cpreced s th"} gives the {\em current precedence} of thread @{text "th"} under
+ state @{text "s"}. The definition of @{text "cpreced"} reflects the basic idea of
+ Priority Inheritance that the {\em current precedence} of a thread is the precedence
+ inherited from the maximum of all its dependants, i.e. the threads which are waiting
+ directly or indirectly waiting for some resources from it. If no such thread exits,
+ @{text "th"}'s {\em current precedence} equals its original precedence, i.e.
+ @{text "preced th s"}.
+ *}
+
+definition cpreced :: "(cs \<Rightarrow> thread list) \<Rightarrow> state \<Rightarrow> thread \<Rightarrow> precedence"
+ where "cpreced wq s = (\<lambda>th. Max ((\<lambda>th'. preced th' s) ` ({th} \<union> dependants wq th)))"
+
+text {*
+ Notice that the current precedence (@{text "cpreced"}) of one thread @{text "th"} can be boosted
+ (becoming larger than its own precedence) by those threads in
+ the @{text "dependants wq th"}-set. If one thread get boosted, we say
+ it inherits the priority (or, more precisely, the precedence) of
+ its dependants. This is how the word "Inheritance" in
+ Priority Inheritance Protocol comes.
+*}
+
+(*<*)
+lemma
+ cpreced_def2:
+ "cpreced wq s th \<equiv> Max ({preced th s} \<union> {preced th' s | th'. th' \<in> dependants wq th})"
+ unfolding cpreced_def image_def
+ apply(rule eq_reflection)
+ apply(rule_tac f="Max" in arg_cong)
+ by (auto)
+(*>*)
+
+
+text {* \noindent
+ Assuming @{text "qs"} be the waiting queue of a critical resource,
+ the following abbreviation "release qs" is the waiting queue after the thread
+ holding the resource (which is thread at the head of @{text "qs"}) released
+ the resource:
+*}
+abbreviation
+ "release qs \<equiv> case qs of
+ [] => []
+ | (_#qs') => (SOME q. distinct q \<and> set q = set qs')"
+text {* \noindent
+ It can be seen from the definition that the thread at the head of @{text "qs"} is removed
+ from the return value, and the value @{term "q"} is an reordering of @{text "qs'"}, the
+ tail of @{text "qs"}. Through this reordering, one of the waiting threads (those in @{text "qs'"} }
+ is chosen nondeterministically to be the head of the new queue @{text "q"}.
+ Therefore, this thread is the one who takes over the resource. This is a little better different
+ from common sense that the thread who comes the earliest should take over.
+ The intention of this definition is to show that the choice of which thread to take over the
+ release resource does not affect the correctness of the PIP protocol.
+*}
+
+text {*
+ The data structure used by the operating system for scheduling is referred to as
+ {\em schedule state}. It is represented as a record consisting of
+ a function assigning waiting queue to resources
+ (to be used as the @{text "wq"} argument in @{text "holding"}, @{text "waiting"}
+ and @{text "RAG"}, etc) and a function assigning precedence to threads:
+ *}
+
+record schedule_state =
+ wq_fun :: "cs \<Rightarrow> thread list" -- {* The function assigning waiting queue. *}
+ cprec_fun :: "thread \<Rightarrow> precedence" -- {* The function assigning precedence. *}
+
+text {* \noindent
+ The following two abbreviations (@{text "all_unlocked"} and @{text "initial_cprec"})
+ are used to set the initial values of the @{text "wq_fun"} @{text "cprec_fun"} fields
+ respectively of the @{text "schedule_state"} record by the following function @{text "sch"},
+ which is used to calculate the system's {\em schedule state}.
+
+ Since there is no thread at the very beginning to make request, all critical resources
+ are free (or unlocked). This status is represented by the abbreviation
+ @{text "all_unlocked"}.
+ *}
+abbreviation
+ "all_unlocked \<equiv> \<lambda>_::cs. ([]::thread list)"
+
+
+text {* \noindent
+ The initial current precedence for a thread can be anything, because there is no thread then.
+ We simply assume every thread has precedence @{text "Prc 0 0"}.
+ *}
+
+abbreviation
+ "initial_cprec \<equiv> \<lambda>_::thread. Prc 0 0"
+
+
+text {* \noindent
+ The following function @{text "schs"} is used to calculate the system's schedule state @{text "schs s"}
+ out of the current system state @{text "s"}. It is the central function to model Priority Inheritance:
+ *}
+fun schs :: "state \<Rightarrow> schedule_state"
+ where
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ Setting the initial value of the @{text "schedule_state"} record (see the explanations above).
+ \end{minipage}
+ *}
+ "schs [] = (| wq_fun = all_unlocked, cprec_fun = initial_cprec |)" |
+
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ \begin{enumerate}
+ \item @{text "ps"} is the schedule state of last moment.
+ \item @{text "pwq"} is the waiting queue function of last moment.
+ \item @{text "pcp"} is the precedence function of last moment (NOT USED).
+ \item @{text "nwq"} is the new waiting queue function. It is calculated using a @{text "case"} statement:
+ \begin{enumerate}
+ \item If the happening event is @{text "P thread cs"}, @{text "thread"} is added to
+ the end of @{text "cs"}'s waiting queue.
+ \item If the happening event is @{text "V thread cs"} and @{text "s"} is a legal state,
+ @{text "th'"} must equal to @{text "thread"},
+ because @{text "thread"} is the one currently holding @{text "cs"}.
+ The case @{text "[] \<Longrightarrow> []"} may never be executed in a legal state.
+ the @{text "(SOME q. distinct q \<and> set q = set qs)"} is used to choose arbitrarily one
+ thread in waiting to take over the released resource @{text "cs"}. In our representation,
+ this amounts to rearrange elements in waiting queue, so that one of them is put at the head.
+ \item For other happening event, the schedule state just does not change.
+ \end{enumerate}
+ \item @{text "ncp"} is new precedence function, it is calculated from the newly updated waiting queue
+ function. The RAGency of precedence function on waiting queue function is the reason to
+ put them in the same record so that they can evolve together.
+ \end{enumerate}
+
+
+ The calculation of @{text "cprec_fun"} depends on the value of @{text "wq_fun"}.
+ Therefore, in the following cases, @{text "wq_fun"} is always calculated first, in
+ the name of @{text "wq"} (if @{text "wq_fun"} is not changed
+ by the happening event) or @{text "new_wq"} (if the value of @{text "wq_fun"} is changed).
+ \end{minipage}
+ *}
+ "schs (Create th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Create th prio # s)|))"
+| "schs (Exit th # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Exit th # s)|))"
+| "schs (Set th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Set th prio # s)|))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ Different from the forth coming cases, the @{text "wq_fun"} field of the schedule state
+ is changed. So, the new value is calculated first, in the name of @{text "new_wq"}.
+ \end{minipage}
+ *}
+| "schs (P th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := (wq cs @ [th])) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (P th cs # s)|))"
+| "schs (V th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := release (wq cs)) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (V th cs # s)|))"
+
+lemma cpreced_initial:
+ "cpreced (\<lambda> cs. []) [] = (\<lambda>_. (Prc 0 0))"
+apply(simp add: cpreced_def)
+apply(simp add: cs_dependants_def cs_RAG_def cs_waiting_def cs_holding_def)
+apply(simp add: preced_def)
+done
+
+lemma sch_old_def:
+ "schs (e#s) = (let ps = schs s in
+ let pwq = wq_fun ps in
+ let nwq = case e of
+ P th cs \<Rightarrow> pwq(cs:=(pwq cs @ [th])) |
+ V th cs \<Rightarrow> let nq = case (pwq cs) of
+ [] \<Rightarrow> [] |
+ (_#qs) \<Rightarrow> (SOME q. distinct q \<and> set q = set qs)
+ in pwq(cs:=nq) |
+ _ \<Rightarrow> pwq
+ in let ncp = cpreced nwq (e#s) in
+ \<lparr>wq_fun = nwq, cprec_fun = ncp\<rparr>
+ )"
+apply(cases e)
+apply(simp_all)
+done
+
+
+text {*
+ \noindent
+ The following @{text "wq"} is a shorthand for @{text "wq_fun"}.
+ *}
+definition wq :: "state \<Rightarrow> cs \<Rightarrow> thread list"
+ where "wq s = wq_fun (schs s)"
+
+text {* \noindent
+ The following @{text "cp"} is a shorthand for @{text "cprec_fun"}.
+ *}
+definition cp :: "state \<Rightarrow> thread \<Rightarrow> precedence"
+ where "cp s \<equiv> cprec_fun (schs s)"
+
+text {* \noindent
+ Functions @{text "holding"}, @{text "waiting"}, @{text "RAG"} and
+ @{text "dependants"} still have the
+ same meaning, but redefined so that they no longer RAG on the
+ fictitious {\em waiting queue function}
+ @{text "wq"}, but on system state @{text "s"}.
+ *}
+defs (overloaded)
+ s_holding_abv:
+ "holding (s::state) \<equiv> holding (wq_fun (schs s))"
+ s_waiting_abv:
+ "waiting (s::state) \<equiv> waiting (wq_fun (schs s))"
+ s_RAG_abv:
+ "RAG (s::state) \<equiv> RAG (wq_fun (schs s))"
+ s_dependants_abv:
+ "dependants (s::state) \<equiv> dependants (wq_fun (schs s))"
+
+
+text {*
+ The following lemma can be proved easily, and the meaning is obvious.
+ *}
+lemma
+ s_holding_def:
+ "holding (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th = hd (wq_fun (schs s) cs))"
+ by (auto simp:s_holding_abv wq_def cs_holding_def)
+
+lemma s_waiting_def:
+ "waiting (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th \<noteq> hd (wq_fun (schs s) cs))"
+ by (auto simp:s_waiting_abv wq_def cs_waiting_def)
+
+lemma s_RAG_def:
+ "RAG (s::state) =
+ {(Th th, Cs cs) | th cs. waiting (wq s) th cs} \<union> {(Cs cs, Th th) | cs th. holding (wq s) th cs}"
+ by (auto simp:s_RAG_abv wq_def cs_RAG_def)
+
+lemma
+ s_dependants_def:
+ "dependants (s::state) th \<equiv> {th' . (Th th', Th th) \<in> (RAG (wq s))^+}"
+ by (auto simp:s_dependants_abv wq_def cs_dependants_def)
+
+text {*
+ The following function @{text "readys"} calculates the set of ready threads. A thread is {\em ready}
+ for running if it is a live thread and it is not waiting for any critical resource.
+ *}
+definition readys :: "state \<Rightarrow> thread set"
+ where "readys s \<equiv> {th . th \<in> threads s \<and> (\<forall> cs. \<not> waiting s th cs)}"
+
+text {* \noindent
+ The following function @{text "runing"} calculates the set of running thread, which is the ready
+ thread with the highest precedence.
+ *}
+definition runing :: "state \<Rightarrow> thread set"
+ where "runing s \<equiv> {th . th \<in> readys s \<and> cp s th = Max ((cp s) ` (readys s))}"
+
+text {* \noindent
+ Notice that the definition of @{text "running"} reflects the preemptive scheduling strategy,
+ because, if the @{text "running"}-thread (the one in @{text "runing"} set)
+ lowered its precedence by resetting its own priority to a lower
+ one, it will lose its status of being the max in @{text "ready"}-set and be superseded.
+*}
+
+text {* \noindent
+ The following function @{text "holdents s th"} returns the set of resources held by thread
+ @{text "th"} in state @{text "s"}.
+ *}
+definition holdents :: "state \<Rightarrow> thread \<Rightarrow> cs set"
+ where "holdents s th \<equiv> {cs . holding s th cs}"
+
+lemma holdents_test:
+ "holdents s th = {cs . (Cs cs, Th th) \<in> RAG s}"
+unfolding holdents_def
+unfolding s_RAG_def
+unfolding s_holding_abv
+unfolding wq_def
+by (simp)
+
+text {* \noindent
+ Observation @{text "cntCS s th"} returns the number of resources held by thread @{text "th"} in
+ state @{text "s"}:
+ *}
+definition cntCS :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntCS s th = card (holdents s th)"
+
+text {* \noindent
+ According to the convention of Paulson's inductive method,
+ the decision made by a protocol that event @{text "e"} is eligible to happen next under state @{text "s"}
+ is expressed as @{text "step s e"}. The predicate @{text "step"} is inductively defined as
+ follows (notice how the decision is based on the {\em observation function}s
+ defined above, and also notice how a complicated protocol is modeled by a few simple
+ observations, and how such a kind of simplicity gives rise to improved trust on
+ faithfulness):
+ *}
+inductive step :: "state \<Rightarrow> event \<Rightarrow> bool"
+ where
+ -- {*
+ A thread can be created if it is not a live thread:
+ *}
+ thread_create: "\<lbrakk>thread \<notin> threads s\<rbrakk> \<Longrightarrow> step s (Create thread prio)" |
+ -- {*
+ A thread can exit if it no longer hold any resource:
+ *}
+ thread_exit: "\<lbrakk>thread \<in> runing s; holdents s thread = {}\<rbrakk> \<Longrightarrow> step s (Exit thread)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can request for an critical resource @{text "cs"}, if it is running and
+ the request does not form a loop in the current RAG. The latter condition
+ is set up to avoid deadlock. The condition also reflects our assumption all threads are
+ carefully programmed so that deadlock can not happen:
+ \end{minipage}
+ *}
+ thread_P: "\<lbrakk>thread \<in> runing s; (Cs cs, Th thread) \<notin> (RAG s)^+\<rbrakk> \<Longrightarrow>
+ step s (P thread cs)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can release a critical resource @{text "cs"}
+ if it is running and holding that resource:
+ \end{minipage}
+ *}
+ thread_V: "\<lbrakk>thread \<in> runing s; holding s thread cs\<rbrakk> \<Longrightarrow> step s (V thread cs)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can adjust its own priority as long as it is current running.
+ With the resetting of one thread's priority, its precedence may change.
+ If this change lowered the precedence, according to the definition of @{text "running"}
+ function,
+ \end{minipage}
+ *}
+ thread_set: "\<lbrakk>thread \<in> runing s\<rbrakk> \<Longrightarrow> step s (Set thread prio)"
+
+text {*
+ In Paulson's inductive method, every protocol is defined by such a @{text "step"}
+ predicate. For instance, the predicate @{text "step"} given above
+ defines the PIP protocol. So, it can also be called "PIP".
+*}
+
+abbreviation
+ "PIP \<equiv> step"
+
+
+text {* \noindent
+ For any protocol defined by a @{text "step"} predicate,
+ the fact that @{text "s"} is a legal state in
+ the protocol is expressed as: @{text "vt step s"}, where
+ the predicate @{text "vt"} can be defined as the following:
+ *}
+inductive vt :: "state \<Rightarrow> bool"
+ where
+ -- {* Empty list @{text "[]"} is a legal state in any protocol:*}
+ vt_nil[intro]: "vt []" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ If @{text "s"} a legal state of the protocol defined by predicate @{text "step"},
+ and event @{text "e"} is allowed to happen under state @{text "s"} by the protocol
+ predicate @{text "step"}, then @{text "e#s"} is a new legal state rendered by the
+ happening of @{text "e"}:
+ \end{minipage}
+ *}
+ vt_cons[intro]: "\<lbrakk>vt s; step s e\<rbrakk> \<Longrightarrow> vt (e#s)"
+
+text {* \noindent
+ It is easy to see that the definition of @{text "vt"} is generic. It can be applied to
+ any specific protocol specified by a @{text "step"}-predicate to get the set of
+ legal states of that particular protocol.
+ *}
+
+text {*
+ The following are two very basic properties of @{text "vt"}.
+*}
+
+lemma step_back_vt: "vt (e#s) \<Longrightarrow> vt s"
+ by(ind_cases "vt (e#s)", simp)
+
+lemma step_back_step: "vt (e#s) \<Longrightarrow> step s e"
+ by(ind_cases "vt (e#s)", simp)
+
+text {* \noindent
+ The following two auxiliary functions @{text "the_cs"} and @{text "the_th"} are used to extract
+ critical resource and thread respectively out of RAG nodes.
+ *}
+fun the_cs :: "node \<Rightarrow> cs"
+ where "the_cs (Cs cs) = cs"
+
+fun the_th :: "node \<Rightarrow> thread"
+ where "the_th (Th th) = th"
+
+text {* \noindent
+ The following predicate @{text "next_th"} describe the next thread to
+ take over when a critical resource is released. In @{text "next_th s th cs t"},
+ @{text "th"} is the thread to release, @{text "t"} is the one to take over.
+ Notice how this definition is backed up by the @{text "release"} function and its use
+ in the @{text "V"}-branch of @{text "schs"} function. This @{text "next_th"} function
+ is not needed for the execution of PIP. It is introduced as an auxiliary function
+ to state lemmas. The correctness of this definition will be confirmed by
+ lemmas @{text "step_v_hold_inv"}, @{text " step_v_wait_inv"},
+ @{text "step_v_get_hold"} and @{text "step_v_not_wait"}.
+ *}
+definition next_th:: "state \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> thread \<Rightarrow> bool"
+ where "next_th s th cs t = (\<exists> rest. wq s cs = th#rest \<and> rest \<noteq> [] \<and>
+ t = hd (SOME q. distinct q \<and> set q = set rest))"
+
+text {* \noindent
+ The aux function @{text "count Q l"} is used to count the occurrence of situation @{text "Q"}
+ in list @{text "l"}:
+ *}
+definition count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"
+ where "count Q l = length (filter Q l)"
+
+text {* \noindent
+ The following observation @{text "cntP s"} returns the number of operation @{text "P"} happened
+ before reaching state @{text "s"}.
+ *}
+definition cntP :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntP s th = count (\<lambda> e. \<exists> cs. e = P th cs) s"
+
+text {* \noindent
+ The following observation @{text "cntV s"} returns the number of operation @{text "V"} happened
+ before reaching state @{text "s"}.
+ *}
+definition cntV :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntV s th = count (\<lambda> e. \<exists> cs. e = V th cs) s"
+
+text {* @{text "the_preced"} is also the same as @{text "preced"}, the only
+ difference is the order of arguemts. *}
+definition "the_preced s th = preced th s"
+
+text {* @{term "the_thread"} extracts thread out of RAG node. *}
+fun the_thread :: "node \<Rightarrow> thread" where
+ "the_thread (Th th) = th"
+
+text {* The following @{text "wRAG"} is the waiting sub-graph of @{text "RAG"}. *}
+definition "wRAG (s::state) = {(Th th, Cs cs) | th cs. waiting s th cs}"
+
+text {* The following @{text "hRAG"} is the holding sub-graph of @{text "RAG"}. *}
+definition "hRAG (s::state) = {(Cs cs, Th th) | th cs. holding s th cs}"
+
+text {*
+ The following @{text "tRAG"} is the thread-graph derived from @{term "RAG"}.
+ It characterizes the dependency between threads when calculating current
+ precedences. It is defined as the composition of the above two sub-graphs,
+ names @{term "wRAG"} and @{term "hRAG"}.
+ *}
+definition "tRAG s = wRAG s O hRAG s"
+
+text {* The following lemma splits @{term "RAG"} graph into the above two sub-graphs. *}
+lemma RAG_split: "RAG s = (wRAG s \<union> hRAG s)"
+ by (unfold s_RAG_abv wRAG_def hRAG_def s_waiting_abv
+ s_holding_abv cs_RAG_def, auto)
+
+definition "cp_gen s x =
+ Max ((the_preced s \<circ> the_thread) ` subtree (tRAG s) x)"
+
+(*<*)
+
+end
+(*>*)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PIPDefs.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,645 @@
+chapter {* Definitions *}
+(*<*)
+theory PIPDefs
+imports Precedence_ord Moment RTree Max
+begin
+(*>*)
+
+text {*
+ In this section, the formal model of Priority Inheritance Protocol (PIP) is presented.
+ The model is based on Paulson's inductive protocol verification method, where
+ the state of the system is modelled as a list of events happened so far with the latest
+ event put at the head.
+*}
+
+text {*
+ To define events, the identifiers of {\em threads},
+ {\em priority} and {\em critical resources } (abbreviated as @{text "cs"})
+ need to be represented. All three are represetned using standard
+ Isabelle/HOL type @{typ "nat"}:
+*}
+
+type_synonym thread = nat -- {* Type for thread identifiers. *}
+type_synonym priority = nat -- {* Type for priorities. *}
+type_synonym cs = nat -- {* Type for critical sections (or critical resources). *}
+
+text {*
+ \noindent
+ The abstraction of Priority Inheritance Protocol (PIP) is set at the system call level.
+ Every system call is represented as an event. The format of events is defined
+ defined as follows:
+ *}
+
+datatype event =
+ Create thread priority | -- {* Thread @{text "thread"} is created with priority @{text "priority"}. *}
+ Exit thread | -- {* Thread @{text "thread"} finishing its execution. *}
+ P thread cs | -- {* Thread @{text "thread"} requesting critical resource @{text "cs"}. *}
+ V thread cs | -- {* Thread @{text "thread"} releasing critical resource @{text "cs"}. *}
+ Set thread priority -- {* Thread @{text "thread"} resets its priority to @{text "priority"}. *}
+
+
+text {*
+ As mentioned earlier, in Paulson's inductive method, the states of system are represented as lists of events,
+ which is defined by the following type @{text "state"}:
+ *}
+type_synonym state = "event list"
+
+
+text {*
+\noindent
+ Resource Allocation Graph (RAG for short) is used extensively in our formal analysis.
+ The following type @{text "node"} is used to represent nodes in RAG.
+ *}
+datatype node =
+ Th "thread" | -- {* Node for thread. *}
+ Cs "cs" -- {* Node for critical resource. *}
+
+text {*
+ \noindent
+ The following function
+ @{text "threads"} is used to calculate the set of live threads (@{text "threads s"})
+ in state @{text "s"}.
+ *}
+fun threads :: "state \<Rightarrow> thread set"
+ where
+ -- {* At the start of the system, the set of threads is empty: *}
+ "threads [] = {}" |
+ -- {* New thread is added to the @{text "threads"}: *}
+ "threads (Create thread prio#s) = {thread} \<union> threads s" |
+ -- {* Finished thread is removed: *}
+ "threads (Exit thread # s) = (threads s) - {thread}" |
+ -- {* Other kind of events does not affect the value of @{text "threads"}: *}
+ "threads (e#s) = threads s"
+
+text {*
+ \noindent
+ The function @{text "threads"} defined above is one of
+ the so called {\em observation function}s which forms
+ the very basis of Paulson's inductive protocol verification method.
+ Each observation function {\em observes} one particular aspect (or attribute)
+ of the system. For example, the attribute observed by @{text "threads s"}
+ is the set of threads living in state @{text "s"}.
+ The protocol being modelled
+ The decision made the protocol being modelled is based on the {\em observation}s
+ returned by {\em observation function}s. Since {\observation function}s forms
+ the very basis on which Paulson's inductive method is based, there will be
+ a lot of such observation functions introduced in the following. In fact, any function
+ which takes event list as argument is a {\em observation function}.
+ *}
+
+text {* \noindent
+ Observation @{text "priority th s"} is
+ the {\em original priority} of thread @{text "th"} in state @{text "s"}.
+ The {\em original priority} is the priority
+ assigned to a thread when it is created or when it is reset by system call
+ (represented by event @{text "Set thread priority"}).
+*}
+
+fun priority :: "thread \<Rightarrow> state \<Rightarrow> priority"
+ where
+ -- {* @{text "0"} is assigned to threads which have never been created: *}
+ "priority thread [] = 0" |
+ "priority thread (Create thread' prio#s) =
+ (if thread' = thread then prio else priority thread s)" |
+ "priority thread (Set thread' prio#s) =
+ (if thread' = thread then prio else priority thread s)" |
+ "priority thread (e#s) = priority thread s"
+
+text {*
+ \noindent
+ Observation @{text "last_set th s"} is the last time when the priority of thread @{text "th"} is set,
+ observed from state @{text "s"}.
+ The time in the system is measured by the number of events happened so far since the very beginning.
+*}
+fun last_set :: "thread \<Rightarrow> state \<Rightarrow> nat"
+ where
+ "last_set thread [] = 0" |
+ "last_set thread ((Create thread' prio)#s) =
+ (if (thread = thread') then length s else last_set thread s)" |
+ "last_set thread ((Set thread' prio)#s) =
+ (if (thread = thread') then length s else last_set thread s)" |
+ "last_set thread (_#s) = last_set thread s"
+
+text {*
+ \noindent
+ The {\em precedence} is a notion derived from {\em priority}, where the {\em precedence} of
+ a thread is the combination of its {\em original priority} and {\em time} the priority is set.
+ The intention is to discriminate threads with the same priority by giving threads whose priority
+ is assigned earlier higher precedences, becasue such threads are more urgent to finish.
+ This explains the following definition:
+ *}
+definition preced :: "thread \<Rightarrow> state \<Rightarrow> precedence"
+ where "preced thread s \<equiv> Prc (priority thread s) (last_set thread s)"
+
+
+text {*
+ \noindent
+ A number of important notions in PIP are represented as the following functions,
+ defined in terms of the waiting queues of the system, where the waiting queues
+ , as a whole, is represented by the @{text "wq"} argument of every notion function.
+ The @{text "wq"} argument is itself a functions which maps every critical resource
+ @{text "cs"} to the list of threads which are holding or waiting for it.
+ The thread at the head of this list is designated as the thread which is current
+ holding the resrouce, which is slightly different from tradition where
+ all threads in the waiting queue are considered as waiting for the resource.
+ *}
+
+consts
+ holding :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
+ waiting :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
+ RAG :: "'b \<Rightarrow> (node \<times> node) set"
+ dependants :: "'b \<Rightarrow> thread \<Rightarrow> thread set"
+
+defs (overloaded)
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ This meaning of @{text "wq"} is reflected in the following definition of @{text "holding wq th cs"},
+ where @{text "holding wq th cs"} means thread @{text "th"} is holding the critical
+ resource @{text "cs"}. This decision is based on @{text "wq"}.
+ \end{minipage}
+ *}
+
+ cs_holding_def:
+ "holding wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread = hd (wq cs))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ In accordance with the definition of @{text "holding wq th cs"},
+ a thread @{text "th"} is considered waiting for @{text "cs"} if
+ it is in the {\em waiting queue} of critical resource @{text "cs"}, but not at the head.
+ This is reflected in the definition of @{text "waiting wq th cs"} as follows:
+ \end{minipage}
+ *}
+ cs_waiting_def:
+ "waiting wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread \<noteq> hd (wq cs))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ @{text "RAG wq"} generates RAG (a binary relations on @{text "node"})
+ out of waiting queues of the system (represented by the @{text "wq"} argument):
+ \end{minipage}
+ *}
+ cs_RAG_def:
+ "RAG (wq::cs \<Rightarrow> thread list) \<equiv>
+ {(Th th, Cs cs) | th cs. waiting wq th cs} \<union> {(Cs cs, Th th) | cs th. holding wq th cs}"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ The following @{text "dependants wq th"} represents the set of threads which are RAGing on
+ thread @{text "th"} in Resource Allocation Graph @{text "RAG wq"}.
+ Here, "RAGing" means waiting directly or indirectly on the critical resource.
+ \end{minipage}
+ *}
+ cs_dependants_def:
+ "dependants (wq::cs \<Rightarrow> thread list) th \<equiv> {th' . (Th th', Th th) \<in> (RAG wq)^+}"
+
+
+text {* \noindent
+ The following
+ @{text "cpreced s th"} gives the {\em current precedence} of thread @{text "th"} under
+ state @{text "s"}. The definition of @{text "cpreced"} reflects the basic idea of
+ Priority Inheritance that the {\em current precedence} of a thread is the precedence
+ inherited from the maximum of all its dependants, i.e. the threads which are waiting
+ directly or indirectly waiting for some resources from it. If no such thread exits,
+ @{text "th"}'s {\em current precedence} equals its original precedence, i.e.
+ @{text "preced th s"}.
+ *}
+
+definition cpreced :: "(cs \<Rightarrow> thread list) \<Rightarrow> state \<Rightarrow> thread \<Rightarrow> precedence"
+ where "cpreced wq s = (\<lambda>th. Max ((\<lambda>th'. preced th' s) ` ({th} \<union> dependants wq th)))"
+
+text {*
+ Notice that the current precedence (@{text "cpreced"}) of one thread @{text "th"} can be boosted
+ (becoming larger than its own precedence) by those threads in
+ the @{text "dependants wq th"}-set. If one thread get boosted, we say
+ it inherits the priority (or, more precisely, the precedence) of
+ its dependants. This is how the word "Inheritance" in
+ Priority Inheritance Protocol comes.
+*}
+
+(*<*)
+lemma
+ cpreced_def2:
+ "cpreced wq s th \<equiv> Max ({preced th s} \<union> {preced th' s | th'. th' \<in> dependants wq th})"
+ unfolding cpreced_def image_def
+ apply(rule eq_reflection)
+ apply(rule_tac f="Max" in arg_cong)
+ by (auto)
+(*>*)
+
+
+text {* \noindent
+ Assuming @{text "qs"} be the waiting queue of a critical resource,
+ the following abbreviation "release qs" is the waiting queue after the thread
+ holding the resource (which is thread at the head of @{text "qs"}) released
+ the resource:
+*}
+abbreviation
+ "release qs \<equiv> case qs of
+ [] => []
+ | (_#qs') => (SOME q. distinct q \<and> set q = set qs')"
+text {* \noindent
+ It can be seen from the definition that the thread at the head of @{text "qs"} is removed
+ from the return value, and the value @{term "q"} is an reordering of @{text "qs'"}, the
+ tail of @{text "qs"}. Through this reordering, one of the waiting threads (those in @{text "qs'"} }
+ is chosen nondeterministically to be the head of the new queue @{text "q"}.
+ Therefore, this thread is the one who takes over the resource. This is a little better different
+ from common sense that the thread who comes the earliest should take over.
+ The intention of this definition is to show that the choice of which thread to take over the
+ release resource does not affect the correctness of the PIP protocol.
+*}
+
+text {*
+ The data structure used by the operating system for scheduling is referred to as
+ {\em schedule state}. It is represented as a record consisting of
+ a function assigning waiting queue to resources
+ (to be used as the @{text "wq"} argument in @{text "holding"}, @{text "waiting"}
+ and @{text "RAG"}, etc) and a function assigning precedence to threads:
+ *}
+
+record schedule_state =
+ wq_fun :: "cs \<Rightarrow> thread list" -- {* The function assigning waiting queue. *}
+ cprec_fun :: "thread \<Rightarrow> precedence" -- {* The function assigning precedence. *}
+
+text {* \noindent
+ The following two abbreviations (@{text "all_unlocked"} and @{text "initial_cprec"})
+ are used to set the initial values of the @{text "wq_fun"} @{text "cprec_fun"} fields
+ respectively of the @{text "schedule_state"} record by the following function @{text "sch"},
+ which is used to calculate the system's {\em schedule state}.
+
+ Since there is no thread at the very beginning to make request, all critical resources
+ are free (or unlocked). This status is represented by the abbreviation
+ @{text "all_unlocked"}.
+ *}
+abbreviation
+ "all_unlocked \<equiv> \<lambda>_::cs. ([]::thread list)"
+
+
+text {* \noindent
+ The initial current precedence for a thread can be anything, because there is no thread then.
+ We simply assume every thread has precedence @{text "Prc 0 0"}.
+ *}
+
+abbreviation
+ "initial_cprec \<equiv> \<lambda>_::thread. Prc 0 0"
+
+
+text {* \noindent
+ The following function @{text "schs"} is used to calculate the system's schedule state @{text "schs s"}
+ out of the current system state @{text "s"}. It is the central function to model Priority Inheritance:
+ *}
+fun schs :: "state \<Rightarrow> schedule_state"
+ where
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ Setting the initial value of the @{text "schedule_state"} record (see the explanations above).
+ \end{minipage}
+ *}
+ "schs [] = (| wq_fun = all_unlocked, cprec_fun = initial_cprec |)" |
+
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ \begin{enumerate}
+ \item @{text "ps"} is the schedule state of last moment.
+ \item @{text "pwq"} is the waiting queue function of last moment.
+ \item @{text "pcp"} is the precedence function of last moment (NOT USED).
+ \item @{text "nwq"} is the new waiting queue function. It is calculated using a @{text "case"} statement:
+ \begin{enumerate}
+ \item If the happening event is @{text "P thread cs"}, @{text "thread"} is added to
+ the end of @{text "cs"}'s waiting queue.
+ \item If the happening event is @{text "V thread cs"} and @{text "s"} is a legal state,
+ @{text "th'"} must equal to @{text "thread"},
+ because @{text "thread"} is the one currently holding @{text "cs"}.
+ The case @{text "[] \<Longrightarrow> []"} may never be executed in a legal state.
+ the @{text "(SOME q. distinct q \<and> set q = set qs)"} is used to choose arbitrarily one
+ thread in waiting to take over the released resource @{text "cs"}. In our representation,
+ this amounts to rearrange elements in waiting queue, so that one of them is put at the head.
+ \item For other happening event, the schedule state just does not change.
+ \end{enumerate}
+ \item @{text "ncp"} is new precedence function, it is calculated from the newly updated waiting queue
+ function. The RAGency of precedence function on waiting queue function is the reason to
+ put them in the same record so that they can evolve together.
+ \end{enumerate}
+
+
+ The calculation of @{text "cprec_fun"} depends on the value of @{text "wq_fun"}.
+ Therefore, in the following cases, @{text "wq_fun"} is always calculated first, in
+ the name of @{text "wq"} (if @{text "wq_fun"} is not changed
+ by the happening event) or @{text "new_wq"} (if the value of @{text "wq_fun"} is changed).
+ \end{minipage}
+ *}
+ "schs (Create th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Create th prio # s)|))"
+| "schs (Exit th # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Exit th # s)|))"
+| "schs (Set th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Set th prio # s)|))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ Different from the forth coming cases, the @{text "wq_fun"} field of the schedule state
+ is changed. So, the new value is calculated first, in the name of @{text "new_wq"}.
+ \end{minipage}
+ *}
+| "schs (P th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := (wq cs @ [th])) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (P th cs # s)|))"
+| "schs (V th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := release (wq cs)) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (V th cs # s)|))"
+
+lemma cpreced_initial:
+ "cpreced (\<lambda> cs. []) [] = (\<lambda>_. (Prc 0 0))"
+apply(simp add: cpreced_def)
+apply(simp add: cs_dependants_def cs_RAG_def cs_waiting_def cs_holding_def)
+apply(simp add: preced_def)
+done
+
+lemma sch_old_def:
+ "schs (e#s) = (let ps = schs s in
+ let pwq = wq_fun ps in
+ let nwq = case e of
+ P th cs \<Rightarrow> pwq(cs:=(pwq cs @ [th])) |
+ V th cs \<Rightarrow> let nq = case (pwq cs) of
+ [] \<Rightarrow> [] |
+ (_#qs) \<Rightarrow> (SOME q. distinct q \<and> set q = set qs)
+ in pwq(cs:=nq) |
+ _ \<Rightarrow> pwq
+ in let ncp = cpreced nwq (e#s) in
+ \<lparr>wq_fun = nwq, cprec_fun = ncp\<rparr>
+ )"
+apply(cases e)
+apply(simp_all)
+done
+
+
+text {*
+ \noindent
+ The following @{text "wq"} is a shorthand for @{text "wq_fun"}.
+ *}
+definition wq :: "state \<Rightarrow> cs \<Rightarrow> thread list"
+ where "wq s = wq_fun (schs s)"
+
+text {* \noindent
+ The following @{text "cp"} is a shorthand for @{text "cprec_fun"}.
+ *}
+definition cp :: "state \<Rightarrow> thread \<Rightarrow> precedence"
+ where "cp s \<equiv> cprec_fun (schs s)"
+
+text {* \noindent
+ Functions @{text "holding"}, @{text "waiting"}, @{text "RAG"} and
+ @{text "dependants"} still have the
+ same meaning, but redefined so that they no longer RAG on the
+ fictitious {\em waiting queue function}
+ @{text "wq"}, but on system state @{text "s"}.
+ *}
+defs (overloaded)
+ s_holding_abv:
+ "holding (s::state) \<equiv> holding (wq_fun (schs s))"
+ s_waiting_abv:
+ "waiting (s::state) \<equiv> waiting (wq_fun (schs s))"
+ s_RAG_abv:
+ "RAG (s::state) \<equiv> RAG (wq_fun (schs s))"
+ s_dependants_abv:
+ "dependants (s::state) \<equiv> dependants (wq_fun (schs s))"
+
+
+text {*
+ The following lemma can be proved easily, and the meaning is obvious.
+ *}
+lemma
+ s_holding_def:
+ "holding (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th = hd (wq_fun (schs s) cs))"
+ by (auto simp:s_holding_abv wq_def cs_holding_def)
+
+lemma s_waiting_def:
+ "waiting (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th \<noteq> hd (wq_fun (schs s) cs))"
+ by (auto simp:s_waiting_abv wq_def cs_waiting_def)
+
+lemma s_RAG_def:
+ "RAG (s::state) =
+ {(Th th, Cs cs) | th cs. waiting (wq s) th cs} \<union> {(Cs cs, Th th) | cs th. holding (wq s) th cs}"
+ by (auto simp:s_RAG_abv wq_def cs_RAG_def)
+
+lemma
+ s_dependants_def:
+ "dependants (s::state) th \<equiv> {th' . (Th th', Th th) \<in> (RAG (wq s))^+}"
+ by (auto simp:s_dependants_abv wq_def cs_dependants_def)
+
+text {*
+ The following function @{text "readys"} calculates the set of ready threads. A thread is {\em ready}
+ for running if it is a live thread and it is not waiting for any critical resource.
+ *}
+definition readys :: "state \<Rightarrow> thread set"
+ where "readys s \<equiv> {th . th \<in> threads s \<and> (\<forall> cs. \<not> waiting s th cs)}"
+
+text {* \noindent
+ The following function @{text "runing"} calculates the set of running thread, which is the ready
+ thread with the highest precedence.
+ *}
+definition runing :: "state \<Rightarrow> thread set"
+ where "runing s \<equiv> {th . th \<in> readys s \<and> cp s th = Max ((cp s) ` (readys s))}"
+
+text {* \noindent
+ Notice that the definition of @{text "running"} reflects the preemptive scheduling strategy,
+ because, if the @{text "running"}-thread (the one in @{text "runing"} set)
+ lowered its precedence by resetting its own priority to a lower
+ one, it will lose its status of being the max in @{text "ready"}-set and be superseded.
+*}
+
+text {* \noindent
+ The following function @{text "holdents s th"} returns the set of resources held by thread
+ @{text "th"} in state @{text "s"}.
+ *}
+definition holdents :: "state \<Rightarrow> thread \<Rightarrow> cs set"
+ where "holdents s th \<equiv> {cs . holding s th cs}"
+
+lemma holdents_test:
+ "holdents s th = {cs . (Cs cs, Th th) \<in> RAG s}"
+unfolding holdents_def
+unfolding s_RAG_def
+unfolding s_holding_abv
+unfolding wq_def
+by (simp)
+
+text {* \noindent
+ Observation @{text "cntCS s th"} returns the number of resources held by thread @{text "th"} in
+ state @{text "s"}:
+ *}
+definition cntCS :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntCS s th = card (holdents s th)"
+
+text {* \noindent
+ According to the convention of Paulson's inductive method,
+ the decision made by a protocol that event @{text "e"} is eligible to happen next under state @{text "s"}
+ is expressed as @{text "step s e"}. The predicate @{text "step"} is inductively defined as
+ follows (notice how the decision is based on the {\em observation function}s
+ defined above, and also notice how a complicated protocol is modeled by a few simple
+ observations, and how such a kind of simplicity gives rise to improved trust on
+ faithfulness):
+ *}
+inductive step :: "state \<Rightarrow> event \<Rightarrow> bool"
+ where
+ -- {*
+ A thread can be created if it is not a live thread:
+ *}
+ thread_create: "\<lbrakk>thread \<notin> threads s\<rbrakk> \<Longrightarrow> step s (Create thread prio)" |
+ -- {*
+ A thread can exit if it no longer hold any resource:
+ *}
+ thread_exit: "\<lbrakk>thread \<in> runing s; holdents s thread = {}\<rbrakk> \<Longrightarrow> step s (Exit thread)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can request for an critical resource @{text "cs"}, if it is running and
+ the request does not form a loop in the current RAG. The latter condition
+ is set up to avoid deadlock. The condition also reflects our assumption all threads are
+ carefully programmed so that deadlock can not happen:
+ \end{minipage}
+ *}
+ thread_P: "\<lbrakk>thread \<in> runing s; (Cs cs, Th thread) \<notin> (RAG s)^+\<rbrakk> \<Longrightarrow>
+ step s (P thread cs)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can release a critical resource @{text "cs"}
+ if it is running and holding that resource:
+ \end{minipage}
+ *}
+ thread_V: "\<lbrakk>thread \<in> runing s; holding s thread cs\<rbrakk> \<Longrightarrow> step s (V thread cs)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can adjust its own priority as long as it is current running.
+ With the resetting of one thread's priority, its precedence may change.
+ If this change lowered the precedence, according to the definition of @{text "running"}
+ function,
+ \end{minipage}
+ *}
+ thread_set: "\<lbrakk>thread \<in> runing s\<rbrakk> \<Longrightarrow> step s (Set thread prio)"
+
+text {*
+ In Paulson's inductive method, every protocol is defined by such a @{text "step"}
+ predicate. For instance, the predicate @{text "step"} given above
+ defines the PIP protocol. So, it can also be called "PIP".
+*}
+
+abbreviation
+ "PIP \<equiv> step"
+
+
+text {* \noindent
+ For any protocol defined by a @{text "step"} predicate,
+ the fact that @{text "s"} is a legal state in
+ the protocol is expressed as: @{text "vt step s"}, where
+ the predicate @{text "vt"} can be defined as the following:
+ *}
+inductive vt :: "state \<Rightarrow> bool"
+ where
+ -- {* Empty list @{text "[]"} is a legal state in any protocol:*}
+ vt_nil[intro]: "vt []" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ If @{text "s"} a legal state of the protocol defined by predicate @{text "step"},
+ and event @{text "e"} is allowed to happen under state @{text "s"} by the protocol
+ predicate @{text "step"}, then @{text "e#s"} is a new legal state rendered by the
+ happening of @{text "e"}:
+ \end{minipage}
+ *}
+ vt_cons[intro]: "\<lbrakk>vt s; step s e\<rbrakk> \<Longrightarrow> vt (e#s)"
+
+text {* \noindent
+ It is easy to see that the definition of @{text "vt"} is generic. It can be applied to
+ any specific protocol specified by a @{text "step"}-predicate to get the set of
+ legal states of that particular protocol.
+ *}
+
+text {*
+ The following are two very basic properties of @{text "vt"}.
+*}
+
+lemma step_back_vt: "vt (e#s) \<Longrightarrow> vt s"
+ by(ind_cases "vt (e#s)", simp)
+
+lemma step_back_step: "vt (e#s) \<Longrightarrow> step s e"
+ by(ind_cases "vt (e#s)", simp)
+
+text {* \noindent
+ The following two auxiliary functions @{text "the_cs"} and @{text "the_th"} are used to extract
+ critical resource and thread respectively out of RAG nodes.
+ *}
+fun the_cs :: "node \<Rightarrow> cs"
+ where "the_cs (Cs cs) = cs"
+
+fun the_th :: "node \<Rightarrow> thread"
+ where "the_th (Th th) = th"
+
+text {* \noindent
+ The following predicate @{text "next_th"} describe the next thread to
+ take over when a critical resource is released. In @{text "next_th s th cs t"},
+ @{text "th"} is the thread to release, @{text "t"} is the one to take over.
+ Notice how this definition is backed up by the @{text "release"} function and its use
+ in the @{text "V"}-branch of @{text "schs"} function. This @{text "next_th"} function
+ is not needed for the execution of PIP. It is introduced as an auxiliary function
+ to state lemmas. The correctness of this definition will be confirmed by
+ lemmas @{text "step_v_hold_inv"}, @{text " step_v_wait_inv"},
+ @{text "step_v_get_hold"} and @{text "step_v_not_wait"}.
+ *}
+definition next_th:: "state \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> thread \<Rightarrow> bool"
+ where "next_th s th cs t = (\<exists> rest. wq s cs = th#rest \<and> rest \<noteq> [] \<and>
+ t = hd (SOME q. distinct q \<and> set q = set rest))"
+
+text {* \noindent
+ The aux function @{text "count Q l"} is used to count the occurrence of situation @{text "Q"}
+ in list @{text "l"}:
+ *}
+definition count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"
+ where "count Q l = length (filter Q l)"
+
+text {* \noindent
+ The following observation @{text "cntP s"} returns the number of operation @{text "P"} happened
+ before reaching state @{text "s"}.
+ *}
+definition cntP :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntP s th = count (\<lambda> e. \<exists> cs. e = P th cs) s"
+
+text {* \noindent
+ The following observation @{text "cntV s"} returns the number of operation @{text "V"} happened
+ before reaching state @{text "s"}.
+ *}
+definition cntV :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntV s th = count (\<lambda> e. \<exists> cs. e = V th cs) s"
+
+text {* @{text "the_preced"} is also the same as @{text "preced"}, the only
+ difference is the order of arguemts. *}
+definition "the_preced s th = preced th s"
+
+text {* @{term "the_thread"} extracts thread out of RAG node. *}
+fun the_thread :: "node \<Rightarrow> thread" where
+ "the_thread (Th th) = th"
+
+text {* The following @{text "wRAG"} is the waiting sub-graph of @{text "RAG"}. *}
+definition "wRAG (s::state) = {(Th th, Cs cs) | th cs. waiting s th cs}"
+
+text {* The following @{text "hRAG"} is the holding sub-graph of @{text "RAG"}. *}
+definition "hRAG (s::state) = {(Cs cs, Th th) | th cs. holding s th cs}"
+
+text {*
+ The following @{text "tRAG"} is the thread-graph derived from @{term "RAG"}.
+ It characterizes the dependency between threads when calculating current
+ precedences. It is defined as the composition of the above two sub-graphs,
+ names @{term "wRAG"} and @{term "hRAG"}.
+ *}
+definition "tRAG s = wRAG s O hRAG s"
+
+text {* The following lemma splits @{term "RAG"} graph into the above two sub-graphs. *}
+lemma RAG_split: "RAG s = (wRAG s \<union> hRAG s)"
+ by (unfold s_RAG_abv wRAG_def hRAG_def s_waiting_abv
+ s_holding_abv cs_RAG_def, auto)
+
+definition "cp_gen s x =
+ Max ((the_preced s \<circ> the_thread) ` subtree (tRAG s) x)"
+
+(*<*)
+
+end
+(*>*)
+
--- a/Precedence_ord.thy Wed May 14 11:52:53 2014 +0100
+++ b/Precedence_ord.thy Wed Jan 27 13:50:02 2016 +0000
@@ -14,6 +14,19 @@
(Prc fx sx, Prc fy sy) \<Rightarrow>
fx < fy \<or> (fx \<le> fy \<and> sy \<le> sx))"
+lemma preced_leI1[intro]:
+ assumes "fx < fy"
+ shows "Prc fx sx \<le> Prc fy sy"
+ using assms
+ by (simp add: precedence_le_def)
+
+lemma preced_leI2[intro]:
+ assumes "fx \<le> fy"
+ and "sy \<le> sx"
+ shows "Prc fx sx \<le> Prc fy sy"
+ using assms
+ by (simp add: precedence_le_def)
+
definition
precedence_less_def: "x < y \<longleftrightarrow> (case (x, y) of
(Prc fx sx, Prc fy sy) \<Rightarrow>
@@ -27,8 +40,19 @@
instance precedence :: preorder ..
-instance precedence :: linorder proof
+instance precedence :: linorder
+proof
qed (auto simp: precedence_le_def precedence_less_def
intro: order_trans split:precedence.splits)
+instantiation precedence :: zero
+begin
+
+definition Zero_precedence_def:
+ "0 = Prc 0 0"
+
+instance ..
+
end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Precedence_ord.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,45 @@
+header {* Order on product types *}
+
+theory Precedence_ord
+imports Main
+begin
+
+datatype precedence = Prc nat nat
+
+instantiation precedence :: order
+begin
+
+definition
+ precedence_le_def: "x \<le> y \<longleftrightarrow> (case (x, y) of
+ (Prc fx sx, Prc fy sy) \<Rightarrow>
+ fx < fy \<or> (fx \<le> fy \<and> sy \<le> sx))"
+
+definition
+ precedence_less_def: "x < y \<longleftrightarrow> (case (x, y) of
+ (Prc fx sx, Prc fy sy) \<Rightarrow>
+ fx < fy \<or> (fx \<le> fy \<and> sy < sx))"
+
+instance
+proof
+qed (auto simp: precedence_le_def precedence_less_def
+ intro: order_trans split:precedence.splits)
+end
+
+instance precedence :: preorder ..
+
+instance precedence :: linorder
+proof
+qed (auto simp: precedence_le_def precedence_less_def
+ intro: order_trans split:precedence.splits)
+
+instantiation precedence :: zero
+begin
+
+definition Zero_precedence_def:
+ "0 = Prc 0 0"
+
+instance ..
+
+end
+
+end
--- a/PrioG.thy Wed May 14 11:52:53 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,2865 +0,0 @@
-theory PrioG
-imports PrioGDef
-begin
-
-lemma runing_ready:
- shows "runing s \<subseteq> readys s"
- unfolding runing_def readys_def
- by auto
-
-lemma readys_threads:
- shows "readys s \<subseteq> threads s"
- unfolding readys_def
- by auto
-
-lemma wq_v_neq:
- "cs \<noteq> cs' \<Longrightarrow> wq (V thread cs#s) cs' = wq s cs'"
- by (auto simp:wq_def Let_def cp_def split:list.splits)
-
-lemma wq_distinct: "vt s \<Longrightarrow> distinct (wq s cs)"
-proof(erule_tac vt.induct, simp add:wq_def)
- fix s e
- assume h1: "step s e"
- and h2: "distinct (wq s cs)"
- thus "distinct (wq (e # s) cs)"
- proof(induct rule:step.induct, auto simp: wq_def Let_def split:list.splits)
- fix thread s
- assume h1: "(Cs cs, Th thread) \<notin> (depend s)\<^sup>+"
- and h2: "thread \<in> set (wq_fun (schs s) cs)"
- and h3: "thread \<in> runing s"
- show "False"
- proof -
- from h3 have "\<And> cs. thread \<in> set (wq_fun (schs s) cs) \<Longrightarrow>
- thread = hd ((wq_fun (schs s) cs))"
- by (simp add:runing_def readys_def s_waiting_def wq_def)
- from this [OF h2] have "thread = hd (wq_fun (schs s) cs)" .
- with h2
- have "(Cs cs, Th thread) \<in> (depend s)"
- by (simp add:s_depend_def s_holding_def wq_def cs_holding_def)
- with h1 show False by auto
- qed
- next
- fix thread s a list
- assume dst: "distinct list"
- show "distinct (SOME q. distinct q \<and> set q = set list)"
- proof(rule someI2)
- from dst show "distinct list \<and> set list = set list" by auto
- next
- fix q assume "distinct q \<and> set q = set list"
- thus "distinct q" by auto
- qed
- qed
-qed
-
-lemma step_back_vt: "vt (e#s) \<Longrightarrow> vt s"
- by(ind_cases "vt (e#s)", simp)
-
-lemma step_back_step: "vt (e#s) \<Longrightarrow> step s e"
- by(ind_cases "vt (e#s)", simp)
-
-lemma block_pre:
- fixes thread cs s
- assumes vt_e: "vt (e#s)"
- and s_ni: "thread \<notin> set (wq s cs)"
- and s_i: "thread \<in> set (wq (e#s) cs)"
- shows "e = P thread cs"
-proof -
- show ?thesis
- proof(cases e)
- case (P th cs)
- with assms
- show ?thesis
- by (auto simp:wq_def Let_def split:if_splits)
- next
- case (Create th prio)
- with assms show ?thesis
- by (auto simp:wq_def Let_def split:if_splits)
- next
- case (Exit th)
- with assms show ?thesis
- by (auto simp:wq_def Let_def split:if_splits)
- next
- case (Set th prio)
- with assms show ?thesis
- by (auto simp:wq_def Let_def split:if_splits)
- next
- case (V th cs)
- with assms show ?thesis
- apply (auto simp:wq_def Let_def split:if_splits)
- proof -
- fix q qs
- assume h1: "thread \<notin> set (wq_fun (schs s) cs)"
- and h2: "q # qs = wq_fun (schs s) cs"
- and h3: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
- and vt: "vt (V th cs # s)"
- from h1 and h2[symmetric] have "thread \<notin> set (q # qs)" by simp
- moreover have "thread \<in> set qs"
- proof -
- have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
- proof(rule someI2)
- from wq_distinct [OF step_back_vt[OF vt], of cs]
- and h2[symmetric, folded wq_def]
- show "distinct qs \<and> set qs = set qs" by auto
- next
- fix x assume "distinct x \<and> set x = set qs"
- thus "set x = set qs" by auto
- qed
- with h3 show ?thesis by simp
- qed
- ultimately show "False" by auto
- qed
- qed
-qed
-
-lemma p_pre: "\<lbrakk>vt ((P thread cs)#s)\<rbrakk> \<Longrightarrow>
- thread \<in> runing s \<and> (Cs cs, Th thread) \<notin> (depend s)^+"
-apply (ind_cases "vt ((P thread cs)#s)")
-apply (ind_cases "step s (P thread cs)")
-by auto
-
-lemma abs1:
- fixes e es
- assumes ein: "e \<in> set es"
- and neq: "hd es \<noteq> hd (es @ [x])"
- shows "False"
-proof -
- from ein have "es \<noteq> []" by auto
- then obtain e ess where "es = e # ess" by (cases es, auto)
- with neq show ?thesis by auto
-qed
-
-lemma q_head: "Q (hd es) \<Longrightarrow> hd es = hd [th\<leftarrow>es . Q th]"
- by (cases es, auto)
-
-inductive_cases evt_cons: "vt (a#s)"
-
-lemma abs2:
- assumes vt: "vt (e#s)"
- and inq: "thread \<in> set (wq s cs)"
- and nh: "thread = hd (wq s cs)"
- and qt: "thread \<noteq> hd (wq (e#s) cs)"
- and inq': "thread \<in> set (wq (e#s) cs)"
- shows "False"
-proof -
- from assms show "False"
- apply (cases e)
- apply ((simp split:if_splits add:Let_def wq_def)[1])+
- apply (insert abs1, fast)[1]
- apply (auto simp:wq_def simp:Let_def split:if_splits list.splits)
- proof -
- fix th qs
- assume vt: "vt (V th cs # s)"
- and th_in: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
- and eq_wq: "wq_fun (schs s) cs = thread # qs"
- show "False"
- proof -
- from wq_distinct[OF step_back_vt[OF vt], of cs]
- and eq_wq[folded wq_def] have "distinct (thread#qs)" by simp
- moreover have "thread \<in> set qs"
- proof -
- have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
- proof(rule someI2)
- from wq_distinct [OF step_back_vt[OF vt], of cs]
- and eq_wq [folded wq_def]
- show "distinct qs \<and> set qs = set qs" by auto
- next
- fix x assume "distinct x \<and> set x = set qs"
- thus "set x = set qs" by auto
- qed
- with th_in show ?thesis by auto
- qed
- ultimately show ?thesis by auto
- qed
- qed
-qed
-
-lemma vt_moment: "\<And> t. \<lbrakk>vt s\<rbrakk> \<Longrightarrow> vt (moment t s)"
-proof(induct s, simp)
- fix a s t
- assume h: "\<And>t.\<lbrakk>vt s\<rbrakk> \<Longrightarrow> vt (moment t s)"
- and vt_a: "vt (a # s)"
- show "vt (moment t (a # s))"
- proof(cases "t \<ge> length (a#s)")
- case True
- from True have "moment t (a#s) = a#s" by simp
- with vt_a show ?thesis by simp
- next
- case False
- hence le_t1: "t \<le> length s" by simp
- from vt_a have "vt s"
- by (erule_tac evt_cons, simp)
- from h [OF this] have "vt (moment t s)" .
- moreover have "moment t (a#s) = moment t s"
- proof -
- from moment_app [OF le_t1, of "[a]"]
- show ?thesis by simp
- qed
- ultimately show ?thesis by auto
- qed
-qed
-
-(* Wrong:
- lemma \<lbrakk>thread \<in> set (wq_fun cs1 s); thread \<in> set (wq_fun cs2 s)\<rbrakk> \<Longrightarrow> cs1 = cs2"
-*)
-
-lemma waiting_unique_pre:
- fixes cs1 cs2 s thread
- assumes vt: "vt s"
- and h11: "thread \<in> set (wq s cs1)"
- and h12: "thread \<noteq> hd (wq s cs1)"
- assumes h21: "thread \<in> set (wq s cs2)"
- and h22: "thread \<noteq> hd (wq s cs2)"
- and neq12: "cs1 \<noteq> cs2"
- shows "False"
-proof -
- let "?Q cs s" = "thread \<in> set (wq s cs) \<and> thread \<noteq> hd (wq s cs)"
- from h11 and h12 have q1: "?Q cs1 s" by simp
- from h21 and h22 have q2: "?Q cs2 s" by simp
- have nq1: "\<not> ?Q cs1 []" by (simp add:wq_def)
- have nq2: "\<not> ?Q cs2 []" by (simp add:wq_def)
- from p_split [of "?Q cs1", OF q1 nq1]
- obtain t1 where lt1: "t1 < length s"
- and np1: "\<not>(thread \<in> set (wq (moment t1 s) cs1) \<and>
- thread \<noteq> hd (wq (moment t1 s) cs1))"
- and nn1: "(\<forall>i'>t1. thread \<in> set (wq (moment i' s) cs1) \<and>
- thread \<noteq> hd (wq (moment i' s) cs1))" by auto
- from p_split [of "?Q cs2", OF q2 nq2]
- obtain t2 where lt2: "t2 < length s"
- and np2: "\<not>(thread \<in> set (wq (moment t2 s) cs2) \<and>
- thread \<noteq> hd (wq (moment t2 s) cs2))"
- and nn2: "(\<forall>i'>t2. thread \<in> set (wq (moment i' s) cs2) \<and>
- thread \<noteq> hd (wq (moment i' s) cs2))" by auto
- show ?thesis
- proof -
- {
- assume lt12: "t1 < t2"
- let ?t3 = "Suc t2"
- from lt2 have le_t3: "?t3 \<le> length s" by auto
- from moment_plus [OF this]
- obtain e where eq_m: "moment ?t3 s = e#moment t2 s" by auto
- have "t2 < ?t3" by simp
- from nn2 [rule_format, OF this] and eq_m
- have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
- h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
- have vt_e: "vt (e#moment t2 s)"
- proof -
- from vt_moment [OF vt]
- have "vt (moment ?t3 s)" .
- with eq_m show ?thesis by simp
- qed
- have ?thesis
- proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
- case True
- from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
- by auto
- from abs2 [OF vt_e True eq_th h2 h1]
- show ?thesis by auto
- next
- case False
- from block_pre [OF vt_e False h1]
- have "e = P thread cs2" .
- with vt_e have "vt ((P thread cs2)# moment t2 s)" by simp
- from p_pre [OF this] have "thread \<in> runing (moment t2 s)" by simp
- with runing_ready have "thread \<in> readys (moment t2 s)" by auto
- with nn1 [rule_format, OF lt12]
- show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
- qed
- } moreover {
- assume lt12: "t2 < t1"
- let ?t3 = "Suc t1"
- from lt1 have le_t3: "?t3 \<le> length s" by auto
- from moment_plus [OF this]
- obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
- have lt_t3: "t1 < ?t3" by simp
- from nn1 [rule_format, OF this] and eq_m
- have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
- h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
- have vt_e: "vt (e#moment t1 s)"
- proof -
- from vt_moment [OF vt]
- have "vt (moment ?t3 s)" .
- with eq_m show ?thesis by simp
- qed
- have ?thesis
- proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
- case True
- from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
- by auto
- from abs2 [OF vt_e True eq_th h2 h1]
- show ?thesis by auto
- next
- case False
- from block_pre [OF vt_e False h1]
- have "e = P thread cs1" .
- with vt_e have "vt ((P thread cs1)# moment t1 s)" by simp
- from p_pre [OF this] have "thread \<in> runing (moment t1 s)" by simp
- with runing_ready have "thread \<in> readys (moment t1 s)" by auto
- with nn2 [rule_format, OF lt12]
- show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
- qed
- } moreover {
- assume eqt12: "t1 = t2"
- let ?t3 = "Suc t1"
- from lt1 have le_t3: "?t3 \<le> length s" by auto
- from moment_plus [OF this]
- obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
- have lt_t3: "t1 < ?t3" by simp
- from nn1 [rule_format, OF this] and eq_m
- have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
- h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
- have vt_e: "vt (e#moment t1 s)"
- proof -
- from vt_moment [OF vt]
- have "vt (moment ?t3 s)" .
- with eq_m show ?thesis by simp
- qed
- have ?thesis
- proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
- case True
- from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
- by auto
- from abs2 [OF vt_e True eq_th h2 h1]
- show ?thesis by auto
- next
- case False
- from block_pre [OF vt_e False h1]
- have eq_e1: "e = P thread cs1" .
- have lt_t3: "t1 < ?t3" by simp
- with eqt12 have "t2 < ?t3" by simp
- from nn2 [rule_format, OF this] and eq_m and eqt12
- have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
- h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
- show ?thesis
- proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
- case True
- from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
- by auto
- from vt_e and eqt12 have "vt (e#moment t2 s)" by simp
- from abs2 [OF this True eq_th h2 h1]
- show ?thesis .
- next
- case False
- have vt_e: "vt (e#moment t2 s)"
- proof -
- from vt_moment [OF vt] eqt12
- have "vt (moment (Suc t2) s)" by auto
- with eq_m eqt12 show ?thesis by simp
- qed
- from block_pre [OF vt_e False h1]
- have "e = P thread cs2" .
- with eq_e1 neq12 show ?thesis by auto
- qed
- qed
- } ultimately show ?thesis by arith
- qed
-qed
-
-lemma waiting_unique:
- fixes s cs1 cs2
- assumes "vt s"
- and "waiting s th cs1"
- and "waiting s th cs2"
- shows "cs1 = cs2"
-using waiting_unique_pre assms
-unfolding wq_def s_waiting_def
-by auto
-
-(* not used *)
-lemma held_unique:
- fixes s::"state"
- assumes "holding s th1 cs"
- and "holding s th2 cs"
- shows "th1 = th2"
-using assms
-unfolding s_holding_def
-by auto
-
-
-lemma birthtime_lt: "th \<in> threads s \<Longrightarrow> birthtime th s < length s"
- apply (induct s, auto)
- by (case_tac a, auto split:if_splits)
-
-lemma birthtime_unique:
- "\<lbrakk>birthtime th1 s = birthtime th2 s; th1 \<in> threads s; th2 \<in> threads s\<rbrakk>
- \<Longrightarrow> th1 = th2"
- apply (induct s, auto)
- by (case_tac a, auto split:if_splits dest:birthtime_lt)
-
-lemma preced_unique :
- assumes pcd_eq: "preced th1 s = preced th2 s"
- and th_in1: "th1 \<in> threads s"
- and th_in2: " th2 \<in> threads s"
- shows "th1 = th2"
-proof -
- from pcd_eq have "birthtime th1 s = birthtime th2 s" by (simp add:preced_def)
- from birthtime_unique [OF this th_in1 th_in2]
- show ?thesis .
-qed
-
-lemma preced_linorder:
- assumes neq_12: "th1 \<noteq> th2"
- and th_in1: "th1 \<in> threads s"
- and th_in2: " th2 \<in> threads s"
- shows "preced th1 s < preced th2 s \<or> preced th1 s > preced th2 s"
-proof -
- from preced_unique [OF _ th_in1 th_in2] and neq_12
- have "preced th1 s \<noteq> preced th2 s" by auto
- thus ?thesis by auto
-qed
-
-lemma unique_minus:
- fixes x y z r
- assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
- and xy: "(x, y) \<in> r"
- and xz: "(x, z) \<in> r^+"
- and neq: "y \<noteq> z"
- shows "(y, z) \<in> r^+"
-proof -
- from xz and neq show ?thesis
- proof(induct)
- case (base ya)
- have "(x, ya) \<in> r" by fact
- from unique [OF xy this] have "y = ya" .
- with base show ?case by auto
- next
- case (step ya z)
- show ?case
- proof(cases "y = ya")
- case True
- from step True show ?thesis by simp
- next
- case False
- from step False
- show ?thesis by auto
- qed
- qed
-qed
-
-lemma unique_base:
- fixes r x y z
- assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
- and xy: "(x, y) \<in> r"
- and xz: "(x, z) \<in> r^+"
- and neq_yz: "y \<noteq> z"
- shows "(y, z) \<in> r^+"
-proof -
- from xz neq_yz show ?thesis
- proof(induct)
- case (base ya)
- from xy unique base show ?case by auto
- next
- case (step ya z)
- show ?case
- proof(cases "y = ya")
- case True
- from True step show ?thesis by auto
- next
- case False
- from False step
- have "(y, ya) \<in> r\<^sup>+" by auto
- with step show ?thesis by auto
- qed
- qed
-qed
-
-lemma unique_chain:
- fixes r x y z
- assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
- and xy: "(x, y) \<in> r^+"
- and xz: "(x, z) \<in> r^+"
- and neq_yz: "y \<noteq> z"
- shows "(y, z) \<in> r^+ \<or> (z, y) \<in> r^+"
-proof -
- from xy xz neq_yz show ?thesis
- proof(induct)
- case (base y)
- have h1: "(x, y) \<in> r" and h2: "(x, z) \<in> r\<^sup>+" and h3: "y \<noteq> z" using base by auto
- from unique_base [OF _ h1 h2 h3] and unique show ?case by auto
- next
- case (step y za)
- show ?case
- proof(cases "y = z")
- case True
- from True step show ?thesis by auto
- next
- case False
- from False step have "(y, z) \<in> r\<^sup>+ \<or> (z, y) \<in> r\<^sup>+" by auto
- thus ?thesis
- proof
- assume "(z, y) \<in> r\<^sup>+"
- with step have "(z, za) \<in> r\<^sup>+" by auto
- thus ?thesis by auto
- next
- assume h: "(y, z) \<in> r\<^sup>+"
- from step have yza: "(y, za) \<in> r" by simp
- from step have "za \<noteq> z" by simp
- from unique_minus [OF _ yza h this] and unique
- have "(za, z) \<in> r\<^sup>+" by auto
- thus ?thesis by auto
- qed
- qed
- qed
-qed
-
-lemma depend_set_unchanged: "(depend (Set th prio # s)) = depend s"
-apply (unfold s_depend_def s_waiting_def wq_def)
-by (simp add:Let_def)
-
-lemma depend_create_unchanged: "(depend (Create th prio # s)) = depend s"
-apply (unfold s_depend_def s_waiting_def wq_def)
-by (simp add:Let_def)
-
-lemma depend_exit_unchanged: "(depend (Exit th # s)) = depend s"
-apply (unfold s_depend_def s_waiting_def wq_def)
-by (simp add:Let_def)
-
-
-
-lemma step_v_hold_inv[elim_format]:
- "\<And>c t. \<lbrakk>vt (V th cs # s);
- \<not> holding (wq s) t c; holding (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow> next_th s th cs t \<and> c = cs"
-proof -
- fix c t
- assume vt: "vt (V th cs # s)"
- and nhd: "\<not> holding (wq s) t c"
- and hd: "holding (wq (V th cs # s)) t c"
- show "next_th s th cs t \<and> c = cs"
- proof(cases "c = cs")
- case False
- with nhd hd show ?thesis
- by (unfold cs_holding_def wq_def, auto simp:Let_def)
- next
- case True
- with step_back_step [OF vt]
- have "step s (V th c)" by simp
- hence "next_th s th cs t"
- proof(cases)
- assume "holding s th c"
- with nhd hd show ?thesis
- apply (unfold s_holding_def cs_holding_def wq_def next_th_def,
- auto simp:Let_def split:list.splits if_splits)
- proof -
- assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
- moreover have "\<dots> = set []"
- proof(rule someI2)
- show "distinct [] \<and> [] = []" by auto
- next
- fix x assume "distinct x \<and> x = []"
- thus "set x = set []" by auto
- qed
- ultimately show False by auto
- next
- assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
- moreover have "\<dots> = set []"
- proof(rule someI2)
- show "distinct [] \<and> [] = []" by auto
- next
- fix x assume "distinct x \<and> x = []"
- thus "set x = set []" by auto
- qed
- ultimately show False by auto
- qed
- qed
- with True show ?thesis by auto
- qed
-qed
-
-lemma step_v_wait_inv[elim_format]:
- "\<And>t c. \<lbrakk>vt (V th cs # s); \<not> waiting (wq (V th cs # s)) t c; waiting (wq s) t c
- \<rbrakk>
- \<Longrightarrow> (next_th s th cs t \<and> cs = c)"
-proof -
- fix t c
- assume vt: "vt (V th cs # s)"
- and nw: "\<not> waiting (wq (V th cs # s)) t c"
- and wt: "waiting (wq s) t c"
- show "next_th s th cs t \<and> cs = c"
- proof(cases "cs = c")
- case False
- with nw wt show ?thesis
- by (auto simp:cs_waiting_def wq_def Let_def)
- next
- case True
- from nw[folded True] wt[folded True]
- have "next_th s th cs t"
- apply (unfold next_th_def, auto simp:cs_waiting_def wq_def Let_def split:list.splits)
- proof -
- fix a list
- assume t_in: "t \<in> set list"
- and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
- and eq_wq: "wq_fun (schs s) cs = a # list"
- have " set (SOME q. distinct q \<and> set q = set list) = set list"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vt], of cs] and eq_wq[folded wq_def]
- show "distinct list \<and> set list = set list" by auto
- next
- show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
- by auto
- qed
- with t_ni and t_in show "a = th" by auto
- next
- fix a list
- assume t_in: "t \<in> set list"
- and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
- and eq_wq: "wq_fun (schs s) cs = a # list"
- have " set (SOME q. distinct q \<and> set q = set list) = set list"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vt], of cs] and eq_wq[folded wq_def]
- show "distinct list \<and> set list = set list" by auto
- next
- show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
- by auto
- qed
- with t_ni and t_in show "t = hd (SOME q. distinct q \<and> set q = set list)" by auto
- next
- fix a list
- assume eq_wq: "wq_fun (schs s) cs = a # list"
- from step_back_step[OF vt]
- show "a = th"
- proof(cases)
- assume "holding s th cs"
- with eq_wq show ?thesis
- by (unfold s_holding_def wq_def, auto)
- qed
- qed
- with True show ?thesis by simp
- qed
-qed
-
-lemma step_v_not_wait[consumes 3]:
- "\<lbrakk>vt (V th cs # s); next_th s th cs t; waiting (wq (V th cs # s)) t cs\<rbrakk> \<Longrightarrow> False"
- by (unfold next_th_def cs_waiting_def wq_def, auto simp:Let_def)
-
-lemma step_v_release:
- "\<lbrakk>vt (V th cs # s); holding (wq (V th cs # s)) th cs\<rbrakk> \<Longrightarrow> False"
-proof -
- assume vt: "vt (V th cs # s)"
- and hd: "holding (wq (V th cs # s)) th cs"
- from step_back_step [OF vt] and hd
- show "False"
- proof(cases)
- assume "holding (wq (V th cs # s)) th cs" and "holding s th cs"
- thus ?thesis
- apply (unfold s_holding_def wq_def cs_holding_def)
- apply (auto simp:Let_def split:list.splits)
- proof -
- fix list
- assume eq_wq[folded wq_def]:
- "wq_fun (schs s) cs = hd (SOME q. distinct q \<and> set q = set list) # list"
- and hd_in: "hd (SOME q. distinct q \<and> set q = set list)
- \<in> set (SOME q. distinct q \<and> set q = set list)"
- have "set (SOME q. distinct q \<and> set q = set list) = set list"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vt], of cs] and eq_wq
- show "distinct list \<and> set list = set list" by auto
- next
- show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
- by auto
- qed
- moreover have "distinct (hd (SOME q. distinct q \<and> set q = set list) # list)"
- proof -
- from wq_distinct[OF step_back_vt[OF vt], of cs] and eq_wq
- show ?thesis by auto
- qed
- moreover note eq_wq and hd_in
- ultimately show "False" by auto
- qed
- qed
-qed
-
-lemma step_v_get_hold:
- "\<And>th'. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) th' cs; next_th s th cs th'\<rbrakk> \<Longrightarrow> False"
- apply (unfold cs_holding_def next_th_def wq_def,
- auto simp:Let_def)
-proof -
- fix rest
- assume vt: "vt (V th cs # s)"
- and eq_wq[folded wq_def]: " wq_fun (schs s) cs = th # rest"
- and nrest: "rest \<noteq> []"
- and ni: "hd (SOME q. distinct q \<and> set q = set rest)
- \<notin> set (SOME q. distinct q \<and> set q = set rest)"
- have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vt], of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x assume "distinct x \<and> set x = set rest"
- hence "set x = set rest" by auto
- with nrest
- show "x \<noteq> []" by (case_tac x, auto)
- qed
- with ni show "False" by auto
-qed
-
-lemma step_v_release_inv[elim_format]:
-"\<And>c t. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) t c; holding (wq s) t c\<rbrakk> \<Longrightarrow>
- c = cs \<and> t = th"
- apply (unfold cs_holding_def wq_def, auto simp:Let_def split:if_splits list.splits)
- proof -
- fix a list
- assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
- from step_back_step [OF vt] show "a = th"
- proof(cases)
- assume "holding s th cs" with eq_wq
- show ?thesis
- by (unfold s_holding_def wq_def, auto)
- qed
- next
- fix a list
- assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
- from step_back_step [OF vt] show "a = th"
- proof(cases)
- assume "holding s th cs" with eq_wq
- show ?thesis
- by (unfold s_holding_def wq_def, auto)
- qed
- qed
-
-lemma step_v_waiting_mono:
- "\<And>t c. \<lbrakk>vt (V th cs # s); waiting (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow> waiting (wq s) t c"
-proof -
- fix t c
- let ?s' = "(V th cs # s)"
- assume vt: "vt ?s'"
- and wt: "waiting (wq ?s') t c"
- show "waiting (wq s) t c"
- proof(cases "c = cs")
- case False
- assume neq_cs: "c \<noteq> cs"
- hence "waiting (wq ?s') t c = waiting (wq s) t c"
- by (unfold cs_waiting_def wq_def, auto simp:Let_def)
- with wt show ?thesis by simp
- next
- case True
- with wt show ?thesis
- apply (unfold cs_waiting_def wq_def, auto simp:Let_def split:list.splits)
- proof -
- fix a list
- assume not_in: "t \<notin> set list"
- and is_in: "t \<in> set (SOME q. distinct q \<and> set q = set list)"
- and eq_wq: "wq_fun (schs s) cs = a # list"
- have "set (SOME q. distinct q \<and> set q = set list) = set list"
- proof(rule someI2)
- from wq_distinct [OF step_back_vt[OF vt], of cs]
- and eq_wq[folded wq_def]
- show "distinct list \<and> set list = set list" by auto
- next
- fix x assume "distinct x \<and> set x = set list"
- thus "set x = set list" by auto
- qed
- with not_in is_in show "t = a" by auto
- next
- fix list
- assume is_waiting: "waiting (wq (V th cs # s)) t cs"
- and eq_wq: "wq_fun (schs s) cs = t # list"
- hence "t \<in> set list"
- apply (unfold wq_def, auto simp:Let_def cs_waiting_def)
- proof -
- assume " t \<in> set (SOME q. distinct q \<and> set q = set list)"
- moreover have "\<dots> = set list"
- proof(rule someI2)
- from wq_distinct [OF step_back_vt[OF vt], of cs]
- and eq_wq[folded wq_def]
- show "distinct list \<and> set list = set list" by auto
- next
- fix x assume "distinct x \<and> set x = set list"
- thus "set x = set list" by auto
- qed
- ultimately show "t \<in> set list" by simp
- qed
- with eq_wq and wq_distinct [OF step_back_vt[OF vt], of cs, unfolded wq_def]
- show False by auto
- qed
- qed
-qed
-
-lemma step_depend_v:
-fixes th::thread
-assumes vt:
- "vt (V th cs#s)"
-shows "
- depend (V th cs # s) =
- depend s - {(Cs cs, Th th)} -
- {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
- {(Cs cs, Th th') |th'. next_th s th cs th'}"
- apply (insert vt, unfold s_depend_def)
- apply (auto split:if_splits list.splits simp:Let_def)
- apply (auto elim: step_v_waiting_mono step_v_hold_inv
- step_v_release step_v_wait_inv
- step_v_get_hold step_v_release_inv)
- apply (erule_tac step_v_not_wait, auto)
- done
-
-lemma step_depend_p:
- "vt (P th cs#s) \<Longrightarrow>
- depend (P th cs # s) = (if (wq s cs = []) then depend s \<union> {(Cs cs, Th th)}
- else depend s \<union> {(Th th, Cs cs)})"
- apply(simp only: s_depend_def wq_def)
- apply (auto split:list.splits prod.splits simp:Let_def wq_def cs_waiting_def cs_holding_def)
- apply(case_tac "csa = cs", auto)
- apply(fold wq_def)
- apply(drule_tac step_back_step)
- apply(ind_cases " step s (P (hd (wq s cs)) cs)")
- apply(auto simp:s_depend_def wq_def cs_holding_def)
- done
-
-lemma simple_A:
- fixes A
- assumes h: "\<And> x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> x = y"
- shows "A = {} \<or> (\<exists> a. A = {a})"
-proof(cases "A = {}")
- case True thus ?thesis by simp
-next
- case False then obtain a where "a \<in> A" by auto
- with h have "A = {a}" by auto
- thus ?thesis by simp
-qed
-
-lemma depend_target_th: "(Th th, x) \<in> depend (s::state) \<Longrightarrow> \<exists> cs. x = Cs cs"
- by (unfold s_depend_def, auto)
-
-lemma acyclic_depend:
- fixes s
- assumes vt: "vt s"
- shows "acyclic (depend s)"
-proof -
- from vt show ?thesis
- proof(induct)
- case (vt_cons s e)
- assume ih: "acyclic (depend s)"
- and stp: "step s e"
- and vt: "vt s"
- show ?case
- proof(cases e)
- case (Create th prio)
- with ih
- show ?thesis by (simp add:depend_create_unchanged)
- next
- case (Exit th)
- with ih show ?thesis by (simp add:depend_exit_unchanged)
- next
- case (V th cs)
- from V vt stp have vtt: "vt (V th cs#s)" by auto
- from step_depend_v [OF this]
- have eq_de:
- "depend (e # s) =
- depend s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
- {(Cs cs, Th th') |th'. next_th s th cs th'}"
- (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
- from ih have ac: "acyclic (?A - ?B - ?C)" by (auto elim:acyclic_subset)
- from step_back_step [OF vtt]
- have "step s (V th cs)" .
- thus ?thesis
- proof(cases)
- assume "holding s th cs"
- hence th_in: "th \<in> set (wq s cs)" and
- eq_hd: "th = hd (wq s cs)" unfolding s_holding_def wq_def by auto
- then obtain rest where
- eq_wq: "wq s cs = th#rest"
- by (cases "wq s cs", auto)
- show ?thesis
- proof(cases "rest = []")
- case False
- let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
- from eq_wq False have eq_D: "?D = {(Cs cs, Th ?th')}"
- by (unfold next_th_def, auto)
- let ?E = "(?A - ?B - ?C)"
- have "(Th ?th', Cs cs) \<notin> ?E\<^sup>*"
- proof
- assume "(Th ?th', Cs cs) \<in> ?E\<^sup>*"
- hence " (Th ?th', Cs cs) \<in> ?E\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
- from tranclD [OF this]
- obtain x where th'_e: "(Th ?th', x) \<in> ?E" by blast
- hence th_d: "(Th ?th', x) \<in> ?A" by simp
- from depend_target_th [OF this]
- obtain cs' where eq_x: "x = Cs cs'" by auto
- with th_d have "(Th ?th', Cs cs') \<in> ?A" by simp
- hence wt_th': "waiting s ?th' cs'"
- unfolding s_depend_def s_waiting_def cs_waiting_def wq_def by simp
- hence "cs' = cs"
- proof(rule waiting_unique [OF vt])
- from eq_wq wq_distinct[OF vt, of cs]
- show "waiting s ?th' cs"
- apply (unfold s_waiting_def wq_def, auto)
- proof -
- assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
- and eq_wq: "wq_fun (schs s) cs = th # rest"
- have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
- next
- fix x assume "distinct x \<and> set x = set rest"
- with False show "x \<noteq> []" by auto
- qed
- hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
- set (SOME q. distinct q \<and> set q = set rest)" by auto
- moreover have "\<dots> = set rest"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
- qed
- moreover note hd_in
- ultimately show "hd (SOME q. distinct q \<and> set q = set rest) = th" by auto
- next
- assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
- and eq_wq: "wq s cs = hd (SOME q. distinct q \<and> set q = set rest) # rest"
- have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x assume "distinct x \<and> set x = set rest"
- with False show "x \<noteq> []" by auto
- qed
- hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
- set (SOME q. distinct q \<and> set q = set rest)" by auto
- moreover have "\<dots> = set rest"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
- qed
- moreover note hd_in
- ultimately show False by auto
- qed
- qed
- with th'_e eq_x have "(Th ?th', Cs cs) \<in> ?E" by simp
- with False
- show "False" by (auto simp: next_th_def eq_wq)
- qed
- with acyclic_insert[symmetric] and ac
- and eq_de eq_D show ?thesis by auto
- next
- case True
- with eq_wq
- have eq_D: "?D = {}"
- by (unfold next_th_def, auto)
- with eq_de ac
- show ?thesis by auto
- qed
- qed
- next
- case (P th cs)
- from P vt stp have vtt: "vt (P th cs#s)" by auto
- from step_depend_p [OF this] P
- have "depend (e # s) =
- (if wq s cs = [] then depend s \<union> {(Cs cs, Th th)} else
- depend s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
- by simp
- moreover have "acyclic ?R"
- proof(cases "wq s cs = []")
- case True
- hence eq_r: "?R = depend s \<union> {(Cs cs, Th th)}" by simp
- have "(Th th, Cs cs) \<notin> (depend s)\<^sup>*"
- proof
- assume "(Th th, Cs cs) \<in> (depend s)\<^sup>*"
- hence "(Th th, Cs cs) \<in> (depend s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
- from tranclD2 [OF this]
- obtain x where "(x, Cs cs) \<in> depend s" by auto
- with True show False by (auto simp:s_depend_def cs_waiting_def)
- qed
- with acyclic_insert ih eq_r show ?thesis by auto
- next
- case False
- hence eq_r: "?R = depend s \<union> {(Th th, Cs cs)}" by simp
- have "(Cs cs, Th th) \<notin> (depend s)\<^sup>*"
- proof
- assume "(Cs cs, Th th) \<in> (depend s)\<^sup>*"
- hence "(Cs cs, Th th) \<in> (depend s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
- moreover from step_back_step [OF vtt] have "step s (P th cs)" .
- ultimately show False
- proof -
- show " \<lbrakk>(Cs cs, Th th) \<in> (depend s)\<^sup>+; step s (P th cs)\<rbrakk> \<Longrightarrow> False"
- by (ind_cases "step s (P th cs)", simp)
- qed
- qed
- with acyclic_insert ih eq_r show ?thesis by auto
- qed
- ultimately show ?thesis by simp
- next
- case (Set thread prio)
- with ih
- thm depend_set_unchanged
- show ?thesis by (simp add:depend_set_unchanged)
- qed
- next
- case vt_nil
- show "acyclic (depend ([]::state))"
- by (auto simp: s_depend_def cs_waiting_def
- cs_holding_def wq_def acyclic_def)
- qed
-qed
-
-lemma finite_depend:
- fixes s
- assumes vt: "vt s"
- shows "finite (depend s)"
-proof -
- from vt show ?thesis
- proof(induct)
- case (vt_cons s e)
- assume ih: "finite (depend s)"
- and stp: "step s e"
- and vt: "vt s"
- show ?case
- proof(cases e)
- case (Create th prio)
- with ih
- show ?thesis by (simp add:depend_create_unchanged)
- next
- case (Exit th)
- with ih show ?thesis by (simp add:depend_exit_unchanged)
- next
- case (V th cs)
- from V vt stp have vtt: "vt (V th cs#s)" by auto
- from step_depend_v [OF this]
- have eq_de: "depend (e # s) =
- depend s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
- {(Cs cs, Th th') |th'. next_th s th cs th'}
-"
- (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
- moreover from ih have ac: "finite (?A - ?B - ?C)" by simp
- moreover have "finite ?D"
- proof -
- have "?D = {} \<or> (\<exists> a. ?D = {a})"
- by (unfold next_th_def, auto)
- thus ?thesis
- proof
- assume h: "?D = {}"
- show ?thesis by (unfold h, simp)
- next
- assume "\<exists> a. ?D = {a}"
- thus ?thesis
- by (metis finite.simps)
- qed
- qed
- ultimately show ?thesis by simp
- next
- case (P th cs)
- from P vt stp have vtt: "vt (P th cs#s)" by auto
- from step_depend_p [OF this] P
- have "depend (e # s) =
- (if wq s cs = [] then depend s \<union> {(Cs cs, Th th)} else
- depend s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
- by simp
- moreover have "finite ?R"
- proof(cases "wq s cs = []")
- case True
- hence eq_r: "?R = depend s \<union> {(Cs cs, Th th)}" by simp
- with True and ih show ?thesis by auto
- next
- case False
- hence "?R = depend s \<union> {(Th th, Cs cs)}" by simp
- with False and ih show ?thesis by auto
- qed
- ultimately show ?thesis by auto
- next
- case (Set thread prio)
- with ih
- show ?thesis by (simp add:depend_set_unchanged)
- qed
- next
- case vt_nil
- show "finite (depend ([]::state))"
- by (auto simp: s_depend_def cs_waiting_def
- cs_holding_def wq_def acyclic_def)
- qed
-qed
-
-text {* Several useful lemmas *}
-
-lemma wf_dep_converse:
- fixes s
- assumes vt: "vt s"
- shows "wf ((depend s)^-1)"
-proof(rule finite_acyclic_wf_converse)
- from finite_depend [OF vt]
- show "finite (depend s)" .
-next
- from acyclic_depend[OF vt]
- show "acyclic (depend s)" .
-qed
-
-lemma hd_np_in: "x \<in> set l \<Longrightarrow> hd l \<in> set l"
-by (induct l, auto)
-
-lemma th_chasing: "(Th th, Cs cs) \<in> depend (s::state) \<Longrightarrow> \<exists> th'. (Cs cs, Th th') \<in> depend s"
- by (auto simp:s_depend_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
-
-lemma wq_threads:
- fixes s cs
- assumes vt: "vt s"
- and h: "th \<in> set (wq s cs)"
- shows "th \<in> threads s"
-proof -
- from vt and h show ?thesis
- proof(induct arbitrary: th cs)
- case (vt_cons s e)
- assume ih: "\<And>th cs. th \<in> set (wq s cs) \<Longrightarrow> th \<in> threads s"
- and stp: "step s e"
- and vt: "vt s"
- and h: "th \<in> set (wq (e # s) cs)"
- show ?case
- proof(cases e)
- case (Create th' prio)
- with ih h show ?thesis
- by (auto simp:wq_def Let_def)
- next
- case (Exit th')
- with stp ih h show ?thesis
- apply (auto simp:wq_def Let_def)
- apply (ind_cases "step s (Exit th')")
- apply (auto simp:runing_def readys_def s_holding_def s_waiting_def holdents_def
- s_depend_def s_holding_def cs_holding_def)
- done
- next
- case (V th' cs')
- show ?thesis
- proof(cases "cs' = cs")
- case False
- with h
- show ?thesis
- apply(unfold wq_def V, auto simp:Let_def V split:prod.splits, fold wq_def)
- by (drule_tac ih, simp)
- next
- case True
- from h
- show ?thesis
- proof(unfold V wq_def)
- assume th_in: "th \<in> set (wq_fun (schs (V th' cs' # s)) cs)" (is "th \<in> set ?l")
- show "th \<in> threads (V th' cs' # s)"
- proof(cases "cs = cs'")
- case False
- hence "?l = wq_fun (schs s) cs" by (simp add:Let_def)
- with th_in have " th \<in> set (wq s cs)"
- by (fold wq_def, simp)
- from ih [OF this] show ?thesis by simp
- next
- case True
- show ?thesis
- proof(cases "wq_fun (schs s) cs'")
- case Nil
- with h V show ?thesis
- apply (auto simp:wq_def Let_def split:if_splits)
- by (fold wq_def, drule_tac ih, simp)
- next
- case (Cons a rest)
- assume eq_wq: "wq_fun (schs s) cs' = a # rest"
- with h V show ?thesis
- apply (auto simp:Let_def wq_def split:if_splits)
- proof -
- assume th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
- have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs'] and eq_wq[folded wq_def]
- show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
- by auto
- qed
- with eq_wq th_in have "th \<in> set (wq_fun (schs s) cs')" by auto
- from ih[OF this[folded wq_def]] show "th \<in> threads s" .
- next
- assume th_in: "th \<in> set (wq_fun (schs s) cs)"
- from ih[OF this[folded wq_def]]
- show "th \<in> threads s" .
- qed
- qed
- qed
- qed
- qed
- next
- case (P th' cs')
- from h stp
- show ?thesis
- apply (unfold P wq_def)
- apply (auto simp:Let_def split:if_splits, fold wq_def)
- apply (auto intro:ih)
- apply(ind_cases "step s (P th' cs')")
- by (unfold runing_def readys_def, auto)
- next
- case (Set thread prio)
- with ih h show ?thesis
- by (auto simp:wq_def Let_def)
- qed
- next
- case vt_nil
- thus ?case by (auto simp:wq_def)
- qed
-qed
-
-lemma range_in: "\<lbrakk>vt s; (Th th) \<in> Range (depend (s::state))\<rbrakk> \<Longrightarrow> th \<in> threads s"
- apply(unfold s_depend_def cs_waiting_def cs_holding_def)
- by (auto intro:wq_threads)
-
-lemma readys_v_eq:
- fixes th thread cs rest
- assumes vt: "vt s"
- and neq_th: "th \<noteq> thread"
- and eq_wq: "wq s cs = thread#rest"
- and not_in: "th \<notin> set rest"
- shows "(th \<in> readys (V thread cs#s)) = (th \<in> readys s)"
-proof -
- from assms show ?thesis
- apply (auto simp:readys_def)
- apply(simp add:s_waiting_def[folded wq_def])
- apply (erule_tac x = csa in allE)
- apply (simp add:s_waiting_def wq_def Let_def split:if_splits)
- apply (case_tac "csa = cs", simp)
- apply (erule_tac x = cs in allE)
- apply(auto simp add: s_waiting_def[folded wq_def] Let_def split: list.splits)
- apply(auto simp add: wq_def)
- apply (auto simp:s_waiting_def wq_def Let_def split:list.splits)
- proof -
- assume th_nin: "th \<notin> set rest"
- and th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
- and eq_wq: "wq_fun (schs s) cs = thread # rest"
- have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
- proof(rule someI2)
- from wq_distinct[OF vt, of cs, unfolded wq_def] and eq_wq[unfolded wq_def]
- show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
- qed
- with th_nin th_in show False by auto
- qed
-qed
-
-lemma chain_building:
- assumes vt: "vt s"
- shows "node \<in> Domain (depend s) \<longrightarrow> (\<exists> th'. th' \<in> readys s \<and> (node, Th th') \<in> (depend s)^+)"
-proof -
- from wf_dep_converse [OF vt]
- have h: "wf ((depend s)\<inverse>)" .
- show ?thesis
- proof(induct rule:wf_induct [OF h])
- fix x
- assume ih [rule_format]:
- "\<forall>y. (y, x) \<in> (depend s)\<inverse> \<longrightarrow>
- y \<in> Domain (depend s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (y, Th th') \<in> (depend s)\<^sup>+)"
- show "x \<in> Domain (depend s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (depend s)\<^sup>+)"
- proof
- assume x_d: "x \<in> Domain (depend s)"
- show "\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (depend s)\<^sup>+"
- proof(cases x)
- case (Th th)
- from x_d Th obtain cs where x_in: "(Th th, Cs cs) \<in> depend s" by (auto simp:s_depend_def)
- with Th have x_in_r: "(Cs cs, x) \<in> (depend s)^-1" by simp
- from th_chasing [OF x_in] obtain th' where "(Cs cs, Th th') \<in> depend s" by blast
- hence "Cs cs \<in> Domain (depend s)" by auto
- from ih [OF x_in_r this] obtain th'
- where th'_ready: " th' \<in> readys s" and cs_in: "(Cs cs, Th th') \<in> (depend s)\<^sup>+" by auto
- have "(x, Th th') \<in> (depend s)\<^sup>+" using Th x_in cs_in by auto
- with th'_ready show ?thesis by auto
- next
- case (Cs cs)
- from x_d Cs obtain th' where th'_d: "(Th th', x) \<in> (depend s)^-1" by (auto simp:s_depend_def)
- show ?thesis
- proof(cases "th' \<in> readys s")
- case True
- from True and th'_d show ?thesis by auto
- next
- case False
- from th'_d and range_in [OF vt] have "th' \<in> threads s" by auto
- with False have "Th th' \<in> Domain (depend s)"
- by (auto simp:readys_def wq_def s_waiting_def s_depend_def cs_waiting_def Domain_def)
- from ih [OF th'_d this]
- obtain th'' where
- th''_r: "th'' \<in> readys s" and
- th''_in: "(Th th', Th th'') \<in> (depend s)\<^sup>+" by auto
- from th'_d and th''_in
- have "(x, Th th'') \<in> (depend s)\<^sup>+" by auto
- with th''_r show ?thesis by auto
- qed
- qed
- qed
- qed
-qed
-
-lemma th_chain_to_ready:
- fixes s th
- assumes vt: "vt s"
- and th_in: "th \<in> threads s"
- shows "th \<in> readys s \<or> (\<exists> th'. th' \<in> readys s \<and> (Th th, Th th') \<in> (depend s)^+)"
-proof(cases "th \<in> readys s")
- case True
- thus ?thesis by auto
-next
- case False
- from False and th_in have "Th th \<in> Domain (depend s)"
- by (auto simp:readys_def s_waiting_def s_depend_def wq_def cs_waiting_def Domain_def)
- from chain_building [rule_format, OF vt this]
- show ?thesis by auto
-qed
-
-lemma waiting_eq: "waiting s th cs = waiting (wq s) th cs"
- by (unfold s_waiting_def cs_waiting_def wq_def, auto)
-
-lemma holding_eq: "holding (s::state) th cs = holding (wq s) th cs"
- by (unfold s_holding_def wq_def cs_holding_def, simp)
-
-lemma holding_unique: "\<lbrakk>holding (s::state) th1 cs; holding s th2 cs\<rbrakk> \<Longrightarrow> th1 = th2"
- by (unfold s_holding_def cs_holding_def, auto)
-
-lemma unique_depend: "\<lbrakk>vt s; (n, n1) \<in> depend s; (n, n2) \<in> depend s\<rbrakk> \<Longrightarrow> n1 = n2"
- apply(unfold s_depend_def, auto, fold waiting_eq holding_eq)
- by(auto elim:waiting_unique holding_unique)
-
-lemma trancl_split: "(a, b) \<in> r^+ \<Longrightarrow> \<exists> c. (a, c) \<in> r"
-by (induct rule:trancl_induct, auto)
-
-lemma dchain_unique:
- assumes vt: "vt s"
- and th1_d: "(n, Th th1) \<in> (depend s)^+"
- and th1_r: "th1 \<in> readys s"
- and th2_d: "(n, Th th2) \<in> (depend s)^+"
- and th2_r: "th2 \<in> readys s"
- shows "th1 = th2"
-proof -
- { assume neq: "th1 \<noteq> th2"
- hence "Th th1 \<noteq> Th th2" by simp
- from unique_chain [OF _ th1_d th2_d this] and unique_depend [OF vt]
- have "(Th th1, Th th2) \<in> (depend s)\<^sup>+ \<or> (Th th2, Th th1) \<in> (depend s)\<^sup>+" by auto
- hence "False"
- proof
- assume "(Th th1, Th th2) \<in> (depend s)\<^sup>+"
- from trancl_split [OF this]
- obtain n where dd: "(Th th1, n) \<in> depend s" by auto
- then obtain cs where eq_n: "n = Cs cs"
- by (auto simp:s_depend_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
- from dd eq_n have "th1 \<notin> readys s"
- by (auto simp:readys_def s_depend_def wq_def s_waiting_def cs_waiting_def)
- with th1_r show ?thesis by auto
- next
- assume "(Th th2, Th th1) \<in> (depend s)\<^sup>+"
- from trancl_split [OF this]
- obtain n where dd: "(Th th2, n) \<in> depend s" by auto
- then obtain cs where eq_n: "n = Cs cs"
- by (auto simp:s_depend_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
- from dd eq_n have "th2 \<notin> readys s"
- by (auto simp:readys_def wq_def s_depend_def s_waiting_def cs_waiting_def)
- with th2_r show ?thesis by auto
- qed
- } thus ?thesis by auto
-qed
-
-
-lemma step_holdents_p_add:
- fixes th cs s
- assumes vt: "vt (P th cs#s)"
- and "wq s cs = []"
- shows "holdents (P th cs#s) th = holdents s th \<union> {cs}"
-proof -
- from assms show ?thesis
- unfolding holdents_test step_depend_p[OF vt] by (auto)
-qed
-
-lemma step_holdents_p_eq:
- fixes th cs s
- assumes vt: "vt (P th cs#s)"
- and "wq s cs \<noteq> []"
- shows "holdents (P th cs#s) th = holdents s th"
-proof -
- from assms show ?thesis
- unfolding holdents_test step_depend_p[OF vt] by auto
-qed
-
-
-lemma finite_holding:
- fixes s th cs
- assumes vt: "vt s"
- shows "finite (holdents s th)"
-proof -
- let ?F = "\<lambda> (x, y). the_cs x"
- from finite_depend [OF vt]
- have "finite (depend s)" .
- hence "finite (?F `(depend s))" by simp
- moreover have "{cs . (Cs cs, Th th) \<in> depend s} \<subseteq> \<dots>"
- proof -
- { have h: "\<And> a A f. a \<in> A \<Longrightarrow> f a \<in> f ` A" by auto
- fix x assume "(Cs x, Th th) \<in> depend s"
- hence "?F (Cs x, Th th) \<in> ?F `(depend s)" by (rule h)
- moreover have "?F (Cs x, Th th) = x" by simp
- ultimately have "x \<in> (\<lambda>(x, y). the_cs x) ` depend s" by simp
- } thus ?thesis by auto
- qed
- ultimately show ?thesis by (unfold holdents_test, auto intro:finite_subset)
-qed
-
-lemma cntCS_v_dec:
- fixes s thread cs
- assumes vtv: "vt (V thread cs#s)"
- shows "(cntCS (V thread cs#s) thread + 1) = cntCS s thread"
-proof -
- from step_back_step[OF vtv]
- have cs_in: "cs \<in> holdents s thread"
- apply (cases, unfold holdents_test s_depend_def, simp)
- by (unfold cs_holding_def s_holding_def wq_def, auto)
- moreover have cs_not_in:
- "(holdents (V thread cs#s) thread) = holdents s thread - {cs}"
- apply (insert wq_distinct[OF step_back_vt[OF vtv], of cs])
- apply (unfold holdents_test, unfold step_depend_v[OF vtv],
- auto simp:next_th_def)
- proof -
- fix rest
- assume dst: "distinct (rest::thread list)"
- and ne: "rest \<noteq> []"
- and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
- moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
- proof(rule someI2)
- from dst show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
- qed
- ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
- set (SOME q. distinct q \<and> set q = set rest)" by simp
- moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from dst show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x assume " distinct x \<and> set x = set rest" with ne
- show "x \<noteq> []" by auto
- qed
- ultimately
- show "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> depend s"
- by auto
- next
- fix rest
- assume dst: "distinct (rest::thread list)"
- and ne: "rest \<noteq> []"
- and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
- moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
- proof(rule someI2)
- from dst show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
- qed
- ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
- set (SOME q. distinct q \<and> set q = set rest)" by simp
- moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from dst show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x assume " distinct x \<and> set x = set rest" with ne
- show "x \<noteq> []" by auto
- qed
- ultimately show "False" by auto
- qed
- ultimately
- have "holdents s thread = insert cs (holdents (V thread cs#s) thread)"
- by auto
- moreover have "card \<dots> =
- Suc (card ((holdents (V thread cs#s) thread) - {cs}))"
- proof(rule card_insert)
- from finite_holding [OF vtv]
- show " finite (holdents (V thread cs # s) thread)" .
- qed
- moreover from cs_not_in
- have "cs \<notin> (holdents (V thread cs#s) thread)" by auto
- ultimately show ?thesis by (simp add:cntCS_def)
-qed
-
-lemma cnp_cnv_cncs:
- fixes s th
- assumes vt: "vt s"
- shows "cntP s th = cntV s th + (if (th \<in> readys s \<or> th \<notin> threads s)
- then cntCS s th else cntCS s th + 1)"
-proof -
- from vt show ?thesis
- proof(induct arbitrary:th)
- case (vt_cons s e)
- assume vt: "vt s"
- and ih: "\<And>th. cntP s th = cntV s th +
- (if (th \<in> readys s \<or> th \<notin> threads s) then cntCS s th else cntCS s th + 1)"
- and stp: "step s e"
- from stp show ?case
- proof(cases)
- case (thread_create thread prio)
- assume eq_e: "e = Create thread prio"
- and not_in: "thread \<notin> threads s"
- show ?thesis
- proof -
- { fix cs
- assume "thread \<in> set (wq s cs)"
- from wq_threads [OF vt this] have "thread \<in> threads s" .
- with not_in have "False" by simp
- } with eq_e have eq_readys: "readys (e#s) = readys s \<union> {thread}"
- by (auto simp:readys_def threads.simps s_waiting_def
- wq_def cs_waiting_def Let_def)
- from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
- from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
- have eq_cncs: "cntCS (e#s) th = cntCS s th"
- unfolding cntCS_def holdents_test
- by (simp add:depend_create_unchanged eq_e)
- { assume "th \<noteq> thread"
- with eq_readys eq_e
- have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
- (th \<in> readys (s) \<or> th \<notin> threads (s))"
- by (simp add:threads.simps)
- with eq_cnp eq_cnv eq_cncs ih not_in
- have ?thesis by simp
- } moreover {
- assume eq_th: "th = thread"
- with not_in ih have " cntP s th = cntV s th + cntCS s th" by simp
- moreover from eq_th and eq_readys have "th \<in> readys (e#s)" by simp
- moreover note eq_cnp eq_cnv eq_cncs
- ultimately have ?thesis by auto
- } ultimately show ?thesis by blast
- qed
- next
- case (thread_exit thread)
- assume eq_e: "e = Exit thread"
- and is_runing: "thread \<in> runing s"
- and no_hold: "holdents s thread = {}"
- from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
- from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
- have eq_cncs: "cntCS (e#s) th = cntCS s th"
- unfolding cntCS_def holdents_test
- by (simp add:depend_exit_unchanged eq_e)
- { assume "th \<noteq> thread"
- with eq_e
- have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
- (th \<in> readys (s) \<or> th \<notin> threads (s))"
- apply (simp add:threads.simps readys_def)
- apply (subst s_waiting_def)
- apply (simp add:Let_def)
- apply (subst s_waiting_def, simp)
- done
- with eq_cnp eq_cnv eq_cncs ih
- have ?thesis by simp
- } moreover {
- assume eq_th: "th = thread"
- with ih is_runing have " cntP s th = cntV s th + cntCS s th"
- by (simp add:runing_def)
- moreover from eq_th eq_e have "th \<notin> threads (e#s)"
- by simp
- moreover note eq_cnp eq_cnv eq_cncs
- ultimately have ?thesis by auto
- } ultimately show ?thesis by blast
- next
- case (thread_P thread cs)
- assume eq_e: "e = P thread cs"
- and is_runing: "thread \<in> runing s"
- and no_dep: "(Cs cs, Th thread) \<notin> (depend s)\<^sup>+"
- from thread_P vt stp ih have vtp: "vt (P thread cs#s)" by auto
- show ?thesis
- proof -
- { have hh: "\<And> A B C. (B = C) \<Longrightarrow> (A \<and> B) = (A \<and> C)" by blast
- assume neq_th: "th \<noteq> thread"
- with eq_e
- have eq_readys: "(th \<in> readys (e#s)) = (th \<in> readys (s))"
- apply (simp add:readys_def s_waiting_def wq_def Let_def)
- apply (rule_tac hh, clarify)
- apply (intro iffI allI, clarify)
- apply (erule_tac x = csa in allE, auto)
- apply (subgoal_tac "wq_fun (schs s) cs \<noteq> []", auto)
- apply (erule_tac x = cs in allE, auto)
- by (case_tac "(wq_fun (schs s) cs)", auto)
- moreover from neq_th eq_e have "cntCS (e # s) th = cntCS s th"
- apply (simp add:cntCS_def holdents_test)
- by (unfold step_depend_p [OF vtp], auto)
- moreover from eq_e neq_th have "cntP (e # s) th = cntP s th"
- by (simp add:cntP_def count_def)
- moreover from eq_e neq_th have "cntV (e#s) th = cntV s th"
- by (simp add:cntV_def count_def)
- moreover from eq_e neq_th have "threads (e#s) = threads s" by simp
- moreover note ih [of th]
- ultimately have ?thesis by simp
- } moreover {
- assume eq_th: "th = thread"
- have ?thesis
- proof -
- from eq_e eq_th have eq_cnp: "cntP (e # s) th = 1 + (cntP s th)"
- by (simp add:cntP_def count_def)
- from eq_e eq_th have eq_cnv: "cntV (e#s) th = cntV s th"
- by (simp add:cntV_def count_def)
- show ?thesis
- proof (cases "wq s cs = []")
- case True
- with is_runing
- have "th \<in> readys (e#s)"
- apply (unfold eq_e wq_def, unfold readys_def s_depend_def)
- apply (simp add: wq_def[symmetric] runing_def eq_th s_waiting_def)
- by (auto simp:readys_def wq_def Let_def s_waiting_def wq_def)
- moreover have "cntCS (e # s) th = 1 + cntCS s th"
- proof -
- have "card {csa. csa = cs \<or> (Cs csa, Th thread) \<in> depend s} =
- Suc (card {cs. (Cs cs, Th thread) \<in> depend s})" (is "card ?L = Suc (card ?R)")
- proof -
- have "?L = insert cs ?R" by auto
- moreover have "card \<dots> = Suc (card (?R - {cs}))"
- proof(rule card_insert)
- from finite_holding [OF vt, of thread]
- show " finite {cs. (Cs cs, Th thread) \<in> depend s}"
- by (unfold holdents_test, simp)
- qed
- moreover have "?R - {cs} = ?R"
- proof -
- have "cs \<notin> ?R"
- proof
- assume "cs \<in> {cs. (Cs cs, Th thread) \<in> depend s}"
- with no_dep show False by auto
- qed
- thus ?thesis by auto
- qed
- ultimately show ?thesis by auto
- qed
- thus ?thesis
- apply (unfold eq_e eq_th cntCS_def)
- apply (simp add: holdents_test)
- by (unfold step_depend_p [OF vtp], auto simp:True)
- qed
- moreover from is_runing have "th \<in> readys s"
- by (simp add:runing_def eq_th)
- moreover note eq_cnp eq_cnv ih [of th]
- ultimately show ?thesis by auto
- next
- case False
- have eq_wq: "wq (e#s) cs = wq s cs @ [th]"
- by (unfold eq_th eq_e wq_def, auto simp:Let_def)
- have "th \<notin> readys (e#s)"
- proof
- assume "th \<in> readys (e#s)"
- hence "\<forall>cs. \<not> waiting (e # s) th cs" by (simp add:readys_def)
- from this[rule_format, of cs] have " \<not> waiting (e # s) th cs" .
- hence "th \<in> set (wq (e#s) cs) \<Longrightarrow> th = hd (wq (e#s) cs)"
- by (simp add:s_waiting_def wq_def)
- moreover from eq_wq have "th \<in> set (wq (e#s) cs)" by auto
- ultimately have "th = hd (wq (e#s) cs)" by blast
- with eq_wq have "th = hd (wq s cs @ [th])" by simp
- hence "th = hd (wq s cs)" using False by auto
- with False eq_wq wq_distinct [OF vtp, of cs]
- show False by (fold eq_e, auto)
- qed
- moreover from is_runing have "th \<in> threads (e#s)"
- by (unfold eq_e, auto simp:runing_def readys_def eq_th)
- moreover have "cntCS (e # s) th = cntCS s th"
- apply (unfold cntCS_def holdents_test eq_e step_depend_p[OF vtp])
- by (auto simp:False)
- moreover note eq_cnp eq_cnv ih[of th]
- moreover from is_runing have "th \<in> readys s"
- by (simp add:runing_def eq_th)
- ultimately show ?thesis by auto
- qed
- qed
- } ultimately show ?thesis by blast
- qed
- next
- case (thread_V thread cs)
- from assms vt stp ih thread_V have vtv: "vt (V thread cs # s)" by auto
- assume eq_e: "e = V thread cs"
- and is_runing: "thread \<in> runing s"
- and hold: "holding s thread cs"
- from hold obtain rest
- where eq_wq: "wq s cs = thread # rest"
- by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
- have eq_threads: "threads (e#s) = threads s" by (simp add: eq_e)
- have eq_set: "set (SOME q. distinct q \<and> set q = set rest) = set rest"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vtv], of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
- by auto
- qed
- show ?thesis
- proof -
- { assume eq_th: "th = thread"
- from eq_th have eq_cnp: "cntP (e # s) th = cntP s th"
- by (unfold eq_e, simp add:cntP_def count_def)
- moreover from eq_th have eq_cnv: "cntV (e#s) th = 1 + cntV s th"
- by (unfold eq_e, simp add:cntV_def count_def)
- moreover from cntCS_v_dec [OF vtv]
- have "cntCS (e # s) thread + 1 = cntCS s thread"
- by (simp add:eq_e)
- moreover from is_runing have rd_before: "thread \<in> readys s"
- by (unfold runing_def, simp)
- moreover have "thread \<in> readys (e # s)"
- proof -
- from is_runing
- have "thread \<in> threads (e#s)"
- by (unfold eq_e, auto simp:runing_def readys_def)
- moreover have "\<forall> cs1. \<not> waiting (e#s) thread cs1"
- proof
- fix cs1
- { assume eq_cs: "cs1 = cs"
- have "\<not> waiting (e # s) thread cs1"
- proof -
- from eq_wq
- have "thread \<notin> set (wq (e#s) cs1)"
- apply(unfold eq_e wq_def eq_cs s_holding_def)
- apply (auto simp:Let_def)
- proof -
- assume "thread \<in> set (SOME q. distinct q \<and> set q = set rest)"
- with eq_set have "thread \<in> set rest" by simp
- with wq_distinct[OF step_back_vt[OF vtv], of cs]
- and eq_wq show False by auto
- qed
- thus ?thesis by (simp add:wq_def s_waiting_def)
- qed
- } moreover {
- assume neq_cs: "cs1 \<noteq> cs"
- have "\<not> waiting (e # s) thread cs1"
- proof -
- from wq_v_neq [OF neq_cs[symmetric]]
- have "wq (V thread cs # s) cs1 = wq s cs1" .
- moreover have "\<not> waiting s thread cs1"
- proof -
- from runing_ready and is_runing
- have "thread \<in> readys s" by auto
- thus ?thesis by (simp add:readys_def)
- qed
- ultimately show ?thesis
- by (auto simp:wq_def s_waiting_def eq_e)
- qed
- } ultimately show "\<not> waiting (e # s) thread cs1" by blast
- qed
- ultimately show ?thesis by (simp add:readys_def)
- qed
- moreover note eq_th ih
- ultimately have ?thesis by auto
- } moreover {
- assume neq_th: "th \<noteq> thread"
- from neq_th eq_e have eq_cnp: "cntP (e # s) th = cntP s th"
- by (simp add:cntP_def count_def)
- from neq_th eq_e have eq_cnv: "cntV (e # s) th = cntV s th"
- by (simp add:cntV_def count_def)
- have ?thesis
- proof(cases "th \<in> set rest")
- case False
- have "(th \<in> readys (e # s)) = (th \<in> readys s)"
- apply (insert step_back_vt[OF vtv])
- by (unfold eq_e, rule readys_v_eq [OF _ neq_th eq_wq False], auto)
- moreover have "cntCS (e#s) th = cntCS s th"
- apply (insert neq_th, unfold eq_e cntCS_def holdents_test step_depend_v[OF vtv], auto)
- proof -
- have "{csa. (Cs csa, Th th) \<in> depend s \<or> csa = cs \<and> next_th s thread cs th} =
- {cs. (Cs cs, Th th) \<in> depend s}"
- proof -
- from False eq_wq
- have " next_th s thread cs th \<Longrightarrow> (Cs cs, Th th) \<in> depend s"
- apply (unfold next_th_def, auto)
- proof -
- assume ne: "rest \<noteq> []"
- and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
- and eq_wq: "wq s cs = thread # rest"
- from eq_set ni have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
- set (SOME q. distinct q \<and> set q = set rest)
- " by simp
- moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vtv], of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x assume "distinct x \<and> set x = set rest"
- with ne show "x \<noteq> []" by auto
- qed
- ultimately show
- "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> depend s"
- by auto
- qed
- thus ?thesis by auto
- qed
- thus "card {csa. (Cs csa, Th th) \<in> depend s \<or> csa = cs \<and> next_th s thread cs th} =
- card {cs. (Cs cs, Th th) \<in> depend s}" by simp
- qed
- moreover note ih eq_cnp eq_cnv eq_threads
- ultimately show ?thesis by auto
- next
- case True
- assume th_in: "th \<in> set rest"
- show ?thesis
- proof(cases "next_th s thread cs th")
- case False
- with eq_wq and th_in have
- neq_hd: "th \<noteq> hd (SOME q. distinct q \<and> set q = set rest)" (is "th \<noteq> hd ?rest")
- by (auto simp:next_th_def)
- have "(th \<in> readys (e # s)) = (th \<in> readys s)"
- proof -
- from eq_wq and th_in
- have "\<not> th \<in> readys s"
- apply (auto simp:readys_def s_waiting_def)
- apply (rule_tac x = cs in exI, auto)
- by (insert wq_distinct[OF step_back_vt[OF vtv], of cs], auto simp add: wq_def)
- moreover
- from eq_wq and th_in and neq_hd
- have "\<not> (th \<in> readys (e # s))"
- apply (auto simp:readys_def s_waiting_def eq_e wq_def Let_def split:list.splits)
- by (rule_tac x = cs in exI, auto simp:eq_set)
- ultimately show ?thesis by auto
- qed
- moreover have "cntCS (e#s) th = cntCS s th"
- proof -
- from eq_wq and th_in and neq_hd
- have "(holdents (e # s) th) = (holdents s th)"
- apply (unfold eq_e step_depend_v[OF vtv],
- auto simp:next_th_def eq_set s_depend_def holdents_test wq_def
- Let_def cs_holding_def)
- by (insert wq_distinct[OF step_back_vt[OF vtv], of cs], auto simp:wq_def)
- thus ?thesis by (simp add:cntCS_def)
- qed
- moreover note ih eq_cnp eq_cnv eq_threads
- ultimately show ?thesis by auto
- next
- case True
- let ?rest = " (SOME q. distinct q \<and> set q = set rest)"
- let ?t = "hd ?rest"
- from True eq_wq th_in neq_th
- have "th \<in> readys (e # s)"
- apply (auto simp:eq_e readys_def s_waiting_def wq_def
- Let_def next_th_def)
- proof -
- assume eq_wq: "wq_fun (schs s) cs = thread # rest"
- and t_in: "?t \<in> set rest"
- show "?t \<in> threads s"
- proof(rule wq_threads[OF step_back_vt[OF vtv]])
- from eq_wq and t_in
- show "?t \<in> set (wq s cs)" by (auto simp:wq_def)
- qed
- next
- fix csa
- assume eq_wq: "wq_fun (schs s) cs = thread # rest"
- and t_in: "?t \<in> set rest"
- and neq_cs: "csa \<noteq> cs"
- and t_in': "?t \<in> set (wq_fun (schs s) csa)"
- show "?t = hd (wq_fun (schs s) csa)"
- proof -
- { assume neq_hd': "?t \<noteq> hd (wq_fun (schs s) csa)"
- from wq_distinct[OF step_back_vt[OF vtv], of cs] and
- eq_wq[folded wq_def] and t_in eq_wq
- have "?t \<noteq> thread" by auto
- with eq_wq and t_in
- have w1: "waiting s ?t cs"
- by (auto simp:s_waiting_def wq_def)
- from t_in' neq_hd'
- have w2: "waiting s ?t csa"
- by (auto simp:s_waiting_def wq_def)
- from waiting_unique[OF step_back_vt[OF vtv] w1 w2]
- and neq_cs have "False" by auto
- } thus ?thesis by auto
- qed
- qed
- moreover have "cntP s th = cntV s th + cntCS s th + 1"
- proof -
- have "th \<notin> readys s"
- proof -
- from True eq_wq neq_th th_in
- show ?thesis
- apply (unfold readys_def s_waiting_def, auto)
- by (rule_tac x = cs in exI, auto simp add: wq_def)
- qed
- moreover have "th \<in> threads s"
- proof -
- from th_in eq_wq
- have "th \<in> set (wq s cs)" by simp
- from wq_threads [OF step_back_vt[OF vtv] this]
- show ?thesis .
- qed
- ultimately show ?thesis using ih by auto
- qed
- moreover from True neq_th have "cntCS (e # s) th = 1 + cntCS s th"
- apply (unfold cntCS_def holdents_test eq_e step_depend_v[OF vtv], auto)
- proof -
- show "card {csa. (Cs csa, Th th) \<in> depend s \<or> csa = cs} =
- Suc (card {cs. (Cs cs, Th th) \<in> depend s})"
- (is "card ?A = Suc (card ?B)")
- proof -
- have "?A = insert cs ?B" by auto
- hence "card ?A = card (insert cs ?B)" by simp
- also have "\<dots> = Suc (card ?B)"
- proof(rule card_insert_disjoint)
- have "?B \<subseteq> ((\<lambda> (x, y). the_cs x) ` depend s)"
- apply (auto simp:image_def)
- by (rule_tac x = "(Cs x, Th th)" in bexI, auto)
- with finite_depend[OF step_back_vt[OF vtv]]
- show "finite {cs. (Cs cs, Th th) \<in> depend s}" by (auto intro:finite_subset)
- next
- show "cs \<notin> {cs. (Cs cs, Th th) \<in> depend s}"
- proof
- assume "cs \<in> {cs. (Cs cs, Th th) \<in> depend s}"
- hence "(Cs cs, Th th) \<in> depend s" by simp
- with True neq_th eq_wq show False
- by (auto simp:next_th_def s_depend_def cs_holding_def)
- qed
- qed
- finally show ?thesis .
- qed
- qed
- moreover note eq_cnp eq_cnv
- ultimately show ?thesis by simp
- qed
- qed
- } ultimately show ?thesis by blast
- qed
- next
- case (thread_set thread prio)
- assume eq_e: "e = Set thread prio"
- and is_runing: "thread \<in> runing s"
- show ?thesis
- proof -
- from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
- from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
- have eq_cncs: "cntCS (e#s) th = cntCS s th"
- unfolding cntCS_def holdents_test
- by (simp add:depend_set_unchanged eq_e)
- from eq_e have eq_readys: "readys (e#s) = readys s"
- by (simp add:readys_def cs_waiting_def s_waiting_def wq_def,
- auto simp:Let_def)
- { assume "th \<noteq> thread"
- with eq_readys eq_e
- have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
- (th \<in> readys (s) \<or> th \<notin> threads (s))"
- by (simp add:threads.simps)
- with eq_cnp eq_cnv eq_cncs ih is_runing
- have ?thesis by simp
- } moreover {
- assume eq_th: "th = thread"
- with is_runing ih have " cntP s th = cntV s th + cntCS s th"
- by (unfold runing_def, auto)
- moreover from eq_th and eq_readys is_runing have "th \<in> readys (e#s)"
- by (simp add:runing_def)
- moreover note eq_cnp eq_cnv eq_cncs
- ultimately have ?thesis by auto
- } ultimately show ?thesis by blast
- qed
- qed
- next
- case vt_nil
- show ?case
- by (unfold cntP_def cntV_def cntCS_def,
- auto simp:count_def holdents_test s_depend_def wq_def cs_holding_def)
- qed
-qed
-
-lemma not_thread_cncs:
- fixes th s
- assumes vt: "vt s"
- and not_in: "th \<notin> threads s"
- shows "cntCS s th = 0"
-proof -
- from vt not_in show ?thesis
- proof(induct arbitrary:th)
- case (vt_cons s e th)
- assume vt: "vt s"
- and ih: "\<And>th. th \<notin> threads s \<Longrightarrow> cntCS s th = 0"
- and stp: "step s e"
- and not_in: "th \<notin> threads (e # s)"
- from stp show ?case
- proof(cases)
- case (thread_create thread prio)
- assume eq_e: "e = Create thread prio"
- and not_in': "thread \<notin> threads s"
- have "cntCS (e # s) th = cntCS s th"
- apply (unfold eq_e cntCS_def holdents_test)
- by (simp add:depend_create_unchanged)
- moreover have "th \<notin> threads s"
- proof -
- from not_in eq_e show ?thesis by simp
- qed
- moreover note ih ultimately show ?thesis by auto
- next
- case (thread_exit thread)
- assume eq_e: "e = Exit thread"
- and nh: "holdents s thread = {}"
- have eq_cns: "cntCS (e # s) th = cntCS s th"
- apply (unfold eq_e cntCS_def holdents_test)
- by (simp add:depend_exit_unchanged)
- show ?thesis
- proof(cases "th = thread")
- case True
- have "cntCS s th = 0" by (unfold cntCS_def, auto simp:nh True)
- with eq_cns show ?thesis by simp
- next
- case False
- with not_in and eq_e
- have "th \<notin> threads s" by simp
- from ih[OF this] and eq_cns show ?thesis by simp
- qed
- next
- case (thread_P thread cs)
- assume eq_e: "e = P thread cs"
- and is_runing: "thread \<in> runing s"
- from assms thread_P ih vt stp thread_P have vtp: "vt (P thread cs#s)" by auto
- have neq_th: "th \<noteq> thread"
- proof -
- from not_in eq_e have "th \<notin> threads s" by simp
- moreover from is_runing have "thread \<in> threads s"
- by (simp add:runing_def readys_def)
- ultimately show ?thesis by auto
- qed
- hence "cntCS (e # s) th = cntCS s th "
- apply (unfold cntCS_def holdents_test eq_e)
- by (unfold step_depend_p[OF vtp], auto)
- moreover have "cntCS s th = 0"
- proof(rule ih)
- from not_in eq_e show "th \<notin> threads s" by simp
- qed
- ultimately show ?thesis by simp
- next
- case (thread_V thread cs)
- assume eq_e: "e = V thread cs"
- and is_runing: "thread \<in> runing s"
- and hold: "holding s thread cs"
- have neq_th: "th \<noteq> thread"
- proof -
- from not_in eq_e have "th \<notin> threads s" by simp
- moreover from is_runing have "thread \<in> threads s"
- by (simp add:runing_def readys_def)
- ultimately show ?thesis by auto
- qed
- from assms thread_V vt stp ih have vtv: "vt (V thread cs#s)" by auto
- from hold obtain rest
- where eq_wq: "wq s cs = thread # rest"
- by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
- from not_in eq_e eq_wq
- have "\<not> next_th s thread cs th"
- apply (auto simp:next_th_def)
- proof -
- assume ne: "rest \<noteq> []"
- and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> threads s" (is "?t \<notin> threads s")
- have "?t \<in> set rest"
- proof(rule someI2)
- from wq_distinct[OF step_back_vt[OF vtv], of cs] and eq_wq
- show "distinct rest \<and> set rest = set rest" by auto
- next
- fix x assume "distinct x \<and> set x = set rest" with ne
- show "hd x \<in> set rest" by (cases x, auto)
- qed
- with eq_wq have "?t \<in> set (wq s cs)" by simp
- from wq_threads[OF step_back_vt[OF vtv], OF this] and ni
- show False by auto
- qed
- moreover note neq_th eq_wq
- ultimately have "cntCS (e # s) th = cntCS s th"
- by (unfold eq_e cntCS_def holdents_test step_depend_v[OF vtv], auto)
- moreover have "cntCS s th = 0"
- proof(rule ih)
- from not_in eq_e show "th \<notin> threads s" by simp
- qed
- ultimately show ?thesis by simp
- next
- case (thread_set thread prio)
- print_facts
- assume eq_e: "e = Set thread prio"
- and is_runing: "thread \<in> runing s"
- from not_in and eq_e have "th \<notin> threads s" by auto
- from ih [OF this] and eq_e
- show ?thesis
- apply (unfold eq_e cntCS_def holdents_test)
- by (simp add:depend_set_unchanged)
- qed
- next
- case vt_nil
- show ?case
- by (unfold cntCS_def,
- auto simp:count_def holdents_test s_depend_def wq_def cs_holding_def)
- qed
-qed
-
-lemma eq_waiting: "waiting (wq (s::state)) th cs = waiting s th cs"
- by (auto simp:s_waiting_def cs_waiting_def wq_def)
-
-lemma dm_depend_threads:
- fixes th s
- assumes vt: "vt s"
- and in_dom: "(Th th) \<in> Domain (depend s)"
- shows "th \<in> threads s"
-proof -
- from in_dom obtain n where "(Th th, n) \<in> depend s" by auto
- moreover from depend_target_th[OF this] obtain cs where "n = Cs cs" by auto
- ultimately have "(Th th, Cs cs) \<in> depend s" by simp
- hence "th \<in> set (wq s cs)"
- by (unfold s_depend_def, auto simp:cs_waiting_def)
- from wq_threads [OF vt this] show ?thesis .
-qed
-
-lemma cp_eq_cpreced: "cp s th = cpreced (wq s) s th"
-unfolding cp_def wq_def
-apply(induct s rule: schs.induct)
-apply(simp add: Let_def cpreced_initial)
-apply(simp add: Let_def)
-apply(simp add: Let_def)
-apply(simp add: Let_def)
-apply(subst (2) schs.simps)
-apply(simp add: Let_def)
-apply(subst (2) schs.simps)
-apply(simp add: Let_def)
-done
-
-
-lemma runing_unique:
- fixes th1 th2 s
- assumes vt: "vt s"
- and runing_1: "th1 \<in> runing s"
- and runing_2: "th2 \<in> runing s"
- shows "th1 = th2"
-proof -
- from runing_1 and runing_2 have "cp s th1 = cp s th2"
- by (unfold runing_def, simp)
- hence eq_max: "Max ((\<lambda>th. preced th s) ` ({th1} \<union> dependents (wq s) th1)) =
- Max ((\<lambda>th. preced th s) ` ({th2} \<union> dependents (wq s) th2))"
- (is "Max (?f ` ?A) = Max (?f ` ?B)")
- by (unfold cp_eq_cpreced cpreced_def)
- obtain th1' where th1_in: "th1' \<in> ?A" and eq_f_th1: "?f th1' = Max (?f ` ?A)"
- proof -
- have h1: "finite (?f ` ?A)"
- proof -
- have "finite ?A"
- proof -
- have "finite (dependents (wq s) th1)"
- proof-
- have "finite {th'. (Th th', Th th1) \<in> (depend (wq s))\<^sup>+}"
- proof -
- let ?F = "\<lambda> (x, y). the_th x"
- have "{th'. (Th th', Th th1) \<in> (depend (wq s))\<^sup>+} \<subseteq> ?F ` ((depend (wq s))\<^sup>+)"
- apply (auto simp:image_def)
- by (rule_tac x = "(Th x, Th th1)" in bexI, auto)
- moreover have "finite \<dots>"
- proof -
- from finite_depend[OF vt] have "finite (depend s)" .
- hence "finite ((depend (wq s))\<^sup>+)"
- apply (unfold finite_trancl)
- by (auto simp: s_depend_def cs_depend_def wq_def)
- thus ?thesis by auto
- qed
- ultimately show ?thesis by (auto intro:finite_subset)
- qed
- thus ?thesis by (simp add:cs_dependents_def)
- qed
- thus ?thesis by simp
- qed
- thus ?thesis by auto
- qed
- moreover have h2: "(?f ` ?A) \<noteq> {}"
- proof -
- have "?A \<noteq> {}" by simp
- thus ?thesis by simp
- qed
- from Max_in [OF h1 h2]
- have "Max (?f ` ?A) \<in> (?f ` ?A)" .
- thus ?thesis by (auto intro:that)
- qed
- obtain th2' where th2_in: "th2' \<in> ?B" and eq_f_th2: "?f th2' = Max (?f ` ?B)"
- proof -
- have h1: "finite (?f ` ?B)"
- proof -
- have "finite ?B"
- proof -
- have "finite (dependents (wq s) th2)"
- proof-
- have "finite {th'. (Th th', Th th2) \<in> (depend (wq s))\<^sup>+}"
- proof -
- let ?F = "\<lambda> (x, y). the_th x"
- have "{th'. (Th th', Th th2) \<in> (depend (wq s))\<^sup>+} \<subseteq> ?F ` ((depend (wq s))\<^sup>+)"
- apply (auto simp:image_def)
- by (rule_tac x = "(Th x, Th th2)" in bexI, auto)
- moreover have "finite \<dots>"
- proof -
- from finite_depend[OF vt] have "finite (depend s)" .
- hence "finite ((depend (wq s))\<^sup>+)"
- apply (unfold finite_trancl)
- by (auto simp: s_depend_def cs_depend_def wq_def)
- thus ?thesis by auto
- qed
- ultimately show ?thesis by (auto intro:finite_subset)
- qed
- thus ?thesis by (simp add:cs_dependents_def)
- qed
- thus ?thesis by simp
- qed
- thus ?thesis by auto
- qed
- moreover have h2: "(?f ` ?B) \<noteq> {}"
- proof -
- have "?B \<noteq> {}" by simp
- thus ?thesis by simp
- qed
- from Max_in [OF h1 h2]
- have "Max (?f ` ?B) \<in> (?f ` ?B)" .
- thus ?thesis by (auto intro:that)
- qed
- from eq_f_th1 eq_f_th2 eq_max
- have eq_preced: "preced th1' s = preced th2' s" by auto
- hence eq_th12: "th1' = th2'"
- proof (rule preced_unique)
- from th1_in have "th1' = th1 \<or> (th1' \<in> dependents (wq s) th1)" by simp
- thus "th1' \<in> threads s"
- proof
- assume "th1' \<in> dependents (wq s) th1"
- hence "(Th th1') \<in> Domain ((depend s)^+)"
- apply (unfold cs_dependents_def cs_depend_def s_depend_def)
- by (auto simp:Domain_def)
- hence "(Th th1') \<in> Domain (depend s)" by (simp add:trancl_domain)
- from dm_depend_threads[OF vt this] show ?thesis .
- next
- assume "th1' = th1"
- with runing_1 show ?thesis
- by (unfold runing_def readys_def, auto)
- qed
- next
- from th2_in have "th2' = th2 \<or> (th2' \<in> dependents (wq s) th2)" by simp
- thus "th2' \<in> threads s"
- proof
- assume "th2' \<in> dependents (wq s) th2"
- hence "(Th th2') \<in> Domain ((depend s)^+)"
- apply (unfold cs_dependents_def cs_depend_def s_depend_def)
- by (auto simp:Domain_def)
- hence "(Th th2') \<in> Domain (depend s)" by (simp add:trancl_domain)
- from dm_depend_threads[OF vt this] show ?thesis .
- next
- assume "th2' = th2"
- with runing_2 show ?thesis
- by (unfold runing_def readys_def, auto)
- qed
- qed
- from th1_in have "th1' = th1 \<or> th1' \<in> dependents (wq s) th1" by simp
- thus ?thesis
- proof
- assume eq_th': "th1' = th1"
- from th2_in have "th2' = th2 \<or> th2' \<in> dependents (wq s) th2" by simp
- thus ?thesis
- proof
- assume "th2' = th2" thus ?thesis using eq_th' eq_th12 by simp
- next
- assume "th2' \<in> dependents (wq s) th2"
- with eq_th12 eq_th' have "th1 \<in> dependents (wq s) th2" by simp
- hence "(Th th1, Th th2) \<in> (depend s)^+"
- by (unfold cs_dependents_def s_depend_def cs_depend_def, simp)
- hence "Th th1 \<in> Domain ((depend s)^+)"
- apply (unfold cs_dependents_def cs_depend_def s_depend_def)
- by (auto simp:Domain_def)
- hence "Th th1 \<in> Domain (depend s)" by (simp add:trancl_domain)
- then obtain n where d: "(Th th1, n) \<in> depend s" by (auto simp:Domain_def)
- from depend_target_th [OF this]
- obtain cs' where "n = Cs cs'" by auto
- with d have "(Th th1, Cs cs') \<in> depend s" by simp
- with runing_1 have "False"
- apply (unfold runing_def readys_def s_depend_def)
- by (auto simp:eq_waiting)
- thus ?thesis by simp
- qed
- next
- assume th1'_in: "th1' \<in> dependents (wq s) th1"
- from th2_in have "th2' = th2 \<or> th2' \<in> dependents (wq s) th2" by simp
- thus ?thesis
- proof
- assume "th2' = th2"
- with th1'_in eq_th12 have "th2 \<in> dependents (wq s) th1" by simp
- hence "(Th th2, Th th1) \<in> (depend s)^+"
- by (unfold cs_dependents_def s_depend_def cs_depend_def, simp)
- hence "Th th2 \<in> Domain ((depend s)^+)"
- apply (unfold cs_dependents_def cs_depend_def s_depend_def)
- by (auto simp:Domain_def)
- hence "Th th2 \<in> Domain (depend s)" by (simp add:trancl_domain)
- then obtain n where d: "(Th th2, n) \<in> depend s" by (auto simp:Domain_def)
- from depend_target_th [OF this]
- obtain cs' where "n = Cs cs'" by auto
- with d have "(Th th2, Cs cs') \<in> depend s" by simp
- with runing_2 have "False"
- apply (unfold runing_def readys_def s_depend_def)
- by (auto simp:eq_waiting)
- thus ?thesis by simp
- next
- assume "th2' \<in> dependents (wq s) th2"
- with eq_th12 have "th1' \<in> dependents (wq s) th2" by simp
- hence h1: "(Th th1', Th th2) \<in> (depend s)^+"
- by (unfold cs_dependents_def s_depend_def cs_depend_def, simp)
- from th1'_in have h2: "(Th th1', Th th1) \<in> (depend s)^+"
- by (unfold cs_dependents_def s_depend_def cs_depend_def, simp)
- show ?thesis
- proof(rule dchain_unique[OF vt h1 _ h2, symmetric])
- from runing_1 show "th1 \<in> readys s" by (simp add:runing_def)
- from runing_2 show "th2 \<in> readys s" by (simp add:runing_def)
- qed
- qed
- qed
-qed
-
-lemma create_pre:
- assumes stp: "step s e"
- and not_in: "th \<notin> threads s"
- and is_in: "th \<in> threads (e#s)"
- obtains prio where "e = Create th prio"
-proof -
- from assms
- show ?thesis
- proof(cases)
- case (thread_create thread prio)
- with is_in not_in have "e = Create th prio" by simp
- from that[OF this] show ?thesis .
- next
- case (thread_exit thread)
- with assms show ?thesis by (auto intro!:that)
- next
- case (thread_P thread)
- with assms show ?thesis by (auto intro!:that)
- next
- case (thread_V thread)
- with assms show ?thesis by (auto intro!:that)
- next
- case (thread_set thread)
- with assms show ?thesis by (auto intro!:that)
- qed
-qed
-
-lemma length_down_to_in:
- assumes le_ij: "i \<le> j"
- and le_js: "j \<le> length s"
- shows "length (down_to j i s) = j - i"
-proof -
- have "length (down_to j i s) = length (from_to i j (rev s))"
- by (unfold down_to_def, auto)
- also have "\<dots> = j - i"
- proof(rule length_from_to_in[OF le_ij])
- from le_js show "j \<le> length (rev s)" by simp
- qed
- finally show ?thesis .
-qed
-
-
-lemma moment_head:
- assumes le_it: "Suc i \<le> length t"
- obtains e where "moment (Suc i) t = e#moment i t"
-proof -
- have "i \<le> Suc i" by simp
- from length_down_to_in [OF this le_it]
- have "length (down_to (Suc i) i t) = 1" by auto
- then obtain e where "down_to (Suc i) i t = [e]"
- apply (cases "(down_to (Suc i) i t)") by auto
- moreover have "down_to (Suc i) 0 t = down_to (Suc i) i t @ down_to i 0 t"
- by (rule down_to_conc[symmetric], auto)
- ultimately have eq_me: "moment (Suc i) t = e#(moment i t)"
- by (auto simp:down_to_moment)
- from that [OF this] show ?thesis .
-qed
-
-lemma cnp_cnv_eq:
- fixes th s
- assumes "vt s"
- and "th \<notin> threads s"
- shows "cntP s th = cntV s th"
-proof -
- from assms show ?thesis
- proof(induct)
- case (vt_cons s e)
- have ih: "th \<notin> threads s \<Longrightarrow> cntP s th = cntV s th" by fact
- have not_in: "th \<notin> threads (e # s)" by fact
- have "step s e" by fact
- thus ?case proof(cases)
- case (thread_create thread prio)
- assume eq_e: "e = Create thread prio"
- hence "thread \<in> threads (e#s)" by simp
- with not_in and eq_e have "th \<notin> threads s" by auto
- from ih [OF this] show ?thesis using eq_e
- by (auto simp:cntP_def cntV_def count_def)
- next
- case (thread_exit thread)
- assume eq_e: "e = Exit thread"
- and not_holding: "holdents s thread = {}"
- have vt_s: "vt s" by fact
- from finite_holding[OF vt_s] have "finite (holdents s thread)" .
- with not_holding have "cntCS s thread = 0" by (unfold cntCS_def, auto)
- moreover have "thread \<in> readys s" using thread_exit by (auto simp:runing_def)
- moreover note cnp_cnv_cncs[OF vt_s, of thread]
- ultimately have eq_thread: "cntP s thread = cntV s thread" by auto
- show ?thesis
- proof(cases "th = thread")
- case True
- with eq_thread eq_e show ?thesis
- by (auto simp:cntP_def cntV_def count_def)
- next
- case False
- with not_in and eq_e have "th \<notin> threads s" by simp
- from ih[OF this] and eq_e show ?thesis
- by (auto simp:cntP_def cntV_def count_def)
- qed
- next
- case (thread_P thread cs)
- assume eq_e: "e = P thread cs"
- have "thread \<in> runing s" by fact
- with not_in eq_e have neq_th: "thread \<noteq> th"
- by (auto simp:runing_def readys_def)
- from not_in eq_e have "th \<notin> threads s" by simp
- from ih[OF this] and neq_th and eq_e show ?thesis
- by (auto simp:cntP_def cntV_def count_def)
- next
- case (thread_V thread cs)
- assume eq_e: "e = V thread cs"
- have "thread \<in> runing s" by fact
- with not_in eq_e have neq_th: "thread \<noteq> th"
- by (auto simp:runing_def readys_def)
- from not_in eq_e have "th \<notin> threads s" by simp
- from ih[OF this] and neq_th and eq_e show ?thesis
- by (auto simp:cntP_def cntV_def count_def)
- next
- case (thread_set thread prio)
- assume eq_e: "e = Set thread prio"
- and "thread \<in> runing s"
- hence "thread \<in> threads (e#s)"
- by (simp add:runing_def readys_def)
- with not_in and eq_e have "th \<notin> threads s" by auto
- from ih [OF this] show ?thesis using eq_e
- by (auto simp:cntP_def cntV_def count_def)
- qed
- next
- case vt_nil
- show ?case by (auto simp:cntP_def cntV_def count_def)
- qed
-qed
-
-lemma eq_depend:
- "depend (wq s) = depend s"
-by (unfold cs_depend_def s_depend_def, auto)
-
-lemma count_eq_dependents:
- assumes vt: "vt s"
- and eq_pv: "cntP s th = cntV s th"
- shows "dependents (wq s) th = {}"
-proof -
- from cnp_cnv_cncs[OF vt] and eq_pv
- have "cntCS s th = 0"
- by (auto split:if_splits)
- moreover have "finite {cs. (Cs cs, Th th) \<in> depend s}"
- proof -
- from finite_holding[OF vt, of th] show ?thesis
- by (simp add:holdents_test)
- qed
- ultimately have h: "{cs. (Cs cs, Th th) \<in> depend s} = {}"
- by (unfold cntCS_def holdents_test cs_dependents_def, auto)
- show ?thesis
- proof(unfold cs_dependents_def)
- { assume "{th'. (Th th', Th th) \<in> (depend (wq s))\<^sup>+} \<noteq> {}"
- then obtain th' where "(Th th', Th th) \<in> (depend (wq s))\<^sup>+" by auto
- hence "False"
- proof(cases)
- assume "(Th th', Th th) \<in> depend (wq s)"
- thus "False" by (auto simp:cs_depend_def)
- next
- fix c
- assume "(c, Th th) \<in> depend (wq s)"
- with h and eq_depend show "False"
- by (cases c, auto simp:cs_depend_def)
- qed
- } thus "{th'. (Th th', Th th) \<in> (depend (wq s))\<^sup>+} = {}" by auto
- qed
-qed
-
-lemma dependents_threads:
- fixes s th
- assumes vt: "vt s"
- shows "dependents (wq s) th \<subseteq> threads s"
-proof
- { fix th th'
- assume h: "th \<in> {th'a. (Th th'a, Th th') \<in> (depend (wq s))\<^sup>+}"
- have "Th th \<in> Domain (depend s)"
- proof -
- from h obtain th' where "(Th th, Th th') \<in> (depend (wq s))\<^sup>+" by auto
- hence "(Th th) \<in> Domain ( (depend (wq s))\<^sup>+)" by (auto simp:Domain_def)
- with trancl_domain have "(Th th) \<in> Domain (depend (wq s))" by simp
- thus ?thesis using eq_depend by simp
- qed
- from dm_depend_threads[OF vt this]
- have "th \<in> threads s" .
- } note hh = this
- fix th1
- assume "th1 \<in> dependents (wq s) th"
- hence "th1 \<in> {th'a. (Th th'a, Th th) \<in> (depend (wq s))\<^sup>+}"
- by (unfold cs_dependents_def, simp)
- from hh [OF this] show "th1 \<in> threads s" .
-qed
-
-lemma finite_threads:
- assumes vt: "vt s"
- shows "finite (threads s)"
-using vt
-by (induct) (auto elim: step.cases)
-
-lemma Max_f_mono:
- assumes seq: "A \<subseteq> B"
- and np: "A \<noteq> {}"
- and fnt: "finite B"
- shows "Max (f ` A) \<le> Max (f ` B)"
-proof(rule Max_mono)
- from seq show "f ` A \<subseteq> f ` B" by auto
-next
- from np show "f ` A \<noteq> {}" by auto
-next
- from fnt and seq show "finite (f ` B)" by auto
-qed
-
-lemma cp_le:
- assumes vt: "vt s"
- and th_in: "th \<in> threads s"
- shows "cp s th \<le> Max ((\<lambda> th. (preced th s)) ` threads s)"
-proof(unfold cp_eq_cpreced cpreced_def cs_dependents_def)
- show "Max ((\<lambda>th. preced th s) ` ({th} \<union> {th'. (Th th', Th th) \<in> (depend (wq s))\<^sup>+}))
- \<le> Max ((\<lambda>th. preced th s) ` threads s)"
- (is "Max (?f ` ?A) \<le> Max (?f ` ?B)")
- proof(rule Max_f_mono)
- show "{th} \<union> {th'. (Th th', Th th) \<in> (depend (wq s))\<^sup>+} \<noteq> {}" by simp
- next
- from finite_threads [OF vt]
- show "finite (threads s)" .
- next
- from th_in
- show "{th} \<union> {th'. (Th th', Th th) \<in> (depend (wq s))\<^sup>+} \<subseteq> threads s"
- apply (auto simp:Domain_def)
- apply (rule_tac dm_depend_threads[OF vt])
- apply (unfold trancl_domain [of "depend s", symmetric])
- by (unfold cs_depend_def s_depend_def, auto simp:Domain_def)
- qed
-qed
-
-lemma le_cp:
- assumes vt: "vt s"
- shows "preced th s \<le> cp s th"
-proof(unfold cp_eq_cpreced preced_def cpreced_def, simp)
- show "Prc (original_priority th s) (birthtime th s)
- \<le> Max (insert (Prc (original_priority th s) (birthtime th s))
- ((\<lambda>th. Prc (original_priority th s) (birthtime th s)) ` dependents (wq s) th))"
- (is "?l \<le> Max (insert ?l ?A)")
- proof(cases "?A = {}")
- case False
- have "finite ?A" (is "finite (?f ` ?B)")
- proof -
- have "finite ?B"
- proof-
- have "finite {th'. (Th th', Th th) \<in> (depend (wq s))\<^sup>+}"
- proof -
- let ?F = "\<lambda> (x, y). the_th x"
- have "{th'. (Th th', Th th) \<in> (depend (wq s))\<^sup>+} \<subseteq> ?F ` ((depend (wq s))\<^sup>+)"
- apply (auto simp:image_def)
- by (rule_tac x = "(Th x, Th th)" in bexI, auto)
- moreover have "finite \<dots>"
- proof -
- from finite_depend[OF vt] have "finite (depend s)" .
- hence "finite ((depend (wq s))\<^sup>+)"
- apply (unfold finite_trancl)
- by (auto simp: s_depend_def cs_depend_def wq_def)
- thus ?thesis by auto
- qed
- ultimately show ?thesis by (auto intro:finite_subset)
- qed
- thus ?thesis by (simp add:cs_dependents_def)
- qed
- thus ?thesis by simp
- qed
- from Max_insert [OF this False, of ?l] show ?thesis by auto
- next
- case True
- thus ?thesis by auto
- qed
-qed
-
-lemma max_cp_eq:
- assumes vt: "vt s"
- shows "Max ((cp s) ` threads s) = Max ((\<lambda> th. (preced th s)) ` threads s)"
- (is "?l = ?r")
-proof(cases "threads s = {}")
- case True
- thus ?thesis by auto
-next
- case False
- have "?l \<in> ((cp s) ` threads s)"
- proof(rule Max_in)
- from finite_threads[OF vt]
- show "finite (cp s ` threads s)" by auto
- next
- from False show "cp s ` threads s \<noteq> {}" by auto
- qed
- then obtain th
- where th_in: "th \<in> threads s" and eq_l: "?l = cp s th" by auto
- have "\<dots> \<le> ?r" by (rule cp_le[OF vt th_in])
- moreover have "?r \<le> cp s th" (is "Max (?f ` ?A) \<le> cp s th")
- proof -
- have "?r \<in> (?f ` ?A)"
- proof(rule Max_in)
- from finite_threads[OF vt]
- show " finite ((\<lambda>th. preced th s) ` threads s)" by auto
- next
- from False show " (\<lambda>th. preced th s) ` threads s \<noteq> {}" by auto
- qed
- then obtain th' where
- th_in': "th' \<in> ?A " and eq_r: "?r = ?f th'" by auto
- from le_cp [OF vt, of th'] eq_r
- have "?r \<le> cp s th'" by auto
- moreover have "\<dots> \<le> cp s th"
- proof(fold eq_l)
- show " cp s th' \<le> Max (cp s ` threads s)"
- proof(rule Max_ge)
- from th_in' show "cp s th' \<in> cp s ` threads s"
- by auto
- next
- from finite_threads[OF vt]
- show "finite (cp s ` threads s)" by auto
- qed
- qed
- ultimately show ?thesis by auto
- qed
- ultimately show ?thesis using eq_l by auto
-qed
-
-lemma max_cp_readys_threads_pre:
- assumes vt: "vt s"
- and np: "threads s \<noteq> {}"
- shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
-proof(unfold max_cp_eq[OF vt])
- show "Max (cp s ` readys s) = Max ((\<lambda>th. preced th s) ` threads s)"
- proof -
- let ?p = "Max ((\<lambda>th. preced th s) ` threads s)"
- let ?f = "(\<lambda>th. preced th s)"
- have "?p \<in> ((\<lambda>th. preced th s) ` threads s)"
- proof(rule Max_in)
- from finite_threads[OF vt] show "finite (?f ` threads s)" by simp
- next
- from np show "?f ` threads s \<noteq> {}" by simp
- qed
- then obtain tm where tm_max: "?f tm = ?p" and tm_in: "tm \<in> threads s"
- by (auto simp:Image_def)
- from th_chain_to_ready [OF vt tm_in]
- have "tm \<in> readys s \<or> (\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (depend s)\<^sup>+)" .
- thus ?thesis
- proof
- assume "\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (depend s)\<^sup>+ "
- then obtain th' where th'_in: "th' \<in> readys s"
- and tm_chain:"(Th tm, Th th') \<in> (depend s)\<^sup>+" by auto
- have "cp s th' = ?f tm"
- proof(subst cp_eq_cpreced, subst cpreced_def, rule Max_eqI)
- from dependents_threads[OF vt] finite_threads[OF vt]
- show "finite ((\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th'))"
- by (auto intro:finite_subset)
- next
- fix p assume p_in: "p \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')"
- from tm_max have " preced tm s = Max ((\<lambda>th. preced th s) ` threads s)" .
- moreover have "p \<le> \<dots>"
- proof(rule Max_ge)
- from finite_threads[OF vt]
- show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
- next
- from p_in and th'_in and dependents_threads[OF vt, of th']
- show "p \<in> (\<lambda>th. preced th s) ` threads s"
- by (auto simp:readys_def)
- qed
- ultimately show "p \<le> preced tm s" by auto
- next
- show "preced tm s \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependents (wq s) th')"
- proof -
- from tm_chain
- have "tm \<in> dependents (wq s) th'"
- by (unfold cs_dependents_def s_depend_def cs_depend_def, auto)
- thus ?thesis by auto
- qed
- qed
- with tm_max
- have h: "cp s th' = Max ((\<lambda>th. preced th s) ` threads s)" by simp
- show ?thesis
- proof (fold h, rule Max_eqI)
- fix q
- assume "q \<in> cp s ` readys s"
- then obtain th1 where th1_in: "th1 \<in> readys s"
- and eq_q: "q = cp s th1" by auto
- show "q \<le> cp s th'"
- apply (unfold h eq_q)
- apply (unfold cp_eq_cpreced cpreced_def)
- apply (rule Max_mono)
- proof -
- from dependents_threads [OF vt, of th1] th1_in
- show "(\<lambda>th. preced th s) ` ({th1} \<union> dependents (wq s) th1) \<subseteq>
- (\<lambda>th. preced th s) ` threads s"
- by (auto simp:readys_def)
- next
- show "(\<lambda>th. preced th s) ` ({th1} \<union> dependents (wq s) th1) \<noteq> {}" by simp
- next
- from finite_threads[OF vt]
- show " finite ((\<lambda>th. preced th s) ` threads s)" by simp
- qed
- next
- from finite_threads[OF vt]
- show "finite (cp s ` readys s)" by (auto simp:readys_def)
- next
- from th'_in
- show "cp s th' \<in> cp s ` readys s" by simp
- qed
- next
- assume tm_ready: "tm \<in> readys s"
- show ?thesis
- proof(fold tm_max)
- have cp_eq_p: "cp s tm = preced tm s"
- proof(unfold cp_eq_cpreced cpreced_def, rule Max_eqI)
- fix y
- assume hy: "y \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependents (wq s) tm)"
- show "y \<le> preced tm s"
- proof -
- { fix y'
- assume hy' : "y' \<in> ((\<lambda>th. preced th s) ` dependents (wq s) tm)"
- have "y' \<le> preced tm s"
- proof(unfold tm_max, rule Max_ge)
- from hy' dependents_threads[OF vt, of tm]
- show "y' \<in> (\<lambda>th. preced th s) ` threads s" by auto
- next
- from finite_threads[OF vt]
- show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
- qed
- } with hy show ?thesis by auto
- qed
- next
- from dependents_threads[OF vt, of tm] finite_threads[OF vt]
- show "finite ((\<lambda>th. preced th s) ` ({tm} \<union> dependents (wq s) tm))"
- by (auto intro:finite_subset)
- next
- show "preced tm s \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependents (wq s) tm)"
- by simp
- qed
- moreover have "Max (cp s ` readys s) = cp s tm"
- proof(rule Max_eqI)
- from tm_ready show "cp s tm \<in> cp s ` readys s" by simp
- next
- from finite_threads[OF vt]
- show "finite (cp s ` readys s)" by (auto simp:readys_def)
- next
- fix y assume "y \<in> cp s ` readys s"
- then obtain th1 where th1_readys: "th1 \<in> readys s"
- and h: "y = cp s th1" by auto
- show "y \<le> cp s tm"
- apply(unfold cp_eq_p h)
- apply(unfold cp_eq_cpreced cpreced_def tm_max, rule Max_mono)
- proof -
- from finite_threads[OF vt]
- show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
- next
- show "(\<lambda>th. preced th s) ` ({th1} \<union> dependents (wq s) th1) \<noteq> {}"
- by simp
- next
- from dependents_threads[OF vt, of th1] th1_readys
- show "(\<lambda>th. preced th s) ` ({th1} \<union> dependents (wq s) th1)
- \<subseteq> (\<lambda>th. preced th s) ` threads s"
- by (auto simp:readys_def)
- qed
- qed
- ultimately show " Max (cp s ` readys s) = preced tm s" by simp
- qed
- qed
- qed
-qed
-
-lemma max_cp_readys_threads:
- assumes vt: "vt s"
- shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
-proof(cases "threads s = {}")
- case True
- thus ?thesis
- by (auto simp:readys_def)
-next
- case False
- show ?thesis by (rule max_cp_readys_threads_pre[OF vt False])
-qed
-
-
-lemma eq_holding: "holding (wq s) th cs = holding s th cs"
- apply (unfold s_holding_def cs_holding_def wq_def, simp)
- done
-
-lemma f_image_eq:
- assumes h: "\<And> a. a \<in> A \<Longrightarrow> f a = g a"
- shows "f ` A = g ` A"
-proof
- show "f ` A \<subseteq> g ` A"
- by(rule image_subsetI, auto intro:h)
-next
- show "g ` A \<subseteq> f ` A"
- by (rule image_subsetI, auto intro:h[symmetric])
-qed
-
-
-definition detached :: "state \<Rightarrow> thread \<Rightarrow> bool"
- where "detached s th \<equiv> (\<not>(\<exists> cs. holding s th cs)) \<and> (\<not>(\<exists>cs. waiting s th cs))"
-
-
-lemma detached_test:
- shows "detached s th = (Th th \<notin> Field (depend s))"
-apply(simp add: detached_def Field_def)
-apply(simp add: s_depend_def)
-apply(simp add: s_holding_abv s_waiting_abv)
-apply(simp add: Domain_iff Range_iff)
-apply(simp add: wq_def)
-apply(auto)
-done
-
-lemma detached_intro:
- fixes s th
- assumes vt: "vt s"
- and eq_pv: "cntP s th = cntV s th"
- shows "detached s th"
-proof -
- from cnp_cnv_cncs[OF vt]
- have eq_cnt: "cntP s th =
- cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
- hence cncs_zero: "cntCS s th = 0"
- by (auto simp:eq_pv split:if_splits)
- with eq_cnt
- have "th \<in> readys s \<or> th \<notin> threads s" by (auto simp:eq_pv)
- thus ?thesis
- proof
- assume "th \<notin> threads s"
- with range_in[OF vt] dm_depend_threads[OF vt]
- show ?thesis
- by (auto simp add: detached_def s_depend_def s_waiting_abv s_holding_abv wq_def Domain_iff Range_iff)
- next
- assume "th \<in> readys s"
- moreover have "Th th \<notin> Range (depend s)"
- proof -
- from card_0_eq [OF finite_holding [OF vt]] and cncs_zero
- have "holdents s th = {}"
- by (simp add:cntCS_def)
- thus ?thesis
- apply(auto simp:holdents_test)
- apply(case_tac a)
- apply(auto simp:holdents_test s_depend_def)
- done
- qed
- ultimately show ?thesis
- by (auto simp add: detached_def s_depend_def s_waiting_abv s_holding_abv wq_def readys_def)
- qed
-qed
-
-lemma detached_elim:
- fixes s th
- assumes vt: "vt s"
- and dtc: "detached s th"
- shows "cntP s th = cntV s th"
-proof -
- from cnp_cnv_cncs[OF vt]
- have eq_pv: " cntP s th =
- cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
- have cncs_z: "cntCS s th = 0"
- proof -
- from dtc have "holdents s th = {}"
- unfolding detached_def holdents_test s_depend_def
- by (simp add: s_waiting_abv wq_def s_holding_abv Domain_iff Range_iff)
- thus ?thesis by (auto simp:cntCS_def)
- qed
- show ?thesis
- proof(cases "th \<in> threads s")
- case True
- with dtc
- have "th \<in> readys s"
- by (unfold readys_def detached_def Field_def Domain_def Range_def,
- auto simp:eq_waiting s_depend_def)
- with cncs_z and eq_pv show ?thesis by simp
- next
- case False
- with cncs_z and eq_pv show ?thesis by simp
- qed
-qed
-
-lemma detached_eq:
- fixes s th
- assumes vt: "vt s"
- shows "(detached s th) = (cntP s th = cntV s th)"
- by (insert vt, auto intro:detached_intro detached_elim)
-
-end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PrioG.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,3628 @@
+theory PrioG
+imports PrioGDef RTree
+begin
+
+locale valid_trace =
+ fixes s
+ assumes vt : "vt s"
+
+locale valid_trace_e = valid_trace +
+ fixes e
+ assumes vt_e: "vt (e#s)"
+begin
+
+lemma pip_e: "PIP s e"
+ using vt_e by (cases, simp)
+
+end
+
+lemma runing_ready:
+ shows "runing s \<subseteq> readys s"
+ unfolding runing_def readys_def
+ by auto
+
+lemma readys_threads:
+ shows "readys s \<subseteq> threads s"
+ unfolding readys_def
+ by auto
+
+lemma wq_v_neq:
+ "cs \<noteq> cs' \<Longrightarrow> wq (V thread cs#s) cs' = wq s cs'"
+ by (auto simp:wq_def Let_def cp_def split:list.splits)
+
+context valid_trace
+begin
+
+lemma ind [consumes 0, case_names Nil Cons, induct type]:
+ assumes "PP []"
+ and "(\<And>s e. valid_trace s \<Longrightarrow> valid_trace (e#s) \<Longrightarrow>
+ PP s \<Longrightarrow> PIP s e \<Longrightarrow> PP (e # s))"
+ shows "PP s"
+proof(rule vt.induct[OF vt])
+ from assms(1) show "PP []" .
+next
+ fix s e
+ assume h: "vt s" "PP s" "PIP s e"
+ show "PP (e # s)"
+ proof(cases rule:assms(2))
+ from h(1) show v1: "valid_trace s" by (unfold_locales, simp)
+ next
+ from h(1,3) have "vt (e#s)" by auto
+ thus "valid_trace (e # s)" by (unfold_locales, simp)
+ qed (insert h, auto)
+qed
+
+lemma wq_distinct: "distinct (wq s cs)"
+proof(rule ind, simp add:wq_def)
+ fix s e
+ assume h1: "step s e"
+ and h2: "distinct (wq s cs)"
+ thus "distinct (wq (e # s) cs)"
+ proof(induct rule:step.induct, auto simp: wq_def Let_def split:list.splits)
+ fix thread s
+ assume h1: "(Cs cs, Th thread) \<notin> (RAG s)\<^sup>+"
+ and h2: "thread \<in> set (wq_fun (schs s) cs)"
+ and h3: "thread \<in> runing s"
+ show "False"
+ proof -
+ from h3 have "\<And> cs. thread \<in> set (wq_fun (schs s) cs) \<Longrightarrow>
+ thread = hd ((wq_fun (schs s) cs))"
+ by (simp add:runing_def readys_def s_waiting_def wq_def)
+ from this [OF h2] have "thread = hd (wq_fun (schs s) cs)" .
+ with h2
+ have "(Cs cs, Th thread) \<in> (RAG s)"
+ by (simp add:s_RAG_def s_holding_def wq_def cs_holding_def)
+ with h1 show False by auto
+ qed
+ next
+ fix thread s a list
+ assume dst: "distinct list"
+ show "distinct (SOME q. distinct q \<and> set q = set list)"
+ proof(rule someI2)
+ from dst show "distinct list \<and> set list = set list" by auto
+ next
+ fix q assume "distinct q \<and> set q = set list"
+ thus "distinct q" by auto
+ qed
+ qed
+qed
+
+end
+
+
+context valid_trace_e
+begin
+
+text {*
+ The following lemma shows that only the @{text "P"}
+ operation can add new thread into waiting queues.
+ Such kind of lemmas are very obvious, but need to be checked formally.
+ This is a kind of confirmation that our modelling is correct.
+*}
+
+lemma block_pre:
+ assumes s_ni: "thread \<notin> set (wq s cs)"
+ and s_i: "thread \<in> set (wq (e#s) cs)"
+ shows "e = P thread cs"
+proof -
+ show ?thesis
+ proof(cases e)
+ case (P th cs)
+ with assms
+ show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (Create th prio)
+ with assms show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (Exit th)
+ with assms show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (Set th prio)
+ with assms show ?thesis
+ by (auto simp:wq_def Let_def split:if_splits)
+ next
+ case (V th cs)
+ with vt_e assms show ?thesis
+ apply (auto simp:wq_def Let_def split:if_splits)
+ proof -
+ fix q qs
+ assume h1: "thread \<notin> set (wq_fun (schs s) cs)"
+ and h2: "q # qs = wq_fun (schs s) cs"
+ and h3: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
+ and vt: "vt (V th cs # s)"
+ from h1 and h2[symmetric] have "thread \<notin> set (q # qs)" by simp
+ moreover have "thread \<in> set qs"
+ proof -
+ have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
+ proof(rule someI2)
+ from wq_distinct [of cs]
+ and h2[symmetric, folded wq_def]
+ show "distinct qs \<and> set qs = set qs" by auto
+ next
+ fix x assume "distinct x \<and> set x = set qs"
+ thus "set x = set qs" by auto
+ qed
+ with h3 show ?thesis by simp
+ qed
+ ultimately show "False" by auto
+ qed
+ qed
+qed
+
+end
+
+text {*
+ The following lemmas is also obvious and shallow. It says
+ that only running thread can request for a critical resource
+ and that the requested resource must be one which is
+ not current held by the thread.
+*}
+
+lemma p_pre: "\<lbrakk>vt ((P thread cs)#s)\<rbrakk> \<Longrightarrow>
+ thread \<in> runing s \<and> (Cs cs, Th thread) \<notin> (RAG s)^+"
+apply (ind_cases "vt ((P thread cs)#s)")
+apply (ind_cases "step s (P thread cs)")
+by auto
+
+lemma abs1:
+ assumes ein: "e \<in> set es"
+ and neq: "hd es \<noteq> hd (es @ [x])"
+ shows "False"
+proof -
+ from ein have "es \<noteq> []" by auto
+ then obtain e ess where "es = e # ess" by (cases es, auto)
+ with neq show ?thesis by auto
+qed
+
+lemma q_head: "Q (hd es) \<Longrightarrow> hd es = hd [th\<leftarrow>es . Q th]"
+ by (cases es, auto)
+
+inductive_cases evt_cons: "vt (a#s)"
+
+context valid_trace_e
+begin
+
+lemma abs2:
+ assumes inq: "thread \<in> set (wq s cs)"
+ and nh: "thread = hd (wq s cs)"
+ and qt: "thread \<noteq> hd (wq (e#s) cs)"
+ and inq': "thread \<in> set (wq (e#s) cs)"
+ shows "False"
+proof -
+ from vt_e assms show "False"
+ apply (cases e)
+ apply ((simp split:if_splits add:Let_def wq_def)[1])+
+ apply (insert abs1, fast)[1]
+ apply (auto simp:wq_def simp:Let_def split:if_splits list.splits)
+ proof -
+ fix th qs
+ assume vt: "vt (V th cs # s)"
+ and th_in: "thread \<in> set (SOME q. distinct q \<and> set q = set qs)"
+ and eq_wq: "wq_fun (schs s) cs = thread # qs"
+ show "False"
+ proof -
+ from wq_distinct[of cs]
+ and eq_wq[folded wq_def] have "distinct (thread#qs)" by simp
+ moreover have "thread \<in> set qs"
+ proof -
+ have "set (SOME q. distinct q \<and> set q = set qs) = set qs"
+ proof(rule someI2)
+ from wq_distinct [of cs]
+ and eq_wq [folded wq_def]
+ show "distinct qs \<and> set qs = set qs" by auto
+ next
+ fix x assume "distinct x \<and> set x = set qs"
+ thus "set x = set qs" by auto
+ qed
+ with th_in show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ qed
+qed
+
+end
+
+context valid_trace
+begin
+
+lemma vt_moment: "\<And> t. vt (moment t s)"
+proof(induct rule:ind)
+ case Nil
+ thus ?case by (simp add:vt_nil)
+next
+ case (Cons s e t)
+ show ?case
+ proof(cases "t \<ge> length (e#s)")
+ case True
+ from True have "moment t (e#s) = e#s" by simp
+ thus ?thesis using Cons
+ by (simp add:valid_trace_def)
+ next
+ case False
+ from Cons have "vt (moment t s)" by simp
+ moreover have "moment t (e#s) = moment t s"
+ proof -
+ from False have "t \<le> length s" by simp
+ from moment_app [OF this, of "[e]"]
+ show ?thesis by simp
+ qed
+ ultimately show ?thesis by simp
+ qed
+qed
+
+(* Wrong:
+ lemma \<lbrakk>thread \<in> set (wq_fun cs1 s); thread \<in> set (wq_fun cs2 s)\<rbrakk> \<Longrightarrow> cs1 = cs2"
+*)
+
+text {* (* ddd *)
+ The nature of the work is like this: since it starts from a very simple and basic
+ model, even intuitively very `basic` and `obvious` properties need to derived from scratch.
+ For instance, the fact
+ that one thread can not be blocked by two critical resources at the same time
+ is obvious, because only running threads can make new requests, if one is waiting for
+ a critical resource and get blocked, it can not make another resource request and get
+ blocked the second time (because it is not running).
+
+ To derive this fact, one needs to prove by contraction and
+ reason about time (or @{text "moement"}). The reasoning is based on a generic theorem
+ named @{text "p_split"}, which is about status changing along the time axis. It says if
+ a condition @{text "Q"} is @{text "True"} at a state @{text "s"},
+ but it was @{text "False"} at the very beginning, then there must exits a moment @{text "t"}
+ in the history of @{text "s"} (notice that @{text "s"} itself is essentially the history
+ of events leading to it), such that @{text "Q"} switched
+ from being @{text "False"} to @{text "True"} and kept being @{text "True"}
+ till the last moment of @{text "s"}.
+
+ Suppose a thread @{text "th"} is blocked
+ on @{text "cs1"} and @{text "cs2"} in some state @{text "s"},
+ since no thread is blocked at the very beginning, by applying
+ @{text "p_split"} to these two blocking facts, there exist
+ two moments @{text "t1"} and @{text "t2"} in @{text "s"}, such that
+ @{text "th"} got blocked on @{text "cs1"} and @{text "cs2"}
+ and kept on blocked on them respectively ever since.
+
+ Without lose of generality, we assume @{text "t1"} is earlier than @{text "t2"}.
+ However, since @{text "th"} was blocked ever since memonent @{text "t1"}, so it was still
+ in blocked state at moment @{text "t2"} and could not
+ make any request and get blocked the second time: Contradiction.
+*}
+
+lemma waiting_unique_pre:
+ assumes h11: "thread \<in> set (wq s cs1)"
+ and h12: "thread \<noteq> hd (wq s cs1)"
+ assumes h21: "thread \<in> set (wq s cs2)"
+ and h22: "thread \<noteq> hd (wq s cs2)"
+ and neq12: "cs1 \<noteq> cs2"
+ shows "False"
+proof -
+ let "?Q cs s" = "thread \<in> set (wq s cs) \<and> thread \<noteq> hd (wq s cs)"
+ from h11 and h12 have q1: "?Q cs1 s" by simp
+ from h21 and h22 have q2: "?Q cs2 s" by simp
+ have nq1: "\<not> ?Q cs1 []" by (simp add:wq_def)
+ have nq2: "\<not> ?Q cs2 []" by (simp add:wq_def)
+ from p_split [of "?Q cs1", OF q1 nq1]
+ obtain t1 where lt1: "t1 < length s"
+ and np1: "\<not>(thread \<in> set (wq (moment t1 s) cs1) \<and>
+ thread \<noteq> hd (wq (moment t1 s) cs1))"
+ and nn1: "(\<forall>i'>t1. thread \<in> set (wq (moment i' s) cs1) \<and>
+ thread \<noteq> hd (wq (moment i' s) cs1))" by auto
+ from p_split [of "?Q cs2", OF q2 nq2]
+ obtain t2 where lt2: "t2 < length s"
+ and np2: "\<not>(thread \<in> set (wq (moment t2 s) cs2) \<and>
+ thread \<noteq> hd (wq (moment t2 s) cs2))"
+ and nn2: "(\<forall>i'>t2. thread \<in> set (wq (moment i' s) cs2) \<and>
+ thread \<noteq> hd (wq (moment i' s) cs2))" by auto
+ show ?thesis
+ proof -
+ {
+ assume lt12: "t1 < t2"
+ let ?t3 = "Suc t2"
+ from lt2 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t2 s" by auto
+ have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t2 s" "e"
+ by (unfold_locales, auto, cases, simp)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre[OF False h1]
+ have "e = P thread cs2" .
+ with vt_e.vt_e have "vt ((P thread cs2)# moment t2 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t2 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t2 s)" by auto
+ with nn1 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume lt12: "t2 < t1"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 True eq_th h2 h1
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have "e = P thread cs1" .
+ with vt_e.vt_e have "vt ((P thread cs1)# moment t1 s)" by simp
+ from p_pre [OF this] have "thread \<in> runing (moment t1 s)" by simp
+ with runing_ready have "thread \<in> readys (moment t1 s)" by auto
+ with nn2 [rule_format, OF lt12]
+ show ?thesis by (simp add:readys_def wq_def s_waiting_def, auto)
+ qed
+ } moreover {
+ assume eqt12: "t1 = t2"
+ let ?t3 = "Suc t1"
+ from lt1 have le_t3: "?t3 \<le> length s" by auto
+ from moment_plus [OF this]
+ obtain e where eq_m: "moment ?t3 s = e#moment t1 s" by auto
+ have lt_t3: "t1 < ?t3" by simp
+ from nn1 [rule_format, OF this] and eq_m
+ have h1: "thread \<in> set (wq (e#moment t1 s) cs1)" and
+ h2: "thread \<noteq> hd (wq (e#moment t1 s) cs1)" by auto
+ have vt_e: "vt (e#moment t1 s)"
+ proof -
+ from vt_moment
+ have "vt (moment ?t3 s)" .
+ with eq_m show ?thesis by simp
+ qed
+ then interpret vt_e: valid_trace_e "moment t1 s" e
+ by (unfold_locales, auto, cases, auto)
+ have ?thesis
+ proof(cases "thread \<in> set (wq (moment t1 s) cs1)")
+ case True
+ from True and np1 have eq_th: "thread = hd (wq (moment t1 s) cs1)"
+ by auto
+ from vt_e.abs2 [OF True eq_th h2 h1]
+ show ?thesis by auto
+ next
+ case False
+ from vt_e.block_pre [OF False h1]
+ have eq_e1: "e = P thread cs1" .
+ have lt_t3: "t1 < ?t3" by simp
+ with eqt12 have "t2 < ?t3" by simp
+ from nn2 [rule_format, OF this] and eq_m and eqt12
+ have h1: "thread \<in> set (wq (e#moment t2 s) cs2)" and
+ h2: "thread \<noteq> hd (wq (e#moment t2 s) cs2)" by auto
+ show ?thesis
+ proof(cases "thread \<in> set (wq (moment t2 s) cs2)")
+ case True
+ from True and np2 have eq_th: "thread = hd (wq (moment t2 s) cs2)"
+ by auto
+ from vt_e and eqt12 have "vt (e#moment t2 s)" by simp
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.abs2 [OF True eq_th h2 h1]
+ show ?thesis .
+ next
+ case False
+ have "vt (e#moment t2 s)"
+ proof -
+ from vt_moment eqt12
+ have "vt (moment (Suc t2) s)" by auto
+ with eq_m eqt12 show ?thesis by simp
+ qed
+ then interpret vt_e2: valid_trace_e "moment t2 s" e
+ by (unfold_locales, auto, cases, auto)
+ from vt_e2.block_pre [OF False h1]
+ have "e = P thread cs2" .
+ with eq_e1 neq12 show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by arith
+ qed
+qed
+
+text {*
+ This lemma is a simple corrolary of @{text "waiting_unique_pre"}.
+*}
+
+lemma waiting_unique:
+ assumes "waiting s th cs1"
+ and "waiting s th cs2"
+ shows "cs1 = cs2"
+using waiting_unique_pre assms
+unfolding wq_def s_waiting_def
+by auto
+
+end
+
+(* not used *)
+text {*
+ Every thread can only be blocked on one critical resource,
+ symmetrically, every critical resource can only be held by one thread.
+ This fact is much more easier according to our definition.
+*}
+lemma held_unique:
+ assumes "holding (s::event list) th1 cs"
+ and "holding s th2 cs"
+ shows "th1 = th2"
+ by (insert assms, unfold s_holding_def, auto)
+
+
+lemma last_set_lt: "th \<in> threads s \<Longrightarrow> last_set th s < length s"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits)
+
+lemma last_set_unique:
+ "\<lbrakk>last_set th1 s = last_set th2 s; th1 \<in> threads s; th2 \<in> threads s\<rbrakk>
+ \<Longrightarrow> th1 = th2"
+ apply (induct s, auto)
+ by (case_tac a, auto split:if_splits dest:last_set_lt)
+
+lemma preced_unique :
+ assumes pcd_eq: "preced th1 s = preced th2 s"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "th1 = th2"
+proof -
+ from pcd_eq have "last_set th1 s = last_set th2 s" by (simp add:preced_def)
+ from last_set_unique [OF this th_in1 th_in2]
+ show ?thesis .
+qed
+
+lemma preced_linorder:
+ assumes neq_12: "th1 \<noteq> th2"
+ and th_in1: "th1 \<in> threads s"
+ and th_in2: " th2 \<in> threads s"
+ shows "preced th1 s < preced th2 s \<or> preced th1 s > preced th2 s"
+proof -
+ from preced_unique [OF _ th_in1 th_in2] and neq_12
+ have "preced th1 s \<noteq> preced th2 s" by auto
+ thus ?thesis by auto
+qed
+
+(* An aux lemma used later *)
+lemma unique_minus:
+ fixes x y z r
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz and neq show ?thesis
+ proof(induct)
+ case (base ya)
+ have "(x, ya) \<in> r" by fact
+ from unique [OF xy this] have "y = ya" .
+ with base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from step True show ?thesis by simp
+ next
+ case False
+ from step False
+ show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_base:
+ fixes r x y z
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+"
+proof -
+ from xz neq_yz show ?thesis
+ proof(induct)
+ case (base ya)
+ from xy unique base show ?case by auto
+ next
+ case (step ya z)
+ show ?case
+ proof(cases "y = ya")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step
+ have "(y, ya) \<in> r\<^sup>+" by auto
+ with step show ?thesis by auto
+ qed
+ qed
+qed
+
+lemma unique_chain:
+ fixes r x y z
+ assumes unique: "\<And> a b c. \<lbrakk>(a, b) \<in> r; (a, c) \<in> r\<rbrakk> \<Longrightarrow> b = c"
+ and xy: "(x, y) \<in> r^+"
+ and xz: "(x, z) \<in> r^+"
+ and neq_yz: "y \<noteq> z"
+ shows "(y, z) \<in> r^+ \<or> (z, y) \<in> r^+"
+proof -
+ from xy xz neq_yz show ?thesis
+ proof(induct)
+ case (base y)
+ have h1: "(x, y) \<in> r" and h2: "(x, z) \<in> r\<^sup>+" and h3: "y \<noteq> z" using base by auto
+ from unique_base [OF _ h1 h2 h3] and unique show ?case by auto
+ next
+ case (step y za)
+ show ?case
+ proof(cases "y = z")
+ case True
+ from True step show ?thesis by auto
+ next
+ case False
+ from False step have "(y, z) \<in> r\<^sup>+ \<or> (z, y) \<in> r\<^sup>+" by auto
+ thus ?thesis
+ proof
+ assume "(z, y) \<in> r\<^sup>+"
+ with step have "(z, za) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ next
+ assume h: "(y, z) \<in> r\<^sup>+"
+ from step have yza: "(y, za) \<in> r" by simp
+ from step have "za \<noteq> z" by simp
+ from unique_minus [OF _ yza h this] and unique
+ have "(za, z) \<in> r\<^sup>+" by auto
+ thus ?thesis by auto
+ qed
+ qed
+ qed
+qed
+
+text {*
+ The following three lemmas show that @{text "RAG"} does not change
+ by the happening of @{text "Set"}, @{text "Create"} and @{text "Exit"}
+ events, respectively.
+*}
+
+lemma RAG_set_unchanged: "(RAG (Set th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_create_unchanged: "(RAG (Create th prio # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+lemma RAG_exit_unchanged: "(RAG (Exit th # s)) = RAG s"
+apply (unfold s_RAG_def s_waiting_def wq_def)
+by (simp add:Let_def)
+
+
+text {*
+ The following lemmas are used in the proof of
+ lemma @{text "step_RAG_v"}, which characterizes how the @{text "RAG"} is changed
+ by @{text "V"}-events.
+ However, since our model is very concise, such seemingly obvious lemmas need to be derived from scratch,
+ starting from the model definitions.
+*}
+lemma step_v_hold_inv[elim_format]:
+ "\<And>c t. \<lbrakk>vt (V th cs # s);
+ \<not> holding (wq s) t c; holding (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow>
+ next_th s th cs t \<and> c = cs"
+proof -
+ fix c t
+ assume vt: "vt (V th cs # s)"
+ and nhd: "\<not> holding (wq s) t c"
+ and hd: "holding (wq (V th cs # s)) t c"
+ show "next_th s th cs t \<and> c = cs"
+ proof(cases "c = cs")
+ case False
+ with nhd hd show ?thesis
+ by (unfold cs_holding_def wq_def, auto simp:Let_def)
+ next
+ case True
+ with step_back_step [OF vt]
+ have "step s (V th c)" by simp
+ hence "next_th s th cs t"
+ proof(cases)
+ assume "holding s th c"
+ with nhd hd show ?thesis
+ apply (unfold s_holding_def cs_holding_def wq_def next_th_def,
+ auto simp:Let_def split:list.splits if_splits)
+ proof -
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ next
+ assume " hd (SOME q. distinct q \<and> q = []) \<in> set (SOME q. distinct q \<and> q = [])"
+ moreover have "\<dots> = set []"
+ proof(rule someI2)
+ show "distinct [] \<and> [] = []" by auto
+ next
+ fix x assume "distinct x \<and> x = []"
+ thus "set x = set []" by auto
+ qed
+ ultimately show False by auto
+ qed
+ qed
+ with True show ?thesis by auto
+ qed
+qed
+
+text {*
+ The following @{text "step_v_wait_inv"} is also an obvious lemma, which, however, needs to be
+ derived from scratch, which confirms the correctness of the definition of @{text "next_th"}.
+*}
+lemma step_v_wait_inv[elim_format]:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); \<not> waiting (wq (V th cs # s)) t c; waiting (wq s) t c
+ \<rbrakk>
+ \<Longrightarrow> (next_th s th cs t \<and> cs = c)"
+proof -
+ fix t c
+ assume vt: "vt (V th cs # s)"
+ and nw: "\<not> waiting (wq (V th cs # s)) t c"
+ and wt: "waiting (wq s) t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp)
+ show "next_th s th cs t \<and> cs = c"
+ proof(cases "cs = c")
+ case False
+ with nw wt show ?thesis
+ by (auto simp:cs_waiting_def wq_def Let_def)
+ next
+ case True
+ from nw[folded True] wt[folded True]
+ have "next_th s th cs t"
+ apply (unfold next_th_def, auto simp:cs_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "a = th" by auto
+ next
+ fix a list
+ assume t_in: "t \<in> set list"
+ and t_ni: "t \<notin> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have " set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ with t_ni and t_in show "t = hd (SOME q. distinct q \<and> set q = set list)" by auto
+ next
+ fix a list
+ assume eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step[OF vt]
+ show "a = th"
+ proof(cases)
+ assume "holding s th cs"
+ with eq_wq show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+ with True show ?thesis by simp
+ qed
+qed
+
+lemma step_v_not_wait[consumes 3]:
+ "\<lbrakk>vt (V th cs # s); next_th s th cs t; waiting (wq (V th cs # s)) t cs\<rbrakk> \<Longrightarrow> False"
+ by (unfold next_th_def cs_waiting_def wq_def, auto simp:Let_def)
+
+lemma step_v_release:
+ "\<lbrakk>vt (V th cs # s); holding (wq (V th cs # s)) th cs\<rbrakk> \<Longrightarrow> False"
+proof -
+ assume vt: "vt (V th cs # s)"
+ and hd: "holding (wq (V th cs # s)) th cs"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ from step_back_step [OF vt] and hd
+ show "False"
+ proof(cases)
+ assume "holding (wq (V th cs # s)) th cs" and "holding s th cs"
+ thus ?thesis
+ apply (unfold s_holding_def wq_def cs_holding_def)
+ apply (auto simp:Let_def split:list.splits)
+ proof -
+ fix list
+ assume eq_wq[folded wq_def]:
+ "wq_fun (schs s) cs = hd (SOME q. distinct q \<and> set q = set list) # list"
+ and hd_in: "hd (SOME q. distinct q \<and> set q = set list)
+ \<in> set (SOME q. distinct q \<and> set q = set list)"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct list \<and> set list = set list" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set list \<Longrightarrow> set x = set list"
+ by auto
+ qed
+ moreover have "distinct (hd (SOME q. distinct q \<and> set q = set list) # list)"
+ proof -
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show ?thesis by auto
+ qed
+ moreover note eq_wq and hd_in
+ ultimately show "False" by auto
+ qed
+ qed
+qed
+
+lemma step_v_get_hold:
+ "\<And>th'. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) th' cs; next_th s th cs th'\<rbrakk> \<Longrightarrow> False"
+ apply (unfold cs_holding_def next_th_def wq_def,
+ auto simp:Let_def)
+proof -
+ fix rest
+ assume vt: "vt (V th cs # s)"
+ and eq_wq[folded wq_def]: " wq_fun (schs s) cs = th # rest"
+ and nrest: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest)
+ \<notin> set (SOME q. distinct q \<and> set q = set rest)"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ hence "set x = set rest" by auto
+ with nrest
+ show "x \<noteq> []" by (case_tac x, auto)
+ qed
+ with ni show "False" by auto
+qed
+
+lemma step_v_release_inv[elim_format]:
+"\<And>c t. \<lbrakk>vt (V th cs # s); \<not> holding (wq (V th cs # s)) t c; holding (wq s) t c\<rbrakk> \<Longrightarrow>
+ c = cs \<and> t = th"
+ apply (unfold cs_holding_def wq_def, auto simp:Let_def split:if_splits list.splits)
+ proof -
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ next
+ fix a list
+ assume vt: "vt (V th cs # s)" and eq_wq: "wq_fun (schs s) cs = a # list"
+ from step_back_step [OF vt] show "a = th"
+ proof(cases)
+ assume "holding s th cs" with eq_wq
+ show ?thesis
+ by (unfold s_holding_def wq_def, auto)
+ qed
+ qed
+
+lemma step_v_waiting_mono:
+ "\<And>t c. \<lbrakk>vt (V th cs # s); waiting (wq (V th cs # s)) t c\<rbrakk> \<Longrightarrow> waiting (wq s) t c"
+proof -
+ fix t c
+ let ?s' = "(V th cs # s)"
+ assume vt: "vt ?s'"
+ and wt: "waiting (wq ?s') t c"
+ from vt interpret vt_v: valid_trace_e s "V th cs"
+ by (cases, unfold_locales, simp+)
+ show "waiting (wq s) t c"
+ proof(cases "c = cs")
+ case False
+ assume neq_cs: "c \<noteq> cs"
+ hence "waiting (wq ?s') t c = waiting (wq s) t c"
+ by (unfold cs_waiting_def wq_def, auto simp:Let_def)
+ with wt show ?thesis by simp
+ next
+ case True
+ with wt show ?thesis
+ apply (unfold cs_waiting_def wq_def, auto simp:Let_def split:list.splits)
+ proof -
+ fix a list
+ assume not_in: "t \<notin> set list"
+ and is_in: "t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ and eq_wq: "wq_fun (schs s) cs = a # list"
+ have "set (SOME q. distinct q \<and> set q = set list) = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ with not_in is_in show "t = a" by auto
+ next
+ fix list
+ assume is_waiting: "waiting (wq (V th cs # s)) t cs"
+ and eq_wq: "wq_fun (schs s) cs = t # list"
+ hence "t \<in> set list"
+ apply (unfold wq_def, auto simp:Let_def cs_waiting_def)
+ proof -
+ assume " t \<in> set (SOME q. distinct q \<and> set q = set list)"
+ moreover have "\<dots> = set list"
+ proof(rule someI2)
+ from vt_v.wq_distinct [of cs]
+ and eq_wq[folded wq_def]
+ show "distinct list \<and> set list = set list" by auto
+ next
+ fix x assume "distinct x \<and> set x = set list"
+ thus "set x = set list" by auto
+ qed
+ ultimately show "t \<in> set list" by simp
+ qed
+ with eq_wq and vt_v.wq_distinct [of cs, unfolded wq_def]
+ show False by auto
+ qed
+ qed
+qed
+
+text {* (* ddd *)
+ The following @{text "step_RAG_v"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "V"}-events:
+*}
+lemma step_RAG_v:
+fixes th::thread
+assumes vt:
+ "vt (V th cs#s)"
+shows "
+ RAG (V th cs # s) =
+ RAG s - {(Cs cs, Th th)} -
+ {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ apply (insert vt, unfold s_RAG_def)
+ apply (auto split:if_splits list.splits simp:Let_def)
+ apply (auto elim: step_v_waiting_mono step_v_hold_inv
+ step_v_release step_v_wait_inv
+ step_v_get_hold step_v_release_inv)
+ apply (erule_tac step_v_not_wait, auto)
+ done
+
+text {*
+ The following @{text "step_RAG_p"} lemma charaterizes how @{text "RAG"} is changed
+ with the happening of @{text "P"}-events:
+*}
+lemma step_RAG_p:
+ "vt (P th cs#s) \<Longrightarrow>
+ RAG (P th cs # s) = (if (wq s cs = []) then RAG s \<union> {(Cs cs, Th th)}
+ else RAG s \<union> {(Th th, Cs cs)})"
+ apply(simp only: s_RAG_def wq_def)
+ apply (auto split:list.splits prod.splits simp:Let_def wq_def cs_waiting_def cs_holding_def)
+ apply(case_tac "csa = cs", auto)
+ apply(fold wq_def)
+ apply(drule_tac step_back_step)
+ apply(ind_cases " step s (P (hd (wq s cs)) cs)")
+ apply(simp add:s_RAG_def wq_def cs_holding_def)
+ apply(auto)
+ done
+
+
+lemma RAG_target_th: "(Th th, x) \<in> RAG (s::state) \<Longrightarrow> \<exists> cs. x = Cs cs"
+ by (unfold s_RAG_def, auto)
+
+context valid_trace
+begin
+
+text {*
+ The following lemma shows that @{text "RAG"} is acyclic.
+ The overall structure is by induction on the formation of @{text "vt s"}
+ and then case analysis on event @{text "e"}, where the non-trivial cases
+ for those for @{text "V"} and @{text "P"} events.
+*}
+lemma acyclic_RAG:
+ shows "acyclic (RAG s)"
+using vt
+proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "acyclic (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de:
+ "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ from ih have ac: "acyclic (?A - ?B - ?C)" by (auto elim:acyclic_subset)
+ from step_back_step [OF vtt]
+ have "step s (V th cs)" .
+ thus ?thesis
+ proof(cases)
+ assume "holding s th cs"
+ hence th_in: "th \<in> set (wq s cs)" and
+ eq_hd: "th = hd (wq s cs)" unfolding s_holding_def wq_def by auto
+ then obtain rest where
+ eq_wq: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ show ?thesis
+ proof(cases "rest = []")
+ case False
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ from eq_wq False have eq_D: "?D = {(Cs cs, Th ?th')}"
+ by (unfold next_th_def, auto)
+ let ?E = "(?A - ?B - ?C)"
+ have "(Th ?th', Cs cs) \<notin> ?E\<^sup>*"
+ proof
+ assume "(Th ?th', Cs cs) \<in> ?E\<^sup>*"
+ hence " (Th ?th', Cs cs) \<in> ?E\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD [OF this]
+ obtain x where th'_e: "(Th ?th', x) \<in> ?E" by blast
+ hence th_d: "(Th ?th', x) \<in> ?A" by simp
+ from RAG_target_th [OF this]
+ obtain cs' where eq_x: "x = Cs cs'" by auto
+ with th_d have "(Th ?th', Cs cs') \<in> ?A" by simp
+ hence wt_th': "waiting s ?th' cs'"
+ unfolding s_RAG_def s_waiting_def cs_waiting_def wq_def by simp
+ hence "cs' = cs"
+ proof(rule vt_s.waiting_unique)
+ from eq_wq vt_s.wq_distinct[of cs]
+ show "waiting s ?th' cs"
+ apply (unfold s_waiting_def wq_def, auto)
+ proof -
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq_fun (schs s) cs = th # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" unfolding wq_def by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show "hd (SOME q. distinct q \<and> set q = set rest) = th" by auto
+ next
+ assume hd_in: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = hd (SOME q. distinct q \<and> set q = set rest) # rest"
+ have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with False show "x \<noteq> []" by auto
+ qed
+ hence "hd (SOME q. distinct q \<and> set q = set rest) \<in>
+ set (SOME q. distinct q \<and> set q = set rest)" by auto
+ moreover have "\<dots> = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ moreover note hd_in
+ ultimately show False by auto
+ qed
+ qed
+ with th'_e eq_x have "(Th ?th', Cs cs) \<in> ?E" by simp
+ with False
+ show "False" by (auto simp: next_th_def eq_wq)
+ qed
+ with acyclic_insert[symmetric] and ac
+ and eq_de eq_D show ?thesis by auto
+ next
+ case True
+ with eq_wq
+ have eq_D: "?D = {}"
+ by (unfold next_th_def, auto)
+ with eq_de ac
+ show ?thesis by auto
+ qed
+ qed
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "acyclic ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ have "(Th th, Cs cs) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Th th, Cs cs) \<in> (RAG s)\<^sup>*"
+ hence "(Th th, Cs cs) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ from tranclD2 [OF this]
+ obtain x where "(x, Cs cs) \<in> RAG s" by auto
+ with True show False by (auto simp:s_RAG_def cs_waiting_def)
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ next
+ case False
+ hence eq_r: "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ have "(Cs cs, Th th) \<notin> (RAG s)\<^sup>*"
+ proof
+ assume "(Cs cs, Th th) \<in> (RAG s)\<^sup>*"
+ hence "(Cs cs, Th th) \<in> (RAG s)\<^sup>+" by (simp add: rtrancl_eq_or_trancl)
+ moreover from step_back_step [OF vtt] have "step s (P th cs)" .
+ ultimately show False
+ proof -
+ show " \<lbrakk>(Cs cs, Th th) \<in> (RAG s)\<^sup>+; step s (P th cs)\<rbrakk> \<Longrightarrow> False"
+ by (ind_cases "step s (P th cs)", simp)
+ qed
+ qed
+ with acyclic_insert ih eq_r show ?thesis by auto
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (Set thread prio)
+ with ih
+ thm RAG_set_unchanged
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "acyclic (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+qed
+
+
+lemma finite_RAG:
+ shows "finite (RAG s)"
+proof -
+ from vt show ?thesis
+ proof(induct)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume ih: "finite (RAG s)"
+ and stp: "step s e"
+ and vt: "vt s"
+ show ?case
+ proof(cases e)
+ case (Create th prio)
+ with ih
+ show ?thesis by (simp add:RAG_create_unchanged)
+ next
+ case (Exit th)
+ with ih show ?thesis by (simp add:RAG_exit_unchanged)
+ next
+ case (V th cs)
+ from V vt stp have vtt: "vt (V th cs#s)" by auto
+ from step_RAG_v [OF this]
+ have eq_de: "RAG (e # s) =
+ RAG s - {(Cs cs, Th th)} - {(Th th', Cs cs) |th'. next_th s th cs th'} \<union>
+ {(Cs cs, Th th') |th'. next_th s th cs th'}
+"
+ (is "?L = (?A - ?B - ?C) \<union> ?D") by (simp add:V)
+ moreover from ih have ac: "finite (?A - ?B - ?C)" by simp
+ moreover have "finite ?D"
+ proof -
+ have "?D = {} \<or> (\<exists> a. ?D = {a})"
+ by (unfold next_th_def, auto)
+ thus ?thesis
+ proof
+ assume h: "?D = {}"
+ show ?thesis by (unfold h, simp)
+ next
+ assume "\<exists> a. ?D = {a}"
+ thus ?thesis
+ by (metis finite.simps)
+ qed
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (P th cs)
+ from P vt stp have vtt: "vt (P th cs#s)" by auto
+ from step_RAG_p [OF this] P
+ have "RAG (e # s) =
+ (if wq s cs = [] then RAG s \<union> {(Cs cs, Th th)} else
+ RAG s \<union> {(Th th, Cs cs)})" (is "?L = ?R")
+ by simp
+ moreover have "finite ?R"
+ proof(cases "wq s cs = []")
+ case True
+ hence eq_r: "?R = RAG s \<union> {(Cs cs, Th th)}" by simp
+ with True and ih show ?thesis by auto
+ next
+ case False
+ hence "?R = RAG s \<union> {(Th th, Cs cs)}" by simp
+ with False and ih show ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ next
+ case (Set thread prio)
+ with ih
+ show ?thesis by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show "finite (RAG ([]::state))"
+ by (auto simp: s_RAG_def cs_waiting_def
+ cs_holding_def wq_def acyclic_def)
+ qed
+qed
+
+text {* Several useful lemmas *}
+
+lemma wf_dep_converse:
+ shows "wf ((RAG s)^-1)"
+proof(rule finite_acyclic_wf_converse)
+ from finite_RAG
+ show "finite (RAG s)" .
+next
+ from acyclic_RAG
+ show "acyclic (RAG s)" .
+qed
+
+end
+
+lemma hd_np_in: "x \<in> set l \<Longrightarrow> hd l \<in> set l"
+ by (induct l, auto)
+
+lemma th_chasing: "(Th th, Cs cs) \<in> RAG (s::state) \<Longrightarrow> \<exists> th'. (Cs cs, Th th') \<in> RAG s"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+
+context valid_trace
+begin
+
+lemma wq_threads:
+ assumes h: "th \<in> set (wq s cs)"
+ shows "th \<in> threads s"
+proof -
+ from vt and h show ?thesis
+ proof(induct arbitrary: th cs)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s
+ using vt_cons(1) by (unfold_locales, auto)
+ assume ih: "\<And>th cs. th \<in> set (wq s cs) \<Longrightarrow> th \<in> threads s"
+ and stp: "step s e"
+ and vt: "vt s"
+ and h: "th \<in> set (wq (e # s) cs)"
+ show ?case
+ proof(cases e)
+ case (Create th' prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ next
+ case (Exit th')
+ with stp ih h show ?thesis
+ apply (auto simp:wq_def Let_def)
+ apply (ind_cases "step s (Exit th')")
+ apply (auto simp:runing_def readys_def s_holding_def s_waiting_def holdents_def
+ s_RAG_def s_holding_def cs_holding_def)
+ done
+ next
+ case (V th' cs')
+ show ?thesis
+ proof(cases "cs' = cs")
+ case False
+ with h
+ show ?thesis
+ apply(unfold wq_def V, auto simp:Let_def V split:prod.splits, fold wq_def)
+ by (drule_tac ih, simp)
+ next
+ case True
+ from h
+ show ?thesis
+ proof(unfold V wq_def)
+ assume th_in: "th \<in> set (wq_fun (schs (V th' cs' # s)) cs)" (is "th \<in> set ?l")
+ show "th \<in> threads (V th' cs' # s)"
+ proof(cases "cs = cs'")
+ case False
+ hence "?l = wq_fun (schs s) cs" by (simp add:Let_def)
+ with th_in have " th \<in> set (wq s cs)"
+ by (fold wq_def, simp)
+ from ih [OF this] show ?thesis by simp
+ next
+ case True
+ show ?thesis
+ proof(cases "wq_fun (schs s) cs'")
+ case Nil
+ with h V show ?thesis
+ apply (auto simp:wq_def Let_def split:if_splits)
+ by (fold wq_def, drule_tac ih, simp)
+ next
+ case (Cons a rest)
+ assume eq_wq: "wq_fun (schs s) cs' = a # rest"
+ with h V show ?thesis
+ apply (auto simp:Let_def wq_def split:if_splits)
+ proof -
+ assume th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_s.wq_distinct[of cs'] and eq_wq[folded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ with eq_wq th_in have "th \<in> set (wq_fun (schs s) cs')" by auto
+ from ih[OF this[folded wq_def]] show "th \<in> threads s" .
+ next
+ assume th_in: "th \<in> set (wq_fun (schs s) cs)"
+ from ih[OF this[folded wq_def]]
+ show "th \<in> threads s" .
+ qed
+ qed
+ qed
+ qed
+ qed
+ next
+ case (P th' cs')
+ from h stp
+ show ?thesis
+ apply (unfold P wq_def)
+ apply (auto simp:Let_def split:if_splits, fold wq_def)
+ apply (auto intro:ih)
+ apply(ind_cases "step s (P th' cs')")
+ by (unfold runing_def readys_def, auto)
+ next
+ case (Set thread prio)
+ with ih h show ?thesis
+ by (auto simp:wq_def Let_def)
+ qed
+ next
+ case vt_nil
+ thus ?case by (auto simp:wq_def)
+ qed
+qed
+
+lemma range_in: "\<lbrakk>(Th th) \<in> Range (RAG (s::state))\<rbrakk> \<Longrightarrow> th \<in> threads s"
+ apply(unfold s_RAG_def cs_waiting_def cs_holding_def)
+ by (auto intro:wq_threads)
+
+lemma readys_v_eq:
+ fixes th thread cs rest
+ assumes neq_th: "th \<noteq> thread"
+ and eq_wq: "wq s cs = thread#rest"
+ and not_in: "th \<notin> set rest"
+ shows "(th \<in> readys (V thread cs#s)) = (th \<in> readys s)"
+proof -
+ from assms show ?thesis
+ apply (auto simp:readys_def)
+ apply(simp add:s_waiting_def[folded wq_def])
+ apply (erule_tac x = csa in allE)
+ apply (simp add:s_waiting_def wq_def Let_def split:if_splits)
+ apply (case_tac "csa = cs", simp)
+ apply (erule_tac x = cs in allE)
+ apply(auto simp add: s_waiting_def[folded wq_def] Let_def split: list.splits)
+ apply(auto simp add: wq_def)
+ apply (auto simp:s_waiting_def wq_def Let_def split:list.splits)
+ proof -
+ assume th_nin: "th \<notin> set rest"
+ and th_in: "th \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ and eq_wq: "wq_fun (schs s) cs = thread # rest"
+ have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from wq_distinct[of cs, unfolded wq_def] and eq_wq[unfolded wq_def]
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ with th_nin th_in show False by auto
+ qed
+qed
+
+text {* \noindent
+ The following lemmas shows that: starting from any node in @{text "RAG"},
+ by chasing out-going edges, it is always possible to reach a node representing a ready
+ thread. In this lemma, it is the @{text "th'"}.
+*}
+
+lemma chain_building:
+ shows "node \<in> Domain (RAG s) \<longrightarrow> (\<exists> th'. th' \<in> readys s \<and> (node, Th th') \<in> (RAG s)^+)"
+proof -
+ from wf_dep_converse
+ have h: "wf ((RAG s)\<inverse>)" .
+ show ?thesis
+ proof(induct rule:wf_induct [OF h])
+ fix x
+ assume ih [rule_format]:
+ "\<forall>y. (y, x) \<in> (RAG s)\<inverse> \<longrightarrow>
+ y \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (y, Th th') \<in> (RAG s)\<^sup>+)"
+ show "x \<in> Domain (RAG s) \<longrightarrow> (\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+)"
+ proof
+ assume x_d: "x \<in> Domain (RAG s)"
+ show "\<exists>th'. th' \<in> readys s \<and> (x, Th th') \<in> (RAG s)\<^sup>+"
+ proof(cases x)
+ case (Th th)
+ from x_d Th obtain cs where x_in: "(Th th, Cs cs) \<in> RAG s" by (auto simp:s_RAG_def)
+ with Th have x_in_r: "(Cs cs, x) \<in> (RAG s)^-1" by simp
+ from th_chasing [OF x_in] obtain th' where "(Cs cs, Th th') \<in> RAG s" by blast
+ hence "Cs cs \<in> Domain (RAG s)" by auto
+ from ih [OF x_in_r this] obtain th'
+ where th'_ready: " th' \<in> readys s" and cs_in: "(Cs cs, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "(x, Th th') \<in> (RAG s)\<^sup>+" using Th x_in cs_in by auto
+ with th'_ready show ?thesis by auto
+ next
+ case (Cs cs)
+ from x_d Cs obtain th' where th'_d: "(Th th', x) \<in> (RAG s)^-1" by (auto simp:s_RAG_def)
+ show ?thesis
+ proof(cases "th' \<in> readys s")
+ case True
+ from True and th'_d show ?thesis by auto
+ next
+ case False
+ from th'_d and range_in have "th' \<in> threads s" by auto
+ with False have "Th th' \<in> Domain (RAG s)"
+ by (auto simp:readys_def wq_def s_waiting_def s_RAG_def cs_waiting_def Domain_def)
+ from ih [OF th'_d this]
+ obtain th'' where
+ th''_r: "th'' \<in> readys s" and
+ th''_in: "(Th th', Th th'') \<in> (RAG s)\<^sup>+" by auto
+ from th'_d and th''_in
+ have "(x, Th th'') \<in> (RAG s)\<^sup>+" by auto
+ with th''_r show ?thesis by auto
+ qed
+ qed
+ qed
+ qed
+qed
+
+text {* \noindent
+ The following is just an instance of @{text "chain_building"}.
+*}
+lemma th_chain_to_ready:
+ assumes th_in: "th \<in> threads s"
+ shows "th \<in> readys s \<or> (\<exists> th'. th' \<in> readys s \<and> (Th th, Th th') \<in> (RAG s)^+)"
+proof(cases "th \<in> readys s")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ from False and th_in have "Th th \<in> Domain (RAG s)"
+ by (auto simp:readys_def s_waiting_def s_RAG_def wq_def cs_waiting_def Domain_def)
+ from chain_building [rule_format, OF this]
+ show ?thesis by auto
+qed
+
+end
+
+lemma waiting_eq: "waiting s th cs = waiting (wq s) th cs"
+ by (unfold s_waiting_def cs_waiting_def wq_def, auto)
+
+lemma holding_eq: "holding (s::state) th cs = holding (wq s) th cs"
+ by (unfold s_holding_def wq_def cs_holding_def, simp)
+
+lemma holding_unique: "\<lbrakk>holding (s::state) th1 cs; holding s th2 cs\<rbrakk> \<Longrightarrow> th1 = th2"
+ by (unfold s_holding_def cs_holding_def, auto)
+
+context valid_trace
+begin
+
+lemma unique_RAG: "\<lbrakk>(n, n1) \<in> RAG s; (n, n2) \<in> RAG s\<rbrakk> \<Longrightarrow> n1 = n2"
+ apply(unfold s_RAG_def, auto, fold waiting_eq holding_eq)
+ by(auto elim:waiting_unique holding_unique)
+
+end
+
+
+lemma trancl_split: "(a, b) \<in> r^+ \<Longrightarrow> \<exists> c. (a, c) \<in> r"
+by (induct rule:trancl_induct, auto)
+
+context valid_trace
+begin
+
+lemma dchain_unique:
+ assumes th1_d: "(n, Th th1) \<in> (RAG s)^+"
+ and th1_r: "th1 \<in> readys s"
+ and th2_d: "(n, Th th2) \<in> (RAG s)^+"
+ and th2_r: "th2 \<in> readys s"
+ shows "th1 = th2"
+proof -
+ { assume neq: "th1 \<noteq> th2"
+ hence "Th th1 \<noteq> Th th2" by simp
+ from unique_chain [OF _ th1_d th2_d this] and unique_RAG
+ have "(Th th1, Th th2) \<in> (RAG s)\<^sup>+ \<or> (Th th2, Th th1) \<in> (RAG s)\<^sup>+" by auto
+ hence "False"
+ proof
+ assume "(Th th1, Th th2) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th1, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th1 \<notin> readys s"
+ by (auto simp:readys_def s_RAG_def wq_def s_waiting_def cs_waiting_def)
+ with th1_r show ?thesis by auto
+ next
+ assume "(Th th2, Th th1) \<in> (RAG s)\<^sup>+"
+ from trancl_split [OF this]
+ obtain n where dd: "(Th th2, n) \<in> RAG s" by auto
+ then obtain cs where eq_n: "n = Cs cs"
+ by (auto simp:s_RAG_def s_holding_def cs_holding_def cs_waiting_def wq_def dest:hd_np_in)
+ from dd eq_n have "th2 \<notin> readys s"
+ by (auto simp:readys_def wq_def s_RAG_def s_waiting_def cs_waiting_def)
+ with th2_r show ?thesis by auto
+ qed
+ } thus ?thesis by auto
+qed
+
+end
+
+
+lemma step_holdents_p_add:
+ fixes th cs s
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs = []"
+ shows "holdents (P th cs#s) th = holdents s th \<union> {cs}"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by (auto)
+qed
+
+lemma step_holdents_p_eq:
+ fixes th cs s
+ assumes vt: "vt (P th cs#s)"
+ and "wq s cs \<noteq> []"
+ shows "holdents (P th cs#s) th = holdents s th"
+proof -
+ from assms show ?thesis
+ unfolding holdents_test step_RAG_p[OF vt] by auto
+qed
+
+
+lemma (in valid_trace) finite_holding :
+ shows "finite (holdents s th)"
+proof -
+ let ?F = "\<lambda> (x, y). the_cs x"
+ from finite_RAG
+ have "finite (RAG s)" .
+ hence "finite (?F `(RAG s))" by simp
+ moreover have "{cs . (Cs cs, Th th) \<in> RAG s} \<subseteq> \<dots>"
+ proof -
+ { have h: "\<And> a A f. a \<in> A \<Longrightarrow> f a \<in> f ` A" by auto
+ fix x assume "(Cs x, Th th) \<in> RAG s"
+ hence "?F (Cs x, Th th) \<in> ?F `(RAG s)" by (rule h)
+ moreover have "?F (Cs x, Th th) = x" by simp
+ ultimately have "x \<in> (\<lambda>(x, y). the_cs x) ` RAG s" by simp
+ } thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (unfold holdents_test, auto intro:finite_subset)
+qed
+
+lemma cntCS_v_dec:
+ fixes s thread cs
+ assumes vtv: "vt (V thread cs#s)"
+ shows "(cntCS (V thread cs#s) thread + 1) = cntCS s thread"
+proof -
+ from vtv interpret vt_s: valid_trace s
+ by (cases, unfold_locales, simp)
+ from vtv interpret vt_v: valid_trace "V thread cs#s"
+ by (unfold_locales, simp)
+ from step_back_step[OF vtv]
+ have cs_in: "cs \<in> holdents s thread"
+ apply (cases, unfold holdents_test s_RAG_def, simp)
+ by (unfold cs_holding_def s_holding_def wq_def, auto)
+ moreover have cs_not_in:
+ "(holdents (V thread cs#s) thread) = holdents s thread - {cs}"
+ apply (insert vt_s.wq_distinct[of cs])
+ apply (unfold holdents_test, unfold step_RAG_v[OF vtv],
+ auto simp:next_th_def)
+ proof -
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately
+ show "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ next
+ fix rest
+ assume dst: "distinct (rest::thread list)"
+ and ne: "rest \<noteq> []"
+ and hd_ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ moreover have "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest" by auto
+ qed
+ ultimately have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)" by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from dst show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume " distinct x \<and> set x = set rest" with ne
+ show "x \<noteq> []" by auto
+ qed
+ ultimately show "False" by auto
+ qed
+ ultimately
+ have "holdents s thread = insert cs (holdents (V thread cs#s) thread)"
+ by auto
+ moreover have "card \<dots> =
+ Suc (card ((holdents (V thread cs#s) thread) - {cs}))"
+ proof(rule card_insert)
+ from vt_v.finite_holding
+ show " finite (holdents (V thread cs # s) thread)" .
+ qed
+ moreover from cs_not_in
+ have "cs \<notin> (holdents (V thread cs#s) thread)" by auto
+ ultimately show ?thesis by (simp add:cntCS_def)
+qed
+
+context valid_trace
+begin
+
+text {* (* ddd *) \noindent
+ The relationship between @{text "cntP"}, @{text "cntV"} and @{text "cntCS"}
+ of one particular thread.
+*}
+
+lemma cnp_cnv_cncs:
+ shows "cntP s th = cntV s th + (if (th \<in> readys s \<or> th \<notin> threads s)
+ then cntCS s th else cntCS s th + 1)"
+proof -
+ from vt show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e)
+ interpret vt_s: valid_trace s using vt_cons(1) by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. cntP s th = cntV s th +
+ (if (th \<in> readys s \<or> th \<notin> threads s) then cntCS s th else cntCS s th + 1)"
+ and stp: "step s e"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in: "thread \<notin> threads s"
+ show ?thesis
+ proof -
+ { fix cs
+ assume "thread \<in> set (wq s cs)"
+ from vt_s.wq_threads [OF this] have "thread \<in> threads s" .
+ with not_in have "False" by simp
+ } with eq_e have eq_readys: "readys (e#s) = readys s \<union> {thread}"
+ by (auto simp:readys_def threads.simps s_waiting_def
+ wq_def cs_waiting_def Let_def)
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_create_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih not_in
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with not_in ih have " cntP s th = cntV s th + cntCS s th" by simp
+ moreover from eq_th and eq_readys have "th \<in> readys (e#s)" by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and is_runing: "thread \<in> runing s"
+ and no_hold: "holdents s thread = {}"
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_exit_unchanged eq_e)
+ { assume "th \<noteq> thread"
+ with eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ apply (simp add:threads.simps readys_def)
+ apply (subst s_waiting_def)
+ apply (simp add:Let_def)
+ apply (subst s_waiting_def, simp)
+ done
+ with eq_cnp eq_cnv eq_cncs ih
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with ih is_runing have " cntP s th = cntV s th + cntCS s th"
+ by (simp add:runing_def)
+ moreover from eq_th eq_e have "th \<notin> threads (e#s)"
+ by simp
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ and no_dep: "(Cs cs, Th thread) \<notin> (RAG s)\<^sup>+"
+ from thread_P vt stp ih have vtp: "vt (P thread cs#s)" by auto
+ then interpret vt_p: valid_trace "(P thread cs#s)"
+ by (unfold_locales, simp)
+ show ?thesis
+ proof -
+ { have hh: "\<And> A B C. (B = C) \<Longrightarrow> (A \<and> B) = (A \<and> C)" by blast
+ assume neq_th: "th \<noteq> thread"
+ with eq_e
+ have eq_readys: "(th \<in> readys (e#s)) = (th \<in> readys (s))"
+ apply (simp add:readys_def s_waiting_def wq_def Let_def)
+ apply (rule_tac hh)
+ apply (intro iffI allI, clarify)
+ apply (erule_tac x = csa in allE, auto)
+ apply (subgoal_tac "wq_fun (schs s) cs \<noteq> []", auto)
+ apply (erule_tac x = cs in allE, auto)
+ by (case_tac "(wq_fun (schs s) cs)", auto)
+ moreover from neq_th eq_e have "cntCS (e # s) th = cntCS s th"
+ apply (simp add:cntCS_def holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto)
+ moreover from eq_e neq_th have "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ moreover from eq_e neq_th have "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ moreover from eq_e neq_th have "threads (e#s) = threads s" by simp
+ moreover note ih [of th]
+ ultimately have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ have ?thesis
+ proof -
+ from eq_e eq_th have eq_cnp: "cntP (e # s) th = 1 + (cntP s th)"
+ by (simp add:cntP_def count_def)
+ from eq_e eq_th have eq_cnv: "cntV (e#s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ show ?thesis
+ proof (cases "wq s cs = []")
+ case True
+ with is_runing
+ have "th \<in> readys (e#s)"
+ apply (unfold eq_e wq_def, unfold readys_def s_RAG_def)
+ apply (simp add: wq_def[symmetric] runing_def eq_th s_waiting_def)
+ by (auto simp:readys_def wq_def Let_def s_waiting_def wq_def)
+ moreover have "cntCS (e # s) th = 1 + cntCS s th"
+ proof -
+ have "card {csa. csa = cs \<or> (Cs csa, Th thread) \<in> RAG s} =
+ Suc (card {cs. (Cs cs, Th thread) \<in> RAG s})" (is "card ?L = Suc (card ?R)")
+ proof -
+ have "?L = insert cs ?R" by auto
+ moreover have "card \<dots> = Suc (card (?R - {cs}))"
+ proof(rule card_insert)
+ from vt_s.finite_holding [of thread]
+ show " finite {cs. (Cs cs, Th thread) \<in> RAG s}"
+ by (unfold holdents_test, simp)
+ qed
+ moreover have "?R - {cs} = ?R"
+ proof -
+ have "cs \<notin> ?R"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th thread) \<in> RAG s}"
+ with no_dep show False by auto
+ qed
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by auto
+ qed
+ thus ?thesis
+ apply (unfold eq_e eq_th cntCS_def)
+ apply (simp add: holdents_test)
+ by (unfold step_RAG_p [OF vtp], auto simp:True)
+ qed
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ moreover note eq_cnp eq_cnv ih [of th]
+ ultimately show ?thesis by auto
+ next
+ case False
+ have eq_wq: "wq (e#s) cs = wq s cs @ [th]"
+ by (unfold eq_th eq_e wq_def, auto simp:Let_def)
+ have "th \<notin> readys (e#s)"
+ proof
+ assume "th \<in> readys (e#s)"
+ hence "\<forall>cs. \<not> waiting (e # s) th cs" by (simp add:readys_def)
+ from this[rule_format, of cs] have " \<not> waiting (e # s) th cs" .
+ hence "th \<in> set (wq (e#s) cs) \<Longrightarrow> th = hd (wq (e#s) cs)"
+ by (simp add:s_waiting_def wq_def)
+ moreover from eq_wq have "th \<in> set (wq (e#s) cs)" by auto
+ ultimately have "th = hd (wq (e#s) cs)" by blast
+ with eq_wq have "th = hd (wq s cs @ [th])" by simp
+ hence "th = hd (wq s cs)" using False by auto
+ with False eq_wq vt_p.wq_distinct [of cs]
+ show False by (fold eq_e, auto)
+ qed
+ moreover from is_runing have "th \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def eq_th)
+ moreover have "cntCS (e # s) th = cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_p[OF vtp])
+ by (auto simp:False)
+ moreover note eq_cnp eq_cnv ih[of th]
+ moreover from is_runing have "th \<in> readys s"
+ by (simp add:runing_def eq_th)
+ ultimately show ?thesis by auto
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_V thread cs)
+ from assms vt stp ih thread_V have vtv: "vt (V thread cs # s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs # s)" by (unfold_locales, simp)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ have eq_threads: "threads (e#s) = threads s" by (simp add: eq_e)
+ have eq_set: "set (SOME q. distinct q \<and> set q = set rest) = set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ show "\<And>x. distinct x \<and> set x = set rest \<Longrightarrow> set x = set rest"
+ by auto
+ qed
+ show ?thesis
+ proof -
+ { assume eq_th: "th = thread"
+ from eq_th have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (unfold eq_e, simp add:cntP_def count_def)
+ moreover from eq_th have eq_cnv: "cntV (e#s) th = 1 + cntV s th"
+ by (unfold eq_e, simp add:cntV_def count_def)
+ moreover from cntCS_v_dec [OF vtv]
+ have "cntCS (e # s) thread + 1 = cntCS s thread"
+ by (simp add:eq_e)
+ moreover from is_runing have rd_before: "thread \<in> readys s"
+ by (unfold runing_def, simp)
+ moreover have "thread \<in> readys (e # s)"
+ proof -
+ from is_runing
+ have "thread \<in> threads (e#s)"
+ by (unfold eq_e, auto simp:runing_def readys_def)
+ moreover have "\<forall> cs1. \<not> waiting (e#s) thread cs1"
+ proof
+ fix cs1
+ { assume eq_cs: "cs1 = cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from eq_wq
+ have "thread \<notin> set (wq (e#s) cs1)"
+ apply(unfold eq_e wq_def eq_cs s_holding_def)
+ apply (auto simp:Let_def)
+ proof -
+ assume "thread \<in> set (SOME q. distinct q \<and> set q = set rest)"
+ with eq_set have "thread \<in> set rest" by simp
+ with vt_v.wq_distinct[of cs]
+ and eq_wq show False
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ qed
+ thus ?thesis by (simp add:wq_def s_waiting_def)
+ qed
+ } moreover {
+ assume neq_cs: "cs1 \<noteq> cs"
+ have "\<not> waiting (e # s) thread cs1"
+ proof -
+ from wq_v_neq [OF neq_cs[symmetric]]
+ have "wq (V thread cs # s) cs1 = wq s cs1" .
+ moreover have "\<not> waiting s thread cs1"
+ proof -
+ from runing_ready and is_runing
+ have "thread \<in> readys s" by auto
+ thus ?thesis by (simp add:readys_def)
+ qed
+ ultimately show ?thesis
+ by (auto simp:wq_def s_waiting_def eq_e)
+ qed
+ } ultimately show "\<not> waiting (e # s) thread cs1" by blast
+ qed
+ ultimately show ?thesis by (simp add:readys_def)
+ qed
+ moreover note eq_th ih
+ ultimately have ?thesis by auto
+ } moreover {
+ assume neq_th: "th \<noteq> thread"
+ from neq_th eq_e have eq_cnp: "cntP (e # s) th = cntP s th"
+ by (simp add:cntP_def count_def)
+ from neq_th eq_e have eq_cnv: "cntV (e # s) th = cntV s th"
+ by (simp add:cntV_def count_def)
+ have ?thesis
+ proof(cases "th \<in> set rest")
+ case False
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ apply (insert step_back_vt[OF vtv])
+ by (simp add: False eq_e eq_wq neq_th vt_s.readys_v_eq)
+ moreover have "cntCS (e#s) th = cntCS s th"
+ apply (insert neq_th, unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ proof -
+ have "{csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from False eq_wq
+ have " next_th s thread cs th \<Longrightarrow> (Cs cs, Th th) \<in> RAG s"
+ apply (unfold next_th_def, auto)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> set rest"
+ and eq_wq: "wq s cs = thread # rest"
+ from eq_set ni have "hd (SOME q. distinct q \<and> set q = set rest) \<notin>
+ set (SOME q. distinct q \<and> set q = set rest)
+ " by simp
+ moreover have "(SOME q. distinct q \<and> set q = set rest) \<noteq> []"
+ proof(rule someI2)
+ from vt_s.wq_distinct[ of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest" by auto
+ next
+ fix x assume "distinct x \<and> set x = set rest"
+ with ne show "x \<noteq> []" by auto
+ qed
+ ultimately show
+ "(Cs cs, Th (hd (SOME q. distinct q \<and> set q = set rest))) \<in> RAG s"
+ by auto
+ qed
+ thus ?thesis by auto
+ qed
+ thus "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs \<and> next_th s thread cs th} =
+ card {cs. (Cs cs, Th th) \<in> RAG s}" by simp
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ assume th_in: "th \<in> set rest"
+ show ?thesis
+ proof(cases "next_th s thread cs th")
+ case False
+ with eq_wq and th_in have
+ neq_hd: "th \<noteq> hd (SOME q. distinct q \<and> set q = set rest)" (is "th \<noteq> hd ?rest")
+ by (auto simp:next_th_def)
+ have "(th \<in> readys (e # s)) = (th \<in> readys s)"
+ proof -
+ from eq_wq and th_in
+ have "\<not> th \<in> readys s"
+ apply (auto simp:readys_def s_waiting_def)
+ apply (rule_tac x = cs in exI, auto)
+ by (insert vt_s.wq_distinct[of cs], auto simp add: wq_def)
+ moreover
+ from eq_wq and th_in and neq_hd
+ have "\<not> (th \<in> readys (e # s))"
+ apply (auto simp:readys_def s_waiting_def eq_e wq_def Let_def split:list.splits)
+ by (rule_tac x = cs in exI, auto simp:eq_set)
+ ultimately show ?thesis by auto
+ qed
+ moreover have "cntCS (e#s) th = cntCS s th"
+ proof -
+ from eq_wq and th_in and neq_hd
+ have "(holdents (e # s) th) = (holdents s th)"
+ apply (unfold eq_e step_RAG_v[OF vtv],
+ auto simp:next_th_def eq_set s_RAG_def holdents_test wq_def
+ Let_def cs_holding_def)
+ by (insert vt_s.wq_distinct[of cs], auto simp:wq_def)
+ thus ?thesis by (simp add:cntCS_def)
+ qed
+ moreover note ih eq_cnp eq_cnv eq_threads
+ ultimately show ?thesis by auto
+ next
+ case True
+ let ?rest = " (SOME q. distinct q \<and> set q = set rest)"
+ let ?t = "hd ?rest"
+ from True eq_wq th_in neq_th
+ have "th \<in> readys (e # s)"
+ apply (auto simp:eq_e readys_def s_waiting_def wq_def
+ Let_def next_th_def)
+ proof -
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ show "?t \<in> threads s"
+ proof(rule vt_s.wq_threads)
+ from eq_wq and t_in
+ show "?t \<in> set (wq s cs)" by (auto simp:wq_def)
+ qed
+ next
+ fix csa
+ assume eq_wq: "wq_fun (schs s) cs = thread # rest"
+ and t_in: "?t \<in> set rest"
+ and neq_cs: "csa \<noteq> cs"
+ and t_in': "?t \<in> set (wq_fun (schs s) csa)"
+ show "?t = hd (wq_fun (schs s) csa)"
+ proof -
+ { assume neq_hd': "?t \<noteq> hd (wq_fun (schs s) csa)"
+ from vt_s.wq_distinct[of cs] and
+ eq_wq[folded wq_def] and t_in eq_wq
+ have "?t \<noteq> thread" by auto
+ with eq_wq and t_in
+ have w1: "waiting s ?t cs"
+ by (auto simp:s_waiting_def wq_def)
+ from t_in' neq_hd'
+ have w2: "waiting s ?t csa"
+ by (auto simp:s_waiting_def wq_def)
+ from vt_s.waiting_unique[OF w1 w2]
+ and neq_cs have "False" by auto
+ } thus ?thesis by auto
+ qed
+ qed
+ moreover have "cntP s th = cntV s th + cntCS s th + 1"
+ proof -
+ have "th \<notin> readys s"
+ proof -
+ from True eq_wq neq_th th_in
+ show ?thesis
+ apply (unfold readys_def s_waiting_def, auto)
+ by (rule_tac x = cs in exI, auto simp add: wq_def)
+ qed
+ moreover have "th \<in> threads s"
+ proof -
+ from th_in eq_wq
+ have "th \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads [OF this]
+ show ?thesis .
+ qed
+ ultimately show ?thesis using ih by auto
+ qed
+ moreover from True neq_th have "cntCS (e # s) th = 1 + cntCS s th"
+ apply (unfold cntCS_def holdents_test eq_e step_RAG_v[OF vtv], auto)
+ proof -
+ show "card {csa. (Cs csa, Th th) \<in> RAG s \<or> csa = cs} =
+ Suc (card {cs. (Cs cs, Th th) \<in> RAG s})"
+ (is "card ?A = Suc (card ?B)")
+ proof -
+ have "?A = insert cs ?B" by auto
+ hence "card ?A = card (insert cs ?B)" by simp
+ also have "\<dots> = Suc (card ?B)"
+ proof(rule card_insert_disjoint)
+ have "?B \<subseteq> ((\<lambda> (x, y). the_cs x) ` RAG s)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Cs x, Th th)" in bexI, auto)
+ with vt_s.finite_RAG
+ show "finite {cs. (Cs cs, Th th) \<in> RAG s}" by (auto intro:finite_subset)
+ next
+ show "cs \<notin> {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof
+ assume "cs \<in> {cs. (Cs cs, Th th) \<in> RAG s}"
+ hence "(Cs cs, Th th) \<in> RAG s" by simp
+ with True neq_th eq_wq show False
+ by (auto simp:next_th_def s_RAG_def cs_holding_def)
+ qed
+ qed
+ finally show ?thesis .
+ qed
+ qed
+ moreover note eq_cnp eq_cnv
+ ultimately show ?thesis by simp
+ qed
+ qed
+ } ultimately show ?thesis by blast
+ qed
+ next
+ case (thread_set thread prio)
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ show ?thesis
+ proof -
+ from eq_e have eq_cnp: "cntP (e#s) th = cntP s th" by (simp add:cntP_def count_def)
+ from eq_e have eq_cnv: "cntV (e#s) th = cntV s th" by (simp add:cntV_def count_def)
+ have eq_cncs: "cntCS (e#s) th = cntCS s th"
+ unfolding cntCS_def holdents_test
+ by (simp add:RAG_set_unchanged eq_e)
+ from eq_e have eq_readys: "readys (e#s) = readys s"
+ by (simp add:readys_def cs_waiting_def s_waiting_def wq_def,
+ auto simp:Let_def)
+ { assume "th \<noteq> thread"
+ with eq_readys eq_e
+ have "(th \<in> readys (e # s) \<or> th \<notin> threads (e # s)) =
+ (th \<in> readys (s) \<or> th \<notin> threads (s))"
+ by (simp add:threads.simps)
+ with eq_cnp eq_cnv eq_cncs ih is_runing
+ have ?thesis by simp
+ } moreover {
+ assume eq_th: "th = thread"
+ with is_runing ih have " cntP s th = cntV s th + cntCS s th"
+ by (unfold runing_def, auto)
+ moreover from eq_th and eq_readys is_runing have "th \<in> readys (e#s)"
+ by (simp add:runing_def)
+ moreover note eq_cnp eq_cnv eq_cncs
+ ultimately have ?thesis by auto
+ } ultimately show ?thesis by blast
+ qed
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntP_def cntV_def cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+lemma not_thread_cncs:
+ assumes not_in: "th \<notin> threads s"
+ shows "cntCS s th = 0"
+proof -
+ from vt not_in show ?thesis
+ proof(induct arbitrary:th)
+ case (vt_cons s e th)
+ interpret vt_s: valid_trace s using vt_cons(1)
+ by (unfold_locales, simp)
+ assume vt: "vt s"
+ and ih: "\<And>th. th \<notin> threads s \<Longrightarrow> cntCS s th = 0"
+ and stp: "step s e"
+ and not_in: "th \<notin> threads (e # s)"
+ from stp show ?case
+ proof(cases)
+ case (thread_create thread prio)
+ assume eq_e: "e = Create thread prio"
+ and not_in': "thread \<notin> threads s"
+ have "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_create_unchanged)
+ moreover have "th \<notin> threads s"
+ proof -
+ from not_in eq_e show ?thesis by simp
+ qed
+ moreover note ih ultimately show ?thesis by auto
+ next
+ case (thread_exit thread)
+ assume eq_e: "e = Exit thread"
+ and nh: "holdents s thread = {}"
+ have eq_cns: "cntCS (e # s) th = cntCS s th"
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_exit_unchanged)
+ show ?thesis
+ proof(cases "th = thread")
+ case True
+ have "cntCS s th = 0" by (unfold cntCS_def, auto simp:nh True)
+ with eq_cns show ?thesis by simp
+ next
+ case False
+ with not_in and eq_e
+ have "th \<notin> threads s" by simp
+ from ih[OF this] and eq_cns show ?thesis by simp
+ qed
+ next
+ case (thread_P thread cs)
+ assume eq_e: "e = P thread cs"
+ and is_runing: "thread \<in> runing s"
+ from assms thread_P ih vt stp thread_P have vtp: "vt (P thread cs#s)" by auto
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ hence "cntCS (e # s) th = cntCS s th "
+ apply (unfold cntCS_def holdents_test eq_e)
+ by (unfold step_RAG_p[OF vtp], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_V thread cs)
+ assume eq_e: "e = V thread cs"
+ and is_runing: "thread \<in> runing s"
+ and hold: "holding s thread cs"
+ have neq_th: "th \<noteq> thread"
+ proof -
+ from not_in eq_e have "th \<notin> threads s" by simp
+ moreover from is_runing have "thread \<in> threads s"
+ by (simp add:runing_def readys_def)
+ ultimately show ?thesis by auto
+ qed
+ from assms thread_V vt stp ih
+ have vtv: "vt (V thread cs#s)" by auto
+ then interpret vt_v: valid_trace "(V thread cs#s)"
+ by (unfold_locales, simp)
+ from hold obtain rest
+ where eq_wq: "wq s cs = thread # rest"
+ by (case_tac "wq s cs", auto simp: wq_def s_holding_def)
+ from not_in eq_e eq_wq
+ have "\<not> next_th s thread cs th"
+ apply (auto simp:next_th_def)
+ proof -
+ assume ne: "rest \<noteq> []"
+ and ni: "hd (SOME q. distinct q \<and> set q = set rest) \<notin> threads s" (is "?t \<notin> threads s")
+ have "?t \<in> set rest"
+ proof(rule someI2)
+ from vt_v.wq_distinct[of cs] and eq_wq
+ show "distinct rest \<and> set rest = set rest"
+ by (metis distinct.simps(2) vt_s.wq_distinct)
+ next
+ fix x assume "distinct x \<and> set x = set rest" with ne
+ show "hd x \<in> set rest" by (cases x, auto)
+ qed
+ with eq_wq have "?t \<in> set (wq s cs)" by simp
+ from vt_s.wq_threads[OF this] and ni
+ show False
+ using `hd (SOME q. distinct q \<and> set q = set rest) \<in> set (wq s cs)`
+ ni vt_s.wq_threads by blast
+ qed
+ moreover note neq_th eq_wq
+ ultimately have "cntCS (e # s) th = cntCS s th"
+ by (unfold eq_e cntCS_def holdents_test step_RAG_v[OF vtv], auto)
+ moreover have "cntCS s th = 0"
+ proof(rule ih)
+ from not_in eq_e show "th \<notin> threads s" by simp
+ qed
+ ultimately show ?thesis by simp
+ next
+ case (thread_set thread prio)
+ print_facts
+ assume eq_e: "e = Set thread prio"
+ and is_runing: "thread \<in> runing s"
+ from not_in and eq_e have "th \<notin> threads s" by auto
+ from ih [OF this] and eq_e
+ show ?thesis
+ apply (unfold eq_e cntCS_def holdents_test)
+ by (simp add:RAG_set_unchanged)
+ qed
+ next
+ case vt_nil
+ show ?case
+ by (unfold cntCS_def,
+ auto simp:count_def holdents_test s_RAG_def wq_def cs_holding_def)
+ qed
+qed
+
+end
+
+lemma eq_waiting: "waiting (wq (s::state)) th cs = waiting s th cs"
+ by (auto simp:s_waiting_def cs_waiting_def wq_def)
+
+context valid_trace
+begin
+
+lemma dm_RAG_threads:
+ assumes in_dom: "(Th th) \<in> Domain (RAG s)"
+ shows "th \<in> threads s"
+proof -
+ from in_dom obtain n where "(Th th, n) \<in> RAG s" by auto
+ moreover from RAG_target_th[OF this] obtain cs where "n = Cs cs" by auto
+ ultimately have "(Th th, Cs cs) \<in> RAG s" by simp
+ hence "th \<in> set (wq s cs)"
+ by (unfold s_RAG_def, auto simp:cs_waiting_def)
+ from wq_threads [OF this] show ?thesis .
+qed
+
+end
+
+lemma cp_eq_cpreced: "cp s th = cpreced (wq s) s th"
+unfolding cp_def wq_def
+apply(induct s rule: schs.induct)
+thm cpreced_initial
+apply(simp add: Let_def cpreced_initial)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+done
+
+context valid_trace
+begin
+
+lemma runing_unique:
+ assumes runing_1: "th1 \<in> runing s"
+ and runing_2: "th2 \<in> runing s"
+ shows "th1 = th2"
+proof -
+ from runing_1 and runing_2 have "cp s th1 = cp s th2"
+ unfolding runing_def
+ apply(simp)
+ done
+ hence eq_max: "Max ((\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)) =
+ Max ((\<lambda>th. preced th s) ` ({th2} \<union> dependants (wq s) th2))"
+ (is "Max (?f ` ?A) = Max (?f ` ?B)")
+ unfolding cp_eq_cpreced
+ unfolding cpreced_def .
+ obtain th1' where th1_in: "th1' \<in> ?A" and eq_f_th1: "?f th1' = Max (?f ` ?A)"
+ proof -
+ have h1: "finite (?f ` ?A)"
+ proof -
+ have "finite ?A"
+ proof -
+ have "finite (dependants (wq s) th1)"
+ proof-
+ have "finite {th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th1) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th1)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?A) \<noteq> {}"
+ proof -
+ have "?A \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?A) \<in> (?f ` ?A)" .
+ thus ?thesis
+ thm cpreced_def
+ unfolding cpreced_def[symmetric]
+ unfolding cp_eq_cpreced[symmetric]
+ unfolding cpreced_def
+ using that[intro] by (auto)
+ qed
+ obtain th2' where th2_in: "th2' \<in> ?B" and eq_f_th2: "?f th2' = Max (?f ` ?B)"
+ proof -
+ have h1: "finite (?f ` ?B)"
+ proof -
+ have "finite ?B"
+ proof -
+ have "finite (dependants (wq s) th2)"
+ proof-
+ have "finite {th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th2) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th2)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ thus ?thesis by auto
+ qed
+ moreover have h2: "(?f ` ?B) \<noteq> {}"
+ proof -
+ have "?B \<noteq> {}" by simp
+ thus ?thesis by simp
+ qed
+ from Max_in [OF h1 h2]
+ have "Max (?f ` ?B) \<in> (?f ` ?B)" .
+ thus ?thesis by (auto intro:that)
+ qed
+ from eq_f_th1 eq_f_th2 eq_max
+ have eq_preced: "preced th1' s = preced th2' s" by auto
+ hence eq_th12: "th1' = th2'"
+ proof (rule preced_unique)
+ from th1_in have "th1' = th1 \<or> (th1' \<in> dependants (wq s) th1)" by simp
+ thus "th1' \<in> threads s"
+ proof
+ assume "th1' \<in> dependants (wq s) th1"
+ hence "(Th th1') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th1') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th1' = th1"
+ with runing_1 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ next
+ from th2_in have "th2' = th2 \<or> (th2' \<in> dependants (wq s) th2)" by simp
+ thus "th2' \<in> threads s"
+ proof
+ assume "th2' \<in> dependants (wq s) th2"
+ hence "(Th th2') \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "(Th th2') \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ from dm_RAG_threads[OF this] show ?thesis .
+ next
+ assume "th2' = th2"
+ with runing_2 show ?thesis
+ by (unfold runing_def readys_def, auto)
+ qed
+ qed
+ from th1_in have "th1' = th1 \<or> th1' \<in> dependants (wq s) th1" by simp
+ thus ?thesis
+ proof
+ assume eq_th': "th1' = th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2" thus ?thesis using eq_th' eq_th12 by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 eq_th' have "th1 \<in> dependants (wq s) th2" by simp
+ hence "(Th th1, Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th1 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th1 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th1, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th1, Cs cs') \<in> RAG s" by simp
+ with runing_1 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ qed
+ next
+ assume th1'_in: "th1' \<in> dependants (wq s) th1"
+ from th2_in have "th2' = th2 \<or> th2' \<in> dependants (wq s) th2" by simp
+ thus ?thesis
+ proof
+ assume "th2' = th2"
+ with th1'_in eq_th12 have "th2 \<in> dependants (wq s) th1" by simp
+ hence "(Th th2, Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ hence "Th th2 \<in> Domain ((RAG s)^+)"
+ apply (unfold cs_dependants_def cs_RAG_def s_RAG_def)
+ by (auto simp:Domain_def)
+ hence "Th th2 \<in> Domain (RAG s)" by (simp add:trancl_domain)
+ then obtain n where d: "(Th th2, n) \<in> RAG s" by (auto simp:Domain_def)
+ from RAG_target_th [OF this]
+ obtain cs' where "n = Cs cs'" by auto
+ with d have "(Th th2, Cs cs') \<in> RAG s" by simp
+ with runing_2 have "False"
+ apply (unfold runing_def readys_def s_RAG_def)
+ by (auto simp:eq_waiting)
+ thus ?thesis by simp
+ next
+ assume "th2' \<in> dependants (wq s) th2"
+ with eq_th12 have "th1' \<in> dependants (wq s) th2" by simp
+ hence h1: "(Th th1', Th th2) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ from th1'_in have h2: "(Th th1', Th th1) \<in> (RAG s)^+"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, simp)
+ show ?thesis
+ proof(rule dchain_unique[OF h1 _ h2, symmetric])
+ from runing_1 show "th1 \<in> readys s" by (simp add:runing_def)
+ from runing_2 show "th2 \<in> readys s" by (simp add:runing_def)
+ qed
+ qed
+ qed
+qed
+
+
+lemma "card (runing s) \<le> 1"
+apply(subgoal_tac "finite (runing s)")
+prefer 2
+apply (metis finite_nat_set_iff_bounded lessI runing_unique)
+apply(rule ccontr)
+apply(simp)
+apply(case_tac "Suc (Suc 0) \<le> card (runing s)")
+apply(subst (asm) card_le_Suc_iff)
+apply(simp)
+apply(auto)[1]
+apply (metis insertCI runing_unique)
+apply(auto)
+done
+
+end
+
+
+lemma create_pre:
+ assumes stp: "step s e"
+ and not_in: "th \<notin> threads s"
+ and is_in: "th \<in> threads (e#s)"
+ obtains prio where "e = Create th prio"
+proof -
+ from assms
+ show ?thesis
+ proof(cases)
+ case (thread_create thread prio)
+ with is_in not_in have "e = Create th prio" by simp
+ from that[OF this] show ?thesis .
+ next
+ case (thread_exit thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_P thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_V thread)
+ with assms show ?thesis by (auto intro!:that)
+ next
+ case (thread_set thread)
+ with assms show ?thesis by (auto intro!:that)
+ qed
+qed
+
+lemma length_down_to_in:
+ assumes le_ij: "i \<le> j"
+ and le_js: "j \<le> length s"
+ shows "length (down_to j i s) = j - i"
+proof -
+ have "length (down_to j i s) = length (from_to i j (rev s))"
+ by (unfold down_to_def, auto)
+ also have "\<dots> = j - i"
+ proof(rule length_from_to_in[OF le_ij])
+ from le_js show "j \<le> length (rev s)" by simp
+ qed
+ finally show ?thesis .
+qed
+
+
+lemma moment_head:
+ assumes le_it: "Suc i \<le> length t"
+ obtains e where "moment (Suc i) t = e#moment i t"
+proof -
+ have "i \<le> Suc i" by simp
+ from length_down_to_in [OF this le_it]
+ have "length (down_to (Suc i) i t) = 1" by auto
+ then obtain e where "down_to (Suc i) i t = [e]"
+ apply (cases "(down_to (Suc i) i t)") by auto
+ moreover have "down_to (Suc i) 0 t = down_to (Suc i) i t @ down_to i 0 t"
+ by (rule down_to_conc[symmetric], auto)
+ ultimately have eq_me: "moment (Suc i) t = e#(moment i t)"
+ by (auto simp:down_to_moment)
+ from that [OF this] show ?thesis .
+qed
+
+context valid_trace
+begin
+
+lemma cnp_cnv_eq:
+ assumes "th \<notin> threads s"
+ shows "cntP s th = cntV s th"
+ using assms
+ using cnp_cnv_cncs not_thread_cncs by auto
+
+end
+
+
+lemma eq_RAG:
+ "RAG (wq s) = RAG s"
+by (unfold cs_RAG_def s_RAG_def, auto)
+
+context valid_trace
+begin
+
+lemma count_eq_dependants:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "dependants (wq s) th = {}"
+proof -
+ from cnp_cnv_cncs and eq_pv
+ have "cntCS s th = 0"
+ by (auto split:if_splits)
+ moreover have "finite {cs. (Cs cs, Th th) \<in> RAG s}"
+ proof -
+ from finite_holding[of th] show ?thesis
+ by (simp add:holdents_test)
+ qed
+ ultimately have h: "{cs. (Cs cs, Th th) \<in> RAG s} = {}"
+ by (unfold cntCS_def holdents_test cs_dependants_def, auto)
+ show ?thesis
+ proof(unfold cs_dependants_def)
+ { assume "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}"
+ then obtain th' where "(Th th', Th th) \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "False"
+ proof(cases)
+ assume "(Th th', Th th) \<in> RAG (wq s)"
+ thus "False" by (auto simp:cs_RAG_def)
+ next
+ fix c
+ assume "(c, Th th) \<in> RAG (wq s)"
+ with h and eq_RAG show "False"
+ by (cases c, auto simp:cs_RAG_def)
+ qed
+ } thus "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} = {}" by auto
+ qed
+qed
+
+lemma dependants_threads:
+ shows "dependants (wq s) th \<subseteq> threads s"
+proof
+ { fix th th'
+ assume h: "th \<in> {th'a. (Th th'a, Th th') \<in> (RAG (wq s))\<^sup>+}"
+ have "Th th \<in> Domain (RAG s)"
+ proof -
+ from h obtain th' where "(Th th, Th th') \<in> (RAG (wq s))\<^sup>+" by auto
+ hence "(Th th) \<in> Domain ( (RAG (wq s))\<^sup>+)" by (auto simp:Domain_def)
+ with trancl_domain have "(Th th) \<in> Domain (RAG (wq s))" by simp
+ thus ?thesis using eq_RAG by simp
+ qed
+ from dm_RAG_threads[OF this]
+ have "th \<in> threads s" .
+ } note hh = this
+ fix th1
+ assume "th1 \<in> dependants (wq s) th"
+ hence "th1 \<in> {th'a. (Th th'a, Th th) \<in> (RAG (wq s))\<^sup>+}"
+ by (unfold cs_dependants_def, simp)
+ from hh [OF this] show "th1 \<in> threads s" .
+qed
+
+lemma finite_threads:
+ shows "finite (threads s)"
+using vt by (induct) (auto elim: step.cases)
+
+end
+
+lemma Max_f_mono:
+ assumes seq: "A \<subseteq> B"
+ and np: "A \<noteq> {}"
+ and fnt: "finite B"
+ shows "Max (f ` A) \<le> Max (f ` B)"
+proof(rule Max_mono)
+ from seq show "f ` A \<subseteq> f ` B" by auto
+next
+ from np show "f ` A \<noteq> {}" by auto
+next
+ from fnt and seq show "finite (f ` B)" by auto
+qed
+
+context valid_trace
+begin
+
+lemma cp_le:
+ assumes th_in: "th \<in> threads s"
+ shows "cp s th \<le> Max ((\<lambda> th. (preced th s)) ` threads s)"
+proof(unfold cp_eq_cpreced cpreced_def cs_dependants_def)
+ show "Max ((\<lambda>th. preced th s) ` ({th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}))
+ \<le> Max ((\<lambda>th. preced th s) ` threads s)"
+ (is "Max (?f ` ?A) \<le> Max (?f ` ?B)")
+ proof(rule Max_f_mono)
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<noteq> {}" by simp
+ next
+ from finite_threads
+ show "finite (threads s)" .
+ next
+ from th_in
+ show "{th} \<union> {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> threads s"
+ apply (auto simp:Domain_def)
+ apply (rule_tac dm_RAG_threads)
+ apply (unfold trancl_domain [of "RAG s", symmetric])
+ by (unfold cs_RAG_def s_RAG_def, auto simp:Domain_def)
+ qed
+qed
+
+lemma le_cp:
+ shows "preced th s \<le> cp s th"
+proof(unfold cp_eq_cpreced preced_def cpreced_def, simp)
+ show "Prc (priority th s) (last_set th s)
+ \<le> Max (insert (Prc (priority th s) (last_set th s))
+ ((\<lambda>th. Prc (priority th s) (last_set th s)) ` dependants (wq s) th))"
+ (is "?l \<le> Max (insert ?l ?A)")
+ proof(cases "?A = {}")
+ case False
+ have "finite ?A" (is "finite (?f ` ?B)")
+ proof -
+ have "finite ?B"
+ proof-
+ have "finite {th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+}"
+ proof -
+ let ?F = "\<lambda> (x, y). the_th x"
+ have "{th'. (Th th', Th th) \<in> (RAG (wq s))\<^sup>+} \<subseteq> ?F ` ((RAG (wq s))\<^sup>+)"
+ apply (auto simp:image_def)
+ by (rule_tac x = "(Th x, Th th)" in bexI, auto)
+ moreover have "finite \<dots>"
+ proof -
+ from finite_RAG have "finite (RAG s)" .
+ hence "finite ((RAG (wq s))\<^sup>+)"
+ apply (unfold finite_trancl)
+ by (auto simp: s_RAG_def cs_RAG_def wq_def)
+ thus ?thesis by auto
+ qed
+ ultimately show ?thesis by (auto intro:finite_subset)
+ qed
+ thus ?thesis by (simp add:cs_dependants_def)
+ qed
+ thus ?thesis by simp
+ qed
+ from Max_insert [OF this False, of ?l] show ?thesis by auto
+ next
+ case True
+ thus ?thesis by auto
+ qed
+qed
+
+lemma max_cp_eq:
+ shows "Max ((cp s) ` threads s) = Max ((\<lambda> th. (preced th s)) ` threads s)"
+ (is "?l = ?r")
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ have "?l \<in> ((cp s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ next
+ from False show "cp s ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th
+ where th_in: "th \<in> threads s" and eq_l: "?l = cp s th" by auto
+ have "\<dots> \<le> ?r" by (rule cp_le[OF th_in])
+ moreover have "?r \<le> cp s th" (is "Max (?f ` ?A) \<le> cp s th")
+ proof -
+ have "?r \<in> (?f ` ?A)"
+ proof(rule Max_in)
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by auto
+ next
+ from False show " (\<lambda>th. preced th s) ` threads s \<noteq> {}" by auto
+ qed
+ then obtain th' where
+ th_in': "th' \<in> ?A " and eq_r: "?r = ?f th'" by auto
+ from le_cp [of th'] eq_r
+ have "?r \<le> cp s th'" by auto
+ moreover have "\<dots> \<le> cp s th"
+ proof(fold eq_l)
+ show " cp s th' \<le> Max (cp s ` threads s)"
+ proof(rule Max_ge)
+ from th_in' show "cp s th' \<in> cp s ` threads s"
+ by auto
+ next
+ from finite_threads
+ show "finite (cp s ` threads s)" by auto
+ qed
+ qed
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis using eq_l by auto
+qed
+
+lemma max_cp_readys_threads_pre:
+ assumes np: "threads s \<noteq> {}"
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(unfold max_cp_eq)
+ show "Max (cp s ` readys s) = Max ((\<lambda>th. preced th s) ` threads s)"
+ proof -
+ let ?p = "Max ((\<lambda>th. preced th s) ` threads s)"
+ let ?f = "(\<lambda>th. preced th s)"
+ have "?p \<in> ((\<lambda>th. preced th s) ` threads s)"
+ proof(rule Max_in)
+ from finite_threads show "finite (?f ` threads s)" by simp
+ next
+ from np show "?f ` threads s \<noteq> {}" by simp
+ qed
+ then obtain tm where tm_max: "?f tm = ?p" and tm_in: "tm \<in> threads s"
+ by (auto simp:Image_def)
+ from th_chain_to_ready [OF tm_in]
+ have "tm \<in> readys s \<or> (\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+)" .
+ thus ?thesis
+ proof
+ assume "\<exists>th'. th' \<in> readys s \<and> (Th tm, Th th') \<in> (RAG s)\<^sup>+ "
+ then obtain th' where th'_in: "th' \<in> readys s"
+ and tm_chain:"(Th tm, Th th') \<in> (RAG s)\<^sup>+" by auto
+ have "cp s th' = ?f tm"
+ proof(subst cp_eq_cpreced, subst cpreced_def, rule Max_eqI)
+ from dependants_threads finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th'))"
+ by (auto intro:finite_subset)
+ next
+ fix p assume p_in: "p \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ from tm_max have " preced tm s = Max ((\<lambda>th. preced th s) ` threads s)" .
+ moreover have "p \<le> \<dots>"
+ proof(rule Max_ge)
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ from p_in and th'_in and dependants_threads[of th']
+ show "p \<in> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ ultimately show "p \<le> preced tm s" by auto
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({th'} \<union> dependants (wq s) th')"
+ proof -
+ from tm_chain
+ have "tm \<in> dependants (wq s) th'"
+ by (unfold cs_dependants_def s_RAG_def cs_RAG_def, auto)
+ thus ?thesis by auto
+ qed
+ qed
+ with tm_max
+ have h: "cp s th' = Max ((\<lambda>th. preced th s) ` threads s)" by simp
+ show ?thesis
+ proof (fold h, rule Max_eqI)
+ fix q
+ assume "q \<in> cp s ` readys s"
+ then obtain th1 where th1_in: "th1 \<in> readys s"
+ and eq_q: "q = cp s th1" by auto
+ show "q \<le> cp s th'"
+ apply (unfold h eq_q)
+ apply (unfold cp_eq_cpreced cpreced_def)
+ apply (rule Max_mono)
+ proof -
+ from dependants_threads [of th1] th1_in
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<subseteq>
+ (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}" by simp
+ next
+ from finite_threads
+ show " finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ from th'_in
+ show "cp s th' \<in> cp s ` readys s" by simp
+ qed
+ next
+ assume tm_ready: "tm \<in> readys s"
+ show ?thesis
+ proof(fold tm_max)
+ have cp_eq_p: "cp s tm = preced tm s"
+ proof(unfold cp_eq_cpreced cpreced_def, rule Max_eqI)
+ fix y
+ assume hy: "y \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ show "y \<le> preced tm s"
+ proof -
+ { fix y'
+ assume hy' : "y' \<in> ((\<lambda>th. preced th s) ` dependants (wq s) tm)"
+ have "y' \<le> preced tm s"
+ proof(unfold tm_max, rule Max_ge)
+ from hy' dependants_threads[of tm]
+ show "y' \<in> (\<lambda>th. preced th s) ` threads s" by auto
+ next
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ qed
+ } with hy show ?thesis by auto
+ qed
+ next
+ from dependants_threads[of tm] finite_threads
+ show "finite ((\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm))"
+ by (auto intro:finite_subset)
+ next
+ show "preced tm s \<in> (\<lambda>th. preced th s) ` ({tm} \<union> dependants (wq s) tm)"
+ by simp
+ qed
+ moreover have "Max (cp s ` readys s) = cp s tm"
+ proof(rule Max_eqI)
+ from tm_ready show "cp s tm \<in> cp s ` readys s" by simp
+ next
+ from finite_threads
+ show "finite (cp s ` readys s)" by (auto simp:readys_def)
+ next
+ fix y assume "y \<in> cp s ` readys s"
+ then obtain th1 where th1_readys: "th1 \<in> readys s"
+ and h: "y = cp s th1" by auto
+ show "y \<le> cp s tm"
+ apply(unfold cp_eq_p h)
+ apply(unfold cp_eq_cpreced cpreced_def tm_max, rule Max_mono)
+ proof -
+ from finite_threads
+ show "finite ((\<lambda>th. preced th s) ` threads s)" by simp
+ next
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1) \<noteq> {}"
+ by simp
+ next
+ from dependants_threads[of th1] th1_readys
+ show "(\<lambda>th. preced th s) ` ({th1} \<union> dependants (wq s) th1)
+ \<subseteq> (\<lambda>th. preced th s) ` threads s"
+ by (auto simp:readys_def)
+ qed
+ qed
+ ultimately show " Max (cp s ` readys s) = preced tm s" by simp
+ qed
+ qed
+ qed
+qed
+
+text {* (* ccc *) \noindent
+ Since the current precedence of the threads in ready queue will always be boosted,
+ there must be one inside it has the maximum precedence of the whole system.
+*}
+lemma max_cp_readys_threads:
+ shows "Max (cp s ` readys s) = Max (cp s ` threads s)"
+proof(cases "threads s = {}")
+ case True
+ thus ?thesis
+ by (auto simp:readys_def)
+next
+ case False
+ show ?thesis by (rule max_cp_readys_threads_pre[OF False])
+qed
+
+end
+
+lemma eq_holding: "holding (wq s) th cs = holding s th cs"
+ apply (unfold s_holding_def cs_holding_def wq_def, simp)
+ done
+
+lemma f_image_eq:
+ assumes h: "\<And> a. a \<in> A \<Longrightarrow> f a = g a"
+ shows "f ` A = g ` A"
+proof
+ show "f ` A \<subseteq> g ` A"
+ by(rule image_subsetI, auto intro:h)
+next
+ show "g ` A \<subseteq> f ` A"
+ by (rule image_subsetI, auto intro:h[symmetric])
+qed
+
+
+definition detached :: "state \<Rightarrow> thread \<Rightarrow> bool"
+ where "detached s th \<equiv> (\<not>(\<exists> cs. holding s th cs)) \<and> (\<not>(\<exists>cs. waiting s th cs))"
+
+
+lemma detached_test:
+ shows "detached s th = (Th th \<notin> Field (RAG s))"
+apply(simp add: detached_def Field_def)
+apply(simp add: s_RAG_def)
+apply(simp add: s_holding_abv s_waiting_abv)
+apply(simp add: Domain_iff Range_iff)
+apply(simp add: wq_def)
+apply(auto)
+done
+
+context valid_trace
+begin
+
+lemma detached_intro:
+ assumes eq_pv: "cntP s th = cntV s th"
+ shows "detached s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_cnt: "cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ hence cncs_zero: "cntCS s th = 0"
+ by (auto simp:eq_pv split:if_splits)
+ with eq_cnt
+ have "th \<in> readys s \<or> th \<notin> threads s" by (auto simp:eq_pv)
+ thus ?thesis
+ proof
+ assume "th \<notin> threads s"
+ with range_in dm_RAG_threads
+ show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def Domain_iff Range_iff)
+ next
+ assume "th \<in> readys s"
+ moreover have "Th th \<notin> Range (RAG s)"
+ proof -
+ from card_0_eq [OF finite_holding] and cncs_zero
+ have "holdents s th = {}"
+ by (simp add:cntCS_def)
+ thus ?thesis
+ apply(auto simp:holdents_test)
+ apply(case_tac a)
+ apply(auto simp:holdents_test s_RAG_def)
+ done
+ qed
+ ultimately show ?thesis
+ by (auto simp add: detached_def s_RAG_def s_waiting_abv s_holding_abv wq_def readys_def)
+ qed
+qed
+
+lemma detached_elim:
+ assumes dtc: "detached s th"
+ shows "cntP s th = cntV s th"
+proof -
+ from cnp_cnv_cncs
+ have eq_pv: " cntP s th =
+ cntV s th + (if th \<in> readys s \<or> th \<notin> threads s then cntCS s th else cntCS s th + 1)" .
+ have cncs_z: "cntCS s th = 0"
+ proof -
+ from dtc have "holdents s th = {}"
+ unfolding detached_def holdents_test s_RAG_def
+ by (simp add: s_waiting_abv wq_def s_holding_abv Domain_iff Range_iff)
+ thus ?thesis by (auto simp:cntCS_def)
+ qed
+ show ?thesis
+ proof(cases "th \<in> threads s")
+ case True
+ with dtc
+ have "th \<in> readys s"
+ by (unfold readys_def detached_def Field_def Domain_def Range_def,
+ auto simp:eq_waiting s_RAG_def)
+ with cncs_z and eq_pv show ?thesis by simp
+ next
+ case False
+ with cncs_z and eq_pv show ?thesis by simp
+ qed
+qed
+
+lemma detached_eq:
+ shows "(detached s th) = (cntP s th = cntV s th)"
+ by (insert vt, auto intro:detached_intro detached_elim)
+
+end
+
+text {*
+ The lemmas in this .thy file are all obvious lemmas, however, they still needs to be derived
+ from the concise and miniature model of PIP given in PrioGDef.thy.
+*}
+
+lemma eq_dependants: "dependants (wq s) = dependants s"
+ by (simp add: s_dependants_abv wq_def)
+
+lemma next_th_unique:
+ assumes nt1: "next_th s th cs th1"
+ and nt2: "next_th s th cs th2"
+ shows "th1 = th2"
+using assms by (unfold next_th_def, auto)
+
+lemma birth_time_lt: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ apply (induct s, simp)
+proof -
+ fix a s
+ assume ih: "s \<noteq> [] \<Longrightarrow> last_set th s < length s"
+ and eq_as: "a # s \<noteq> []"
+ show "last_set th (a # s) < length (a # s)"
+ proof(cases "s \<noteq> []")
+ case False
+ from False show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ next
+ case True
+ from ih [OF True] show ?thesis
+ by (cases a, auto simp:last_set.simps)
+ qed
+qed
+
+lemma th_in_ne: "th \<in> threads s \<Longrightarrow> s \<noteq> []"
+ by (induct s, auto simp:threads.simps)
+
+lemma preced_tm_lt: "th \<in> threads s \<Longrightarrow> preced th s = Prc x y \<Longrightarrow> y < length s"
+ apply (drule_tac th_in_ne)
+ by (unfold preced_def, auto intro: birth_time_lt)
+
+text {* @{text "the_preced"} is also the same as @{text "preced"}, the only
+ difference is the order of arguemts. *}
+definition "the_preced s th = preced th s"
+
+lemma inj_the_preced:
+ "inj_on (the_preced s) (threads s)"
+ by (metis inj_onI preced_unique the_preced_def)
+
+text {* @{term "the_thread"} extracts thread out of RAG node. *}
+fun the_thread :: "node \<Rightarrow> thread" where
+ "the_thread (Th th) = th"
+
+text {* The following @{text "wRAG"} is the waiting sub-graph of @{text "RAG"}. *}
+definition "wRAG (s::state) = {(Th th, Cs cs) | th cs. waiting s th cs}"
+
+text {* The following @{text "hRAG"} is the holding sub-graph of @{text "RAG"}. *}
+definition "hRAG (s::state) = {(Cs cs, Th th) | th cs. holding s th cs}"
+
+text {* The following lemma splits @{term "RAG"} graph into the above two sub-graphs. *}
+lemma RAG_split: "RAG s = (wRAG s \<union> hRAG s)"
+ by (unfold s_RAG_abv wRAG_def hRAG_def s_waiting_abv
+ s_holding_abv cs_RAG_def, auto)
+
+text {*
+ The following @{text "tRAG"} is the thread-graph derived from @{term "RAG"}.
+ It characterizes the dependency between threads when calculating current
+ precedences. It is defined as the composition of the above two sub-graphs,
+ names @{term "wRAG"} and @{term "hRAG"}.
+ *}
+definition "tRAG s = wRAG s O hRAG s"
+
+(* ccc *)
+
+definition "cp_gen s x =
+ Max ((the_preced s \<circ> the_thread) ` subtree (tRAG s) x)"
+
+lemma tRAG_alt_def:
+ "tRAG s = {(Th th1, Th th2) | th1 th2.
+ \<exists> cs. (Th th1, Cs cs) \<in> RAG s \<and> (Cs cs, Th th2) \<in> RAG s}"
+ by (auto simp:tRAG_def RAG_split wRAG_def hRAG_def)
+
+lemma tRAG_Field:
+ "Field (tRAG s) \<subseteq> Field (RAG s)"
+ by (unfold tRAG_alt_def Field_def, auto)
+
+lemma tRAG_ancestorsE:
+ assumes "x \<in> ancestors (tRAG s) u"
+ obtains th where "x = Th th"
+proof -
+ from assms have "(u, x) \<in> (tRAG s)^+"
+ by (unfold ancestors_def, auto)
+ from tranclE[OF this] obtain c where "(c, x) \<in> tRAG s" by auto
+ then obtain th where "x = Th th"
+ by (unfold tRAG_alt_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma tRAG_mono:
+ assumes "RAG s' \<subseteq> RAG s"
+ shows "tRAG s' \<subseteq> tRAG s"
+ using assms
+ by (unfold tRAG_alt_def, auto)
+
+lemma holding_next_thI:
+ assumes "holding s th cs"
+ and "length (wq s cs) > 1"
+ obtains th' where "next_th s th cs th'"
+proof -
+ from assms(1)[folded eq_holding, unfolded cs_holding_def]
+ have " th \<in> set (wq s cs) \<and> th = hd (wq s cs)" .
+ then obtain rest where h1: "wq s cs = th#rest"
+ by (cases "wq s cs", auto)
+ with assms(2) have h2: "rest \<noteq> []" by auto
+ let ?th' = "hd (SOME q. distinct q \<and> set q = set rest)"
+ have "next_th s th cs ?th'" using h1(1) h2
+ by (unfold next_th_def, auto)
+ from that[OF this] show ?thesis .
+qed
+
+lemma RAG_tRAG_transfer:
+ assumes "vt s'"
+ assumes "RAG s = RAG s' \<union> {(Th th, Cs cs)}"
+ and "(Cs cs, Th th'') \<in> RAG s'"
+ shows "tRAG s = tRAG s' \<union> {(Th th, Th th'')}" (is "?L = ?R")
+proof -
+ interpret vt_s': valid_trace "s'" using assms(1)
+ by (unfold_locales, simp)
+ interpret rtree: rtree "RAG s'"
+ proof
+ show "single_valued (RAG s')"
+ apply (intro_locales)
+ by (unfold single_valued_def,
+ auto intro:vt_s'.unique_RAG)
+
+ show "acyclic (RAG s')"
+ by (rule vt_s'.acyclic_RAG)
+ qed
+ { fix n1 n2
+ assume "(n1, n2) \<in> ?L"
+ from this[unfolded tRAG_alt_def]
+ obtain th1 th2 cs' where
+ h: "n1 = Th th1" "n2 = Th th2"
+ "(Th th1, Cs cs') \<in> RAG s"
+ "(Cs cs', Th th2) \<in> RAG s" by auto
+ from h(4) and assms(2) have cs_in: "(Cs cs', Th th2) \<in> RAG s'" by auto
+ from h(3) and assms(2)
+ have "(Th th1, Cs cs') = (Th th, Cs cs) \<or>
+ (Th th1, Cs cs') \<in> RAG s'" by auto
+ hence "(n1, n2) \<in> ?R"
+ proof
+ assume h1: "(Th th1, Cs cs') = (Th th, Cs cs)"
+ hence eq_th1: "th1 = th" by simp
+ moreover have "th2 = th''"
+ proof -
+ from h1 have "cs' = cs" by simp
+ from assms(3) cs_in[unfolded this] rtree.sgv
+ show ?thesis
+ by (unfold single_valued_def, auto)
+ qed
+ ultimately show ?thesis using h(1,2) by auto
+ next
+ assume "(Th th1, Cs cs') \<in> RAG s'"
+ with cs_in have "(Th th1, Th th2) \<in> tRAG s'"
+ by (unfold tRAG_alt_def, auto)
+ from this[folded h(1, 2)] show ?thesis by auto
+ qed
+ } moreover {
+ fix n1 n2
+ assume "(n1, n2) \<in> ?R"
+ hence "(n1, n2) \<in>tRAG s' \<or> (n1, n2) = (Th th, Th th'')" by auto
+ hence "(n1, n2) \<in> ?L"
+ proof
+ assume "(n1, n2) \<in> tRAG s'"
+ moreover have "... \<subseteq> ?L"
+ proof(rule tRAG_mono)
+ show "RAG s' \<subseteq> RAG s" by (unfold assms(2), auto)
+ qed
+ ultimately show ?thesis by auto
+ next
+ assume eq_n: "(n1, n2) = (Th th, Th th'')"
+ from assms(2, 3) have "(Cs cs, Th th'') \<in> RAG s" by auto
+ moreover have "(Th th, Cs cs) \<in> RAG s" using assms(2) by auto
+ ultimately show ?thesis
+ by (unfold eq_n tRAG_alt_def, auto)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+context valid_trace
+begin
+
+lemmas RAG_tRAG_transfer = RAG_tRAG_transfer[OF vt]
+
+end
+
+lemma cp_alt_def:
+ "cp s th =
+ Max ((the_preced s) ` {th'. Th th' \<in> (subtree (RAG s) (Th th))})"
+proof -
+ have "Max (the_preced s ` ({th} \<union> dependants (wq s) th)) =
+ Max (the_preced s ` {th'. Th th' \<in> subtree (RAG s) (Th th)})"
+ (is "Max (_ ` ?L) = Max (_ ` ?R)")
+ proof -
+ have "?L = ?R"
+ by (auto dest:rtranclD simp:cs_dependants_def cs_RAG_def s_RAG_def subtree_def)
+ thus ?thesis by simp
+ qed
+ thus ?thesis by (unfold cp_eq_cpreced cpreced_def, fold the_preced_def, simp)
+qed
+
+lemma cp_gen_alt_def:
+ "cp_gen s = (Max \<circ> (\<lambda>x. (the_preced s \<circ> the_thread) ` subtree (tRAG s) x))"
+ by (auto simp:cp_gen_def)
+
+lemma tRAG_nodeE:
+ assumes "(n1, n2) \<in> tRAG s"
+ obtains th1 th2 where "n1 = Th th1" "n2 = Th th2"
+ using assms
+ by (auto simp: tRAG_def wRAG_def hRAG_def tRAG_def)
+
+lemma subtree_nodeE:
+ assumes "n \<in> subtree (tRAG s) (Th th)"
+ obtains th1 where "n = Th th1"
+proof -
+ show ?thesis
+ proof(rule subtreeE[OF assms])
+ assume "n = Th th"
+ from that[OF this] show ?thesis .
+ next
+ assume "Th th \<in> ancestors (tRAG s) n"
+ hence "(n, Th th) \<in> (tRAG s)^+" by (auto simp:ancestors_def)
+ hence "\<exists> th1. n = Th th1"
+ proof(induct)
+ case (base y)
+ from tRAG_nodeE[OF this] show ?case by metis
+ next
+ case (step y z)
+ thus ?case by auto
+ qed
+ with that show ?thesis by auto
+ qed
+qed
+
+lemma tRAG_star_RAG: "(tRAG s)^* \<subseteq> (RAG s)^*"
+proof -
+ have "(wRAG s O hRAG s)^* \<subseteq> (RAG s O RAG s)^*"
+ by (rule rtrancl_mono, auto simp:RAG_split)
+ also have "... \<subseteq> ((RAG s)^*)^*"
+ by (rule rtrancl_mono, auto)
+ also have "... = (RAG s)^*" by simp
+ finally show ?thesis by (unfold tRAG_def, simp)
+qed
+
+lemma tRAG_subtree_RAG: "subtree (tRAG s) x \<subseteq> subtree (RAG s) x"
+proof -
+ { fix a
+ assume "a \<in> subtree (tRAG s) x"
+ hence "(a, x) \<in> (tRAG s)^*" by (auto simp:subtree_def)
+ with tRAG_star_RAG[of s]
+ have "(a, x) \<in> (RAG s)^*" by auto
+ hence "a \<in> subtree (RAG s) x" by (auto simp:subtree_def)
+ } thus ?thesis by auto
+qed
+
+lemma tRAG_trancl_eq:
+ "{th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {th'. (Th th', Th th) \<in> (RAG s)^+}"
+ (is "?L = ?R")
+proof -
+ { fix th'
+ assume "th' \<in> ?L"
+ hence "(Th th', Th th) \<in> (tRAG s)^+" by auto
+ from tranclD[OF this]
+ obtain z where h: "(Th th', z) \<in> tRAG s" "(z, Th th) \<in> (tRAG s)\<^sup>*" by auto
+ from tRAG_subtree_RAG[of s] and this(2)
+ have "(z, Th th) \<in> (RAG s)^*" by (meson subsetCE tRAG_star_RAG)
+ moreover from h(1) have "(Th th', z) \<in> (RAG s)^+" using tRAG_alt_def by auto
+ ultimately have "th' \<in> ?R" by auto
+ } moreover
+ { fix th'
+ assume "th' \<in> ?R"
+ hence "(Th th', Th th) \<in> (RAG s)^+" by (auto)
+ from plus_rpath[OF this]
+ obtain xs where rp: "rpath (RAG s) (Th th') xs (Th th)" "xs \<noteq> []" by auto
+ hence "(Th th', Th th) \<in> (tRAG s)^+"
+ proof(induct xs arbitrary:th' th rule:length_induct)
+ case (1 xs th' th)
+ then obtain x1 xs1 where Cons1: "xs = x1#xs1" by (cases xs, auto)
+ show ?case
+ proof(cases "xs1")
+ case Nil
+ from 1(2)[unfolded Cons1 Nil]
+ have rp: "rpath (RAG s) (Th th') [x1] (Th th)" .
+ hence "(Th th', x1) \<in> (RAG s)" by (cases, simp)
+ then obtain cs where "x1 = Cs cs"
+ by (unfold s_RAG_def, auto)
+ from rpath_nnl_lastE[OF rp[unfolded this]]
+ show ?thesis by auto
+ next
+ case (Cons x2 xs2)
+ from 1(2)[unfolded Cons1[unfolded this]]
+ have rp: "rpath (RAG s) (Th th') (x1 # x2 # xs2) (Th th)" .
+ from rpath_edges_on[OF this]
+ have eds: "edges_on (Th th' # x1 # x2 # xs2) \<subseteq> RAG s" .
+ have "(Th th', x1) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ with eds have rg1: "(Th th', x1) \<in> RAG s" by auto
+ then obtain cs1 where eq_x1: "x1 = Cs cs1" by (unfold s_RAG_def, auto)
+ have "(x1, x2) \<in> edges_on (Th th' # x1 # x2 # xs2)"
+ by (simp add: edges_on_unfold)
+ from this eds
+ have rg2: "(x1, x2) \<in> RAG s" by auto
+ from this[unfolded eq_x1]
+ obtain th1 where eq_x2: "x2 = Th th1" by (unfold s_RAG_def, auto)
+ from rg1[unfolded eq_x1] rg2[unfolded eq_x1 eq_x2]
+ have rt1: "(Th th', Th th1) \<in> tRAG s" by (unfold tRAG_alt_def, auto)
+ from rp have "rpath (RAG s) x2 xs2 (Th th)"
+ by (elim rpath_ConsE, simp)
+ from this[unfolded eq_x2] have rp': "rpath (RAG s) (Th th1) xs2 (Th th)" .
+ show ?thesis
+ proof(cases "xs2 = []")
+ case True
+ from rpath_nilE[OF rp'[unfolded this]]
+ have "th1 = th" by auto
+ from rt1[unfolded this] show ?thesis by auto
+ next
+ case False
+ from 1(1)[rule_format, OF _ rp' this, unfolded Cons1 Cons]
+ have "(Th th1, Th th) \<in> (tRAG s)\<^sup>+" by simp
+ with rt1 show ?thesis by auto
+ qed
+ qed
+ qed
+ hence "th' \<in> ?L" by auto
+ } ultimately show ?thesis by blast
+qed
+
+lemma tRAG_trancl_eq_Th:
+ "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} =
+ {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}"
+ using tRAG_trancl_eq by auto
+
+lemma dependants_alt_def:
+ "dependants s th = {th'. (Th th', Th th) \<in> (tRAG s)^+}"
+ by (metis eq_RAG s_dependants_def tRAG_trancl_eq)
+
+context valid_trace
+begin
+
+lemma count_eq_tRAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using assms count_eq_dependants dependants_alt_def eq_dependants by auto
+
+lemma count_eq_RAG_plus:
+ assumes "cntP s th = cntV s th"
+ shows "{th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using assms count_eq_dependants cs_dependants_def eq_RAG by auto
+
+lemma count_eq_RAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (RAG s)^+} = {}"
+ using count_eq_RAG_plus[OF assms] by auto
+
+lemma count_eq_tRAG_plus_Th:
+ assumes "cntP s th = cntV s th"
+ shows "{Th th' | th'. (Th th', Th th) \<in> (tRAG s)^+} = {}"
+ using count_eq_tRAG_plus[OF assms] by auto
+
+end
+
+lemma tRAG_subtree_eq:
+ "(subtree (tRAG s) (Th th)) = {Th th' | th'. Th th' \<in> (subtree (RAG s) (Th th))}"
+ (is "?L = ?R")
+proof -
+ { fix n
+ assume h: "n \<in> ?L"
+ hence "n \<in> ?R"
+ by (smt mem_Collect_eq subsetCE subtree_def subtree_nodeE tRAG_subtree_RAG)
+ } moreover {
+ fix n
+ assume "n \<in> ?R"
+ then obtain th' where h: "n = Th th'" "(Th th', Th th) \<in> (RAG s)^*"
+ by (auto simp:subtree_def)
+ from rtranclD[OF this(2)]
+ have "n \<in> ?L"
+ proof
+ assume "Th th' \<noteq> Th th \<and> (Th th', Th th) \<in> (RAG s)\<^sup>+"
+ with h have "n \<in> {Th th' | th'. (Th th', Th th) \<in> (RAG s)^+}" by auto
+ thus ?thesis using subtree_def tRAG_trancl_eq by fastforce
+ qed (insert h, auto simp:subtree_def)
+ } ultimately show ?thesis by auto
+qed
+
+lemma threads_set_eq:
+ "the_thread ` (subtree (tRAG s) (Th th)) =
+ {th'. Th th' \<in> (subtree (RAG s) (Th th))}" (is "?L = ?R")
+ by (auto intro:rev_image_eqI simp:tRAG_subtree_eq)
+
+lemma cp_alt_def1:
+ "cp s th = Max ((the_preced s o the_thread) ` (subtree (tRAG s) (Th th)))"
+proof -
+ have "(the_preced s ` the_thread ` subtree (tRAG s) (Th th)) =
+ ((the_preced s \<circ> the_thread) ` subtree (tRAG s) (Th th))"
+ by auto
+ thus ?thesis by (unfold cp_alt_def, fold threads_set_eq, auto)
+qed
+
+lemma cp_gen_def_cond:
+ assumes "x = Th th"
+ shows "cp s th = cp_gen s (Th th)"
+by (unfold cp_alt_def1 cp_gen_def, simp)
+
+lemma cp_gen_over_set:
+ assumes "\<forall> x \<in> A. \<exists> th. x = Th th"
+ shows "cp_gen s ` A = (cp s \<circ> the_thread) ` A"
+proof(rule f_image_eq)
+ fix a
+ assume "a \<in> A"
+ from assms[rule_format, OF this]
+ obtain th where eq_a: "a = Th th" by auto
+ show "cp_gen s a = (cp s \<circ> the_thread) a"
+ by (unfold eq_a, simp, unfold cp_gen_def_cond[OF refl[of "Th th"]], simp)
+qed
+
+
+context valid_trace
+begin
+
+lemma RAG_threads:
+ assumes "(Th th) \<in> Field (RAG s)"
+ shows "th \<in> threads s"
+ using assms
+ by (metis Field_def UnE dm_RAG_threads range_in vt)
+
+lemma subtree_tRAG_thread:
+ assumes "th \<in> threads s"
+ shows "subtree (tRAG s) (Th th) \<subseteq> Th ` threads s" (is "?L \<subseteq> ?R")
+proof -
+ have "?L = {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ by (unfold tRAG_subtree_eq, simp)
+ also have "... \<subseteq> ?R"
+ proof
+ fix x
+ assume "x \<in> {Th th' |th'. Th th' \<in> subtree (RAG s) (Th th)}"
+ then obtain th' where h: "x = Th th'" "Th th' \<in> subtree (RAG s) (Th th)" by auto
+ from this(2)
+ show "x \<in> ?R"
+ proof(cases rule:subtreeE)
+ case 1
+ thus ?thesis by (simp add: assms h(1))
+ next
+ case 2
+ thus ?thesis by (metis ancestors_Field dm_RAG_threads h(1) image_eqI)
+ qed
+ qed
+ finally show ?thesis .
+qed
+
+lemma readys_root:
+ assumes "th \<in> readys s"
+ shows "root (RAG s) (Th th)"
+proof -
+ { fix x
+ assume "x \<in> ancestors (RAG s) (Th th)"
+ hence h: "(Th th, x) \<in> (RAG s)^+" by (auto simp:ancestors_def)
+ from tranclD[OF this]
+ obtain z where "(Th th, z) \<in> RAG s" by auto
+ with assms(1) have False
+ apply (case_tac z, auto simp:readys_def s_RAG_def s_waiting_def cs_waiting_def)
+ by (fold wq_def, blast)
+ } thus ?thesis by (unfold root_def, auto)
+qed
+
+lemma readys_in_no_subtree:
+ assumes "th \<in> readys s"
+ and "th' \<noteq> th"
+ shows "Th th \<notin> subtree (RAG s) (Th th')"
+proof
+ assume "Th th \<in> subtree (RAG s) (Th th')"
+ thus False
+ proof(cases rule:subtreeE)
+ case 1
+ with assms show ?thesis by auto
+ next
+ case 2
+ with readys_root[OF assms(1)]
+ show ?thesis by (auto simp:root_def)
+ qed
+qed
+
+lemma not_in_thread_isolated:
+ assumes "th \<notin> threads s"
+ shows "(Th th) \<notin> Field (RAG s)"
+proof
+ assume "(Th th) \<in> Field (RAG s)"
+ with dm_RAG_threads and range_in assms
+ show False by (unfold Field_def, blast)
+qed
+
+lemma wf_RAG: "wf (RAG s)"
+proof(rule finite_acyclic_wf)
+ from finite_RAG show "finite (RAG s)" .
+next
+ from acyclic_RAG show "acyclic (RAG s)" .
+qed
+
+lemma sgv_wRAG: "single_valued (wRAG s)"
+ using waiting_unique
+ by (unfold single_valued_def wRAG_def, auto)
+
+lemma sgv_hRAG: "single_valued (hRAG s)"
+ using holding_unique
+ by (unfold single_valued_def hRAG_def, auto)
+
+lemma sgv_tRAG: "single_valued (tRAG s)"
+ by (unfold tRAG_def, rule single_valued_relcomp,
+ insert sgv_wRAG sgv_hRAG, auto)
+
+lemma acyclic_tRAG: "acyclic (tRAG s)"
+proof(unfold tRAG_def, rule acyclic_compose)
+ show "acyclic (RAG s)" using acyclic_RAG .
+next
+ show "wRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+next
+ show "hRAG s \<subseteq> RAG s" unfolding RAG_split by auto
+qed
+
+lemma sgv_RAG: "single_valued (RAG s)"
+ using unique_RAG by (auto simp:single_valued_def)
+
+lemma rtree_RAG: "rtree (RAG s)"
+ using sgv_RAG acyclic_RAG
+ by (unfold rtree_def rtree_axioms_def sgv_def, auto)
+
+end
+context valid_trace
+begin
+
+(* ddd *)
+lemma cp_gen_rec:
+ assumes "x = Th th"
+ shows "cp_gen s x = Max ({the_preced s th} \<union> (cp_gen s) ` children (tRAG s) x)"
+proof(cases "children (tRAG s) x = {}")
+ case True
+ show ?thesis
+ by (unfold True cp_gen_def subtree_children, simp add:assms)
+next
+ case False
+ hence [simp]: "children (tRAG s) x \<noteq> {}" by auto
+ note fsbttRAGs.finite_subtree[simp]
+ have [simp]: "finite (children (tRAG s) x)"
+ by (intro rev_finite_subset[OF fsbttRAGs.finite_subtree],
+ rule children_subtree)
+ { fix r x
+ have "subtree r x \<noteq> {}" by (auto simp:subtree_def)
+ } note this[simp]
+ have [simp]: "\<exists>x\<in>children (tRAG s) x. subtree (tRAG s) x \<noteq> {}"
+ proof -
+ from False obtain q where "q \<in> children (tRAG s) x" by blast
+ moreover have "subtree (tRAG s) q \<noteq> {}" by simp
+ ultimately show ?thesis by blast
+ qed
+ have h: "Max ((the_preced s \<circ> the_thread) `
+ ({x} \<union> \<Union>(subtree (tRAG s) ` children (tRAG s) x))) =
+ Max ({the_preced s th} \<union> cp_gen s ` children (tRAG s) x)"
+ (is "?L = ?R")
+ proof -
+ let "Max (?f ` (?A \<union> \<Union> (?g ` ?B)))" = ?L
+ let "Max (_ \<union> (?h ` ?B))" = ?R
+ let ?L1 = "?f ` \<Union>(?g ` ?B)"
+ have eq_Max_L1: "Max ?L1 = Max (?h ` ?B)"
+ proof -
+ have "?L1 = ?f ` (\<Union> x \<in> ?B.(?g x))" by simp
+ also have "... = (\<Union> x \<in> ?B. ?f ` (?g x))" by auto
+ finally have "Max ?L1 = Max ..." by simp
+ also have "... = Max (Max ` (\<lambda>x. ?f ` subtree (tRAG s) x) ` ?B)"
+ by (subst Max_UNION, simp+)
+ also have "... = Max (cp_gen s ` children (tRAG s) x)"
+ by (unfold image_comp cp_gen_alt_def, simp)
+ finally show ?thesis .
+ qed
+ show ?thesis
+ proof -
+ have "?L = Max (?f ` ?A \<union> ?L1)" by simp
+ also have "... = max (the_preced s (the_thread x)) (Max ?L1)"
+ by (subst Max_Un, simp+)
+ also have "... = max (?f x) (Max (?h ` ?B))"
+ by (unfold eq_Max_L1, simp)
+ also have "... =?R"
+ by (rule max_Max_eq, (simp)+, unfold assms, simp)
+ finally show ?thesis .
+ qed
+ qed thus ?thesis
+ by (fold h subtree_children, unfold cp_gen_def, simp)
+qed
+
+lemma cp_rec:
+ "cp s th = Max ({the_preced s th} \<union>
+ (cp s o the_thread) ` children (tRAG s) (Th th))"
+proof -
+ have "Th th = Th th" by simp
+ note h = cp_gen_def_cond[OF this] cp_gen_rec[OF this]
+ show ?thesis
+ proof -
+ have "cp_gen s ` children (tRAG s) (Th th) =
+ (cp s \<circ> the_thread) ` children (tRAG s) (Th th)"
+ proof(rule cp_gen_over_set)
+ show " \<forall>x\<in>children (tRAG s) (Th th). \<exists>th. x = Th th"
+ by (unfold tRAG_alt_def, auto simp:children_def)
+ qed
+ thus ?thesis by (subst (1) h(1), unfold h(2), simp)
+ qed
+qed
+
+end
+
+end
--- a/PrioGDef.thy Wed May 14 11:52:53 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,484 +0,0 @@
-(*<*)
-theory PrioGDef
-imports Precedence_ord Moment
-begin
-(*>*)
-
-text {*
- In this section, the formal model of Priority Inheritance is presented.
- The model is based on Paulson's inductive protocol verification method, where
- the state of the system is modelled as a list of events happened so far with the latest
- event put at the head.
-
- To define events, the identifiers of {\em threads},
- {\em priority} and {\em critical resources } (abbreviated as @{text "cs"})
- need to be represented. All three are represetned using standard
- Isabelle/HOL type @{typ "nat"}:
-*}
-
-type_synonym thread = nat -- {* Type for thread identifiers. *}
-type_synonym priority = nat -- {* Type for priorities. *}
-type_synonym cs = nat -- {* Type for critical sections (or critical resources). *}
-
-text {*
- \noindent
- Every event in the system corresponds to a system call, the formats of which are
- defined as follows:
- *}
-
-datatype event =
- Create thread priority | -- {* Thread @{text "thread"} is created with priority @{text "priority"}. *}
- Exit thread | -- {* Thread @{text "thread"} finishing its execution. *}
- P thread cs | -- {* Thread @{text "thread"} requesting critical resource @{text "cs"}. *}
- V thread cs | -- {* Thread @{text "thread"} releasing critical resource @{text "cs"}. *}
- Set thread priority -- {* Thread @{text "thread"} resets its priority to @{text "priority"}. *}
-
-text {*
-\noindent
- Resource Allocation Graph (RAG for short) is used extensively in our formal analysis.
- The following type @{text "node"} is used to represent nodes in RAG.
- *}
-datatype node =
- Th "thread" | -- {* Node for thread. *}
- Cs "cs" -- {* Node for critical resource. *}
-
-text {*
- In Paulson's inductive method, the states of system are represented as lists of events,
- which is defined by the following type @{text "state"}:
- *}
-type_synonym state = "event list"
-
-text {*
- \noindent
- The following function
- @{text "threads"} is used to calculate the set of live threads (@{text "threads s"})
- in state @{text "s"}.
- *}
-fun threads :: "state \<Rightarrow> thread set"
- where
- -- {* At the start of the system, the set of threads is empty: *}
- "threads [] = {}" |
- -- {* New thread is added to the @{text "threads"}: *}
- "threads (Create thread prio#s) = {thread} \<union> threads s" |
- -- {* Finished thread is removed: *}
- "threads (Exit thread # s) = (threads s) - {thread}" |
- -- {* Other kind of events does not affect the value of @{text "threads"}: *}
- "threads (e#s) = threads s"
-text {* \noindent
- Functions such as @{text "threads"}, which extract information out of system states, are called
- {\em observing functions}. A series of observing functions will be defined in the sequel in order to
- model the protocol.
- Observing function @{text "original_priority"} calculates
- the {\em original priority} of thread @{text "th"} in state @{text "s"}, expressed as
- : @{text "original_priority th s" }. The {\em original priority} is the priority
- assigned to a thread when it is created or when it is reset by system call
- @{text "Set thread priority"}.
-*}
-
-fun original_priority :: "thread \<Rightarrow> state \<Rightarrow> priority"
- where
- -- {* @{text "0"} is assigned to threads which have never been created: *}
- "original_priority thread [] = 0" |
- "original_priority thread (Create thread' prio#s) =
- (if thread' = thread then prio else original_priority thread s)" |
- "original_priority thread (Set thread' prio#s) =
- (if thread' = thread then prio else original_priority thread s)" |
- "original_priority thread (e#s) = original_priority thread s"
-
-text {*
- \noindent
- In the following,
- @{text "birthtime th s"} is the time when thread @{text "th"} is created,
- observed from state @{text "s"}.
- The time in the system is measured by the number of events happened so far since the very beginning.
-*}
-fun birthtime :: "thread \<Rightarrow> state \<Rightarrow> nat"
- where
- "birthtime thread [] = 0" |
- "birthtime thread ((Create thread' prio)#s) =
- (if (thread = thread') then length s else birthtime thread s)" |
- "birthtime thread ((Set thread' prio)#s) =
- (if (thread = thread') then length s else birthtime thread s)" |
- "birthtime thread (e#s) = birthtime thread s"
-
-text {*
- \noindent
- The {\em precedence} is a notion derived from {\em priority}, where the {\em precedence} of
- a thread is the combination of its {\em original priority} and {\em birth time}. The intention is
- to discriminate threads with the same priority by giving threads whose priority
- is assigned earlier higher precedences, becasue such threads are more urgent to finish.
- This explains the following definition:
- *}
-definition preced :: "thread \<Rightarrow> state \<Rightarrow> precedence"
- where "preced thread s \<equiv> Prc (original_priority thread s) (birthtime thread s)"
-
-
-text {*
- \noindent
- A number of important notions are defined here:
- *}
-
-consts
- holding :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
- waiting :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
- depend :: "'b \<Rightarrow> (node \<times> node) set"
- dependents :: "'b \<Rightarrow> thread \<Rightarrow> thread set"
-
-text {*
- \noindent
- In the definition of the following several functions, it is supposed that
- the waiting queue of every critical resource is given by a waiting queue
- function @{text "wq"}, which servers as arguments of these functions.
- *}
-defs (overloaded)
- -- {*
- \begin{minipage}{0.9\textwidth}
- We define that the thread which is at the head of waiting queue of resource @{text "cs"}
- is holding the resource. This definition is slightly different from tradition where
- all threads in the waiting queue are considered as waiting for the resource.
- This notion is reflected in the definition of @{text "holding wq th cs"} as follows:
- \end{minipage}
- *}
- cs_holding_def:
- "holding wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread = hd (wq cs))"
- -- {*
- \begin{minipage}{0.9\textwidth}
- In accordance with the definition of @{text "holding wq th cs"},
- a thread @{text "th"} is considered waiting for @{text "cs"} if
- it is in the {\em waiting queue} of critical resource @{text "cs"}, but not at the head.
- This is reflected in the definition of @{text "waiting wq th cs"} as follows:
- \end{minipage}
- *}
- cs_waiting_def:
- "waiting wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread \<noteq> hd (wq cs))"
- -- {*
- \begin{minipage}{0.9\textwidth}
- @{text "depend wq"} represents the Resource Allocation Graph of the system under the waiting
- queue function @{text "wq"}.
- \end{minipage}
- *}
- cs_depend_def:
- "depend (wq::cs \<Rightarrow> thread list) \<equiv>
- {(Th th, Cs cs) | th cs. waiting wq th cs} \<union> {(Cs cs, Th th) | cs th. holding wq th cs}"
- -- {*
- \begin{minipage}{0.9\textwidth}
- The following @{text "dependents wq th"} represents the set of threads which are depending on
- thread @{text "th"} in Resource Allocation Graph @{text "depend wq"}:
- \end{minipage}
- *}
- cs_dependents_def:
- "dependents (wq::cs \<Rightarrow> thread list) th \<equiv> {th' . (Th th', Th th) \<in> (depend wq)^+}"
-
-
-text {*
- The data structure used by the operating system for scheduling is referred to as
- {\em schedule state}. It is represented as a record consisting of
- a function assigning waiting queue to resources and a function assigning precedence to
- threads:
- *}
-record schedule_state =
- wq_fun :: "cs \<Rightarrow> thread list" -- {* The function assigning waiting queue. *}
- cprec_fun :: "thread \<Rightarrow> precedence" -- {* The function assigning precedence. *}
-
-text {* \noindent
- The following
- @{text "cpreced s th"} gives the {\em current precedence} of thread @{text "th"} under
- state @{text "s"}. The definition of @{text "cpreced"} reflects the basic idea of
- Priority Inheritance that the {\em current precedence} of a thread is the precedence
- inherited from the maximum of all its dependents, i.e. the threads which are waiting
- directly or indirectly waiting for some resources from it. If no such thread exits,
- @{text "th"}'s {\em current precedence} equals its original precedence, i.e.
- @{text "preced th s"}.
- *}
-definition cpreced :: "(cs \<Rightarrow> thread list) \<Rightarrow> state \<Rightarrow> thread \<Rightarrow> precedence"
- where "cpreced wq s = (\<lambda> th. Max ((\<lambda> th. preced th s) ` ({th} \<union> dependents wq th)))"
-
-(*<*)
-lemma
- cpreced_def2:
- "cpreced wq s th \<equiv> Max ({preced th s} \<union> {preced th' s | th'. th' \<in> dependents wq th})"
- unfolding cpreced_def image_def
- apply(rule eq_reflection)
- apply(rule_tac f="Max" in arg_cong)
- by (auto)
-(*>*)
-
-abbreviation
- "all_unlocked \<equiv> \<lambda>_::cs. ([]::thread list)"
-
-abbreviation
- "initial_cprec \<equiv> \<lambda>_::thread. Prc 0 0"
-
-abbreviation
- "release qs \<equiv> case qs of
- [] => []
- | (_#qs) => (SOME q. distinct q \<and> set q = set qs)"
-
-text {* \noindent
- The following function @{text "schs"} is used to calculate the schedule state @{text "schs s"}.
- It is the key function to model Priority Inheritance:
- *}
-fun schs :: "state \<Rightarrow> schedule_state"
- where
- "schs [] = (| wq_fun = \<lambda> cs. [], cprec_fun = (\<lambda>_. Prc 0 0) |)" |
-
- -- {*
- \begin{minipage}{0.9\textwidth}
- \begin{enumerate}
- \item @{text "ps"} is the schedule state of last moment.
- \item @{text "pwq"} is the waiting queue function of last moment.
- \item @{text "pcp"} is the precedence function of last moment (NOT USED).
- \item @{text "nwq"} is the new waiting queue function. It is calculated using a @{text "case"} statement:
- \begin{enumerate}
- \item If the happening event is @{text "P thread cs"}, @{text "thread"} is added to
- the end of @{text "cs"}'s waiting queue.
- \item If the happening event is @{text "V thread cs"} and @{text "s"} is a legal state,
- @{text "th'"} must equal to @{text "thread"},
- because @{text "thread"} is the one currently holding @{text "cs"}.
- The case @{text "[] \<Longrightarrow> []"} may never be executed in a legal state.
- the @{text "(SOME q. distinct q \<and> set q = set qs)"} is used to choose arbitrarily one
- thread in waiting to take over the released resource @{text "cs"}. In our representation,
- this amounts to rearrange elements in waiting queue, so that one of them is put at the head.
- \item For other happening event, the schedule state just does not change.
- \end{enumerate}
- \item @{text "ncp"} is new precedence function, it is calculated from the newly updated waiting queue
- function. The dependency of precedence function on waiting queue function is the reason to
- put them in the same record so that they can evolve together.
- \end{enumerate}
- \end{minipage}
- *}
- "schs (Create th prio # s) =
- (let wq = wq_fun (schs s) in
- (|wq_fun = wq, cprec_fun = cpreced wq (Create th prio # s)|))"
-| "schs (Exit th # s) =
- (let wq = wq_fun (schs s) in
- (|wq_fun = wq, cprec_fun = cpreced wq (Exit th # s)|))"
-| "schs (Set th prio # s) =
- (let wq = wq_fun (schs s) in
- (|wq_fun = wq, cprec_fun = cpreced wq (Set th prio # s)|))"
-| "schs (P th cs # s) =
- (let wq = wq_fun (schs s) in
- let new_wq = wq(cs := (wq cs @ [th])) in
- (|wq_fun = new_wq, cprec_fun = cpreced new_wq (P th cs # s)|))"
-| "schs (V th cs # s) =
- (let wq = wq_fun (schs s) in
- let new_wq = wq(cs := release (wq cs)) in
- (|wq_fun = new_wq, cprec_fun = cpreced new_wq (V th cs # s)|))"
-
-lemma cpreced_initial:
- "cpreced (\<lambda> cs. []) [] = (\<lambda>_. (Prc 0 0))"
-apply(simp add: cpreced_def)
-apply(simp add: cs_dependents_def cs_depend_def cs_waiting_def cs_holding_def)
-apply(simp add: preced_def)
-done
-
-lemma sch_old_def:
- "schs (e#s) = (let ps = schs s in
- let pwq = wq_fun ps in
- let nwq = case e of
- P th cs \<Rightarrow> pwq(cs:=(pwq cs @ [th])) |
- V th cs \<Rightarrow> let nq = case (pwq cs) of
- [] \<Rightarrow> [] |
- (_#qs) \<Rightarrow> (SOME q. distinct q \<and> set q = set qs)
- in pwq(cs:=nq) |
- _ \<Rightarrow> pwq
- in let ncp = cpreced nwq (e#s) in
- \<lparr>wq_fun = nwq, cprec_fun = ncp\<rparr>
- )"
-apply(cases e)
-apply(simp_all)
-done
-
-
-text {*
- \noindent
- The following @{text "wq"} is a shorthand for @{text "wq_fun"}.
- *}
-definition wq :: "state \<Rightarrow> cs \<Rightarrow> thread list"
- where "wq s = wq_fun (schs s)"
-
-text {* \noindent
- The following @{text "cp"} is a shorthand for @{text "cprec_fun"}.
- *}
-definition cp :: "state \<Rightarrow> thread \<Rightarrow> precedence"
- where "cp s \<equiv> cprec_fun (schs s)"
-
-text {* \noindent
- Functions @{text "holding"}, @{text "waiting"}, @{text "depend"} and
- @{text "dependents"} still have the
- same meaning, but redefined so that they no longer depend on the
- fictitious {\em waiting queue function}
- @{text "wq"}, but on system state @{text "s"}.
- *}
-defs (overloaded)
- s_holding_abv:
- "holding (s::state) \<equiv> holding (wq_fun (schs s))"
- s_waiting_abv:
- "waiting (s::state) \<equiv> waiting (wq_fun (schs s))"
- s_depend_abv:
- "depend (s::state) \<equiv> depend (wq_fun (schs s))"
- s_dependents_abv:
- "dependents (s::state) \<equiv> dependents (wq_fun (schs s))"
-
-
-text {*
- The following lemma can be proved easily:
- *}
-lemma
- s_holding_def:
- "holding (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th = hd (wq_fun (schs s) cs))"
- by (auto simp:s_holding_abv wq_def cs_holding_def)
-
-lemma s_waiting_def:
- "waiting (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th \<noteq> hd (wq_fun (schs s) cs))"
- by (auto simp:s_waiting_abv wq_def cs_waiting_def)
-
-lemma s_depend_def:
- "depend (s::state) =
- {(Th th, Cs cs) | th cs. waiting (wq s) th cs} \<union> {(Cs cs, Th th) | cs th. holding (wq s) th cs}"
- by (auto simp:s_depend_abv wq_def cs_depend_def)
-
-lemma
- s_dependents_def:
- "dependents (s::state) th \<equiv> {th' . (Th th', Th th) \<in> (depend (wq s))^+}"
- by (auto simp:s_dependents_abv wq_def cs_dependents_def)
-
-text {*
- The following function @{text "readys"} calculates the set of ready threads. A thread is {\em ready}
- for running if it is a live thread and it is not waiting for any critical resource.
- *}
-definition readys :: "state \<Rightarrow> thread set"
- where "readys s \<equiv> {th . th \<in> threads s \<and> (\<forall> cs. \<not> waiting s th cs)}"
-
-text {* \noindent
- The following function @{text "runing"} calculates the set of running thread, which is the ready
- thread with the highest precedence.
- *}
-definition runing :: "state \<Rightarrow> thread set"
- where "runing s \<equiv> {th . th \<in> readys s \<and> cp s th = Max ((cp s) ` (readys s))}"
-
-text {* \noindent
- The following function @{text "holdents s th"} returns the set of resources held by thread
- @{text "th"} in state @{text "s"}.
- *}
-definition holdents :: "state \<Rightarrow> thread \<Rightarrow> cs set"
- where "holdents s th \<equiv> {cs . holding s th cs}"
-
-lemma holdents_test:
- "holdents s th = {cs . (Cs cs, Th th) \<in> depend s}"
-unfolding holdents_def
-unfolding s_depend_def
-unfolding s_holding_abv
-unfolding wq_def
-by (simp)
-
-text {* \noindent
- @{text "cntCS s th"} returns the number of resources held by thread @{text "th"} in
- state @{text "s"}:
- *}
-definition cntCS :: "state \<Rightarrow> thread \<Rightarrow> nat"
- where "cntCS s th = card (holdents s th)"
-
-text {* \noindent
- The fact that event @{text "e"} is eligible to happen next in state @{text "s"}
- is expressed as @{text "step s e"}. The predicate @{text "step"} is inductively defined as
- follows:
- *}
-inductive step :: "state \<Rightarrow> event \<Rightarrow> bool"
- where
- -- {*
- A thread can be created if it is not a live thread:
- *}
- thread_create: "\<lbrakk>thread \<notin> threads s\<rbrakk> \<Longrightarrow> step s (Create thread prio)" |
- -- {*
- A thread can exit if it no longer hold any resource:
- *}
- thread_exit: "\<lbrakk>thread \<in> runing s; holdents s thread = {}\<rbrakk> \<Longrightarrow> step s (Exit thread)" |
- -- {*
- \begin{minipage}{0.9\textwidth}
- A thread can request for an critical resource @{text "cs"}, if it is running and
- the request does not form a loop in the current RAG. The latter condition
- is set up to avoid deadlock. The condition also reflects our assumption all threads are
- carefully programmed so that deadlock can not happen:
- \end{minipage}
- *}
- thread_P: "\<lbrakk>thread \<in> runing s; (Cs cs, Th thread) \<notin> (depend s)^+\<rbrakk> \<Longrightarrow>
- step s (P thread cs)" |
- -- {*
- \begin{minipage}{0.9\textwidth}
- A thread can release a critical resource @{text "cs"}
- if it is running and holding that resource:
- \end{minipage}
- *}
- thread_V: "\<lbrakk>thread \<in> runing s; holding s thread cs\<rbrakk> \<Longrightarrow> step s (V thread cs)" |
- -- {*
- A thread can adjust its own priority as long as it is current running:
- *}
- thread_set: "\<lbrakk>thread \<in> runing s\<rbrakk> \<Longrightarrow> step s (Set thread prio)"
-
-text {* \noindent
- With predicate @{text "step"}, the fact that @{text "s"} is a legal state in
- Priority Inheritance protocol can be expressed as: @{text "vt step s"}, where
- the predicate @{text "vt"} can be defined as the following:
- *}
-inductive vt :: "state \<Rightarrow> bool"
- where
- -- {* Empty list @{text "[]"} is a legal state in any protocol:*}
- vt_nil[intro]: "vt []" |
- -- {*
- \begin{minipage}{0.9\textwidth}
- If @{text "s"} a legal state, and event @{text "e"} is eligible to happen
- in state @{text "s"}, then @{text "e#s"} is a legal state as well:
- \end{minipage}
- *}
- vt_cons[intro]: "\<lbrakk>vt s; step s e\<rbrakk> \<Longrightarrow> vt (e#s)"
-
-text {* \noindent
- It is easy to see that the definition of @{text "vt"} is generic. It can be applied to
- any step predicate to get the set of legal states.
- *}
-
-text {* \noindent
- The following two functions @{text "the_cs"} and @{text "the_th"} are used to extract
- critical resource and thread respectively out of RAG nodes.
- *}
-fun the_cs :: "node \<Rightarrow> cs"
- where "the_cs (Cs cs) = cs"
-
-fun the_th :: "node \<Rightarrow> thread"
- where "the_th (Th th) = th"
-
-text {* \noindent
- The following predicate @{text "next_th"} describe the next thread to
- take over when a critical resource is released. In @{text "next_th s th cs t"},
- @{text "th"} is the thread to release, @{text "t"} is the one to take over.
- *}
-definition next_th:: "state \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> thread \<Rightarrow> bool"
- where "next_th s th cs t = (\<exists> rest. wq s cs = th#rest \<and> rest \<noteq> [] \<and>
- t = hd (SOME q. distinct q \<and> set q = set rest))"
-
-text {* \noindent
- The function @{text "count Q l"} is used to count the occurrence of situation @{text "Q"}
- in list @{text "l"}:
- *}
-definition count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"
- where "count Q l = length (filter Q l)"
-
-text {* \noindent
- The following @{text "cntP s"} returns the number of operation @{text "P"} happened
- before reaching state @{text "s"}.
- *}
-definition cntP :: "state \<Rightarrow> thread \<Rightarrow> nat"
- where "cntP s th = count (\<lambda> e. \<exists> cs. e = P th cs) s"
-
-text {* \noindent
- The following @{text "cntV s"} returns the number of operation @{text "V"} happened
- before reaching state @{text "s"}.
- *}
-definition cntV :: "state \<Rightarrow> thread \<Rightarrow> nat"
- where "cntV s th = count (\<lambda> e. \<exists> cs. e = V th cs) s"
-(*<*)
-
-end
-(*>*)
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PrioGDef.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,616 @@
+chapter {* Definitions *}
+(*<*)
+theory PrioGDef
+imports Precedence_ord Moment
+begin
+(*>*)
+
+text {*
+ In this section, the formal model of Priority Inheritance Protocol (PIP) is presented.
+ The model is based on Paulson's inductive protocol verification method, where
+ the state of the system is modelled as a list of events happened so far with the latest
+ event put at the head.
+*}
+
+text {*
+ To define events, the identifiers of {\em threads},
+ {\em priority} and {\em critical resources } (abbreviated as @{text "cs"})
+ need to be represented. All three are represetned using standard
+ Isabelle/HOL type @{typ "nat"}:
+*}
+
+type_synonym thread = nat -- {* Type for thread identifiers. *}
+type_synonym priority = nat -- {* Type for priorities. *}
+type_synonym cs = nat -- {* Type for critical sections (or critical resources). *}
+
+text {*
+ \noindent
+ The abstraction of Priority Inheritance Protocol (PIP) is set at the system call level.
+ Every system call is represented as an event. The format of events is defined
+ defined as follows:
+ *}
+
+datatype event =
+ Create thread priority | -- {* Thread @{text "thread"} is created with priority @{text "priority"}. *}
+ Exit thread | -- {* Thread @{text "thread"} finishing its execution. *}
+ P thread cs | -- {* Thread @{text "thread"} requesting critical resource @{text "cs"}. *}
+ V thread cs | -- {* Thread @{text "thread"} releasing critical resource @{text "cs"}. *}
+ Set thread priority -- {* Thread @{text "thread"} resets its priority to @{text "priority"}. *}
+
+
+text {*
+ As mentioned earlier, in Paulson's inductive method, the states of system are represented as lists of events,
+ which is defined by the following type @{text "state"}:
+ *}
+type_synonym state = "event list"
+
+
+text {*
+\noindent
+ Resource Allocation Graph (RAG for short) is used extensively in our formal analysis.
+ The following type @{text "node"} is used to represent nodes in RAG.
+ *}
+datatype node =
+ Th "thread" | -- {* Node for thread. *}
+ Cs "cs" -- {* Node for critical resource. *}
+
+text {*
+ \noindent
+ The following function
+ @{text "threads"} is used to calculate the set of live threads (@{text "threads s"})
+ in state @{text "s"}.
+ *}
+fun threads :: "state \<Rightarrow> thread set"
+ where
+ -- {* At the start of the system, the set of threads is empty: *}
+ "threads [] = {}" |
+ -- {* New thread is added to the @{text "threads"}: *}
+ "threads (Create thread prio#s) = {thread} \<union> threads s" |
+ -- {* Finished thread is removed: *}
+ "threads (Exit thread # s) = (threads s) - {thread}" |
+ -- {* Other kind of events does not affect the value of @{text "threads"}: *}
+ "threads (e#s) = threads s"
+
+text {*
+ \noindent
+ The function @{text "threads"} defined above is one of
+ the so called {\em observation function}s which forms
+ the very basis of Paulson's inductive protocol verification method.
+ Each observation function {\em observes} one particular aspect (or attribute)
+ of the system. For example, the attribute observed by @{text "threads s"}
+ is the set of threads living in state @{text "s"}.
+ The protocol being modelled
+ The decision made the protocol being modelled is based on the {\em observation}s
+ returned by {\em observation function}s. Since {\observation function}s forms
+ the very basis on which Paulson's inductive method is based, there will be
+ a lot of such observation functions introduced in the following. In fact, any function
+ which takes event list as argument is a {\em observation function}.
+ *}
+
+text {* \noindent
+ Observation @{text "priority th s"} is
+ the {\em original priority} of thread @{text "th"} in state @{text "s"}.
+ The {\em original priority} is the priority
+ assigned to a thread when it is created or when it is reset by system call
+ (represented by event @{text "Set thread priority"}).
+*}
+
+fun priority :: "thread \<Rightarrow> state \<Rightarrow> priority"
+ where
+ -- {* @{text "0"} is assigned to threads which have never been created: *}
+ "priority thread [] = 0" |
+ "priority thread (Create thread' prio#s) =
+ (if thread' = thread then prio else priority thread s)" |
+ "priority thread (Set thread' prio#s) =
+ (if thread' = thread then prio else priority thread s)" |
+ "priority thread (e#s) = priority thread s"
+
+text {*
+ \noindent
+ Observation @{text "last_set th s"} is the last time when the priority of thread @{text "th"} is set,
+ observed from state @{text "s"}.
+ The time in the system is measured by the number of events happened so far since the very beginning.
+*}
+fun last_set :: "thread \<Rightarrow> state \<Rightarrow> nat"
+ where
+ "last_set thread [] = 0" |
+ "last_set thread ((Create thread' prio)#s) =
+ (if (thread = thread') then length s else last_set thread s)" |
+ "last_set thread ((Set thread' prio)#s) =
+ (if (thread = thread') then length s else last_set thread s)" |
+ "last_set thread (_#s) = last_set thread s"
+
+text {*
+ \noindent
+ The {\em precedence} is a notion derived from {\em priority}, where the {\em precedence} of
+ a thread is the combination of its {\em original priority} and {\em time} the priority is set.
+ The intention is to discriminate threads with the same priority by giving threads whose priority
+ is assigned earlier higher precedences, becasue such threads are more urgent to finish.
+ This explains the following definition:
+ *}
+definition preced :: "thread \<Rightarrow> state \<Rightarrow> precedence"
+ where "preced thread s \<equiv> Prc (priority thread s) (last_set thread s)"
+
+
+text {*
+ \noindent
+ A number of important notions in PIP are represented as the following functions,
+ defined in terms of the waiting queues of the system, where the waiting queues
+ , as a whole, is represented by the @{text "wq"} argument of every notion function.
+ The @{text "wq"} argument is itself a functions which maps every critical resource
+ @{text "cs"} to the list of threads which are holding or waiting for it.
+ The thread at the head of this list is designated as the thread which is current
+ holding the resrouce, which is slightly different from tradition where
+ all threads in the waiting queue are considered as waiting for the resource.
+ *}
+
+consts
+ holding :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
+ waiting :: "'b \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> bool"
+ RAG :: "'b \<Rightarrow> (node \<times> node) set"
+ dependants :: "'b \<Rightarrow> thread \<Rightarrow> thread set"
+
+defs (overloaded)
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ This meaning of @{text "wq"} is reflected in the following definition of @{text "holding wq th cs"},
+ where @{text "holding wq th cs"} means thread @{text "th"} is holding the critical
+ resource @{text "cs"}. This decision is based on @{text "wq"}.
+ \end{minipage}
+ *}
+
+ cs_holding_def:
+ "holding wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread = hd (wq cs))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ In accordance with the definition of @{text "holding wq th cs"},
+ a thread @{text "th"} is considered waiting for @{text "cs"} if
+ it is in the {\em waiting queue} of critical resource @{text "cs"}, but not at the head.
+ This is reflected in the definition of @{text "waiting wq th cs"} as follows:
+ \end{minipage}
+ *}
+ cs_waiting_def:
+ "waiting wq thread cs \<equiv> (thread \<in> set (wq cs) \<and> thread \<noteq> hd (wq cs))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ @{text "RAG wq"} generates RAG (a binary relations on @{text "node"})
+ out of waiting queues of the system (represented by the @{text "wq"} argument):
+ \end{minipage}
+ *}
+ cs_RAG_def:
+ "RAG (wq::cs \<Rightarrow> thread list) \<equiv>
+ {(Th th, Cs cs) | th cs. waiting wq th cs} \<union> {(Cs cs, Th th) | cs th. holding wq th cs}"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ The following @{text "dependants wq th"} represents the set of threads which are RAGing on
+ thread @{text "th"} in Resource Allocation Graph @{text "RAG wq"}.
+ Here, "RAGing" means waiting directly or indirectly on the critical resource.
+ \end{minipage}
+ *}
+ cs_dependants_def:
+ "dependants (wq::cs \<Rightarrow> thread list) th \<equiv> {th' . (Th th', Th th) \<in> (RAG wq)^+}"
+
+
+text {* \noindent
+ The following
+ @{text "cpreced s th"} gives the {\em current precedence} of thread @{text "th"} under
+ state @{text "s"}. The definition of @{text "cpreced"} reflects the basic idea of
+ Priority Inheritance that the {\em current precedence} of a thread is the precedence
+ inherited from the maximum of all its dependants, i.e. the threads which are waiting
+ directly or indirectly waiting for some resources from it. If no such thread exits,
+ @{text "th"}'s {\em current precedence} equals its original precedence, i.e.
+ @{text "preced th s"}.
+ *}
+
+definition cpreced :: "(cs \<Rightarrow> thread list) \<Rightarrow> state \<Rightarrow> thread \<Rightarrow> precedence"
+ where "cpreced wq s = (\<lambda>th. Max ((\<lambda>th'. preced th' s) ` ({th} \<union> dependants wq th)))"
+
+text {*
+ Notice that the current precedence (@{text "cpreced"}) of one thread @{text "th"} can be boosted
+ (becoming larger than its own precedence) by those threads in
+ the @{text "dependants wq th"}-set. If one thread get boosted, we say
+ it inherits the priority (or, more precisely, the precedence) of
+ its dependants. This is how the word "Inheritance" in
+ Priority Inheritance Protocol comes.
+*}
+
+(*<*)
+lemma
+ cpreced_def2:
+ "cpreced wq s th \<equiv> Max ({preced th s} \<union> {preced th' s | th'. th' \<in> dependants wq th})"
+ unfolding cpreced_def image_def
+ apply(rule eq_reflection)
+ apply(rule_tac f="Max" in arg_cong)
+ by (auto)
+(*>*)
+
+
+text {* \noindent
+ Assuming @{text "qs"} be the waiting queue of a critical resource,
+ the following abbreviation "release qs" is the waiting queue after the thread
+ holding the resource (which is thread at the head of @{text "qs"}) released
+ the resource:
+*}
+abbreviation
+ "release qs \<equiv> case qs of
+ [] => []
+ | (_#qs') => (SOME q. distinct q \<and> set q = set qs')"
+text {* \noindent
+ It can be seen from the definition that the thread at the head of @{text "qs"} is removed
+ from the return value, and the value @{term "q"} is an reordering of @{text "qs'"}, the
+ tail of @{text "qs"}. Through this reordering, one of the waiting threads (those in @{text "qs'"} }
+ is chosen nondeterministically to be the head of the new queue @{text "q"}.
+ Therefore, this thread is the one who takes over the resource. This is a little better different
+ from common sense that the thread who comes the earliest should take over.
+ The intention of this definition is to show that the choice of which thread to take over the
+ release resource does not affect the correctness of the PIP protocol.
+*}
+
+text {*
+ The data structure used by the operating system for scheduling is referred to as
+ {\em schedule state}. It is represented as a record consisting of
+ a function assigning waiting queue to resources
+ (to be used as the @{text "wq"} argument in @{text "holding"}, @{text "waiting"}
+ and @{text "RAG"}, etc) and a function assigning precedence to threads:
+ *}
+
+record schedule_state =
+ wq_fun :: "cs \<Rightarrow> thread list" -- {* The function assigning waiting queue. *}
+ cprec_fun :: "thread \<Rightarrow> precedence" -- {* The function assigning precedence. *}
+
+text {* \noindent
+ The following two abbreviations (@{text "all_unlocked"} and @{text "initial_cprec"})
+ are used to set the initial values of the @{text "wq_fun"} @{text "cprec_fun"} fields
+ respectively of the @{text "schedule_state"} record by the following function @{text "sch"},
+ which is used to calculate the system's {\em schedule state}.
+
+ Since there is no thread at the very beginning to make request, all critical resources
+ are free (or unlocked). This status is represented by the abbreviation
+ @{text "all_unlocked"}.
+ *}
+abbreviation
+ "all_unlocked \<equiv> \<lambda>_::cs. ([]::thread list)"
+
+
+text {* \noindent
+ The initial current precedence for a thread can be anything, because there is no thread then.
+ We simply assume every thread has precedence @{text "Prc 0 0"}.
+ *}
+
+abbreviation
+ "initial_cprec \<equiv> \<lambda>_::thread. Prc 0 0"
+
+
+text {* \noindent
+ The following function @{text "schs"} is used to calculate the system's schedule state @{text "schs s"}
+ out of the current system state @{text "s"}. It is the central function to model Priority Inheritance:
+ *}
+fun schs :: "state \<Rightarrow> schedule_state"
+ where
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ Setting the initial value of the @{text "schedule_state"} record (see the explanations above).
+ \end{minipage}
+ *}
+ "schs [] = (| wq_fun = all_unlocked, cprec_fun = initial_cprec |)" |
+
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ \begin{enumerate}
+ \item @{text "ps"} is the schedule state of last moment.
+ \item @{text "pwq"} is the waiting queue function of last moment.
+ \item @{text "pcp"} is the precedence function of last moment (NOT USED).
+ \item @{text "nwq"} is the new waiting queue function. It is calculated using a @{text "case"} statement:
+ \begin{enumerate}
+ \item If the happening event is @{text "P thread cs"}, @{text "thread"} is added to
+ the end of @{text "cs"}'s waiting queue.
+ \item If the happening event is @{text "V thread cs"} and @{text "s"} is a legal state,
+ @{text "th'"} must equal to @{text "thread"},
+ because @{text "thread"} is the one currently holding @{text "cs"}.
+ The case @{text "[] \<Longrightarrow> []"} may never be executed in a legal state.
+ the @{text "(SOME q. distinct q \<and> set q = set qs)"} is used to choose arbitrarily one
+ thread in waiting to take over the released resource @{text "cs"}. In our representation,
+ this amounts to rearrange elements in waiting queue, so that one of them is put at the head.
+ \item For other happening event, the schedule state just does not change.
+ \end{enumerate}
+ \item @{text "ncp"} is new precedence function, it is calculated from the newly updated waiting queue
+ function. The RAGency of precedence function on waiting queue function is the reason to
+ put them in the same record so that they can evolve together.
+ \end{enumerate}
+
+
+ The calculation of @{text "cprec_fun"} depends on the value of @{text "wq_fun"}.
+ Therefore, in the following cases, @{text "wq_fun"} is always calculated first, in
+ the name of @{text "wq"} (if @{text "wq_fun"} is not changed
+ by the happening event) or @{text "new_wq"} (if the value of @{text "wq_fun"} is changed).
+ \end{minipage}
+ *}
+ "schs (Create th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Create th prio # s)|))"
+| "schs (Exit th # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Exit th # s)|))"
+| "schs (Set th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Set th prio # s)|))"
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ Different from the forth coming cases, the @{text "wq_fun"} field of the schedule state
+ is changed. So, the new value is calculated first, in the name of @{text "new_wq"}.
+ \end{minipage}
+ *}
+| "schs (P th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := (wq cs @ [th])) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (P th cs # s)|))"
+| "schs (V th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := release (wq cs)) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (V th cs # s)|))"
+
+lemma cpreced_initial:
+ "cpreced (\<lambda> cs. []) [] = (\<lambda>_. (Prc 0 0))"
+apply(simp add: cpreced_def)
+apply(simp add: cs_dependants_def cs_RAG_def cs_waiting_def cs_holding_def)
+apply(simp add: preced_def)
+done
+
+lemma sch_old_def:
+ "schs (e#s) = (let ps = schs s in
+ let pwq = wq_fun ps in
+ let nwq = case e of
+ P th cs \<Rightarrow> pwq(cs:=(pwq cs @ [th])) |
+ V th cs \<Rightarrow> let nq = case (pwq cs) of
+ [] \<Rightarrow> [] |
+ (_#qs) \<Rightarrow> (SOME q. distinct q \<and> set q = set qs)
+ in pwq(cs:=nq) |
+ _ \<Rightarrow> pwq
+ in let ncp = cpreced nwq (e#s) in
+ \<lparr>wq_fun = nwq, cprec_fun = ncp\<rparr>
+ )"
+apply(cases e)
+apply(simp_all)
+done
+
+
+text {*
+ \noindent
+ The following @{text "wq"} is a shorthand for @{text "wq_fun"}.
+ *}
+definition wq :: "state \<Rightarrow> cs \<Rightarrow> thread list"
+ where "wq s = wq_fun (schs s)"
+
+text {* \noindent
+ The following @{text "cp"} is a shorthand for @{text "cprec_fun"}.
+ *}
+definition cp :: "state \<Rightarrow> thread \<Rightarrow> precedence"
+ where "cp s \<equiv> cprec_fun (schs s)"
+
+definition "cp_gen s x = Max ((the_preced s \<circ> the_thread) ` subtree (tRAG s) x)"
+
+text {* \noindent
+ Functions @{text "holding"}, @{text "waiting"}, @{text "RAG"} and
+ @{text "dependants"} still have the
+ same meaning, but redefined so that they no longer RAG on the
+ fictitious {\em waiting queue function}
+ @{text "wq"}, but on system state @{text "s"}.
+ *}
+defs (overloaded)
+ s_holding_abv:
+ "holding (s::state) \<equiv> holding (wq_fun (schs s))"
+ s_waiting_abv:
+ "waiting (s::state) \<equiv> waiting (wq_fun (schs s))"
+ s_RAG_abv:
+ "RAG (s::state) \<equiv> RAG (wq_fun (schs s))"
+ s_dependants_abv:
+ "dependants (s::state) \<equiv> dependants (wq_fun (schs s))"
+
+
+text {*
+ The following lemma can be proved easily, and the meaning is obvious.
+ *}
+lemma
+ s_holding_def:
+ "holding (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th = hd (wq_fun (schs s) cs))"
+ by (auto simp:s_holding_abv wq_def cs_holding_def)
+
+lemma s_waiting_def:
+ "waiting (s::state) th cs \<equiv> (th \<in> set (wq_fun (schs s) cs) \<and> th \<noteq> hd (wq_fun (schs s) cs))"
+ by (auto simp:s_waiting_abv wq_def cs_waiting_def)
+
+lemma s_RAG_def:
+ "RAG (s::state) =
+ {(Th th, Cs cs) | th cs. waiting (wq s) th cs} \<union> {(Cs cs, Th th) | cs th. holding (wq s) th cs}"
+ by (auto simp:s_RAG_abv wq_def cs_RAG_def)
+
+lemma
+ s_dependants_def:
+ "dependants (s::state) th \<equiv> {th' . (Th th', Th th) \<in> (RAG (wq s))^+}"
+ by (auto simp:s_dependants_abv wq_def cs_dependants_def)
+
+text {*
+ The following function @{text "readys"} calculates the set of ready threads. A thread is {\em ready}
+ for running if it is a live thread and it is not waiting for any critical resource.
+ *}
+definition readys :: "state \<Rightarrow> thread set"
+ where "readys s \<equiv> {th . th \<in> threads s \<and> (\<forall> cs. \<not> waiting s th cs)}"
+
+text {* \noindent
+ The following function @{text "runing"} calculates the set of running thread, which is the ready
+ thread with the highest precedence.
+ *}
+definition runing :: "state \<Rightarrow> thread set"
+ where "runing s \<equiv> {th . th \<in> readys s \<and> cp s th = Max ((cp s) ` (readys s))}"
+
+text {* \noindent
+ Notice that the definition of @{text "running"} reflects the preemptive scheduling strategy,
+ because, if the @{text "running"}-thread (the one in @{text "runing"} set)
+ lowered its precedence by resetting its own priority to a lower
+ one, it will lose its status of being the max in @{text "ready"}-set and be superseded.
+*}
+
+text {* \noindent
+ The following function @{text "holdents s th"} returns the set of resources held by thread
+ @{text "th"} in state @{text "s"}.
+ *}
+definition holdents :: "state \<Rightarrow> thread \<Rightarrow> cs set"
+ where "holdents s th \<equiv> {cs . holding s th cs}"
+
+lemma holdents_test:
+ "holdents s th = {cs . (Cs cs, Th th) \<in> RAG s}"
+unfolding holdents_def
+unfolding s_RAG_def
+unfolding s_holding_abv
+unfolding wq_def
+by (simp)
+
+text {* \noindent
+ Observation @{text "cntCS s th"} returns the number of resources held by thread @{text "th"} in
+ state @{text "s"}:
+ *}
+definition cntCS :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntCS s th = card (holdents s th)"
+
+text {* \noindent
+ According to the convention of Paulson's inductive method,
+ the decision made by a protocol that event @{text "e"} is eligible to happen next under state @{text "s"}
+ is expressed as @{text "step s e"}. The predicate @{text "step"} is inductively defined as
+ follows (notice how the decision is based on the {\em observation function}s
+ defined above, and also notice how a complicated protocol is modeled by a few simple
+ observations, and how such a kind of simplicity gives rise to improved trust on
+ faithfulness):
+ *}
+inductive step :: "state \<Rightarrow> event \<Rightarrow> bool"
+ where
+ -- {*
+ A thread can be created if it is not a live thread:
+ *}
+ thread_create: "\<lbrakk>thread \<notin> threads s\<rbrakk> \<Longrightarrow> step s (Create thread prio)" |
+ -- {*
+ A thread can exit if it no longer hold any resource:
+ *}
+ thread_exit: "\<lbrakk>thread \<in> runing s; holdents s thread = {}\<rbrakk> \<Longrightarrow> step s (Exit thread)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can request for an critical resource @{text "cs"}, if it is running and
+ the request does not form a loop in the current RAG. The latter condition
+ is set up to avoid deadlock. The condition also reflects our assumption all threads are
+ carefully programmed so that deadlock can not happen:
+ \end{minipage}
+ *}
+ thread_P: "\<lbrakk>thread \<in> runing s; (Cs cs, Th thread) \<notin> (RAG s)^+\<rbrakk> \<Longrightarrow>
+ step s (P thread cs)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can release a critical resource @{text "cs"}
+ if it is running and holding that resource:
+ \end{minipage}
+ *}
+ thread_V: "\<lbrakk>thread \<in> runing s; holding s thread cs\<rbrakk> \<Longrightarrow> step s (V thread cs)" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ A thread can adjust its own priority as long as it is current running.
+ With the resetting of one thread's priority, its precedence may change.
+ If this change lowered the precedence, according to the definition of @{text "running"}
+ function,
+ \end{minipage}
+ *}
+ thread_set: "\<lbrakk>thread \<in> runing s\<rbrakk> \<Longrightarrow> step s (Set thread prio)"
+
+text {*
+ In Paulson's inductive method, every protocol is defined by such a @{text "step"}
+ predicate. For instance, the predicate @{text "step"} given above
+ defines the PIP protocol. So, it can also be called "PIP".
+*}
+
+abbreviation
+ "PIP \<equiv> step"
+
+
+text {* \noindent
+ For any protocol defined by a @{text "step"} predicate,
+ the fact that @{text "s"} is a legal state in
+ the protocol is expressed as: @{text "vt step s"}, where
+ the predicate @{text "vt"} can be defined as the following:
+ *}
+inductive vt :: "state \<Rightarrow> bool"
+ where
+ -- {* Empty list @{text "[]"} is a legal state in any protocol:*}
+ vt_nil[intro]: "vt []" |
+ -- {*
+ \begin{minipage}{0.9\textwidth}
+ If @{text "s"} a legal state of the protocol defined by predicate @{text "step"},
+ and event @{text "e"} is allowed to happen under state @{text "s"} by the protocol
+ predicate @{text "step"}, then @{text "e#s"} is a new legal state rendered by the
+ happening of @{text "e"}:
+ \end{minipage}
+ *}
+ vt_cons[intro]: "\<lbrakk>vt s; step s e\<rbrakk> \<Longrightarrow> vt (e#s)"
+
+text {* \noindent
+ It is easy to see that the definition of @{text "vt"} is generic. It can be applied to
+ any specific protocol specified by a @{text "step"}-predicate to get the set of
+ legal states of that particular protocol.
+ *}
+
+text {*
+ The following are two very basic properties of @{text "vt"}.
+*}
+
+lemma step_back_vt: "vt (e#s) \<Longrightarrow> vt s"
+ by(ind_cases "vt (e#s)", simp)
+
+lemma step_back_step: "vt (e#s) \<Longrightarrow> step s e"
+ by(ind_cases "vt (e#s)", simp)
+
+text {* \noindent
+ The following two auxiliary functions @{text "the_cs"} and @{text "the_th"} are used to extract
+ critical resource and thread respectively out of RAG nodes.
+ *}
+fun the_cs :: "node \<Rightarrow> cs"
+ where "the_cs (Cs cs) = cs"
+
+fun the_th :: "node \<Rightarrow> thread"
+ where "the_th (Th th) = th"
+
+text {* \noindent
+ The following predicate @{text "next_th"} describe the next thread to
+ take over when a critical resource is released. In @{text "next_th s th cs t"},
+ @{text "th"} is the thread to release, @{text "t"} is the one to take over.
+ Notice how this definition is backed up by the @{text "release"} function and its use
+ in the @{text "V"}-branch of @{text "schs"} function. This @{text "next_th"} function
+ is not needed for the execution of PIP. It is introduced as an auxiliary function
+ to state lemmas. The correctness of this definition will be confirmed by
+ lemmas @{text "step_v_hold_inv"}, @{text " step_v_wait_inv"},
+ @{text "step_v_get_hold"} and @{text "step_v_not_wait"}.
+ *}
+definition next_th:: "state \<Rightarrow> thread \<Rightarrow> cs \<Rightarrow> thread \<Rightarrow> bool"
+ where "next_th s th cs t = (\<exists> rest. wq s cs = th#rest \<and> rest \<noteq> [] \<and>
+ t = hd (SOME q. distinct q \<and> set q = set rest))"
+
+text {* \noindent
+ The aux function @{text "count Q l"} is used to count the occurrence of situation @{text "Q"}
+ in list @{text "l"}:
+ *}
+definition count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat"
+ where "count Q l = length (filter Q l)"
+
+text {* \noindent
+ The following observation @{text "cntP s"} returns the number of operation @{text "P"} happened
+ before reaching state @{text "s"}.
+ *}
+definition cntP :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntP s th = count (\<lambda> e. \<exists> cs. e = P th cs) s"
+
+text {* \noindent
+ The following observation @{text "cntV s"} returns the number of operation @{text "V"} happened
+ before reaching state @{text "s"}.
+ *}
+definition cntV :: "state \<Rightarrow> thread \<Rightarrow> nat"
+ where "cntV s th = count (\<lambda> e. \<exists> cs. e = V th cs) s"
+(*<*)
+
+end
+(*>*)
+
--- a/README Wed May 14 11:52:53 2014 +0100
+++ b/README Wed Jan 27 13:50:02 2016 +0000
@@ -1,16 +1,18 @@
Theories:
=========
+ Max.thy Some generic facts about Max.
Precedence_ord.thy A theory of precedences.
Moment.thy The notion of moment.
- PrioGDef.thy The formal definition of the PIP-model.
- PrioG.thy Basic properties of the PIP-model.
- ExtGG.thy The correctness proof of the PIP-model.
- CpsG.thy Properties interesting for an implementation.
+ PIPDefs.thy The formal definition of the PIP-model.
+ PIPBasics.thy Basic properties of the PIP-model.
+ Correctness.thy The correctness proof of the PIP-model.
+ Implementation.thy Properties interesting for an implementation.
+
The repository can be checked using Isabelle 2013-2.
- isabelle build -d . PIP
+ isabelle build -c -v -d . PIP
Othe directories are:
@@ -18,12 +20,13 @@
Slides
Paper
- Journal
+ Journal: isabelle build -c -v -d . Journal
Literature
+
+Test 3
-
--- a/ROOT Wed May 14 11:52:53 2014 +0100
+++ b/ROOT Wed Jan 27 13:50:02 2016 +0000
@@ -1,7 +1,8 @@
session "PIP" = HOL +
- theories [document = false]
- "CpsG"
- "ExtGG"
+ theories [document = false, quick_and_dirty]
+ "Implementation"
+ "Correctness"
+ "Test"
session "Slides2" in "Slides" = PIP +
options [document_variants="slides2"]
@@ -37,3 +38,7 @@
theories
"~~/src/HOL/Library/LaTeXsugar"
"Paper"
+ document_files
+ "root.bib"
+ "root.tex"
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RTree.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,1745 @@
+theory RTree
+imports "~~/src/HOL/Library/Transitive_Closure_Table" Max
+begin
+
+section {* A theory of relational trees *}
+
+inductive_cases path_nilE [elim!]: "rtrancl_path r x [] y"
+inductive_cases path_consE [elim!]: "rtrancl_path r x (z#zs) y"
+
+subsection {* Definitions *}
+
+text {*
+ In this theory, we are going to give a notion of of `Relational Graph` and
+ its derived notion `Relational Tree`. Given a binary relation @{text "r"},
+ the `Relational Graph of @{text "r"}` is the graph, the edges of which
+ are those in @{text "r"}. In this way, any binary relation can be viewed
+ as a `Relational Graph`. Note, this notion of graph includes infinite graphs.
+
+ A `Relation Graph` @{text "r"} is said to be a `Relational Tree` if it is both
+ {\em single valued} and {\em acyclic}.
+*}
+
+text {*
+ The following @{text "sgv"} specifies that relation @{text "r"} is {\em single valued}.
+*}
+locale sgv =
+ fixes r
+ assumes sgv: "single_valued r"
+
+text {*
+ The following @{text "rtree"} specifies that @{text "r"} is a
+ {\em Relational Tree}.
+*}
+locale rtree = sgv +
+ assumes acl: "acyclic r"
+
+text {*
+ The following two auxiliary functions @{text "rel_of"} and @{text "pred_of"}
+ transfer between the predicate and set representation of binary relations.
+*}
+
+definition "rel_of r = {(x, y) | x y. r x y}"
+
+definition "pred_of r = (\<lambda> x y. (x, y) \<in> r)"
+
+text {*
+ To reason about {\em Relational Graph}, a notion of path is
+ needed, which is given by the following @{text "rpath"} (short
+ for `relational path`).
+ The path @{text "xs"} in proposition @{text "rpath r x xs y"} is
+ a path leading from @{text "x"} to @{text "y"}, which serves as a
+ witness of the fact @{text "(x, y) \<in> r^*"}.
+
+ @{text "rpath"}
+ is simply a wrapper of the @{text "rtrancl_path"} defined in the imported
+ theory @{text "Transitive_Closure_Table"}, which defines
+ a notion of path for the predicate form of binary relations.
+*}
+definition "rpath r x xs y = rtrancl_path (pred_of r) x xs y"
+
+text {*
+ Given a path @{text "ps"}, @{text "edges_on ps"} is the
+ set of edges along the path, which is defined as follows:
+*}
+
+definition "edges_on ps = {(a,b) | a b. \<exists> xs ys. ps = xs@[a,b]@ys}"
+
+text {*
+ The following @{text "indep"} defines a notion of independence.
+ Two nodes @{text "x"} and @{text "y"} are said to be independent
+ (expressed as @{text "indep x y"}), if neither one is reachable
+ from the other in relational graph @{text "r"}.
+*}
+definition "indep r x y = (((x, y) \<notin> r^*) \<and> ((y, x) \<notin> r^*))"
+
+text {*
+ In relational tree @{text "r"}, the sub tree of node @{text "x"} is written
+ @{text "subtree r x"}, which is defined to be the set of nodes (including itself)
+ which can reach @{text "x"} by following some path in @{text "r"}:
+*}
+
+definition "subtree r x = {y . (y, x) \<in> r^*}"
+
+definition "ancestors r x = {y. (x, y) \<in> r^+}"
+
+definition "root r x = (ancestors r x = {})"
+
+text {*
+ The following @{text "edge_in r x"} is the set of edges
+ contained in the sub-tree of @{text "x"}, with @{text "r"} as the underlying graph.
+*}
+
+definition "edges_in r x = {(a, b) | a b. (a, b) \<in> r \<and> b \<in> subtree r x}"
+
+text {*
+ The following lemma @{text "edges_in_meaning"} shows the intuitive meaning
+ of `an edge @{text "(a, b)"} is in the sub-tree of @{text "x"}`,
+ i.e., both @{text "a"} and @{text "b"} are in the sub-tree.
+*}
+lemma edges_in_meaning:
+ "edges_in r x = {(a, b) | a b. (a, b) \<in> r \<and> a \<in> subtree r x \<and> b \<in> subtree r x}"
+proof -
+ { fix a b
+ assume h: "(a, b) \<in> r" "b \<in> subtree r x"
+ moreover have "a \<in> subtree r x"
+ proof -
+ from h(2)[unfolded subtree_def] have "(b, x) \<in> r^*" by simp
+ with h(1) have "(a, x) \<in> r^*" by auto
+ thus ?thesis by (auto simp:subtree_def)
+ qed
+ ultimately have "((a, b) \<in> r \<and> a \<in> subtree r x \<and> b \<in> subtree r x)"
+ by (auto)
+ } thus ?thesis by (auto simp:edges_in_def)
+qed
+
+text {*
+ The following lemma shows the meaning of @{term "edges_in"} from the other side,
+ which says: for the edge @{text "(a,b)"} to be outside of the sub-tree of @{text "x"},
+ it is sufficient to show that @{text "b"} is.
+*}
+lemma edges_in_refutation:
+ assumes "b \<notin> subtree r x"
+ shows "(a, b) \<notin> edges_in r x"
+ using assms by (unfold edges_in_def subtree_def, auto)
+
+definition "children r x = {y. (y, x) \<in> r}"
+
+locale fbranch =
+ fixes r
+ assumes fb: "\<forall> x \<in> Range r . finite (children r x)"
+begin
+
+lemma finite_children: "finite (children r x)"
+proof(cases "children r x = {}")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ then obtain y where "(y, x) \<in> r" by (auto simp:children_def)
+ hence "x \<in> Range r" by auto
+ from fb[rule_format, OF this]
+ show ?thesis .
+qed
+
+end
+
+locale fsubtree = fbranch +
+ assumes wf: "wf r"
+
+(* ccc *)
+
+subsection {* Auxiliary lemmas *}
+
+lemma index_minimize:
+ assumes "P (i::nat)"
+ obtains j where "P j" and "\<forall> k < j. \<not> P k"
+using assms
+proof -
+ have "\<exists> j. P j \<and> (\<forall> k < j. \<not> P k)"
+ using assms
+ proof(induct i rule:less_induct)
+ case (less t)
+ show ?case
+ proof(cases "\<forall> j < t. \<not> P j")
+ case True
+ with less (2) show ?thesis by blast
+ next
+ case False
+ then obtain j where "j < t" "P j" by auto
+ from less(1)[OF this]
+ show ?thesis .
+ qed
+ qed
+ with that show ?thesis by metis
+qed
+
+subsection {* Properties of Relational Graphs and Relational Trees *}
+
+subsubsection {* Properties of @{text "rel_of"} and @{text "pred_of"} *}
+
+text {* The following lemmas establish bijectivity of the two functions *}
+
+lemma pred_rel_eq: "pred_of (rel_of r) = r" by (auto simp:rel_of_def pred_of_def)
+
+lemma rel_pred_eq: "rel_of (pred_of r) = r" by (auto simp:rel_of_def pred_of_def)
+
+lemma rel_of_star: "rel_of (r^**) = (rel_of r)^*"
+ by (unfold rel_of_def rtranclp_rtrancl_eq, auto)
+
+lemma pred_of_star: "pred_of (r^*) = (pred_of r)^**"
+proof -
+ { fix x y
+ have "pred_of (r^*) x y = (pred_of r)^** x y"
+ by (unfold pred_of_def rtranclp_rtrancl_eq, auto)
+ } thus ?thesis by auto
+qed
+
+lemma star_2_pstar: "(x, y) \<in> r^* = (pred_of (r^*)) x y"
+ by (simp add: pred_of_def)
+
+subsubsection {* Properties of @{text "rpath"} *}
+
+text {* Induction rule for @{text "rpath"}: *}
+
+lemma rpath_induct [consumes 1, case_names rbase rstep, induct pred: rpath]:
+ assumes "rpath r x1 x2 x3"
+ and "\<And>x. P x [] x"
+ and "\<And>x y ys z. (x, y) \<in> r \<Longrightarrow> rpath r y ys z \<Longrightarrow> P y ys z \<Longrightarrow> P x (y # ys) z"
+ shows "P x1 x2 x3"
+ using assms[unfolded rpath_def]
+ by (induct, auto simp:pred_of_def rpath_def)
+
+lemma rpathE:
+ assumes "rpath r x xs y"
+ obtains (base) "y = x" "xs = []"
+ | (step) z zs where "(x, z) \<in> r" "rpath r z zs y" "xs = z#zs"
+ using assms
+ by (induct, auto)
+
+text {* Introduction rule for empty path *}
+lemma rbaseI [intro!]:
+ assumes "x = y"
+ shows "rpath r x [] y"
+ by (unfold rpath_def assms,
+ rule Transitive_Closure_Table.rtrancl_path.base)
+
+text {* Introduction rule for non-empty path *}
+lemma rstepI [intro!]:
+ assumes "(x, y) \<in> r"
+ and "rpath r y ys z"
+ shows "rpath r x (y#ys) z"
+proof(unfold rpath_def, rule Transitive_Closure_Table.rtrancl_path.step)
+ from assms(1) show "pred_of r x y" by (auto simp:pred_of_def)
+next
+ from assms(2) show "rtrancl_path (pred_of r) y ys z"
+ by (auto simp:pred_of_def rpath_def)
+qed
+
+text {* Introduction rule for @{text "@"}-path *}
+lemma rpath_appendI [intro]:
+ assumes "rpath r x xs a" and "rpath r a ys y"
+ shows "rpath r x (xs @ ys) y"
+ using assms
+ by (unfold rpath_def, auto intro:rtrancl_path_trans)
+
+text {* Elimination rule for empty path *}
+
+lemma rpath_cases [cases pred:rpath]:
+ assumes "rpath r a1 a2 a3"
+ obtains (rbase) "a1 = a3" and "a2 = []"
+ | (rstep) y :: "'a" and ys :: "'a list"
+ where "(a1, y) \<in> r" and "a2 = y # ys" and "rpath r y ys a3"
+ using assms [unfolded rpath_def]
+ by (cases, auto simp:rpath_def pred_of_def)
+
+lemma rpath_nilE [elim!, cases pred:rpath]:
+ assumes "rpath r x [] y"
+ obtains "y = x"
+ using assms[unfolded rpath_def] by auto
+
+-- {* This is a auxiliary lemmas used only in the proof of @{text "rpath_nnl_lastE"} *}
+lemma rpath_nnl_last:
+ assumes "rtrancl_path r x xs y"
+ and "xs \<noteq> []"
+ obtains xs' where "xs = xs'@[y]"
+proof -
+ from append_butlast_last_id[OF `xs \<noteq> []`, symmetric]
+ obtain xs' y' where eq_xs: "xs = (xs' @ y' # [])" by simp
+ with assms(1)
+ have "rtrancl_path r x ... y" by simp
+ hence "y = y'" by (rule rtrancl_path_appendE, auto)
+ with eq_xs have "xs = xs'@[y]" by simp
+ from that[OF this] show ?thesis .
+qed
+
+text {*
+ Elimination rule for non-empty paths constructed with @{text "#"}.
+*}
+
+lemma rpath_ConsE [elim!, cases pred:rpath]:
+ assumes "rpath r x (y # ys) x2"
+ obtains (rstep) "(x, y) \<in> r" and "rpath r y ys x2"
+ using assms[unfolded rpath_def]
+ by (cases, auto simp:rpath_def pred_of_def)
+
+text {*
+ Elimination rule for non-empty path, where the destination node
+ @{text "y"} is shown to be at the end of the path.
+*}
+lemma rpath_nnl_lastE:
+ assumes "rpath r x xs y"
+ and "xs \<noteq> []"
+ obtains xs' where "xs = xs'@[y]"
+ using assms[unfolded rpath_def]
+ by (rule rpath_nnl_last, auto)
+
+text {* Other elimination rules of @{text "rpath"} *}
+
+lemma rpath_appendE:
+ assumes "rpath r x (xs @ [a] @ ys) y"
+ obtains "rpath r x (xs @ [a]) a" and "rpath r a ys y"
+ using rtrancl_path_appendE[OF assms[unfolded rpath_def, simplified], folded rpath_def]
+ by auto
+
+lemma rpath_subE:
+ assumes "rpath r x (xs @ [a] @ ys @ [b] @ zs) y"
+ obtains "rpath r x (xs @ [a]) a" and "rpath r a (ys @ [b]) b" and "rpath r b zs y"
+ using assms
+ by (elim rpath_appendE, auto)
+
+text {* Every path has a unique end point. *}
+lemma rpath_dest_eq:
+ assumes "rpath r x xs x1"
+ and "rpath r x xs x2"
+ shows "x1 = x2"
+ using assms
+ by (induct, auto)
+
+subsubsection {* Properites of @{text "edges_on"} *}
+
+lemma edges_on_unfold:
+ "edges_on (a # b # xs) = {(a, b)} \<union> edges_on (b # xs)" (is "?L = ?R")
+proof -
+ { fix c d
+ assume "(c, d) \<in> ?L"
+ then obtain l1 l2 where h: "(a # b # xs) = l1 @ [c, d] @ l2"
+ by (auto simp:edges_on_def)
+ have "(c, d) \<in> ?R"
+ proof(cases "l1")
+ case Nil
+ with h have "(c, d) = (a, b)" by auto
+ thus ?thesis by auto
+ next
+ case (Cons e es)
+ from h[unfolded this] have "b#xs = es@[c, d]@l2" by auto
+ thus ?thesis by (auto simp:edges_on_def)
+ qed
+ } moreover
+ { fix c d
+ assume "(c, d) \<in> ?R"
+ moreover have "(a, b) \<in> ?L"
+ proof -
+ have "(a # b # xs) = []@[a,b]@xs" by simp
+ hence "\<exists> l1 l2. (a # b # xs) = l1@[a,b]@l2" by auto
+ thus ?thesis by (unfold edges_on_def, simp)
+ qed
+ moreover {
+ assume "(c, d) \<in> edges_on (b#xs)"
+ then obtain l1 l2 where "b#xs = l1@[c, d]@l2" by (unfold edges_on_def, auto)
+ hence "a#b#xs = (a#l1)@[c,d]@l2" by simp
+ hence "\<exists> l1 l2. (a # b # xs) = l1@[c,d]@l2" by metis
+ hence "(c,d) \<in> ?L" by (unfold edges_on_def, simp)
+ }
+ ultimately have "(c, d) \<in> ?L" by auto
+ } ultimately show ?thesis by auto
+qed
+
+lemma edges_on_len:
+ assumes "(a,b) \<in> edges_on l"
+ shows "length l \<ge> 2"
+ using assms
+ by (unfold edges_on_def, auto)
+
+text {* Elimination of @{text "edges_on"} for non-empty path *}
+
+lemma edges_on_consE [elim, cases set:edges_on]:
+ assumes "(a,b) \<in> edges_on (x#xs)"
+ obtains (head) xs' where "x = a" and "xs = b#xs'"
+ | (tail) "(a,b) \<in> edges_on xs"
+proof -
+ from assms obtain l1 l2
+ where h: "(x#xs) = l1 @ [a,b] @ l2" by (unfold edges_on_def, blast)
+ have "(\<exists> xs'. x = a \<and> xs = b#xs') \<or> ((a,b) \<in> edges_on xs)"
+ proof(cases "l1")
+ case Nil with h
+ show ?thesis by auto
+ next
+ case (Cons e el)
+ from h[unfolded this]
+ have "xs = el @ [a,b] @ l2" by auto
+ thus ?thesis
+ by (unfold edges_on_def, auto)
+ qed
+ thus ?thesis
+ proof
+ assume "(\<exists>xs'. x = a \<and> xs = b # xs')"
+ then obtain xs' where "x = a" "xs = b#xs'" by blast
+ from that(1)[OF this] show ?thesis .
+ next
+ assume "(a, b) \<in> edges_on xs"
+ from that(2)[OF this] show ?thesis .
+ qed
+qed
+
+text {*
+ Every edges on the path is a graph edges:
+*}
+lemma rpath_edges_on:
+ assumes "rpath r x xs y"
+ shows "(edges_on (x#xs)) \<subseteq> r"
+ using assms
+proof(induct arbitrary:y)
+ case (rbase x)
+ thus ?case by (unfold edges_on_def, auto)
+next
+ case (rstep x y ys z)
+ show ?case
+ proof -
+ { fix a b
+ assume "(a, b) \<in> edges_on (x # y # ys)"
+ hence "(a, b) \<in> r" by (cases, insert rstep, auto)
+ } thus ?thesis by auto
+ qed
+qed
+
+text {* @{text "edges_on"} is mono with respect to @{text "#"}-operation: *}
+lemma edges_on_Cons_mono:
+ shows "edges_on xs \<subseteq> edges_on (x#xs)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> edges_on xs"
+ then obtain l1 l2 where "xs = l1 @ [a,b] @ l2"
+ by (auto simp:edges_on_def)
+ hence "x # xs = (x#l1) @ [a, b] @ l2" by auto
+ hence "(a, b) \<in> edges_on (x#xs)"
+ by (unfold edges_on_def, blast)
+ } thus ?thesis by auto
+qed
+
+text {*
+ The following rule @{text "rpath_transfer"} is used to show
+ that one path is intact as long as all the edges on it are intact
+ with the change of graph.
+
+ If @{text "x#xs"} is path in graph @{text "r1"} and
+ every edges along the path is also in @{text "r2"},
+ then @{text "x#xs"} is also a edge in graph @{text "r2"}:
+*}
+
+lemma rpath_transfer:
+ assumes "rpath r1 x xs y"
+ and "edges_on (x#xs) \<subseteq> r2"
+ shows "rpath r2 x xs y"
+ using assms
+proof(induct)
+ case (rstep x y ys z)
+ show ?case
+ proof(rule rstepI)
+ show "(x, y) \<in> r2"
+ proof -
+ have "(x, y) \<in> edges_on (x # y # ys)"
+ by (unfold edges_on_def, auto)
+ with rstep(4) show ?thesis by auto
+ qed
+ next
+ show "rpath r2 y ys z"
+ using rstep edges_on_Cons_mono[of "y#ys" "x"] by (auto)
+ qed
+qed (unfold rpath_def, auto intro!:Transitive_Closure_Table.rtrancl_path.base)
+
+lemma edges_on_rpathI:
+ assumes "edges_on (a#xs@[b]) \<subseteq> r"
+ shows "rpath r a (xs@[b]) b"
+ using assms
+proof(induct xs arbitrary: a b)
+ case Nil
+ moreover have "(a, b) \<in> edges_on (a # [] @ [b])"
+ by (unfold edges_on_def, auto)
+ ultimately have "(a, b) \<in> r" by auto
+ thus ?case by auto
+next
+ case (Cons x xs a b)
+ from this(2) have "edges_on (x # xs @ [b]) \<subseteq> r" by (simp add:edges_on_unfold)
+ from Cons(1)[OF this] have " rpath r x (xs @ [b]) b" .
+ moreover from Cons(2) have "(a, x) \<in> r" by (auto simp:edges_on_unfold)
+ ultimately show ?case by (auto)
+qed
+
+text {*
+ The following lemma extracts the path from @{text "x"} to @{text "y"}
+ from proposition @{text "(x, y) \<in> r^*"}
+*}
+lemma star_rpath:
+ assumes "(x, y) \<in> r^*"
+ obtains xs where "rpath r x xs y"
+proof -
+ have "\<exists> xs. rpath r x xs y"
+ proof(unfold rpath_def, rule iffD1[OF rtranclp_eq_rtrancl_path])
+ from assms
+ show "(pred_of r)\<^sup>*\<^sup>* x y"
+ apply (fold pred_of_star)
+ by (auto simp:pred_of_def)
+ qed
+ from that and this show ?thesis by blast
+qed
+
+text {*
+ The following lemma uses the path @{text "xs"} from @{text "x"} to @{text "y"}
+ as a witness to show @{text "(x, y) \<in> r^*"}.
+*}
+lemma rpath_star:
+ assumes "rpath r x xs y"
+ shows "(x, y) \<in> r^*"
+proof -
+ from iffD2[OF rtranclp_eq_rtrancl_path] and assms[unfolded rpath_def]
+ have "(pred_of r)\<^sup>*\<^sup>* x y" by metis
+ thus ?thesis by (simp add: pred_of_star star_2_pstar)
+qed
+
+lemma subtree_transfer:
+ assumes "a \<in> subtree r1 a'"
+ and "r1 \<subseteq> r2"
+ shows "a \<in> subtree r2 a'"
+proof -
+ from assms(1)[unfolded subtree_def]
+ have "(a, a') \<in> r1^*" by auto
+ from star_rpath[OF this]
+ obtain xs where rp: "rpath r1 a xs a'" by blast
+ hence "rpath r2 a xs a'"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] and assms(2)
+ show "edges_on (a # xs) \<subseteq> r2" by simp
+ qed
+ from rpath_star[OF this]
+ show ?thesis by (auto simp:subtree_def)
+qed
+
+lemma subtree_rev_transfer:
+ assumes "a \<notin> subtree r2 a'"
+ and "r1 \<subseteq> r2"
+ shows "a \<notin> subtree r1 a'"
+ using assms and subtree_transfer by metis
+
+text {*
+ The following lemmas establishes a relation from paths in @{text "r"}
+ to @{text "r^+"} relation.
+*}
+lemma rpath_plus:
+ assumes "rpath r x xs y"
+ and "xs \<noteq> []"
+ shows "(x, y) \<in> r^+"
+proof -
+ from assms(2) obtain e es where "xs = e#es" by (cases xs, auto)
+ from assms(1)[unfolded this]
+ show ?thesis
+ proof(cases)
+ case rstep
+ show ?thesis
+ proof -
+ from rpath_star[OF rstep(2)] have "(e, y) \<in> r\<^sup>*" .
+ with rstep(1) show "(x, y) \<in> r^+" by auto
+ qed
+ qed
+qed
+
+lemma plus_rpath:
+ assumes "(x, y) \<in> r^+"
+ obtains xs where "rpath r x xs y" and "xs \<noteq> []"
+proof -
+ from assms
+ show ?thesis
+ proof(cases rule:converse_tranclE[consumes 1])
+ case 1
+ hence "rpath r x [y] y" by auto
+ from that[OF this] show ?thesis by auto
+ next
+ case (2 z)
+ from 2(2) have "(z, y) \<in> r^*" by auto
+ from star_rpath[OF this] obtain xs where "rpath r z xs y" by auto
+ from rstepI[OF 2(1) this]
+ have "rpath r x (z # xs) y" .
+ from that[OF this] show ?thesis by auto
+ qed
+qed
+
+subsubsection {* Properties of @{text "subtree"} and @{term "ancestors"}*}
+
+lemma ancestors_subtreeI:
+ assumes "b \<in> ancestors r a"
+ shows "a \<in> subtree r b"
+ using assms by (auto simp:subtree_def ancestors_def)
+
+lemma ancestors_Field:
+ assumes "b \<in> ancestors r a"
+ obtains "a \<in> Domain r" "b \<in> Range r"
+ using assms
+ apply (unfold ancestors_def, simp)
+ by (metis Domain.DomainI Range.intros trancl_domain trancl_range)
+
+lemma subtreeE:
+ assumes "a \<in> subtree r b"
+ obtains "a = b"
+ | "a \<noteq> b" and "b \<in> ancestors r a"
+proof -
+ from assms have "(a, b) \<in> r^*" by (auto simp:subtree_def)
+ from rtranclD[OF this]
+ have " a = b \<or> a \<noteq> b \<and> (a, b) \<in> r\<^sup>+" .
+ with that[unfolded ancestors_def] show ?thesis by auto
+qed
+
+
+lemma subtree_Field:
+ "subtree r x \<subseteq> Field r \<union> {x}"
+proof
+ fix y
+ assume "y \<in> subtree r x"
+ thus "y \<in> Field r \<union> {x}"
+ proof(cases rule:subtreeE)
+ case 1
+ thus ?thesis by auto
+ next
+ case 2
+ thus ?thesis apply (auto simp:ancestors_def)
+ using Field_def tranclD by fastforce
+ qed
+qed
+
+lemma subtree_ancestorsI:
+ assumes "a \<in> subtree r b"
+ and "a \<noteq> b"
+ shows "b \<in> ancestors r a"
+ using assms
+ by (auto elim!:subtreeE)
+
+text {*
+ @{text "subtree"} is mono with respect to the underlying graph.
+*}
+lemma subtree_mono:
+ assumes "r1 \<subseteq> r2"
+ shows "subtree r1 x \<subseteq> subtree r2 x"
+proof
+ fix c
+ assume "c \<in> subtree r1 x"
+ hence "(c, x) \<in> r1^*" by (auto simp:subtree_def)
+ from star_rpath[OF this] obtain xs
+ where rp:"rpath r1 c xs x" by metis
+ hence "rpath r2 c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] have "edges_on (c # xs) \<subseteq> r1" .
+ with assms show "edges_on (c # xs) \<subseteq> r2" by auto
+ qed
+ thus "c \<in> subtree r2 x"
+ by (rule rpath_star[elim_format], auto simp:subtree_def)
+qed
+
+text {*
+ The following lemma characterizes the change of sub-tree of @{text "x"}
+ with the removal of an outside edge @{text "(a,b)"}.
+
+ Note that, according to lemma @{thm edges_in_refutation}, the assumption
+ @{term "b \<notin> subtree r x"} amounts to saying @{text "(a, b)"}
+ is outside the sub-tree of @{text "x"}.
+*}
+lemma subtree_del_outside: (* ddd *)
+ assumes "b \<notin> subtree r x"
+ shows "subtree (r - {(a, b)}) x = (subtree r x)"
+proof -
+ { fix c
+ assume "c \<in> (subtree r x)"
+ hence "(c, x) \<in> r^*" by (auto simp:subtree_def)
+ hence "c \<in> subtree (r - {(a, b)}) x"
+ proof(rule star_rpath)
+ fix xs
+ assume rp: "rpath r c xs x"
+ show ?thesis
+ proof -
+ from rp
+ have "rpath (r - {(a, b)}) c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] have "edges_on (c # xs) \<subseteq> r" .
+ moreover have "(a, b) \<notin> edges_on (c#xs)"
+ proof
+ assume "(a, b) \<in> edges_on (c # xs)"
+ then obtain l1 l2 where h: "c#xs = l1@[a,b]@l2" by (auto simp:edges_on_def)
+ hence "tl (c#xs) = tl (l1@[a,b]@l2)" by simp
+ then obtain l1' where eq_xs_b: "xs = l1'@[b]@l2" by (cases l1, auto)
+ from rp[unfolded this]
+ show False
+ proof(rule rpath_appendE)
+ assume "rpath r b l2 x"
+ thus ?thesis
+ by(rule rpath_star[elim_format], insert assms(1), auto simp:subtree_def)
+ qed
+ qed
+ ultimately show "edges_on (c # xs) \<subseteq> r - {(a,b)}" by auto
+ qed
+ thus ?thesis by (rule rpath_star[elim_format], auto simp:subtree_def)
+ qed
+ qed
+ } moreover {
+ fix c
+ assume "c \<in> subtree (r - {(a, b)}) x"
+ moreover have "... \<subseteq> (subtree r x)" by (rule subtree_mono, auto)
+ ultimately have "c \<in> (subtree r x)" by auto
+ } ultimately show ?thesis by auto
+qed
+
+(* ddd *)
+lemma subset_del_subtree_outside: (* ddd *)
+ assumes "Range r' \<inter> subtree r x = {}"
+ shows "subtree (r - r') x = (subtree r x)"
+proof -
+ { fix c
+ assume "c \<in> (subtree r x)"
+ hence "(c, x) \<in> r^*" by (auto simp:subtree_def)
+ hence "c \<in> subtree (r - r') x"
+ proof(rule star_rpath)
+ fix xs
+ assume rp: "rpath r c xs x"
+ show ?thesis
+ proof -
+ from rp
+ have "rpath (r - r') c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] have "edges_on (c # xs) \<subseteq> r" .
+ moreover {
+ fix a b
+ assume h: "(a, b) \<in> r'"
+ have "(a, b) \<notin> edges_on (c#xs)"
+ proof
+ assume "(a, b) \<in> edges_on (c # xs)"
+ then obtain l1 l2 where "c#xs = (l1@[a])@[b]@l2" by (auto simp:edges_on_def)
+ hence "tl (c#xs) = tl (l1@[a,b]@l2)" by simp
+ then obtain l1' where eq_xs_b: "xs = l1'@[b]@l2" by (cases l1, auto)
+ from rp[unfolded this]
+ show False
+ proof(rule rpath_appendE)
+ assume "rpath r b l2 x"
+ from rpath_star[OF this]
+ have "b \<in> subtree r x" by (auto simp:subtree_def)
+ with assms (1) and h show ?thesis by (auto)
+ qed
+ qed
+ } ultimately show "edges_on (c # xs) \<subseteq> r - r'" by auto
+ qed
+ thus ?thesis by (rule rpath_star[elim_format], auto simp:subtree_def)
+ qed
+ qed
+ } moreover {
+ fix c
+ assume "c \<in> subtree (r - r') x"
+ moreover have "... \<subseteq> (subtree r x)" by (rule subtree_mono, auto)
+ ultimately have "c \<in> (subtree r x)" by auto
+ } ultimately show ?thesis by auto
+qed
+
+lemma subtree_insert_ext:
+ assumes "b \<in> subtree r x"
+ shows "subtree (r \<union> {(a, b)}) x = (subtree r x) \<union> (subtree r a)"
+ using assms by (auto simp:subtree_def rtrancl_insert)
+
+lemma subtree_insert_next:
+ assumes "b \<notin> subtree r x"
+ shows "subtree (r \<union> {(a, b)}) x = (subtree r x)"
+ using assms
+ by (auto simp:subtree_def rtrancl_insert)
+
+lemma set_add_rootI:
+ assumes "root r a"
+ and "a \<notin> Domain r1"
+ shows "root (r \<union> r1) a"
+proof -
+ let ?r = "r \<union> r1"
+ { fix a'
+ assume "a' \<in> ancestors ?r a"
+ hence "(a, a') \<in> ?r^+" by (auto simp:ancestors_def)
+ from tranclD[OF this] obtain z where "(a, z) \<in> ?r" by auto
+ moreover have "(a, z) \<notin> r"
+ proof
+ assume "(a, z) \<in> r"
+ with assms(1) show False
+ by (auto simp:root_def ancestors_def)
+ qed
+ ultimately have "(a, z) \<in> r1" by auto
+ with assms(2)
+ have False by (auto)
+ } thus ?thesis by (auto simp:root_def)
+qed
+
+lemma ancestors_mono:
+ assumes "r1 \<subseteq> r2"
+ shows "ancestors r1 x \<subseteq> ancestors r2 x"
+proof
+ fix a
+ assume "a \<in> ancestors r1 x"
+ hence "(x, a) \<in> r1^+" by (auto simp:ancestors_def)
+ from plus_rpath[OF this] obtain xs where
+ h: "rpath r1 x xs a" "xs \<noteq> []" .
+ have "rpath r2 x xs a"
+ proof(rule rpath_transfer[OF h(1)])
+ from rpath_edges_on[OF h(1)] and assms
+ show "edges_on (x # xs) \<subseteq> r2" by auto
+ qed
+ from rpath_plus[OF this h(2)]
+ show "a \<in> ancestors r2 x" by (auto simp:ancestors_def)
+qed
+
+lemma subtree_refute:
+ assumes "x \<notin> ancestors r y"
+ and "x \<noteq> y"
+ shows "y \<notin> subtree r x"
+proof
+ assume "y \<in> subtree r x"
+ thus False
+ by(elim subtreeE, insert assms, auto)
+qed
+
+subsubsection {* Properties about relational trees *}
+
+context rtree
+begin
+
+lemma ancestors_headE:
+ assumes "c \<in> ancestors r a"
+ assumes "(a, b) \<in> r"
+ obtains "b = c"
+ | "c \<in> ancestors r b"
+proof -
+ from assms(1)
+ have "(a, c) \<in> r^+" by (auto simp:ancestors_def)
+ hence "b = c \<or> c \<in> ancestors r b"
+ proof(cases rule:converse_tranclE[consumes 1])
+ case 1
+ with assms(2) and sgv have "b = c" by (auto simp:single_valued_def)
+ thus ?thesis by auto
+ next
+ case (2 y)
+ from 2(1) and assms(2) and sgv have "y = b" by (auto simp:single_valued_def)
+ from 2(2)[unfolded this] have "c \<in> ancestors r b" by (auto simp:ancestors_def)
+ thus ?thesis by auto
+ qed
+ with that show ?thesis by metis
+qed
+
+lemma ancestors_accum:
+ assumes "(a, b) \<in> r"
+ shows "ancestors r a = ancestors r b \<union> {b}"
+proof -
+ { fix c
+ assume "c \<in> ancestors r a"
+ hence "(a, c) \<in> r^+" by (auto simp:ancestors_def)
+ hence "c \<in> ancestors r b \<union> {b}"
+ proof(cases rule:converse_tranclE[consumes 1])
+ case 1
+ with sgv assms have "c = b" by (unfold single_valued_def, auto)
+ thus ?thesis by auto
+ next
+ case (2 c')
+ with sgv assms have "c' = b" by (unfold single_valued_def, auto)
+ from 2(2)[unfolded this]
+ show ?thesis by (auto simp:ancestors_def)
+ qed
+ } moreover {
+ fix c
+ assume "c \<in> ancestors r b \<union> {b}"
+ hence "c = b \<or> c \<in> ancestors r b" by auto
+ hence "c \<in> ancestors r a"
+ proof
+ assume "c = b"
+ from assms[folded this]
+ show ?thesis by (auto simp:ancestors_def)
+ next
+ assume "c \<in> ancestors r b"
+ with assms show ?thesis by (auto simp:ancestors_def)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+lemma rootI:
+ assumes h: "\<And> x'. x' \<noteq> x \<Longrightarrow> x \<notin> subtree r' x'"
+ and "r' \<subseteq> r"
+ shows "root r' x"
+proof -
+ from acyclic_subset[OF acl assms(2)]
+ have acl': "acyclic r'" .
+ { fix x'
+ assume "x' \<in> ancestors r' x"
+ hence h1: "(x, x') \<in> r'^+" by (auto simp:ancestors_def)
+ have "x' \<noteq> x"
+ proof
+ assume eq_x: "x' = x"
+ from h1[unfolded this] and acl'
+ show False by (auto simp:acyclic_def)
+ qed
+ moreover from h1 have "x \<in> subtree r' x'" by (auto simp:subtree_def)
+ ultimately have False using h by auto
+ } thus ?thesis by (auto simp:root_def)
+qed
+
+lemma rpath_overlap_oneside: (* ddd *)
+ assumes "rpath r x xs1 x1"
+ and "rpath r x xs2 x2"
+ and "length xs1 \<le> length xs2"
+ obtains xs3 where "xs2 = xs1 @ xs3"
+proof(cases "xs1 = []")
+ case True
+ with that show ?thesis by auto
+next
+ case False
+ have "\<forall> i \<le> length xs1. take i xs1 = take i xs2"
+ proof -
+ { assume "\<not> (\<forall> i \<le> length xs1. take i xs1 = take i xs2)"
+ then obtain i where "i \<le> length xs1 \<and> take i xs1 \<noteq> take i xs2" by auto
+ from this(1) have "False"
+ proof(rule index_minimize)
+ fix j
+ assume h1: "j \<le> length xs1 \<and> take j xs1 \<noteq> take j xs2"
+ and h2: " \<forall>k<j. \<not> (k \<le> length xs1 \<and> take k xs1 \<noteq> take k xs2)"
+ -- {* @{text "j - 1"} is the branch point between @{text "xs1"} and @{text "xs2"} *}
+ let ?idx = "j - 1"
+ -- {* A number of inequalities concerning @{text "j - 1"} are derived first *}
+ have lt_i: "?idx < length xs1" using False h1
+ by (metis Suc_diff_1 le_neq_implies_less length_greater_0_conv lessI less_imp_diff_less)
+ have lt_i': "?idx < length xs2" using lt_i and assms(3) by auto
+ have lt_j: "?idx < j" using h1 by (cases j, auto)
+ -- {* From thesis inequalities, a number of equations concerning @{text "xs1"}
+ and @{text "xs2"} are derived *}
+ have eq_take: "take ?idx xs1 = take ?idx xs2"
+ using h2[rule_format, OF lt_j] and h1 by auto
+ have eq_xs1: " xs1 = take ?idx xs1 @ xs1 ! (?idx) # drop (Suc (?idx)) xs1"
+ using id_take_nth_drop[OF lt_i] .
+ have eq_xs2: "xs2 = take ?idx xs2 @ xs2 ! (?idx) # drop (Suc (?idx)) xs2"
+ using id_take_nth_drop[OF lt_i'] .
+ -- {* The branch point along the path is finally pinpointed *}
+ have neq_idx: "xs1!?idx \<noteq> xs2!?idx"
+ proof -
+ have "take j xs1 = take ?idx xs1 @ [xs1 ! ?idx]"
+ using eq_xs1 Suc_diff_1 lt_i lt_j take_Suc_conv_app_nth by fastforce
+ moreover have eq_tk2: "take j xs2 = take ?idx xs2 @ [xs2 ! ?idx]"
+ using Suc_diff_1 lt_i' lt_j take_Suc_conv_app_nth by fastforce
+ ultimately show ?thesis using eq_take h1 by auto
+ qed
+ show ?thesis
+ proof(cases " take (j - 1) xs1 = []")
+ case True
+ have "(x, xs1!?idx) \<in> r"
+ proof -
+ from eq_xs1[unfolded True, simplified, symmetric] assms(1)
+ have "rpath r x ( xs1 ! ?idx # drop (Suc ?idx) xs1) x1" by simp
+ from this[unfolded rpath_def]
+ show ?thesis by (auto simp:pred_of_def)
+ qed
+ moreover have "(x, xs2!?idx) \<in> r"
+ proof -
+ from eq_xs2[folded eq_take, unfolded True, simplified, symmetric] assms(2)
+ have "rpath r x ( xs2 ! ?idx # drop (Suc ?idx) xs2) x2" by simp
+ from this[unfolded rpath_def]
+ show ?thesis by (auto simp:pred_of_def)
+ qed
+ ultimately show ?thesis using neq_idx sgv[unfolded single_valued_def] by metis
+ next
+ case False
+ then obtain e es where eq_es: "take ?idx xs1 = es@[e]"
+ using rev_exhaust by blast
+ have "(e, xs1!?idx) \<in> r"
+ proof -
+ from eq_xs1[unfolded eq_es]
+ have "xs1 = es@[e, xs1!?idx]@drop (Suc ?idx) xs1" by simp
+ hence "(e, xs1!?idx) \<in> edges_on xs1" by (simp add:edges_on_def, metis)
+ with rpath_edges_on[OF assms(1)] edges_on_Cons_mono[of xs1 x]
+ show ?thesis by auto
+ qed moreover have "(e, xs2!?idx) \<in> r"
+ proof -
+ from eq_xs2[folded eq_take, unfolded eq_es]
+ have "xs2 = es@[e, xs2!?idx]@drop (Suc ?idx) xs2" by simp
+ hence "(e, xs2!?idx) \<in> edges_on xs2" by (simp add:edges_on_def, metis)
+ with rpath_edges_on[OF assms(2)] edges_on_Cons_mono[of xs2 x]
+ show ?thesis by auto
+ qed
+ ultimately show ?thesis
+ using sgv[unfolded single_valued_def] neq_idx by metis
+ qed
+ qed
+ } thus ?thesis by auto
+ qed
+ from this[rule_format, of "length xs1"]
+ have "take (length xs1) xs1 = take (length xs1) xs2" by simp
+ moreover have "xs2 = take (length xs1) xs2 @ drop (length xs1) xs2" by simp
+ ultimately have "xs2 = xs1 @ drop (length xs1) xs2" by auto
+ from that[OF this] show ?thesis .
+qed
+
+lemma rpath_overlap [consumes 2, cases pred:rpath]:
+ assumes "rpath r x xs1 x1"
+ and "rpath r x xs2 x2"
+ obtains (less_1) xs3 where "xs2 = xs1 @ xs3"
+ | (less_2) xs3 where "xs1 = xs2 @ xs3"
+proof -
+ have "length xs1 \<le> length xs2 \<or> length xs2 \<le> length xs1" by auto
+ with assms rpath_overlap_oneside that show ?thesis by metis
+qed
+
+text {*
+ As a corollary of @{thm "rpath_overlap_oneside"},
+ the following two lemmas gives one important property of relation tree,
+ i.e. there is at most one path between any two nodes.
+ Similar to the proof of @{thm rpath_overlap}, we starts with
+ the one side version first.
+*}
+
+lemma rpath_unique_oneside:
+ assumes "rpath r x xs1 y"
+ and "rpath r x xs2 y"
+ and "length xs1 \<le> length xs2"
+ shows "xs1 = xs2"
+proof -
+ from rpath_overlap_oneside[OF assms]
+ obtain xs3 where less_1: "xs2 = xs1 @ xs3" by blast
+ show ?thesis
+ proof(cases "xs3 = []")
+ case True
+ from less_1[unfolded this] show ?thesis by simp
+ next
+ case False
+ note FalseH = this
+ show ?thesis
+ proof(cases "xs1 = []")
+ case True
+ have "(x, x) \<in> r^+"
+ proof(rule rpath_plus)
+ from assms(1)[unfolded True]
+ have "y = x" by (cases rule:rpath_nilE, simp)
+ from assms(2)[unfolded this] show "rpath r x xs2 x" .
+ next
+ from less_1 and False show "xs2 \<noteq> []" by simp
+ qed
+ with acl show ?thesis by (unfold acyclic_def, auto)
+ next
+ case False
+ then obtain e es where eq_xs1: "xs1 = es@[e]" using rev_exhaust by auto
+ from assms(2)[unfolded less_1 this]
+ have "rpath r x (es @ [e] @ xs3) y" by simp
+ thus ?thesis
+ proof(cases rule:rpath_appendE)
+ case 1
+ from rpath_dest_eq [OF 1(1)[folded eq_xs1] assms(1)]
+ have "e = y" .
+ from rpath_plus [OF 1(2)[unfolded this] FalseH]
+ have "(y, y) \<in> r^+" .
+ with acl show ?thesis by (unfold acyclic_def, auto)
+ qed
+ qed
+ qed
+qed
+
+text {*
+ The following is the full version of path uniqueness.
+*}
+lemma rpath_unique:
+ assumes "rpath r x xs1 y"
+ and "rpath r x xs2 y"
+ shows "xs1 = xs2"
+proof(cases "length xs1 \<le> length xs2")
+ case True
+ from rpath_unique_oneside[OF assms this] show ?thesis .
+next
+ case False
+ hence "length xs2 \<le> length xs1" by simp
+ from rpath_unique_oneside[OF assms(2,1) this]
+ show ?thesis by simp
+qed
+
+text {*
+ The following lemma shows that the `independence` relation is symmetric.
+ It is an obvious auxiliary lemma which will be used later.
+*}
+lemma sym_indep: "indep r x y \<Longrightarrow> indep r y x"
+ by (unfold indep_def, auto)
+
+text {*
+ This is another `obvious` lemma about trees, which says trees rooted at
+ independent nodes are disjoint.
+*}
+lemma subtree_disjoint:
+ assumes "indep r x y"
+ shows "subtree r x \<inter> subtree r y = {}"
+proof -
+ { fix z x y xs1 xs2 xs3
+ assume ind: "indep r x y"
+ and rp1: "rpath r z xs1 x"
+ and rp2: "rpath r z xs2 y"
+ and h: "xs2 = xs1 @ xs3"
+ have False
+ proof(cases "xs1 = []")
+ case True
+ from rp1[unfolded this] have "x = z" by auto
+ from rp2[folded this] rpath_star ind[unfolded indep_def]
+ show ?thesis by metis
+ next
+ case False
+ then obtain e es where eq_xs1: "xs1 = es@[e]" using rev_exhaust by blast
+ from rp2[unfolded h this]
+ have "rpath r z (es @ [e] @ xs3) y" by simp
+ thus ?thesis
+ proof(cases rule:rpath_appendE)
+ case 1
+ have "e = x" using 1(1)[folded eq_xs1] rp1 rpath_dest_eq by metis
+ from rpath_star[OF 1(2)[unfolded this]] ind[unfolded indep_def]
+ show ?thesis by auto
+ qed
+ qed
+ } note my_rule = this
+ { fix z
+ assume h: "z \<in> subtree r x" "z \<in> subtree r y"
+ from h(1) have "(z, x) \<in> r^*" by (unfold subtree_def, auto)
+ then obtain xs1 where rp1: "rpath r z xs1 x" using star_rpath by metis
+ from h(2) have "(z, y) \<in> r^*" by (unfold subtree_def, auto)
+ then obtain xs2 where rp2: "rpath r z xs2 y" using star_rpath by metis
+ from rp1 rp2
+ have False
+ by (cases, insert my_rule[OF sym_indep[OF assms(1)] rp2 rp1]
+ my_rule[OF assms(1) rp1 rp2], auto)
+ } thus ?thesis by auto
+qed
+
+text {*
+ The following lemma @{text "subtree_del"} characterizes the change of sub-tree of
+ @{text "x"} with the removal of an inside edge @{text "(a, b)"}.
+ Note that, the case for the removal of an outside edge has already been dealt with
+ in lemma @{text "subtree_del_outside"}).
+
+ This lemma is underpinned by the following two `obvious` facts:
+ \begin{enumearte}
+ \item
+ In graph @{text "r"}, for an inside edge @{text "(a,b) \<in> edges_in r x"},
+ every node @{text "c"} in the sub-tree of @{text "a"} has a path
+ which goes first from @{text "c"} to @{text "a"}, then through edge @{text "(a, b)"}, and
+ finally reaches @{text "x"}. By the uniqueness of path in a tree,
+ all paths from sub-tree of @{text "a"} to @{text "x"} are such constructed, therefore
+ must go through @{text "(a, b)"}. The consequence is: with the removal of @{text "(a,b)"},
+ all such paths will be broken.
+
+ \item
+ On the other hand, all paths not originate from within the sub-tree of @{text "a"}
+ will not be affected by the removal of edge @{text "(a, b)"}.
+ The reason is simple: if the path is affected by the removal, it must
+ contain @{text "(a, b)"}, then it must originate from within the sub-tree of @{text "a"}.
+ \end{enumearte}
+*}
+
+lemma subtree_del_inside: (* ddd *)
+ assumes "(a,b) \<in> edges_in r x"
+ shows "subtree (r - {(a, b)}) x = (subtree r x) - subtree r a"
+proof -
+ from assms have asm: "b \<in> subtree r x" "(a, b) \<in> r" by (auto simp:edges_in_def)
+ -- {* The proof follows a common pattern to prove the equality of sets. *}
+ { -- {* The `left to right` direction.
+ *}
+ fix c
+ -- {* Assuming @{text "c"} is inside the sub-tree of @{text "x"} in the reduced graph *}
+ assume h: "c \<in> subtree (r - {(a, b)}) x"
+ -- {* We are going to show that @{text "c"} can not be in the sub-tree of @{text "a"} in
+ the original graph. *}
+ -- {* In other words, all nodes inside the sub-tree of @{text "a"} in the original
+ graph will be removed from the sub-tree of @{text "x"} in the reduced graph. *}
+ -- {* The reason, as analyzed before, is that all paths from within the
+ sub-tree of @{text "a"} are broken with the removal of edge @{text "(a,b)"}.
+ *}
+ have "c \<in> (subtree r x) - subtree r a"
+ proof -
+ let ?r' = "r - {(a, b)}" -- {* The reduced graph is abbreviated as @{text "?r'"} *}
+ from h have "(c, x) \<in> ?r'^*" by (auto simp:subtree_def)
+ -- {* Extract from the reduced graph the path @{text "xs"} from @{text "c"} to @{text "x"}. *}
+ then obtain xs where rp0: "rpath ?r' c xs x" by (rule star_rpath, auto)
+ -- {* It is easy to show @{text "xs"} is also a path in the original graph *}
+ hence rp1: "rpath r c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp0]
+ show "edges_on (c # xs) \<subseteq> r" by auto
+ qed
+ -- {* @{text "xs"} is used as the witness to show that @{text "c"}
+ in the sub-tree of @{text "x"} in the original graph. *}
+ hence "c \<in> subtree r x"
+ by (rule rpath_star[elim_format], auto simp:subtree_def)
+ -- {* The next step is to show that @{text "c"} can not be in the sub-tree of @{text "a"}
+ in the original graph. *}
+ -- {* We need to use the fact that all paths originate from within sub-tree of @{text "a"}
+ are broken. *}
+ moreover have "c \<notin> subtree r a"
+ proof
+ -- {* Proof by contradiction, suppose otherwise *}
+ assume otherwise: "c \<in> subtree r a"
+ -- {* Then there is a path in original graph leading from @{text "c"} to @{text "a"} *}
+ obtain xs1 where rp_c: "rpath r c xs1 a"
+ proof -
+ from otherwise have "(c, a) \<in> r^*" by (auto simp:subtree_def)
+ thus ?thesis by (rule star_rpath, auto intro!:that)
+ qed
+ -- {* Starting from this path, we are going to construct a fictional
+ path from @{text "c"} to @{text "x"}, which, as explained before,
+ is broken, so that contradiction can be derived. *}
+ -- {* First, there is a path from @{text "b"} to @{text "x"} *}
+ obtain ys where rp_b: "rpath r b ys x"
+ proof -
+ from asm have "(b, x) \<in> r^*" by (auto simp:subtree_def)
+ thus ?thesis by (rule star_rpath, auto intro!:that)
+ qed
+ -- {* The paths @{text "xs1"} and @{text "ys"} can be
+ tied together using @{text "(a,b)"} to form a path
+ from @{text "c"} to @{text "x"}: *}
+ have "rpath r c (xs1 @ b # ys) x"
+ proof -
+ from rstepI[OF asm(2) rp_b] have "rpath r a (b # ys) x" .
+ from rpath_appendI[OF rp_c this]
+ show ?thesis .
+ qed
+ -- {* By the uniqueness of path between two nodes of a tree, we have: *}
+ from rpath_unique[OF rp1 this] have eq_xs: "xs = xs1 @ b # ys" .
+ -- {* Contradiction can be derived from from this fictional path . *}
+ show False
+ proof -
+ -- {* It can be shown that @{term "(a,b)"} is on this fictional path. *}
+ have "(a, b) \<in> edges_on (c#xs)"
+ proof(cases "xs1 = []")
+ case True
+ from rp_c[unfolded this] have "rpath r c [] a" .
+ hence eq_c: "c = a" by (rule rpath_nilE, simp)
+ hence "c#xs = a#xs" by simp
+ from this and eq_xs have "c#xs = a # xs1 @ b # ys" by simp
+ from this[unfolded True] have "c#xs = []@[a,b]@ys" by simp
+ thus ?thesis by (auto simp:edges_on_def)
+ next
+ case False
+ from rpath_nnl_lastE[OF rp_c this]
+ obtain xs' where "xs1 = xs'@[a]" by auto
+ from eq_xs[unfolded this] have "c#xs = (c#xs')@[a,b]@ys" by simp
+ thus ?thesis by (unfold edges_on_def, blast)
+ qed
+ -- {* It can also be shown that @{term "(a,b)"} is not on this fictional path. *}
+ moreover have "(a, b) \<notin> edges_on (c#xs)"
+ using rpath_edges_on[OF rp0] by auto
+ -- {* Contradiction is thus derived. *}
+ ultimately show False by auto
+ qed
+ qed
+ ultimately show ?thesis by auto
+ qed
+ } moreover {
+ -- {* The `right to left` direction.
+ *}
+ fix c
+ -- {* Assuming that @{text "c"} is in the sub-tree of @{text "x"}, but
+ outside of the sub-tree of @{text "a"} in the original graph, *}
+ assume h: "c \<in> (subtree r x) - subtree r a"
+ -- {* we need to show that in the reduced graph, @{text "c"} is still in
+ the sub-tree of @{text "x"}. *}
+ have "c \<in> subtree (r - {(a, b)}) x"
+ proof -
+ -- {* The proof goes by showing that the path from @{text "c"} to @{text "x"}
+ in the original graph is not affected by the removal of @{text "(a,b)"}.
+ *}
+ from h have "(c, x) \<in> r^*" by (unfold subtree_def, auto)
+ -- {* Extract the path @{text "xs"} from @{text "c"} to @{text "x"} in the original graph. *}
+ from star_rpath[OF this] obtain xs where rp: "rpath r c xs x" by auto
+ -- {* Show that it is also a path in the reduced graph. *}
+ hence "rpath (r - {(a, b)}) c xs x"
+ -- {* The proof goes by using rule @{thm rpath_transfer} *}
+ proof(rule rpath_transfer)
+ -- {* We need to show all edges on the path are still in the reduced graph. *}
+ show "edges_on (c # xs) \<subseteq> r - {(a, b)}"
+ proof -
+ -- {* It is easy to show that all the edges are in the original graph. *}
+ from rpath_edges_on [OF rp] have " edges_on (c # xs) \<subseteq> r" .
+ -- {* The essential part is to show that @{text "(a, b)"} is not on the path. *}
+ moreover have "(a,b) \<notin> edges_on (c#xs)"
+ proof
+ -- {* Proof by contradiction, suppose otherwise: *}
+ assume otherwise: "(a, b) \<in> edges_on (c#xs)"
+ -- {* Then @{text "(a, b)"} is in the middle of the path.
+ with @{text "l1"} and @{text "l2"} be the nodes in
+ the front and rear respectively. *}
+ then obtain l1 l2 where eq_xs:
+ "c#xs = l1 @ [a, b] @ l2" by (unfold edges_on_def, blast)
+ -- {* From this, it can be shown that @{text "c"} is
+ in the sub-tree of @{text "a"} *}
+ have "c \<in> subtree r a"
+ proof(cases "l1 = []")
+ case True
+ -- {* If @{text "l1"} is null, it can be derived that @{text "c = a"}. *}
+ with eq_xs have "c = a" by auto
+ -- {* So, @{text "c"} is obviously in the sub-tree of @{text "a"}. *}
+ thus ?thesis by (unfold subtree_def, auto)
+ next
+ case False
+ -- {* When @{text "l1"} is not null, it must have a tail @{text "es"}: *}
+ then obtain e es where "l1 = e#es" by (cases l1, auto)
+ -- {* The relation of this tail with @{text "xs"} is derived: *}
+ with eq_xs have "xs = es@[a,b]@l2" by auto
+ -- {* From this, a path from @{text "c"} to @{text "a"} is made visible: *}
+ from rp[unfolded this] have "rpath r c (es @ [a] @ (b#l2)) x" by simp
+ thus ?thesis
+ proof(cases rule:rpath_appendE)
+ -- {* The path from @{text "c"} to @{text "a"} is extraced
+ using @{thm "rpath_appendE"}: *}
+ case 1
+ from rpath_star[OF this(1)]
+ -- {* The extracted path servers as a witness that @{text "c"} is
+ in the sub-tree of @{text "a"}: *}
+ show ?thesis by (simp add:subtree_def)
+ qed
+ qed with h show False by auto
+ qed ultimately show ?thesis by auto
+ qed
+ qed
+ -- {* From , it is shown that @{text "c"} is in the sub-tree of @{text "x"}
+ inthe reduced graph. *}
+ from rpath_star[OF this] show ?thesis by (auto simp:subtree_def)
+ qed
+ }
+ -- {* The equality of sets is derived from the two directions just proved. *}
+ ultimately show ?thesis by auto
+qed
+
+lemma set_del_rootI:
+ assumes "r1 \<subseteq> r"
+ and "a \<in> Domain r1"
+ shows "root (r - r1) a"
+proof -
+ let ?r = "r - r1"
+ { fix a'
+ assume neq: "a' \<noteq> a"
+ have "a \<notin> subtree ?r a'"
+ proof
+ assume "a \<in> subtree ?r a'"
+ hence "(a, a') \<in> ?r^*" by (auto simp:subtree_def)
+ from star_rpath[OF this] obtain xs
+ where rp: "rpath ?r a xs a'" by auto
+ from rpathE[OF this] and neq
+ obtain z zs where h: "(a, z) \<in> ?r" "rpath ?r z zs a'" "xs = z#zs" by auto
+ from assms(2) obtain z' where z'_in: "(a, z') \<in> r1" by (auto simp:DomainE)
+ with assms(1) have "(a, z') \<in> r" by auto
+ moreover from h(1) have "(a, z) \<in> r" by simp
+ ultimately have "z' = z" using sgv by (auto simp:single_valued_def)
+ from z'_in[unfolded this] and h(1) show False by auto
+ qed
+ } thus ?thesis by (intro rootI, auto)
+qed
+
+lemma edge_del_no_rootI:
+ assumes "(a, b) \<in> r"
+ shows "root (r - {(a, b)}) a"
+ by (rule set_del_rootI, insert assms, auto)
+
+lemma ancestors_children_unique:
+ assumes "z1 \<in> ancestors r x \<inter> children r y"
+ and "z2 \<in> ancestors r x \<inter> children r y"
+ shows "z1 = z2"
+proof -
+ from assms have h:
+ "(x, z1) \<in> r^+" "(z1, y) \<in> r"
+ "(x, z2) \<in> r^+" "(z2, y) \<in> r"
+ by (auto simp:ancestors_def children_def)
+
+ -- {* From this, a path containing @{text "z1"} is obtained. *}
+ from plus_rpath[OF h(1)] obtain xs1
+ where h1: "rpath r x xs1 z1" "xs1 \<noteq> []" by auto
+ from rpath_nnl_lastE[OF this] obtain xs1' where eq_xs1: "xs1 = xs1' @ [z1]"
+ by auto
+ from h(2) have h2: "rpath r z1 [y] y" by auto
+ from rpath_appendI[OF h1(1) h2, unfolded eq_xs1]
+ have rp1: "rpath r x (xs1' @ [z1, y]) y" by simp
+
+ -- {* Then, another path containing @{text "z2"} is obtained. *}
+ from plus_rpath[OF h(3)] obtain xs2
+ where h3: "rpath r x xs2 z2" "xs2 \<noteq> []" by auto
+ from rpath_nnl_lastE[OF this] obtain xs2' where eq_xs2: "xs2 = xs2' @ [z2]"
+ by auto
+ from h(4) have h4: "rpath r z2 [y] y" by auto
+ from rpath_appendI[OF h3(1) h4, unfolded eq_xs2]
+ have "rpath r x (xs2' @ [z2, y]) y" by simp
+
+ -- {* Finally @{text "z1 = z2"} is proved by uniqueness of path. *}
+ from rpath_unique[OF rp1 this]
+ have "xs1' @ [z1, y] = xs2' @ [z2, y]" .
+ thus ?thesis by auto
+qed
+
+lemma ancestors_childrenE:
+ assumes "y \<in> ancestors r x"
+ obtains "x \<in> children r y"
+ | z where "z \<in> ancestors r x \<inter> children r y"
+proof -
+ from assms(1) have "(x, y) \<in> r^+" by (auto simp:ancestors_def)
+ from tranclD2[OF this] obtain z where
+ h: "(x, z) \<in> r\<^sup>*" "(z, y) \<in> r" by auto
+ from h(1)
+ show ?thesis
+ proof(cases rule:rtranclE)
+ case base
+ from h(2)[folded this] have "x \<in> children r y"
+ by (auto simp:children_def)
+ thus ?thesis by (intro that, auto)
+ next
+ case (step u)
+ hence "z \<in> ancestors r x" by (auto simp:ancestors_def)
+ moreover from h(2) have "z \<in> children r y"
+ by (auto simp:children_def)
+ ultimately show ?thesis by (intro that, auto)
+ qed
+qed
+
+
+end (* of rtree *)
+
+lemma subtree_children:
+ "subtree r x = {x} \<union> (\<Union> (subtree r ` (children r x)))" (is "?L = ?R")
+proof -
+ { fix z
+ assume "z \<in> ?L"
+ hence "z \<in> ?R"
+ proof(cases rule:subtreeE[consumes 1])
+ case 2
+ hence "(z, x) \<in> r^+" by (auto simp:ancestors_def)
+ thus ?thesis
+ proof(rule tranclE)
+ assume "(z, x) \<in> r"
+ hence "z \<in> children r x" by (unfold children_def, auto)
+ moreover have "z \<in> subtree r z" by (auto simp:subtree_def)
+ ultimately show ?thesis by auto
+ next
+ fix c
+ assume h: "(z, c) \<in> r\<^sup>+" "(c, x) \<in> r"
+ hence "c \<in> children r x" by (auto simp:children_def)
+ moreover from h have "z \<in> subtree r c" by (auto simp:subtree_def)
+ ultimately show ?thesis by auto
+ qed
+ qed auto
+ } moreover {
+ fix z
+ assume h: "z \<in> ?R"
+ have "x \<in> subtree r x" by (auto simp:subtree_def)
+ moreover {
+ assume "z \<in> \<Union>(subtree r ` children r x)"
+ then obtain y where "(y, x) \<in> r" "(z, y) \<in> r^*"
+ by (auto simp:subtree_def children_def)
+ hence "(z, x) \<in> r^*" by auto
+ hence "z \<in> ?L" by (auto simp:subtree_def)
+ } ultimately have "z \<in> ?L" using h by auto
+ } ultimately show ?thesis by auto
+qed
+
+context fsubtree
+begin
+
+lemma finite_subtree:
+ shows "finite (subtree r x)"
+proof(induct rule:wf_induct[OF wf])
+ case (1 x)
+ have "finite (\<Union>(subtree r ` children r x))"
+ proof(rule finite_Union)
+ show "finite (subtree r ` children r x)"
+ proof(cases "children r x = {}")
+ case True
+ thus ?thesis by auto
+ next
+ case False
+ hence "x \<in> Range r" by (auto simp:children_def)
+ from fb[rule_format, OF this]
+ have "finite (children r x)" .
+ thus ?thesis by (rule finite_imageI)
+ qed
+ next
+ fix M
+ assume "M \<in> subtree r ` children r x"
+ then obtain y where h: "y \<in> children r x" "M = subtree r y" by auto
+ hence "(y, x) \<in> r" by (auto simp:children_def)
+ from 1[rule_format, OF this, folded h(2)]
+ show "finite M" .
+ qed
+ thus ?case
+ by (unfold subtree_children finite_Un, auto)
+qed
+
+end
+
+definition "pairself f = (\<lambda>(a, b). (f a, f b))"
+
+definition "rel_map f r = (pairself f ` r)"
+
+lemma rel_mapE:
+ assumes "(a, b) \<in> rel_map f r"
+ obtains c d
+ where "(c, d) \<in> r" "(a, b) = (f c, f d)"
+ using assms
+ by (unfold rel_map_def pairself_def, auto)
+
+lemma rel_mapI:
+ assumes "(a, b) \<in> r"
+ and "c = f a"
+ and "d = f b"
+ shows "(c, d) \<in> rel_map f r"
+ using assms
+ by (unfold rel_map_def pairself_def, auto)
+
+lemma map_appendE:
+ assumes "map f zs = xs @ ys"
+ obtains xs' ys'
+ where "zs = xs' @ ys'" "xs = map f xs'" "ys = map f ys'"
+proof -
+ have "\<exists> xs' ys'. zs = xs' @ ys' \<and> xs = map f xs' \<and> ys = map f ys'"
+ using assms
+ proof(induct xs arbitrary:zs ys)
+ case (Nil zs ys)
+ thus ?case by auto
+ next
+ case (Cons x xs zs ys)
+ note h = this
+ show ?case
+ proof(cases zs)
+ case (Cons e es)
+ with h have eq_x: "map f es = xs @ ys" "x = f e" by auto
+ from h(1)[OF this(1)]
+ obtain xs' ys' where "es = xs' @ ys'" "xs = map f xs'" "ys = map f ys'"
+ by blast
+ with Cons eq_x
+ have "zs = (e#xs') @ ys' \<and> x # xs = map f (e#xs') \<and> ys = map f ys'" by auto
+ thus ?thesis by metis
+ qed (insert h, auto)
+ qed
+ thus ?thesis by (auto intro!:that)
+qed
+
+lemma rel_map_mono:
+ assumes "r1 \<subseteq> r2"
+ shows "rel_map f r1 \<subseteq> rel_map f r2"
+ using assms
+ by (auto simp:rel_map_def pairself_def)
+
+lemma rel_map_compose [simp]:
+ shows "rel_map f1 (rel_map f2 r) = rel_map (f1 o f2) r"
+ by (auto simp:rel_map_def pairself_def)
+
+lemma edges_on_map: "edges_on (map f xs) = rel_map f (edges_on xs)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> edges_on (map f xs)"
+ then obtain l1 l2 where eq_map: "map f xs = l1 @ [a, b] @ l2"
+ by (unfold edges_on_def, auto)
+ hence "(a, b) \<in> rel_map f (edges_on xs)"
+ by (auto elim!:map_appendE intro!:rel_mapI simp:edges_on_def)
+ } moreover {
+ fix a b
+ assume "(a, b) \<in> rel_map f (edges_on xs)"
+ then obtain c d where
+ h: "(c, d) \<in> edges_on xs" "(a, b) = (f c, f d)"
+ by (elim rel_mapE, auto)
+ then obtain l1 l2 where
+ eq_xs: "xs = l1 @ [c, d] @ l2"
+ by (auto simp:edges_on_def)
+ hence eq_map: "map f xs = map f l1 @ [f c, f d] @ map f l2" by auto
+ have "(a, b) \<in> edges_on (map f xs)"
+ proof -
+ from h(2) have "[f c, f d] = [a, b]" by simp
+ from eq_map[unfolded this] show ?thesis by (auto simp:edges_on_def)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+lemma image_id:
+ assumes "\<And> x. x \<in> A \<Longrightarrow> f x = x"
+ shows "f ` A = A"
+ using assms by (auto simp:image_def)
+
+lemma rel_map_inv_id:
+ assumes "inj_on f ((Domain r) \<union> (Range r))"
+ shows "(rel_map (inv_into ((Domain r) \<union> (Range r)) f \<circ> f) r) = r"
+proof -
+ let ?f = "(inv_into (Domain r \<union> Range r) f \<circ> f)"
+ {
+ fix a b
+ assume h0: "(a, b) \<in> r"
+ have "pairself ?f (a, b) = (a, b)"
+ proof -
+ from assms h0 have "?f a = a" by (auto intro:inv_into_f_f)
+ moreover have "?f b = b"
+ by (insert h0, simp, intro inv_into_f_f[OF assms], auto intro!:RangeI)
+ ultimately show ?thesis by (auto simp:pairself_def)
+ qed
+ } thus ?thesis by (unfold rel_map_def, intro image_id, case_tac x, auto)
+qed
+
+lemma rel_map_acyclic:
+ assumes "acyclic r"
+ and "inj_on f ((Domain r) \<union> (Range r))"
+ shows "acyclic (rel_map f r)"
+proof -
+ let ?D = "Domain r \<union> Range r"
+ { fix a
+ assume "(a, a) \<in> (rel_map f r)^+"
+ from plus_rpath[OF this]
+ obtain xs where rp: "rpath (rel_map f r) a xs a" "xs \<noteq> []" by auto
+ from rpath_nnl_lastE[OF this] obtain xs' where eq_xs: "xs = xs'@[a]" by auto
+ from rpath_edges_on[OF rp(1)]
+ have h: "edges_on (a # xs) \<subseteq> rel_map f r" .
+ from edges_on_map[of "inv_into ?D f" "a#xs"]
+ have "edges_on (map (inv_into ?D f) (a # xs)) = rel_map (inv_into ?D f) (edges_on (a # xs))" .
+ with rel_map_mono[OF h, of "inv_into ?D f"]
+ have "edges_on (map (inv_into ?D f) (a # xs)) \<subseteq> rel_map ((inv_into ?D f) o f) r" by simp
+ from this[unfolded eq_xs]
+ have subr: "edges_on (map (inv_into ?D f) (a # xs' @ [a])) \<subseteq> rel_map (inv_into ?D f \<circ> f) r" .
+ have "(map (inv_into ?D f) (a # xs' @ [a])) = (inv_into ?D f a) # map (inv_into ?D f) xs' @ [inv_into ?D f a]"
+ by simp
+ from edges_on_rpathI[OF subr[unfolded this]]
+ have "rpath (rel_map (inv_into ?D f \<circ> f) r)
+ (inv_into ?D f a) (map (inv_into ?D f) xs' @ [inv_into ?D f a]) (inv_into ?D f a)" .
+ hence "(inv_into ?D f a, inv_into ?D f a) \<in> (rel_map (inv_into ?D f \<circ> f) r)^+"
+ by (rule rpath_plus, simp)
+ moreover have "(rel_map (inv_into ?D f \<circ> f) r) = r" by (rule rel_map_inv_id[OF assms(2)])
+ moreover note assms(1)
+ ultimately have False by (unfold acyclic_def, auto)
+ } thus ?thesis by (auto simp:acyclic_def)
+qed
+
+lemma relpow_mult:
+ "((r::'a rel) ^^ m) ^^ n = r ^^ (m*n)"
+proof(induct n arbitrary:m)
+ case (Suc k m)
+ thus ?case
+ proof -
+ have h: "(m * k + m) = (m + m * k)" by auto
+ show ?thesis
+ apply (simp add:Suc relpow_add[symmetric])
+ by (unfold h, simp)
+ qed
+qed simp
+
+lemma compose_relpow_2:
+ assumes "r1 \<subseteq> r"
+ and "r2 \<subseteq> r"
+ shows "r1 O r2 \<subseteq> r ^^ (2::nat)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> r1 O r2"
+ then obtain e where "(a, e) \<in> r1" "(e, b) \<in> r2"
+ by auto
+ with assms have "(a, e) \<in> r" "(e, b) \<in> r" by auto
+ hence "(a, b) \<in> r ^^ (Suc (Suc 0))" by auto
+ } thus ?thesis by (auto simp:numeral_2_eq_2)
+qed
+
+lemma acyclic_compose:
+ assumes "acyclic r"
+ and "r1 \<subseteq> r"
+ and "r2 \<subseteq> r"
+ shows "acyclic (r1 O r2)"
+proof -
+ { fix a
+ assume "(a, a) \<in> (r1 O r2)^+"
+ from trancl_mono[OF this compose_relpow_2[OF assms(2, 3)]]
+ have "(a, a) \<in> (r ^^ 2) ^+" .
+ from trancl_power[THEN iffD1, OF this]
+ obtain n where h: "(a, a) \<in> (r ^^ 2) ^^ n" "n > 0" by blast
+ from this(1)[unfolded relpow_mult] have h2: "(a, a) \<in> r ^^ (2 * n)" .
+ have "(a, a) \<in> r^+"
+ proof(cases rule:trancl_power[THEN iffD2])
+ from h(2) h2 show "\<exists>n>0. (a, a) \<in> r ^^ n"
+ by (rule_tac x = "2*n" in exI, auto)
+ qed
+ with assms have "False" by (auto simp:acyclic_def)
+ } thus ?thesis by (auto simp:acyclic_def)
+qed
+
+lemma children_compose_unfold:
+ "children (r1 O r2) x = \<Union> (children r1 ` (children r2 x))"
+ by (auto simp:children_def)
+
+lemma fbranch_compose:
+ assumes "fbranch r1"
+ and "fbranch r2"
+ shows "fbranch (r1 O r2)"
+proof -
+ { fix x
+ assume "x\<in>Range (r1 O r2)"
+ then obtain y z where h: "(y, z) \<in> r1" "(z, x) \<in> r2" by auto
+ have "finite (children (r1 O r2) x)"
+ proof(unfold children_compose_unfold, rule finite_Union)
+ show "finite (children r1 ` children r2 x)"
+ proof(rule finite_imageI)
+ from h(2) have "x \<in> Range r2" by auto
+ from assms(2)[unfolded fbranch_def, rule_format, OF this]
+ show "finite (children r2 x)" .
+ qed
+ next
+ fix M
+ assume "M \<in> children r1 ` children r2 x"
+ then obtain y where h1: "y \<in> children r2 x" "M = children r1 y" by auto
+ show "finite M"
+ proof(cases "children r1 y = {}")
+ case True
+ with h1(2) show ?thesis by auto
+ next
+ case False
+ hence "y \<in> Range r1" by (unfold children_def, auto)
+ from assms(1)[unfolded fbranch_def, rule_format, OF this, folded h1(2)]
+ show ?thesis .
+ qed
+ qed
+ } thus ?thesis by (unfold fbranch_def, auto)
+qed
+
+lemma finite_fbranchI:
+ assumes "finite r"
+ shows "fbranch r"
+proof -
+ { fix x
+ assume "x \<in>Range r"
+ have "finite (children r x)"
+ proof -
+ have "{y. (y, x) \<in> r} \<subseteq> Domain r" by (auto)
+ from rev_finite_subset[OF finite_Domain[OF assms] this]
+ have "finite {y. (y, x) \<in> r}" .
+ thus ?thesis by (unfold children_def, simp)
+ qed
+ } thus ?thesis by (auto simp:fbranch_def)
+qed
+
+lemma subset_fbranchI:
+ assumes "fbranch r1"
+ and "r2 \<subseteq> r1"
+ shows "fbranch r2"
+proof -
+ { fix x
+ assume "x \<in>Range r2"
+ with assms(2) have "x \<in> Range r1" by auto
+ from assms(1)[unfolded fbranch_def, rule_format, OF this]
+ have "finite (children r1 x)" .
+ hence "finite (children r2 x)"
+ proof(rule rev_finite_subset)
+ from assms(2)
+ show "children r2 x \<subseteq> children r1 x" by (auto simp:children_def)
+ qed
+ } thus ?thesis by (auto simp:fbranch_def)
+qed
+
+lemma children_subtree:
+ shows "children r x \<subseteq> subtree r x"
+ by (auto simp:children_def subtree_def)
+
+lemma children_union_kept:
+ assumes "x \<notin> Range r'"
+ shows "children (r \<union> r') x = children r x"
+ using assms
+ by (auto simp:children_def)
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RTree.thy~ Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,1748 @@
+theory RTree
+imports "~~/src/HOL/Library/Transitive_Closure_Table" Max
+begin
+
+section {* A theory of relational trees *}
+
+inductive_cases path_nilE [elim!]: "rtrancl_path r x [] y"
+inductive_cases path_consE [elim!]: "rtrancl_path r x (z#zs) y"
+
+subsection {* Definitions *}
+
+text {*
+ In this theory, we are going to give a notion of of `Relational Graph` and
+ its derived notion `Relational Tree`. Given a binary relation @{text "r"},
+ the `Relational Graph of @{text "r"}` is the graph, the edges of which
+ are those in @{text "r"}. In this way, any binary relation can be viewed
+ as a `Relational Graph`. Note, this notion of graph includes infinite graphs.
+
+ A `Relation Graph` @{text "r"} is said to be a `Relational Tree` if it is both
+ {\em single valued} and {\em acyclic}.
+*}
+
+text {*
+ The following @{text "sgv"} specifies that relation @{text "r"} is {\em single valued}.
+*}
+locale sgv =
+ fixes r
+ assumes sgv: "single_valued r"
+
+text {*
+ The following @{text "rtree"} specifies that @{text "r"} is a
+ {\em Relational Tree}.
+*}
+locale rtree = sgv +
+ assumes acl: "acyclic r"
+
+text {*
+ The following two auxiliary functions @{text "rel_of"} and @{text "pred_of"}
+ transfer between the predicate and set representation of binary relations.
+*}
+
+definition "rel_of r = {(x, y) | x y. r x y}"
+
+definition "pred_of r = (\<lambda> x y. (x, y) \<in> r)"
+
+text {*
+ To reason about {\em Relational Graph}, a notion of path is
+ needed, which is given by the following @{text "rpath"} (short
+ for `relational path`).
+ The path @{text "xs"} in proposition @{text "rpath r x xs y"} is
+ a path leading from @{text "x"} to @{text "y"}, which serves as a
+ witness of the fact @{text "(x, y) \<in> r^*"}.
+
+ @{text "rpath"}
+ is simply a wrapper of the @{text "rtrancl_path"} defined in the imported
+ theory @{text "Transitive_Closure_Table"}, which defines
+ a notion of path for the predicate form of binary relations.
+*}
+definition "rpath r x xs y = rtrancl_path (pred_of r) x xs y"
+
+text {*
+ Given a path @{text "ps"}, @{text "edges_on ps"} is the
+ set of edges along the path, which is defined as follows:
+*}
+
+definition "edges_on ps = {(a,b) | a b. \<exists> xs ys. ps = xs@[a,b]@ys}"
+
+text {*
+ The following @{text "indep"} defines a notion of independence.
+ Two nodes @{text "x"} and @{text "y"} are said to be independent
+ (expressed as @{text "indep x y"}), if neither one is reachable
+ from the other in relational graph @{text "r"}.
+*}
+definition "indep r x y = (((x, y) \<notin> r^*) \<and> ((y, x) \<notin> r^*))"
+
+text {*
+ In relational tree @{text "r"}, the sub tree of node @{text "x"} is written
+ @{text "subtree r x"}, which is defined to be the set of nodes (including itself)
+ which can reach @{text "x"} by following some path in @{text "r"}:
+*}
+
+definition "subtree r x = {y . (y, x) \<in> r^*}"
+
+definition "ancestors r x = {y. (x, y) \<in> r^+}"
+
+definition "root r x = (ancestors r x = {})"
+
+text {*
+ The following @{text "edge_in r x"} is the set of edges
+ contained in the sub-tree of @{text "x"}, with @{text "r"} as the underlying graph.
+*}
+
+definition "edges_in r x = {(a, b) | a b. (a, b) \<in> r \<and> b \<in> subtree r x}"
+
+text {*
+ The following lemma @{text "edges_in_meaning"} shows the intuitive meaning
+ of `an edge @{text "(a, b)"} is in the sub-tree of @{text "x"}`,
+ i.e., both @{text "a"} and @{text "b"} are in the sub-tree.
+*}
+lemma edges_in_meaning:
+ "edges_in r x = {(a, b) | a b. (a, b) \<in> r \<and> a \<in> subtree r x \<and> b \<in> subtree r x}"
+proof -
+ { fix a b
+ assume h: "(a, b) \<in> r" "b \<in> subtree r x"
+ moreover have "a \<in> subtree r x"
+ proof -
+ from h(2)[unfolded subtree_def] have "(b, x) \<in> r^*" by simp
+ with h(1) have "(a, x) \<in> r^*" by auto
+ thus ?thesis by (auto simp:subtree_def)
+ qed
+ ultimately have "((a, b) \<in> r \<and> a \<in> subtree r x \<and> b \<in> subtree r x)"
+ by (auto)
+ } thus ?thesis by (auto simp:edges_in_def)
+qed
+
+text {*
+ The following lemma shows the meaning of @{term "edges_in"} from the other side,
+ which says: for the edge @{text "(a,b)"} to be outside of the sub-tree of @{text "x"},
+ it is sufficient to show that @{text "b"} is.
+*}
+lemma edges_in_refutation:
+ assumes "b \<notin> subtree r x"
+ shows "(a, b) \<notin> edges_in r x"
+ using assms by (unfold edges_in_def subtree_def, auto)
+
+definition "children r x = {y. (y, x) \<in> r}"
+
+locale fbranch =
+ fixes r
+ assumes fb: "\<forall> x \<in> Range r . finite (children r x)"
+begin
+
+lemma finite_children: "finite (children r x)"
+proof(cases "children r x = {}")
+ case True
+ thus ?thesis by auto
+next
+ case False
+ then obtain y where "(y, x) \<in> r" by (auto simp:children_def)
+ hence "x \<in> Range r" by auto
+ from fb[rule_format, OF this]
+ show ?thesis .
+qed
+
+end
+
+locale fsubtree = fbranch +
+ assumes wf: "wf r"
+
+(* ccc *)
+
+subsection {* Auxiliary lemmas *}
+
+lemma index_minimize:
+ assumes "P (i::nat)"
+ obtains j where "P j" and "\<forall> k < j. \<not> P k"
+proof -
+ have "\<exists> j. P j \<and> (\<forall> k < j. \<not> P k)"
+ using assms
+ proof(induct i rule:less_induct)
+ case (less t)
+ show ?case
+ proof(cases "\<forall> j < t. \<not> P j")
+ case True
+ with less (2) show ?thesis by blast
+ next
+ case False
+ then obtain j where "j < t" "P j" by auto
+ from less(1)[OF this]
+ show ?thesis .
+ qed
+ qed
+ with that show ?thesis by metis
+qed
+
+subsection {* Properties of Relational Graphs and Relational Trees *}
+
+subsubsection {* Properties of @{text "rel_of"} and @{text "pred_of"} *}
+
+text {* The following lemmas establish bijectivity of the two functions *}
+
+lemma pred_rel_eq: "pred_of (rel_of r) = r" by (auto simp:rel_of_def pred_of_def)
+
+lemma rel_pred_eq: "rel_of (pred_of r) = r" by (auto simp:rel_of_def pred_of_def)
+
+lemma rel_of_star: "rel_of (r^**) = (rel_of r)^*"
+ by (unfold rel_of_def rtranclp_rtrancl_eq, auto)
+
+lemma pred_of_star: "pred_of (r^*) = (pred_of r)^**"
+proof -
+ { fix x y
+ have "pred_of (r^*) x y = (pred_of r)^** x y"
+ by (unfold pred_of_def rtranclp_rtrancl_eq, auto)
+ } thus ?thesis by auto
+qed
+
+lemma star_2_pstar: "(x, y) \<in> r^* = (pred_of (r^*)) x y"
+ by (simp add: pred_of_def)
+
+subsubsection {* Properties of @{text "rpath"} *}
+
+text {* Induction rule for @{text "rpath"}: *}
+
+lemma rpath_induct [consumes 1, case_names rbase rstep, induct pred: rpath]:
+ assumes "rpath r x1 x2 x3"
+ and "\<And>x. P x [] x"
+ and "\<And>x y ys z. (x, y) \<in> r \<Longrightarrow> rpath r y ys z \<Longrightarrow> P y ys z \<Longrightarrow> P x (y # ys) z"
+ shows "P x1 x2 x3"
+ using assms[unfolded rpath_def]
+ by (induct, auto simp:pred_of_def rpath_def)
+
+lemma rpathE:
+ assumes "rpath r x xs y"
+ obtains (base) "y = x" "xs = []"
+ | (step) z zs where "(x, z) \<in> r" "rpath r z zs y" "xs = z#zs"
+ using assms
+ by (induct, auto)
+
+text {* Introduction rule for empty path *}
+lemma rbaseI [intro!]:
+ assumes "x = y"
+ shows "rpath r x [] y"
+ by (unfold rpath_def assms,
+ rule Transitive_Closure_Table.rtrancl_path.base)
+
+text {* Introduction rule for non-empty path *}
+lemma rstepI [intro!]:
+ assumes "(x, y) \<in> r"
+ and "rpath r y ys z"
+ shows "rpath r x (y#ys) z"
+proof(unfold rpath_def, rule Transitive_Closure_Table.rtrancl_path.step)
+ from assms(1) show "pred_of r x y" by (auto simp:pred_of_def)
+next
+ from assms(2) show "rtrancl_path (pred_of r) y ys z"
+ by (auto simp:pred_of_def rpath_def)
+qed
+
+text {* Introduction rule for @{text "@"}-path *}
+lemma rpath_appendI [intro]:
+ assumes "rpath r x xs a" and "rpath r a ys y"
+ shows "rpath r x (xs @ ys) y"
+ using assms
+ by (unfold rpath_def, auto intro:rtrancl_path_trans)
+
+text {* Elimination rule for empty path *}
+
+lemma rpath_cases [cases pred:rpath]:
+ assumes "rpath r a1 a2 a3"
+ obtains (rbase) "a1 = a3" and "a2 = []"
+ | (rstep) y :: "'a" and ys :: "'a list"
+ where "(a1, y) \<in> r" and "a2 = y # ys" and "rpath r y ys a3"
+ using assms [unfolded rpath_def]
+ by (cases, auto simp:rpath_def pred_of_def)
+
+lemma rpath_nilE [elim!, cases pred:rpath]:
+ assumes "rpath r x [] y"
+ obtains "y = x"
+ using assms[unfolded rpath_def] by auto
+
+-- {* This is a auxiliary lemmas used only in the proof of @{text "rpath_nnl_lastE"} *}
+lemma rpath_nnl_last:
+ assumes "rtrancl_path r x xs y"
+ and "xs \<noteq> []"
+ obtains xs' where "xs = xs'@[y]"
+proof -
+ from append_butlast_last_id[OF `xs \<noteq> []`, symmetric]
+ obtain xs' y' where eq_xs: "xs = (xs' @ y' # [])" by simp
+ with assms(1)
+ have "rtrancl_path r x ... y" by simp
+ hence "y = y'" by (rule rtrancl_path_appendE, auto)
+ with eq_xs have "xs = xs'@[y]" by simp
+ from that[OF this] show ?thesis .
+qed
+
+text {*
+ Elimination rule for non-empty paths constructed with @{text "#"}.
+*}
+
+lemma rpath_ConsE [elim!, cases pred:rpath]:
+ assumes "rpath r x (y # ys) x2"
+ obtains (rstep) "(x, y) \<in> r" and "rpath r y ys x2"
+ using assms[unfolded rpath_def]
+ by (cases, auto simp:rpath_def pred_of_def)
+
+text {*
+ Elimination rule for non-empty path, where the destination node
+ @{text "y"} is shown to be at the end of the path.
+*}
+lemma rpath_nnl_lastE:
+ assumes "rpath r x xs y"
+ and "xs \<noteq> []"
+ obtains xs' where "xs = xs'@[y]"
+ using assms[unfolded rpath_def]
+ by (rule rpath_nnl_last, auto)
+
+text {* Other elimination rules of @{text "rpath"} *}
+
+lemma rpath_appendE:
+ assumes "rpath r x (xs @ [a] @ ys) y"
+ obtains "rpath r x (xs @ [a]) a" and "rpath r a ys y"
+ using rtrancl_path_appendE[OF assms[unfolded rpath_def, simplified], folded rpath_def]
+ by auto
+
+lemma rpath_subE:
+ assumes "rpath r x (xs @ [a] @ ys @ [b] @ zs) y"
+ obtains "rpath r x (xs @ [a]) a" and "rpath r a (ys @ [b]) b" and "rpath r b zs y"
+ using assms
+ by (elim rpath_appendE, auto)
+
+text {* Every path has a unique end point. *}
+lemma rpath_dest_eq:
+ assumes "rpath r x xs x1"
+ and "rpath r x xs x2"
+ shows "x1 = x2"
+ using assms
+ by (induct, auto)
+
+subsubsection {* Properites of @{text "edges_on"} *}
+
+lemma edges_on_unfold:
+ "edges_on (a # b # xs) = {(a, b)} \<union> edges_on (b # xs)" (is "?L = ?R")
+proof -
+ { fix c d
+ assume "(c, d) \<in> ?L"
+ then obtain l1 l2 where h: "(a # b # xs) = l1 @ [c, d] @ l2"
+ by (auto simp:edges_on_def)
+ have "(c, d) \<in> ?R"
+ proof(cases "l1")
+ case Nil
+ with h have "(c, d) = (a, b)" by auto
+ thus ?thesis by auto
+ next
+ case (Cons e es)
+ from h[unfolded this] have "b#xs = es@[c, d]@l2" by auto
+ thus ?thesis by (auto simp:edges_on_def)
+ qed
+ } moreover
+ { fix c d
+ assume "(c, d) \<in> ?R"
+ moreover have "(a, b) \<in> ?L"
+ proof -
+ have "(a # b # xs) = []@[a,b]@xs" by simp
+ hence "\<exists> l1 l2. (a # b # xs) = l1@[a,b]@l2" by auto
+ thus ?thesis by (unfold edges_on_def, simp)
+ qed
+ moreover {
+ assume "(c, d) \<in> edges_on (b#xs)"
+ then obtain l1 l2 where "b#xs = l1@[c, d]@l2" by (unfold edges_on_def, auto)
+ hence "a#b#xs = (a#l1)@[c,d]@l2" by simp
+ hence "\<exists> l1 l2. (a # b # xs) = l1@[c,d]@l2" by metis
+ hence "(c,d) \<in> ?L" by (unfold edges_on_def, simp)
+ }
+ ultimately have "(c, d) \<in> ?L" by auto
+ } ultimately show ?thesis by auto
+qed
+
+lemma edges_on_len:
+ assumes "(a,b) \<in> edges_on l"
+ shows "length l \<ge> 2"
+ using assms
+ by (unfold edges_on_def, auto)
+
+text {* Elimination of @{text "edges_on"} for non-empty path *}
+
+lemma edges_on_consE [elim, cases set:edges_on]:
+ assumes "(a,b) \<in> edges_on (x#xs)"
+ obtains (head) xs' where "x = a" and "xs = b#xs'"
+ | (tail) "(a,b) \<in> edges_on xs"
+proof -
+ from assms obtain l1 l2
+ where h: "(x#xs) = l1 @ [a,b] @ l2" by (unfold edges_on_def, blast)
+ have "(\<exists> xs'. x = a \<and> xs = b#xs') \<or> ((a,b) \<in> edges_on xs)"
+ proof(cases "l1")
+ case Nil with h
+ show ?thesis by auto
+ next
+ case (Cons e el)
+ from h[unfolded this]
+ have "xs = el @ [a,b] @ l2" by auto
+ thus ?thesis
+ by (unfold edges_on_def, auto)
+ qed
+ thus ?thesis
+ proof
+ assume "(\<exists>xs'. x = a \<and> xs = b # xs')"
+ then obtain xs' where "x = a" "xs = b#xs'" by blast
+ from that(1)[OF this] show ?thesis .
+ next
+ assume "(a, b) \<in> edges_on xs"
+ from that(2)[OF this] show ?thesis .
+ qed
+qed
+
+text {*
+ Every edges on the path is a graph edges:
+*}
+lemma rpath_edges_on:
+ assumes "rpath r x xs y"
+ shows "(edges_on (x#xs)) \<subseteq> r"
+ using assms
+proof(induct arbitrary:y)
+ case (rbase x)
+ thus ?case by (unfold edges_on_def, auto)
+next
+ case (rstep x y ys z)
+ show ?case
+ proof -
+ { fix a b
+ assume "(a, b) \<in> edges_on (x # y # ys)"
+ hence "(a, b) \<in> r" by (cases, insert rstep, auto)
+ } thus ?thesis by auto
+ qed
+qed
+
+text {* @{text "edges_on"} is mono with respect to @{text "#"}-operation: *}
+lemma edges_on_Cons_mono:
+ shows "edges_on xs \<subseteq> edges_on (x#xs)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> edges_on xs"
+ then obtain l1 l2 where "xs = l1 @ [a,b] @ l2"
+ by (auto simp:edges_on_def)
+ hence "x # xs = (x#l1) @ [a, b] @ l2" by auto
+ hence "(a, b) \<in> edges_on (x#xs)"
+ by (unfold edges_on_def, blast)
+ } thus ?thesis by auto
+qed
+
+text {*
+ The following rule @{text "rpath_transfer"} is used to show
+ that one path is intact as long as all the edges on it are intact
+ with the change of graph.
+
+ If @{text "x#xs"} is path in graph @{text "r1"} and
+ every edges along the path is also in @{text "r2"},
+ then @{text "x#xs"} is also a edge in graph @{text "r2"}:
+*}
+
+lemma rpath_transfer:
+ assumes "rpath r1 x xs y"
+ and "edges_on (x#xs) \<subseteq> r2"
+ shows "rpath r2 x xs y"
+ using assms
+proof(induct)
+ case (rstep x y ys z)
+ show ?case
+ proof(rule rstepI)
+ show "(x, y) \<in> r2"
+ proof -
+ have "(x, y) \<in> edges_on (x # y # ys)"
+ by (unfold edges_on_def, auto)
+ with rstep(4) show ?thesis by auto
+ qed
+ next
+ show "rpath r2 y ys z"
+ using rstep edges_on_Cons_mono[of "y#ys" "x"] by (auto)
+ qed
+qed (unfold rpath_def, auto intro!:Transitive_Closure_Table.rtrancl_path.base)
+
+lemma edges_on_rpathI:
+ assumes "edges_on (a#xs@[b]) \<subseteq> r"
+ shows "rpath r a (xs@[b]) b"
+ using assms
+proof(induct xs arbitrary: a b)
+ case Nil
+ moreover have "(a, b) \<in> edges_on (a # [] @ [b])"
+ by (unfold edges_on_def, auto)
+ ultimately have "(a, b) \<in> r" by auto
+ thus ?case by auto
+next
+ case (Cons x xs a b)
+ from this(2) have "edges_on (x # xs @ [b]) \<subseteq> r" by (simp add:edges_on_unfold)
+ from Cons(1)[OF this] have " rpath r x (xs @ [b]) b" .
+ moreover from Cons(2) have "(a, x) \<in> r" by (auto simp:edges_on_unfold)
+ ultimately show ?case by (auto)
+qed
+
+text {*
+ The following lemma extracts the path from @{text "x"} to @{text "y"}
+ from proposition @{text "(x, y) \<in> r^*"}
+*}
+lemma star_rpath:
+ assumes "(x, y) \<in> r^*"
+ obtains xs where "rpath r x xs y"
+proof -
+ have "\<exists> xs. rpath r x xs y"
+ proof(unfold rpath_def, rule iffD1[OF rtranclp_eq_rtrancl_path])
+ from assms
+ show "(pred_of r)\<^sup>*\<^sup>* x y"
+ apply (fold pred_of_star)
+ by (auto simp:pred_of_def)
+ qed
+ from that and this show ?thesis by blast
+qed
+
+text {*
+ The following lemma uses the path @{text "xs"} from @{text "x"} to @{text "y"}
+ as a witness to show @{text "(x, y) \<in> r^*"}.
+*}
+lemma rpath_star:
+ assumes "rpath r x xs y"
+ shows "(x, y) \<in> r^*"
+proof -
+ from iffD2[OF rtranclp_eq_rtrancl_path] and assms[unfolded rpath_def]
+ have "(pred_of r)\<^sup>*\<^sup>* x y" by metis
+ thus ?thesis by (simp add: pred_of_star star_2_pstar)
+qed
+
+lemma subtree_transfer:
+ assumes "a \<in> subtree r1 a'"
+ and "r1 \<subseteq> r2"
+ shows "a \<in> subtree r2 a'"
+proof -
+ from assms(1)[unfolded subtree_def]
+ have "(a, a') \<in> r1^*" by auto
+ from star_rpath[OF this]
+ obtain xs where rp: "rpath r1 a xs a'" by blast
+ hence "rpath r2 a xs a'"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] and assms(2)
+ show "edges_on (a # xs) \<subseteq> r2" by simp
+ qed
+ from rpath_star[OF this]
+ show ?thesis by (auto simp:subtree_def)
+qed
+
+lemma subtree_rev_transfer:
+ assumes "a \<notin> subtree r2 a'"
+ and "r1 \<subseteq> r2"
+ shows "a \<notin> subtree r1 a'"
+ using assms and subtree_transfer by metis
+
+text {*
+ The following lemmas establishes a relation from paths in @{text "r"}
+ to @{text "r^+"} relation.
+*}
+lemma rpath_plus:
+ assumes "rpath r x xs y"
+ and "xs \<noteq> []"
+ shows "(x, y) \<in> r^+"
+proof -
+ from assms(2) obtain e es where "xs = e#es" by (cases xs, auto)
+ from assms(1)[unfolded this]
+ show ?thesis
+ proof(cases)
+ case rstep
+ show ?thesis
+ proof -
+ from rpath_star[OF rstep(2)] have "(e, y) \<in> r\<^sup>*" .
+ with rstep(1) show "(x, y) \<in> r^+" by auto
+ qed
+ qed
+qed
+
+lemma plus_rpath:
+ assumes "(x, y) \<in> r^+"
+ obtains xs where "rpath r x xs y" and "xs \<noteq> []"
+proof -
+ from assms
+ show ?thesis
+ proof(cases rule:converse_tranclE[consumes 1])
+ case 1
+ hence "rpath r x [y] y" by auto
+ from that[OF this] show ?thesis by auto
+ next
+ case (2 z)
+ from 2(2) have "(z, y) \<in> r^*" by auto
+ from star_rpath[OF this] obtain xs where "rpath r z xs y" by auto
+ from rstepI[OF 2(1) this]
+ have "rpath r x (z # xs) y" .
+ from that[OF this] show ?thesis by auto
+ qed
+qed
+
+subsubsection {* Properties of @{text "subtree"} and @{term "ancestors"}*}
+
+lemma ancestors_subtreeI:
+ assumes "b \<in> ancestors r a"
+ shows "a \<in> subtree r b"
+ using assms by (auto simp:subtree_def ancestors_def)
+
+lemma ancestors_Field:
+ assumes "b \<in> ancestors r a"
+ obtains "a \<in> Domain r" "b \<in> Range r"
+ using assms
+ apply (unfold ancestors_def, simp)
+ by (metis Domain.DomainI Range.intros trancl_domain trancl_range)
+
+lemma subtreeE:
+ assumes "a \<in> subtree r b"
+ obtains "a = b"
+ | "a \<noteq> b" and "b \<in> ancestors r a"
+proof -
+ from assms have "(a, b) \<in> r^*" by (auto simp:subtree_def)
+ from rtranclD[OF this]
+ have " a = b \<or> a \<noteq> b \<and> (a, b) \<in> r\<^sup>+" .
+ with that[unfolded ancestors_def] show ?thesis by auto
+qed
+
+lemma subtree_Field:
+ assumes "a \<in> Field r"
+ shows "subtree r a \<subseteq> Field r"
+by (metis Field_def UnI1 ancestors_Field assms subsetI subtreeE)
+
+lemma subtree_Field:
+ "subtree r x \<subseteq> Field r \<union> {x}"
+proof
+ fix y
+ assume "y \<in> subtree r x"
+ thus "y \<in> Field r \<union> {x}"
+ proof(cases rule:subtreeE)
+ case 1
+ thus ?thesis by auto
+ next
+ case 2
+ thus ?thesis apply (auto simp:ancestors_def)
+ using Field_def tranclD by fastforce
+ qed
+qed
+
+lemma subtree_ancestorsI:
+ assumes "a \<in> subtree r b"
+ and "a \<noteq> b"
+ shows "b \<in> ancestors r a"
+ using assms
+ by (auto elim!:subtreeE)
+
+text {*
+ @{text "subtree"} is mono with respect to the underlying graph.
+*}
+lemma subtree_mono:
+ assumes "r1 \<subseteq> r2"
+ shows "subtree r1 x \<subseteq> subtree r2 x"
+proof
+ fix c
+ assume "c \<in> subtree r1 x"
+ hence "(c, x) \<in> r1^*" by (auto simp:subtree_def)
+ from star_rpath[OF this] obtain xs
+ where rp:"rpath r1 c xs x" by metis
+ hence "rpath r2 c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] have "edges_on (c # xs) \<subseteq> r1" .
+ with assms show "edges_on (c # xs) \<subseteq> r2" by auto
+ qed
+ thus "c \<in> subtree r2 x"
+ by (rule rpath_star[elim_format], auto simp:subtree_def)
+qed
+
+text {*
+ The following lemma characterizes the change of sub-tree of @{text "x"}
+ with the removal of an outside edge @{text "(a,b)"}.
+
+ Note that, according to lemma @{thm edges_in_refutation}, the assumption
+ @{term "b \<notin> subtree r x"} amounts to saying @{text "(a, b)"}
+ is outside the sub-tree of @{text "x"}.
+*}
+lemma subtree_del_outside: (* ddd *)
+ assumes "b \<notin> subtree r x"
+ shows "subtree (r - {(a, b)}) x = (subtree r x)"
+proof -
+ { fix c
+ assume "c \<in> (subtree r x)"
+ hence "(c, x) \<in> r^*" by (auto simp:subtree_def)
+ hence "c \<in> subtree (r - {(a, b)}) x"
+ proof(rule star_rpath)
+ fix xs
+ assume rp: "rpath r c xs x"
+ show ?thesis
+ proof -
+ from rp
+ have "rpath (r - {(a, b)}) c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] have "edges_on (c # xs) \<subseteq> r" .
+ moreover have "(a, b) \<notin> edges_on (c#xs)"
+ proof
+ assume "(a, b) \<in> edges_on (c # xs)"
+ then obtain l1 l2 where h: "c#xs = l1@[a,b]@l2" by (auto simp:edges_on_def)
+ hence "tl (c#xs) = tl (l1@[a,b]@l2)" by simp
+ then obtain l1' where eq_xs_b: "xs = l1'@[b]@l2" by (cases l1, auto)
+ from rp[unfolded this]
+ show False
+ proof(rule rpath_appendE)
+ assume "rpath r b l2 x"
+ thus ?thesis
+ by(rule rpath_star[elim_format], insert assms(1), auto simp:subtree_def)
+ qed
+ qed
+ ultimately show "edges_on (c # xs) \<subseteq> r - {(a,b)}" by auto
+ qed
+ thus ?thesis by (rule rpath_star[elim_format], auto simp:subtree_def)
+ qed
+ qed
+ } moreover {
+ fix c
+ assume "c \<in> subtree (r - {(a, b)}) x"
+ moreover have "... \<subseteq> (subtree r x)" by (rule subtree_mono, auto)
+ ultimately have "c \<in> (subtree r x)" by auto
+ } ultimately show ?thesis by auto
+qed
+
+(* ddd *)
+lemma subset_del_subtree_outside: (* ddd *)
+ assumes "Range r' \<inter> subtree r x = {}"
+ shows "subtree (r - r') x = (subtree r x)"
+proof -
+ { fix c
+ assume "c \<in> (subtree r x)"
+ hence "(c, x) \<in> r^*" by (auto simp:subtree_def)
+ hence "c \<in> subtree (r - r') x"
+ proof(rule star_rpath)
+ fix xs
+ assume rp: "rpath r c xs x"
+ show ?thesis
+ proof -
+ from rp
+ have "rpath (r - r') c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp] have "edges_on (c # xs) \<subseteq> r" .
+ moreover {
+ fix a b
+ assume h: "(a, b) \<in> r'"
+ have "(a, b) \<notin> edges_on (c#xs)"
+ proof
+ assume "(a, b) \<in> edges_on (c # xs)"
+ then obtain l1 l2 where "c#xs = (l1@[a])@[b]@l2" by (auto simp:edges_on_def)
+ hence "tl (c#xs) = tl (l1@[a,b]@l2)" by simp
+ then obtain l1' where eq_xs_b: "xs = l1'@[b]@l2" by (cases l1, auto)
+ from rp[unfolded this]
+ show False
+ proof(rule rpath_appendE)
+ assume "rpath r b l2 x"
+ from rpath_star[OF this]
+ have "b \<in> subtree r x" by (auto simp:subtree_def)
+ with assms (1) and h show ?thesis by (auto)
+ qed
+ qed
+ } ultimately show "edges_on (c # xs) \<subseteq> r - r'" by auto
+ qed
+ thus ?thesis by (rule rpath_star[elim_format], auto simp:subtree_def)
+ qed
+ qed
+ } moreover {
+ fix c
+ assume "c \<in> subtree (r - r') x"
+ moreover have "... \<subseteq> (subtree r x)" by (rule subtree_mono, auto)
+ ultimately have "c \<in> (subtree r x)" by auto
+ } ultimately show ?thesis by auto
+qed
+
+lemma subtree_insert_ext:
+ assumes "b \<in> subtree r x"
+ shows "subtree (r \<union> {(a, b)}) x = (subtree r x) \<union> (subtree r a)"
+ using assms by (auto simp:subtree_def rtrancl_insert)
+
+lemma subtree_insert_next:
+ assumes "b \<notin> subtree r x"
+ shows "subtree (r \<union> {(a, b)}) x = (subtree r x)"
+ using assms
+ by (auto simp:subtree_def rtrancl_insert)
+
+lemma set_add_rootI:
+ assumes "root r a"
+ and "a \<notin> Domain r1"
+ shows "root (r \<union> r1) a"
+proof -
+ let ?r = "r \<union> r1"
+ { fix a'
+ assume "a' \<in> ancestors ?r a"
+ hence "(a, a') \<in> ?r^+" by (auto simp:ancestors_def)
+ from tranclD[OF this] obtain z where "(a, z) \<in> ?r" by auto
+ moreover have "(a, z) \<notin> r"
+ proof
+ assume "(a, z) \<in> r"
+ with assms(1) show False
+ by (auto simp:root_def ancestors_def)
+ qed
+ ultimately have "(a, z) \<in> r1" by auto
+ with assms(2)
+ have False by (auto)
+ } thus ?thesis by (auto simp:root_def)
+qed
+
+lemma ancestors_mono:
+ assumes "r1 \<subseteq> r2"
+ shows "ancestors r1 x \<subseteq> ancestors r2 x"
+proof
+ fix a
+ assume "a \<in> ancestors r1 x"
+ hence "(x, a) \<in> r1^+" by (auto simp:ancestors_def)
+ from plus_rpath[OF this] obtain xs where
+ h: "rpath r1 x xs a" "xs \<noteq> []" .
+ have "rpath r2 x xs a"
+ proof(rule rpath_transfer[OF h(1)])
+ from rpath_edges_on[OF h(1)] and assms
+ show "edges_on (x # xs) \<subseteq> r2" by auto
+ qed
+ from rpath_plus[OF this h(2)]
+ show "a \<in> ancestors r2 x" by (auto simp:ancestors_def)
+qed
+
+lemma subtree_refute:
+ assumes "x \<notin> ancestors r y"
+ and "x \<noteq> y"
+ shows "y \<notin> subtree r x"
+proof
+ assume "y \<in> subtree r x"
+ thus False
+ by(elim subtreeE, insert assms, auto)
+qed
+
+subsubsection {* Properties about relational trees *}
+
+context rtree
+begin
+
+lemma ancestors_headE:
+ assumes "c \<in> ancestors r a"
+ assumes "(a, b) \<in> r"
+ obtains "b = c"
+ | "c \<in> ancestors r b"
+proof -
+ from assms(1)
+ have "(a, c) \<in> r^+" by (auto simp:ancestors_def)
+ hence "b = c \<or> c \<in> ancestors r b"
+ proof(cases rule:converse_tranclE[consumes 1])
+ case 1
+ with assms(2) and sgv have "b = c" by (auto simp:single_valued_def)
+ thus ?thesis by auto
+ next
+ case (2 y)
+ from 2(1) and assms(2) and sgv have "y = b" by (auto simp:single_valued_def)
+ from 2(2)[unfolded this] have "c \<in> ancestors r b" by (auto simp:ancestors_def)
+ thus ?thesis by auto
+ qed
+ with that show ?thesis by metis
+qed
+
+lemma ancestors_accum:
+ assumes "(a, b) \<in> r"
+ shows "ancestors r a = ancestors r b \<union> {b}"
+proof -
+ { fix c
+ assume "c \<in> ancestors r a"
+ hence "(a, c) \<in> r^+" by (auto simp:ancestors_def)
+ hence "c \<in> ancestors r b \<union> {b}"
+ proof(cases rule:converse_tranclE[consumes 1])
+ case 1
+ with sgv assms have "c = b" by (unfold single_valued_def, auto)
+ thus ?thesis by auto
+ next
+ case (2 c')
+ with sgv assms have "c' = b" by (unfold single_valued_def, auto)
+ from 2(2)[unfolded this]
+ show ?thesis by (auto simp:ancestors_def)
+ qed
+ } moreover {
+ fix c
+ assume "c \<in> ancestors r b \<union> {b}"
+ hence "c = b \<or> c \<in> ancestors r b" by auto
+ hence "c \<in> ancestors r a"
+ proof
+ assume "c = b"
+ from assms[folded this]
+ show ?thesis by (auto simp:ancestors_def)
+ next
+ assume "c \<in> ancestors r b"
+ with assms show ?thesis by (auto simp:ancestors_def)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+lemma rootI:
+ assumes h: "\<And> x'. x' \<noteq> x \<Longrightarrow> x \<notin> subtree r' x'"
+ and "r' \<subseteq> r"
+ shows "root r' x"
+proof -
+ from acyclic_subset[OF acl assms(2)]
+ have acl': "acyclic r'" .
+ { fix x'
+ assume "x' \<in> ancestors r' x"
+ hence h1: "(x, x') \<in> r'^+" by (auto simp:ancestors_def)
+ have "x' \<noteq> x"
+ proof
+ assume eq_x: "x' = x"
+ from h1[unfolded this] and acl'
+ show False by (auto simp:acyclic_def)
+ qed
+ moreover from h1 have "x \<in> subtree r' x'" by (auto simp:subtree_def)
+ ultimately have False using h by auto
+ } thus ?thesis by (auto simp:root_def)
+qed
+
+lemma rpath_overlap_oneside: (* ddd *)
+ assumes "rpath r x xs1 x1"
+ and "rpath r x xs2 x2"
+ and "length xs1 \<le> length xs2"
+ obtains xs3 where "xs2 = xs1 @ xs3"
+proof(cases "xs1 = []")
+ case True
+ with that show ?thesis by auto
+next
+ case False
+ have "\<forall> i \<le> length xs1. take i xs1 = take i xs2"
+ proof -
+ { assume "\<not> (\<forall> i \<le> length xs1. take i xs1 = take i xs2)"
+ then obtain i where "i \<le> length xs1 \<and> take i xs1 \<noteq> take i xs2" by auto
+ from this(1) have "False"
+ proof(rule index_minimize)
+ fix j
+ assume h1: "j \<le> length xs1 \<and> take j xs1 \<noteq> take j xs2"
+ and h2: " \<forall>k<j. \<not> (k \<le> length xs1 \<and> take k xs1 \<noteq> take k xs2)"
+ -- {* @{text "j - 1"} is the branch point between @{text "xs1"} and @{text "xs2"} *}
+ let ?idx = "j - 1"
+ -- {* A number of inequalities concerning @{text "j - 1"} are derived first *}
+ have lt_i: "?idx < length xs1" using False h1
+ by (metis Suc_diff_1 le_neq_implies_less length_greater_0_conv lessI less_imp_diff_less)
+ have lt_i': "?idx < length xs2" using lt_i and assms(3) by auto
+ have lt_j: "?idx < j" using h1 by (cases j, auto)
+ -- {* From thesis inequalities, a number of equations concerning @{text "xs1"}
+ and @{text "xs2"} are derived *}
+ have eq_take: "take ?idx xs1 = take ?idx xs2"
+ using h2[rule_format, OF lt_j] and h1 by auto
+ have eq_xs1: " xs1 = take ?idx xs1 @ xs1 ! (?idx) # drop (Suc (?idx)) xs1"
+ using id_take_nth_drop[OF lt_i] .
+ have eq_xs2: "xs2 = take ?idx xs2 @ xs2 ! (?idx) # drop (Suc (?idx)) xs2"
+ using id_take_nth_drop[OF lt_i'] .
+ -- {* The branch point along the path is finally pinpointed *}
+ have neq_idx: "xs1!?idx \<noteq> xs2!?idx"
+ proof -
+ have "take j xs1 = take ?idx xs1 @ [xs1 ! ?idx]"
+ using eq_xs1 Suc_diff_1 lt_i lt_j take_Suc_conv_app_nth by fastforce
+ moreover have eq_tk2: "take j xs2 = take ?idx xs2 @ [xs2 ! ?idx]"
+ using Suc_diff_1 lt_i' lt_j take_Suc_conv_app_nth by fastforce
+ ultimately show ?thesis using eq_take h1 by auto
+ qed
+ show ?thesis
+ proof(cases " take (j - 1) xs1 = []")
+ case True
+ have "(x, xs1!?idx) \<in> r"
+ proof -
+ from eq_xs1[unfolded True, simplified, symmetric] assms(1)
+ have "rpath r x ( xs1 ! ?idx # drop (Suc ?idx) xs1) x1" by simp
+ from this[unfolded rpath_def]
+ show ?thesis by (auto simp:pred_of_def)
+ qed
+ moreover have "(x, xs2!?idx) \<in> r"
+ proof -
+ from eq_xs2[folded eq_take, unfolded True, simplified, symmetric] assms(2)
+ have "rpath r x ( xs2 ! ?idx # drop (Suc ?idx) xs2) x2" by simp
+ from this[unfolded rpath_def]
+ show ?thesis by (auto simp:pred_of_def)
+ qed
+ ultimately show ?thesis using neq_idx sgv[unfolded single_valued_def] by metis
+ next
+ case False
+ then obtain e es where eq_es: "take ?idx xs1 = es@[e]"
+ using rev_exhaust by blast
+ have "(e, xs1!?idx) \<in> r"
+ proof -
+ from eq_xs1[unfolded eq_es]
+ have "xs1 = es@[e, xs1!?idx]@drop (Suc ?idx) xs1" by simp
+ hence "(e, xs1!?idx) \<in> edges_on xs1" by (simp add:edges_on_def, metis)
+ with rpath_edges_on[OF assms(1)] edges_on_Cons_mono[of xs1 x]
+ show ?thesis by auto
+ qed moreover have "(e, xs2!?idx) \<in> r"
+ proof -
+ from eq_xs2[folded eq_take, unfolded eq_es]
+ have "xs2 = es@[e, xs2!?idx]@drop (Suc ?idx) xs2" by simp
+ hence "(e, xs2!?idx) \<in> edges_on xs2" by (simp add:edges_on_def, metis)
+ with rpath_edges_on[OF assms(2)] edges_on_Cons_mono[of xs2 x]
+ show ?thesis by auto
+ qed
+ ultimately show ?thesis
+ using sgv[unfolded single_valued_def] neq_idx by metis
+ qed
+ qed
+ } thus ?thesis by auto
+ qed
+ from this[rule_format, of "length xs1"]
+ have "take (length xs1) xs1 = take (length xs1) xs2" by simp
+ moreover have "xs2 = take (length xs1) xs2 @ drop (length xs1) xs2" by simp
+ ultimately have "xs2 = xs1 @ drop (length xs1) xs2" by auto
+ from that[OF this] show ?thesis .
+qed
+
+lemma rpath_overlap [consumes 2, cases pred:rpath]:
+ assumes "rpath r x xs1 x1"
+ and "rpath r x xs2 x2"
+ obtains (less_1) xs3 where "xs2 = xs1 @ xs3"
+ | (less_2) xs3 where "xs1 = xs2 @ xs3"
+proof -
+ have "length xs1 \<le> length xs2 \<or> length xs2 \<le> length xs1" by auto
+ with assms rpath_overlap_oneside that show ?thesis by metis
+qed
+
+text {*
+ As a corollary of @{thm "rpath_overlap_oneside"},
+ the following two lemmas gives one important property of relation tree,
+ i.e. there is at most one path between any two nodes.
+ Similar to the proof of @{thm rpath_overlap}, we starts with
+ the one side version first.
+*}
+
+lemma rpath_unique_oneside:
+ assumes "rpath r x xs1 y"
+ and "rpath r x xs2 y"
+ and "length xs1 \<le> length xs2"
+ shows "xs1 = xs2"
+proof -
+ from rpath_overlap_oneside[OF assms]
+ obtain xs3 where less_1: "xs2 = xs1 @ xs3" by blast
+ show ?thesis
+ proof(cases "xs3 = []")
+ case True
+ from less_1[unfolded this] show ?thesis by simp
+ next
+ case False
+ note FalseH = this
+ show ?thesis
+ proof(cases "xs1 = []")
+ case True
+ have "(x, x) \<in> r^+"
+ proof(rule rpath_plus)
+ from assms(1)[unfolded True]
+ have "y = x" by (cases rule:rpath_nilE, simp)
+ from assms(2)[unfolded this] show "rpath r x xs2 x" .
+ next
+ from less_1 and False show "xs2 \<noteq> []" by simp
+ qed
+ with acl show ?thesis by (unfold acyclic_def, auto)
+ next
+ case False
+ then obtain e es where eq_xs1: "xs1 = es@[e]" using rev_exhaust by auto
+ from assms(2)[unfolded less_1 this]
+ have "rpath r x (es @ [e] @ xs3) y" by simp
+ thus ?thesis
+ proof(cases rule:rpath_appendE)
+ case 1
+ from rpath_dest_eq [OF 1(1)[folded eq_xs1] assms(1)]
+ have "e = y" .
+ from rpath_plus [OF 1(2)[unfolded this] FalseH]
+ have "(y, y) \<in> r^+" .
+ with acl show ?thesis by (unfold acyclic_def, auto)
+ qed
+ qed
+ qed
+qed
+
+text {*
+ The following is the full version of path uniqueness.
+*}
+lemma rpath_unique:
+ assumes "rpath r x xs1 y"
+ and "rpath r x xs2 y"
+ shows "xs1 = xs2"
+proof(cases "length xs1 \<le> length xs2")
+ case True
+ from rpath_unique_oneside[OF assms this] show ?thesis .
+next
+ case False
+ hence "length xs2 \<le> length xs1" by simp
+ from rpath_unique_oneside[OF assms(2,1) this]
+ show ?thesis by simp
+qed
+
+text {*
+ The following lemma shows that the `independence` relation is symmetric.
+ It is an obvious auxiliary lemma which will be used later.
+*}
+lemma sym_indep: "indep r x y \<Longrightarrow> indep r y x"
+ by (unfold indep_def, auto)
+
+text {*
+ This is another `obvious` lemma about trees, which says trees rooted at
+ independent nodes are disjoint.
+*}
+lemma subtree_disjoint:
+ assumes "indep r x y"
+ shows "subtree r x \<inter> subtree r y = {}"
+proof -
+ { fix z x y xs1 xs2 xs3
+ assume ind: "indep r x y"
+ and rp1: "rpath r z xs1 x"
+ and rp2: "rpath r z xs2 y"
+ and h: "xs2 = xs1 @ xs3"
+ have False
+ proof(cases "xs1 = []")
+ case True
+ from rp1[unfolded this] have "x = z" by auto
+ from rp2[folded this] rpath_star ind[unfolded indep_def]
+ show ?thesis by metis
+ next
+ case False
+ then obtain e es where eq_xs1: "xs1 = es@[e]" using rev_exhaust by blast
+ from rp2[unfolded h this]
+ have "rpath r z (es @ [e] @ xs3) y" by simp
+ thus ?thesis
+ proof(cases rule:rpath_appendE)
+ case 1
+ have "e = x" using 1(1)[folded eq_xs1] rp1 rpath_dest_eq by metis
+ from rpath_star[OF 1(2)[unfolded this]] ind[unfolded indep_def]
+ show ?thesis by auto
+ qed
+ qed
+ } note my_rule = this
+ { fix z
+ assume h: "z \<in> subtree r x" "z \<in> subtree r y"
+ from h(1) have "(z, x) \<in> r^*" by (unfold subtree_def, auto)
+ then obtain xs1 where rp1: "rpath r z xs1 x" using star_rpath by metis
+ from h(2) have "(z, y) \<in> r^*" by (unfold subtree_def, auto)
+ then obtain xs2 where rp2: "rpath r z xs2 y" using star_rpath by metis
+ from rp1 rp2
+ have False
+ by (cases, insert my_rule[OF sym_indep[OF assms(1)] rp2 rp1]
+ my_rule[OF assms(1) rp1 rp2], auto)
+ } thus ?thesis by auto
+qed
+
+text {*
+ The following lemma @{text "subtree_del"} characterizes the change of sub-tree of
+ @{text "x"} with the removal of an inside edge @{text "(a, b)"}.
+ Note that, the case for the removal of an outside edge has already been dealt with
+ in lemma @{text "subtree_del_outside"}).
+
+ This lemma is underpinned by the following two `obvious` facts:
+ \begin{enumearte}
+ \item
+ In graph @{text "r"}, for an inside edge @{text "(a,b) \<in> edges_in r x"},
+ every node @{text "c"} in the sub-tree of @{text "a"} has a path
+ which goes first from @{text "c"} to @{text "a"}, then through edge @{text "(a, b)"}, and
+ finally reaches @{text "x"}. By the uniqueness of path in a tree,
+ all paths from sub-tree of @{text "a"} to @{text "x"} are such constructed, therefore
+ must go through @{text "(a, b)"}. The consequence is: with the removal of @{text "(a,b)"},
+ all such paths will be broken.
+
+ \item
+ On the other hand, all paths not originate from within the sub-tree of @{text "a"}
+ will not be affected by the removal of edge @{text "(a, b)"}.
+ The reason is simple: if the path is affected by the removal, it must
+ contain @{text "(a, b)"}, then it must originate from within the sub-tree of @{text "a"}.
+ \end{enumearte}
+*}
+
+lemma subtree_del_inside: (* ddd *)
+ assumes "(a,b) \<in> edges_in r x"
+ shows "subtree (r - {(a, b)}) x = (subtree r x) - subtree r a"
+proof -
+ from assms have asm: "b \<in> subtree r x" "(a, b) \<in> r" by (auto simp:edges_in_def)
+ -- {* The proof follows a common pattern to prove the equality of sets. *}
+ { -- {* The `left to right` direction.
+ *}
+ fix c
+ -- {* Assuming @{text "c"} is inside the sub-tree of @{text "x"} in the reduced graph *}
+ assume h: "c \<in> subtree (r - {(a, b)}) x"
+ -- {* We are going to show that @{text "c"} can not be in the sub-tree of @{text "a"} in
+ the original graph. *}
+ -- {* In other words, all nodes inside the sub-tree of @{text "a"} in the original
+ graph will be removed from the sub-tree of @{text "x"} in the reduced graph. *}
+ -- {* The reason, as analyzed before, is that all paths from within the
+ sub-tree of @{text "a"} are broken with the removal of edge @{text "(a,b)"}.
+ *}
+ have "c \<in> (subtree r x) - subtree r a"
+ proof -
+ let ?r' = "r - {(a, b)}" -- {* The reduced graph is abbreviated as @{text "?r'"} *}
+ from h have "(c, x) \<in> ?r'^*" by (auto simp:subtree_def)
+ -- {* Extract from the reduced graph the path @{text "xs"} from @{text "c"} to @{text "x"}. *}
+ then obtain xs where rp0: "rpath ?r' c xs x" by (rule star_rpath, auto)
+ -- {* It is easy to show @{text "xs"} is also a path in the original graph *}
+ hence rp1: "rpath r c xs x"
+ proof(rule rpath_transfer)
+ from rpath_edges_on[OF rp0]
+ show "edges_on (c # xs) \<subseteq> r" by auto
+ qed
+ -- {* @{text "xs"} is used as the witness to show that @{text "c"}
+ in the sub-tree of @{text "x"} in the original graph. *}
+ hence "c \<in> subtree r x"
+ by (rule rpath_star[elim_format], auto simp:subtree_def)
+ -- {* The next step is to show that @{text "c"} can not be in the sub-tree of @{text "a"}
+ in the original graph. *}
+ -- {* We need to use the fact that all paths originate from within sub-tree of @{text "a"}
+ are broken. *}
+ moreover have "c \<notin> subtree r a"
+ proof
+ -- {* Proof by contradiction, suppose otherwise *}
+ assume otherwise: "c \<in> subtree r a"
+ -- {* Then there is a path in original graph leading from @{text "c"} to @{text "a"} *}
+ obtain xs1 where rp_c: "rpath r c xs1 a"
+ proof -
+ from otherwise have "(c, a) \<in> r^*" by (auto simp:subtree_def)
+ thus ?thesis by (rule star_rpath, auto intro!:that)
+ qed
+ -- {* Starting from this path, we are going to construct a fictional
+ path from @{text "c"} to @{text "x"}, which, as explained before,
+ is broken, so that contradiction can be derived. *}
+ -- {* First, there is a path from @{text "b"} to @{text "x"} *}
+ obtain ys where rp_b: "rpath r b ys x"
+ proof -
+ from asm have "(b, x) \<in> r^*" by (auto simp:subtree_def)
+ thus ?thesis by (rule star_rpath, auto intro!:that)
+ qed
+ -- {* The paths @{text "xs1"} and @{text "ys"} can be
+ tied together using @{text "(a,b)"} to form a path
+ from @{text "c"} to @{text "x"}: *}
+ have "rpath r c (xs1 @ b # ys) x"
+ proof -
+ from rstepI[OF asm(2) rp_b] have "rpath r a (b # ys) x" .
+ from rpath_appendI[OF rp_c this]
+ show ?thesis .
+ qed
+ -- {* By the uniqueness of path between two nodes of a tree, we have: *}
+ from rpath_unique[OF rp1 this] have eq_xs: "xs = xs1 @ b # ys" .
+ -- {* Contradiction can be derived from from this fictional path . *}
+ show False
+ proof -
+ -- {* It can be shown that @{term "(a,b)"} is on this fictional path. *}
+ have "(a, b) \<in> edges_on (c#xs)"
+ proof(cases "xs1 = []")
+ case True
+ from rp_c[unfolded this] have "rpath r c [] a" .
+ hence eq_c: "c = a" by (rule rpath_nilE, simp)
+ hence "c#xs = a#xs" by simp
+ from this and eq_xs have "c#xs = a # xs1 @ b # ys" by simp
+ from this[unfolded True] have "c#xs = []@[a,b]@ys" by simp
+ thus ?thesis by (auto simp:edges_on_def)
+ next
+ case False
+ from rpath_nnl_lastE[OF rp_c this]
+ obtain xs' where "xs1 = xs'@[a]" by auto
+ from eq_xs[unfolded this] have "c#xs = (c#xs')@[a,b]@ys" by simp
+ thus ?thesis by (unfold edges_on_def, blast)
+ qed
+ -- {* It can also be shown that @{term "(a,b)"} is not on this fictional path. *}
+ moreover have "(a, b) \<notin> edges_on (c#xs)"
+ using rpath_edges_on[OF rp0] by auto
+ -- {* Contradiction is thus derived. *}
+ ultimately show False by auto
+ qed
+ qed
+ ultimately show ?thesis by auto
+ qed
+ } moreover {
+ -- {* The `right to left` direction.
+ *}
+ fix c
+ -- {* Assuming that @{text "c"} is in the sub-tree of @{text "x"}, but
+ outside of the sub-tree of @{text "a"} in the original graph, *}
+ assume h: "c \<in> (subtree r x) - subtree r a"
+ -- {* we need to show that in the reduced graph, @{text "c"} is still in
+ the sub-tree of @{text "x"}. *}
+ have "c \<in> subtree (r - {(a, b)}) x"
+ proof -
+ -- {* The proof goes by showing that the path from @{text "c"} to @{text "x"}
+ in the original graph is not affected by the removal of @{text "(a,b)"}.
+ *}
+ from h have "(c, x) \<in> r^*" by (unfold subtree_def, auto)
+ -- {* Extract the path @{text "xs"} from @{text "c"} to @{text "x"} in the original graph. *}
+ from star_rpath[OF this] obtain xs where rp: "rpath r c xs x" by auto
+ -- {* Show that it is also a path in the reduced graph. *}
+ hence "rpath (r - {(a, b)}) c xs x"
+ -- {* The proof goes by using rule @{thm rpath_transfer} *}
+ proof(rule rpath_transfer)
+ -- {* We need to show all edges on the path are still in the reduced graph. *}
+ show "edges_on (c # xs) \<subseteq> r - {(a, b)}"
+ proof -
+ -- {* It is easy to show that all the edges are in the original graph. *}
+ from rpath_edges_on [OF rp] have " edges_on (c # xs) \<subseteq> r" .
+ -- {* The essential part is to show that @{text "(a, b)"} is not on the path. *}
+ moreover have "(a,b) \<notin> edges_on (c#xs)"
+ proof
+ -- {* Proof by contradiction, suppose otherwise: *}
+ assume otherwise: "(a, b) \<in> edges_on (c#xs)"
+ -- {* Then @{text "(a, b)"} is in the middle of the path.
+ with @{text "l1"} and @{text "l2"} be the nodes in
+ the front and rear respectively. *}
+ then obtain l1 l2 where eq_xs:
+ "c#xs = l1 @ [a, b] @ l2" by (unfold edges_on_def, blast)
+ -- {* From this, it can be shown that @{text "c"} is
+ in the sub-tree of @{text "a"} *}
+ have "c \<in> subtree r a"
+ proof(cases "l1 = []")
+ case True
+ -- {* If @{text "l1"} is null, it can be derived that @{text "c = a"}. *}
+ with eq_xs have "c = a" by auto
+ -- {* So, @{text "c"} is obviously in the sub-tree of @{text "a"}. *}
+ thus ?thesis by (unfold subtree_def, auto)
+ next
+ case False
+ -- {* When @{text "l1"} is not null, it must have a tail @{text "es"}: *}
+ then obtain e es where "l1 = e#es" by (cases l1, auto)
+ -- {* The relation of this tail with @{text "xs"} is derived: *}
+ with eq_xs have "xs = es@[a,b]@l2" by auto
+ -- {* From this, a path from @{text "c"} to @{text "a"} is made visible: *}
+ from rp[unfolded this] have "rpath r c (es @ [a] @ (b#l2)) x" by simp
+ thus ?thesis
+ proof(cases rule:rpath_appendE)
+ -- {* The path from @{text "c"} to @{text "a"} is extraced
+ using @{thm "rpath_appendE"}: *}
+ case 1
+ from rpath_star[OF this(1)]
+ -- {* The extracted path servers as a witness that @{text "c"} is
+ in the sub-tree of @{text "a"}: *}
+ show ?thesis by (simp add:subtree_def)
+ qed
+ qed with h show False by auto
+ qed ultimately show ?thesis by auto
+ qed
+ qed
+ -- {* From , it is shown that @{text "c"} is in the sub-tree of @{text "x"}
+ inthe reduced graph. *}
+ from rpath_star[OF this] show ?thesis by (auto simp:subtree_def)
+ qed
+ }
+ -- {* The equality of sets is derived from the two directions just proved. *}
+ ultimately show ?thesis by auto
+qed
+
+lemma set_del_rootI:
+ assumes "r1 \<subseteq> r"
+ and "a \<in> Domain r1"
+ shows "root (r - r1) a"
+proof -
+ let ?r = "r - r1"
+ { fix a'
+ assume neq: "a' \<noteq> a"
+ have "a \<notin> subtree ?r a'"
+ proof
+ assume "a \<in> subtree ?r a'"
+ hence "(a, a') \<in> ?r^*" by (auto simp:subtree_def)
+ from star_rpath[OF this] obtain xs
+ where rp: "rpath ?r a xs a'" by auto
+ from rpathE[OF this] and neq
+ obtain z zs where h: "(a, z) \<in> ?r" "rpath ?r z zs a'" "xs = z#zs" by auto
+ from assms(2) obtain z' where z'_in: "(a, z') \<in> r1" by (auto simp:DomainE)
+ with assms(1) have "(a, z') \<in> r" by auto
+ moreover from h(1) have "(a, z) \<in> r" by simp
+ ultimately have "z' = z" using sgv by (auto simp:single_valued_def)
+ from z'_in[unfolded this] and h(1) show False by auto
+ qed
+ } thus ?thesis by (intro rootI, auto)
+qed
+
+lemma edge_del_no_rootI:
+ assumes "(a, b) \<in> r"
+ shows "root (r - {(a, b)}) a"
+ by (rule set_del_rootI, insert assms, auto)
+
+lemma ancestors_children_unique:
+ assumes "z1 \<in> ancestors r x \<inter> children r y"
+ and "z2 \<in> ancestors r x \<inter> children r y"
+ shows "z1 = z2"
+proof -
+ from assms have h:
+ "(x, z1) \<in> r^+" "(z1, y) \<in> r"
+ "(x, z2) \<in> r^+" "(z2, y) \<in> r"
+ by (auto simp:ancestors_def children_def)
+
+ -- {* From this, a path containing @{text "z1"} is obtained. *}
+ from plus_rpath[OF h(1)] obtain xs1
+ where h1: "rpath r x xs1 z1" "xs1 \<noteq> []" by auto
+ from rpath_nnl_lastE[OF this] obtain xs1' where eq_xs1: "xs1 = xs1' @ [z1]"
+ by auto
+ from h(2) have h2: "rpath r z1 [y] y" by auto
+ from rpath_appendI[OF h1(1) h2, unfolded eq_xs1]
+ have rp1: "rpath r x (xs1' @ [z1, y]) y" by simp
+
+ -- {* Then, another path containing @{text "z2"} is obtained. *}
+ from plus_rpath[OF h(3)] obtain xs2
+ where h3: "rpath r x xs2 z2" "xs2 \<noteq> []" by auto
+ from rpath_nnl_lastE[OF this] obtain xs2' where eq_xs2: "xs2 = xs2' @ [z2]"
+ by auto
+ from h(4) have h4: "rpath r z2 [y] y" by auto
+ from rpath_appendI[OF h3(1) h4, unfolded eq_xs2]
+ have "rpath r x (xs2' @ [z2, y]) y" by simp
+
+ -- {* Finally @{text "z1 = z2"} is proved by uniqueness of path. *}
+ from rpath_unique[OF rp1 this]
+ have "xs1' @ [z1, y] = xs2' @ [z2, y]" .
+ thus ?thesis by auto
+qed
+
+lemma ancestors_childrenE:
+ assumes "y \<in> ancestors r x"
+ obtains "x \<in> children r y"
+ | z where "z \<in> ancestors r x \<inter> children r y"
+proof -
+ from assms(1) have "(x, y) \<in> r^+" by (auto simp:ancestors_def)
+ from tranclD2[OF this] obtain z where
+ h: "(x, z) \<in> r\<^sup>*" "(z, y) \<in> r" by auto
+ from h(1)
+ show ?thesis
+ proof(cases rule:rtranclE)
+ case base
+ from h(2)[folded this] have "x \<in> children r y"
+ by (auto simp:children_def)
+ thus ?thesis by (intro that, auto)
+ next
+ case (step u)
+ hence "z \<in> ancestors r x" by (auto simp:ancestors_def)
+ moreover from h(2) have "z \<in> children r y"
+ by (auto simp:children_def)
+ ultimately show ?thesis by (intro that, auto)
+ qed
+qed
+
+
+end (* of rtree *)
+
+lemma subtree_children:
+ "subtree r x = {x} \<union> (\<Union> (subtree r ` (children r x)))" (is "?L = ?R")
+proof -
+ { fix z
+ assume "z \<in> ?L"
+ hence "z \<in> ?R"
+ proof(cases rule:subtreeE[consumes 1])
+ case 2
+ hence "(z, x) \<in> r^+" by (auto simp:ancestors_def)
+ thus ?thesis
+ proof(rule tranclE)
+ assume "(z, x) \<in> r"
+ hence "z \<in> children r x" by (unfold children_def, auto)
+ moreover have "z \<in> subtree r z" by (auto simp:subtree_def)
+ ultimately show ?thesis by auto
+ next
+ fix c
+ assume h: "(z, c) \<in> r\<^sup>+" "(c, x) \<in> r"
+ hence "c \<in> children r x" by (auto simp:children_def)
+ moreover from h have "z \<in> subtree r c" by (auto simp:subtree_def)
+ ultimately show ?thesis by auto
+ qed
+ qed auto
+ } moreover {
+ fix z
+ assume h: "z \<in> ?R"
+ have "x \<in> subtree r x" by (auto simp:subtree_def)
+ moreover {
+ assume "z \<in> \<Union>(subtree r ` children r x)"
+ then obtain y where "(y, x) \<in> r" "(z, y) \<in> r^*"
+ by (auto simp:subtree_def children_def)
+ hence "(z, x) \<in> r^*" by auto
+ hence "z \<in> ?L" by (auto simp:subtree_def)
+ } ultimately have "z \<in> ?L" using h by auto
+ } ultimately show ?thesis by auto
+qed
+
+context fsubtree
+begin
+
+lemma finite_subtree:
+ shows "finite (subtree r x)"
+proof(induct rule:wf_induct[OF wf])
+ case (1 x)
+ have "finite (\<Union>(subtree r ` children r x))"
+ proof(rule finite_Union)
+ show "finite (subtree r ` children r x)"
+ proof(cases "children r x = {}")
+ case True
+ thus ?thesis by auto
+ next
+ case False
+ hence "x \<in> Range r" by (auto simp:children_def)
+ from fb[rule_format, OF this]
+ have "finite (children r x)" .
+ thus ?thesis by (rule finite_imageI)
+ qed
+ next
+ fix M
+ assume "M \<in> subtree r ` children r x"
+ then obtain y where h: "y \<in> children r x" "M = subtree r y" by auto
+ hence "(y, x) \<in> r" by (auto simp:children_def)
+ from 1[rule_format, OF this, folded h(2)]
+ show "finite M" .
+ qed
+ thus ?case
+ by (unfold subtree_children finite_Un, auto)
+qed
+
+end
+
+definition "pairself f = (\<lambda>(a, b). (f a, f b))"
+
+definition "rel_map f r = (pairself f ` r)"
+
+lemma rel_mapE:
+ assumes "(a, b) \<in> rel_map f r"
+ obtains c d
+ where "(c, d) \<in> r" "(a, b) = (f c, f d)"
+ using assms
+ by (unfold rel_map_def pairself_def, auto)
+
+lemma rel_mapI:
+ assumes "(a, b) \<in> r"
+ and "c = f a"
+ and "d = f b"
+ shows "(c, d) \<in> rel_map f r"
+ using assms
+ by (unfold rel_map_def pairself_def, auto)
+
+lemma map_appendE:
+ assumes "map f zs = xs @ ys"
+ obtains xs' ys'
+ where "zs = xs' @ ys'" "xs = map f xs'" "ys = map f ys'"
+proof -
+ have "\<exists> xs' ys'. zs = xs' @ ys' \<and> xs = map f xs' \<and> ys = map f ys'"
+ using assms
+ proof(induct xs arbitrary:zs ys)
+ case (Nil zs ys)
+ thus ?case by auto
+ next
+ case (Cons x xs zs ys)
+ note h = this
+ show ?case
+ proof(cases zs)
+ case (Cons e es)
+ with h have eq_x: "map f es = xs @ ys" "x = f e" by auto
+ from h(1)[OF this(1)]
+ obtain xs' ys' where "es = xs' @ ys'" "xs = map f xs'" "ys = map f ys'"
+ by blast
+ with Cons eq_x
+ have "zs = (e#xs') @ ys' \<and> x # xs = map f (e#xs') \<and> ys = map f ys'" by auto
+ thus ?thesis by metis
+ qed (insert h, auto)
+ qed
+ thus ?thesis by (auto intro!:that)
+qed
+
+lemma rel_map_mono:
+ assumes "r1 \<subseteq> r2"
+ shows "rel_map f r1 \<subseteq> rel_map f r2"
+ using assms
+ by (auto simp:rel_map_def pairself_def)
+
+lemma rel_map_compose [simp]:
+ shows "rel_map f1 (rel_map f2 r) = rel_map (f1 o f2) r"
+ by (auto simp:rel_map_def pairself_def)
+
+lemma edges_on_map: "edges_on (map f xs) = rel_map f (edges_on xs)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> edges_on (map f xs)"
+ then obtain l1 l2 where eq_map: "map f xs = l1 @ [a, b] @ l2"
+ by (unfold edges_on_def, auto)
+ hence "(a, b) \<in> rel_map f (edges_on xs)"
+ by (auto elim!:map_appendE intro!:rel_mapI simp:edges_on_def)
+ } moreover {
+ fix a b
+ assume "(a, b) \<in> rel_map f (edges_on xs)"
+ then obtain c d where
+ h: "(c, d) \<in> edges_on xs" "(a, b) = (f c, f d)"
+ by (elim rel_mapE, auto)
+ then obtain l1 l2 where
+ eq_xs: "xs = l1 @ [c, d] @ l2"
+ by (auto simp:edges_on_def)
+ hence eq_map: "map f xs = map f l1 @ [f c, f d] @ map f l2" by auto
+ have "(a, b) \<in> edges_on (map f xs)"
+ proof -
+ from h(2) have "[f c, f d] = [a, b]" by simp
+ from eq_map[unfolded this] show ?thesis by (auto simp:edges_on_def)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+lemma image_id:
+ assumes "\<And> x. x \<in> A \<Longrightarrow> f x = x"
+ shows "f ` A = A"
+ using assms by (auto simp:image_def)
+
+lemma rel_map_inv_id:
+ assumes "inj_on f ((Domain r) \<union> (Range r))"
+ shows "(rel_map (inv_into ((Domain r) \<union> (Range r)) f \<circ> f) r) = r"
+proof -
+ let ?f = "(inv_into (Domain r \<union> Range r) f \<circ> f)"
+ {
+ fix a b
+ assume h0: "(a, b) \<in> r"
+ have "pairself ?f (a, b) = (a, b)"
+ proof -
+ from assms h0 have "?f a = a" by (auto intro:inv_into_f_f)
+ moreover have "?f b = b"
+ by (insert h0, simp, intro inv_into_f_f[OF assms], auto intro!:RangeI)
+ ultimately show ?thesis by (auto simp:pairself_def)
+ qed
+ } thus ?thesis by (unfold rel_map_def, intro image_id, case_tac x, auto)
+qed
+
+lemma rel_map_acyclic:
+ assumes "acyclic r"
+ and "inj_on f ((Domain r) \<union> (Range r))"
+ shows "acyclic (rel_map f r)"
+proof -
+ let ?D = "Domain r \<union> Range r"
+ { fix a
+ assume "(a, a) \<in> (rel_map f r)^+"
+ from plus_rpath[OF this]
+ obtain xs where rp: "rpath (rel_map f r) a xs a" "xs \<noteq> []" by auto
+ from rpath_nnl_lastE[OF this] obtain xs' where eq_xs: "xs = xs'@[a]" by auto
+ from rpath_edges_on[OF rp(1)]
+ have h: "edges_on (a # xs) \<subseteq> rel_map f r" .
+ from edges_on_map[of "inv_into ?D f" "a#xs"]
+ have "edges_on (map (inv_into ?D f) (a # xs)) = rel_map (inv_into ?D f) (edges_on (a # xs))" .
+ with rel_map_mono[OF h, of "inv_into ?D f"]
+ have "edges_on (map (inv_into ?D f) (a # xs)) \<subseteq> rel_map ((inv_into ?D f) o f) r" by simp
+ from this[unfolded eq_xs]
+ have subr: "edges_on (map (inv_into ?D f) (a # xs' @ [a])) \<subseteq> rel_map (inv_into ?D f \<circ> f) r" .
+ have "(map (inv_into ?D f) (a # xs' @ [a])) = (inv_into ?D f a) # map (inv_into ?D f) xs' @ [inv_into ?D f a]"
+ by simp
+ from edges_on_rpathI[OF subr[unfolded this]]
+ have "rpath (rel_map (inv_into ?D f \<circ> f) r)
+ (inv_into ?D f a) (map (inv_into ?D f) xs' @ [inv_into ?D f a]) (inv_into ?D f a)" .
+ hence "(inv_into ?D f a, inv_into ?D f a) \<in> (rel_map (inv_into ?D f \<circ> f) r)^+"
+ by (rule rpath_plus, simp)
+ moreover have "(rel_map (inv_into ?D f \<circ> f) r) = r" by (rule rel_map_inv_id[OF assms(2)])
+ moreover note assms(1)
+ ultimately have False by (unfold acyclic_def, auto)
+ } thus ?thesis by (auto simp:acyclic_def)
+qed
+
+lemma relpow_mult:
+ "((r::'a rel) ^^ m) ^^ n = r ^^ (m*n)"
+proof(induct n arbitrary:m)
+ case (Suc k m)
+ thus ?case
+ proof -
+ have h: "(m * k + m) = (m + m * k)" by auto
+ show ?thesis
+ apply (simp add:Suc relpow_add[symmetric])
+ by (unfold h, simp)
+ qed
+qed simp
+
+lemma compose_relpow_2:
+ assumes "r1 \<subseteq> r"
+ and "r2 \<subseteq> r"
+ shows "r1 O r2 \<subseteq> r ^^ (2::nat)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> r1 O r2"
+ then obtain e where "(a, e) \<in> r1" "(e, b) \<in> r2"
+ by auto
+ with assms have "(a, e) \<in> r" "(e, b) \<in> r" by auto
+ hence "(a, b) \<in> r ^^ (Suc (Suc 0))" by auto
+ } thus ?thesis by (auto simp:numeral_2_eq_2)
+qed
+
+lemma acyclic_compose:
+ assumes "acyclic r"
+ and "r1 \<subseteq> r"
+ and "r2 \<subseteq> r"
+ shows "acyclic (r1 O r2)"
+proof -
+ { fix a
+ assume "(a, a) \<in> (r1 O r2)^+"
+ from trancl_mono[OF this compose_relpow_2[OF assms(2, 3)]]
+ have "(a, a) \<in> (r ^^ 2) ^+" .
+ from trancl_power[THEN iffD1, OF this]
+ obtain n where h: "(a, a) \<in> (r ^^ 2) ^^ n" "n > 0" by blast
+ from this(1)[unfolded relpow_mult] have h2: "(a, a) \<in> r ^^ (2 * n)" .
+ have "(a, a) \<in> r^+"
+ proof(cases rule:trancl_power[THEN iffD2])
+ from h(2) h2 show "\<exists>n>0. (a, a) \<in> r ^^ n"
+ by (rule_tac x = "2*n" in exI, auto)
+ qed
+ with assms have "False" by (auto simp:acyclic_def)
+ } thus ?thesis by (auto simp:acyclic_def)
+qed
+
+lemma children_compose_unfold:
+ "children (r1 O r2) x = \<Union> (children r1 ` (children r2 x))"
+ by (auto simp:children_def)
+
+lemma fbranch_compose:
+ assumes "fbranch r1"
+ and "fbranch r2"
+ shows "fbranch (r1 O r2)"
+proof -
+ { fix x
+ assume "x\<in>Range (r1 O r2)"
+ then obtain y z where h: "(y, z) \<in> r1" "(z, x) \<in> r2" by auto
+ have "finite (children (r1 O r2) x)"
+ proof(unfold children_compose_unfold, rule finite_Union)
+ show "finite (children r1 ` children r2 x)"
+ proof(rule finite_imageI)
+ from h(2) have "x \<in> Range r2" by auto
+ from assms(2)[unfolded fbranch_def, rule_format, OF this]
+ show "finite (children r2 x)" .
+ qed
+ next
+ fix M
+ assume "M \<in> children r1 ` children r2 x"
+ then obtain y where h1: "y \<in> children r2 x" "M = children r1 y" by auto
+ show "finite M"
+ proof(cases "children r1 y = {}")
+ case True
+ with h1(2) show ?thesis by auto
+ next
+ case False
+ hence "y \<in> Range r1" by (unfold children_def, auto)
+ from assms(1)[unfolded fbranch_def, rule_format, OF this, folded h1(2)]
+ show ?thesis .
+ qed
+ qed
+ } thus ?thesis by (unfold fbranch_def, auto)
+qed
+
+lemma finite_fbranchI:
+ assumes "finite r"
+ shows "fbranch r"
+proof -
+ { fix x
+ assume "x \<in>Range r"
+ have "finite (children r x)"
+ proof -
+ have "{y. (y, x) \<in> r} \<subseteq> Domain r" by (auto)
+ from rev_finite_subset[OF finite_Domain[OF assms] this]
+ have "finite {y. (y, x) \<in> r}" .
+ thus ?thesis by (unfold children_def, simp)
+ qed
+ } thus ?thesis by (auto simp:fbranch_def)
+qed
+
+lemma subset_fbranchI:
+ assumes "fbranch r1"
+ and "r2 \<subseteq> r1"
+ shows "fbranch r2"
+proof -
+ { fix x
+ assume "x \<in>Range r2"
+ with assms(2) have "x \<in> Range r1" by auto
+ from assms(1)[unfolded fbranch_def, rule_format, OF this]
+ have "finite (children r1 x)" .
+ hence "finite (children r2 x)"
+ proof(rule rev_finite_subset)
+ from assms(2)
+ show "children r2 x \<subseteq> children r1 x" by (auto simp:children_def)
+ qed
+ } thus ?thesis by (auto simp:fbranch_def)
+qed
+
+lemma children_subtree:
+ shows "children r x \<subseteq> subtree r x"
+ by (auto simp:children_def subtree_def)
+
+lemma children_union_kept:
+ assumes "x \<notin> Range r'"
+ shows "children (r \<union> r') x = children r x"
+ using assms
+ by (auto simp:children_def)
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Test.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,789 @@
+theory Test
+imports Precedence_ord Graphs
+begin
+
+type_synonym thread = nat -- {* Type for thread identifiers. *}
+type_synonym priority = nat -- {* Type for priorities. *}
+type_synonym cs = nat -- {* Type for critical sections (or resources). *}
+
+-- {* Schedulling Events *}
+
+datatype event =
+ Create thread priority
+| Exit thread
+| P thread cs
+| V thread cs
+| Set thread priority
+
+type_synonym state = "event list"
+
+fun threads :: "state \<Rightarrow> thread set"
+ where
+ "threads [] = {}"
+| "threads (Create th prio#s) = {th} \<union> threads s"
+| "threads (Exit th # s) = (threads s) - {th}"
+| "threads (_#s) = threads s"
+
+fun priority :: "thread \<Rightarrow> state \<Rightarrow> priority"
+ where
+ "priority th [] = 0"
+| "priority th (Create th' prio#s) = (if th' = th then prio else priority th s)"
+| "priority th (Set th' prio#s) = (if th' = th then prio else priority th s)"
+| "priority th (_#s) = priority th s"
+
+fun last_set :: "thread \<Rightarrow> state \<Rightarrow> nat"
+ where
+ "last_set th [] = 0"
+| "last_set th ((Create th' prio)#s) = (if (th = th') then length s else last_set th s)"
+| "last_set th ((Set th' prio)#s) = (if (th = th') then length s else last_set th s)"
+| "last_set th (_#s) = last_set th s"
+
+
+definition preced :: "thread \<Rightarrow> state \<Rightarrow> precedence"
+ where "preced th s \<equiv> Prc (priority th s) (last_set th s)"
+
+abbreviation
+ "preceds s ths \<equiv> {preced th s | th. th \<in> ths}"
+
+definition
+ "holds wq th cs \<equiv> th \<in> set (wq cs) \<and> th = hd (wq cs)"
+
+definition
+ "waits wq th cs \<equiv> th \<in> set (wq cs) \<and> th \<noteq> hd (wq cs)"
+
+--{* Nodes in Resource Graph *}
+datatype node =
+ Th "thread"
+| Cs "cs"
+
+definition
+ "RAG wq \<equiv> {(Th th, Cs cs) | th cs. waits wq th cs} \<union> {(Cs cs, Th th) | cs th. holds wq th cs}"
+
+definition
+ "dependants wq th \<equiv> {th' . (Th th', Th th) \<in> (RAG wq)^+}"
+
+record schedule_state =
+ wq_fun :: "cs \<Rightarrow> thread list"
+ cprec_fun :: "thread \<Rightarrow> precedence"
+
+definition cpreced :: "(cs \<Rightarrow> thread list) \<Rightarrow> state \<Rightarrow> thread \<Rightarrow> precedence"
+ where
+ "cpreced wq s th \<equiv> Max ({preced th s} \<union> {preced th' s | th'. th' \<in> dependants wq th})"
+
+abbreviation
+ "all_unlocked \<equiv> \<lambda>_::cs. ([]::thread list)"
+
+abbreviation
+ "initial_cprec \<equiv> \<lambda>_::thread. Prc 0 0"
+
+abbreviation
+ "release qs \<equiv> case qs of
+ [] => []
+ | (_ # qs) => SOME q. distinct q \<and> set q = set qs"
+
+lemma [simp]:
+ "(SOME q. distinct q \<and> q = []) = []"
+by auto
+
+lemma [simp]:
+ "(x \<in> set (SOME q. distinct q \<and> set q = set p)) = (x \<in> set p)"
+apply(rule iffI)
+apply (metis (mono_tags, lifting) List.finite_set finite_distinct_list some_eq_ex)+
+done
+
+abbreviation
+ "next_to_run ths \<equiv> hd (SOME q::thread list. distinct q \<and> set q = set ths)"
+
+
+fun schs :: "state \<Rightarrow> schedule_state"
+ where
+ "schs [] = (| wq_fun = \<lambda> cs. [], cprec_fun = (\<lambda>_. Prc 0 0) |)"
+| "schs (Create th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Create th prio # s)|))"
+| "schs (Exit th # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Exit th # s)|))"
+| "schs (Set th prio # s) =
+ (let wq = wq_fun (schs s) in
+ (|wq_fun = wq, cprec_fun = cpreced wq (Set th prio # s)|))"
+| "schs (P th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := (wq cs @ [th])) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (P th cs # s)|))"
+| "schs (V th cs # s) =
+ (let wq = wq_fun (schs s) in
+ let new_wq = wq(cs := release (wq cs)) in
+ (|wq_fun = new_wq, cprec_fun = cpreced new_wq (V th cs # s)|))"
+
+definition wq :: "state \<Rightarrow> cs \<Rightarrow> thread list"
+ where "wq s = wq_fun (schs s)"
+
+definition cpreced2 :: "state \<Rightarrow> thread \<Rightarrow> precedence"
+ where "cpreced2 s \<equiv> cprec_fun (schs s)"
+
+abbreviation
+ "cpreceds2 s ths \<equiv> {cpreced2 s th | th. th \<in> ths}"
+
+definition
+ "holds2 s \<equiv> holds (wq_fun (schs s))"
+
+definition
+ "waits2 s \<equiv> waits (wq_fun (schs s))"
+
+definition
+ "RAG2 s \<equiv> RAG (wq_fun (schs s))"
+
+definition
+ "dependants2 s \<equiv> dependants (wq_fun (schs s))"
+
+(* ready -> is a thread that is not waiting for any resource *)
+definition readys :: "state \<Rightarrow> thread set"
+ where "readys s \<equiv> {th . th \<in> threads s \<and> (\<forall> cs. \<not> waits2 s th cs)}"
+
+definition runing :: "state \<Rightarrow> thread set"
+ where "runing s \<equiv> {th . th \<in> readys s \<and> cpreced2 s th = Max (cpreceds2 s (readys s))}"
+
+(* all resources a thread hols in a state *)
+definition holding :: "state \<Rightarrow> thread \<Rightarrow> cs set"
+ where "holding s th \<equiv> {cs . holds2 s th cs}"
+
+
+lemma exists_distinct:
+ obtains ys where "distinct ys" "set ys = set xs"
+by (metis List.finite_set finite_distinct_list)
+
+lemma next_to_run_set [simp]:
+ "wts \<noteq> [] \<Longrightarrow> next_to_run wts \<in> set wts"
+apply(rule exists_distinct[of wts])
+by (metis (mono_tags, lifting) hd_in_set set_empty some_eq_ex)
+
+lemma holding_RAG:
+ "holding s th = {cs . (Cs cs, Th th) \<in> RAG2 s}"
+unfolding holding_def RAG2_def RAG_def
+unfolding holds2_def holds_def waits_def
+by auto
+
+inductive step :: "state \<Rightarrow> event \<Rightarrow> bool"
+ where
+ step_Create: "\<lbrakk>th \<notin> threads s\<rbrakk> \<Longrightarrow> step s (Create th prio)"
+| step_Exit: "\<lbrakk>th \<in> runing s; holding s th = {}\<rbrakk> \<Longrightarrow> step s (Exit th)"
+| step_P: "\<lbrakk>th \<in> runing s; (Cs cs, Th th) \<notin> (RAG2 s)^+\<rbrakk> \<Longrightarrow> step s (P th cs)"
+| step_V: "\<lbrakk>th \<in> runing s; holds2 s th cs\<rbrakk> \<Longrightarrow> step s (V th cs)"
+| step_Set: "\<lbrakk>th \<in> runing s\<rbrakk> \<Longrightarrow> step s (Set th prio)"
+
+(* valid states *)
+inductive vt :: "state \<Rightarrow> bool"
+ where
+ vt_nil[intro]: "vt []"
+| vt_cons[intro]: "\<lbrakk>vt s; step s e\<rbrakk> \<Longrightarrow> vt (e#s)"
+
+lemma runing_ready:
+ shows "runing s \<subseteq> readys s"
+ unfolding runing_def readys_def
+ by auto
+
+lemma readys_threads:
+ shows "readys s \<subseteq> threads s"
+ unfolding readys_def
+ by auto
+
+lemma wq_threads:
+ assumes vt: "vt s"
+ and h: "th \<in> set (wq s cs)"
+ shows "th \<in> threads s"
+using assms
+apply(induct)
+apply(simp add: wq_def)
+apply(erule step.cases)
+apply(auto simp add: wq_def Let_def holding_def holds2_def holds_def waits2_def runing_def readys_def)
+apply(simp add: waits_def)
+apply(auto simp add: waits_def split: if_splits)[1]
+apply(auto split: if_splits)
+apply(simp only: waits_def)
+by (metis insert_iff set_simps(2))
+
+
+
+lemma Domain_RAG_threads:
+ assumes vt: "vt s"
+ and in_dom: "(Th th) \<in> Domain (RAG2 s)"
+ shows "th \<in> threads s"
+proof -
+ from in_dom obtain n where "(Th th, n) \<in> RAG2 s" by auto
+ then obtain cs where "n = Cs cs" "(Th th, Cs cs) \<in> RAG2 s"
+ unfolding RAG2_def RAG_def by auto
+ then have "th \<in> set (wq s cs)"
+ unfolding wq_def RAG_def RAG2_def waits_def by auto
+ with wq_threads [OF vt] show ?thesis .
+qed
+
+lemma dependants_threads:
+ assumes vt: "vt s"
+ shows "dependants2 s th \<subseteq> threads s"
+proof
+ fix th1
+ assume "th1 \<in> dependants2 s th"
+ then have h: "(Th th1, Th th) \<in> (RAG2 s)\<^sup>+"
+ unfolding dependants2_def dependants_def RAG2_def by simp
+ then have "Th th1 \<in> Domain ((RAG2 s)\<^sup>+)" unfolding Domain_def by auto
+ then have "Th th1 \<in> Domain (RAG2 s)" using trancl_domain by simp
+ then show "th1 \<in> threads s" using vt by (rule_tac Domain_RAG_threads)
+qed
+
+lemma finite_threads:
+ assumes vt: "vt s"
+ shows "finite (threads s)"
+using vt by (induct) (auto elim: step.cases)
+
+
+section {* Distinctness of @{const wq} *}
+
+lemma wq_distinct_step:
+ assumes "step s e" "distinct (wq s cs)"
+ shows "distinct (wq (e # s) cs)"
+using assms
+unfolding wq_def
+apply(erule_tac step.cases)
+apply(auto simp add: RAG2_def RAG_def Let_def)[1]
+apply(auto simp add: wq_def Let_def RAG2_def RAG_def holds_def runing_def waits2_def waits_def readys_def)
+apply(auto split: list.split)
+apply(rule someI2)
+apply(auto)
+done
+
+lemma wq_distinct:
+ assumes "vt s"
+ shows "distinct (wq s cs)"
+using assms
+apply(induct)
+apply(simp add: wq_def)
+apply(simp add: wq_distinct_step)
+done
+
+
+section {* Single_Valuedness of @{const waits2}, @{const holds2}, @{const RAG2} *}
+
+lemma waits2_unique:
+ assumes "vt s"
+ and "waits2 s th cs1"
+ and "waits2 s th cs2"
+ shows "cs1 = cs2"
+using assms
+apply(induct)
+apply(simp add: waits2_def waits_def)
+apply(erule step.cases)
+apply(auto simp add: Let_def waits2_def waits_def holds_def RAG2_def RAG_def
+ readys_def runing_def split: if_splits)
+apply (metis Nil_is_append_conv hd_append2 list.distinct(1) split_list)
+apply (metis Nil_is_append_conv hd_append2 list.distinct(1) split_list)
+apply (metis distinct.simps(2) distinct_length_2_or_more list.sel(1) wq_def wq_distinct)
+by (metis (full_types, hide_lams) distinct.simps(2) distinct_length_2_or_more list.sel(1) wq_def wq_distinct)
+
+lemma single_valued_waits2:
+ assumes "vt s"
+ shows "single_valuedP (waits2 s)"
+using assms
+unfolding single_valued_def
+by (metis Collect_splitD fst_eqD sndI waits2_unique)
+
+lemma single_valued_holds2:
+ assumes "vt s"
+ shows "single_valuedP (\<lambda>cs th. holds2 s th cs)"
+unfolding single_valued_def holds2_def holds_def by simp
+
+lemma single_valued_RAG2:
+ assumes "vt s"
+ shows "single_valued (RAG2 s)"
+using single_valued_waits2[OF assms] single_valued_holds2[OF assms]
+unfolding RAG2_def RAG_def
+apply(rule_tac single_valued_union)
+unfolding holds2_def[symmetric] waits2_def[symmetric]
+apply(rule single_valued_Collect)
+apply(simp)
+apply(simp add: inj_on_def)
+apply(rule single_valued_Collect)
+apply(simp)
+apply(simp add: inj_on_def)
+apply(auto)
+done
+
+
+section {* Properties of @{const RAG2} under events *}
+
+lemma RAG_Set [simp]:
+ shows "RAG2 (Set th prio # s) = RAG2 s"
+unfolding RAG2_def
+by (simp add: Let_def)
+
+lemma RAG_Create [simp]:
+ "RAG2 (Create th prio # s) = RAG2 s"
+unfolding RAG2_def
+by (simp add: Let_def)
+
+lemma RAG_Exit [simp]:
+ shows "RAG2 (Exit th # s) = RAG2 s"
+unfolding RAG2_def
+by (simp add: Let_def)
+
+lemma RAG_P1:
+ assumes "wq s cs = []"
+ shows "RAG2 (P th cs # s) \<subseteq> RAG2 s \<union> {(Cs cs, Th th)}"
+using assms
+unfolding RAG2_def RAG_def wq_def Let_def waits_def holds_def
+by (auto simp add: Let_def)
+
+lemma RAG_P2:
+ assumes "(Cs cs, Th th) \<notin> (RAG2 s)\<^sup>+" "wq s cs \<noteq> []"
+ shows "RAG2 (P th cs # s) \<subseteq> RAG2 s \<union> {(Th th, Cs cs)}"
+using assms
+unfolding RAG2_def RAG_def wq_def Let_def waits_def holds_def
+by (auto simp add: Let_def)
+
+
+lemma RAG_V1:
+assumes vt: "wq s cs = [th]"
+shows "RAG2 (V th cs # s) \<subseteq> RAG2 s - {(Cs cs, Th th)}"
+using assms
+unfolding RAG2_def RAG_def waits_def holds_def wq_def
+by (auto simp add: Let_def)
+
+lemma RAG_V2:
+assumes vt:"vt s" "wq s cs = th # wts \<and> wts \<noteq> []"
+shows "RAG2 (V th cs # s) \<subseteq>
+ RAG2 s - {(Cs cs, Th th), (Th (next_to_run wts), Cs cs)} \<union> {(Cs cs, Th (next_to_run wts))}"
+unfolding RAG2_def RAG_def waits_def holds_def
+using assms wq_distinct[OF vt(1), of"cs"]
+by (auto simp add: Let_def wq_def)
+
+
+
+section {* Acyclicity of @{const RAG2} *}
+
+lemma acyclic_RAG_step:
+ assumes vt: "vt s"
+ and stp: "step s e"
+ and ac: "acyclic (RAG2 s)"
+ shows "acyclic (RAG2 (e # s))"
+using stp vt ac
+proof (induct)
+ case (step_P th s cs)
+ have ac: "acyclic (RAG2 s)" by fact
+ have ds: "(Cs cs, Th th) \<notin> (RAG2 s)\<^sup>+" by fact
+ { assume wq_empty: "wq s cs = []" -- "case waiting queue is empty"
+ then have "(Th th, Cs cs) \<notin> (RAG2 s)\<^sup>+"
+ proof (rule_tac notI)
+ assume "(Th th, Cs cs) \<in> (RAG2 s)\<^sup>+"
+ then obtain x where "(x, Cs cs) \<in> RAG2 s" using tranclD2 by metis
+ with wq_empty show False by (auto simp: RAG2_def RAG_def wq_def waits_def)
+ qed
+ with ac have "acyclic (RAG2 s \<union> {(Cs cs, Th th)})" by simp
+ then have "acyclic (RAG2 (P th cs # s))" using RAG_P1[OF wq_empty]
+ by (rule acyclic_subset)
+ }
+ moreover
+ { assume wq_not_empty: "wq s cs \<noteq> []" -- "case waiting queue is not empty"
+ from ac ds
+ have "acyclic (RAG2 s \<union> {(Th th, Cs cs)})" by simp
+ then have "acyclic (RAG2 (P th cs # s))" using RAG_P2[OF ds wq_not_empty]
+ by (rule acyclic_subset)
+ }
+ ultimately show "acyclic (RAG2 (P th cs # s))" by metis
+next
+ case (step_V th s cs) -- "case for release of a lock"
+ have vt: "vt s" by fact
+ have ac: "acyclic (RAG2 s)" by fact
+ have hd: "holds2 s th cs" by fact
+ from vt have wq_distinct:"distinct (wq s cs)" by (rule wq_distinct)
+ from hd have "th \<in> set (wq s cs)" "th = hd (wq s cs)" unfolding holds2_def holds_def wq_def by auto
+ then obtain wts where eq_wq: "wq s cs = th # wts" by (cases "wq s cs") (auto)
+ -- "case no thread present in the waiting queue to take over"
+ { assume "wts = []"
+ with eq_wq have "wq s cs = [th]" by simp
+ then have "RAG2 (V th cs # s) \<subseteq> RAG2 s - {(Cs cs, Th th)}" by (rule RAG_V1)
+ moreover have "acyclic (RAG2 s - {(Cs cs, Th th)})" using ac by (auto intro: acyclic_subset)
+ ultimately
+ have "acyclic (RAG2 (V th cs # s))" by (auto intro: acyclic_subset)
+ }
+ moreover
+ -- "at least one thread present to take over"
+ { def nth \<equiv> "next_to_run wts"
+ assume wq_not_empty: "wts \<noteq> []"
+ have "waits2 s nth cs"
+ using eq_wq wq_not_empty wq_distinct
+ unfolding nth_def waits2_def waits_def wq_def[symmetric] by auto
+ then have cs_in_RAG: "(Th nth, Cs cs) \<in> RAG2 s"
+ unfolding RAG2_def RAG_def waits2_def by auto
+ have "RAG2 (V th cs # s) \<subseteq> RAG2 s - {(Cs cs, Th th), (Th nth, Cs cs)} \<union> {(Cs cs, Th nth)}"
+ unfolding nth_def using vt wq_not_empty eq_wq by (rule_tac RAG_V2) (auto)
+ moreover
+ have "acyclic (RAG2 s - {(Cs cs, Th th), (Th nth, Cs cs)} \<union> {(Cs cs, Th nth)})"
+ proof -
+ have "acyclic (RAG2 s - {(Cs cs, Th th), (Th nth, Cs cs)})" using ac by (auto intro: acyclic_subset)
+ moreover
+ have "(Th nth, Cs cs) \<notin> (RAG2 s - {(Cs cs, Th th), (Th nth, Cs cs)})\<^sup>+"
+ proof (rule notI)
+ assume "(Th nth, Cs cs) \<in> (RAG2 s - {(Cs cs, Th th), (Th nth, Cs cs)})\<^sup>+"
+ then obtain z where a: "(Th nth, z) \<in> (RAG2 s - {(Cs cs, Th th), (Th nth, Cs cs)})"
+ by (metis converse_tranclE)
+ then have "(Th nth, z) \<in> RAG2 s" by simp
+ then have "z = Cs cs" using cs_in_RAG single_valued_RAG2[OF vt]
+ by (simp add: single_valued_def)
+ then show "False" using a by simp
+ qed
+ ultimately
+ show "acyclic (RAG2 s - {(Cs cs, Th th), (Th nth, Cs cs)} \<union> {(Cs cs, Th nth) })" by simp
+ qed
+ ultimately have "acyclic (RAG2 (V th cs # s))"
+ by (rule_tac acyclic_subset)
+ }
+ ultimately show "acyclic (RAG2 (V th cs # s))" by metis
+qed (simp_all)
+
+
+lemma finite_RAG:
+ assumes "vt s"
+ shows "finite (RAG2 s)"
+using assms
+apply(induct)
+apply(simp add: RAG2_def RAG_def waits_def holds_def)
+apply(erule step.cases)
+apply(auto)
+apply(case_tac "wq sa cs = []")
+apply(rule finite_subset)
+apply(rule RAG_P1)
+apply(simp)
+apply(simp)
+apply(rule finite_subset)
+apply(rule RAG_P2)
+apply(simp)
+apply(simp)
+apply(simp)
+apply(subgoal_tac "\<exists>wts. wq sa cs = th # wts")
+apply(erule exE)
+apply(case_tac "wts = []")
+apply(rule finite_subset)
+apply(rule RAG_V1)
+apply(simp)
+apply(simp)
+apply(rule finite_subset)
+apply(rule RAG_V2)
+apply(simp)
+apply(simp)
+apply(simp)
+apply(subgoal_tac "th \<in> set (wq sa cs) \<and> th = hd (wq sa cs)")
+apply(case_tac "wq sa cs")
+apply(auto)[2]
+apply(auto simp add: holds2_def holds_def wq_def)
+done
+
+
+
+lemma dchain_unique:
+ assumes vt: "vt s"
+ and th1_d: "(n, Th th1) \<in> (RAG2 s)^+"
+ and th1_r: "th1 \<in> readys s"
+ and th2_d: "(n, Th th2) \<in> (RAG2 s)^+"
+ and th2_r: "th2 \<in> readys s"
+ shows "th1 = th2"
+proof(rule ccontr)
+ assume neq: "th1 \<noteq> th2"
+ with single_valued_confluent2 [OF single_valued_RAG2 [OF vt]] th1_d th2_d
+ have "(Th th1, Th th2) \<in> (RAG2 s)\<^sup>+ \<or> (Th th2, Th th1) \<in> (RAG2 s)\<^sup>+" by auto
+ moreover
+ { assume "(Th th1, Th th2) \<in> (RAG2 s)\<^sup>+"
+ then obtain n where dd: "(Th th1, n) \<in> RAG2 s" by (metis converse_tranclE)
+ then obtain cs where eq_n: "n = Cs cs"
+ unfolding RAG2_def RAG_def by (case_tac n) (auto)
+ from dd eq_n have "th1 \<notin> readys s"
+ unfolding RAG2_def RAG_def waits2_def readys_def by (auto)
+ with th1_r have "False" by auto
+ }
+ moreover
+ { assume "(Th th2, Th th1) \<in> (RAG2 s)\<^sup>+"
+ then obtain n where dd: "(Th th2, n) \<in> RAG2 s" by (metis converse_tranclE)
+ then obtain cs where eq_n: "n = Cs cs"
+ unfolding RAG2_def RAG_def by (case_tac n) (auto)
+ from dd eq_n have "th2 \<notin> readys s"
+ unfolding RAG2_def RAG_def waits2_def readys_def by (auto)
+ with th2_r have "False" by auto
+ }
+ ultimately show "False" by metis
+qed
+
+lemma cpreced2_cpreced: "cpreced2 s th = cpreced (wq s) s th"
+unfolding cpreced2_def wq_def
+apply(induct s rule: schs.induct)
+apply(simp add: Let_def cpreced_def dependants_def RAG_def waits_def holds_def preced_def)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+apply(subst (2) schs.simps)
+apply(simp add: Let_def)
+done
+
+lemma cpreced_Exit:
+ shows "cpreced2 (Exit th # s) th' = cpreced2 s th'"
+by (simp add: cpreced2_cpreced cpreced_def preced_def wq_def Let_def)
+
+lemma readys_Exit:
+ shows "readys (Exit th # s) = readys s - {th}"
+by (auto simp add: readys_def waits2_def Let_def)
+
+lemma readys_Create:
+ shows "readys (Create th prio # s) \<subseteq> {th} \<union> readys s"
+apply (auto simp add: readys_def waits2_def Let_def waits_def)
+done
+
+lemma readys_Set:
+ shows "readys (Set th prio # s) = readys s"
+by (auto simp add: readys_def waits2_def Let_def)
+
+
+lemma readys_P:
+ shows "readys (P th cs # s) \<subseteq> readys s"
+apply(auto simp add: readys_def waits2_def Let_def)
+apply(simp add: waits_def)
+apply(case_tac "csa = cs")
+apply(simp)
+apply(drule_tac x="cs" in spec)
+apply(simp)
+apply (metis hd_append2 in_set_insert insert_Nil list.sel(1))
+apply(drule_tac x="csa" in spec)
+apply(simp)
+done
+
+lemma readys_V:
+ shows "readys (V th cs # s) \<subseteq> readys s \<union> set (wq s cs)"
+apply(auto simp add: readys_def waits2_def waits_def Let_def wq_def)
+done
+
+
+fun the_th :: "node \<Rightarrow> thread"
+ where "the_th (Th th) = th"
+
+lemma image_Collect2:
+ "f ` A = {f x | x. x \<in> A}"
+apply(auto)
+done
+
+lemma Collect_disj_eq2:
+ "{f x | x. x = y \<or> x \<in> A} = {f y} \<union> {f x | x. x \<in> A}"
+by (auto)
+
+lemma last_set_lt:
+ "th \<in> threads s \<Longrightarrow> last_set th s < length s"
+ apply(induct rule: threads.induct)
+ apply(auto)
+ done
+
+lemma last_set_eq_iff:
+ assumes "th1 \<in> threads s" "th2 \<in> threads s"
+ shows "last_set th1 s = last_set th2 s \<longleftrightarrow> th1 = th2"
+ using assms
+ apply(induct s rule: threads.induct)
+ apply(auto split:if_splits dest:last_set_lt)
+ done
+
+lemma preced_eq_iff:
+ assumes th_in1: "th1 \<in> threads s"
+ and th_in2: "th2 \<in> threads s"
+ shows "preced th1 s = preced th2 s \<longleftrightarrow> th1 = th2"
+using assms
+by (auto simp add: preced_def last_set_eq_iff)
+
+lemma dm_RAG_threads:
+ assumes vt: "vt s"
+ and in_dom: "(Th th) \<in> Domain (RAG2 s)"
+ shows "th \<in> threads s"
+proof -
+ from in_dom obtain n where a: "(Th th, n) \<in> RAG2 s" by auto
+ then obtain cs where "n = Cs cs"
+ unfolding RAG2_def RAG_def
+ by auto
+ then have "(Th th, Cs cs) \<in> RAG2 s" using a by simp
+ hence "th \<in> set (wq s cs)"
+ unfolding RAG2_def wq_def RAG_def waits_def
+ by (auto)
+ then show ?thesis
+ apply(rule_tac wq_threads)
+ apply(rule assms)
+ apply(simp)
+ done
+qed
+
+lemma cpreced_eq_iff:
+ assumes "th1 \<in> readys s" "th2 \<in> readys s" "vt s"
+ shows "cpreced2 s th1 = cpreced2 s th2 \<longleftrightarrow> th1 = th2"
+proof
+ def S1\<equiv>"({th1} \<union> dependants (wq s) th1)"
+ def S2\<equiv>"({th2} \<union> dependants (wq s) th2)"
+ have fin: "finite ((the_th o fst) ` ((RAG (wq s))\<^sup>+))"
+ apply(rule)
+ apply(simp add: finite_trancl)
+ apply(simp add: wq_def)
+ apply(rule finite_RAG[simplified RAG2_def])
+ apply(rule assms)
+ done
+
+ from fin have h: "finite (preceds s S1)" "finite (preceds s S2)"
+ apply(simp_all add: S2_def S1_def Collect_disj_eq2 image_Collect[symmetric])
+ apply(rule)
+ apply(simp add: dependants_def)
+ apply(rule rev_finite_subset)
+ apply(assumption)
+ apply(auto simp add: image_def)[1]
+ apply(metis fst_conv the_th.simps)
+ apply(rule)
+ apply(simp add: dependants_def)
+ apply(rule rev_finite_subset)
+ apply(assumption)
+ apply(auto simp add: image_def)[1]
+ apply(metis fst_conv the_th.simps)
+ done
+ moreover have "S1 \<noteq> {}" "S2 \<noteq> {}" by (simp_all add: S1_def S2_def)
+ then have "(preceds s S1) \<noteq> {}" "(preceds s S2) \<noteq> {}" by simp_all
+ ultimately have m: "Max (preceds s S1) \<in> (preceds s S1)" "Max (preceds s S2) \<in> (preceds s S2)"
+ apply(rule_tac [!] Max_in)
+ apply(simp_all)
+ done
+
+ assume q: "cpreced2 s th1 = cpreced2 s th2"
+ then have eq_max: "Max (preceds s S1) = Max (preceds s S2)"
+ unfolding cpreced2_cpreced cpreced_def
+ apply(simp only: S1_def S2_def)
+ apply(simp add: Collect_disj_eq2)
+ done
+
+ obtain th0 where th0_in: "th0 \<in> S1" "th0 \<in> S2" and
+ eq_f_th1: "preced th0 s = Max (preceds s S1)"
+ "preced th0 s = Max (preceds s S2)"
+ using m
+ apply(clarify)
+ apply(simp add: eq_max)
+ apply(subst (asm) (2) preced_eq_iff)
+ apply(insert assms(2))[1]
+ apply(simp add: S2_def)
+ apply(auto)[1]
+ apply (metis contra_subsetD readys_threads)
+ apply(simp add: dependants_def)
+ apply(subgoal_tac "Th tha \<in> Domain ((RAG2 s)^+)")
+ apply(simp add: trancl_domain)
+ apply (metis Domain_RAG_threads assms(3))
+ apply(simp only: RAG2_def wq_def)
+ apply (metis Domain_iff)
+ apply(insert assms(1))[1]
+ apply(simp add: S1_def)
+ apply(auto)[1]
+ apply (metis contra_subsetD readys_threads)
+ apply(simp add: dependants_def)
+ apply(subgoal_tac "Th th \<in> Domain ((RAG2 s)^+)")
+ apply(simp add: trancl_domain)
+ apply (metis Domain_RAG_threads assms(3))
+ apply(simp only: RAG2_def wq_def)
+ apply (metis Domain_iff)
+ apply(simp)
+ done
+ then show "th1 = th2"
+ apply -
+ apply(insert th0_in assms(1, 2))[1]
+ apply(simp add: S1_def S2_def)
+ apply(auto)
+ --"first case"
+ prefer 2
+ apply(subgoal_tac "Th th2 \<in> Domain (RAG2 s)")
+ apply(subgoal_tac "\<exists>cs. (Th th2, Cs cs) \<in> RAG2 s")
+ apply(erule exE)
+ apply(simp add: runing_def RAG2_def RAG_def readys_def waits2_def)[1]
+ apply(auto simp add: RAG2_def RAG_def)[1]
+ apply(subgoal_tac "Th th2 \<in> Domain ((RAG2 s)^+)")
+ apply (metis trancl_domain)
+ apply(subgoal_tac "(Th th2, Th th1) \<in> (RAG2 s)^+")
+ apply (metis Domain_iff)
+ apply(simp add: dependants_def RAG2_def wq_def)
+ --"second case"
+ apply(subgoal_tac "Th th1 \<in> Domain (RAG2 s)")
+ apply(subgoal_tac "\<exists>cs. (Th th1, Cs cs) \<in> RAG2 s")
+ apply(erule exE)
+ apply(insert assms(1))[1]
+ apply(simp add: runing_def RAG2_def RAG_def readys_def waits2_def)[1]
+ apply(auto simp add: RAG2_def RAG_def)[1]
+ apply(subgoal_tac "Th th1 \<in> Domain ((RAG2 s)^+)")
+ apply (metis trancl_domain)
+ apply(subgoal_tac "(Th th1, Th th2) \<in> (RAG2 s)^+")
+ apply (metis Domain_iff)
+ apply(simp add: dependants_def RAG2_def wq_def)
+ --"third case"
+ apply(rule dchain_unique)
+ apply(rule assms(3))
+ apply(simp add: dependants_def RAG2_def wq_def)
+ apply(simp)
+ apply(simp add: dependants_def RAG2_def wq_def)
+ apply(simp)
+ done
+next
+ assume "th1 = th2"
+ then show "cpreced2 s th1 = cpreced2 s th2" by simp
+qed
+
+lemma at_most_one_running:
+ assumes "vt s"
+ shows "card (runing s) \<le> 1"
+proof (rule ccontr)
+ assume "\<not> card (runing s) \<le> 1"
+ then have "2 \<le> card (runing s)" by auto
+ moreover
+ have "finite (runing s)"
+ by (metis `\<not> card (runing s) \<le> 1` card_infinite le0)
+ ultimately obtain th1 th2 where a:
+ "th1 \<noteq> th2" "th1 \<in> runing s" "th2 \<in> runing s"
+ "cpreced2 s th1 = cpreced2 s th2"
+ apply(auto simp add: numerals card_le_Suc_iff runing_def)
+ apply(blast)
+ done
+ then have "th1 = th2"
+ apply(subst (asm) cpreced_eq_iff)
+ apply(auto intro: assms a)
+ apply (metis contra_subsetD runing_ready)+
+ done
+ then show "False" using a(1) by auto
+qed
+
+
+
+ (*
+ obtain th0 where th0_in: "th0 \<in> S1 \<and> th0 \<in> S2"
+ and eq_f_th0: "preced th0 s = Max ((\<lambda>th. preced th s) ` (S1 \<inter> S2))"
+ proof -
+ from fin have h1: "finite ((\<lambda>th. preced th s) ` (S1 \<inter> S2))"
+ apply(simp only: S1_def S2_def)
+ apply(rule)
+ apply(rule)
+ apply(rule)
+ apply(simp add: dependants_def)
+ apply(rule rev_finite_subset)
+ apply(assumption)
+ apply(auto simp add: image_def)
+ apply (metis fst_conv the_th.simps)
+ done
+ moreover
+ have "S1 \<inter> S2 \<noteq> {}" apply (simp add: S1_def S2_def)
+ apply(auto)
+
+ done
+ then have h2: "((\<lambda>th. preced th s) ` (S1 \<union> S2)) \<noteq> {}" by simp
+ ultimately have "Max ((\<lambda>th. preced th s) ` (S1 \<union> S2)) \<in> ((\<lambda>th. preced th s) ` (S1 \<union> S2))"
+ apply(rule Max_in)
+ done
+ then show ?thesis using that[intro] apply(auto)
+
+ apply(erule_tac preced_unique)
+ done
+ qed
+ *)
+
+thm waits_def waits2_def
+
+end
\ No newline at end of file
Binary file journal.pdf has changed
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/red_1.thy Wed Jan 27 13:50:02 2016 +0000
@@ -0,0 +1,359 @@
+section {*
+ This file contains lemmas used to guide the recalculation of current precedence
+ after every system call (or system operation)
+*}
+theory CpsG
+imports PrioG Max RTree
+begin
+
+
+definition "wRAG (s::state) = {(Th th, Cs cs) | th cs. waiting s th cs}"
+
+definition "hRAG (s::state) = {(Cs cs, Th th) | th cs. holding s th cs}"
+
+definition "tRAG s = wRAG s O hRAG s"
+
+definition "pairself f = (\<lambda>(a, b). (f a, f b))"
+
+definition "rel_map f r = (pairself f ` r)"
+
+fun the_thread :: "node \<Rightarrow> thread" where
+ "the_thread (Th th) = th"
+
+definition "tG s = rel_map the_thread (tRAG s)"
+
+locale pip =
+ fixes s
+ assumes vt: "vt s"
+
+
+lemma RAG_split: "RAG s = (wRAG s \<union> hRAG s)"
+ by (unfold s_RAG_abv wRAG_def hRAG_def s_waiting_abv
+ s_holding_abv cs_RAG_def, auto)
+
+lemma relpow_mult:
+ "((r::'a rel) ^^ m) ^^ n = r ^^ (m*n)"
+proof(induct n arbitrary:m)
+ case (Suc k m)
+ thus ?case (is "?L = ?R")
+ proof -
+ have h: "(m * k + m) = (m + m * k)" by auto
+ show ?thesis
+ apply (simp add:Suc relpow_add[symmetric])
+ by (unfold h, simp)
+ qed
+qed simp
+
+lemma compose_relpow_2:
+ assumes "r1 \<subseteq> r"
+ and "r2 \<subseteq> r"
+ shows "r1 O r2 \<subseteq> r ^^ (2::nat)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> r1 O r2"
+ then obtain e where "(a, e) \<in> r1" "(e, b) \<in> r2"
+ by auto
+ with assms have "(a, e) \<in> r" "(e, b) \<in> r" by auto
+ hence "(a, b) \<in> r ^^ (Suc (Suc 0))" by auto
+ } thus ?thesis by (auto simp:numeral_2_eq_2)
+qed
+
+
+lemma acyclic_compose:
+ assumes "acyclic r"
+ and "r1 \<subseteq> r"
+ and "r2 \<subseteq> r"
+ shows "acyclic (r1 O r2)"
+proof -
+ { fix a
+ assume "(a, a) \<in> (r1 O r2)^+"
+ from trancl_mono[OF this compose_relpow_2[OF assms(2, 3)]]
+ have "(a, a) \<in> (r ^^ 2) ^+" .
+ from trancl_power[THEN iffD1, OF this]
+ obtain n where h: "(a, a) \<in> (r ^^ 2) ^^ n" "n > 0" by blast
+ from this(1)[unfolded relpow_mult] have h2: "(a, a) \<in> r ^^ (2 * n)" .
+ have "(a, a) \<in> r^+"
+ proof(cases rule:trancl_power[THEN iffD2])
+ from h(2) h2 show "\<exists>n>0. (a, a) \<in> r ^^ n"
+ by (rule_tac x = "2*n" in exI, auto)
+ qed
+ with assms have "False" by (auto simp:acyclic_def)
+ } thus ?thesis by (auto simp:acyclic_def)
+qed
+
+lemma range_tRAG: "Range (tRAG s) \<subseteq> {Th th | th. True}"
+proof -
+ have "Range (wRAG s O hRAG s) \<subseteq> {Th th |th. True}" (is "?L \<subseteq> ?R")
+ proof -
+ have "?L \<subseteq> Range (hRAG s)" by auto
+ also have "... \<subseteq> ?R"
+ by (unfold hRAG_def, auto)
+ finally show ?thesis by auto
+ qed
+ thus ?thesis by (simp add:tRAG_def)
+qed
+
+lemma domain_tRAG: "Domain (tRAG s) \<subseteq> {Th th | th. True}"
+proof -
+ have "Domain (wRAG s O hRAG s) \<subseteq> {Th th |th. True}" (is "?L \<subseteq> ?R")
+ proof -
+ have "?L \<subseteq> Domain (wRAG s)" by auto
+ also have "... \<subseteq> ?R"
+ by (unfold wRAG_def, auto)
+ finally show ?thesis by auto
+ qed
+ thus ?thesis by (simp add:tRAG_def)
+qed
+
+lemma rel_mapE:
+ assumes "(a, b) \<in> rel_map f r"
+ obtains c d
+ where "(c, d) \<in> r" "(a, b) = (f c, f d)"
+ using assms
+ by (unfold rel_map_def pairself_def, auto)
+
+lemma rel_mapI:
+ assumes "(a, b) \<in> r"
+ and "c = f a"
+ and "d = f b"
+ shows "(c, d) \<in> rel_map f r"
+ using assms
+ by (unfold rel_map_def pairself_def, auto)
+
+lemma map_appendE:
+ assumes "map f zs = xs @ ys"
+ obtains xs' ys'
+ where "zs = xs' @ ys'" "xs = map f xs'" "ys = map f ys'"
+proof -
+ have "\<exists> xs' ys'. zs = xs' @ ys' \<and> xs = map f xs' \<and> ys = map f ys'"
+ using assms
+ proof(induct xs arbitrary:zs ys)
+ case (Nil zs ys)
+ thus ?case by auto
+ next
+ case (Cons x xs zs ys)
+ note h = this
+ show ?case
+ proof(cases zs)
+ case (Cons e es)
+ with h have eq_x: "map f es = xs @ ys" "x = f e" by auto
+ from h(1)[OF this(1)]
+ obtain xs' ys' where "es = xs' @ ys'" "xs = map f xs'" "ys = map f ys'"
+ by blast
+ with Cons eq_x
+ have "zs = (e#xs') @ ys' \<and> x # xs = map f (e#xs') \<and> ys = map f ys'" by auto
+ thus ?thesis by metis
+ qed (insert h, auto)
+ qed
+ thus ?thesis by (auto intro!:that)
+qed
+
+lemma rel_map_mono:
+ assumes "r1 \<subseteq> r2"
+ shows "rel_map f r1 \<subseteq> rel_map f r2"
+ using assms
+ by (auto simp:rel_map_def pairself_def)
+
+lemma rel_map_compose [simp]:
+ shows "rel_map f1 (rel_map f2 r) = rel_map (f1 o f2) r"
+ by (auto simp:rel_map_def pairself_def)
+
+lemma edges_on_map: "edges_on (map f xs) = rel_map f (edges_on xs)"
+proof -
+ { fix a b
+ assume "(a, b) \<in> edges_on (map f xs)"
+ then obtain l1 l2 where eq_map: "map f xs = l1 @ [a, b] @ l2"
+ by (unfold edges_on_def, auto)
+ hence "(a, b) \<in> rel_map f (edges_on xs)"
+ by (auto elim!:map_appendE intro!:rel_mapI simp:edges_on_def)
+ } moreover {
+ fix a b
+ assume "(a, b) \<in> rel_map f (edges_on xs)"
+ then obtain c d where
+ h: "(c, d) \<in> edges_on xs" "(a, b) = (f c, f d)"
+ by (elim rel_mapE, auto)
+ then obtain l1 l2 where
+ eq_xs: "xs = l1 @ [c, d] @ l2"
+ by (auto simp:edges_on_def)
+ hence eq_map: "map f xs = map f l1 @ [f c, f d] @ map f l2" by auto
+ have "(a, b) \<in> edges_on (map f xs)"
+ proof -
+ from h(2) have "[f c, f d] = [a, b]" by simp
+ from eq_map[unfolded this] show ?thesis by (auto simp:edges_on_def)
+ qed
+ } ultimately show ?thesis by auto
+qed
+
+lemma plus_rpath:
+ assumes "(a, b) \<in> r^+"
+ obtains xs where "rpath r a xs b" "xs \<noteq> []"
+proof -
+ from assms obtain m where h: "(a, m) \<in> r" "(m, b) \<in> r^*"
+ by (auto dest!:tranclD)
+ from star_rpath[OF this(2)] obtain xs where "rpath r m xs b" by auto
+ from rstepI[OF h(1) this] have "rpath r a (m # xs) b" .
+ from that[OF this] show ?thesis by auto
+qed
+
+lemma edges_on_unfold:
+ "edges_on (a # b # xs) = {(a, b)} \<union> edges_on (b # xs)" (is "?L = ?R")
+proof -
+ { fix c d
+ assume "(c, d) \<in> ?L"
+ then obtain l1 l2 where h: "(a # b # xs) = l1 @ [c, d] @ l2"
+ by (auto simp:edges_on_def)
+ have "(c, d) \<in> ?R"
+ proof(cases "l1")
+ case Nil
+ with h have "(c, d) = (a, b)" by auto
+ thus ?thesis by auto
+ next
+ case (Cons e es)
+ from h[unfolded this] have "b#xs = es@[c, d]@l2" by auto
+ thus ?thesis by (auto simp:edges_on_def)
+ qed
+ } moreover
+ { fix c d
+ assume "(c, d) \<in> ?R"
+ moreover have "(a, b) \<in> ?L"
+ proof -
+ have "(a # b # xs) = []@[a,b]@xs" by simp
+ hence "\<exists> l1 l2. (a # b # xs) = l1@[a,b]@l2" by auto
+ thus ?thesis by (unfold edges_on_def, simp)
+ qed
+ moreover {
+ assume "(c, d) \<in> edges_on (b#xs)"
+ then obtain l1 l2 where "b#xs = l1@[c, d]@l2" by (unfold edges_on_def, auto)
+ hence "a#b#xs = (a#l1)@[c,d]@l2" by simp
+ hence "\<exists> l1 l2. (a # b # xs) = l1@[c,d]@l2" by metis
+ hence "(c,d) \<in> ?L" by (unfold edges_on_def, simp)
+ }
+ ultimately have "(c, d) \<in> ?L" by auto
+ } ultimately show ?thesis by auto
+qed
+
+lemma edges_on_rpathI:
+ assumes "edges_on (a#xs@[b]) \<subseteq> r"
+ shows "rpath r a (xs@[b]) b"
+ using assms
+proof(induct xs arbitrary: a b)
+ case Nil
+ moreover have "(a, b) \<in> edges_on (a # [] @ [b])"
+ by (unfold edges_on_def, auto)
+ ultimately have "(a, b) \<in> r" by auto
+ thus ?case by auto
+next
+ case (Cons x xs a b)
+ from this(2) have "edges_on (x # xs @ [b]) \<subseteq> r" by (simp add:edges_on_unfold)
+ from Cons(1)[OF this] have " rpath r x (xs @ [b]) b" .
+ moreover from Cons(2) have "(a, x) \<in> r" by (auto simp:edges_on_unfold)
+ ultimately show ?case by (auto intro!:rstepI)
+qed
+
+lemma image_id:
+ assumes "\<And> x. x \<in> A \<Longrightarrow> f x = x"
+ shows "f ` A = A"
+ using assms by (auto simp:image_def)
+
+lemma rel_map_inv_id:
+ assumes "inj_on f ((Domain r) \<union> (Range r))"
+ shows "(rel_map (inv_into ((Domain r) \<union> (Range r)) f \<circ> f) r) = r"
+proof -
+ let ?f = "(inv_into (Domain r \<union> Range r) f \<circ> f)"
+ {
+ fix a b
+ assume h0: "(a, b) \<in> r"
+ have "pairself ?f (a, b) = (a, b)"
+ proof -
+ from assms h0 have "?f a = a" by (auto intro:inv_into_f_f)
+ moreover have "?f b = b"
+ by (insert h0, simp, intro inv_into_f_f[OF assms], auto intro!:RangeI)
+ ultimately show ?thesis by (auto simp:pairself_def)
+ qed
+ } thus ?thesis by (unfold rel_map_def, intro image_id, case_tac x, auto)
+qed
+
+lemma rel_map_acyclic:
+ assumes "acyclic r"
+ and "inj_on f ((Domain r) \<union> (Range r))"
+ shows "acyclic (rel_map f r)"
+proof -
+ let ?D = "Domain r \<union> Range r"
+ { fix a
+ assume "(a, a) \<in> (rel_map f r)^+"
+ from plus_rpath[OF this]
+ obtain xs where rp: "rpath (rel_map f r) a xs a" "xs \<noteq> []" by auto
+ from rpath_nnl_lastE[OF this] obtain xs' where eq_xs: "xs = xs'@[a]" by auto
+ from rpath_edges_on[OF rp(1)]
+ have h: "edges_on (a # xs) \<subseteq> rel_map f r" .
+ from edges_on_map[of "inv_into ?D f" "a#xs"]
+ have "edges_on (map (inv_into ?D f) (a # xs)) = rel_map (inv_into ?D f) (edges_on (a # xs))" .
+ with rel_map_mono[OF h, of "inv_into ?D f"]
+ have "edges_on (map (inv_into ?D f) (a # xs)) \<subseteq> rel_map ((inv_into ?D f) o f) r" by simp
+ from this[unfolded eq_xs]
+ have subr: "edges_on (map (inv_into ?D f) (a # xs' @ [a])) \<subseteq> rel_map (inv_into ?D f \<circ> f) r" .
+ have "(map (inv_into ?D f) (a # xs' @ [a])) = (inv_into ?D f a) # map (inv_into ?D f) xs' @ [inv_into ?D f a]"
+ by simp
+ from edges_on_rpathI[OF subr[unfolded this]]
+ have "rpath (rel_map (inv_into ?D f \<circ> f) r)
+ (inv_into ?D f a) (map (inv_into ?D f) xs' @ [inv_into ?D f a]) (inv_into ?D f a)" .
+ hence "(inv_into ?D f a, inv_into ?D f a) \<in> (rel_map (inv_into ?D f \<circ> f) r)^+"
+ by (rule rpath_plus, simp)
+ moreover have "(rel_map (inv_into ?D f \<circ> f) r) = r" by (rule rel_map_inv_id[OF assms(2)])
+ moreover note assms(1)
+ ultimately have False by (unfold acyclic_def, auto)
+ } thus ?thesis by (auto simp:acyclic_def)
+qed
+
+context pip
+begin
+
+interpretation rtree_RAG: rtree "RAG s"
+proof
+ show "single_valued (RAG s)"
+ by (unfold single_valued_def, auto intro: unique_RAG[OF vt])
+
+ show "acyclic (RAG s)"
+ by (rule acyclic_RAG[OF vt])
+qed
+
+lemma sgv_wRAG:
+ shows "single_valued (wRAG s)"
+ using waiting_unique[OF vt]
+ by (unfold single_valued_def wRAG_def, auto)
+
+lemma sgv_hRAG:
+ shows "single_valued (hRAG s)"
+ using held_unique
+ by (unfold single_valued_def hRAG_def, auto)
+
+lemma sgv_tRAG: shows "single_valued (tRAG s)"
+ by (unfold tRAG_def, rule Relation.single_valued_relcomp,
+ insert sgv_hRAG sgv_wRAG, auto)
+
+lemma acyclic_hRAG:
+ shows "acyclic (hRAG s)"
+ by (rule acyclic_subset[OF acyclic_RAG[OF vt]], insert RAG_split, auto)
+
+lemma acyclic_wRAG:
+ shows "acyclic (wRAG s)"
+ by (rule acyclic_subset[OF acyclic_RAG[OF vt]], insert RAG_split, auto)
+
+lemma acyclic_tRAG:
+ shows "acyclic (tRAG s)"
+ by (unfold tRAG_def, rule acyclic_compose[OF acyclic_RAG[OF vt]],
+ unfold RAG_split, auto)
+
+lemma acyclic_tG:
+ shows "acyclic (tG s)"
+proof(unfold tG_def, rule rel_map_acyclic[OF acyclic_tRAG])
+ show "inj_on the_thread (Domain (tRAG s) \<union> Range (tRAG s))"
+ proof(rule subset_inj_on)
+ show " inj_on the_thread {Th th |th. True}" by (unfold inj_on_def, auto)
+ next
+ from domain_tRAG range_tRAG
+ show " Domain (tRAG s) \<union> Range (tRAG s) \<subseteq> {Th th |th. True}" by auto
+ qed
+qed
+
+end
Binary file scripts_structure.pdf has changed
Binary file scripts_structure.pptx has changed