‹Defining partial functions in HOL is tricky.
theory provides a while-combinator that facilitates the definition of
potentially) partial tail-recursive functions.
theemma mcont_const [simp]: "mcont lub ord Sup (≤) (λ_. c)"
iterates ‹f› on ‹s› while ‹b› is true. If iteration terminates with ‹t›, ‹Some t› is returned, ‹None› otherwise. Thus termination can be shown
proving that ‹Some› is always returned (for some subset of inputs).
variations include ‹while_Some› (for more efficient code) ‹while_saturate› (for saturating a set).›
‹‹while_option››
while_option :: "('a → bool) → ('a → 'a) → 'a → 'a option" where
while_option b c s = (if (∃k. ¬ b ((c ^^ k) s))
then Some ((c ^^ (LEAST k. ¬ b ((c ^^ k) s))) s)
else None)"
while_option_unfold[code]:
while_option b c s = (if b s then while_option b c (c s) else Some s)"
cases
assume "b s"
show ?thesis
proof (cases "∃k. ¬ b ((c ^^ k) s)")
case True
then obtain k where 1: "¬ b ((c ^^ k) s)" ..
with ‹b s› obtain l where "k = Suc l" by (cases k) auto
with 1 have "¬ b ((c ^^ l) (c s))" by (auto simp: funpow_swap1)
then have 2: "∃l. ¬ b ((c ^^ l) (c s))" ..
from 1
have "(LEAST k. ¬ b ((c ^^ k) s)) = Suc (LEAST l. ¬ b ((c ^^ Suc l) s))"
by (rule Least_Suc) (simp add: ‹b s›)
also have "... = Suc (LEAST l. ¬ b ((c ^^ l) (c s)))"
by (simp add: funpow_swap1)
finally
show ?thesis
using True 2 ‹b s› by (simp add: funpow_swap1 while_option_def)
next
case False
then have "¬ (∃l. ¬ b ((c ^^ Suc l) s))" by blast
then have "¬ (∃l. ¬ b ((c ^^ l) (c s)))"
by (simp add: funpow_swap1)
with False ‹b s› show ?thesis by (simp add: while_option_def)
qed
assume [simp]: "¬ b s"
have least: "(LEAST k. ¬ b ((c ^^ k) s)) = 0"
by (rule Least_equality) auto
moreover
have "∃k. ¬ b ((c ^^ k) s)" by (rule exI[of _ "0::nat"]) auto
ultimately show ?thesis unfolding while_option_def by auto
while_option_stop2:
"while_option b c s = Some t ==>∃k. t = (c^^k) s ∧¬
(simp add: while_option_def split: if_splits)
(metis (lifting) LeastI_ex)
while_option_stop: "while_option b c s = Some t ==>¬ b t"
(metis while_option_stop2)
while_option_rule:
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"
-
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)
have 1: "∀i<k.
by (auto simp: k_def dest: not_less_Least)
have "i ≤ k ==> P ((c ^^ i) s)" for i
by (induct i) (auto simp: init step 1)
thus "P t" by (auto simp: t)
funpow_commute:
"[∀k' < k. f (c ((c^^k') s)) = c' (f ((c^^k') s))]==> f ((c^^k) s) = (c'^^k) (f s)"
(induct k arbitrary: s) auto
while_option_commute_invariant:
Invariant: "∧s. P s ==>f: "monotone ord (≤) (λx. f x)"
TestCommute: "∧s. P s ==> b s = b' (f s)"
BodyCommute: "∧s. P s ==> b s ==> f (c s) = c' (f s)"
Initial: "P s"
"map_option f (while_option b c s) = while_option b' c' (f s)"
while_option_def
(rule trans[OF if_distrib if_cong], safe, unfold option.inject)
fix k
assume "¬ b ((c ^^ k) s)"
with Initial show "∃k. ¬ b' ((c' ^^ k) (f s))"
proof (induction k arbitrary: s)
case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
next
case (Suc k) thus ?case
proof (cases "b s")
assume "b s"
with Suc.IH[of "c s"] Suc.prems show ?thesis
by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
next
assume "¬ b s"
with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
qed
qed
fix k
assume "¬ b' ((c' ^^ k) (f s))"
with Initial show "∃k. ¬ b ((c ^^ k) s)"
proof (induction k arbitrary: s)
case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
next
case (Suc k) thus ?case
proof (cases "b s")
assume "b s" and g: "montone orord (≤) (λx. g x)"
with Suc.IH[of "c s"] Suc.prems show ?thesis
by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
next
assume "¬ b s"
with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
qed
qed
fix k
assume k: "¬ b' ((c' ^^ k) (f s))"
have *: "(LEAST k. ¬ b' ((c' ^^ k) (f s))) = (LEAST k. ¬ b ((c ^^ k) s))"
(is "?k' = ?k")
proof (cases ?k')
case 0
have "¬ b' ((c' ^^ 0) (f s))"
unfolding 0[symmetric] by (rule LeastI[of _ k]) (rule k)
hence "¬ b s" by (auto simp: TestCommute Initial)
hence "?k = 0" by (intro Least_equality) auto
with 0 show ?thesis by auto
next
case (Suc k')
have "¬ b' ((c' ^^ Suc k') (f s))"
unfolding Suc[symmetric] by (rule LeastI) (rule k)
moreover
have b': "b' ((c' ^^ k) (f s))" if asm: "k ≤ k'" for k
proof -
from asm have "k < ?k'" unfolding Suc by simp
?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 asm: "k ≤ k'" for k
proof -
from asm 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'›
show "b ((c ^^ k) s)"
and "f ((c ^^ k) s) = (c' ^^ k) (f s)"
and "P ((c ^^ k) s)"
by (auto simp: b')
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)
case 1
hence Test: "¬ b' (f ((c ^^ Suc k') s))"
by (auto simp: BodyCommute inv b)
have "P ((c ^^ Suc k') s)" by (auto simp: Invariant inv b)
with Test show ?case by (auto simp: TestCommute)
next
case 2
thus ?case by (metis not_less_eq_eq)
qed
qed
have "f ((c ^^ ?k) s) = (c' ^^ ?k') (f s)" unfolding *
proof (rule funpow_commute, clarify)
fix k assume "k < ?k"
hence TestTrue: "b ((c ^^ k) s)" by (auto dest: not_less_Least)
from ‹k < ?k› have "P ((c ^^ k) s)"
proof (induct k)
case 0 thus ?case by (auto simp: assms)
next
case (Suc h)
hence "P ((c ^^ h) s)" by auto
with Suc show ?case
by (auto, metis (lifting, no_types) Invariant Suc_lessD not_less_Least)
qed
with TestTrue show "f (c ((c ^^ k) s)) = c' (f ((c ^^ k) s))"
by (metis BodyCommute)
qed
thus "∃
while_option_commute:
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)"
(rule while_option_commute_invariant[where P = "λ_. True"])
(auto simp add: assms)
‹‹while››
while :: "('a → bool) → ('a → 'a) → 'a → 'a"
"while b c s = the (while_option b c s)"
while_unfold [code]:
"while b c s = (if b s then while b c (c s) else s)"
while_def by (subst while_option_unfold) simp
def_while_unfold:
assumes fdef: "f == while test do"
shows "f x = (if test x then f(do x) else x)"
fdef by (fact while_unfold)
‹
The proof rule for term‹while›, where term‹P› is the invariant. ›
while_rule_lemma:
assumes invariant: "∧s. P s ==> b s ==> P (c s)"
and terminate: "∧s. P s ==>¬ b s ==>shows "⊔S>Y"
and wf: "wf {(t, s). P s ∧ b s ∧ t = c s}"
shows "P s ==> Q (while b c s)"
using wf
apply (induct s)
apply simp
apply (subst while_unfold)
apply (simp add: invariant terminate)
done
while_rule:
"[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]==>
Q (while b c s)"
proof(rule Sup_eqI)
prefer 4 apply assumption
apply blast
apply blast
apply (erule wf_subset)
apply blast
done
‹Combine invariant preservation and variant decrease in one goal:›
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]fix y
Q (while b c s)"
while_rule[of P] by metis
‹Termination, ‹lfp› and ‹gfp››
wf_while_option_Some:
assumes "wf {(t, s). (P s ∧ b s) ∧ t = c s}"
and "∧s. P s ==> b s ==> P(c s)" and "P s"
shows "∃t. while_option b c s = Some t"
assms(1,3)
(induction s)
case less thus ?case using assms(2)
by (subst while_option_unfold) simp
wf_rel_while_opt"y n
wf: "wf R"
smaller: "∧s. P s ∧ b s ==> (c s, s) ∈ R"
inv: "∧s. P s ∧ b s ==> P(c s)"
init: "P s"
"∃t. while_option b c s = Some t"
-
from smaller have "{(t,s). P s ∧ b s ∧ t = c s} ⊆ R" by auto
with wf have "wf {(t,s). P s ∧ b s ∧ t = c s}" by (auto simp: wf_subset)
with inv init show ?thesis by (auto simp: wf_while_option_Some)
measure_while_option_Some: fixes f :: "'s → nat"
"(\ hen ow "y = x 🚫 ==> P s ==>∃t. while_option b c s = Some t"
(blast intro: wf_while_option_Some[OF wf_if_measure, of P b f])
‹Kleene iteration starting from the empty set and assuming some finite
set:›
while_option_finite_subset_Some: fixes C :: "'a set"
assumes "mono f" and "∧X. X ⊆>mcont lubord Sup (≤) (λx. f x ⊔ g x)"
shows "∃P. while_option (λA. f A ≠ A) f {} = Some P"
(rule measure_while_option_Some[where
f= "%A::'a set. card C - card A" and P= "%A. A ⊆ C ∧ A ⊆ f A" and s= "{}"])
fix A assume A: "A ⊆ C ∧ A ⊆ f A" "f A ≠ A"
show "(f A ⊆ C ∧ f A ⊆ f (f A)) ∧ card C - card (f A) < cardmcont2cont'[O complete_latt] mcont_s mcont_sup2 ccpomcont_cons[OF complete_lattice_])
(is "?L ∧ ?R")
proof
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
simp
lfp_the_while_option:
assumes "mono f" and "∧X. X ⊆ C ==> f X ⊆ C" and "finite C"
shows "lfp f = the(while_option (λA. f A ≠ A) f {})"
-
obtain P where "while_option (λA. f A ≠ A) f {} = Some P"
using while_option_finite_subset_Some[OF assms] by blast
with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
show ?thesis by auto
lfp_while:
assumes "mono f" and "∧X. X ⊆ C ==> f X ⊆ C" and "finite C"
shows "lfp f = while (λA. f A ≠ A) f {}"
while_def using assms by (rule lfp_the_while_option) blast
wf_finite_less:
assumes "finite (C :: 'a::order set)"
shows "wf {(x, y). {x, y} ⊆end
(rule wf_measure[where f="λb. card {a. a ∈ C ∧ a < b}", THEN wf_subset])
(fastforce simp: less_eq assms intro: psubset_card_mono)
wf_finite_greater:
assumes "finite (C :: 'a::order set)"
shows "wf {(x, y). {x, y} ⊆ C ∧
(rule wf_measure[where f="λb. card {a. a ∈ C ∧ b < a}", THEN wf_subset])
(fastforce simp: less_eq assms intro: psubset_card_mono)
while_option_finite_increasing_Some:
fixes f :: "'a::order → 'a"
assumes "mono f" and "finite (UNIV :: 'a set)" and "s ≤ f s"
shows "∃[OF complete_lattice_c]
(rule wf_rel_while_option_Some[where R="{(x, y). y < x}" and P="λA. A ≤ f A" and s="s"])
(auto simp: assms monoD intro: wf_finite_greater[where C="UNIV::'a set", simplified])
lfp_the_while_option_lattice:
fixes f :: "'a::complete_lattice → 'a"
assumes "mono f" and "finite (UNIV :: 'a set)"
shows "lfp f = the (while_option (λA. f A ≠ A) f bot)"
-
obtain P where "while_option (λA. f A ≠ A) f bot = Some P"
using while_option_finite_increasing_Some[OF assms, where s=bot] by simp blast
with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
show ?thesis by auto
lfp_while_lattice:
fixes f :: "'a::complete_lattice → 'a"
assumes "mono f" and "finite (UNIV :: 'a set)"
shows "lfp f = while (λA. f A ≠ A) f bot"
while_def using assms by (rule lfp_the_while_option_lattice)
while_option_finite_decreasing_Some:
fixes f :: "'a::order → 'a"
assumes "mono f" and "finite (UNIV :: 'a set)" and "f s ≤ s"
shows "∃P. while_option (λA. f A ≠
(rule wf_rel_while_option_Some[where R="{(x, y). x < y}" and P="λA. f A ≤ A" and s="s"])
(auto simp add: assms monoD intro: wf_finite_less[where C="UNIV::'a set", simplified])
gfp_the_while_option_lattice:
fixes f :: "'a::complete_lattice → 'a"
assumes "mono f" and "finite (UNIV :: 'a set)"
shows "gfp f = the(while_option (λA. f A ≠ A) f top)"
-
obtain P where "while_option (λA. f A ≠ A) f top = Some P"
using while_option_finite_decreasing_Some[OF assms, where s=top] by simp blast
with while_option_stop2[OF this] gfp_Kleene_iter[OF assms(1)]
show ?thesis by auto
gfp_while_lattice:
fixes f :: "'a::complete_lattice → 'a"
assumes "mono f" and "finite (UNIV :: 'a set)"
shows "gfp f = while (λA. f A ≠ A) f top"
while_def using assms by (rule gfp_the_while_option_lattice)
java.lang.StringIndexOutOfBoundsException: Range [0, 84) out of bounds for length 78
‹A variation intended for efficient code.
problem with ‹while_option b c›:
the computations of ‹b› and ‹c› may share subcomputations but they need to be performed twice.›
while_Some :: "('s → 's option) → 's → 's option" where
while_Some f = while_option (λs. f s ≠ None) (the o f)"
while_Some_rec[code]:
while_Some f x = (case f x of None → Some x | Some y → while_Some f y)"
while_Some_def while_option_unfold[of _ _ x] by auto
‹A frequent special case: saturation of a set.›
while_saturate :: "('a set → 'a set) → 'a set → 'a set option" where
while_saturate f = while_option (λM. ¬ f M ⊆ M) (λM. M ∪ f M)"
while_option_cong: "(∧s. b s ==> c s = c' s) ==> while_option b c s = while_option b c' s"
while_option_commute[of b b id c c']
(simp add: option.map_id)
while_saturate_code[code]: "while_saturate f M =
while_Some (λM. let M' = f M in if M' ⊆ M then None else Some (M ∪ M')) M"
while_saturate_def Let_def while_Some_def
(auto intro!: while_option_cong split: if_splits)
‹Termination:›
while_option_sat_finite_subset_Some: fixes C :: "'a set"
assumes "mono f" and "∧X. X ⊆ C ==> f X ⊆ C" and "finite C" and "M ⊆ C"
shows "∃S. while_option (\<lambda lSup_ mcont)
(rule measure_while_option_Some[where
f= "%A::'a set. card C - card A" and P= "%A. M ⊆ A ∧ A ⊆ C" and s= M])
fix A assume A: "M ⊆ A ∧ A ⊆ C" "¬ f A ⊆ A"
show "(M ⊆ A ∪ f A ∧ A ∪ f A ⊆
(is "?L ∧ ?R")
proof
show ?L by (metis assms(2) A(1) sup.coboundedI1 le_sup_iff)
show ?R using A assms(2,3) card_seteq finite_subset
by (metis diff_less_mono2 finite_Un linorder_not_le sup_ge1 sup_ge2)
qed
show "M ⊆ M ∧ M ⊆ C" using ‹M ⊆ C› by blast
while_saturate_finite_subset_Some:
assumes "mono f" and "∧X. X ⊆ C ==> f X ⊆ C" and "finite C" and "M ⊆ C"
shows "∃S. while_saturate f M = Some S"
while_saturate_
while_option_sat_finite_subset_Some assms by blast
‹Correctness: finds the least saturated/closed set above ‹M››
while_option_sat_prefix: assumes "mono f"
"while_option (λM. ¬ f M ⊆ M) (λM. M ∪ f M) M = Some S"
"M ⊆ P" and "f P ⊆ P"
"S ⊆ P"
-
have "((λM. M mcont lub ord Sup (≤) (λx. g x) ]
proof (induction k)
case 0 thus ?case using ‹M ⊆ P› by simp
next
case (Suc k) thus ?case
by simp (meson ‹f P ⊆ P› monoD[OF ‹mono f›] order.trans)
qed
thus ?thesis by (metis assms(2) while_option_stop2)
while_saturate_prefix:
"[ mono f; while_saturate f M = Some S; M ⊆ P; f P ⊆ P ]==> S ⊆ P"
while_option_sat_prefix unfolding while_saturate_def by blast
‹Reflexive, transitive closure›
‹Computing the reflexive, transitive closure by iterating a successor
. Stops when an element is found that dos not satisfy the test.
refined (and hence more efficient) versions can be found in ITP 2011 paper
Nipkow (the theories are in the AFP entry Flyspeck by Nipkow)
the AFP article Executable Transitive Closures by René Thiemann.›
fixes p :: "'a → bool"
and f :: "'a → 'a list"
and x :: 'a
fun rtrancl_while_test :: "'a list × 'a set → bool"
"rtrancl_while_test (ws,_) = (ws ≠ [] ∧ p(hd ws))"
fun rtrancl_while_step :: "'a list × 'a set → 'a list × 'a set"
"rtrancl_while_step (ws, Z) =
(let x = hd ws; new = remdups (filter (λy. y ∉ Z) (f x))
in (new @ tl ws, set new ∪ Z))"
rtrancl_while :: "('a list * 'a set) option"
"rtrancl_while = while_option rtrancl_while_test rtrancl_while_step ([x],{x})"
fun rtrancl_while_invariant :: "'a list × 'a set → bool"
"rtrancl_while_invariant (ws, Z) =
(x ∈
Z ⊆ {(x,y). y ∈ set(f x)}* `` {x} ∧ (∀z∈Z - set ws. p z))"
lemma rtrancl_while_invariant:
assumes inv: "rtrancl_while_invariant st" and test: "rtrancl_while_test st"
shows
(cases st)
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)
rtrancl_while_Some:
assumes "rtrancl_while = Some(ws,Z)"
shows "if ws = []
then Z = {(x,y). y ∈ set(f x)}* `` {x} ∧ (∀z∈Z. p z)
else ¬ lfp: partial_function_definitions "(\le:_ :: complete_lattice →
-
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]])
show ?thesis
proof (cases "ws = []")
case True
thus ?thesis using I
by (auto simp del:Image_Collect_case_prod dest: Image_closed_trancl)
next
case False
thus ?thesis using I while_option_stop[OF assms[unfolded rtrancl_while_def]]
by (simp add: subset_iff)
qed
rtrancl_while_finite_Some:
assumes "finite ({(x, y). y ∈ set (f x)}* `` {x})" (is "finite ?Cl")
shows "∃y. rtrancl_while = Some y"
-
let ?R = "(λ(_, Z). card (?Cl - Z)) <*mlex
have "wf ?R" by (blast intro: wf_mlex)
then show ?thesis unfolding rt
proof (rule wf_rel_while_option_Some[of ?R rtrancl_while_invariant])
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)"
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
show ?thesis
proof (cases "remdups (filter (λy. y ∉ Z) (f h)) = []")
case False
then obtain z where "z ∈ set (remdups (filter (λl mcont2mcont_image [THEN lfpmcont2mcont, cont_intro, simp]:
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 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 show ?thesis unfolding mlex_prod_def by simp
qed
qed
qed (simp_all add: rtrancl_while_invariant)
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:
Die farbliche Syntaxdarstellung und die Messung sind noch experimentell.
