header {* Deciding Equivalence of $\Pi$-Extended Regular Expressions *}
theory Equivalence_Checking
imports Derivatives "~~/src/HOL/Library/While_Combinator"
"~~/src/HOL/Library/Product_Lexorder" "~~/src/HOL/Library/RBT_Set"
begin
hide_const RBT.map
subsection {* Bisimulation between languages and regular expressions *}
type_synonym 'a rexp_pair = "'a list list * ('a list rexp * 'a list rexp)"
type_synonym 'a rexp_pairs = "'a rexp_pair list"
context alphabet
begin
context
fixes n :: nat
begin
coinductive bisimilar :: "'a lang => 'a lang => bool" where
"K ⊆ lists (Σ n) ==> L ⊆ lists (Σ n)
==> ([] ∈ K <-> [] ∈ L)
==> (!!x. x ∈ Σ n ==> bisimilar (lQuot x K) (lQuot x L))
==> bisimilar K L"
lemma equal_if_bisimilar:
assumes "K ⊆ lists (Σ n)" "L ⊆ lists (Σ n)" "bisimilar K L" shows "K = L"
proof (rule set_eqI)
fix w
from assms show "w ∈ K <-> w ∈ L"
proof (induction w arbitrary: K L)
case Nil thus ?case by (auto elim: bisimilar.cases)
next
case (Cons a w K L)
show ?case
proof cases
assume "a ∈ Σ n"
with `bisimilar K L` have "bisimilar (lQuot a K) (lQuot a L)"
by (auto elim!: bisimilar.cases)
then have "w ∈ lQuot a K <-> w ∈ lQuot a L"
by (intro Cons.IH) (auto elim!: bisimilar.cases)
thus ?case by (auto simp: lQuot_def)
next
assume "a ∉ Σ n"
thus ?case using Cons.prems by fastforce
qed
qed
qed
lemma language_coinduct:
fixes R (infixl "∼" 50)
assumes "!!K L. K ∼ L ==> K ⊆ lists (Σ n) ∧ L ⊆ lists (Σ n)"
assumes "K ∼ L"
assumes "!!K L. K ∼ L ==> ([] ∈ K <-> [] ∈ L)"
assumes "!!K L x. K ∼ L ==> x : Σ n ==> lQuot x K ∼ lQuot x L"
shows "K = L"
apply (rule equal_if_bisimilar)
apply (rule conjunct1[OF assms(1)[OF assms(2)]])
apply (rule conjunct2[OF assms(1)[OF assms(2)]])
apply (rule bisimilar.coinduct[of R, OF `K ∼ L`])
apply (auto simp: assms)
done
end
end
context embed
begin
definition is_bisimulation where
"is_bisimulation n X =
(∀(r,s) ∈ X. wf n r ∧ wf n s ∧ (final r <-> final s) ∧
(∀a∈Σ n. («lderiv a r», «lderiv a s») ∈ X))"
lemma bisim_lang_eq:
fixes r s :: "'a rexp"
assumes bisim: "is_bisimulation n X"
assumes "(r, s) ∈ X"
shows "lang n r = lang n s"
proof -
let ?R = "λK L. (∃(r,s) ∈ X. K = lang n r ∧ L = lang n s)"
show ?thesis
proof (rule language_coinduct[where R="?R"])
from `(r, s) ∈ X` bisim show "?R (lang n r) (lang n s)"
by (auto split: prod.splits simp: is_bisimulation_def)
next
fix K L assume "?R K L"
then obtain r s where rs: "(r, s) ∈ X"
and KL: "K = lang n r" "L = lang n s" by auto
with bisim have "final r <-> final s" and wfr: "wf n r" and wfs: "wf n s"
by (auto simp: is_bisimulation_def)
thus "[] ∈ K <-> [] ∈ L"
by (auto simp: lang_final[of r n] lang_final[of s n] KL)
txt{* next case, but shared context *}
from bisim rs KL lang_subset_lists
show "K ⊆ lists (Σ n) ∧ L ⊆ lists (Σ n)"
unfolding is_bisimulation_def by fastforce
txt{* next case, but shared context *}
fix a assume *: "a ∈ Σ n"
with rs bisim have witness: "(«lderiv a r», «lderiv a s») ∈ X"
by (fastforce simp: is_bisimulation_def)
show "?R (lQuot a K) (lQuot a L)"
using KL ACI_norm_lang lang_lderiv[OF wfr *] lang_lderiv[OF wfs *]
by (blast intro!: bexI[OF _ witness])
qed
qed
lemma lderivs_lang_eq:
fixes r s :: "'a rexp"
assumes "wf n r" "wf n s"
shows "(∀(r, s) ∈ lderivs_set n «r» «s». final r = final s) = (lang n r = lang n s)" (is "?L = ?R")
proof
assume ?L
hence "∀(r, s) ∈ lderivs_set n «r» «s». wf n r ∧ wf n s ∧ (final r <-> final s)"
using assms by (auto simp add: ACI_norm_lderivs)
moreover
{ fix r' s' w assume "(r', s') ∈ lderivs_set n r s" and *: "w ∈ Σ n"
then obtain ws where ws: "wf_word n ws" "r' = «lderivs ws r»" "s' = «lderivs ws s»" by auto
with * have "(«lderiv w r'», «lderiv w s'») = («lderivs (ws @ [w]) r», «lderivs (ws @ [w]) s»)"
by (auto simp: ACI_norm_lderiv)
hence "(«lderiv w r'», «lderiv w s'») ∈ lderivs_set n r s"
using * ws(1) by (auto intro!: imageI exI[of _ "ws @ [w]"])
}
ultimately have "is_bisimulation n (lderivs_set n «r» «s»)"
unfolding is_bisimulation_def by (auto simp: ACI_norm_lderivs)
hence "lang n «r» = lang n «s»" by (intro bisim_lang_eq) (auto intro: exI[of _ "[]"])
thus ?R by (rule box_equals[OF _ ACI_norm_lang ACI_norm_lang])
next
assume ?R thus ?L using assms lang_lderivs lang_final by (auto simp: ACI_norm_lderivs) metis+
qed
end
subsection {* Different normalization function *}
locale normalizer = embed Σ project embed
for Σ :: "nat => 'a :: linorder set"
and project :: "'a => 'a"
and embed :: "'a => 'a list" +
fixes norm :: "'a :: linorder rexp => 'c"
and nlang :: "nat => 'c => 'a list set"
assumes lang_norm: "wf n r ==> nlang n (norm r) = lang n r"
begin
abbreviation "nfinal n r ≡ ([] ∈ nlang n r)"
lemma nfinal_final: "wf n r ==> nfinal n (norm r) = final r"
using lang_final lang_norm by blast
definition "norms ≡ (%(r,s). (norm r, norm s))"
lemma finite_norm: "finite {norm «lderivs xs r» | xs . True}"
by (rule finite_surj[OF finite_lderivs, of _ norm]) auto
lemma finite_norm_lderivs: "finite (norms ` (lderivs_set n r s))"
by (intro finite_subset[OF _ finite_cartesian_product[OF finite_norm finite_norm]]) (auto simp: norms_def)
definition is_nbisimulation where
"is_nbisimulation n X =
(∀(r,s) ∈ X. wf n r ∧ wf n s ∧ (final r <-> final s) ∧
(∀a∈Σ n. (norm «lderiv a r», norm «lderiv a s») ∈ norms ` X))"
lemma nbisim_lang_eq:
fixes r s :: "'a rexp"
assumes nbisim: "is_nbisimulation n X"
assumes "(r, s) ∈ X"
shows "lang n r = lang n s"
proof -
let ?R = "λK L. (∃(r,s) ∈ norms ` X. K = nlang n r ∧ L = nlang n s)"
show ?thesis
proof (rule language_coinduct[where R="?R"])
from `(r, s) ∈ X` nbisim show "?R (lang n r) (lang n s)"
by (auto split: prod.splits simp: lang_norm norms_def is_nbisimulation_def)
next
fix K L assume "?R K L"
then obtain r s where rs: "(r, s) ∈ X"
and KL: "K = nlang n (norm r)" "L = nlang n (norm s)" by (auto simp: norms_def)
with nbisim have "final r <-> final s" and wfr: "wf n r" and wfs: "wf n s"
by (auto simp: is_nbisimulation_def)
thus "[] ∈ K <-> [] ∈ L"
by (auto simp: lang_norm[OF wfr] lang_norm[OF wfs] lang_final[of r n] lang_final[of s n] KL)
txt{* next case, but shared context *}
from nbisim rs KL lang_subset_lists
show "K ⊆ lists (Σ n) ∧ L ⊆ lists (Σ n)"
unfolding is_nbisimulation_def lang_norm[OF wfr] lang_norm[OF wfs] by fastforce
txt{* next case, but shared context *}
fix a assume *: "a ∈ Σ n"
with rs nbisim have witness: "(norm «lderiv a r», norm «lderiv a s») ∈ norms ` X"
by (fastforce simp: is_nbisimulation_def)
show "?R (lQuot a K) (lQuot a L)"
using KL[unfolded lang_norm[OF wfr] lang_norm[OF wfs]]
trans[OF lang_norm[OF iffD2[OF ACI_norm_wf, OF wf_lderiv[OF wfr]]] ACI_norm_lang]
trans[OF lang_norm[OF iffD2[OF ACI_norm_wf, OF wf_lderiv[OF wfs]]] ACI_norm_lang]
lang_lderiv[OF wfr *] lang_lderiv[OF wfs *]
by (blast intro!: bexI[OF _ witness])
qed
qed
lemma norm_lderivs_lang_eq:
fixes r s :: "'a rexp"
assumes "wf n r" "wf n s"
shows "(∀(r, s) ∈ norms ` lderivs_set n «r» «s». nfinal n r = nfinal n s) = (lang n r = lang n s)"
by (rule trans[OF _ lderivs_lang_eq[OF assms]]) (fastforce simp: norms_def assms nfinal_final)
end
text {* Closure computation *}
primrec remdups' where
"remdups' f [] = []"
| "remdups' f (x # xs) =
(case List.find (λy. f x = f y) xs of None => x # remdups' f xs | _ => remdups' f xs)"
lemma map_remdups'[simp]: "map f (remdups' f xs) = remdups (map f xs)"
by (induct xs) (auto split: option.splits simp add: find_Some_iff find_None_iff)
lemma remdups'_map[simp]: "remdups' f (map g xs) = map g (remdups' (f o g) xs)"
by (induct xs) (auto split: option.splits simp add: find_None_iff,
auto simp: find_Some_iff elim: imageI[OF nth_mem])
lemma map_apfst_remdups':
"map (f o fst) (remdups' snd xs) = map fst (remdups' snd (map (apfst f) xs))"
by (auto simp: comp_def)
lemma set_remdups'[simp]: "f ` set (remdups' f xs) = f ` set xs"
by (induct xs) (auto split: option.splits simp add: find_Some_iff)
lemma subset_remdups': "set (remdups' f xs) ⊆ set xs"
by (induct xs) (auto split: option.splits)
lemma find_append[simp]:
"List.find P (xs @ ys) = None = (List.find P xs = None ∧ List.find P ys = None)"
by (induct xs) auto
lemma subset_remdups'_append: "set (remdups' f (xs @ ys)) ⊆ set (remdups' f xs) ∪ set (remdups' f ys)"
by (induct xs arbitrary: ys) (auto split: option.splits)
lemmas mp_remdups' = set_mp[OF subset_remdups']
lemmas mp_remdups'_append = set_mp[OF subset_remdups'_append]
lemma inj_on_set_remdups'[simp]: "inj_on f (set (remdups' f xs))"
by (induct xs) (auto split: option.splits simp add: find_None_iff dest!: mp_remdups')
lemma distinct_remdups'[simp]: "distinct (map f (remdups' f xs))"
by (induct xs) (auto split: option.splits simp: find_None_iff)
lemma distinct_remdups'_strong: "(∀x∈set xs. ∀y∈set xs. g x = g y --> f x = f y) ==>
distinct (map g (remdups' f xs))"
proof (induct xs)
case (Cons x xs) thus ?case
by (auto split: option.splits) (fastforce simp: find_None_iff dest!: mp_remdups')
qed simp
lemma set_remdups'_strong: "(∀x∈set xs. ∀y∈set xs. g x = g y --> f x = f y) ==>
f ` set (remdups' g xs) = f ` set xs"
proof (induct xs)
case (Cons x xs) thus ?case
by (clarsimp split: option.splits simp add: find_Some_iff)
(intro insert_absorb[symmetric] image_eqI[OF _ nth_mem, of _ f xs], auto)
qed simp
fun test where "test (ws, _, _) = (case ws of [] => False | (w,p,q)#_ => final p = final q)"
fun test' where "test' (ws, _) = (case ws of [] => False | (p,q)#_ => final p = final q)"
locale equivalence_checker =
fixes σ :: "nat => 'a :: linorder list"
and π :: "'a => 'a"
and ε :: "'a => 'a list"
and norm :: "'a rexp => 'c"
and nlang :: "nat => 'c => 'a list set"
assumes norm: "normalizer (set o σ) π ε norm nlang"
sublocale equivalence_checker ⊆ normalizer "set o σ" π ε
by (rule norm)
context equivalence_checker
begin
fun step where "step n (ws, ps, N) =
(let
(w, r, s) = hd ws;
ps' = (r, s) # ps;
succs = map (λa.
let
r' = «lderiv a r»;
s' = «lderiv a s»
in ((a # w, r', s'), (norm r', norm s'))) (σ n);
new = remdups' snd (filter (λ(_, rs). rs ∉ N) succs);
ws' = tl ws @ map fst new;
N' = set (map snd new) ∪ N
in (ws', ps', N'))"
fun step' where "step' n (ws, N) =
(let
(r, s) = hd ws;
succs = map (λa.
let
r' = «lderiv a r»;
s' = «lderiv a s»
in ((r', s'), (norm r', norm s'))) (σ n);
new = remdups' snd (filter (λ(_, rs). rs ∉ N) succs)
in (tl ws @ map fst new, set (map snd new) ∪ N))"
lemma step_unfold: "step n (w # ws, ps, N) = (ws', ps', N') ==> (∃xs r s.
w = (xs, r, s) ∧ ps' = (r, s) # ps ∧
ws' = ws @ remdups' (norms o snd) (filter (λ(_, p). norms p ∉ N)
(map (λa. (a#xs, «lderiv a r», «lderiv a s»)) (σ n))) ∧
N' = set (map (λa. (norm «lderiv a r», norm «lderiv a s»)) (σ n)) ∪ N)"
by (auto split: prod.splits dest!: mp_remdups'
simp: Let_def norms_def filter_map set_n_lists image_Collect image_image comp_def)
definition closure where "closure n = while_option test (step n)"
definition closure' where "closure' n = while_option test' (step' n)"
definition pre_bisim where
"pre_bisim n r s = (λ(ws, ps, N).
(«r», «s») ∈ snd ` set ws ∪ set ps ∧
distinct (map snd ws @ ps) ∧
bij_betw norms (set (map snd ws @ ps)) N ∧
(∀(w, r', s') ∈ set ws. «lderivs (rev w) r» = r' ∧ «lderivs (rev w) s» = s' ∧
wf_word n (rev w) ∧ wf n r' ∧ wf n s') ∧
(∀(r', s') ∈ set ps. (∃w. «lderivs w r» = r' ∧ «lderivs w s» = s') ∧
wf n r' ∧ wf n s' ∧ (final r' <-> final s') ∧
(∀a∈set (σ n). (norm «lderiv a r'», norm «lderiv a s'») ∈ N)))"
lemma pre_bisim_start:
"[|wf n r; wf n s|] ==> pre_bisim n r s ([([], «r», «s»)], [], {(norm «r», norm «s»)})"
by (auto simp add: pre_bisim_def bij_betw_def norms_def)
lemma step_mono:
assumes "step n (ws, ps, N) = (ws', ps', N')"
shows "snd ` set ws ∪ set ps ⊆ snd ` set ws' ∪ set ps'"
using assms proof (intro subsetI, elim UnE)
fix x assume "x ∈ snd `set ws"
with assms show "x ∈ snd ` set ws' ∪ set ps'"
proof (cases "x = snd (hd ws)")
case False with `x ∈ image snd (set ws)` have "x ∈ snd ` set (tl ws)" by (cases ws) auto
with assms show ?thesis by (auto split: prod.splits simp: Let_def)
qed (auto split: prod.splits simp: Let_def)
qed (auto split: prod.splits simp: Let_def)
lemma pre_bisim_step: "pre_bisim n r s st ==> test st ==> pre_bisim n r s (step n st)"
proof (unfold pre_bisim_def, (split prod.splits)+, elim prod_caseE conjE, clarify, intro allI impI conjI)
fix ws ps N ws' ps' N'
assume test: "test (ws, ps, N)"
and step: "step n (ws, ps, N) = (ws', ps', N')"
and rs: "(«r», «s») ∈ snd ` set ws ∪ set ps"
and distinct: "distinct (map snd ws @ ps)"
and bij: "bij_betw norms (set (map snd ws @ ps)) N"
and ws: "∀(w, r', s') ∈ set ws. «lderivs (rev w) r» = r' ∧ «lderivs (rev w) s» = s' ∧
wf_word n (rev w) ∧ wf n r' ∧ wf n s'"
(is "∀(w, r', s') ∈ set ws. ?ws w r' s'")
and ps: "∀(r', s') ∈ set ps. (∃w. «lderivs w r» = r' ∧ «lderivs w s» = s') ∧
wf n r' ∧ wf n s' ∧ (final r' <-> final s') ∧
(∀a∈set (σ n). (norm «lderiv a r'», norm «lderiv a s'») ∈ N)"
(is "∀(r, s) ∈ set ps. ?ps r s N")
from test obtain x xs where ws_Cons: "ws = x#xs" by (cases ws) auto
obtain w r' s' where x: "x = (w, r', s')" and ps': "ps' = (r', s') # ps"
and ws': "ws' = xs @ remdups' (norms o snd) (filter (λ(_, p). norms p ∉ N)
(map (λa. (a # w, «lderiv a r'», «lderiv a s'»)) (σ n)))"
and N': "N' = (set (map (λa. (norm «lderiv a r'», norm «lderiv a s'»)) (σ n)) - N) ∪ N"
using step_unfold[OF step[unfolded ws_Cons]] by blast
hence ws'ps': "set (map snd ws' @ ps') = set (remdups' norms (filter (λp. norms p ∉ N)
(map (λa. («lderiv a r'», «lderiv a s'»)) (σ n)))) ∪ (set (map snd ws @ ps))"
unfolding ws' ps' ws_Cons x by (auto dest!: mp_remdups' simp: filter_map image_image image_Un o_def)
from rs step show "(«r», «s») ∈ snd ` set ws' ∪ set ps'" by (blast dest: step_mono)
from distinct ps' ws' ws_Cons x bij show "distinct (map snd ws' @ ps')"
by (auto simp: bij_betw_def
intro!: imageI[of _ _ norms] distinct_remdups'_strong
dest!: mp_remdups'
elim: image_eqI[of _ snd, OF sym[OF snd_conv]])
from ps' ws' N' ws x bij show "bij_betw norms (set (map snd ws' @ ps')) N'"
unfolding ws'ps' N' by (intro bij_betw_combine[OF _ bij]) (auto simp: bij_betw_def norms_def)
from ws x ws_Cons have wr's': "?ws w r' s'" by auto
with ws ws_Cons show "∀(w, r', s') ∈ set ws'. ?ws w r' s'" unfolding ws'
by (auto dest!: mp_remdups' simp: ACI_norm_lderiv elim!: set_mp)
from ps wr's' test[unfolded ws_Cons x] show "∀(r', s') ∈ set ps'. ?ps r' s' N'" unfolding ps' N'
by (fastforce simp: image_Collect)
qed
lemma step_commute: "ws ≠ [] ==> (case step n (ws, ps, N) of (ws', ps', N') => (map snd ws', N')) = step' n (map snd ws, N)"
apply (auto split: prod.splits)
apply (auto simp only: step.simps step'.simps Let_def map_apfst_remdups' filter_map List.map.compositionality[unfolded comp_def] apfst_def map_pair_def snd_conv id_def)
apply (auto simp: filter_map comp_def map_tl hd_map)
apply (intro image_eqI, auto)+
done
lemma closure_closure':
"Option.map (λ(ws, ps, N). (map snd ws, N)) (closure n (ws, ps, N)) =
closure' n (map snd ws, N)"
unfolding closure_def closure'_def
by (rule trans[OF while_option_commute[of _ test' _ _ "step' n"]])
(auto split: list.splits simp del: step.simps step'.simps List.map.simps simp: step_commute)
theorem closure_sound:
assumes result: "closure n ([([], «r», «s»)], [], {(norm «r», norm «s»)}) = Some([], ps, N)"
and wf: "wf n r" "wf n s"
shows "lang n r = lang n s"
proof -
from pre_bisim_step pre_bisim_start[OF wf] have pre_bisim_ps: "pre_bisim n r s ([], ps, N)"
by (rule while_option_rule[OF _ result[unfolded closure_def]])
then have "is_nbisimulation n (set ps)" "(«r», «s») ∈ set ps"
by (auto simp: bij_betw_def pre_bisim_def is_nbisimulation_def in_lists_conv_set norms_def)
hence "lang n «r» = lang n «s»"
by (intro nbisim_lang_eq image_eqI) auto
thus "lang n r = lang n s" unfolding ACI_norm_lang .
qed
theorem closure'_sound:
assumes result: "closure' n ([(«r», «s»)], {(norm «r», norm «s»)}) = Some([], N)"
and wf: "wf n r" "wf n s"
shows "lang n r = lang n s"
using wf trans[OF closure_closure'[of n "[([], «r», «s»)]" "[]" "{(norm «r», norm «s»)}", simplified]
result, unfolded option_map_eq_Some]
by (auto dest: closure_sound)
theorem closure_termination:
assumes wf: "wf n r" "wf n s"
and cl: "closure n ([([], «r», «s»)], [], {(norm «r», norm «s»)}) = None" (is "?cl = None")
shows "False"
proof -
let ?D = "{norm «lderivs xs r» | xs . True} × {norm «lderivs xs s» | xs . True}"
let ?X = "λps. ?D - norms ` set ps"
let ?f = "λ(ws, ps, N). card (?X ps)"
have "∃st. ?cl = Some st" unfolding closure_def
proof (rule measure_while_option_Some[of "pre_bisim n r s" _ _ ?f], intro conjI)
fix st assume pre_bisim: "pre_bisim n r s st" and "test st"
hence pre_bisim_step: "pre_bisim n r s (step n st)" by (rule pre_bisim_step)
obtain ws ps N where st: "st = (ws, ps, N)" by (cases st) blast
hence "finite (?X ps)" by (blast intro: finite_cartesian_product finite_norm)
moreover obtain ws' ps' N' where step: "step n (ws, ps, N) = (ws', ps', N')"
by (cases "step n (ws, ps, N)") blast
moreover
{ have "norms ` set ps ⊆ ?D" using pre_bisim[unfolded st pre_bisim_def]
by (auto simp: norms_def ACI_norm_lderivs)
moreover
have "norms ` set ps' ⊆ ?D" using pre_bisim_step[unfolded st step pre_bisim_def]
by (auto simp: norms_def ACI_norm_lderivs)
moreover
{ have "distinct (map snd ws @ ps)" "inj_on norms (set (map snd ws @ ps))"
using pre_bisim[unfolded st pre_bisim_def] by (auto simp: bij_betw_def)
hence "distinct (map norms (map snd ws @ ps))" unfolding distinct_map ..
hence "norms ` set ps ⊂ norms ` set (snd (hd ws) # ps)" using `test st` st
by (cases ws) auto
moreover have "norms ` set ps' = norms ` set (snd (hd ws) # ps)"
using step by (auto split: prod.splits)
ultimately have "norms ` set ps ⊂ norms ` set ps'" by simp
}
ultimately have "?X ps' ⊂ ?X ps" by (auto simp add: image_set simp del: set_map)
}
ultimately show "?f (step n st) < ?f st" unfolding st step
using psubset_card_mono[of "?X ps" "?X ps'"] by simp
qed (auto simp add: pre_bisim_start[OF wf] pre_bisim_step)
thus False using cl by auto
qed
theorem closure'_termination:
assumes wf: "wf n r" "wf n s"
and cl: "closure' n ([(«r», «s»)], {(norm «r», norm «s»)}) = None"
shows "False"
using wf trans[OF closure_closure'[of n "[([], «r», «s»)]" "[]" "{(norm «r», norm «s»)}", simplified]
cl, unfolded option_map_is_None]
by (auto intro: closure_termination)
theorem closure_complete:
assumes eq: "lang n r = lang n s"
and wf: "wf n r" "wf n s"
shows "∃ps N. closure n ([([], «r», «s»)], [], {(norm «r», norm «s»)}) = Some([], ps, N)"
(is "∃_ _. ?cl = _")
proof (cases ?cl)
case (Some st)
moreover obtain ws ps N where ws_ps_N: "st = (ws, ps, N)" by (cases st) blast
ultimately show ?thesis
proof (cases ws)
case (Cons wrs ws)
then obtain w r' s' where wrs: "wrs = (w, r', s')" by (cases wrs) blast
with ws_ps_N Cons have "final r' ≠ final s'"
using while_option_stop2[OF Some[unfolded closure_def]] by simp
moreover
from pre_bisim_step pre_bisim_start[OF wf] have pre_bisim_ps: "pre_bisim n r s st"
by (rule while_option_rule[OF _ Some[unfolded closure_def]])
hence "«lderivs (rev w) r» = r'" "«lderivs (rev w) s» = s'" "wf_word n (rev w)"
unfolding ws_ps_N Cons wrs pre_bisim_def ACI_norm_lderivs by auto
ultimately show ?thesis using eq wf lderivs_final by auto
qed blast
qed (auto intro: closure_termination[OF wf])
theorem closure'_complete:
assumes eq: "lang n r = lang n s"
and wf: "wf n r" "wf n s"
shows "∃N. closure' n ([(«r», «s»)], {(norm «r», norm «s»)}) = Some([], N)"
using assms closure_closure'[of n "[([], «r», «s»)]" "[]" "{(norm «r», norm «s»)}", symmetric]
by (auto dest!: closure_complete)
text {* The overall procedure *}
definition check_eqv where
"check_eqv n r s <-> wf n r ∧ wf n s ∧
(let r' = «r»; s' = «s» in (case closure n ([([], r', s')], [], {(norm r', norm s')}) of
Some([],_) => True | _ => False))"
definition check_eqv_counterexample where
"check_eqv_counterexample n r s =
(let r' = «r»; s' = «s» in (case closure n ([([], r', s')], [], {(norm r', norm s')}) of
Some([],_) => None | Some((w,_,_) # _, _) => Some w))"
definition check_eqv' where
"check_eqv' n r s <-> wf n r ∧ wf n s ∧
(let r' = «r»; s' = «s» in (case closure' n ([(r', s')], {(norm r', norm s')}) of
Some([],_) => True | _ => False))"
lemma check_eqv_check_eqv': "check_eqv n r s = check_eqv' n r s"
unfolding check_eqv_def check_eqv'_def Let_def
using closure_closure'[of n "[([], «r», «s»)]" "[]" "{(norm «r», norm «s»)}", symmetric]
by (auto split: option.splits list.splits)
lemma soundness:
assumes "check_eqv n r s"
shows "lang n r = lang n s"
using closure_sound assms by (auto simp: check_eqv_def Let_def split: option.splits list.splits)
lemma soundness':
assumes "check_eqv' n r s"
shows "lang n r = lang n s"
using soundness check_eqv_check_eqv' assms by auto
lemma completeness:
assumes "lang n r = lang n s" "wf n r" "wf n s"
shows "check_eqv n r s"
using closure_complete[OF assms] assms(2,3) by (auto simp: check_eqv_def)
lemma completeness':
assumes "lang n r = lang n s" "wf n r" "wf n s"
shows "check_eqv' n r s"
using completeness check_eqv_check_eqv' assms by auto
end
end