diff -r 0cdd6729a962 -r 31f9e5ada550 src/HOL/Library/While_Combinator.thy --- a/src/HOL/Library/While_Combinator.thy Mon Nov 04 22:05:20 2024 +0100 +++ b/src/HOL/Library/While_Combinator.thy Mon Nov 04 22:36:42 2024 +0100 @@ -33,7 +33,7 @@ also have "... = Suc (LEAST l. \ b ((c ^^ l) (c s)))" by (simp add: funpow_swap1) finally - show ?thesis + show ?thesis using True 2 \b s\ by (simp add: funpow_swap1 while_option_def) next case False @@ -46,9 +46,9 @@ assume [simp]: "\ b s" have least: "(LEAST k. \ b ((c ^^ k) s)) = 0" by (rule Least_equality) auto - moreover + moreover have "\k. \ b ((c ^^ k) s)" by (rule exI[of _ "0::nat"]) auto - ultimately show ?thesis unfolding while_option_def by auto + ultimately show ?thesis unfolding while_option_def by auto qed lemma while_option_stop2: @@ -60,23 +60,22 @@ by(metis while_option_stop2) theorem while_option_rule: - assumes step: "!!s. P s ==> b s ==> P (c s)" + assumes step: "\s. P s \ b s \ P (c s)" and result: "while_option b c s = Some t" and init: "P s" shows "P t" proof - define k where "k = (LEAST k. \ b ((c ^^ k) s))" from assms have t: "t = (c ^^ k) s" - by (simp add: while_option_def k_def split: if_splits) + by (simp add: while_option_def k_def split: if_splits) have 1: "\i k" then have "P ((c ^^ i) s)" - by (induct i) (auto simp: init step 1) } + have "P ((c ^^ i) s)" if "i \ k" for i + using that by (induct i) (auto simp: init step 1) thus "P t" by (auto simp: t) qed -lemma funpow_commute: +lemma funpow_commute: "\\k' < k. f (c ((c^^k') s)) = c' (f ((c^^k') s))\ \ f ((c^^k) s) = (c'^^k) (f s)" by (induct k arbitrary: s) auto @@ -138,23 +137,26 @@ have "\ b' ((c' ^^ Suc k') (f s))" unfolding Suc[symmetric] by (rule LeastI) (rule k) moreover - { fix k assume "k \ k'" - hence "k < ?k'" unfolding Suc by simp - hence "b' ((c' ^^ k) (f s))" by (rule iffD1[OF not_not, OF not_less_Least]) - } - note b' = this - { fix k assume "k \ k'" - hence "f ((c ^^ k) s) = (c' ^^ k) (f s)" - and "b ((c ^^ k) s) = b' ((c' ^^ k) (f s))" - and "P ((c ^^ k) s)" + have b': "b' ((c' ^^ k) (f s))" if "k \ k'" for k + proof - + from that have "k < ?k'" unfolding Suc by simp + thus ?thesis by (rule iffD1[OF not_not, OF not_less_Least]) + qed + have b: "b ((c ^^ k) s)" + and body: "f ((c ^^ k) s) = (c' ^^ k) (f s)" + and inv: "P ((c ^^ k) s)" + if "k \ k'" for k + proof - + from that have "f ((c ^^ k) s) = (c' ^^ k) (f s)" + and "b ((c ^^ k) s) = b' ((c' ^^ k) (f s))" + and "P ((c ^^ k) s)" by (induct k) (auto simp: b' assms) with \k \ k'\ - have "b ((c ^^ k) s)" - and "f ((c ^^ k) s) = (c' ^^ k) (f s)" - and "P ((c ^^ k) s)" + show "b ((c ^^ k) s)" + and "f ((c ^^ k) s) = (c' ^^ k) (f s)" + and "P ((c ^^ k) s)" by (auto simp: b') - } - note b = this(1) and body = this(2) and inv = this(3) + qed hence k': "f ((c ^^ k') s) = (c' ^^ k') (f s)" by auto ultimately show ?thesis unfolding Suc using b proof (intro Least_equality[symmetric], goal_cases) @@ -188,7 +190,7 @@ qed lemma while_option_commute: - assumes "\s. b s = b' (f s)" "\s. \b s\ \ f (c s) = c' (f s)" + assumes "\s. b s = b' (f s)" "\s. \b s\ \ f (c s) = c' (f s)" shows "map_option f (while_option b c s) = while_option b' c' (f s)" by(rule while_option_commute_invariant[where P = "\_. True"]) (auto simp add: assms) @@ -213,8 +215,8 @@ \ theorem while_rule_lemma: - assumes invariant: "!!s. P s ==> b s ==> P (c s)" - and terminate: "!!s. P s ==> \ b s ==> Q s" + assumes invariant: "\s. P s \ b s \ P (c s)" + and terminate: "\s. P s \ \ b s \ Q s" and wf: "wf {(t, s). P s \ b s \ t = c s}" shows "P s \ Q (while b c s)" using wf @@ -225,11 +227,11 @@ done theorem while_rule: - "[| P s; - !!s. [| P s; b s |] ==> P (c s); - !!s. [| P s; \ b s |] ==> Q s; + "\P s; + \s. \P s; b s\ \ P (c s); + \s. \P s; \ b s\ \ Q s; wf r; - !!s. [| P s; b s |] ==> (c s, s) \ r |] ==> + \s. \P s; b s\ \ (c s, s) \ r\ \ Q (while b c s)" apply (rule while_rule_lemma) prefer 4 apply assumption @@ -241,10 +243,10 @@ text \Combine invariant preservation and variant decrease in one goal:\ theorem while_rule2: - "[| P s; - !!s. [| P s; b s |] ==> P (c s) \ (c s, s) \ r; - !!s. [| P s; \ b s |] ==> Q s; - wf r |] ==> + "\P s; + \s. \P s; b s\ \ P (c s) \ (c s, s) \ r; + \s. \P s; \ b s\ \ Q s; + wf r\ \ Q (while b c s)" using while_rule[of P] by metis @@ -281,7 +283,7 @@ bounding set:\ lemma while_option_finite_subset_Some: fixes C :: "'a set" - assumes "mono f" and "!!X. X \ C \ f X \ C" and "finite C" + assumes "mono f" and "\X. X \ C \ f X \ C" and "finite C" shows "\P. while_option (\A. f A \ A) f {} = Some P" proof(rule measure_while_option_Some[where f= "%A::'a set. card C - card A" and P= "%A. A \ C \ A \ f A" and s= "{}"]) @@ -289,13 +291,13 @@ show "(f A \ C \ f A \ f (f A)) \ card C - card (f A) < card C - card A" (is "?L \ ?R") proof - show ?L by(metis A(1) assms(2) monoD[OF \mono f\]) + show ?L by (metis A(1) assms(2) monoD[OF \mono f\]) show ?R by (metis A assms(2,3) card_seteq diff_less_mono2 equalityI linorder_le_less_linear rev_finite_subset) qed qed simp lemma lfp_the_while_option: - assumes "mono f" and "!!X. X \ C \ f X \ C" and "finite C" + assumes "mono f" and "\X. X \ C \ f X \ C" and "finite C" shows "lfp f = the(while_option (\A. f A \ A) f {})" proof- obtain P where "while_option (\A. f A \ A) f {} = Some P" @@ -305,7 +307,7 @@ qed lemma lfp_while: - assumes "mono f" and "!!X. X \ C \ f X \ C" and "finite C" + assumes "mono f" and "\X. X \ C \ f X \ C" and "finite C" shows "lfp f = while (\A. f A \ A) f {}" unfolding while_def using assms by (rule lfp_the_while_option) blast @@ -377,9 +379,9 @@ and the AFP article Executable Transitive Closures by René Thiemann.\ context -fixes p :: "'a \ bool" -and f :: "'a \ 'a list" -and x :: 'a + fixes p :: "'a \ bool" + and f :: "'a \ 'a list" + and x :: 'a begin qualified fun rtrancl_while_test :: "'a list \ 'a set \ bool" @@ -398,32 +400,35 @@ (x \ Z \ set ws \ Z \ distinct ws \ {(x,y). y \ set(f x)} `` (Z - set ws) \ Z \ Z \ {(x,y). y \ set(f x)}\<^sup>* `` {x} \ (\z\Z - set ws. p z))" -qualified lemma rtrancl_while_invariant: +qualified lemma rtrancl_while_invariant: assumes inv: "rtrancl_while_invariant st" and test: "rtrancl_while_test st" shows "rtrancl_while_invariant (rtrancl_while_step st)" proof (cases st) - fix ws Z assume st: "st = (ws, Z)" + fix ws Z + assume st: "st = (ws, Z)" with test obtain h t where "ws = h # t" "p h" by (cases ws) auto with inv st show ?thesis by (auto intro: rtrancl.rtrancl_into_rtrancl) qed -lemma rtrancl_while_Some: assumes "rtrancl_while = Some(ws,Z)" -shows "if ws = [] - then Z = {(x,y). y \ set(f x)}\<^sup>* `` {x} \ (\z\Z. p z) - else \p(hd ws) \ hd ws \ {(x,y). y \ set(f x)}\<^sup>* `` {x}" +lemma rtrancl_while_Some: + assumes "rtrancl_while = Some(ws,Z)" + shows "if ws = [] + then Z = {(x,y). y \ set(f x)}\<^sup>* `` {x} \ (\z\Z. p z) + else \p(hd ws) \ hd ws \ {(x,y). y \ set(f x)}\<^sup>* `` {x}" proof - have "rtrancl_while_invariant ([x],{x})" by simp with rtrancl_while_invariant have I: "rtrancl_while_invariant (ws,Z)" by (rule while_option_rule[OF _ assms[unfolded rtrancl_while_def]]) - { assume "ws = []" - hence ?thesis using I + show ?thesis + proof (cases "ws = []") + case True + thus ?thesis using I by (auto simp del:Image_Collect_case_prod dest: Image_closed_trancl) - } moreover - { assume "ws \ []" - hence ?thesis using I while_option_stop[OF assms[unfolded rtrancl_while_def]] + next + case False + thus ?thesis using I while_option_stop[OF assms[unfolded rtrancl_while_def]] by (simp add: subset_iff) - } - ultimately show ?thesis by simp + qed qed lemma rtrancl_while_finite_Some: @@ -434,26 +439,29 @@ have "wf ?R" by (blast intro: wf_mlex) then show ?thesis unfolding rtrancl_while_def proof (rule wf_rel_while_option_Some[of ?R rtrancl_while_invariant]) - fix st assume *: "rtrancl_while_invariant st \ rtrancl_while_test st" + fix st + assume *: "rtrancl_while_invariant st \ rtrancl_while_test st" hence I: "rtrancl_while_invariant (rtrancl_while_step st)" by (blast intro: rtrancl_while_invariant) show "(rtrancl_while_step st, st) \ ?R" proof (cases st) - fix ws Z let ?ws = "fst (rtrancl_while_step st)" and ?Z = "snd (rtrancl_while_step st)" + fix ws Z + let ?ws = "fst (rtrancl_while_step st)" + let ?Z = "snd (rtrancl_while_step st)" assume st: "st = (ws, Z)" with * obtain h t where ws: "ws = h # t" "p h" by (cases ws) auto - { assume "remdups (filter (\y. y \ Z) (f h)) \ []" + show ?thesis + proof (cases "remdups (filter (\y. y \ Z) (f h)) = []") + case False then obtain z where "z \ set (remdups (filter (\y. y \ Z) (f h)))" by fastforce with st ws I have "Z \ ?Z" "Z \ ?Cl" "?Z \ ?Cl" by auto with assms have "card (?Cl - ?Z) < card (?Cl - Z)" by (blast intro: psubset_card_mono) - with st ws have ?thesis unfolding mlex_prod_def by simp - } - moreover - { assume "remdups (filter (\y. y \ Z) (f h)) = []" + with st ws show ?thesis unfolding mlex_prod_def by simp + next + case True with st ws have "?Z = Z" "?ws = t" by (auto simp: filter_empty_conv) - with st ws have ?thesis unfolding mlex_prod_def by simp - } - ultimately show ?thesis by blast + with st ws show ?thesis unfolding mlex_prod_def by simp + qed qed qed (simp_all add: rtrancl_while_invariant) qed